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