10 # LOAD FILTERING MODULE...
11 use Filter::Util::Call;
15 # CATCH ATTEMPTS TO CALL case OUTSIDE THE SCOPE OF ANY switch
17 $::_S_W_I_T_C_H = sub { croak "case/when statement not in switch/given block" };
21 my ($Perl5, $Perl6) = (0,0);
25 $fallthrough = grep /\bfallthrough\b/, @_;
26 $offset = (caller)[2]+1;
27 filter_add({}) unless @_>1 && $_[1] eq 'noimport';
30 for ( qw( on_defined on_exists ) )
32 *{"${pkg}::$_"} = \&$_;
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, @_);
48 local $Switch::file = (caller)[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;
58 use Text::Balanced ':ALL';
62 my ($pretext,$offset) = @_;
63 ($pretext=~tr/\n/\n/)+($offset||0);
68 local $SIG{__WARN__}=sub{die$@};
70 my $ishash = defined eval 'my $hr='.$_[0];
75 my $pod_or_DATA = qr/ ^=[A-Za-z] .*? ^=cut (?![A-Za-z]) .*? $
82 my ($source, $line) = @_;
83 return $source unless $Perl5 && $source =~ /case|switch/
84 || $Perl6 && $source =~ /when|given|default/;
87 component: while (pos $source < length $source)
89 if ($source =~ m/(\G\s*use\s+Switch\b)/gc)
91 $text .= q{use Switch 'noimport'};
94 my @pos = Text::Balanced::_match_quotelike(\$source,qr/\s*/,1,0);
97 my $pre = substr($source,$pos[0],$pos[1]); # matched prefix
99 if( substr($source,$pos[4],$pos[5]) eq '/' && # 1st delimiter
100 substr($source,$pos[2],$pos[3]) eq '' && # no op like 'm'
101 index( substr($source,$pos[16],$pos[17]), 'x' ) == -1 && # no //x
102 ($iEol = index( $source, "\n", $pos[4] )) > 0 &&
103 $iEol < $pos[8] ){ # embedded newlines
104 # If this is a pattern, it isn't compatible with Switch. Backup past 1st '/'.
105 pos( $source ) = $pos[6];
106 $text .= $pre . substr($source,$pos[2],$pos[6]-$pos[2]);
108 $text .= $pre . substr($source,$pos[2],$pos[18]-$pos[2]);
112 if ($source =~ m/(\G\s*$pod_or_DATA)/gc) {
116 @pos = Text::Balanced::_match_variable(\$source,qr/\s*/);
119 $text .= " " if $pos[0] < $pos[2];
120 $text .= substr($source,$pos[0],$pos[4]-$pos[0]);
124 if ($Perl5 && $source =~ m/\G(\n*)(\s*)(switch)\b(?=\s*[(])/gc
125 || $Perl6 && $source =~ m/\G(\n*)(\s*)(given)\b(?=\s*[(])/gc
126 || $Perl6 && $source =~ m/\G(\n*)(\s*)(given)\b(.*)(?=\{)/gc)
130 $text .= $1.$2.'S_W_I_T_C_H: while (1) ';
132 @pos = Text::Balanced::_match_codeblock(\$source,qr/\s*/,qr/\(/,qr/\)/,qr/[[{(<]/,qr/[]})>]/,undef)
134 die "Bad $keyword statement (problem in the parentheses?) near $Switch::file line ", line(substr($source,0,pos $source),$line), "\n";
136 $arg = filter_blocks(substr($source,$pos[0],$pos[4]-$pos[0]),line(substr($source,0,$pos[0]),$line));
138 $arg =~ s {^\s*[(]\s*%} { ( \\\%} ||
139 $arg =~ s {^\s*[(]\s*m\b} { ( qr} ||
140 $arg =~ s {^\s*[(]\s*/} { ( qr/} ||
141 $arg =~ s {^\s*[(]\s*qw} { ( \\qw};
142 @pos = Text::Balanced::_match_codeblock(\$source,qr/\s*/,qr/\{/,qr/\}/,qr/\{/,qr/\}/,undef)
144 die "Bad $keyword statement (problem in the code block?) near $Switch::file line ", line(substr($source,0, pos $source), $line), "\n";
146 my $code = filter_blocks(substr($source,$pos[0],$pos[4]-$pos[0]),line(substr($source,0,$pos[0]),$line));
147 $code =~ s/{/{ local \$::_S_W_I_T_C_H; Switch::switch $arg;/;
148 $text .= $code . 'continue {last}';
151 elsif ($Perl5 && $source =~ m/\G(\s*)(case\b)(?!\s*=>)/gc
152 || $Perl6 && $source =~ m/\G(\s*)(when\b)(?!\s*=>)/gc
153 || $Perl6 && $source =~ m/\G(\s*)(default\b)(?=\s*\{)/gc)
156 $text .= $1 . ($keyword eq "default"
158 : "if (Switch::case");
160 if ($keyword eq "default") {
163 elsif (@pos = Text::Balanced::_match_codeblock(\$source,qr/\s*/,qr/\{/,qr/\}/,qr/\{/,qr/\}/,undef)) {
164 my $code = substr($source,$pos[0],$pos[4]-$pos[0]);
165 $text .= " " if $pos[0] < $pos[2];
166 $text .= "sub " if is_block $code;
167 $text .= filter_blocks($code,line(substr($source,0,$pos[0]),$line)) . ")";
169 elsif (@pos = Text::Balanced::_match_codeblock(\$source,qr/\s*/,qr/[[(]/,qr/[])]/,qr/[[({]/,qr/[])}]/,undef)) {
170 my $code = filter_blocks(substr($source,$pos[0],$pos[4]-$pos[0]),line(substr($source,0,$pos[0]),$line));
171 $code =~ s {^\s*[(]\s*%} { ( \\\%} ||
172 $code =~ s {^\s*[(]\s*m\b} { ( qr} ||
173 $code =~ s {^\s*[(]\s*/} { ( qr/} ||
174 $code =~ s {^\s*[(]\s*qw} { ( \\qw};
175 $text .= " " if $pos[0] < $pos[2];
178 elsif ($Perl6 && do{@pos = Text::Balanced::_match_variable(\$source,qr/\s*/)}) {
179 my $code = filter_blocks(substr($source,$pos[0],$pos[4]-$pos[0]),line(substr($source,0,$pos[0]),$line));
180 $code =~ s {^\s*%} { \%} ||
181 $code =~ s {^\s*@} { \@};
182 $text .= " " if $pos[0] < $pos[2];
185 elsif ( @pos = Text::Balanced::_match_quotelike(\$source,qr/\s*/,1,0)) {
186 my $code = substr($source,$pos[2],$pos[18]-$pos[2]);
187 $code = filter_blocks($code,line(substr($source,0,$pos[2]),$line));
188 $code =~ s {^\s*m} { qr} ||
189 $code =~ s {^\s*/} { qr/} ||
190 $code =~ s {^\s*qw} { \\qw};
191 $text .= " " if $pos[0] < $pos[2];
194 elsif ($Perl5 && $source =~ m/\G\s*(([^\$\@{])[^\$\@{]*)(?=\s*{)/gc
195 || $Perl6 && $source =~ m/\G\s*([^;{]*)()/gc) {
196 my $code = filter_blocks($1,line(substr($source,0,pos $source),$line));
197 $text .= ' \\' if $2 eq '%';
201 die "Bad $keyword statement (invalid $keyword value?) near $Switch::file line ", line(substr($source,0,pos $source), $line), "\n";
204 die "Missing opening brace or semi-colon after 'when' value near $Switch::file line ", line(substr($source,0,pos $source), $line), "\n"
205 unless !$Perl6 || $source =~ m/\G(\s*)(?=;|\{)/gc;
207 do{@pos = Text::Balanced::_match_codeblock(\$source,qr/\s*/,qr/\{/,qr/\}/,qr/\{/,qr/\}/,undef)}
209 if ($source =~ m/\G\s*(?=([};]|\Z))/gc) {
213 die "Bad $keyword statement (problem in the code block?) near $Switch::file line ", line(substr($source,0,pos $source),$line), "\n";
215 my $code = filter_blocks(substr($source,$pos[0],$pos[4]-$pos[0]),line(substr($source,0,$pos[0]),$line));
216 $code =~ s/}(?=\s*\Z)/;last S_W_I_T_C_H }/
218 $text .= "{ while (1) $code continue { goto C_A_S_E_$casecounter } last S_W_I_T_C_H; C_A_S_E_$casecounter: }";
223 $source =~ m/\G(\s*(-[sm]\s+|\w+|#.*\n|\W))/gc;
235 for my $nextx ( @$x )
237 my $numx = ref($nextx) || defined $nextx && (~$nextx&$nextx) eq 0;
238 for my $j ( 0..$#$y )
240 my $nexty = $y->[$j];
241 push @numy, ref($nexty) || defined $nexty && (~$nexty&$nexty) eq 0
243 return 1 if $numx && $numy[$j] && $nextx==$nexty
253 my $ref = @_==1 && ref($_[0]) eq 'HASH' ? $_[0] : { @_ };
259 my $ref = @_==1 && ref($_[0]) eq 'HASH' ? $_[0] : { @_ };
260 [ grep { defined $ref->{$_} } keys %$ref ]
265 my ($s_val) = @_ ? $_[0] : $_;
266 my $s_ref = ref $s_val;
268 if ($s_ref eq 'CODE')
271 sub { my $c_val = $_[0];
272 return $s_val == $c_val if ref $c_val eq 'CODE';
273 return $s_val->(@$c_val) if ref $c_val eq 'ARRAY';
274 return $s_val->($c_val);
277 elsif ($s_ref eq "" && defined $s_val && (~$s_val&$s_val) eq 0) # NUMERIC SCALAR
280 sub { my $c_val = $_[0];
281 my $c_ref = ref $c_val;
282 return $s_val == $c_val if $c_ref eq ""
284 && (~$c_val&$c_val) eq 0;
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}
296 elsif ($s_ref eq "") # STRING SCALAR
299 sub { my $c_val = $_[0];
300 my $c_ref = ref $c_val;
301 return $s_val eq $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) if $c_ref eq 'Switch';
305 return scalar $s_val=~/$c_val/
306 if $c_ref eq 'Regexp';
307 return scalar $c_val->{$s_val}
312 elsif ($s_ref eq 'ARRAY')
315 sub { my $c_val = $_[0];
316 my $c_ref = ref $c_val;
317 return in($s_val,[$c_val]) if $c_ref eq "";
318 return in($s_val,$c_val) if $c_ref eq 'ARRAY';
319 return $c_val->(@$s_val) if $c_ref eq 'CODE';
320 return $c_val->call(@$s_val)
321 if $c_ref eq 'Switch';
322 return scalar grep {$_=~/$c_val/} @$s_val
323 if $c_ref eq 'Regexp';
324 return scalar grep {$c_val->{$_}} @$s_val
329 elsif ($s_ref eq 'Regexp')
332 sub { my $c_val = $_[0];
333 my $c_ref = ref $c_val;
334 return $c_val=~/s_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 $s_val eq $c_val if $c_ref eq 'Regexp';
340 return grep {$_=~/$s_val/ && $c_val->{$_}} keys %$c_val
345 elsif ($s_ref eq 'HASH')
348 sub { my $c_val = $_[0];
349 my $c_ref = ref $c_val;
350 return $s_val->{$c_val} if $c_ref eq "";
351 return scalar grep {$s_val->{$_}} @$c_val
352 if $c_ref eq 'ARRAY';
353 return $c_val->($s_val) if $c_ref eq 'CODE';
354 return $c_val->call($s_val) if $c_ref eq 'Switch';
355 return grep {$_=~/$c_val/ && $s_val->{"$_"}} keys %$s_val
356 if $c_ref eq 'Regexp';
357 return $s_val==$c_val if $c_ref eq 'HASH';
361 elsif ($s_ref eq 'Switch')
364 sub { my $c_val = $_[0];
365 return $s_val == $c_val if ref $c_val eq 'Switch';
366 return $s_val->call(@$c_val)
367 if ref $c_val eq 'ARRAY';
368 return $s_val->call($c_val);
373 croak "Cannot switch on $s_ref";
378 sub case($) { local $SIG{__WARN__} = \&carp;
379 $::_S_W_I_T_C_H->(@_); }
383 my $placeholder = bless { arity=>1, impl=>sub{$_[1+$_[0]]} };
385 sub __() { $placeholder }
390 bless { arity=>0, impl=>sub{$_[$index]} };
400 my ($self,@args) = @_;
401 return $self->{impl}->(0,@args);
409 my ($left, $right, $reversed) = @_;
410 ($right,$left) = @_ if $reversed;
412 my $rop = ref $right eq 'Switch'
414 : bless { arity=>0, impl=>sub{$right} };
416 my $lop = ref $left eq 'Switch'
418 : bless { arity=>0, impl=>sub{$left} };
420 my $arity = $lop->{arity} + $rop->{arity};
424 impl => sub { my $start = shift;
425 return $op->($lop->{impl}->($start,@_),
426 $rop->{impl}->($start+$lop->{arity},@_));
439 my $lop = ref $left eq 'Switch'
441 : bless { arity=>0, impl=>sub{$left} };
443 my $arity = $lop->{arity};
447 impl => sub { $op->($lop->{impl}->(@_)) }
454 "+" => meta_bop {$_[0] + $_[1]},
455 "-" => meta_bop {$_[0] - $_[1]},
456 "*" => meta_bop {$_[0] * $_[1]},
457 "/" => meta_bop {$_[0] / $_[1]},
458 "%" => meta_bop {$_[0] % $_[1]},
459 "**" => meta_bop {$_[0] ** $_[1]},
460 "<<" => meta_bop {$_[0] << $_[1]},
461 ">>" => meta_bop {$_[0] >> $_[1]},
462 "x" => meta_bop {$_[0] x $_[1]},
463 "." => meta_bop {$_[0] . $_[1]},
464 "<" => meta_bop {$_[0] < $_[1]},
465 "<=" => meta_bop {$_[0] <= $_[1]},
466 ">" => meta_bop {$_[0] > $_[1]},
467 ">=" => meta_bop {$_[0] >= $_[1]},
468 "==" => meta_bop {$_[0] == $_[1]},
469 "!=" => meta_bop {$_[0] != $_[1]},
470 "<=>" => meta_bop {$_[0] <=> $_[1]},
471 "lt" => meta_bop {$_[0] lt $_[1]},
472 "le" => meta_bop {$_[0] le $_[1]},
473 "gt" => meta_bop {$_[0] gt $_[1]},
474 "ge" => meta_bop {$_[0] ge $_[1]},
475 "eq" => meta_bop {$_[0] eq $_[1]},
476 "ne" => meta_bop {$_[0] ne $_[1]},
477 "cmp" => meta_bop {$_[0] cmp $_[1]},
478 "\&" => meta_bop {$_[0] & $_[1]},
479 "^" => meta_bop {$_[0] ^ $_[1]},
480 "|" => meta_bop {$_[0] | $_[1]},
481 "atan2" => meta_bop {atan2 $_[0], $_[1]},
483 "neg" => meta_uop {-$_[0]},
484 "!" => meta_uop {!$_[0]},
485 "~" => meta_uop {~$_[0]},
486 "cos" => meta_uop {cos $_[0]},
487 "sin" => meta_uop {sin $_[0]},
488 "exp" => meta_uop {exp $_[0]},
489 "abs" => meta_uop {abs $_[0]},
490 "log" => meta_uop {log $_[0]},
491 "sqrt" => meta_uop {sqrt $_[0]},
492 "bool" => sub { croak "Can't use && or || in expression containing __" },
494 # "&()" => sub { $_[0]->{impl} },
496 # "||" => meta_bop {$_[0] || $_[1]},
497 # "&&" => meta_bop {$_[0] && $_[1]},
507 Switch - A switch statement for Perl
511 This document describes version 2.14 of Switch,
512 released Dec 29, 2008.
519 case 1 { print "number 1" }
520 case "a" { print "string a" }
521 case [1..10,42] { print "number in list" }
522 case (\@array) { print "number in list" }
523 case /\w+/ { print "pattern" }
524 case qr/\w+/ { print "pattern" }
525 case (\%hash) { print "entry in hash" }
526 case (\&sub) { print "arg to subroutine" }
527 else { print "previous case not true" }
532 [Skip ahead to L<"DESCRIPTION"> if you don't care about the whys
533 and wherefores of this control structure]
535 In seeking to devise a "Swiss Army" case mechanism suitable for Perl,
536 it is useful to generalize this notion of distributed conditional
537 testing as far as possible. Specifically, the concept of "matching"
538 between the switch value and the various case values need not be
539 restricted to numeric (or string or referential) equality, as it is in other
540 languages. Indeed, as Table 1 illustrates, Perl
541 offers at least eighteen different ways in which two values could
544 Table 1: Matching a switch value ($s) with a case value ($c)
546 Switch Case Type of Match Implied Matching Code
548 ====== ===== ===================== =============
550 number same numeric or referential match if $s == $c;
553 object method result of method call match if $s->$c();
554 ref name match if defined $s->$c();
557 other other string equality match if $s eq $c;
561 string regexp pattern match match if $s =~ /$c/;
563 array scalar array entry existence match if 0<=$c && $c<@$s;
564 ref array entry definition match if defined $s->[$c];
565 array entry truth match if $s->[$c];
567 array array array intersection match if intersects(@$s, @$c);
568 ref ref (apply this table to
569 all pairs of elements
573 array regexp array grep match if grep /$c/, @$s;
576 hash scalar hash entry existence match if exists $s->{$c};
577 ref hash entry definition match if defined $s->{$c};
578 hash entry truth match if $s->{$c};
580 hash regexp hash grep match if grep /$c/, keys %$s;
583 sub scalar return value defn match if defined $s->($c);
584 ref return value truth match if $s->($c);
586 sub array return value defn match if defined $s->(@$c);
587 ref ref return value truth match if $s->(@$c);
590 In reality, Table 1 covers 31 alternatives, because only the equality and
591 intersection tests are commutative; in all other cases, the roles of
592 the C<$s> and C<$c> variables could be reversed to produce a
593 different test. For example, instead of testing a single hash for
594 the existence of a series of keys (C<match if exists $s-E<gt>{$c}>),
595 one could test for the existence of a single key in a series of hashes
596 (C<match if exists $c-E<gt>{$s}>).
600 The Switch.pm module implements a generalized case mechanism that covers
601 most (but not all) of the numerous possible combinations of switch and case
602 values described above.
604 The module augments the standard Perl syntax with two new control
605 statements: C<switch> and C<case>. The C<switch> statement takes a
606 single scalar argument of any type, specified in parentheses.
607 C<switch> stores this value as the
608 current switch value in a (localized) control variable.
609 The value is followed by a block which may contain one or more
610 Perl statements (including the C<case> statement described below).
611 The block is unconditionally executed once the switch value has
614 A C<case> statement takes a single scalar argument (in mandatory
615 parentheses if it's a variable; otherwise the parens are optional) and
616 selects the appropriate type of matching between that argument and the
617 current switch value. The type of matching used is determined by the
618 respective types of the switch value and the C<case> argument, as
619 specified in Table 1. If the match is successful, the mandatory
620 block associated with the C<case> statement is executed.
622 In most other respects, the C<case> statement is semantically identical
623 to an C<if> statement. For example, it can be followed by an C<else>
624 clause, and can be used as a postfix statement qualifier.
626 However, when a C<case> block has been executed control is automatically
627 transferred to the statement after the immediately enclosing C<switch>
628 block, rather than to the next statement within the block. In other
629 words, the success of any C<case> statement prevents other cases in the
630 same scope from executing. But see L<"Allowing fall-through"> below.
632 Together these two new statements provide a fully generalized case
639 %special = ( woohoo => 1, d'oh => 1 );
644 case (%special) { print "homer\n"; } # if $special{$_}
645 case /[a-z]/i { print "alpha\n"; } # if $_ =~ /a-z/i
646 case [1..9] { print "small num\n"; } # if $_ in [1..9]
647 case { $_[0] >= 10 } { print "big num\n"; } # if $_ >= 10
648 print "must be punctuation\n" case /\W/; # if $_ ~= /\W/
652 Note that C<switch>es can be nested within C<case> (or any other) blocks,
653 and a series of C<case> statements can try different types of matches
654 -- hash membership, pattern match, array intersection, simple equality,
655 etc. -- against the same switch value.
657 The use of intersection tests against an array reference is particularly
658 useful for aggregating integral cases:
662 switch ($_[0]) { case 0 { return 'zero' }
663 case [2,4,6,8] { return 'even' }
664 case [1,3,5,7,9] { return 'odd' }
665 case /[A-F]/i { return 'hex' }
670 =head2 Allowing fall-through
672 Fall-though (trying another case after one has already succeeded)
673 is usually a Bad Idea in a switch statement. However, this
674 is Perl, not a police state, so there I<is> a way to do it, if you must.
676 If a C<case> block executes an untargeted C<next>, control is
677 immediately transferred to the statement I<after> the C<case> statement
678 (i.e. usually another case), rather than out of the surrounding
684 case 1 { handle_num_1(); next } # and try next case...
685 case "1" { handle_str_1(); next } # and try next case...
686 case [0..9] { handle_num_any(); } # and we're done
687 case /\d/ { handle_dig_any(); next } # and try next case...
688 case /.*/ { handle_str_any(); next } # and try next case...
691 If $val held the number C<1>, the above C<switch> block would call the
692 first three C<handle_...> subroutines, jumping to the next case test
693 each time it encountered a C<next>. After the third C<case> block
694 was executed, control would jump to the end of the enclosing
697 On the other hand, if $val held C<10>, then only the last two C<handle_...>
698 subroutines would be called.
700 Note that this mechanism allows the notion of I<conditional fall-through>.
704 case [0..9] { handle_num_any(); next if $val < 7; }
705 case /\d/ { handle_dig_any(); }
708 If an untargeted C<last> statement is executed in a case block, this
709 immediately transfers control out of the enclosing C<switch> block
710 (in other words, there is an implicit C<last> at the end of each
711 normal C<case> block). Thus the previous example could also have been
715 case [0..9] { handle_num_any(); last if $val >= 7; next; }
716 case /\d/ { handle_dig_any(); }
720 =head2 Automating fall-through
722 In situations where case fall-through should be the norm, rather than an
723 exception, an endless succession of terminal C<next>s is tedious and ugly.
724 Hence, it is possible to reverse the default behaviour by specifying
725 the string "fallthrough" when importing the module. For example, the
726 following code is equivalent to the first example in L<"Allowing fall-through">:
728 use Switch 'fallthrough';
731 case 1 { handle_num_1(); }
732 case "1" { handle_str_1(); }
733 case [0..9] { handle_num_any(); last }
734 case /\d/ { handle_dig_any(); }
735 case /.*/ { handle_str_any(); }
738 Note the explicit use of a C<last> to preserve the non-fall-through
739 behaviour of the third case.
743 =head2 Alternative syntax
745 Perl 6 will provide a built-in switch statement with essentially the
746 same semantics as those offered by Switch.pm, but with a different
747 pair of keywords. In Perl 6 C<switch> will be spelled C<given>, and
748 C<case> will be pronounced C<when>. In addition, the C<when> statement
749 will not require switch or case values to be parenthesized.
751 This future syntax is also (largely) available via the Switch.pm module, by
752 importing it with the argument C<"Perl6">. For example:
757 when 1 { handle_num_1(); }
758 when ($str1) { handle_str_1(); }
759 when [0..9] { handle_num_any(); last }
760 when /\d/ { handle_dig_any(); }
761 when /.*/ { handle_str_any(); }
762 default { handle anything else; }
765 Note that scalars still need to be parenthesized, since they would be
768 Note too that you can mix and match both syntaxes by importing the module
771 use Switch 'Perl5', 'Perl6';
774 =head2 Higher-order Operations
776 One situation in which C<switch> and C<case> do not provide a good
777 substitute for a cascaded C<if>, is where a switch value needs to
778 be tested against a series of conditions. For example:
782 case { $_[0] < 10 } { return 'milk' }
783 case { $_[0] < 20 } { return 'coke' }
784 case { $_[0] < 30 } { return 'beer' }
785 case { $_[0] < 40 } { return 'wine' }
786 case { $_[0] < 50 } { return 'malt' }
787 case { $_[0] < 60 } { return 'Moet' }
788 else { return 'milk' }
792 (This is equivalent to writing C<case (sub { $_[0] < 10 })>, etc.; C<$_[0]>
793 is the argument to the anonymous subroutine.)
795 The need to specify each condition as a subroutine block is tiresome. To
796 overcome this, when importing Switch.pm, a special "placeholder"
797 subroutine named C<__> [sic] may also be imported. This subroutine
798 converts (almost) any expression in which it appears to a reference to a
799 higher-order function. That is, the expression:
809 With C<__>, the previous ugly case statements can be rewritten:
811 case __ < 10 { return 'milk' }
812 case __ < 20 { return 'coke' }
813 case __ < 30 { return 'beer' }
814 case __ < 40 { return 'wine' }
815 case __ < 50 { return 'malt' }
816 case __ < 60 { return 'Moet' }
817 else { return 'milk' }
819 The C<__> subroutine makes extensive use of operator overloading to
820 perform its magic. All operations involving __ are overloaded to
821 produce an anonymous subroutine that implements a lazy version
822 of the original operation.
824 The only problem is that operator overloading does not allow the
825 boolean operators C<&&> and C<||> to be overloaded. So a case statement
828 case 0 <= __ && __ < 10 { return 'digit' }
830 doesn't act as expected, because when it is
831 executed, it constructs two higher order subroutines
832 and then treats the two resulting references as arguments to C<&&>:
834 sub { 0 <= $_[0] } && sub { $_[0] < 10 }
836 This boolean expression is inevitably true, since both references are
837 non-false. Fortunately, the overloaded C<'bool'> operator catches this
838 situation and flags it as an error.
842 The module is implemented using Filter::Util::Call and Text::Balanced
843 and requires both these modules to be installed.
847 Damian Conway (damian@conway.org). This module is now maintained by Rafael
848 Garcia-Suarez (rgarciasuarez@gmail.com) and more generally by the Perl 5
849 Porters (perl5-porters@perl.org), as part of the Perl core.
853 There are undoubtedly serious bugs lurking somewhere in code this funky :-)
854 Bug reports and other feedback are most welcome.
858 Due to the heuristic nature of Switch.pm's source parsing, the presence of
859 regexes with embedded newlines that are specified with raw C</.../>
860 delimiters and don't have a modifier C<//x> are indistinguishable from
861 code chunks beginning with the division operator C</>. As a workaround
862 you must use C<m/.../> or C<m?...?> for such patterns. Also, the presence
863 of regexes specified with raw C<?...?> delimiters may cause mysterious
864 errors. The workaround is to use C<m?...?> instead.
866 Due to the way source filters work in Perl, you can't use Switch inside
869 If your source file is longer then 1 million characters and you have a
870 switch statement that crosses the 1 million (or 2 million, etc.)
871 character boundary you will get mysterious errors. The workaround is to
872 use smaller source files.
876 Copyright (c) 1997-2008, Damian Conway. All Rights Reserved.
877 This module is free software. It may be used, redistributed
878 and/or modified under the same terms as Perl itself.