7 use if $] >= 5.011, 'deprecate';
12 # LOAD FILTERING MODULE...
13 use Filter::Util::Call;
17 # CATCH ATTEMPTS TO CALL case OUTSIDE THE SCOPE OF ANY switch
19 $::_S_W_I_T_C_H = sub { croak "case/when statement not in switch/given block" };
23 my ($Perl5, $Perl6) = (0,0);
27 $fallthrough = grep /\bfallthrough\b/, @_;
28 $offset = (caller)[2]+1;
29 filter_add({}) unless @_>1 && $_[1] eq 'noimport';
32 for ( qw( on_defined on_exists ) )
34 *{"${pkg}::$_"} = \&$_;
36 *{"${pkg}::__"} = \&__ if grep /__/, @_;
37 $Perl6 = 1 if grep(/Perl\s*6/i, @_);
38 $Perl5 = 1 if grep(/Perl\s*5/i, @_) || !grep(/Perl\s*6/i, @_);
50 local $Switch::file = (caller)[1];
53 $status = filter_read(1_000_000);
54 return $status if $status<0;
55 $_ = filter_blocks($_,$offset);
56 $_ = "# line $offset\n" . $_ if $offset; undef $offset;
60 use Text::Balanced ':ALL';
64 my ($pretext,$offset) = @_;
65 ($pretext=~tr/\n/\n/)+($offset||0);
70 local $SIG{__WARN__}=sub{die$@};
72 my $ishash = defined eval 'my $hr='.$_[0];
77 my $pod_or_DATA = qr/ ^=[A-Za-z] .*? ^=cut (?![A-Za-z]) .*? $
84 my ($source, $line) = @_;
85 return $source unless $Perl5 && $source =~ /case|switch/
86 || $Perl6 && $source =~ /when|given|default/;
89 component: while (pos $source < length $source)
91 if ($source =~ m/(\G\s*use\s+Switch\b)/gc)
93 $text .= q{use Switch 'noimport'};
96 my @pos = Text::Balanced::_match_quotelike(\$source,qr/\s*/,1,0);
99 my $pre = substr($source,$pos[0],$pos[1]); # matched prefix
101 if( substr($source,$pos[4],$pos[5]) eq '/' && # 1st delimiter
102 substr($source,$pos[2],$pos[3]) eq '' && # no op like 'm'
103 index( substr($source,$pos[16],$pos[17]), 'x' ) == -1 && # no //x
104 ($iEol = index( $source, "\n", $pos[4] )) > 0 &&
105 $iEol < $pos[8] ){ # embedded newlines
106 # If this is a pattern, it isn't compatible with Switch. Backup past 1st '/'.
107 pos( $source ) = $pos[6];
108 $text .= $pre . substr($source,$pos[2],$pos[6]-$pos[2]);
110 $text .= $pre . substr($source,$pos[2],$pos[18]-$pos[2]);
114 if ($source =~ m/(\G\s*$pod_or_DATA)/gc) {
118 @pos = Text::Balanced::_match_variable(\$source,qr/\s*/);
121 $text .= " " if $pos[0] < $pos[2];
122 $text .= substr($source,$pos[0],$pos[4]-$pos[0]);
126 if ($Perl5 && $source =~ m/\G(\n*)(\s*)(switch)\b(?=\s*[(])/gc
127 || $Perl6 && $source =~ m/\G(\n*)(\s*)(given)\b(?=\s*[(])/gc
128 || $Perl6 && $source =~ m/\G(\n*)(\s*)(given)\b(.*)(?=\{)/gc)
132 $text .= $1.$2.'S_W_I_T_C_H: while (1) ';
134 @pos = Text::Balanced::_match_codeblock(\$source,qr/\s*/,qr/\(/,qr/\)/,qr/[[{(<]/,qr/[]})>]/,undef)
136 die "Bad $keyword statement (problem in the parentheses?) near $Switch::file line ", line(substr($source,0,pos $source),$line), "\n";
138 $arg = filter_blocks(substr($source,$pos[0],$pos[4]-$pos[0]),line(substr($source,0,$pos[0]),$line));
140 $arg =~ s {^\s*[(]\s*%} { ( \\\%} ||
141 $arg =~ s {^\s*[(]\s*m\b} { ( qr} ||
142 $arg =~ s {^\s*[(]\s*/} { ( qr/} ||
143 $arg =~ s {^\s*[(]\s*qw} { ( \\qw};
144 @pos = Text::Balanced::_match_codeblock(\$source,qr/\s*/,qr/\{/,qr/\}/,qr/\{/,qr/\}/,undef)
146 die "Bad $keyword statement (problem in the code block?) near $Switch::file line ", line(substr($source,0, pos $source), $line), "\n";
148 my $code = filter_blocks(substr($source,$pos[0],$pos[4]-$pos[0]),line(substr($source,0,$pos[0]),$line));
149 $code =~ s/{/{ local \$::_S_W_I_T_C_H; Switch::switch $arg;/;
150 $text .= $code . 'continue {last}';
153 elsif ($Perl5 && $source =~ m/\G(\s*)(case\b)(?!\s*=>)/gc
154 || $Perl6 && $source =~ m/\G(\s*)(when\b)(?!\s*=>)/gc
155 || $Perl6 && $source =~ m/\G(\s*)(default\b)(?=\s*\{)/gc)
158 $text .= $1 . ($keyword eq "default"
160 : "if (Switch::case");
162 if ($keyword eq "default") {
165 elsif (@pos = Text::Balanced::_match_codeblock(\$source,qr/\s*/,qr/\{/,qr/\}/,qr/\{/,qr/\}/,undef)) {
166 my $code = substr($source,$pos[0],$pos[4]-$pos[0]);
167 $text .= " " if $pos[0] < $pos[2];
168 $text .= "sub " if is_block $code;
169 $text .= filter_blocks($code,line(substr($source,0,$pos[0]),$line)) . ")";
171 elsif (@pos = Text::Balanced::_match_codeblock(\$source,qr/\s*/,qr/[[(]/,qr/[])]/,qr/[[({]/,qr/[])}]/,undef)) {
172 my $code = filter_blocks(substr($source,$pos[0],$pos[4]-$pos[0]),line(substr($source,0,$pos[0]),$line));
173 $code =~ s {^\s*[(]\s*%} { ( \\\%} ||
174 $code =~ s {^\s*[(]\s*m\b} { ( qr} ||
175 $code =~ s {^\s*[(]\s*/} { ( qr/} ||
176 $code =~ s {^\s*[(]\s*qw} { ( \\qw};
177 $text .= " " if $pos[0] < $pos[2];
180 elsif ($Perl6 && do{@pos = Text::Balanced::_match_variable(\$source,qr/\s*/)}) {
181 my $code = filter_blocks(substr($source,$pos[0],$pos[4]-$pos[0]),line(substr($source,0,$pos[0]),$line));
182 $code =~ s {^\s*%} { \%} ||
183 $code =~ s {^\s*@} { \@};
184 $text .= " " if $pos[0] < $pos[2];
187 elsif ( @pos = Text::Balanced::_match_quotelike(\$source,qr/\s*/,1,0)) {
188 my $code = substr($source,$pos[2],$pos[18]-$pos[2]);
189 $code = filter_blocks($code,line(substr($source,0,$pos[2]),$line));
190 $code =~ s {^\s*m} { qr} ||
191 $code =~ s {^\s*/} { qr/} ||
192 $code =~ s {^\s*qw} { \\qw};
193 $text .= " " if $pos[0] < $pos[2];
196 elsif ($Perl5 && $source =~ m/\G\s*(([^\$\@{])[^\$\@{]*)(?=\s*{)/gc
197 || $Perl6 && $source =~ m/\G\s*([^;{]*)()/gc) {
198 my $code = filter_blocks($1,line(substr($source,0,pos $source),$line));
199 $text .= ' \\' if $2 eq '%';
203 die "Bad $keyword statement (invalid $keyword value?) near $Switch::file line ", line(substr($source,0,pos $source), $line), "\n";
206 die "Missing opening brace or semi-colon after 'when' value near $Switch::file line ", line(substr($source,0,pos $source), $line), "\n"
207 unless !$Perl6 || $source =~ m/\G(\s*)(?=;|\{)/gc;
209 do{@pos = Text::Balanced::_match_codeblock(\$source,qr/\s*/,qr/\{/,qr/\}/,qr/\{/,qr/\}/,undef)}
211 if ($source =~ m/\G\s*(?=([};]|\Z))/gc) {
215 die "Bad $keyword statement (problem in the code block?) near $Switch::file line ", line(substr($source,0,pos $source),$line), "\n";
217 my $code = filter_blocks(substr($source,$pos[0],$pos[4]-$pos[0]),line(substr($source,0,$pos[0]),$line));
218 $code =~ s/}(?=\s*\Z)/;last S_W_I_T_C_H }/
220 $text .= "{ while (1) $code continue { goto C_A_S_E_$casecounter } last S_W_I_T_C_H; C_A_S_E_$casecounter: }";
225 $source =~ m/\G(\s*(-[sm]\s+|\w+|#.*\n|\W))/gc;
237 for my $nextx ( @$x )
239 my $numx = ref($nextx) || defined $nextx && (~$nextx&$nextx) eq 0;
240 for my $j ( 0..$#$y )
242 my $nexty = $y->[$j];
243 push @numy, ref($nexty) || defined $nexty && (~$nexty&$nexty) eq 0
245 return 1 if $numx && $numy[$j] && $nextx==$nexty
255 my $ref = @_==1 && ref($_[0]) eq 'HASH' ? $_[0] : { @_ };
261 my $ref = @_==1 && ref($_[0]) eq 'HASH' ? $_[0] : { @_ };
262 [ grep { defined $ref->{$_} } keys %$ref ]
267 my ($s_val) = @_ ? $_[0] : $_;
268 my $s_ref = ref $s_val;
270 if ($s_ref eq 'CODE')
273 sub { my $c_val = $_[0];
274 return $s_val == $c_val if ref $c_val eq 'CODE';
275 return $s_val->(@$c_val) if ref $c_val eq 'ARRAY';
276 return $s_val->($c_val);
279 elsif ($s_ref eq "" && defined $s_val && (~$s_val&$s_val) eq 0) # NUMERIC SCALAR
282 sub { my $c_val = $_[0];
283 my $c_ref = ref $c_val;
284 return $s_val == $c_val if $c_ref eq ""
286 && (~$c_val&$c_val) eq 0;
287 return $s_val eq $c_val if $c_ref eq "";
288 return in([$s_val],$c_val) if $c_ref eq 'ARRAY';
289 return $c_val->($s_val) if $c_ref eq 'CODE';
290 return $c_val->call($s_val) if $c_ref eq 'Switch';
291 return scalar $s_val=~/$c_val/
292 if $c_ref eq 'Regexp';
293 return scalar $c_val->{$s_val}
298 elsif ($s_ref eq "") # STRING SCALAR
301 sub { my $c_val = $_[0];
302 my $c_ref = ref $c_val;
303 return $s_val eq $c_val if $c_ref eq "";
304 return in([$s_val],$c_val) if $c_ref eq 'ARRAY';
305 return $c_val->($s_val) if $c_ref eq 'CODE';
306 return $c_val->call($s_val) if $c_ref eq 'Switch';
307 return scalar $s_val=~/$c_val/
308 if $c_ref eq 'Regexp';
309 return scalar $c_val->{$s_val}
314 elsif ($s_ref eq 'ARRAY')
317 sub { my $c_val = $_[0];
318 my $c_ref = ref $c_val;
319 return in($s_val,[$c_val]) if $c_ref eq "";
320 return in($s_val,$c_val) if $c_ref eq 'ARRAY';
321 return $c_val->(@$s_val) if $c_ref eq 'CODE';
322 return $c_val->call(@$s_val)
323 if $c_ref eq 'Switch';
324 return scalar grep {$_=~/$c_val/} @$s_val
325 if $c_ref eq 'Regexp';
326 return scalar grep {$c_val->{$_}} @$s_val
331 elsif ($s_ref eq 'Regexp')
334 sub { my $c_val = $_[0];
335 my $c_ref = ref $c_val;
336 return $c_val=~/s_val/ if $c_ref eq "";
337 return scalar grep {$_=~/s_val/} @$c_val
338 if $c_ref eq 'ARRAY';
339 return $c_val->($s_val) if $c_ref eq 'CODE';
340 return $c_val->call($s_val) if $c_ref eq 'Switch';
341 return $s_val eq $c_val if $c_ref eq 'Regexp';
342 return grep {$_=~/$s_val/ && $c_val->{$_}} keys %$c_val
347 elsif ($s_ref eq 'HASH')
350 sub { my $c_val = $_[0];
351 my $c_ref = ref $c_val;
352 return $s_val->{$c_val} if $c_ref eq "";
353 return scalar grep {$s_val->{$_}} @$c_val
354 if $c_ref eq 'ARRAY';
355 return $c_val->($s_val) if $c_ref eq 'CODE';
356 return $c_val->call($s_val) if $c_ref eq 'Switch';
357 return grep {$_=~/$c_val/ && $s_val->{"$_"}} keys %$s_val
358 if $c_ref eq 'Regexp';
359 return $s_val==$c_val if $c_ref eq 'HASH';
363 elsif ($s_ref eq 'Switch')
366 sub { my $c_val = $_[0];
367 return $s_val == $c_val if ref $c_val eq 'Switch';
368 return $s_val->call(@$c_val)
369 if ref $c_val eq 'ARRAY';
370 return $s_val->call($c_val);
375 croak "Cannot switch on $s_ref";
380 sub case($) { local $SIG{__WARN__} = \&carp;
381 $::_S_W_I_T_C_H->(@_); }
385 my $placeholder = bless { arity=>1, impl=>sub{$_[1+$_[0]]} };
387 sub __() { $placeholder }
392 bless { arity=>0, impl=>sub{$_[$index]} };
402 my ($self,@args) = @_;
403 return $self->{impl}->(0,@args);
411 my ($left, $right, $reversed) = @_;
412 ($right,$left) = @_ if $reversed;
414 my $rop = ref $right eq 'Switch'
416 : bless { arity=>0, impl=>sub{$right} };
418 my $lop = ref $left eq 'Switch'
420 : bless { arity=>0, impl=>sub{$left} };
422 my $arity = $lop->{arity} + $rop->{arity};
426 impl => sub { my $start = shift;
427 return $op->($lop->{impl}->($start,@_),
428 $rop->{impl}->($start+$lop->{arity},@_));
441 my $lop = ref $left eq 'Switch'
443 : bless { arity=>0, impl=>sub{$left} };
445 my $arity = $lop->{arity};
449 impl => sub { $op->($lop->{impl}->(@_)) }
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 "<<" => meta_bop {$_[0] << $_[1]},
463 ">>" => meta_bop {$_[0] >> $_[1]},
464 "x" => meta_bop {$_[0] x $_[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 "!=" => meta_bop {$_[0] != $_[1]},
472 "<=>" => meta_bop {$_[0] <=> $_[1]},
473 "lt" => meta_bop {$_[0] lt $_[1]},
474 "le" => meta_bop {$_[0] le $_[1]},
475 "gt" => meta_bop {$_[0] gt $_[1]},
476 "ge" => meta_bop {$_[0] ge $_[1]},
477 "eq" => meta_bop {$_[0] eq $_[1]},
478 "ne" => meta_bop {$_[0] ne $_[1]},
479 "cmp" => meta_bop {$_[0] cmp $_[1]},
480 "\&" => meta_bop {$_[0] & $_[1]},
481 "^" => meta_bop {$_[0] ^ $_[1]},
482 "|" => meta_bop {$_[0] | $_[1]},
483 "atan2" => meta_bop {atan2 $_[0], $_[1]},
485 "neg" => meta_uop {-$_[0]},
486 "!" => meta_uop {!$_[0]},
487 "~" => meta_uop {~$_[0]},
488 "cos" => meta_uop {cos $_[0]},
489 "sin" => meta_uop {sin $_[0]},
490 "exp" => meta_uop {exp $_[0]},
491 "abs" => meta_uop {abs $_[0]},
492 "log" => meta_uop {log $_[0]},
493 "sqrt" => meta_uop {sqrt $_[0]},
494 "bool" => sub { croak "Can't use && or || in expression containing __" },
496 # "&()" => sub { $_[0]->{impl} },
498 # "||" => meta_bop {$_[0] || $_[1]},
499 # "&&" => meta_bop {$_[0] && $_[1]},
509 Switch - A switch statement for Perl
513 This document describes version 2.14 of Switch,
514 released Dec 29, 2008.
521 case 1 { print "number 1" }
522 case "a" { print "string a" }
523 case [1..10,42] { print "number in list" }
524 case (\@array) { print "number in list" }
525 case /\w+/ { print "pattern" }
526 case qr/\w+/ { print "pattern" }
527 case (\%hash) { print "entry in hash" }
528 case (\&sub) { print "arg to subroutine" }
529 else { print "previous case not true" }
534 [Skip ahead to L<"DESCRIPTION"> if you don't care about the whys
535 and wherefores of this control structure]
537 In seeking to devise a "Swiss Army" case mechanism suitable for Perl,
538 it is useful to generalize this notion of distributed conditional
539 testing as far as possible. Specifically, the concept of "matching"
540 between the switch value and the various case values need not be
541 restricted to numeric (or string or referential) equality, as it is in other
542 languages. Indeed, as Table 1 illustrates, Perl
543 offers at least eighteen different ways in which two values could
546 Table 1: Matching a switch value ($s) with a case value ($c)
548 Switch Case Type of Match Implied Matching Code
550 ====== ===== ===================== =============
552 number same numeric or referential match if $s == $c;
555 object method result of method call match if $s->$c();
556 ref name match if defined $s->$c();
559 other other string equality match if $s eq $c;
563 string regexp pattern match match if $s =~ /$c/;
565 array scalar array entry existence match if 0<=$c && $c<@$s;
566 ref array entry definition match if defined $s->[$c];
567 array entry truth match if $s->[$c];
569 array array array intersection match if intersects(@$s, @$c);
570 ref ref (apply this table to
571 all pairs of elements
575 array regexp array grep match if grep /$c/, @$s;
578 hash scalar hash entry existence match if exists $s->{$c};
579 ref hash entry definition match if defined $s->{$c};
580 hash entry truth match if $s->{$c};
582 hash regexp hash grep match if grep /$c/, keys %$s;
585 sub scalar return value defn match if defined $s->($c);
586 ref return value truth match if $s->($c);
588 sub array return value defn match if defined $s->(@$c);
589 ref ref return value truth match if $s->(@$c);
592 In reality, Table 1 covers 31 alternatives, because only the equality and
593 intersection tests are commutative; in all other cases, the roles of
594 the C<$s> and C<$c> variables could be reversed to produce a
595 different test. For example, instead of testing a single hash for
596 the existence of a series of keys (C<match if exists $s-E<gt>{$c}>),
597 one could test for the existence of a single key in a series of hashes
598 (C<match if exists $c-E<gt>{$s}>).
602 The Switch.pm module implements a generalized case mechanism that covers
603 most (but not all) of the numerous possible combinations of switch and case
604 values described above.
606 The module augments the standard Perl syntax with two new control
607 statements: C<switch> and C<case>. The C<switch> statement takes a
608 single scalar argument of any type, specified in parentheses.
609 C<switch> stores this value as the
610 current switch value in a (localized) control variable.
611 The value is followed by a block which may contain one or more
612 Perl statements (including the C<case> statement described below).
613 The block is unconditionally executed once the switch value has
616 A C<case> statement takes a single scalar argument (in mandatory
617 parentheses if it's a variable; otherwise the parens are optional) and
618 selects the appropriate type of matching between that argument and the
619 current switch value. The type of matching used is determined by the
620 respective types of the switch value and the C<case> argument, as
621 specified in Table 1. If the match is successful, the mandatory
622 block associated with the C<case> statement is executed.
624 In most other respects, the C<case> statement is semantically identical
625 to an C<if> statement. For example, it can be followed by an C<else>
626 clause, and can be used as a postfix statement qualifier.
628 However, when a C<case> block has been executed control is automatically
629 transferred to the statement after the immediately enclosing C<switch>
630 block, rather than to the next statement within the block. In other
631 words, the success of any C<case> statement prevents other cases in the
632 same scope from executing. But see L<"Allowing fall-through"> below.
634 Together these two new statements provide a fully generalized case
641 %special = ( woohoo => 1, d'oh => 1 );
646 case (%special) { print "homer\n"; } # if $special{$_}
647 case /[a-z]/i { print "alpha\n"; } # if $_ =~ /a-z/i
648 case [1..9] { print "small num\n"; } # if $_ in [1..9]
649 case { $_[0] >= 10 } { print "big num\n"; } # if $_ >= 10
650 print "must be punctuation\n" case /\W/; # if $_ ~= /\W/
654 Note that C<switch>es can be nested within C<case> (or any other) blocks,
655 and a series of C<case> statements can try different types of matches
656 -- hash membership, pattern match, array intersection, simple equality,
657 etc. -- against the same switch value.
659 The use of intersection tests against an array reference is particularly
660 useful for aggregating integral cases:
664 switch ($_[0]) { case 0 { return 'zero' }
665 case [2,4,6,8] { return 'even' }
666 case [1,3,5,7,9] { return 'odd' }
667 case /[A-F]/i { return 'hex' }
672 =head2 Allowing fall-through
674 Fall-though (trying another case after one has already succeeded)
675 is usually a Bad Idea in a switch statement. However, this
676 is Perl, not a police state, so there I<is> a way to do it, if you must.
678 If a C<case> block executes an untargeted C<next>, control is
679 immediately transferred to the statement I<after> the C<case> statement
680 (i.e. usually another case), rather than out of the surrounding
686 case 1 { handle_num_1(); next } # and try next case...
687 case "1" { handle_str_1(); next } # and try next case...
688 case [0..9] { handle_num_any(); } # and we're done
689 case /\d/ { handle_dig_any(); next } # and try next case...
690 case /.*/ { handle_str_any(); next } # and try next case...
693 If $val held the number C<1>, the above C<switch> block would call the
694 first three C<handle_...> subroutines, jumping to the next case test
695 each time it encountered a C<next>. After the third C<case> block
696 was executed, control would jump to the end of the enclosing
699 On the other hand, if $val held C<10>, then only the last two C<handle_...>
700 subroutines would be called.
702 Note that this mechanism allows the notion of I<conditional fall-through>.
706 case [0..9] { handle_num_any(); next if $val < 7; }
707 case /\d/ { handle_dig_any(); }
710 If an untargeted C<last> statement is executed in a case block, this
711 immediately transfers control out of the enclosing C<switch> block
712 (in other words, there is an implicit C<last> at the end of each
713 normal C<case> block). Thus the previous example could also have been
717 case [0..9] { handle_num_any(); last if $val >= 7; next; }
718 case /\d/ { handle_dig_any(); }
722 =head2 Automating fall-through
724 In situations where case fall-through should be the norm, rather than an
725 exception, an endless succession of terminal C<next>s is tedious and ugly.
726 Hence, it is possible to reverse the default behaviour by specifying
727 the string "fallthrough" when importing the module. For example, the
728 following code is equivalent to the first example in L<"Allowing fall-through">:
730 use Switch 'fallthrough';
733 case 1 { handle_num_1(); }
734 case "1" { handle_str_1(); }
735 case [0..9] { handle_num_any(); last }
736 case /\d/ { handle_dig_any(); }
737 case /.*/ { handle_str_any(); }
740 Note the explicit use of a C<last> to preserve the non-fall-through
741 behaviour of the third case.
745 =head2 Alternative syntax
747 Perl 6 will provide a built-in switch statement with essentially the
748 same semantics as those offered by Switch.pm, but with a different
749 pair of keywords. In Perl 6 C<switch> will be spelled C<given>, and
750 C<case> will be pronounced C<when>. In addition, the C<when> statement
751 will not require switch or case values to be parenthesized.
753 This future syntax is also (largely) available via the Switch.pm module, by
754 importing it with the argument C<"Perl6">. For example:
759 when 1 { handle_num_1(); }
760 when ($str1) { handle_str_1(); }
761 when [0..9] { handle_num_any(); last }
762 when /\d/ { handle_dig_any(); }
763 when /.*/ { handle_str_any(); }
764 default { handle anything else; }
767 Note that scalars still need to be parenthesized, since they would be
770 Note too that you can mix and match both syntaxes by importing the module
773 use Switch 'Perl5', 'Perl6';
776 =head2 Higher-order Operations
778 One situation in which C<switch> and C<case> do not provide a good
779 substitute for a cascaded C<if>, is where a switch value needs to
780 be tested against a series of conditions. For example:
784 case { $_[0] < 10 } { return 'milk' }
785 case { $_[0] < 20 } { return 'coke' }
786 case { $_[0] < 30 } { return 'beer' }
787 case { $_[0] < 40 } { return 'wine' }
788 case { $_[0] < 50 } { return 'malt' }
789 case { $_[0] < 60 } { return 'Moet' }
790 else { return 'milk' }
794 (This is equivalent to writing C<case (sub { $_[0] < 10 })>, etc.; C<$_[0]>
795 is the argument to the anonymous subroutine.)
797 The need to specify each condition as a subroutine block is tiresome. To
798 overcome this, when importing Switch.pm, a special "placeholder"
799 subroutine named C<__> [sic] may also be imported. This subroutine
800 converts (almost) any expression in which it appears to a reference to a
801 higher-order function. That is, the expression:
811 With C<__>, the previous ugly case statements can be rewritten:
813 case __ < 10 { return 'milk' }
814 case __ < 20 { return 'coke' }
815 case __ < 30 { return 'beer' }
816 case __ < 40 { return 'wine' }
817 case __ < 50 { return 'malt' }
818 case __ < 60 { return 'Moet' }
819 else { return 'milk' }
821 The C<__> subroutine makes extensive use of operator overloading to
822 perform its magic. All operations involving __ are overloaded to
823 produce an anonymous subroutine that implements a lazy version
824 of the original operation.
826 The only problem is that operator overloading does not allow the
827 boolean operators C<&&> and C<||> to be overloaded. So a case statement
830 case 0 <= __ && __ < 10 { return 'digit' }
832 doesn't act as expected, because when it is
833 executed, it constructs two higher order subroutines
834 and then treats the two resulting references as arguments to C<&&>:
836 sub { 0 <= $_[0] } && sub { $_[0] < 10 }
838 This boolean expression is inevitably true, since both references are
839 non-false. Fortunately, the overloaded C<'bool'> operator catches this
840 situation and flags it as an error.
844 The module is implemented using Filter::Util::Call and Text::Balanced
845 and requires both these modules to be installed.
849 Damian Conway (damian@conway.org). This module is now maintained by Rafael
850 Garcia-Suarez (rgarciasuarez@gmail.com) and more generally by the Perl 5
851 Porters (perl5-porters@perl.org), as part of the Perl core.
855 There are undoubtedly serious bugs lurking somewhere in code this funky :-)
856 Bug reports and other feedback are most welcome.
860 Due to the heuristic nature of Switch.pm's source parsing, the presence of
861 regexes with embedded newlines that are specified with raw C</.../>
862 delimiters and don't have a modifier C<//x> are indistinguishable from
863 code chunks beginning with the division operator C</>. As a workaround
864 you must use C<m/.../> or C<m?...?> for such patterns. Also, the presence
865 of regexes specified with raw C<?...?> delimiters may cause mysterious
866 errors. The workaround is to use C<m?...?> instead.
868 Due to the way source filters work in Perl, you can't use Switch inside
871 If your source file is longer then 1 million characters and you have a
872 switch statement that crosses the 1 million (or 2 million, etc.)
873 character boundary you will get mysterious errors. The workaround is to
874 use smaller source files.
878 Copyright (c) 1997-2008, Damian Conway. All Rights Reserved.
879 This module is free software. It may be used, redistributed
880 and/or modified under the same terms as Perl itself.