lib/Switch.pm

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