lib/Switch.pm

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