lib/perl5/5.8.8/Switch.pm

   1 package Switch;
   2
   3 use strict;
   4 use vars qw($VERSION);
   5 use Carp;
   6
   7 $VERSION = '2.10_01';
   8
   9
  10 # LOAD FILTERING MODULE...
  11 use Filter::Util::Call;
  12
  13 sub __();
  14
  15 # CATCH ATTEMPTS TO CALL case OUTSIDE THE SCOPE OF ANY switch
  16
  17 $::_S_W_I_T_C_H = sub { croak "case/when statement not in switch/given block" };
  18
  19 my $offset;
  20 my $fallthrough;
  21 my ($Perl5, $Perl6) = (0,0);
  22
  23 sub import
  24 {
  25         $fallthrough = grep /\bfallthrough\b/, @_;
  26         $offset = (caller)[2]+1;
  27         filter_add({}) unless @_>1 && $_[1] eq 'noimport';
  28         my $pkg = caller;
  29         no strict 'refs';
  30         for ( qw( on_defined on_exists ) )
  31         {
  32                 *{"${pkg}::$_"} = \&$_;
  33         }
  34         *{"${pkg}::__"} = \&__ if grep /__/, @_;
  35         $Perl6 = 1 if grep(/Perl\s*6/i, @_);
  36         $Perl5 = 1 if grep(/Perl\s*5/i, @_) || !grep(/Perl\s*6/i, @_);
  37         1;
  38 }
  39
  40 sub unimport
  41 {
  42         filter_del()
  43 }
  44
  45 sub filter
  46 {
  47         my($self) = @_ ;
  48         local $Switch::file = (caller)[1];
  49
  50         my $status = 1;
  51         $status = filter_read(1_000_000);
  52         return $status if $status<0;
  53         $_ = filter_blocks($_,$offset);
  54         $_ = "# line $offset\n" . $_ if $offset; undef $offset;
  55         return $status;
  56 }
  57
  58 use Text::Balanced ':ALL';
  59
  60 sub line
  61 {
  62         my ($pretext,$offset) = @_;
  63         ($pretext=~tr/\n/\n/)+($offset||0);
  64 }
  65
  66 sub is_block
  67 {
  68         local $SIG{__WARN__}=sub{die$@};
  69         local $^W=1;
  70         my $ishash = defined  eval 'my $hr='.$_[0];
  71         undef $@;
  72         return !$ishash;
  73 }
  74
  75
  76 my $EOP = qr/\n\n|\Z/;
  77 my $CUT = qr/\n=cut.*$EOP/;
  78 my $pod_or_DATA = qr/ ^=(?:head[1-4]|item) .*? $CUT
  79                     | ^=pod .*? $CUT
  80                     | ^=for .*? $EOP
  81                     | ^=begin \s* (\S+) .*? \n=end \s* \1 .*? $EOP
  82                     | ^__(DATA|END)__\n.*
  83                     /smx;
  84
  85 my $casecounter = 1;
  86 sub filter_blocks
  87 {
  88         my ($source, $line) = @_;
  89         return $source unless $Perl5 && $source =~ /case|switch/
  90                            || $Perl6 && $source =~ /when|given|default/;
  91         pos $source = 0;
  92         my $text = "";
  93         component: while (pos $source < length $source)
  94         {
  95                 if ($source =~ m/(\G\s*use\s+Switch\b)/gc)
  96                 {
  97                         $text .= q{use Switch 'noimport'};
  98                         next component;
  99                 }
 100                 my @pos = Text::Balanced::_match_quotelike(\$source,qr/\s*/,1,0);
 101                 if (defined $pos[0])
 102                 {
 103                         my $pre = substr($source,$pos[0],$pos[1]); # matched prefix
 104                         $text .= $pre . substr($source,$pos[2],$pos[18]-$pos[2]);
 105                         next component;
 106                 }
 107                 if ($source =~ m/\G\s*($pod_or_DATA)/gc) {
 108                         next component;
 109                 }
 110                 @pos = Text::Balanced::_match_variable(\$source,qr/\s*/);
 111                 if (defined $pos[0])
 112                 {
 113                         $text .= " " if $pos[0] < $pos[2];
 114                         $text .= substr($source,$pos[0],$pos[4]-$pos[0]);
 115                         next component;
 116                 }
 117
 118                 if ($Perl5 && $source =~ m/\G(\n*)(\s*)(switch)\b(?=\s*[(])/gc
 119                  || $Perl6 && $source =~ m/\G(\n*)(\s*)(given)\b(?=\s*[(])/gc
 120                  || $Perl6 && $source =~ m/\G(\n*)(\s*)(given)\b(.*)(?=\{)/gc)
 121                 {
 122                         my $keyword = $3;
 123                         my $arg = $4;
 124                         $text .= $1.$2.'S_W_I_T_C_H: while (1) ';
 125                         unless ($arg) {
 126                                 @pos = Text::Balanced::_match_codeblock(\$source,qr/\s*/,qr/\(/,qr/\)/,qr/[[{(<]/,qr/[]})>]/,undef)
 127                                 or do {
 128                                         die "Bad $keyword statement (problem in the parentheses?) near $Switch::file line ", line(substr($source,0,pos $source),$line), "\n";
 129                                 };
 130                                 $arg = filter_blocks(substr($source,$pos[0],$pos[4]-$pos[0]),line(substr($source,0,$pos[0]),$line));
 131                         }
 132                         $arg =~ s {^\s*[(]\s*%}   { ( \\\%}     ||
 133                         $arg =~ s {^\s*[(]\s*m\b} { ( qr}       ||
 134                         $arg =~ s {^\s*[(]\s*/}   { ( qr/}      ||
 135                         $arg =~ s {^\s*[(]\s*qw}  { ( \\qw};
 136                         @pos = Text::Balanced::_match_codeblock(\$source,qr/\s*/,qr/\{/,qr/\}/,qr/\{/,qr/\}/,undef)
 137                         or do {
 138                                 die "Bad $keyword statement (problem in the code block?) near $Switch::file line ", line(substr($source,0, pos $source), $line), "\n";
 139                         };
 140                         my $code = filter_blocks(substr($source,$pos[0],$pos[4]-$pos[0]),line(substr($source,0,$pos[0]),$line));
 141                         $code =~ s/{/{ local \$::_S_W_I_T_C_H; Switch::switch $arg;/;
 142                         $text .= $code . 'continue {last}';
 143                         next component;
 144                 }
 145                 elsif ($Perl5 && $source =~ m/\G(\s*)(case\b)(?!\s*=>)/gc
 146                     || $Perl6 && $source =~ m/\G(\s*)(when\b)(?!\s*=>)/gc
 147                     || $Perl6 && $source =~ m/\G(\s*)(default\b)(?=\s*\{)/gc)
 148                 {
 149                         my $keyword = $2;
 150                         $text .= $1 . ($keyword eq "default"
 151                                         ? "if (1)"
 152                                         : "if (Switch::case");
 153
 154                         if ($keyword eq "default") {
 155                                 # Nothing to do
 156                         }
 157                         elsif (@pos = Text::Balanced::_match_codeblock(\$source,qr/\s*/,qr/\{/,qr/\}/,qr/\{/,qr/\}/,undef)) {
 158                                 my $code = substr($source,$pos[0],$pos[4]-$pos[0]);
 159                                 $text .= " " if $pos[0] < $pos[2];
 160                                 $text .= "sub " if is_block $code;
 161                                 $text .= filter_blocks($code,line(substr($source,0,$pos[0]),$line)) . ")";
 162                         }
 163                         elsif (@pos = Text::Balanced::_match_codeblock(\$source,qr/\s*/,qr/[[(]/,qr/[])]/,qr/[[({]/,qr/[])}]/,undef)) {
 164                                 my $code = filter_blocks(substr($source,$pos[0],$pos[4]-$pos[0]),line(substr($source,0,$pos[0]),$line));
 165                                 $code =~ s {^\s*[(]\s*%}   { ( \\\%}    ||
 166                                 $code =~ s {^\s*[(]\s*m\b} { ( qr}      ||
 167                                 $code =~ s {^\s*[(]\s*/}   { ( qr/}     ||
 168                                 $code =~ s {^\s*[(]\s*qw}  { ( \\qw};
 169                                 $text .= " " if $pos[0] < $pos[2];
 170                                 $text .= "$code)";
 171                         }
 172                         elsif ($Perl6 && do{@pos = Text::Balanced::_match_variable(\$source,qr/\s*/)}) {
 173                                 my $code = filter_blocks(substr($source,$pos[0],$pos[4]-$pos[0]),line(substr($source,0,$pos[0]),$line));
 174                                 $code =~ s {^\s*%}  { \%}       ||
 175                                 $code =~ s {^\s*@}  { \@};
 176                                 $text .= " " if $pos[0] < $pos[2];
 177                                 $text .= "$code)";
 178                         }
 179                         elsif ( @pos = Text::Balanced::_match_quotelike(\$source,qr/\s*/,1,0)) {
 180                                 my $code = substr($source,$pos[2],$pos[18]-$pos[2]);
 181                                 $code = filter_blocks($code,line(substr($source,0,$pos[2]),$line));
 182                                 $code =~ s {^\s*m}  { qr}       ||
 183                                 $code =~ s {^\s*/}  { qr/}      ||
 184                                 $code =~ s {^\s*qw} { \\qw};
 185                                 $text .= " " if $pos[0] < $pos[2];
 186                                 $text .= "$code)";
 187                         }
 188                         elsif ($Perl5 && $source =~ m/\G\s*(([^\$\@{])[^\$\@{]*)(?=\s*{)/gc
 189                            ||  $Perl6 && $source =~ m/\G\s*([^;{]*)()/gc) {
 190                                 my $code = filter_blocks($1,line(substr($source,0,pos $source),$line));
 191                                 $text .= ' \\' if $2 eq '%';
 192                                 $text .= " $code)";
 193                         }
 194                         else {
 195                                 die "Bad $keyword statement (invalid $keyword value?) near $Switch::file line ", line(substr($source,0,pos $source), $line), "\n";
 196                         }
 197
 198                         die "Missing opening brace or semi-colon after 'when' value near $Switch::file line ", line(substr($source,0,pos $source), $line), "\n"
 199                                 unless !$Perl6 || $source =~ m/\G(\s*)(?=;|\{)/gc;
 200
 201                         do{@pos = Text::Balanced::_match_codeblock(\$source,qr/\s*/,qr/\{/,qr/\}/,qr/\{/,qr/\}/,undef)}
 202                         or do {
 203                                 if ($source =~ m/\G\s*(?=([};]|\Z))/gc) {
 204                                         $casecounter++;
 205                                         next component;
 206                                 }
 207                                 die "Bad $keyword statement (problem in the code block?) near $Switch::file line ", line(substr($source,0,pos $source),$line), "\n";
 208                         };
 209                         my $code = filter_blocks(substr($source,$pos[0],$pos[4]-$pos[0]),line(substr($source,0,$pos[0]),$line));
 210                         $code =~ s/}(?=\s*\Z)/;last S_W_I_T_C_H }/
 211                                 unless $fallthrough;
 212                         $text .= "{ while (1) $code continue { goto C_A_S_E_$casecounter } last S_W_I_T_C_H; C_A_S_E_$casecounter: }";
 213                         $casecounter++;
 214                         next component;
 215                 }
 216
 217                 $source =~ m/\G(\s*(-[sm]\s+|\w+|#.*\n|\W))/gc;
 218                 $text .= $1;
 219         }
 220         $text;
 221 }
 222
 223
 224
 225 sub in
 226 {
 227         my ($x,$y) = @_;
 228         my @numy;
 229         for my $nextx ( @$x )
 230         {
 231                 my $numx = ref($nextx) || defined $nextx && (~$nextx&$nextx) eq 0;
 232                 for my $j ( 0..$#$y )
 233                 {
 234                         my $nexty = $y->[$j];
 235                         push @numy, ref($nexty) || defined $nexty && (~$nexty&$nexty) eq 0
 236                                 if @numy <= $j;
 237                         return 1 if $numx && $numy[$j] && $nextx==$nexty
 238                                  || $nextx eq $nexty;
 239
 240                 }
 241         }
 242         return "";
 243 }
 244
 245 sub on_exists
 246 {
 247         my $ref = @_==1 && ref($_[0]) eq 'HASH' ? $_[0] : { @_ };
 248         [ keys %$ref ]
 249 }
 250
 251 sub on_defined
 252 {
 253         my $ref = @_==1 && ref($_[0]) eq 'HASH' ? $_[0] : { @_ };
 254         [ grep { defined $ref->{$_} } keys %$ref ]
 255 }
 256
 257 sub switch(;$)
 258 {
 259         my ($s_val) = @_ ? $_[0] : $_;
 260         my $s_ref = ref $s_val;
 261
 262         if ($s_ref eq 'CODE')
 263         {
 264                 $::_S_W_I_T_C_H =
 265                       sub { my $c_val = $_[0];
 266                             return $s_val == $c_val  if ref $c_val eq 'CODE';
 267                             return $s_val->(@$c_val) if ref $c_val eq 'ARRAY';
 268                             return $s_val->($c_val);
 269                           };
 270         }
 271         elsif ($s_ref eq "" && defined $s_val && (~$s_val&$s_val) eq 0) # NUMERIC SCALAR
 272         {
 273                 $::_S_W_I_T_C_H =
 274                       sub { my $c_val = $_[0];
 275                             my $c_ref = ref $c_val;
 276                             return $s_val == $c_val     if $c_ref eq ""
 277                                                         && defined $c_val
 278                                                         && (~$c_val&$c_val) eq 0;
 279                             return $s_val eq $c_val     if $c_ref eq "";
 280                             return in([$s_val],$c_val)  if $c_ref eq 'ARRAY';
 281                             return $c_val->($s_val)     if $c_ref eq 'CODE';
 282                             return $c_val->call($s_val) if $c_ref eq 'Switch';
 283                             return scalar $s_val=~/$c_val/
 284                                                         if $c_ref eq 'Regexp';
 285                             return scalar $c_val->{$s_val}
 286                                                         if $c_ref eq 'HASH';
 287                             return;
 288                           };
 289         }
 290         elsif ($s_ref eq "")                            # STRING SCALAR
 291         {
 292                 $::_S_W_I_T_C_H =
 293                       sub { my $c_val = $_[0];
 294                             my $c_ref = ref $c_val;
 295                             return $s_val eq $c_val     if $c_ref eq "";
 296                             return in([$s_val],$c_val)  if $c_ref eq 'ARRAY';
 297                             return $c_val->($s_val)     if $c_ref eq 'CODE';
 298                             return $c_val->call($s_val) if $c_ref eq 'Switch';
 299                             return scalar $s_val=~/$c_val/
 300                                                         if $c_ref eq 'Regexp';
 301                             return scalar $c_val->{$s_val}
 302                                                         if $c_ref eq 'HASH';
 303                             return;
 304                           };
 305         }
 306         elsif ($s_ref eq 'ARRAY')
 307         {
 308                 $::_S_W_I_T_C_H =
 309                       sub { my $c_val = $_[0];
 310                             my $c_ref = ref $c_val;
 311                             return in($s_val,[$c_val])  if $c_ref eq "";
 312                             return in($s_val,$c_val)    if $c_ref eq 'ARRAY';
 313                             return $c_val->(@$s_val)    if $c_ref eq 'CODE';
 314                             return $c_val->call(@$s_val)
 315                                                         if $c_ref eq 'Switch';
 316                             return scalar grep {$_=~/$c_val/} @$s_val
 317                                                         if $c_ref eq 'Regexp';
 318                             return scalar grep {$c_val->{$_}} @$s_val
 319                                                         if $c_ref eq 'HASH';
 320                             return;
 321                           };
 322         }
 323         elsif ($s_ref eq 'Regexp')
 324         {
 325                 $::_S_W_I_T_C_H =
 326                       sub { my $c_val = $_[0];
 327                             my $c_ref = ref $c_val;
 328                             return $c_val=~/s_val/      if $c_ref eq "";
 329                             return scalar grep {$_=~/s_val/} @$c_val
 330                                                         if $c_ref eq 'ARRAY';
 331                             return $c_val->($s_val)     if $c_ref eq 'CODE';
 332                             return $c_val->call($s_val) if $c_ref eq 'Switch';
 333                             return $s_val eq $c_val     if $c_ref eq 'Regexp';
 334                             return grep {$_=~/$s_val/ && $c_val->{$_}} keys %$c_val
 335                                                         if $c_ref eq 'HASH';
 336                             return;
 337                           };
 338         }
 339         elsif ($s_ref eq 'HASH')
 340         {
 341                 $::_S_W_I_T_C_H =
 342                       sub { my $c_val = $_[0];
 343                             my $c_ref = ref $c_val;
 344                             return $s_val->{$c_val}     if $c_ref eq "";
 345                             return scalar grep {$s_val->{$_}} @$c_val
 346                                                         if $c_ref eq 'ARRAY';
 347                             return $c_val->($s_val)     if $c_ref eq 'CODE';
 348                             return $c_val->call($s_val) if $c_ref eq 'Switch';
 349                             return grep {$_=~/$c_val/ && $s_val->{"$_"}} keys %$s_val
 350                                                         if $c_ref eq 'Regexp';
 351                             return $s_val==$c_val       if $c_ref eq 'HASH';
 352                             return;
 353                           };
 354         }
 355         elsif ($s_ref eq 'Switch')
 356         {
 357                 $::_S_W_I_T_C_H =
 358                       sub { my $c_val = $_[0];
 359                             return $s_val == $c_val  if ref $c_val eq 'Switch';
 360                             return $s_val->call(@$c_val)
 361                                                      if ref $c_val eq 'ARRAY';
 362                             return $s_val->call($c_val);
 363                           };
 364         }
 365         else
 366         {
 367                 croak "Cannot switch on $s_ref";
 368         }
 369         return 1;
 370 }
 371
 372 sub case($) { local $SIG{__WARN__} = \&carp;
 373               $::_S_W_I_T_C_H->(@_); }
 374
 375 # IMPLEMENT __
 376
 377 my $placeholder = bless { arity=>1, impl=>sub{$_[1+$_[0]]} };
 378
 379 sub __() { $placeholder }
 380
 381 sub __arg($)
 382 {
 383         my $index = $_[0]+1;
 384         bless { arity=>0, impl=>sub{$_[$index]} };
 385 }
 386
 387 sub hosub(&@)
 388 {
 389         # WRITE THIS
 390 }
 391
 392 sub call
 393 {
 394         my ($self,@args) = @_;
 395         return $self->{impl}->(0,@args);
 396 }
 397
 398 sub meta_bop(&)
 399 {
 400         my ($op) = @_;
 401         sub
 402         {
 403                 my ($left, $right, $reversed) = @_;
 404                 ($right,$left) = @_ if $reversed;
 405
 406                 my $rop = ref $right eq 'Switch'
 407                         ? $right
 408                         : bless { arity=>0, impl=>sub{$right} };
 409
 410                 my $lop = ref $left eq 'Switch'
 411                         ? $left
 412                         : bless { arity=>0, impl=>sub{$left} };
 413
 414                 my $arity = $lop->{arity} + $rop->{arity};
 415
 416                 return bless {
 417                                 arity => $arity,
 418                                 impl  => sub { my $start = shift;
 419                                                return $op->($lop->{impl}->($start,@_),
 420                                                             $rop->{impl}->($start+$lop->{arity},@_));
 421                                              }
 422                              };
 423         };
 424 }
 425
 426 sub meta_uop(&)
 427 {
 428         my ($op) = @_;
 429         sub
 430         {
 431                 my ($left) = @_;
 432
 433                 my $lop = ref $left eq 'Switch'
 434                         ? $left
 435                         : bless { arity=>0, impl=>sub{$left} };
 436
 437                 my $arity = $lop->{arity};
 438
 439                 return bless {
 440                                 arity => $arity,
 441                                 impl  => sub { $op->($lop->{impl}->(@_)) }
 442                              };
 443         };
 444 }
 445
 446
 447 use overload
 448         "+"     =>      meta_bop {$_[0] + $_[1]},
 449         "-"     =>      meta_bop {$_[0] - $_[1]},
 450         "*"     =>      meta_bop {$_[0] * $_[1]},
 451         "/"     =>      meta_bop {$_[0] / $_[1]},
 452         "%"     =>      meta_bop {$_[0] % $_[1]},
 453         "**"    =>      meta_bop {$_[0] ** $_[1]},
 454         "<<"    =>      meta_bop {$_[0] << $_[1]},
 455         ">>"    =>      meta_bop {$_[0] >> $_[1]},
 456         "x"     =>      meta_bop {$_[0] x $_[1]},
 457         "."     =>      meta_bop {$_[0] . $_[1]},
 458         "<"     =>      meta_bop {$_[0] < $_[1]},
 459         "<="    =>      meta_bop {$_[0] <= $_[1]},
 460         ">"     =>      meta_bop {$_[0] > $_[1]},
 461         ">="    =>      meta_bop {$_[0] >= $_[1]},
 462         "=="    =>      meta_bop {$_[0] == $_[1]},
 463         "!="    =>      meta_bop {$_[0] != $_[1]},
 464         "<=>"   =>      meta_bop {$_[0] <=> $_[1]},
 465         "lt"    =>      meta_bop {$_[0] lt $_[1]},
 466         "le"    =>      meta_bop {$_[0] le $_[1]},
 467         "gt"    =>      meta_bop {$_[0] gt $_[1]},
 468         "ge"    =>      meta_bop {$_[0] ge $_[1]},
 469         "eq"    =>      meta_bop {$_[0] eq $_[1]},
 470         "ne"    =>      meta_bop {$_[0] ne $_[1]},
 471         "cmp"   =>      meta_bop {$_[0] cmp $_[1]},
 472         "\&"    =>      meta_bop {$_[0] & $_[1]},
 473         "^"     =>      meta_bop {$_[0] ^ $_[1]},
 474         "|"     =>      meta_bop {$_[0] | $_[1]},
 475         "atan2" =>      meta_bop {atan2 $_[0], $_[1]},
 476
 477         "neg"   =>      meta_uop {-$_[0]},
 478         "!"     =>      meta_uop {!$_[0]},
 479         "~"     =>      meta_uop {~$_[0]},
 480         "cos"   =>      meta_uop {cos $_[0]},
 481         "sin"   =>      meta_uop {sin $_[0]},
 482         "exp"   =>      meta_uop {exp $_[0]},
 483         "abs"   =>      meta_uop {abs $_[0]},
 484         "log"   =>      meta_uop {log $_[0]},
 485         "sqrt"  =>      meta_uop {sqrt $_[0]},
 486         "bool"  =>      sub { croak "Can't use && or || in expression containing __" },
 487
 488         #       "&()"   =>      sub { $_[0]->{impl} },
 489
 490         #       "||"    =>      meta_bop {$_[0] || $_[1]},
 491         #       "&&"    =>      meta_bop {$_[0] && $_[1]},
 492         # fallback => 1,
 493         ;
 494 1;
 495
 496 __END__
 497
 498
 499 =head1 NAME
 500
 501 Switch - A switch statement for Perl
 502
 503 =head1 VERSION
 504
 505 This document describes version 2.10 of Switch,
 506 released Dec 29, 2003.
 507
 508 =head1 SYNOPSIS
 509
 510         use Switch;
 511
 512         switch ($val) {
 513
 514                 case 1          { print "number 1" }
 515                 case "a"        { print "string a" }
 516                 case [1..10,42] { print "number in list" }
 517                 case (@array)   { print "number in list" }
 518                 case /\w+/      { print "pattern" }
 519                 case qr/\w+/    { print "pattern" }
 520                 case (%hash)    { print "entry in hash" }
 521                 case (\%hash)   { print "entry in hash" }
 522                 case (\&sub)    { print "arg to subroutine" }
 523                 else            { print "previous case not true" }
 524         }
 525
 526 =head1 BACKGROUND
 527
 528 [Skip ahead to L<"DESCRIPTION"> if you don't care about the whys
 529 and wherefores of this control structure]
 530
 531 In seeking to devise a "Swiss Army" case mechanism suitable for Perl,
 532 it is useful to generalize this notion of distributed conditional
 533 testing as far as possible. Specifically, the concept of "matching"
 534 between the switch value and the various case values need not be
 535 restricted to numeric (or string or referential) equality, as it is in other
 536 languages. Indeed, as Table 1 illustrates, Perl
 537 offers at least eighteen different ways in which two values could
 538 generate a match.
 539
 540         Table 1: Matching a switch value ($s) with a case value ($c)
 541
 542         Switch  Case    Type of Match Implied   Matching Code
 543         Value   Value
 544         ======  =====   =====================   =============
 545
 546         number  same    numeric or referential  match if $s == $c;
 547         or ref          equality
 548
 549         object  method  result of method call   match if $s->$c();
 550         ref     name                            match if defined $s->$c();
 551                 or ref
 552
 553         other   other   string equality         match if $s eq $c;
 554         non-ref non-ref
 555         scalar  scalar
 556
 557         string  regexp  pattern match           match if $s =~ /$c/;
 558
 559         array   scalar  array entry existence   match if 0<=$c && $c<@$s;
 560         ref             array entry definition  match if defined $s->[$c];
 561                         array entry truth       match if $s->[$c];
 562
 563         array   array   array intersection      match if intersects(@$s, @$c);
 564         ref     ref     (apply this table to
 565                          all pairs of elements
 566                          $s->[$i] and
 567                          $c->[$j])
 568
 569         array   regexp  array grep              match if grep /$c/, @$s;
 570         ref
 571
 572         hash    scalar  hash entry existence    match if exists $s->{$c};
 573         ref             hash entry definition   match if defined $s->{$c};
 574                         hash entry truth        match if $s->{$c};
 575
 576         hash    regexp  hash grep               match if grep /$c/, keys %$s;
 577         ref
 578
 579         sub     scalar  return value defn       match if defined $s->($c);
 580         ref             return value truth      match if $s->($c);
 581
 582         sub     array   return value defn       match if defined $s->(@$c);
 583         ref     ref     return value truth      match if $s->(@$c);
 584
 585
 586 In reality, Table 1 covers 31 alternatives, because only the equality and
 587 intersection tests are commutative; in all other cases, the roles of
 588 the C<$s> and C<$c> variables could be reversed to produce a
 589 different test. For example, instead of testing a single hash for
 590 the existence of a series of keys (C<match if exists $s-E<gt>{$c}>),
 591 one could test for the existence of a single key in a series of hashes
 592 (C<match if exists $c-E<gt>{$s}>).
 593
 594 As L<perltodo> observes, a Perl case mechanism must support all these
 595 "ways to do it".
 596
 597
 598 =head1 DESCRIPTION
 599
 600 The Switch.pm module implements a generalized case mechanism that covers
 601 the numerous possible combinations of switch and case values described above.
 602
 603 The module augments the standard Perl syntax with two new control
 604 statements: C<switch> and C<case>. The C<switch> statement takes a
 605 single scalar argument of any type, specified in parentheses.
 606 C<switch> stores this value as the
 607 current switch value in a (localized) control variable.
 608 The value is followed by a block which may contain one or more
 609 Perl statements (including the C<case> statement described below).
 610 The block is unconditionally executed once the switch value has
 611 been cached.
 612
 613 A C<case> statement takes a single scalar argument (in mandatory
 614 parentheses if it's a variable; otherwise the parens are optional) and
 615 selects the appropriate type of matching between that argument and the
 616 current switch value. The type of matching used is determined by the
 617 respective types of the switch value and the C<case> argument, as
 618 specified in Table 1. If the match is successful, the mandatory
 619 block associated with the C<case> statement is executed.
 620
 621 In most other respects, the C<case> statement is semantically identical
 622 to an C<if> statement. For example, it can be followed by an C<else>
 623 clause, and can be used as a postfix statement qualifier.
 624
 625 However, when a C<case> block has been executed control is automatically
 626 transferred to the statement after the immediately enclosing C<switch>
 627 block, rather than to the next statement within the block. In other
 628 words, the success of any C<case> statement prevents other cases in the
 629 same scope from executing. But see L<"Allowing fall-through"> below.
 630
 631 Together these two new statements provide a fully generalized case
 632 mechanism:
 633
 634         use Switch;
 635
 636         # AND LATER...
 637
 638         %special = ( woohoo => 1,  d'oh => 1 );
 639
 640         while (<>) {
 641             switch ($_) {
 642
 643                 case (%special) { print "homer\n"; }      # if $special{$_}
 644                 case /a-z/i     { print "alpha\n"; }      # if $_ =~ /a-z/i
 645                 case [1..9]     { print "small num\n"; }  # if $_ in [1..9]
 646
 647                 case { $_[0] >= 10 } {                    # if $_ >= 10
 648                     my $age = <>;
 649                     switch (sub{ $_[0] < $age } ) {
 650
 651                         case 20  { print "teens\n"; }     # if 20 < $age
 652                         case 30  { print "twenties\n"; }  # if 30 < $age
 653                         else     { print "history\n"; }
 654                     }
 655                 }
 656
 657                 print "must be punctuation\n" case /\W/;  # if $_ ~= /\W/
 658         }
 659
 660 Note that C<switch>es can be nested within C<case> (or any other) blocks,
 661 and a series of C<case> statements can try different types of matches
 662 -- hash membership, pattern match, array intersection, simple equality,
 663 etc. -- against the same switch value.
 664
 665 The use of intersection tests against an array reference is particularly
 666 useful for aggregating integral cases:
 667
 668         sub classify_digit
 669         {
 670                 switch ($_[0]) { case 0            { return 'zero' }
 671                                  case [2,4,6,8]    { return 'even' }
 672                                  case [1,3,4,7,9]  { return 'odd' }
 673                                  case /[A-F]/i     { return 'hex' }
 674                                }
 675         }
 676
 677
 678 =head2 Allowing fall-through
 679
 680 Fall-though (trying another case after one has already succeeded)
 681 is usually a Bad Idea in a switch statement. However, this
 682 is Perl, not a police state, so there I<is> a way to do it, if you must.
 683
 684 If a C<case> block executes an untargeted C<next>, control is
 685 immediately transferred to the statement I<after> the C<case> statement
 686 (i.e. usually another case), rather than out of the surrounding
 687 C<switch> block.
 688
 689 For example:
 690
 691         switch ($val) {
 692                 case 1      { handle_num_1(); next }    # and try next case...
 693                 case "1"    { handle_str_1(); next }    # and try next case...
 694                 case [0..9] { handle_num_any(); }       # and we're done
 695                 case /\d/   { handle_dig_any(); next }  # and try next case...
 696                 case /.*/   { handle_str_any(); next }  # and try next case...
 697         }
 698
 699 If $val held the number C<1>, the above C<switch> block would call the
 700 first three C<handle_...> subroutines, jumping to the next case test
 701 each time it encountered a C<next>. After the thrid C<case> block
 702 was executed, control would jump to the end of the enclosing
 703 C<switch> block.
 704
 705 On the other hand, if $val held C<10>, then only the last two C<handle_...>
 706 subroutines would be called.
 707
 708 Note that this mechanism allows the notion of I<conditional fall-through>.
 709 For example:
 710
 711         switch ($val) {
 712                 case [0..9] { handle_num_any(); next if $val < 7; }
 713                 case /\d/   { handle_dig_any(); }
 714         }
 715
 716 If an untargeted C<last> statement is executed in a case block, this
 717 immediately transfers control out of the enclosing C<switch> block
 718 (in other words, there is an implicit C<last> at the end of each
 719 normal C<case> block). Thus the previous example could also have been
 720 written:
 721
 722         switch ($val) {
 723                 case [0..9] { handle_num_any(); last if $val >= 7; next; }
 724                 case /\d/   { handle_dig_any(); }
 725         }
 726
 727
 728 =head2 Automating fall-through
 729
 730 In situations where case fall-through should be the norm, rather than an
 731 exception, an endless succession of terminal C<next>s is tedious and ugly.
 732 Hence, it is possible to reverse the default behaviour by specifying
 733 the string "fallthrough" when importing the module. For example, the
 734 following code is equivalent to the first example in L<"Allowing fall-through">:
 735
 736         use Switch 'fallthrough';
 737
 738         switch ($val) {
 739                 case 1      { handle_num_1(); }
 740                 case "1"    { handle_str_1(); }
 741                 case [0..9] { handle_num_any(); last }
 742                 case /\d/   { handle_dig_any(); }
 743                 case /.*/   { handle_str_any(); }
 744         }
 745
 746 Note the explicit use of a C<last> to preserve the non-fall-through
 747 behaviour of the third case.
 748
 749
 750
 751 =head2 Alternative syntax
 752
 753 Perl 6 will provide a built-in switch statement with essentially the
 754 same semantics as those offered by Switch.pm, but with a different
 755 pair of keywords. In Perl 6 C<switch> will be spelled C<given>, and
 756 C<case> will be pronounced C<when>. In addition, the C<when> statement
 757 will not require switch or case values to be parenthesized.
 758
 759 This future syntax is also (largely) available via the Switch.pm module, by
 760 importing it with the argument C<"Perl6">.  For example:
 761
 762         use Switch 'Perl6';
 763
 764         given ($val) {
 765                 when 1       { handle_num_1(); }
 766                 when ($str1) { handle_str_1(); }
 767                 when [0..9]  { handle_num_any(); last }
 768                 when /\d/    { handle_dig_any(); }
 769                 when /.*/    { handle_str_any(); }
 770                 default      { handle anything else; }
 771         }
 772
 773 Note that scalars still need to be parenthesized, since they would be
 774 ambiguous in Perl 5.
 775
 776 Note too that you can mix and match both syntaxes by importing the module
 777 with:
 778
 779         use Switch 'Perl5', 'Perl6';
 780
 781
 782 =head2 Higher-order Operations
 783
 784 One situation in which C<switch> and C<case> do not provide a good
 785 substitute for a cascaded C<if>, is where a switch value needs to
 786 be tested against a series of conditions. For example:
 787
 788         sub beverage {
 789             switch (shift) {
 790
 791                 case sub { $_[0] < 10 }  { return 'milk' }
 792                 case sub { $_[0] < 20 }  { return 'coke' }
 793                 case sub { $_[0] < 30 }  { return 'beer' }
 794                 case sub { $_[0] < 40 }  { return 'wine' }
 795                 case sub { $_[0] < 50 }  { return 'malt' }
 796                 case sub { $_[0] < 60 }  { return 'Moet' }
 797                 else                     { return 'milk' }
 798             }
 799         }
 800
 801 The need to specify each condition as a subroutine block is tiresome. To
 802 overcome this, when importing Switch.pm, a special "placeholder"
 803 subroutine named C<__> [sic] may also be imported. This subroutine
 804 converts (almost) any expression in which it appears to a reference to a
 805 higher-order function. That is, the expression:
 806
 807         use Switch '__';
 808
 809         __ < 2 + __
 810
 811 is equivalent to:
 812
 813         sub { $_[0] < 2 + $_[1] }
 814
 815 With C<__>, the previous ugly case statements can be rewritten:
 816
 817         case  __ < 10  { return 'milk' }
 818         case  __ < 20  { return 'coke' }
 819         case  __ < 30  { return 'beer' }
 820         case  __ < 40  { return 'wine' }
 821         case  __ < 50  { return 'malt' }
 822         case  __ < 60  { return 'Moet' }
 823         else           { return 'milk' }
 824
 825 The C<__> subroutine makes extensive use of operator overloading to
 826 perform its magic. All operations involving __ are overloaded to
 827 produce an anonymous subroutine that implements a lazy version
 828 of the original operation.
 829
 830 The only problem is that operator overloading does not allow the
 831 boolean operators C<&&> and C<||> to be overloaded. So a case statement
 832 like this:
 833
 834         case  0 <= __ && __ < 10  { return 'digit' }
 835
 836 doesn't act as expected, because when it is
 837 executed, it constructs two higher order subroutines
 838 and then treats the two resulting references as arguments to C<&&>:
 839
 840         sub { 0 <= $_[0] } && sub { $_[0] < 10 }
 841
 842 This boolean expression is inevitably true, since both references are
 843 non-false. Fortunately, the overloaded C<'bool'> operator catches this
 844 situation and flags it as a error.
 845
 846 =head1 DEPENDENCIES
 847
 848 The module is implemented using Filter::Util::Call and Text::Balanced
 849 and requires both these modules to be installed.
 850
 851 =head1 AUTHOR
 852
 853 Damian Conway (damian@conway.org). The maintainer of this module is now Rafael
 854 Garcia-Suarez (rgarciasuarez@free.fr).
 855
 856 =head1 BUGS
 857
 858 There are undoubtedly serious bugs lurking somewhere in code this funky :-)
 859 Bug reports and other feedback are most welcome.
 860
 861 =head1 LIMITATIONS
 862
 863 Due to the heuristic nature of Switch.pm's source parsing, the presence
 864 of regexes specified with raw C<?...?> delimiters may cause mysterious
 865 errors. The workaround is to use C<m?...?> instead.
 866
 867 Due to the way source filters work in Perl, you can't use Switch inside
 868 an string C<eval>.
 869
 870 If your source file is longer then 1 million characters and you have a
 871 switch statement that crosses the 1 million (or 2 million, etc.)
 872 character boundary you will get mysterious errors. The workaround is to
 873 use smaller source files.
 874
 875 =head1 COPYRIGHT
 876
 877     Copyright (c) 1997-2003, Damian Conway. All Rights Reserved.
 878     This module is free software. It may be used, redistributed
 879         and/or modified under the same terms as Perl itself.