dist/Switch/Switch.pm

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