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