lib/Switch.pm

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