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