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];
76 my $EOP = qr/\n\n|\Z/;
77 my $CUT = qr/\n=cut.*$EOP/;
78 my $pod_or_DATA = qr/ ^=(?:head[1-4]|item) .*? $CUT
81 | ^=begin \s* (\S+) .*? \n=end \s* \1 .*? $EOP
88 my ($source, $line) = @_;
89 return $source unless $Perl5 && $source =~ /case|switch/
90 || $Perl6 && $source =~ /when|given|default/;
93 component: while (pos $source < length $source)
95 if ($source =~ m/(\G\s*use\s+Switch\b)/gc)
97 $text .= q{use Switch 'noimport'};
100 my @pos = Text::Balanced::_match_quotelike(\$source,qr/\s*/,1,0);
103 my $pre = substr($source,$pos[0],$pos[1]); # matched prefix
104 $text .= $pre . substr($source,$pos[2],$pos[18]-$pos[2]);
107 if ($source =~ m/\G\s*($pod_or_DATA)/gc) {
110 @pos = Text::Balanced::_match_variable(\$source,qr/\s*/);
113 $text .= " " if $pos[0] < $pos[2];
114 $text .= substr($source,$pos[0],$pos[4]-$pos[0]);
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)
124 $text .= $1.$2.'S_W_I_T_C_H: while (1) ';
126 @pos = Text::Balanced::_match_codeblock(\$source,qr/\s*/,qr/\(/,qr/\)/,qr/[[{(<]/,qr/[]})>]/,undef)
128 die "Bad $keyword statement (problem in the parentheses?) near $Switch::file line ", line(substr($source,0,pos $source),$line), "\n";
130 $arg = filter_blocks(substr($source,$pos[0],$pos[4]-$pos[0]),line(substr($source,0,$pos[0]),$line));
132 $arg =~ s {^\s*[(]\s*%} { ( \\\%} ||
133 $arg =~ s {^\s*[(]\s*m\b} { ( qr} ||
134 $arg =~ s {^\s*[(]\s*/} { ( qr/} ||
135 $arg =~ s {^\s*[(]\s*qw} { ( \\qw};
136 @pos = Text::Balanced::_match_codeblock(\$source,qr/\s*/,qr/\{/,qr/\}/,qr/\{/,qr/\}/,undef)
138 die "Bad $keyword statement (problem in the code block?) near $Switch::file line ", line(substr($source,0, pos $source), $line), "\n";
140 my $code = filter_blocks(substr($source,$pos[0],$pos[4]-$pos[0]),line(substr($source,0,$pos[0]),$line));
141 $code =~ s/{/{ local \$::_S_W_I_T_C_H; Switch::switch $arg;/;
142 $text .= $code . 'continue {last}';
145 elsif ($Perl5 && $source =~ m/\G(\s*)(case\b)(?!\s*=>)/gc
146 || $Perl6 && $source =~ m/\G(\s*)(when\b)(?!\s*=>)/gc
147 || $Perl6 && $source =~ m/\G(\s*)(default\b)(?=\s*\{)/gc)
150 $text .= $1 . ($keyword eq "default"
152 : "if (Switch::case");
154 if ($keyword eq "default") {
157 elsif (@pos = Text::Balanced::_match_codeblock(\$source,qr/\s*/,qr/\{/,qr/\}/,qr/\{/,qr/\}/,undef)) {
158 my $code = substr($source,$pos[0],$pos[4]-$pos[0]);
159 $text .= " " if $pos[0] < $pos[2];
160 $text .= "sub " if is_block $code;
161 $text .= filter_blocks($code,line(substr($source,0,$pos[0]),$line)) . ")";
163 elsif (@pos = Text::Balanced::_match_codeblock(\$source,qr/\s*/,qr/[[(]/,qr/[])]/,qr/[[({]/,qr/[])}]/,undef)) {
164 my $code = filter_blocks(substr($source,$pos[0],$pos[4]-$pos[0]),line(substr($source,0,$pos[0]),$line));
165 $code =~ s {^\s*[(]\s*%} { ( \\\%} ||
166 $code =~ s {^\s*[(]\s*m\b} { ( qr} ||
167 $code =~ s {^\s*[(]\s*/} { ( qr/} ||
168 $code =~ s {^\s*[(]\s*qw} { ( \\qw};
169 $text .= " " if $pos[0] < $pos[2];
172 elsif ($Perl6 && do{@pos = Text::Balanced::_match_variable(\$source,qr/\s*/)}) {
173 my $code = filter_blocks(substr($source,$pos[0],$pos[4]-$pos[0]),line(substr($source,0,$pos[0]),$line));
174 $code =~ s {^\s*%} { \%} ||
175 $code =~ s {^\s*@} { \@};
176 $text .= " " if $pos[0] < $pos[2];
179 elsif ( @pos = Text::Balanced::_match_quotelike(\$source,qr/\s*/,1,0)) {
180 my $code = substr($source,$pos[2],$pos[18]-$pos[2]);
181 $code = filter_blocks($code,line(substr($source,0,$pos[2]),$line));
182 $code =~ s {^\s*m} { qr} ||
183 $code =~ s {^\s*/} { qr/} ||
184 $code =~ s {^\s*qw} { \\qw};
185 $text .= " " if $pos[0] < $pos[2];
188 elsif ($Perl5 && $source =~ m/\G\s*(([^\$\@{])[^\$\@{]*)(?=\s*{)/gc
189 || $Perl6 && $source =~ m/\G\s*([^;{]*)()/gc) {
190 my $code = filter_blocks($1,line(substr($source,0,pos $source),$line));
191 $text .= ' \\' if $2 eq '%';
195 die "Bad $keyword statement (invalid $keyword value?) near $Switch::file line ", line(substr($source,0,pos $source), $line), "\n";
198 die "Missing opening brace or semi-colon after 'when' value near $Switch::file line ", line(substr($source,0,pos $source), $line), "\n"
199 unless !$Perl6 || $source =~ m/\G(\s*)(?=;|\{)/gc;
201 do{@pos = Text::Balanced::_match_codeblock(\$source,qr/\s*/,qr/\{/,qr/\}/,qr/\{/,qr/\}/,undef)}
203 if ($source =~ m/\G\s*(?=([};]|\Z))/gc) {
207 die "Bad $keyword statement (problem in the code block?) near $Switch::file line ", line(substr($source,0,pos $source),$line), "\n";
209 my $code = filter_blocks(substr($source,$pos[0],$pos[4]-$pos[0]),line(substr($source,0,$pos[0]),$line));
210 $code =~ s/}(?=\s*\Z)/;last S_W_I_T_C_H }/
212 $text .= "{ while (1) $code continue { goto C_A_S_E_$casecounter } last S_W_I_T_C_H; C_A_S_E_$casecounter: }";
217 $source =~ m/\G(\s*(-[sm]\s+|\w+|#.*\n|\W))/gc;
229 for my $nextx ( @$x )
231 my $numx = ref($nextx) || defined $nextx && (~$nextx&$nextx) eq 0;
232 for my $j ( 0..$#$y )
234 my $nexty = $y->[$j];
235 push @numy, ref($nexty) || defined $nexty && (~$nexty&$nexty) eq 0
237 return 1 if $numx && $numy[$j] && $nextx==$nexty
247 my $ref = @_==1 && ref($_[0]) eq 'HASH' ? $_[0] : { @_ };
253 my $ref = @_==1 && ref($_[0]) eq 'HASH' ? $_[0] : { @_ };
254 [ grep { defined $ref->{$_} } keys %$ref ]
259 my ($s_val) = @_ ? $_[0] : $_;
260 my $s_ref = ref $s_val;
262 if ($s_ref eq 'CODE')
265 sub { my $c_val = $_[0];
266 return $s_val == $c_val if ref $c_val eq 'CODE';
267 return $s_val->(@$c_val) if ref $c_val eq 'ARRAY';
268 return $s_val->($c_val);
271 elsif ($s_ref eq "" && defined $s_val && (~$s_val&$s_val) eq 0) # NUMERIC SCALAR
274 sub { my $c_val = $_[0];
275 my $c_ref = ref $c_val;
276 return $s_val == $c_val if $c_ref eq ""
278 && (~$c_val&$c_val) eq 0;
279 return $s_val eq $c_val if $c_ref eq "";
280 return in([$s_val],$c_val) if $c_ref eq 'ARRAY';
281 return $c_val->($s_val) if $c_ref eq 'CODE';
282 return $c_val->call($s_val) if $c_ref eq 'Switch';
283 return scalar $s_val=~/$c_val/
284 if $c_ref eq 'Regexp';
285 return scalar $c_val->{$s_val}
290 elsif ($s_ref eq "") # STRING SCALAR
293 sub { my $c_val = $_[0];
294 my $c_ref = ref $c_val;
295 return $s_val eq $c_val if $c_ref eq "";
296 return in([$s_val],$c_val) if $c_ref eq 'ARRAY';
297 return $c_val->($s_val) if $c_ref eq 'CODE';
298 return $c_val->call($s_val) if $c_ref eq 'Switch';
299 return scalar $s_val=~/$c_val/
300 if $c_ref eq 'Regexp';
301 return scalar $c_val->{$s_val}
306 elsif ($s_ref eq 'ARRAY')
309 sub { my $c_val = $_[0];
310 my $c_ref = ref $c_val;
311 return in($s_val,[$c_val]) if $c_ref eq "";
312 return in($s_val,$c_val) if $c_ref eq 'ARRAY';
313 return $c_val->(@$s_val) if $c_ref eq 'CODE';
314 return $c_val->call(@$s_val)
315 if $c_ref eq 'Switch';
316 return scalar grep {$_=~/$c_val/} @$s_val
317 if $c_ref eq 'Regexp';
318 return scalar grep {$c_val->{$_}} @$s_val
323 elsif ($s_ref eq 'Regexp')
326 sub { my $c_val = $_[0];
327 my $c_ref = ref $c_val;
328 return $c_val=~/s_val/ if $c_ref eq "";
329 return scalar grep {$_=~/s_val/} @$c_val
330 if $c_ref eq 'ARRAY';
331 return $c_val->($s_val) if $c_ref eq 'CODE';
332 return $c_val->call($s_val) if $c_ref eq 'Switch';
333 return $s_val eq $c_val if $c_ref eq 'Regexp';
334 return grep {$_=~/$s_val/ && $c_val->{$_}} keys %$c_val
339 elsif ($s_ref eq 'HASH')
342 sub { my $c_val = $_[0];
343 my $c_ref = ref $c_val;
344 return $s_val->{$c_val} if $c_ref eq "";
345 return scalar grep {$s_val->{$_}} @$c_val
346 if $c_ref eq 'ARRAY';
347 return $c_val->($s_val) if $c_ref eq 'CODE';
348 return $c_val->call($s_val) if $c_ref eq 'Switch';
349 return grep {$_=~/$c_val/ && $s_val->{"$_"}} keys %$s_val
350 if $c_ref eq 'Regexp';
351 return $s_val==$c_val if $c_ref eq 'HASH';
355 elsif ($s_ref eq 'Switch')
358 sub { my $c_val = $_[0];
359 return $s_val == $c_val if ref $c_val eq 'Switch';
360 return $s_val->call(@$c_val)
361 if ref $c_val eq 'ARRAY';
362 return $s_val->call($c_val);
367 croak "Cannot switch on $s_ref";
372 sub case($) { local $SIG{__WARN__} = \&carp;
373 $::_S_W_I_T_C_H->(@_); }
377 my $placeholder = bless { arity=>1, impl=>sub{$_[1+$_[0]]} };
379 sub __() { $placeholder }
384 bless { arity=>0, impl=>sub{$_[$index]} };
394 my ($self,@args) = @_;
395 return $self->{impl}->(0,@args);
403 my ($left, $right, $reversed) = @_;
404 ($right,$left) = @_ if $reversed;
406 my $rop = ref $right eq 'Switch'
408 : bless { arity=>0, impl=>sub{$right} };
410 my $lop = ref $left eq 'Switch'
412 : bless { arity=>0, impl=>sub{$left} };
414 my $arity = $lop->{arity} + $rop->{arity};
418 impl => sub { my $start = shift;
419 return $op->($lop->{impl}->($start,@_),
420 $rop->{impl}->($start+$lop->{arity},@_));
433 my $lop = ref $left eq 'Switch'
435 : bless { arity=>0, impl=>sub{$left} };
437 my $arity = $lop->{arity};
441 impl => sub { $op->($lop->{impl}->(@_)) }
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 ">>" => meta_bop {$_[0] >> $_[1]},
456 "x" => meta_bop {$_[0] x $_[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 "<=>" => meta_bop {$_[0] <=> $_[1]},
465 "lt" => meta_bop {$_[0] lt $_[1]},
466 "le" => meta_bop {$_[0] le $_[1]},
467 "gt" => meta_bop {$_[0] gt $_[1]},
468 "ge" => meta_bop {$_[0] ge $_[1]},
469 "eq" => meta_bop {$_[0] eq $_[1]},
470 "ne" => meta_bop {$_[0] ne $_[1]},
471 "cmp" => meta_bop {$_[0] cmp $_[1]},
472 "\&" => meta_bop {$_[0] & $_[1]},
473 "^" => meta_bop {$_[0] ^ $_[1]},
474 "|" => meta_bop {$_[0] | $_[1]},
475 "atan2" => meta_bop {atan2 $_[0], $_[1]},
477 "neg" => meta_uop {-$_[0]},
478 "!" => meta_uop {!$_[0]},
479 "~" => meta_uop {~$_[0]},
480 "cos" => meta_uop {cos $_[0]},
481 "sin" => meta_uop {sin $_[0]},
482 "exp" => meta_uop {exp $_[0]},
483 "abs" => meta_uop {abs $_[0]},
484 "log" => meta_uop {log $_[0]},
485 "sqrt" => meta_uop {sqrt $_[0]},
486 "bool" => sub { croak "Can't use && or || in expression containing __" },
488 # "&()" => sub { $_[0]->{impl} },
490 # "||" => meta_bop {$_[0] || $_[1]},
491 # "&&" => meta_bop {$_[0] && $_[1]},
501 Switch - A switch statement for Perl
505 This document describes version 2.10 of Switch,
506 released Dec 29, 2003.
514 case 1 { print "number 1" }
515 case "a" { print "string a" }
516 case [1..10,42] { print "number in list" }
517 case (@array) { print "number in list" }
518 case /\w+/ { print "pattern" }
519 case qr/\w+/ { print "pattern" }
520 case (%hash) { print "entry in hash" }
521 case (\%hash) { print "entry in hash" }
522 case (\&sub) { print "arg to subroutine" }
523 else { print "previous case not true" }
528 [Skip ahead to L<"DESCRIPTION"> if you don't care about the whys
529 and wherefores of this control structure]
531 In seeking to devise a "Swiss Army" case mechanism suitable for Perl,
532 it is useful to generalize this notion of distributed conditional
533 testing as far as possible. Specifically, the concept of "matching"
534 between the switch value and the various case values need not be
535 restricted to numeric (or string or referential) equality, as it is in other
536 languages. Indeed, as Table 1 illustrates, Perl
537 offers at least eighteen different ways in which two values could
540 Table 1: Matching a switch value ($s) with a case value ($c)
542 Switch Case Type of Match Implied Matching Code
544 ====== ===== ===================== =============
546 number same numeric or referential match if $s == $c;
549 object method result of method call match if $s->$c();
550 ref name match if defined $s->$c();
553 other other string equality match if $s eq $c;
557 string regexp pattern match match if $s =~ /$c/;
559 array scalar array entry existence match if 0<=$c && $c<@$s;
560 ref array entry definition match if defined $s->[$c];
561 array entry truth match if $s->[$c];
563 array array array intersection match if intersects(@$s, @$c);
564 ref ref (apply this table to
565 all pairs of elements
569 array regexp array grep match if grep /$c/, @$s;
572 hash scalar hash entry existence match if exists $s->{$c};
573 ref hash entry definition match if defined $s->{$c};
574 hash entry truth match if $s->{$c};
576 hash regexp hash grep match if grep /$c/, keys %$s;
579 sub scalar return value defn match if defined $s->($c);
580 ref return value truth match if $s->($c);
582 sub array return value defn match if defined $s->(@$c);
583 ref ref return value truth match if $s->(@$c);
586 In reality, Table 1 covers 31 alternatives, because only the equality and
587 intersection tests are commutative; in all other cases, the roles of
588 the C<$s> and C<$c> variables could be reversed to produce a
589 different test. For example, instead of testing a single hash for
590 the existence of a series of keys (C<match if exists $s-E<gt>{$c}>),
591 one could test for the existence of a single key in a series of hashes
592 (C<match if exists $c-E<gt>{$s}>).
594 As L<perltodo> observes, a Perl case mechanism must support all these
600 The Switch.pm module implements a generalized case mechanism that covers
601 the numerous possible combinations of switch and case values described above.
603 The module augments the standard Perl syntax with two new control
604 statements: C<switch> and C<case>. The C<switch> statement takes a
605 single scalar argument of any type, specified in parentheses.
606 C<switch> stores this value as the
607 current switch value in a (localized) control variable.
608 The value is followed by a block which may contain one or more
609 Perl statements (including the C<case> statement described below).
610 The block is unconditionally executed once the switch value has
613 A C<case> statement takes a single scalar argument (in mandatory
614 parentheses if it's a variable; otherwise the parens are optional) and
615 selects the appropriate type of matching between that argument and the
616 current switch value. The type of matching used is determined by the
617 respective types of the switch value and the C<case> argument, as
618 specified in Table 1. If the match is successful, the mandatory
619 block associated with the C<case> statement is executed.
621 In most other respects, the C<case> statement is semantically identical
622 to an C<if> statement. For example, it can be followed by an C<else>
623 clause, and can be used as a postfix statement qualifier.
625 However, when a C<case> block has been executed control is automatically
626 transferred to the statement after the immediately enclosing C<switch>
627 block, rather than to the next statement within the block. In other
628 words, the success of any C<case> statement prevents other cases in the
629 same scope from executing. But see L<"Allowing fall-through"> below.
631 Together these two new statements provide a fully generalized case
638 %special = ( woohoo => 1, d'oh => 1 );
643 case (%special) { print "homer\n"; } # if $special{$_}
644 case /[a-z]/i { print "alpha\n"; } # if $_ =~ /a-z/i
645 case [1..9] { print "small num\n"; } # if $_ in [1..9]
646 case { $_[0] >= 10 } { print "big num\n"; } # if $_ >= 10
647 print "must be punctuation\n" case /\W/; # if $_ ~= /\W/
651 Note that C<switch>es can be nested within C<case> (or any other) blocks,
652 and a series of C<case> statements can try different types of matches
653 -- hash membership, pattern match, array intersection, simple equality,
654 etc. -- against the same switch value.
656 The use of intersection tests against an array reference is particularly
657 useful for aggregating integral cases:
661 switch ($_[0]) { case 0 { return 'zero' }
662 case [2,4,6,8] { return 'even' }
663 case [1,3,5,7,9] { return 'odd' }
664 case /[A-F]/i { return 'hex' }
669 =head2 Allowing fall-through
671 Fall-though (trying another case after one has already succeeded)
672 is usually a Bad Idea in a switch statement. However, this
673 is Perl, not a police state, so there I<is> a way to do it, if you must.
675 If a C<case> block executes an untargeted C<next>, control is
676 immediately transferred to the statement I<after> the C<case> statement
677 (i.e. usually another case), rather than out of the surrounding
683 case 1 { handle_num_1(); next } # and try next case...
684 case "1" { handle_str_1(); next } # and try next case...
685 case [0..9] { handle_num_any(); } # and we're done
686 case /\d/ { handle_dig_any(); next } # and try next case...
687 case /.*/ { handle_str_any(); next } # and try next case...
690 If $val held the number C<1>, the above C<switch> block would call the
691 first three C<handle_...> subroutines, jumping to the next case test
692 each time it encountered a C<next>. After the third C<case> block
693 was executed, control would jump to the end of the enclosing
696 On the other hand, if $val held C<10>, then only the last two C<handle_...>
697 subroutines would be called.
699 Note that this mechanism allows the notion of I<conditional fall-through>.
703 case [0..9] { handle_num_any(); next if $val < 7; }
704 case /\d/ { handle_dig_any(); }
707 If an untargeted C<last> statement is executed in a case block, this
708 immediately transfers control out of the enclosing C<switch> block
709 (in other words, there is an implicit C<last> at the end of each
710 normal C<case> block). Thus the previous example could also have been
714 case [0..9] { handle_num_any(); last if $val >= 7; next; }
715 case /\d/ { handle_dig_any(); }
719 =head2 Automating fall-through
721 In situations where case fall-through should be the norm, rather than an
722 exception, an endless succession of terminal C<next>s is tedious and ugly.
723 Hence, it is possible to reverse the default behaviour by specifying
724 the string "fallthrough" when importing the module. For example, the
725 following code is equivalent to the first example in L<"Allowing fall-through">:
727 use Switch 'fallthrough';
730 case 1 { handle_num_1(); }
731 case "1" { handle_str_1(); }
732 case [0..9] { handle_num_any(); last }
733 case /\d/ { handle_dig_any(); }
734 case /.*/ { handle_str_any(); }
737 Note the explicit use of a C<last> to preserve the non-fall-through
738 behaviour of the third case.
742 =head2 Alternative syntax
744 Perl 6 will provide a built-in switch statement with essentially the
745 same semantics as those offered by Switch.pm, but with a different
746 pair of keywords. In Perl 6 C<switch> will be spelled C<given>, and
747 C<case> will be pronounced C<when>. In addition, the C<when> statement
748 will not require switch or case values to be parenthesized.
750 This future syntax is also (largely) available via the Switch.pm module, by
751 importing it with the argument C<"Perl6">. For example:
756 when 1 { handle_num_1(); }
757 when ($str1) { handle_str_1(); }
758 when [0..9] { handle_num_any(); last }
759 when /\d/ { handle_dig_any(); }
760 when /.*/ { handle_str_any(); }
761 default { handle anything else; }
764 Note that scalars still need to be parenthesized, since they would be
767 Note too that you can mix and match both syntaxes by importing the module
770 use Switch 'Perl5', 'Perl6';
773 =head2 Higher-order Operations
775 One situation in which C<switch> and C<case> do not provide a good
776 substitute for a cascaded C<if>, is where a switch value needs to
777 be tested against a series of conditions. For example:
781 case { $_[0] < 10 } { return 'milk' }
782 case { $_[0] < 20 } { return 'coke' }
783 case { $_[0] < 30 } { return 'beer' }
784 case { $_[0] < 40 } { return 'wine' }
785 case { $_[0] < 50 } { return 'malt' }
786 case { $_[0] < 60 } { return 'Moet' }
787 else { return 'milk' }
791 (This is equivalent to writing C<case (sub { $_[0] < 10 })>, etc.; C<$_[0]>
792 is the argument to the anonymous subroutine.)
794 The need to specify each condition as a subroutine block is tiresome. To
795 overcome this, when importing Switch.pm, a special "placeholder"
796 subroutine named C<__> [sic] may also be imported. This subroutine
797 converts (almost) any expression in which it appears to a reference to a
798 higher-order function. That is, the expression:
808 With C<__>, the previous ugly case statements can be rewritten:
810 case __ < 10 { return 'milk' }
811 case __ < 20 { return 'coke' }
812 case __ < 30 { return 'beer' }
813 case __ < 40 { return 'wine' }
814 case __ < 50 { return 'malt' }
815 case __ < 60 { return 'Moet' }
816 else { return 'milk' }
818 The C<__> subroutine makes extensive use of operator overloading to
819 perform its magic. All operations involving __ are overloaded to
820 produce an anonymous subroutine that implements a lazy version
821 of the original operation.
823 The only problem is that operator overloading does not allow the
824 boolean operators C<&&> and C<||> to be overloaded. So a case statement
827 case 0 <= __ && __ < 10 { return 'digit' }
829 doesn't act as expected, because when it is
830 executed, it constructs two higher order subroutines
831 and then treats the two resulting references as arguments to C<&&>:
833 sub { 0 <= $_[0] } && sub { $_[0] < 10 }
835 This boolean expression is inevitably true, since both references are
836 non-false. Fortunately, the overloaded C<'bool'> operator catches this
837 situation and flags it as a error.
841 The module is implemented using Filter::Util::Call and Text::Balanced
842 and requires both these modules to be installed.
846 Damian Conway (damian@conway.org). The maintainer of this module is now Rafael
847 Garcia-Suarez (rgarciasuarez@free.fr).
851 There are undoubtedly serious bugs lurking somewhere in code this funky :-)
852 Bug reports and other feedback are most welcome.
856 Due to the heuristic nature of Switch.pm's source parsing, the presence
857 of regexes specified with raw C<?...?> delimiters may cause mysterious
858 errors. The workaround is to use C<m?...?> instead.
860 Due to the way source filters work in Perl, you can't use Switch inside
863 If your source file is longer then 1 million characters and you have a
864 switch statement that crosses the 1 million (or 2 million, etc.)
865 character boundary you will get mysterious errors. The workaround is to
866 use smaller source files.
870 Copyright (c) 1997-2006, Damian Conway. All Rights Reserved.
871 This module is free software. It may be used, redistributed
872 and/or modified under the same terms as Perl itself.