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
516 case 1 { print "number 1" }
517 case "a" { print "string a" }
518 case [1..10,42] { print "number in list" }
519 case (\@array) { print "number in list" }
520 case /\w+/ { print "pattern" }
521 case qr/\w+/ { print "pattern" }
522 case (\%hash) { print "entry in hash" }
523 case (\&sub) { print "arg to subroutine" }
524 else { print "previous case not true" }
529 [Skip ahead to L<"DESCRIPTION"> if you don't care about the whys
530 and wherefores of this control structure]
532 In seeking to devise a "Swiss Army" case mechanism suitable for Perl,
533 it is useful to generalize this notion of distributed conditional
534 testing as far as possible. Specifically, the concept of "matching"
535 between the switch value and the various case values need not be
536 restricted to numeric (or string or referential) equality, as it is in other
537 languages. Indeed, as Table 1 illustrates, Perl
538 offers at least eighteen different ways in which two values could
541 Table 1: Matching a switch value ($s) with a case value ($c)
543 Switch Case Type of Match Implied Matching Code
545 ====== ===== ===================== =============
547 number same numeric or referential match if $s == $c;
550 object method result of method call match if $s->$c();
551 ref name match if defined $s->$c();
554 other other string equality match if $s eq $c;
558 string regexp pattern match match if $s =~ /$c/;
560 array scalar array entry existence match if 0<=$c && $c<@$s;
561 ref array entry definition match if defined $s->[$c];
562 array entry truth match if $s->[$c];
564 array array array intersection match if intersects(@$s, @$c);
565 ref ref (apply this table to
566 all pairs of elements
570 array regexp array grep match if grep /$c/, @$s;
573 hash scalar hash entry existence match if exists $s->{$c};
574 ref hash entry definition match if defined $s->{$c};
575 hash entry truth match if $s->{$c};
577 hash regexp hash grep match if grep /$c/, keys %$s;
580 sub scalar return value defn match if defined $s->($c);
581 ref return value truth match if $s->($c);
583 sub array return value defn match if defined $s->(@$c);
584 ref ref return value truth match if $s->(@$c);
587 In reality, Table 1 covers 31 alternatives, because only the equality and
588 intersection tests are commutative; in all other cases, the roles of
589 the C<$s> and C<$c> variables could be reversed to produce a
590 different test. For example, instead of testing a single hash for
591 the existence of a series of keys (C<match if exists $s-E<gt>{$c}>),
592 one could test for the existence of a single key in a series of hashes
593 (C<match if exists $c-E<gt>{$s}>).
597 The Switch.pm module implements a generalized case mechanism that covers
598 most (but not all) of the numerous possible combinations of switch and case
599 values described above.
601 The module augments the standard Perl syntax with two new control
602 statements: C<switch> and C<case>. The C<switch> statement takes a
603 single scalar argument of any type, specified in parentheses.
604 C<switch> stores this value as the
605 current switch value in a (localized) control variable.
606 The value is followed by a block which may contain one or more
607 Perl statements (including the C<case> statement described below).
608 The block is unconditionally executed once the switch value has
611 A C<case> statement takes a single scalar argument (in mandatory
612 parentheses if it's a variable; otherwise the parens are optional) and
613 selects the appropriate type of matching between that argument and the
614 current switch value. The type of matching used is determined by the
615 respective types of the switch value and the C<case> argument, as
616 specified in Table 1. If the match is successful, the mandatory
617 block associated with the C<case> statement is executed.
619 In most other respects, the C<case> statement is semantically identical
620 to an C<if> statement. For example, it can be followed by an C<else>
621 clause, and can be used as a postfix statement qualifier.
623 However, when a C<case> block has been executed control is automatically
624 transferred to the statement after the immediately enclosing C<switch>
625 block, rather than to the next statement within the block. In other
626 words, the success of any C<case> statement prevents other cases in the
627 same scope from executing. But see L<"Allowing fall-through"> below.
629 Together these two new statements provide a fully generalized case
636 %special = ( woohoo => 1, d'oh => 1 );
641 case (%special) { print "homer\n"; } # if $special{$_}
642 case /[a-z]/i { print "alpha\n"; } # if $_ =~ /a-z/i
643 case [1..9] { print "small num\n"; } # if $_ in [1..9]
644 case { $_[0] >= 10 } { print "big num\n"; } # if $_ >= 10
645 print "must be punctuation\n" case /\W/; # if $_ ~= /\W/
649 Note that C<switch>es can be nested within C<case> (or any other) blocks,
650 and a series of C<case> statements can try different types of matches
651 -- hash membership, pattern match, array intersection, simple equality,
652 etc. -- against the same switch value.
654 The use of intersection tests against an array reference is particularly
655 useful for aggregating integral cases:
659 switch ($_[0]) { case 0 { return 'zero' }
660 case [2,4,6,8] { return 'even' }
661 case [1,3,5,7,9] { return 'odd' }
662 case /[A-F]/i { return 'hex' }
667 =head2 Allowing fall-through
669 Fall-though (trying another case after one has already succeeded)
670 is usually a Bad Idea in a switch statement. However, this
671 is Perl, not a police state, so there I<is> a way to do it, if you must.
673 If a C<case> block executes an untargeted C<next>, control is
674 immediately transferred to the statement I<after> the C<case> statement
675 (i.e. usually another case), rather than out of the surrounding
681 case 1 { handle_num_1(); next } # and try next case...
682 case "1" { handle_str_1(); next } # and try next case...
683 case [0..9] { handle_num_any(); } # and we're done
684 case /\d/ { handle_dig_any(); next } # and try next case...
685 case /.*/ { handle_str_any(); next } # and try next case...
688 If $val held the number C<1>, the above C<switch> block would call the
689 first three C<handle_...> subroutines, jumping to the next case test
690 each time it encountered a C<next>. After the third C<case> block
691 was executed, control would jump to the end of the enclosing
694 On the other hand, if $val held C<10>, then only the last two C<handle_...>
695 subroutines would be called.
697 Note that this mechanism allows the notion of I<conditional fall-through>.
701 case [0..9] { handle_num_any(); next if $val < 7; }
702 case /\d/ { handle_dig_any(); }
705 If an untargeted C<last> statement is executed in a case block, this
706 immediately transfers control out of the enclosing C<switch> block
707 (in other words, there is an implicit C<last> at the end of each
708 normal C<case> block). Thus the previous example could also have been
712 case [0..9] { handle_num_any(); last if $val >= 7; next; }
713 case /\d/ { handle_dig_any(); }
717 =head2 Automating fall-through
719 In situations where case fall-through should be the norm, rather than an
720 exception, an endless succession of terminal C<next>s is tedious and ugly.
721 Hence, it is possible to reverse the default behaviour by specifying
722 the string "fallthrough" when importing the module. For example, the
723 following code is equivalent to the first example in L<"Allowing fall-through">:
725 use Switch 'fallthrough';
728 case 1 { handle_num_1(); }
729 case "1" { handle_str_1(); }
730 case [0..9] { handle_num_any(); last }
731 case /\d/ { handle_dig_any(); }
732 case /.*/ { handle_str_any(); }
735 Note the explicit use of a C<last> to preserve the non-fall-through
736 behaviour of the third case.
740 =head2 Alternative syntax
742 Perl 6 will provide a built-in switch statement with essentially the
743 same semantics as those offered by Switch.pm, but with a different
744 pair of keywords. In Perl 6 C<switch> will be spelled C<given>, and
745 C<case> will be pronounced C<when>. In addition, the C<when> statement
746 will not require switch or case values to be parenthesized.
748 This future syntax is also (largely) available via the Switch.pm module, by
749 importing it with the argument C<"Perl6">. For example:
754 when 1 { handle_num_1(); }
755 when ($str1) { handle_str_1(); }
756 when [0..9] { handle_num_any(); last }
757 when /\d/ { handle_dig_any(); }
758 when /.*/ { handle_str_any(); }
759 default { handle anything else; }
762 Note that scalars still need to be parenthesized, since they would be
765 Note too that you can mix and match both syntaxes by importing the module
768 use Switch 'Perl5', 'Perl6';
771 =head2 Higher-order Operations
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:
779 case { $_[0] < 10 } { return 'milk' }
780 case { $_[0] < 20 } { return 'coke' }
781 case { $_[0] < 30 } { return 'beer' }
782 case { $_[0] < 40 } { return 'wine' }
783 case { $_[0] < 50 } { return 'malt' }
784 case { $_[0] < 60 } { return 'Moet' }
785 else { return 'milk' }
789 (This is equivalent to writing C<case (sub { $_[0] < 10 })>, etc.; C<$_[0]>
790 is the argument to the anonymous subroutine.)
792 The need to specify each condition as a subroutine block is tiresome. To
793 overcome this, when importing Switch.pm, a special "placeholder"
794 subroutine named C<__> [sic] may also be imported. This subroutine
795 converts (almost) any expression in which it appears to a reference to a
796 higher-order function. That is, the expression:
806 With C<__>, the previous ugly case statements can be rewritten:
808 case __ < 10 { return 'milk' }
809 case __ < 20 { return 'coke' }
810 case __ < 30 { return 'beer' }
811 case __ < 40 { return 'wine' }
812 case __ < 50 { return 'malt' }
813 case __ < 60 { return 'Moet' }
814 else { return 'milk' }
816 The C<__> subroutine makes extensive use of operator overloading to
817 perform its magic. All operations involving __ are overloaded to
818 produce an anonymous subroutine that implements a lazy version
819 of the original operation.
821 The only problem is that operator overloading does not allow the
822 boolean operators C<&&> and C<||> to be overloaded. So a case statement
825 case 0 <= __ && __ < 10 { return 'digit' }
827 doesn't act as expected, because when it is
828 executed, it constructs two higher order subroutines
829 and then treats the two resulting references as arguments to C<&&>:
831 sub { 0 <= $_[0] } && sub { $_[0] < 10 }
833 This boolean expression is inevitably true, since both references are
834 non-false. Fortunately, the overloaded C<'bool'> operator catches this
835 situation and flags it as an error.
839 The module is implemented using Filter::Util::Call and Text::Balanced
840 and requires both these modules to be installed.
844 Damian Conway (damian@conway.org). This module is now maintained by Rafael
845 Garcia-Suarez (rgarciasuarez@gmail.com) and more generally by the Perl 5
846 Porters (perl5-porters@perl.org), as part of the Perl core.
850 There are undoubtedly serious bugs lurking somewhere in code this funky :-)
851 Bug reports and other feedback are most welcome.
855 Due to the heuristic nature of Switch.pm's source parsing, the presence of
856 regexes with embedded newlines that are specified with raw C</.../>
857 delimiters and don't have a modifier C<//x> are indistinguishable from
858 code chunks beginning with the division operator C</>. As a workaround
859 you must use C<m/.../> or C<m?...?> for such patterns. Also, the presence
860 of regexes specified with raw C<?...?> delimiters may cause mysterious
861 errors. The workaround is to use C<m?...?> instead.
863 Due to the way source filters work in Perl, you can't use Switch inside
866 If your source file is longer then 1 million characters and you have a
867 switch statement that crosses the 1 million (or 2 million, etc.)
868 character boundary you will get mysterious errors. The workaround is to
869 use smaller source files.
873 Copyright (c) 1997-2008, Damian Conway. All Rights Reserved.
874 This module is free software. It may be used, redistributed
875 and/or modified under the same terms as Perl itself.