Add Switch 2.01, resort MANIFEST (forgot that in #9117)
Jarkko Hietaniemi [Tue, 13 Mar 2001 01:13:39 +0000 (01:13 +0000)]
p4raw-id: //depot/perl@9118

MANIFEST
lib/Switch.pm [new file with mode: 0644]
t/lib/switch.t [new file with mode: 0644]

index 0d299a4..4fbcb65 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -750,6 +750,7 @@ lib/Search/Dict.pm  Perform binary search on dictionaries
 lib/SelectSaver.pm     Enforce proper select scoping
 lib/SelfLoader.pm      Load functions only on demand
 lib/Shell.pm           Make AUTOLOADed system() calls
+lib/Switch.pm          Switch for Perl
 lib/Symbol.pm          Symbol table manipulation routines
 lib/Term/ANSIColor.pm  Perl module supporting termcap usage
 lib/Term/Cap.pm                Perl module supporting termcap usage
@@ -758,6 +759,8 @@ lib/Term/ReadLine.pm        Stub readline library
 lib/Test.pm            A simple framework for writing test scripts
 lib/Test/Harness.pm    A test harness
 lib/Text/Abbrev.pm     An abbreviation table builder
+lib/Text/Balanced.pm   Text::Balanced
+lib/Text/Balanced.pod  Text::Balanced
 lib/Text/ParseWords.pm Perl module to split words on arbitrary delimiter
 lib/Text/Soundex.pm    Perl module to implement Soundex
 lib/Text/Tabs.pm       Do expand and unexpand
@@ -1088,8 +1091,8 @@ lib/unicode/PropList.txt                  Unicode character database
 lib/unicode/README.Ethiopic                    Unicode character database
 lib/unicode/README.perl                                Unicode character database
 lib/unicode/ReadMe.txt                         Unicode character database info
-lib/unicode/SpecCase.txt                       Unicode character database
 lib/unicode/Scripts.txt                                Unicode character database
+lib/unicode/SpecCase.txt                       Unicode character database
 lib/unicode/To/Digit.pl                                Unicode character database
 lib/unicode/To/Lower.pl                                Unicode character database
 lib/unicode/To/Title.pl                                Unicode character database
@@ -1520,9 +1523,18 @@ t/lib/st-tied.t          See if Storable works
 t/lib/st-tiedhook.t    See if Storable works
 t/lib/st-tieditems.t   See if Storable works
 t/lib/st-utf8.t                See if Storable works
+t/lib/switch.t         Test whether switch works
 t/lib/symbol.t         See if Symbol works
 t/lib/syslfs.t         See if large files work for sysio
 t/lib/syslog.t         See if Sys::Syslog works
+t/lib/tb-genxt.t       See if Text::Balanced works
+t/lib/tb-xbrak.t       See if Text::Balanced works
+t/lib/tb-xcode.t       See if Text::Balanced works
+t/lib/tb-xdeli.t       See if Text::Balanced works
+t/lib/tb-xmult.t       See if Text::Balanced works
+t/lib/tb-xquot.t       See if Text::Balanced works
+t/lib/tb-xtagg.t       See if Text::Balanced works
+t/lib/tb-xvari.t       See if Text::Balanced works
 t/lib/test-harness.t    See if Test::Harness works
 t/lib/textfill.t       See if Text::Wrap::fill works
 t/lib/texttabs.t       See if Text::Tabs works
@@ -1858,13 +1870,3 @@ x2p/util.c               Utility routines
 x2p/util.h             Public declarations for the above
 x2p/walk.c             Parse tree walker
 xsutils.c              Additional bundled package methods not in UNIVERSAL::
-lib/Text/Balanced.pm   Text::Balanced
-lib/Text/Balanced.pod  Text::Balanced
-t/lib/tb-genxt.t       See if Text::Balanced works
-t/lib/tb-xbrak.t       See if Text::Balanced works
-t/lib/tb-xcode.t       See if Text::Balanced works
-t/lib/tb-xdeli.t       See if Text::Balanced works
-t/lib/tb-xmult.t       See if Text::Balanced works
-t/lib/tb-xquot.t       See if Text::Balanced works
-t/lib/tb-xtagg.t       See if Text::Balanced works
-t/lib/tb-xvari.t       See if Text::Balanced works
diff --git a/lib/Switch.pm b/lib/Switch.pm
new file mode 100644 (file)
index 0000000..dfab91c
--- /dev/null
@@ -0,0 +1,786 @@
+package Switch;
+
+use strict;
+use vars qw($VERSION);
+use Carp;
+
+$VERSION = '2.01';
+
+
+# LOAD FILTERING MODULE...
+use Filter::Util::Call;
+
+sub __();
+
+# CATCH ATTEMPTS TO CALL case OUTSIDE THE SCOPE OF ANY switch
+
+$::_S_W_I_T_C_H = sub { croak "case statement not in switch block" };
+
+my $offset;
+my $fallthrough;
+my $nextlabel = 1;
+
+sub import
+{
+       $fallthrough = grep /\bfallthrough\b/, @_;
+       $offset = (caller)[2]+1;
+       filter_add({}) unless @_>1 && $_[1] ne '__';
+       my $pkg = caller;
+       no strict 'refs';
+       for ( qw( on_defined on_exists ) )
+       {
+               *{"${pkg}::$_"} = \&$_;
+       }
+       *{"${pkg}::__"} = \&__ if grep /__/, @_;
+       1;
+}
+
+sub unimport
+{      
+       filter_del()
+}
+
+sub filter
+{
+       my($self) = @_ ;
+       local $Switch::file = (caller)[1];
+
+       my $status = 1;
+       $status = filter_read(10_000);
+       return $status if $status<0;
+       $_ = filter_blocks($_,$offset);
+       $_ = "# line $offset\n" . $_ if $offset; undef $offset;
+       # print STDERR $_;
+       return $status;
+}
+
+use Text::Balanced ':ALL';
+
+sub line
+{
+       my ($pretext,$offset) = @_;
+       ($pretext=~tr/\n/\n/)+$offset,
+}
+
+sub is_block
+{
+       local $SIG{__WARN__}=sub{die$@};
+       local $^W=1;
+       my $ishash = defined  eval 'my $hr='.$_[0];
+       undef $@;
+       return !$ishash;
+}
+
+my $casecounter = 1;
+sub filter_blocks
+{
+       my ($source, $line) = @_;
+       return $source unless $source =~ /case|switch/;
+       pos $source = 0;
+       my $text = "";
+       component: while (pos $source < length $source)
+       {
+               if ($source =~ m/(\G\s*use\s+switch\b)/gc)
+               {
+                       $text .= q{use Switch 'noimport'};
+                       next component;
+               }
+               my @pos = Text::Balanced::_match_quotelike(\$source,qr/\s*/,1,1);
+               if (defined $pos[0])
+               {
+                       $text .= substr($source,$pos[2],$pos[18]-$pos[2]);
+                       next component;
+               }
+               @pos = Text::Balanced::_match_variable(\$source,qr/\s*/);
+               if (defined $pos[0])
+               {
+                       $text .= substr($source,$pos[0],$pos[4]-$pos[0]);
+                       next component;
+               }
+
+               if ($source =~ m/\G(\n*)(\s*)switch\b(?=\s*[(])/gc)
+               {
+                       $text .= $1.$2.'S_W_I_T_C_H: while (1) ';
+                       @pos = Text::Balanced::_match_codeblock(\$source,qr/\s*/,qr/\(/,qr/\)/,qr/\{/,qr/\}/,undef) 
+                       or do {
+                               die "Bad switch statement (problem in the parentheses?) near $Switch::file line ", line(substr($source,0,pos $source),$line), "\n";
+                       };
+                       my $arg = filter_blocks(substr($source,$pos[0],$pos[4]-$pos[0]),line(substr($source,0,$pos[0]),$line));
+                       $arg =~ s {^\s*[(]\s*%}   { ( \\\%}     ||
+                       $arg =~ s {^\s*[(]\s*m\b} { ( qr}       ||
+                       $arg =~ s {^\s*[(]\s*/}   { ( qr/}      ||
+                       $arg =~ s {^\s*[(]\s*qw}  { ( \\qw};
+                       @pos = Text::Balanced::_match_codeblock(\$source,qr/\s*/,qr/\{/,qr/\}/,qr/\{/,qr/\}/,undef)
+                       or do {
+                               die "Bad switch statement (problem in the code block?) near $Switch::file line ", line(substr($source,0, pos $source), $line), "\n";
+                       };
+                       my $code = filter_blocks(substr($source,$pos[0],$pos[4]-$pos[0]),line(substr($source,0,$pos[0]),$line));
+                       $code =~ s/{/{ local \$::_S_W_I_T_C_H; Switch::switch $arg;/;
+                       $text .= $code . 'continue {last}';
+                       next component;
+               }
+               elsif ($source =~ m/\G(\s*)(case\b)(?!\s*=>)/gc)
+               {
+                       $text .= $1."if (Switch::case";
+                       if (@pos = Text::Balanced::_match_codeblock(\$source,qr/\s*/,qr/\{/,qr/\}/,qr/\{/,qr/\}/,undef)) {
+                               my $code = substr($source,$pos[0],$pos[4]-$pos[0]);
+                               $text .= " sub" if is_block $code;
+                               $text .= " " . filter_blocks($code,line(substr($source,0,$pos[0]),$line)) . ")";
+                       }
+                       elsif (@pos = Text::Balanced::_match_codeblock(\$source,qr/\s*/,qr/[[(]/,qr/[])]/,qr/[[({]/,qr/[])}]/,undef)) {
+                               my $code = filter_blocks(substr($source,$pos[0],$pos[4]-$pos[0]),line(substr($source,0,$pos[0]),$line));
+                               $code =~ s {^\s*[(]\s*%}   { ( \\\%}    ||
+                               $code =~ s {^\s*[(]\s*m\b} { ( qr}      ||
+                               $code =~ s {^\s*[(]\s*/}   { ( qr/}     ||
+                               $code =~ s {^\s*[(]\s*qw}  { ( \\qw};
+                               $text .= " $code)";
+                       }
+                       elsif ( @pos = Text::Balanced::_match_quotelike(\$source,qr/\s*/,1,1)) {
+                               my $code = substr($source,$pos[2],$pos[18]-$pos[2]);
+                               $code = filter_blocks($code,line(substr($source,0,$pos[2]),$line));
+                               $code =~ s {^\s*m}  { qr}       ||
+                               $code =~ s {^\s*/}  { qr/}      ||
+                               $code =~ s {^\s*qw} { \\qw};
+                               $text .= " $code)";
+                       }
+                       elsif ($source =~ m/\G\s*(([^\$\@{])[^\$\@{]*)(?=\s*{)/gc) {
+                               my $code = filter_blocks($1,line(substr($source,0,pos $source),$line));
+                               $text .= ' \\' if $2 eq '%';
+                               $text .= " $code)";
+                       }
+                       else {
+                               die "Bad case statement (invalid case value?) near $Switch::file line ", line(substr($source,0,pos $source), $line), "\n";
+                       }
+
+                       @pos = Text::Balanced::_match_codeblock(\$source,qr/\s*/,qr/\{/,qr/\}/,qr/\{/,qr/\}/,undef)
+                       or do {
+                               if ($source =~ m/\G\s*(?=([};]|\Z))/gc) {
+                                       $casecounter++;
+                                       next component;
+                               }
+                               die "Bad case statement (problem in the code block?) near $Switch::file line ", line(substr($source,0,pos $source),$line), "\n";
+                       };
+                       my $code = filter_blocks(substr($source,$pos[0],$pos[4]-$pos[0]),line(substr($source,0,$pos[0]),$line));
+                       $code =~ s/}(?=\s*\Z)/;last S_W_I_T_C_H }/
+                               unless $fallthrough;
+                       $text .= "{ while (1) $code continue { goto C_A_S_E_$casecounter } last S_W_I_T_C_H; C_A_S_E_$casecounter: }";
+                       $casecounter++;
+                       next component;
+               }
+
+               $source =~ m/\G(\s*(\w+|#.*\n|\W))/gc;
+               $text .= $1;
+       }
+       $text;
+}
+
+
+
+sub in
+{
+       my ($x,$y) = @_;
+       my @numy;
+       for my $nextx ( @$x )
+       {
+               my $numx = ref($nextx) || (~$nextx&$nextx) eq 0;
+               for my $j ( 0..$#$y )
+               {
+                       my $nexty = $y->[$j];
+                       push @numy, ref($nexty) || (~$nexty&$nexty) eq 0
+                               if @numy <= $j;
+                       return 1 if $numx && $numy[$j] && $nextx==$nexty
+                                || $nextx eq $nexty;
+                       
+               }
+       }
+       return "";
+}
+
+sub on_exists
+{
+       my $ref = @_==1 && ref($_[0]) eq 'HASH' ? $_[0] : { @_ };
+       [ keys %$ref ]
+}
+
+sub on_defined
+{
+       my $ref = @_==1 && ref($_[0]) eq 'HASH' ? $_[0] : { @_ };
+       [ grep { defined $ref->{$_} } keys %$ref ]
+}
+
+sub switch(;$)
+{
+       my ($s_val) = @_ ? $_[0] : $_;
+       my $s_ref = ref $s_val;
+       
+       if ($s_ref eq 'CODE')
+       {
+               $::_S_W_I_T_C_H =
+                     sub { my $c_val = $_[0];
+                           return $s_val == $c_val  if ref $c_val eq 'CODE';
+                           return $s_val->(@$c_val) if ref $c_val eq 'ARRAY';
+                           return $s_val->($c_val);
+                         };
+       }
+       elsif ($s_ref eq "" && (~$s_val&$s_val) eq 0)   # NUMERIC SCALAR
+       {
+               $::_S_W_I_T_C_H =
+                     sub { my $c_val = $_[0];
+                           my $c_ref = ref $c_val;
+                           return $s_val == $c_val     if $c_ref eq ""
+                                                       && (~$c_val&$c_val) eq 0;
+                           return $s_val eq $c_val     if $c_ref eq "";
+                           return in([$s_val],$c_val)  if $c_ref eq 'ARRAY';
+                           return $c_val->($s_val)     if $c_ref eq 'CODE';
+                           return $c_val->call($s_val) if $c_ref eq 'Switch';
+                           return scalar $s_val=~/$c_val/
+                                                       if $c_ref eq 'Regexp';
+                           return scalar $c_val->{$s_val}
+                                                       if $c_ref eq 'HASH';
+                           return;     
+                         };
+       }
+       elsif ($s_ref eq "")                            # STRING SCALAR
+       {
+               $::_S_W_I_T_C_H =
+                     sub { my $c_val = $_[0];
+                           my $c_ref = ref $c_val;
+                           return $s_val eq $c_val     if $c_ref eq "";
+                           return in([$s_val],$c_val)  if $c_ref eq 'ARRAY';
+                           return $c_val->($s_val)     if $c_ref eq 'CODE';
+                           return $c_val->call($s_val) if $c_ref eq 'Switch';
+                           return scalar $s_val=~/$c_val/
+                                                       if $c_ref eq 'Regexp';
+                           return scalar $c_val->{$s_val}
+                                                       if $c_ref eq 'HASH';
+                           return;     
+                         };
+       }
+       elsif ($s_ref eq 'ARRAY')
+       {
+               $::_S_W_I_T_C_H =
+                     sub { my $c_val = $_[0];
+                           my $c_ref = ref $c_val;
+                           return in($s_val,[$c_val])  if $c_ref eq "";
+                           return in($s_val,$c_val)    if $c_ref eq 'ARRAY';
+                           return $c_val->(@$s_val)    if $c_ref eq 'CODE';
+                           return $c_val->call(@$s_val)
+                                                       if $c_ref eq 'Switch';
+                           return scalar grep {$_=~/$c_val/} @$s_val
+                                                       if $c_ref eq 'Regexp';
+                           return scalar grep {$c_val->{$_}} @$s_val
+                                                       if $c_ref eq 'HASH';
+                           return;     
+                         };
+       }
+       elsif ($s_ref eq 'Regexp')
+       {
+               $::_S_W_I_T_C_H =
+                     sub { my $c_val = $_[0];
+                           my $c_ref = ref $c_val;
+                           return $c_val=~/s_val/      if $c_ref eq "";
+                           return scalar grep {$_=~/s_val/} @$c_val
+                                                       if $c_ref eq 'ARRAY';
+                           return $c_val->($s_val)     if $c_ref eq 'CODE';
+                           return $c_val->call($s_val) if $c_ref eq 'Switch';
+                           return $s_val eq $c_val     if $c_ref eq 'Regexp';
+                           return grep {$_=~/$s_val/ && $c_val->{$_}} keys %$c_val
+                                                       if $c_ref eq 'HASH';
+                           return;     
+                         };
+       }
+       elsif ($s_ref eq 'HASH')
+       {
+               $::_S_W_I_T_C_H =
+                     sub { my $c_val = $_[0];
+                           my $c_ref = ref $c_val;
+                           return $s_val->{$c_val}     if $c_ref eq "";
+                           return scalar grep {$s_val->{$_}} @$c_val
+                                                       if $c_ref eq 'ARRAY';
+                           return $c_val->($s_val)     if $c_ref eq 'CODE';
+                           return $c_val->call($s_val) if $c_ref eq 'Switch';
+                           return grep {$_=~/$c_val/ && $s_val->{"$_"}} keys %$s_val
+                                                       if $c_ref eq 'Regexp';
+                           return $s_val==$c_val       if $c_ref eq 'HASH';
+                           return;     
+                         };
+       }
+       elsif ($s_ref eq 'Switch')
+       {
+               $::_S_W_I_T_C_H =
+                     sub { my $c_val = $_[0];
+                           return $s_val == $c_val  if ref $c_val eq 'Switch';
+                           return $s_val->call(@$c_val)
+                                                    if ref $c_val eq 'ARRAY';
+                           return $s_val->call($c_val);
+                         };
+       }
+       else
+       {
+               croak "Cannot switch on $s_ref";
+       }
+       return 1;
+}
+
+sub case($) { $::_S_W_I_T_C_H->(@_); }
+
+# IMPLEMENT __
+
+my $placeholder = bless { arity=>1, impl=>sub{$_[1+$_[0]]} };
+
+sub __() { $placeholder }
+
+sub __arg($)
+{
+       my $index = $_[0]+1;
+       bless { arity=>0, impl=>sub{$_[$index]} };
+}
+
+sub hosub(&@)
+{
+       # WRITE THIS
+}
+
+sub call
+{
+       my ($self,@args) = @_;
+       return $self->{impl}->(0,@args);
+}
+
+sub meta_bop(&)
+{
+       my ($op) = @_;
+       sub
+       {
+               my ($left, $right, $reversed) = @_;
+               ($right,$left) = @_ if $reversed;
+
+               my $rop = ref $right eq 'Switch'
+                       ? $right
+                       : bless { arity=>0, impl=>sub{$right} };
+
+               my $lop = ref $left eq 'Switch'
+                       ? $left
+                       : bless { arity=>0, impl=>sub{$left} };
+
+               my $arity = $lop->{arity} + $rop->{arity};
+
+               return bless {
+                               arity => $arity,
+                               impl  => sub { my $start = shift;
+                                              return $op->($lop->{impl}->($start,@_),
+                                                           $rop->{impl}->($start+$lop->{arity},@_));
+                                            }
+                            };
+       };
+}
+
+sub meta_uop(&)
+{
+       my ($op) = @_;
+       sub
+       {
+               my ($left) = @_;
+
+               my $lop = ref $left eq 'Switch'
+                       ? $left
+                       : bless { arity=>0, impl=>sub{$left} };
+
+               my $arity = $lop->{arity};
+
+               return bless {
+                               arity => $arity,
+                               impl  => sub { $op->($lop->{impl}->(@_)) }
+                            };
+       };
+}
+
+
+use overload
+       "+"     =>      meta_bop {$_[0] + $_[1]},
+       "-"     =>      meta_bop {$_[0] - $_[1]},  
+       "*"     =>      meta_bop {$_[0] * $_[1]},
+       "/"     =>      meta_bop {$_[0] / $_[1]},
+       "%"     =>      meta_bop {$_[0] % $_[1]},
+       "**"    =>      meta_bop {$_[0] ** $_[1]},
+       "<<"    =>      meta_bop {$_[0] << $_[1]},
+       ">>"    =>      meta_bop {$_[0] >> $_[1]},
+       "x"     =>      meta_bop {$_[0] x $_[1]},
+       "."     =>      meta_bop {$_[0] . $_[1]},
+       "<"     =>      meta_bop {$_[0] < $_[1]},
+       "<="    =>      meta_bop {$_[0] <= $_[1]},
+       ">"     =>      meta_bop {$_[0] > $_[1]},
+       ">="    =>      meta_bop {$_[0] >= $_[1]},
+       "=="    =>      meta_bop {$_[0] == $_[1]},
+       "!="    =>      meta_bop {$_[0] != $_[1]},
+       "<=>"   =>      meta_bop {$_[0] <=> $_[1]},
+       "lt"    =>      meta_bop {$_[0] lt $_[1]},
+       "le"    =>      meta_bop {$_[0] le $_[1]},
+       "gt"    =>      meta_bop {$_[0] gt $_[1]},
+       "ge"    =>      meta_bop {$_[0] ge $_[1]},
+       "eq"    =>      meta_bop {$_[0] eq $_[1]},
+       "ne"    =>      meta_bop {$_[0] ne $_[1]},
+       "cmp"   =>      meta_bop {$_[0] cmp $_[1]},
+       "\&"    =>      meta_bop {$_[0] & $_[1]},
+       "^"     =>      meta_bop {$_[0] ^ $_[1]},
+       "|"     =>      meta_bop {$_[0] | $_[1]},
+       "atan2" =>      meta_bop {atan2 $_[0], $_[1]},
+
+       "neg"   =>      meta_uop {-$_[0]},
+       "!"     =>      meta_uop {!$_[0]},
+       "~"     =>      meta_uop {~$_[0]},
+       "cos"   =>      meta_uop {cos $_[0]},
+       "sin"   =>      meta_uop {sin $_[0]},
+       "exp"   =>      meta_uop {exp $_[0]},
+       "abs"   =>      meta_uop {abs $_[0]},
+       "log"   =>      meta_uop {log $_[0]},
+       "sqrt"  =>      meta_uop {sqrt $_[0]},
+       "bool"  =>      sub { croak "Can't use && or || in expression containing __" },
+
+       #       "&()"   =>      sub { $_[0]->{impl} },
+
+       #       "||"    =>      meta_bop {$_[0] || $_[1]},
+       #       "&&"    =>      meta_bop {$_[0] && $_[1]},
+       # fallback => 1,
+       ;
+1;
+
+__END__
+
+
+=head1 NAME
+
+Switch - A switch statement for Perl
+
+=head1 VERSION
+
+This document describes version 2.01 of Switch,
+released January  9, 2001.
+
+=head1 SYNOPSIS
+
+       use Switch;
+
+       switch ($val) {
+
+               case 1          { print "number 1" }
+               case "a"        { print "string a" }
+               case [1..10,42] { print "number in list" }
+               case (@array)   { print "number in list" }
+               case /\w+/      { print "pattern" }
+               case qr/\w+/    { print "pattern" }
+               case (%hash)    { print "entry in hash" }
+               case (\%hash)   { print "entry in hash" }
+               case (\&sub)    { print "arg to subroutine" }
+               else            { print "previous case not true" }
+       }
+
+=head1 BACKGROUND
+
+[Skip ahead to L<"DESCRIPTION"> if you don't care about the whys
+and wherefores of this control structure]
+
+In seeking to devise a "Swiss Army" case mechanism suitable for Perl,
+it is useful to generalize this notion of distributed conditional
+testing as far as possible. Specifically, the concept of "matching"
+between the switch value and the various case values need not be
+restricted to numeric (or string or referential) equality, as it is in other 
+languages. Indeed, as Table 1 illustrates, Perl
+offers at least eighteen different ways in which two values could
+generate a match.
+
+       Table 1: Matching a switch value ($s) with a case value ($c)
+
+        Switch  Case    Type of Match Implied   Matching Code
+        Value   Value   
+        ======  =====   =====================   =============
+
+        number  same    numeric or referential  match if $s == $c;
+        or ref          equality
+
+       object  method  result of method call   match if $s->$c();
+       ref     name                            match if defined $s->$c();
+               or ref
+
+        other   other   string equality         match if $s eq $c;
+        non-ref non-ref
+        scalar  scalar
+
+        string  regexp  pattern match           match if $s =~ /$c/;
+
+        array   scalar  array entry existence   match if 0<=$c && $c<@$s;
+        ref             array entry definition  match if defined $s->[$c];
+                        array entry truth       match if $s->[$c];
+
+        array   array   array intersection      match if intersects(@$s, @$c);
+        ref     ref     (apply this table to
+                         all pairs of elements
+                         $s->[$i] and
+                         $c->[$j])
+
+        array   regexp  array grep              match if grep /$c/, @$s;
+        ref     
+
+        hash    scalar  hash entry existence    match if exists $s->{$c};
+        ref             hash entry definition   match if defined $s->{$c};
+                        hash entry truth        match if $s->{$c};
+
+        hash    regexp  hash grep               match if grep /$c/, keys %$s;
+        ref     
+
+        sub     scalar  return value defn       match if defined $s->($c);
+        ref             return value truth      match if $s->($c);
+
+        sub     array   return value defn       match if defined $s->(@$c);
+        ref     ref     return value truth      match if $s->(@$c);
+
+
+In reality, Table 1 covers 31 alternatives, because only the equality and
+intersection tests are commutative; in all other cases, the roles of
+the C<$s> and C<$c> variables could be reversed to produce a
+different test. For example, instead of testing a single hash for
+the existence of a series of keys (C<match if exists $s-E<gt>{$c}>),
+one could test for the existence of a single key in a series of hashes
+(C<match if exists $c-E<gt>{$s}>).
+
+As L<perltodo> observes, a Perl case mechanism must support all these
+"ways to do it".
+
+
+=head1 DESCRIPTION
+
+The Switch.pm module implements a generalized case mechanism that covers
+the numerous possible combinations of switch and case values described above.
+
+The module augments the standard Perl syntax with two new control
+statements: C<switch> and C<case>. The C<switch> statement takes a
+single scalar argument of any type, specified in parentheses.
+C<switch> stores this value as the
+current switch value in a (localized) control variable.
+The value is followed by a block which may contain one or more
+Perl statements (including the C<case> statement described below).
+The block is unconditionally executed once the switch value has
+been cached.
+
+A C<case> statement takes a single scalar argument (in mandatory
+parentheses if it's a variable; otherwise the parens are optional) and
+selects the appropriate type of matching between that argument and the
+current switch value. The type of matching used is determined by the
+respective types of the switch value and the C<case> argument, as
+specified in Table 1. If the match is successful, the mandatory
+block associated with the C<case> statement is executed.
+
+In most other respects, the C<case> statement is semantically identical
+to an C<if> statement. For example, it can be followed by an C<else>
+clause, and can be used as a postfix statement qualifier. 
+
+However, when a C<case> block has been executed control is automatically
+transferred to the statement after the immediately enclosing C<switch>
+block, rather than to the next statement within the block. In other
+words, the success of any C<case> statement prevents other cases in the
+same scope from executing. But see L<"Allowing fall-through"> below.
+
+Together these two new statements provide a fully generalized case
+mechanism:
+
+        use Switch;
+
+        # AND LATER...
+
+        %special = ( woohoo => 1,  d'oh => 1 );
+
+        while (<>) {
+            switch ($_) {
+
+                case %special  { print "homer\n"; }       # if $special{$_}
+                case /a-z/i    { print "alpha\n"; }       # if $_ =~ /a-z/i
+                case [1..9]    { print "small num\n"; }   # if $_ in [1..9]
+
+                case { $_[0] >= 10 } {                    # if $_ >= 10
+                    my $age = <>;
+                    switch (sub{ $_[0] < $age } ) {
+
+                        case 20  { print "teens\n"; }     # if 20 < $age
+                        case 30  { print "twenties\n"; }  # if 30 < $age
+                        else     { print "history\n"; }
+                    }
+                }
+
+                print "must be punctuation\n" case /\W/;  # if $_ ~= /\W/
+        }
+
+Note that C<switch>es can be nested within C<case> (or any other) blocks,
+and a series of C<case> statements can try different types of matches
+-- hash membership, pattern match, array intersection, simple equality,
+etc. -- against the same switch value.
+
+The use of intersection tests against an array reference is particularly
+useful for aggregating integral cases:
+
+        sub classify_digit
+        {
+                switch ($_[0]) { case 0            { return 'zero' }
+                                 case [2,4,6,8]    { return 'even' }
+                                 case [1,3,4,7,9]  { return 'odd' }
+                                 case /[A-F]/i     { return 'hex' }
+                               }
+        }
+
+
+=head2 Allowing fall-through
+
+Fall-though (trying another case after one has already succeeded)
+is usually a Bad Idea in a switch statement. However, this
+is Perl, not a police state, so there I<is> a way to do it, if you must.
+
+If a C<case> block executes an untargetted C<next>, control is
+immediately transferred to the statement I<after> the C<case> statement
+(i.e. usually another case), rather than out of the surrounding
+C<switch> block.
+
+For example:
+
+        switch ($val) {
+                case 1      { handle_num_1(); next }    # and try next case...
+                case "1"    { handle_str_1(); next }    # and try next case...
+                case [0..9] { handle_num_any(); }       # and we're done
+                case /\d/   { handle_dig_any(); next }  # and try next case...
+                case /.*/   { handle_str_any(); next }  # and try next case...
+        }
+
+If $val held the number C<1>, the above C<switch> block would call the
+first three C<handle_...> subroutines, jumping to the next case test
+each time it encountered a C<next>. After the thrid C<case> block
+was executed, control would jump to the end of the enclosing
+C<switch> block.
+
+On the other hand, if $val held C<10>, then only the last two C<handle_...>
+subroutines would be called.
+
+Note that this mechanism allows the notion of I<conditional fall-through>.
+For example:
+
+        switch ($val) {
+                case [0..9] { handle_num_any(); next if $val < 7; }
+                case /\d/   { handle_dig_any(); }
+        }
+
+If an untargetted C<last> statement is executed in a case block, this
+immediately transfers control out of the enclosing C<switch> block
+(in other words, there is an implicit C<last> at the end of each
+normal C<case> block). Thus the previous example could also have been
+written:
+
+        switch ($val) {
+                case [0..9] { handle_num_any(); last if $val >= 7; next; }
+                case /\d/   { handle_dig_any(); }
+        }
+
+
+=head2 Automating fall-through
+
+In situations where case fall-through should be the norm, rather than an
+exception, an endless succession of terminal C<next>s is tedious and ugly.
+Hence, it is possible to reverse the default behaviour by specifying
+the string "fallthrough" when importing the module. For example, the 
+following code is equivalent to the first example in L<"Allowing fall-through">:
+
+        use Switch 'fallthrough';
+
+        switch ($val) {
+                case 1      { handle_num_1(); }
+                case "1"    { handle_str_1(); }
+                case [0..9] { handle_num_any(); last }
+                case /\d/   { handle_dig_any(); }
+                case /.*/   { handle_str_any(); }
+        }
+
+Note the explicit use of a C<last> to preserve the non-fall-through
+behaviour of the third case.
+
+
+
+=head2 Higher-order Operations
+
+One situation in which C<switch> and C<case> do not provide a good
+substitute for a cascaded C<if>, is where a switch value needs to
+be tested against a series of conditions. For example:
+
+        sub beverage {
+            switch (shift) {
+
+                case sub { $_[0] < 10 }  { return 'milk' }
+                case sub { $_[0] < 20 }  { return 'coke' }
+                case sub { $_[0] < 30 }  { return 'beer' }
+                case sub { $_[0] < 40 }  { return 'wine' }
+                case sub { $_[0] < 50 }  { return 'malt' }
+                case sub { $_[0] < 60 }  { return 'Moet' }
+                else                     { return 'milk' }
+            }
+        }
+
+The need to specify each condition as a subroutine block is tiresome. To
+overcome this, when importing Switch.pm, a special "placeholder"
+subroutine named C<__> [sic] may also be imported. This subroutine
+converts (almost) any expression in which it appears to a reference to a
+higher-order function. That is, the expression:
+
+        use Switch '__';
+
+        __ < 2 + __
+
+is equivalent to:
+
+        sub { $_[0] < 2 + $_[1] }
+
+With C<__>, the previous ugly case statements can be rewritten:
+
+        case  __ < 10  { return 'milk' }
+        case  __ < 20  { return 'coke' }
+        case  __ < 30  { return 'beer' }
+        case  __ < 40  { return 'wine' }
+        case  __ < 50  { return 'malt' }
+        case  __ < 60  { return 'Moet' }
+        else           { return 'milk' }
+
+The C<__> subroutine makes extensive use of operator overloading to
+perform its magic. All operations involving __ are overloaded to
+produce an anonymous subroutine that implements a lazy version
+of the original operation.
+
+The only problem is that operator overloading does not allow the
+boolean operators C<&&> and C<||> to be overloaded. So a case statement
+like this:
+
+        case  0 <= __ && __ < 10  { return 'digit' }  
+
+doesn't act as expected, because when it is
+executed, it constructs two higher order subroutines
+and then treats the two resulting references as arguments to C<&&>:
+
+        sub { 0 <= $_[0] } && sub { $_[0] < 10 }
+
+This boolean expression is inevitably true, since both references are
+non-false. Fortunately, the overloaded C<'bool'> operator catches this
+situation and flags it as a error. 
+
+=head1 DEPENDENCIES
+
+The module is implemented using Filter::Util::Call and Text::Balanced
+and requires both these modules to be installed. 
+
+=head1 AUTHOR
+
+Damian Conway (damian@conway.org)
+
+=head1 BUGS
+
+There are undoubtedly serious bugs lurking somewhere in code this funky :-)
+Bug reports and other feedback are most welcome.
+
+=head1 COPYRIGHT
+
+Copyright (c) 1997-2000, Damian Conway. All Rights Reserved.
+This module is free software. It may be used, redistributed
+and/or modified under the terms of the Perl Artistic License
+  (see http://www.perl.com/perl/misc/Artistic.html)
diff --git a/t/lib/switch.t b/t/lib/switch.t
new file mode 100644 (file)
index 0000000..3fcd5ca
--- /dev/null
@@ -0,0 +1,285 @@
+BEGIN {
+    chdir 't' if -d 't';
+    @INC = '../lib';
+}
+
+use Carp;
+use Switch qw(__ fallthrough);
+
+print "1..293\n";
+
+my $count = 0;
+sub ok($)
+{
+       $count++;
+       print "line ", (caller)[2], "; " unless $_[0];
+       print "not " unless $_[0];
+       print "ok $count\n";
+}
+
+# NON-case THINGS;
+
+$case->{case} = { case => "case" };
+
+*case = \&case;
+
+# PREMATURE case
+
+eval { case 1 { ok(0) }; ok(0) } || ok(1);
+
+# H.O. FUNCS
+
+switch (__ > 2) {
+
+       case 1  { ok(0) } else { ok(1) }
+       case 2  { ok(0) } else { ok(1) }
+       case 3  { ok(1) } else { ok(0) }
+}
+
+switch (3) {
+
+       eval { case __ <= 1 || __ > 2   { ok(0) } } || ok(1);
+       case __ <= 2            { ok(0) };
+       case __ <= 3            { ok(1) };
+}
+
+# POSSIBLE ARGS: NUMERIC, STRING, ARRAY, HASH, REGEX, CODE
+
+# 1. NUMERIC SWITCH
+
+for (1..3)
+{
+       switch ($_) {
+               # SELF
+               case ($_) { ok(1) } else { ok(0) }
+
+               # NUMERIC
+               case (1) { ok ($_==1) } else { ok($_!=1) }
+               case  1  { ok ($_==1) } else { ok($_!=1) }
+               case (3) { ok ($_==3) } else { ok($_!=3) }
+               case (4) { ok (0) } else { ok(1) }
+               case (2) { ok ($_==2) } else { ok($_!=2) }
+
+               # STRING
+               case ('a') { ok (0) } else { ok(1) }
+               case  'a'  { ok (0) } else { ok(1) }
+               case ('3') { ok ($_ == 3) } else { ok($_ != 3) }
+               case ('3.0') { ok (0) } else { ok(1) }
+
+               # ARRAY
+               case ([10,5,1]) { ok ($_==1) } else { ok($_!=1) }
+               case  [10,5,1]  { ok ($_==1) } else { ok($_!=1) }
+               case (['a','b']) { ok (0) } else { ok(1) }
+               case (['a','b',3]) { ok ($_==3) } else { ok ($_!=3) }
+               case (['a','b',2.0]) { ok ($_==2) } else { ok ($_!=2) }
+               case ([]) { ok (0) } else { ok(1) }
+
+               # HASH
+               case ({}) { ok (0) } else { ok (1) }
+               case {} { ok (0) } else { ok (1) }
+               case {1,1} { ok ($_==1) } else { ok($_!=1) }
+               case ({1=>1, 2=>0}) { ok ($_==1) } else { ok($_!=1) }
+
+               # SUB/BLOCK
+               case (sub {$_[0]==2}) { ok ($_==2) } else { ok($_!=2) }
+               case {$_[0]==2} { ok ($_==2) } else { ok($_!=2) }
+               case {0} { ok (0) } else { ok (1) }     # ; -> SUB, NOT HASH
+               case {1} { ok (1) } else { ok (0) }     # ; -> SUB, NOT HASH
+       }
+}
+
+
+# 2. STRING SWITCH
+
+for ('a'..'c','1')
+{
+       switch ($_) {
+               # SELF
+               case ($_) { ok(1) } else { ok(0) }
+
+               # NUMERIC
+               case (1)  { ok ($_ !~ /[a-c]/) } else { ok ($_ =~ /[a-c]/) }
+               case (1.0) { ok ($_ !~ /[a-c]/) } else { ok ($_ =~ /[a-c]/) }
+
+               # STRING
+               case ('a') { ok ($_ eq 'a') } else { ok($_ ne 'a') }
+               case ('b') { ok ($_ eq 'b') } else { ok($_ ne 'b') }
+               case ('c') { ok ($_ eq 'c') } else { ok($_ ne 'c') }
+               case ('1') { ok ($_ eq '1') } else { ok($_ ne '1') }
+               case ('d') { ok (0) } else { ok (1) }
+
+               # ARRAY
+               case (['a','1']) { ok ($_ eq 'a' || $_ eq '1') }
+                       else { ok ($_ ne 'a' && $_ ne '1') }
+               case (['z','2']) { ok (0) } else { ok(1) }
+               case ([]) { ok (0) } else { ok(1) }
+
+               # HASH
+               case ({}) { ok (0) } else { ok (1) }
+               case ({a=>'a', 1=>1, 2=>0}) { ok ($_ eq 'a' || $_ eq '1') }
+                       else { ok ($_ ne 'a' && $_ ne '1') }
+
+               # SUB/BLOCK
+               case (sub{$_[0] eq 'a' }) { ok ($_ eq 'a') }
+                       else { ok($_ ne 'a') }
+               case {$_[0] eq 'a'} { ok ($_ eq 'a') } else { ok($_ ne 'a') }
+               case {0} { ok (0) } else { ok (1) }     # ; -> SUB, NOT HASH
+               case {1} { ok (1) } else { ok (0) }     # ; -> SUB, NOT HASH
+       }
+}
+
+
+# 3. ARRAY SWITCH
+
+my $iteration = 0;
+for ([],[1,'a'],[2,'b'])
+{
+       switch ($_) {
+       $iteration++;
+               # SELF
+               case ($_) { ok(1) }
+
+               # NUMERIC
+               case (1) { ok ($iteration==2) } else { ok ($iteration!=2) }
+               case (1.0) { ok ($iteration==2) } else { ok ($iteration!=2) }
+
+               # STRING
+               case ('a') { ok ($iteration==2) } else { ok ($iteration!=2) }
+               case ('b') { ok ($iteration==3) } else { ok ($iteration!=3) }
+               case ('1') { ok ($iteration==2) } else { ok ($iteration!=2) }
+
+               # ARRAY
+               case (['a',2]) { ok ($iteration>=2) } else { ok ($iteration<2) }
+               case ([1,'a']) { ok ($iteration==2) } else { ok($iteration!=2) }
+               case ([]) { ok (0) } else { ok(1) }
+               case ([7..100]) { ok (0) } else { ok(1) }
+
+               # HASH
+               case ({}) { ok (0) } else { ok (1) }
+               case ({a=>'a', 1=>1, 2=>0}) { ok ($iteration==2) }
+                       else { ok ($iteration!=2) }
+
+               # SUB/BLOCK
+               case {scalar grep /a/, @_} { ok ($iteration==2) }
+                       else { ok ($iteration!=2) }
+               case (sub {scalar grep /a/, @_ }) { ok ($iteration==2) }
+                       else { ok ($iteration!=2) }
+               case {0} { ok (0) } else { ok (1) }     # ; -> SUB, NOT HASH
+               case {1} { ok (1) } else { ok (0) }     # ; -> SUB, NOT HASH
+       }
+}
+
+
+# 4. HASH SWITCH
+
+$iteration = 0;
+for ({},{a=>1,b=>0})
+{
+       switch ($_) {
+       $iteration++;
+
+               # SELF
+               case ($_) { ok(1) } else { ok(0) }
+
+               # NUMERIC
+               case (1) { ok (0) } else { ok (1) }
+               case (1.0) { ok (0) } else { ok (1) }
+
+               # STRING
+               case ('a') { ok ($iteration==2) } else { ok ($iteration!=2) }
+               case ('b') { ok (0) } else { ok (1) }
+               case ('c') { ok (0) } else { ok (1) }
+
+               # ARRAY
+               case (['a',2]) { ok ($iteration==2) }
+                       else { ok ($iteration!=2) }
+               case (['b','a']) { ok ($iteration==2) }
+                       else { ok ($iteration!=2) }
+               case (['b','c']) { ok (0) } else { ok (1) }
+               case ([]) { ok (0) } else { ok(1) }
+               case ([7..100]) { ok (0) } else { ok(1) }
+
+               # HASH
+               case ({}) { ok (0) } else { ok (1) }
+               case ({a=>'a', 1=>1, 2=>0}) { ok (0) } else { ok (1) }
+
+               # SUB/BLOCK
+               case {$_[0]{a}} { ok ($iteration==2) }
+                       else { ok ($iteration!=2) }
+               case (sub {$_[0]{a}}) { ok ($iteration==2) }
+                       else { ok ($iteration!=2) }
+               case {0} { ok (0) } else { ok (1) }     # ; -> SUB, NOT HASH
+               case {1} { ok (1) } else { ok (0) }     # ; -> SUB, NOT HASH
+       }
+}
+
+
+# 5. CODE SWITCH
+
+$iteration = 0;
+for ( sub {1},
+      sub { return 0 unless @_;
+           my ($data) = @_;
+           my $type = ref $data;
+           return $type eq 'HASH'   && $data->{a}
+               || $type eq 'Regexp' && 'a' =~ /$data/
+               || $type eq ""       && $data eq '1';
+         },
+      sub {0} )
+{
+       switch ($_) {
+       $iteration++;
+               # SELF
+               case ($_) { ok(1) } else { ok(0) }
+
+               # NUMERIC
+               case (1) { ok ($iteration<=2) } else { ok ($iteration>2) }
+               case (1.0) { ok ($iteration<=2) } else { ok ($iteration>2) }
+               case (1.1) { ok ($iteration==1) } else { ok ($iteration!=1) }
+
+               # STRING
+               case ('a') { ok ($iteration==1) } else { ok ($iteration!=1) }
+               case ('b') { ok ($iteration==1) } else { ok ($iteration!=1) }
+               case ('c') { ok ($iteration==1) } else { ok ($iteration!=1) }
+               case ('1') { ok ($iteration<=2) } else { ok ($iteration>2) }
+
+               # ARRAY
+               case ([1, 'a']) { ok ($iteration<=2) }
+                       else { ok ($iteration>2) }
+               case (['b','a']) { ok ($iteration==1) }
+                       else { ok ($iteration!=1) }
+               case (['b','c']) { ok ($iteration==1) }
+                       else { ok ($iteration!=1) }
+               case ([]) { ok ($iteration==1) } else { ok($iteration!=1) }
+               case ([7..100]) { ok ($iteration==1) }
+                       else { ok($iteration!=1) }
+
+               # HASH
+               case ({}) { ok ($iteration==1) } else { ok ($iteration!=1) }
+               case ({a=>'a', 1=>1, 2=>0}) { ok ($iteration<=2) }
+                       else { ok ($iteration>2) }
+
+               # SUB/BLOCK
+               case {$_[0]->{a}} { ok (0) } else { ok (1) }
+               case (sub {$_[0]{a}}) { ok (0) } else { ok (1) }
+               case {0} { ok (0) } else { ok (1) }     # ; -> SUB, NOT HASH
+               case {1} { ok (0) } else { ok (1) }     # ; -> SUB, NOT HASH
+       }
+}
+
+
+# NESTED SWITCHES
+
+for my $count (1..3)
+{
+       switch ([9,"a",11]) {
+               case (qr/\d/) {
+                               switch ($count) {
+                                       case (1)     { ok($count==1) }
+                                               else { ok($count!=1) }
+                                       case ([5,6]) { ok(0) } else { ok(1) }
+                               }
+                           }
+               ok(1) case (11);
+       }
+}