lib/Switch.pm

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