lib/Switch.pm

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