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];
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.11 of Switch,
506 released Nov 22, 2006.
513 case 1 { print "number 1" }
514 case "a" { print "string a" }
515 case [1..10,42] { print "number in list" }
516 case (@array) { print "number in list" }
517 case /\w+/ { print "pattern" }
518 case qr/\w+/ { print "pattern" }
519 case (%hash) { print "entry in hash" }
520 case (\%hash) { print "entry in hash" }
521 case (\&sub) { print "arg to subroutine" }
522 else { print "previous case not true" }
527 [Skip ahead to L<"DESCRIPTION"> if you don't care about the whys
528 and wherefores of this control structure]
530 In seeking to devise a "Swiss Army" case mechanism suitable for Perl,
531 it is useful to generalize this notion of distributed conditional
532 testing as far as possible. Specifically, the concept of "matching"
533 between the switch value and the various case values need not be
534 restricted to numeric (or string or referential) equality, as it is in other
535 languages. Indeed, as Table 1 illustrates, Perl
536 offers at least eighteen different ways in which two values could
539 Table 1: Matching a switch value ($s) with a case value ($c)
541 Switch Case Type of Match Implied Matching Code
543 ====== ===== ===================== =============
545 number same numeric or referential match if $s == $c;
548 object method result of method call match if $s->$c();
549 ref name match if defined $s->$c();
552 other other string equality match if $s eq $c;
556 string regexp pattern match match if $s =~ /$c/;
558 array scalar array entry existence match if 0<=$c && $c<@$s;
559 ref array entry definition match if defined $s->[$c];
560 array entry truth match if $s->[$c];
562 array array array intersection match if intersects(@$s, @$c);
563 ref ref (apply this table to
564 all pairs of elements
568 array regexp array grep match if grep /$c/, @$s;
571 hash scalar hash entry existence match if exists $s->{$c};
572 ref hash entry definition match if defined $s->{$c};
573 hash entry truth match if $s->{$c};
575 hash regexp hash grep match if grep /$c/, keys %$s;
578 sub scalar return value defn match if defined $s->($c);
579 ref return value truth match if $s->($c);
581 sub array return value defn match if defined $s->(@$c);
582 ref ref return value truth match if $s->(@$c);
585 In reality, Table 1 covers 31 alternatives, because only the equality and
586 intersection tests are commutative; in all other cases, the roles of
587 the C<$s> and C<$c> variables could be reversed to produce a
588 different test. For example, instead of testing a single hash for
589 the existence of a series of keys (C<match if exists $s-E<gt>{$c}>),
590 one could test for the existence of a single key in a series of hashes
591 (C<match if exists $c-E<gt>{$s}>).
595 The Switch.pm module implements a generalized case mechanism that covers
596 most (but not all) of the numerous possible combinations of switch and case
597 values described above.
599 The module augments the standard Perl syntax with two new control
600 statements: C<switch> and C<case>. The C<switch> statement takes a
601 single scalar argument of any type, specified in parentheses.
602 C<switch> stores this value as the
603 current switch value in a (localized) control variable.
604 The value is followed by a block which may contain one or more
605 Perl statements (including the C<case> statement described below).
606 The block is unconditionally executed once the switch value has
609 A C<case> statement takes a single scalar argument (in mandatory
610 parentheses if it's a variable; otherwise the parens are optional) and
611 selects the appropriate type of matching between that argument and the
612 current switch value. The type of matching used is determined by the
613 respective types of the switch value and the C<case> argument, as
614 specified in Table 1. If the match is successful, the mandatory
615 block associated with the C<case> statement is executed.
617 In most other respects, the C<case> statement is semantically identical
618 to an C<if> statement. For example, it can be followed by an C<else>
619 clause, and can be used as a postfix statement qualifier.
621 However, when a C<case> block has been executed control is automatically
622 transferred to the statement after the immediately enclosing C<switch>
623 block, rather than to the next statement within the block. In other
624 words, the success of any C<case> statement prevents other cases in the
625 same scope from executing. But see L<"Allowing fall-through"> below.
627 Together these two new statements provide a fully generalized case
634 %special = ( woohoo => 1, d'oh => 1 );
639 case (%special) { print "homer\n"; } # if $special{$_}
640 case /[a-z]/i { print "alpha\n"; } # if $_ =~ /a-z/i
641 case [1..9] { print "small num\n"; } # if $_ in [1..9]
642 case { $_[0] >= 10 } { print "big num\n"; } # if $_ >= 10
643 print "must be punctuation\n" case /\W/; # if $_ ~= /\W/
647 Note that C<switch>es can be nested within C<case> (or any other) blocks,
648 and a series of C<case> statements can try different types of matches
649 -- hash membership, pattern match, array intersection, simple equality,
650 etc. -- against the same switch value.
652 The use of intersection tests against an array reference is particularly
653 useful for aggregating integral cases:
657 switch ($_[0]) { case 0 { return 'zero' }
658 case [2,4,6,8] { return 'even' }
659 case [1,3,5,7,9] { return 'odd' }
660 case /[A-F]/i { return 'hex' }
665 =head2 Allowing fall-through
667 Fall-though (trying another case after one has already succeeded)
668 is usually a Bad Idea in a switch statement. However, this
669 is Perl, not a police state, so there I<is> a way to do it, if you must.
671 If a C<case> block executes an untargeted C<next>, control is
672 immediately transferred to the statement I<after> the C<case> statement
673 (i.e. usually another case), rather than out of the surrounding
679 case 1 { handle_num_1(); next } # and try next case...
680 case "1" { handle_str_1(); next } # and try next case...
681 case [0..9] { handle_num_any(); } # and we're done
682 case /\d/ { handle_dig_any(); next } # and try next case...
683 case /.*/ { handle_str_any(); next } # and try next case...
686 If $val held the number C<1>, the above C<switch> block would call the
687 first three C<handle_...> subroutines, jumping to the next case test
688 each time it encountered a C<next>. After the third C<case> block
689 was executed, control would jump to the end of the enclosing
692 On the other hand, if $val held C<10>, then only the last two C<handle_...>
693 subroutines would be called.
695 Note that this mechanism allows the notion of I<conditional fall-through>.
699 case [0..9] { handle_num_any(); next if $val < 7; }
700 case /\d/ { handle_dig_any(); }
703 If an untargeted C<last> statement is executed in a case block, this
704 immediately transfers control out of the enclosing C<switch> block
705 (in other words, there is an implicit C<last> at the end of each
706 normal C<case> block). Thus the previous example could also have been
710 case [0..9] { handle_num_any(); last if $val >= 7; next; }
711 case /\d/ { handle_dig_any(); }
715 =head2 Automating fall-through
717 In situations where case fall-through should be the norm, rather than an
718 exception, an endless succession of terminal C<next>s is tedious and ugly.
719 Hence, it is possible to reverse the default behaviour by specifying
720 the string "fallthrough" when importing the module. For example, the
721 following code is equivalent to the first example in L<"Allowing fall-through">:
723 use Switch 'fallthrough';
726 case 1 { handle_num_1(); }
727 case "1" { handle_str_1(); }
728 case [0..9] { handle_num_any(); last }
729 case /\d/ { handle_dig_any(); }
730 case /.*/ { handle_str_any(); }
733 Note the explicit use of a C<last> to preserve the non-fall-through
734 behaviour of the third case.
738 =head2 Alternative syntax
740 Perl 6 will provide a built-in switch statement with essentially the
741 same semantics as those offered by Switch.pm, but with a different
742 pair of keywords. In Perl 6 C<switch> will be spelled C<given>, and
743 C<case> will be pronounced C<when>. In addition, the C<when> statement
744 will not require switch or case values to be parenthesized.
746 This future syntax is also (largely) available via the Switch.pm module, by
747 importing it with the argument C<"Perl6">. For example:
752 when 1 { handle_num_1(); }
753 when ($str1) { handle_str_1(); }
754 when [0..9] { handle_num_any(); last }
755 when /\d/ { handle_dig_any(); }
756 when /.*/ { handle_str_any(); }
757 default { handle anything else; }
760 Note that scalars still need to be parenthesized, since they would be
763 Note too that you can mix and match both syntaxes by importing the module
766 use Switch 'Perl5', 'Perl6';
769 =head2 Higher-order Operations
771 One situation in which C<switch> and C<case> do not provide a good
772 substitute for a cascaded C<if>, is where a switch value needs to
773 be tested against a series of conditions. For example:
777 case { $_[0] < 10 } { return 'milk' }
778 case { $_[0] < 20 } { return 'coke' }
779 case { $_[0] < 30 } { return 'beer' }
780 case { $_[0] < 40 } { return 'wine' }
781 case { $_[0] < 50 } { return 'malt' }
782 case { $_[0] < 60 } { return 'Moet' }
783 else { return 'milk' }
787 (This is equivalent to writing C<case (sub { $_[0] < 10 })>, etc.; C<$_[0]>
788 is the argument to the anonymous subroutine.)
790 The need to specify each condition as a subroutine block is tiresome. To
791 overcome this, when importing Switch.pm, a special "placeholder"
792 subroutine named C<__> [sic] may also be imported. This subroutine
793 converts (almost) any expression in which it appears to a reference to a
794 higher-order function. That is, the expression:
804 With C<__>, the previous ugly case statements can be rewritten:
806 case __ < 10 { return 'milk' }
807 case __ < 20 { return 'coke' }
808 case __ < 30 { return 'beer' }
809 case __ < 40 { return 'wine' }
810 case __ < 50 { return 'malt' }
811 case __ < 60 { return 'Moet' }
812 else { return 'milk' }
814 The C<__> subroutine makes extensive use of operator overloading to
815 perform its magic. All operations involving __ are overloaded to
816 produce an anonymous subroutine that implements a lazy version
817 of the original operation.
819 The only problem is that operator overloading does not allow the
820 boolean operators C<&&> and C<||> to be overloaded. So a case statement
823 case 0 <= __ && __ < 10 { return 'digit' }
825 doesn't act as expected, because when it is
826 executed, it constructs two higher order subroutines
827 and then treats the two resulting references as arguments to C<&&>:
829 sub { 0 <= $_[0] } && sub { $_[0] < 10 }
831 This boolean expression is inevitably true, since both references are
832 non-false. Fortunately, the overloaded C<'bool'> operator catches this
833 situation and flags it as a error.
837 The module is implemented using Filter::Util::Call and Text::Balanced
838 and requires both these modules to be installed.
842 Damian Conway (damian@conway.org). The maintainer of this module is now Rafael
843 Garcia-Suarez (rgarciasuarez@gmail.com).
847 There are undoubtedly serious bugs lurking somewhere in code this funky :-)
848 Bug reports and other feedback are most welcome.
852 Due to the heuristic nature of Switch.pm's source parsing, the presence
853 of regexes specified with raw C<?...?> delimiters may cause mysterious
854 errors. The workaround is to use C<m?...?> instead.
856 Due to the way source filters work in Perl, you can't use Switch inside
859 If your source file is longer then 1 million characters and you have a
860 switch statement that crosses the 1 million (or 2 million, etc.)
861 character boundary you will get mysterious errors. The workaround is to
862 use smaller source files.
866 Copyright (c) 1997-2006, Damian Conway. All Rights Reserved.
867 This module is free software. It may be used, redistributed
868 and/or modified under the same terms as Perl itself.