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