lib/Switch.pm

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