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