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