lib/Switch.pm

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