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