lib/Switch.pm

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