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(10_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/;
94 component: while (pos $source < length $source)
96 if ($source =~ m/(\G\s*use\s+Switch\b)/gc)
98 $text .= q{use Switch 'noimport'};
101 my @pos = Text::Balanced::_match_quotelike(\$source,qr/\s*/,1,0);
104 $text .= " " if $pos[0] < $pos[2];
105 $text .= substr($source,$pos[2],$pos[18]-$pos[2]);
108 if ($source =~ m/\G\s*($pod_or_DATA)/gc) {
111 @pos = Text::Balanced::_match_variable(\$source,qr/\s*/);
114 $text .= " " if $pos[0] < $pos[2];
115 $text .= substr($source,$pos[0],$pos[4]-$pos[0]);
119 if ($Perl5 && $source =~ m/\G(\n*)(\s*)(switch)\b(?=\s*[(])/gc
120 || $Perl6 && $source =~ m/\G(\n*)(\s*)(given)\b(?=\s*[(])/gc
121 || $Perl6 && $source =~ m/\G(\n*)(\s*)(given)\b(.*)(?=\{)/gc)
125 # print STDERR "[$arg]\n";
126 $text .= $1.$2.'S_W_I_T_C_H: while (1) ';
128 @pos = Text::Balanced::_match_codeblock(\$source,qr/\s*/,qr/\(/,qr/\)/,qr/[[{(<]/,qr/[]})>]/,undef)
130 die "Bad $keyword statement (problem in the parentheses?) near $Switch::file line ", line(substr($source,0,pos $source),$line), "\n";
132 $arg = filter_blocks(substr($source,$pos[0],$pos[4]-$pos[0]),line(substr($source,0,$pos[0]),$line));
134 $arg =~ s {^\s*[(]\s*%} { ( \\\%} ||
135 $arg =~ s {^\s*[(]\s*m\b} { ( qr} ||
136 $arg =~ s {^\s*[(]\s*/} { ( qr/} ||
137 $arg =~ s {^\s*[(]\s*qw} { ( \\qw};
138 @pos = Text::Balanced::_match_codeblock(\$source,qr/\s*/,qr/\{/,qr/\}/,qr/\{/,qr/\}/,undef)
140 die "Bad $keyword statement (problem in the code block?) near $Switch::file line ", line(substr($source,0, pos $source), $line), "\n";
142 my $code = filter_blocks(substr($source,$pos[0],$pos[4]-$pos[0]),line(substr($source,0,$pos[0]),$line));
143 $code =~ s/{/{ local \$::_S_W_I_T_C_H; Switch::switch $arg;/;
144 $text .= $code . 'continue {last}';
147 elsif ($Perl5 && $source =~ m/\G(\s*)(case\b)(?!\s*=>)/gc
148 || $Perl6 && $source =~ m/\G(\s*)(when\b)(?!\s*=>)/gc)
151 $text .= $1."if (Switch::case";
152 if (@pos = Text::Balanced::_match_codeblock(\$source,qr/\s*/,qr/\{/,qr/\}/,qr/\{/,qr/\}/,undef)) {
153 my $code = substr($source,$pos[0],$pos[4]-$pos[0]);
154 $text .= " " if $pos[0] < $pos[2];
155 $text .= "sub " if is_block $code;
156 $text .= filter_blocks($code,line(substr($source,0,$pos[0]),$line)) . ")";
158 elsif (@pos = Text::Balanced::_match_codeblock(\$source,qr/\s*/,qr/[[(]/,qr/[])]/,qr/[[({]/,qr/[])}]/,undef)) {
159 my $code = filter_blocks(substr($source,$pos[0],$pos[4]-$pos[0]),line(substr($source,0,$pos[0]),$line));
160 $code =~ s {^\s*[(]\s*%} { ( \\\%} ||
161 $code =~ s {^\s*[(]\s*m\b} { ( qr} ||
162 $code =~ s {^\s*[(]\s*/} { ( qr/} ||
163 $code =~ s {^\s*[(]\s*qw} { ( \\qw};
164 $text .= " " if $pos[0] < $pos[2];
167 elsif ($Perl6 && do{@pos = Text::Balanced::_match_variable(\$source,qr/\s*/)}) {
168 my $code = filter_blocks(substr($source,$pos[0],$pos[4]-$pos[0]),line(substr($source,0,$pos[0]),$line));
169 $code =~ s {^\s*%} { \%} ||
170 $code =~ s {^\s*@} { \@};
171 $text .= " " if $pos[0] < $pos[2];
174 elsif ( @pos = Text::Balanced::_match_quotelike(\$source,qr/\s*/,1,0)) {
175 my $code = substr($source,$pos[2],$pos[18]-$pos[2]);
176 $code = filter_blocks($code,line(substr($source,0,$pos[2]),$line));
177 $code =~ s {^\s*m} { qr} ||
178 $code =~ s {^\s*/} { qr/} ||
179 $code =~ s {^\s*qw} { \\qw};
180 $text .= " " if $pos[0] < $pos[2];
183 elsif ($Perl5 && $source =~ m/\G\s*(([^\$\@{])[^\$\@{]*)(?=\s*{)/gc
184 || $Perl6 && $source =~ m/\G\s*([^;{]*)()/gc) {
185 my $code = filter_blocks($1,line(substr($source,0,pos $source),$line));
186 $text .= ' \\' if $2 eq '%';
190 die "Bad $keyword statement (invalid $keyword value?) near $Switch::file line ", line(substr($source,0,pos $source), $line), "\n";
193 die "Missing opening brace or semi-colon after 'when' value near $Switch::file line ", line(substr($source,0,pos $source), $line), "\n"
194 unless !$Perl6 || $source =~ m/\G(\s*)(?=;|\{)/gc;
196 do{@pos = Text::Balanced::_match_codeblock(\$source,qr/\s*/,qr/\{/,qr/\}/,qr/\{/,qr/\}/,undef)}
198 if ($source =~ m/\G\s*(?=([};]|\Z))/gc) {
202 die "Bad $keyword statement (problem in the code block?) near $Switch::file line ", line(substr($source,0,pos $source),$line), "\n";
204 my $code = filter_blocks(substr($source,$pos[0],$pos[4]-$pos[0]),line(substr($source,0,$pos[0]),$line));
205 $code =~ s/}(?=\s*\Z)/;last S_W_I_T_C_H }/
207 $text .= "{ while (1) $code continue { goto C_A_S_E_$casecounter } last S_W_I_T_C_H; C_A_S_E_$casecounter: }";
212 $source =~ m/\G(\s*(-[sm]\s+|\w+|#.*\n|\W))/gc;
224 for my $nextx ( @$x )
226 my $numx = ref($nextx) || defined $nextx && (~$nextx&$nextx) eq 0;
227 for my $j ( 0..$#$y )
229 my $nexty = $y->[$j];
230 push @numy, ref($nexty) || defined $nexty && (~$nexty&$nexty) eq 0
232 return 1 if $numx && $numy[$j] && $nextx==$nexty
242 my $ref = @_==1 && ref($_[0]) eq 'HASH' ? $_[0] : { @_ };
248 my $ref = @_==1 && ref($_[0]) eq 'HASH' ? $_[0] : { @_ };
249 [ grep { defined $ref->{$_} } keys %$ref ]
254 my ($s_val) = @_ ? $_[0] : $_;
255 my $s_ref = ref $s_val;
257 if ($s_ref eq 'CODE')
260 sub { my $c_val = $_[0];
261 return $s_val == $c_val if ref $c_val eq 'CODE';
262 return $s_val->(@$c_val) if ref $c_val eq 'ARRAY';
263 return $s_val->($c_val);
266 elsif ($s_ref eq "" && defined $s_val && (~$s_val&$s_val) eq 0) # NUMERIC SCALAR
269 sub { my $c_val = $_[0];
270 my $c_ref = ref $c_val;
271 return $s_val == $c_val if $c_ref eq ""
273 && (~$c_val&$c_val) eq 0;
274 return $s_val eq $c_val if $c_ref eq "";
275 return in([$s_val],$c_val) if $c_ref eq 'ARRAY';
276 return $c_val->($s_val) if $c_ref eq 'CODE';
277 return $c_val->call($s_val) if $c_ref eq 'Switch';
278 return scalar $s_val=~/$c_val/
279 if $c_ref eq 'Regexp';
280 return scalar $c_val->{$s_val}
285 elsif ($s_ref eq "") # STRING SCALAR
288 sub { my $c_val = $_[0];
289 my $c_ref = ref $c_val;
290 return $s_val eq $c_val if $c_ref eq "";
291 return in([$s_val],$c_val) if $c_ref eq 'ARRAY';
292 return $c_val->($s_val) if $c_ref eq 'CODE';
293 return $c_val->call($s_val) if $c_ref eq 'Switch';
294 return scalar $s_val=~/$c_val/
295 if $c_ref eq 'Regexp';
296 return scalar $c_val->{$s_val}
301 elsif ($s_ref eq 'ARRAY')
304 sub { my $c_val = $_[0];
305 my $c_ref = ref $c_val;
306 return in($s_val,[$c_val]) if $c_ref eq "";
307 return in($s_val,$c_val) if $c_ref eq 'ARRAY';
308 return $c_val->(@$s_val) if $c_ref eq 'CODE';
309 return $c_val->call(@$s_val)
310 if $c_ref eq 'Switch';
311 return scalar grep {$_=~/$c_val/} @$s_val
312 if $c_ref eq 'Regexp';
313 return scalar grep {$c_val->{$_}} @$s_val
318 elsif ($s_ref eq 'Regexp')
321 sub { my $c_val = $_[0];
322 my $c_ref = ref $c_val;
323 return $c_val=~/s_val/ if $c_ref eq "";
324 return scalar grep {$_=~/s_val/} @$c_val
325 if $c_ref eq 'ARRAY';
326 return $c_val->($s_val) if $c_ref eq 'CODE';
327 return $c_val->call($s_val) if $c_ref eq 'Switch';
328 return $s_val eq $c_val if $c_ref eq 'Regexp';
329 return grep {$_=~/$s_val/ && $c_val->{$_}} keys %$c_val
334 elsif ($s_ref eq 'HASH')
337 sub { my $c_val = $_[0];
338 my $c_ref = ref $c_val;
339 return $s_val->{$c_val} if $c_ref eq "";
340 return scalar grep {$s_val->{$_}} @$c_val
341 if $c_ref eq 'ARRAY';
342 return $c_val->($s_val) if $c_ref eq 'CODE';
343 return $c_val->call($s_val) if $c_ref eq 'Switch';
344 return grep {$_=~/$c_val/ && $s_val->{"$_"}} keys %$s_val
345 if $c_ref eq 'Regexp';
346 return $s_val==$c_val if $c_ref eq 'HASH';
350 elsif ($s_ref eq 'Switch')
353 sub { my $c_val = $_[0];
354 return $s_val == $c_val if ref $c_val eq 'Switch';
355 return $s_val->call(@$c_val)
356 if ref $c_val eq 'ARRAY';
357 return $s_val->call($c_val);
362 croak "Cannot switch on $s_ref";
367 sub case($) { local $SIG{__WARN__} = \&carp;
368 $::_S_W_I_T_C_H->(@_); }
372 my $placeholder = bless { arity=>1, impl=>sub{$_[1+$_[0]]} };
374 sub __() { $placeholder }
379 bless { arity=>0, impl=>sub{$_[$index]} };
389 my ($self,@args) = @_;
390 return $self->{impl}->(0,@args);
398 my ($left, $right, $reversed) = @_;
399 ($right,$left) = @_ if $reversed;
401 my $rop = ref $right eq 'Switch'
403 : bless { arity=>0, impl=>sub{$right} };
405 my $lop = ref $left eq 'Switch'
407 : bless { arity=>0, impl=>sub{$left} };
409 my $arity = $lop->{arity} + $rop->{arity};
413 impl => sub { my $start = shift;
414 return $op->($lop->{impl}->($start,@_),
415 $rop->{impl}->($start+$lop->{arity},@_));
428 my $lop = ref $left eq 'Switch'
430 : bless { arity=>0, impl=>sub{$left} };
432 my $arity = $lop->{arity};
436 impl => sub { $op->($lop->{impl}->(@_)) }
443 "+" => meta_bop {$_[0] + $_[1]},
444 "-" => meta_bop {$_[0] - $_[1]},
445 "*" => meta_bop {$_[0] * $_[1]},
446 "/" => meta_bop {$_[0] / $_[1]},
447 "%" => meta_bop {$_[0] % $_[1]},
448 "**" => meta_bop {$_[0] ** $_[1]},
449 "<<" => meta_bop {$_[0] << $_[1]},
450 ">>" => meta_bop {$_[0] >> $_[1]},
451 "x" => meta_bop {$_[0] x $_[1]},
452 "." => meta_bop {$_[0] . $_[1]},
453 "<" => meta_bop {$_[0] < $_[1]},
454 "<=" => meta_bop {$_[0] <= $_[1]},
455 ">" => meta_bop {$_[0] > $_[1]},
456 ">=" => meta_bop {$_[0] >= $_[1]},
457 "==" => meta_bop {$_[0] == $_[1]},
458 "!=" => meta_bop {$_[0] != $_[1]},
459 "<=>" => meta_bop {$_[0] <=> $_[1]},
460 "lt" => meta_bop {$_[0] lt $_[1]},
461 "le" => meta_bop {$_[0] le $_[1]},
462 "gt" => meta_bop {$_[0] gt $_[1]},
463 "ge" => meta_bop {$_[0] ge $_[1]},
464 "eq" => meta_bop {$_[0] eq $_[1]},
465 "ne" => meta_bop {$_[0] ne $_[1]},
466 "cmp" => meta_bop {$_[0] cmp $_[1]},
467 "\&" => meta_bop {$_[0] & $_[1]},
468 "^" => meta_bop {$_[0] ^ $_[1]},
469 "|" => meta_bop {$_[0] | $_[1]},
470 "atan2" => meta_bop {atan2 $_[0], $_[1]},
472 "neg" => meta_uop {-$_[0]},
473 "!" => meta_uop {!$_[0]},
474 "~" => meta_uop {~$_[0]},
475 "cos" => meta_uop {cos $_[0]},
476 "sin" => meta_uop {sin $_[0]},
477 "exp" => meta_uop {exp $_[0]},
478 "abs" => meta_uop {abs $_[0]},
479 "log" => meta_uop {log $_[0]},
480 "sqrt" => meta_uop {sqrt $_[0]},
481 "bool" => sub { croak "Can't use && or || in expression containing __" },
483 # "&()" => sub { $_[0]->{impl} },
485 # "||" => meta_bop {$_[0] || $_[1]},
486 # "&&" => meta_bop {$_[0] && $_[1]},
496 Switch - A switch statement for Perl
500 This document describes version 2.09 of Switch,
501 released June 12, 2002.
509 case 1 { print "number 1" }
510 case "a" { print "string a" }
511 case [1..10,42] { print "number in list" }
512 case (@array) { print "number in list" }
513 case /\w+/ { print "pattern" }
514 case qr/\w+/ { print "pattern" }
515 case (%hash) { print "entry in hash" }
516 case (\%hash) { print "entry in hash" }
517 case (\&sub) { print "arg to subroutine" }
518 else { print "previous case not true" }
523 [Skip ahead to L<"DESCRIPTION"> if you don't care about the whys
524 and wherefores of this control structure]
526 In seeking to devise a "Swiss Army" case mechanism suitable for Perl,
527 it is useful to generalize this notion of distributed conditional
528 testing as far as possible. Specifically, the concept of "matching"
529 between the switch value and the various case values need not be
530 restricted to numeric (or string or referential) equality, as it is in other
531 languages. Indeed, as Table 1 illustrates, Perl
532 offers at least eighteen different ways in which two values could
535 Table 1: Matching a switch value ($s) with a case value ($c)
537 Switch Case Type of Match Implied Matching Code
539 ====== ===== ===================== =============
541 number same numeric or referential match if $s == $c;
544 object method result of method call match if $s->$c();
545 ref name match if defined $s->$c();
548 other other string equality match if $s eq $c;
552 string regexp pattern match match if $s =~ /$c/;
554 array scalar array entry existence match if 0<=$c && $c<@$s;
555 ref array entry definition match if defined $s->[$c];
556 array entry truth match if $s->[$c];
558 array array array intersection match if intersects(@$s, @$c);
559 ref ref (apply this table to
560 all pairs of elements
564 array regexp array grep match if grep /$c/, @$s;
567 hash scalar hash entry existence match if exists $s->{$c};
568 ref hash entry definition match if defined $s->{$c};
569 hash entry truth match if $s->{$c};
571 hash regexp hash grep match if grep /$c/, keys %$s;
574 sub scalar return value defn match if defined $s->($c);
575 ref return value truth match if $s->($c);
577 sub array return value defn match if defined $s->(@$c);
578 ref ref return value truth match if $s->(@$c);
581 In reality, Table 1 covers 31 alternatives, because only the equality and
582 intersection tests are commutative; in all other cases, the roles of
583 the C<$s> and C<$c> variables could be reversed to produce a
584 different test. For example, instead of testing a single hash for
585 the existence of a series of keys (C<match if exists $s-E<gt>{$c}>),
586 one could test for the existence of a single key in a series of hashes
587 (C<match if exists $c-E<gt>{$s}>).
589 As L<perltodo> observes, a Perl case mechanism must support all these
595 The Switch.pm module implements a generalized case mechanism that covers
596 the numerous possible combinations of switch and case values described above.
598 The module augments the standard Perl syntax with two new control
599 statements: C<switch> and C<case>. The C<switch> statement takes a
600 single scalar argument of any type, specified in parentheses.
601 C<switch> stores this value as the
602 current switch value in a (localized) control variable.
603 The value is followed by a block which may contain one or more
604 Perl statements (including the C<case> statement described below).
605 The block is unconditionally executed once the switch value has
608 A C<case> statement takes a single scalar argument (in mandatory
609 parentheses if it's a variable; otherwise the parens are optional) and
610 selects the appropriate type of matching between that argument and the
611 current switch value. The type of matching used is determined by the
612 respective types of the switch value and the C<case> argument, as
613 specified in Table 1. If the match is successful, the mandatory
614 block associated with the C<case> statement is executed.
616 In most other respects, the C<case> statement is semantically identical
617 to an C<if> statement. For example, it can be followed by an C<else>
618 clause, and can be used as a postfix statement qualifier.
620 However, when a C<case> block has been executed control is automatically
621 transferred to the statement after the immediately enclosing C<switch>
622 block, rather than to the next statement within the block. In other
623 words, the success of any C<case> statement prevents other cases in the
624 same scope from executing. But see L<"Allowing fall-through"> below.
626 Together these two new statements provide a fully generalized case
633 %special = ( woohoo => 1, d'oh => 1 );
638 case (%special) { print "homer\n"; } # if $special{$_}
639 case /a-z/i { print "alpha\n"; } # if $_ =~ /a-z/i
640 case [1..9] { print "small num\n"; } # if $_ in [1..9]
642 case { $_[0] >= 10 } { # if $_ >= 10
644 switch (sub{ $_[0] < $age } ) {
646 case 20 { print "teens\n"; } # if 20 < $age
647 case 30 { print "twenties\n"; } # if 30 < $age
648 else { print "history\n"; }
652 print "must be punctuation\n" case /\W/; # if $_ ~= /\W/
655 Note that C<switch>es can be nested within C<case> (or any other) blocks,
656 and a series of C<case> statements can try different types of matches
657 -- hash membership, pattern match, array intersection, simple equality,
658 etc. -- against the same switch value.
660 The use of intersection tests against an array reference is particularly
661 useful for aggregating integral cases:
665 switch ($_[0]) { case 0 { return 'zero' }
666 case [2,4,6,8] { return 'even' }
667 case [1,3,4,7,9] { return 'odd' }
668 case /[A-F]/i { return 'hex' }
673 =head2 Allowing fall-through
675 Fall-though (trying another case after one has already succeeded)
676 is usually a Bad Idea in a switch statement. However, this
677 is Perl, not a police state, so there I<is> a way to do it, if you must.
679 If a C<case> block executes an untargetted C<next>, control is
680 immediately transferred to the statement I<after> the C<case> statement
681 (i.e. usually another case), rather than out of the surrounding
687 case 1 { handle_num_1(); next } # and try next case...
688 case "1" { handle_str_1(); next } # and try next case...
689 case [0..9] { handle_num_any(); } # and we're done
690 case /\d/ { handle_dig_any(); next } # and try next case...
691 case /.*/ { handle_str_any(); next } # and try next case...
694 If $val held the number C<1>, the above C<switch> block would call the
695 first three C<handle_...> subroutines, jumping to the next case test
696 each time it encountered a C<next>. After the thrid C<case> block
697 was executed, control would jump to the end of the enclosing
700 On the other hand, if $val held C<10>, then only the last two C<handle_...>
701 subroutines would be called.
703 Note that this mechanism allows the notion of I<conditional fall-through>.
707 case [0..9] { handle_num_any(); next if $val < 7; }
708 case /\d/ { handle_dig_any(); }
711 If an untargetted C<last> statement is executed in a case block, this
712 immediately transfers control out of the enclosing C<switch> block
713 (in other words, there is an implicit C<last> at the end of each
714 normal C<case> block). Thus the previous example could also have been
718 case [0..9] { handle_num_any(); last if $val >= 7; next; }
719 case /\d/ { handle_dig_any(); }
723 =head2 Automating fall-through
725 In situations where case fall-through should be the norm, rather than an
726 exception, an endless succession of terminal C<next>s is tedious and ugly.
727 Hence, it is possible to reverse the default behaviour by specifying
728 the string "fallthrough" when importing the module. For example, the
729 following code is equivalent to the first example in L<"Allowing fall-through">:
731 use Switch 'fallthrough';
734 case 1 { handle_num_1(); }
735 case "1" { handle_str_1(); }
736 case [0..9] { handle_num_any(); last }
737 case /\d/ { handle_dig_any(); }
738 case /.*/ { handle_str_any(); }
741 Note the explicit use of a C<last> to preserve the non-fall-through
742 behaviour of the third case.
746 =head2 Alternative syntax
748 Perl 6 will provide a built-in switch statement with essentially the
749 same semantics as those offered by Switch.pm, but with a different
750 pair of keywords. In Perl 6 C<switch> will be spelled C<given>, and
751 C<case> will be pronounced C<when>. In addition, the C<when> statement
752 will not require switch or case values to be parenthesized.
754 This future syntax is also (largely) available via the Switch.pm module, by
755 importing it with the argument C<"Perl6">. For example:
760 when 1 { handle_num_1(); }
761 when ($str1) { handle_str_1(); }
762 when [0..9] { handle_num_any(); last }
763 when /\d/ { handle_dig_any(); }
764 when /.*/ { handle_str_any(); }
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:
785 case sub { $_[0] < 10 } { return 'milk' }
786 case sub { $_[0] < 20 } { return 'coke' }
787 case sub { $_[0] < 30 } { return 'beer' }
788 case sub { $_[0] < 40 } { return 'wine' }
789 case sub { $_[0] < 50 } { return 'malt' }
790 case sub { $_[0] < 60 } { return 'Moet' }
791 else { return 'milk' }
795 The need to specify each condition as a subroutine block is tiresome. To
796 overcome this, when importing Switch.pm, a special "placeholder"
797 subroutine named C<__> [sic] may also be imported. This subroutine
798 converts (almost) any expression in which it appears to a reference to a
799 higher-order function. That is, the expression:
807 sub { $_[0] < 2 + $_[1] }
809 With C<__>, the previous ugly case statements can be rewritten:
811 case __ < 10 { return 'milk' }
812 case __ < 20 { return 'coke' }
813 case __ < 30 { return 'beer' }
814 case __ < 40 { return 'wine' }
815 case __ < 50 { return 'malt' }
816 case __ < 60 { return 'Moet' }
817 else { return 'milk' }
819 The C<__> subroutine makes extensive use of operator overloading to
820 perform its magic. All operations involving __ are overloaded to
821 produce an anonymous subroutine that implements a lazy version
822 of the original operation.
824 The only problem is that operator overloading does not allow the
825 boolean operators C<&&> and C<||> to be overloaded. So a case statement
828 case 0 <= __ && __ < 10 { return 'digit' }
830 doesn't act as expected, because when it is
831 executed, it constructs two higher order subroutines
832 and then treats the two resulting references as arguments to C<&&>:
834 sub { 0 <= $_[0] } && sub { $_[0] < 10 }
836 This boolean expression is inevitably true, since both references are
837 non-false. Fortunately, the overloaded C<'bool'> operator catches this
838 situation and flags it as a error.
842 The module is implemented using Filter::Util::Call and Text::Balanced
843 and requires both these modules to be installed.
847 Damian Conway (damian@conway.org)
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.
862 Copyright (c) 1997-2001, Damian Conway. All Rights Reserved.
863 This module is free software. It may be used, redistributed
864 and/or modified under the same terms as Perl itself.