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