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/;
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 $text .= " " if $pos[0] < $pos[2];
104 $text .= 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 # print STDERR "[$arg]\n";
125 $text .= $1.$2.'S_W_I_T_C_H: while (1) ';
127 @pos = Text::Balanced::_match_codeblock(\$source,qr/\s*/,qr/\(/,qr/\)/,qr/[[{(<]/,qr/[]})>]/,undef)
129 die "Bad $keyword statement (problem in the parentheses?) near $Switch::file line ", line(substr($source,0,pos $source),$line), "\n";
131 $arg = filter_blocks(substr($source,$pos[0],$pos[4]-$pos[0]),line(substr($source,0,$pos[0]),$line));
133 $arg =~ s {^\s*[(]\s*%} { ( \\\%} ||
134 $arg =~ s {^\s*[(]\s*m\b} { ( qr} ||
135 $arg =~ s {^\s*[(]\s*/} { ( qr/} ||
136 $arg =~ s {^\s*[(]\s*qw} { ( \\qw};
137 @pos = Text::Balanced::_match_codeblock(\$source,qr/\s*/,qr/\{/,qr/\}/,qr/\{/,qr/\}/,undef)
139 die "Bad $keyword statement (problem in the code block?) near $Switch::file line ", line(substr($source,0, pos $source), $line), "\n";
141 my $code = filter_blocks(substr($source,$pos[0],$pos[4]-$pos[0]),line(substr($source,0,$pos[0]),$line));
142 $code =~ s/{/{ local \$::_S_W_I_T_C_H; Switch::switch $arg;/;
143 $text .= $code . 'continue {last}';
146 elsif ($Perl5 && $source =~ m/\G(\s*)(case\b)(?!\s*=>)/gc
147 || $Perl6 && $source =~ m/\G(\s*)(when\b)(?!\s*=>)/gc)
150 $text .= $1."if (Switch::case";
151 if (@pos = Text::Balanced::_match_codeblock(\$source,qr/\s*/,qr/\{/,qr/\}/,qr/\{/,qr/\}/,undef)) {
152 my $code = substr($source,$pos[0],$pos[4]-$pos[0]);
153 $text .= " " if $pos[0] < $pos[2];
154 $text .= "sub " if is_block $code;
155 $text .= filter_blocks($code,line(substr($source,0,$pos[0]),$line)) . ")";
157 elsif (@pos = Text::Balanced::_match_codeblock(\$source,qr/\s*/,qr/[[(]/,qr/[])]/,qr/[[({]/,qr/[])}]/,undef)) {
158 my $code = filter_blocks(substr($source,$pos[0],$pos[4]-$pos[0]),line(substr($source,0,$pos[0]),$line));
159 $code =~ s {^\s*[(]\s*%} { ( \\\%} ||
160 $code =~ s {^\s*[(]\s*m\b} { ( qr} ||
161 $code =~ s {^\s*[(]\s*/} { ( qr/} ||
162 $code =~ s {^\s*[(]\s*qw} { ( \\qw};
163 $text .= " " if $pos[0] < $pos[2];
166 elsif ($Perl6 && do{@pos = Text::Balanced::_match_variable(\$source,qr/\s*/)}) {
167 my $code = filter_blocks(substr($source,$pos[0],$pos[4]-$pos[0]),line(substr($source,0,$pos[0]),$line));
168 $code =~ s {^\s*%} { \%} ||
169 $code =~ s {^\s*@} { \@};
170 $text .= " " if $pos[0] < $pos[2];
173 elsif ( @pos = Text::Balanced::_match_quotelike(\$source,qr/\s*/,1,0)) {
174 my $code = substr($source,$pos[2],$pos[18]-$pos[2]);
175 $code = filter_blocks($code,line(substr($source,0,$pos[2]),$line));
176 $code =~ s {^\s*m} { qr} ||
177 $code =~ s {^\s*/} { qr/} ||
178 $code =~ s {^\s*qw} { \\qw};
179 $text .= " " if $pos[0] < $pos[2];
182 elsif ($Perl5 && $source =~ m/\G\s*(([^\$\@{])[^\$\@{]*)(?=\s*{)/gc
183 || $Perl6 && $source =~ m/\G\s*([^;{]*)()/gc) {
184 my $code = filter_blocks($1,line(substr($source,0,pos $source),$line));
185 $text .= ' \\' if $2 eq '%';
189 die "Bad $keyword statement (invalid $keyword value?) near $Switch::file line ", line(substr($source,0,pos $source), $line), "\n";
192 die "Missing opening brace or semi-colon after 'when' value near $Switch::file line ", line(substr($source,0,pos $source), $line), "\n"
193 unless !$Perl6 || $source =~ m/\G(\s*)(?=;|\{)/gc;
195 do{@pos = Text::Balanced::_match_codeblock(\$source,qr/\s*/,qr/\{/,qr/\}/,qr/\{/,qr/\}/,undef)}
197 if ($source =~ m/\G\s*(?=([};]|\Z))/gc) {
201 die "Bad $keyword statement (problem in the code block?) near $Switch::file line ", line(substr($source,0,pos $source),$line), "\n";
203 my $code = filter_blocks(substr($source,$pos[0],$pos[4]-$pos[0]),line(substr($source,0,$pos[0]),$line));
204 $code =~ s/}(?=\s*\Z)/;last S_W_I_T_C_H }/
206 $text .= "{ while (1) $code continue { goto C_A_S_E_$casecounter } last S_W_I_T_C_H; C_A_S_E_$casecounter: }";
211 $source =~ m/\G(\s*(-[sm]\s+|\w+|#.*\n|\W))/gc;
223 for my $nextx ( @$x )
225 my $numx = ref($nextx) || defined $nextx && (~$nextx&$nextx) eq 0;
226 for my $j ( 0..$#$y )
228 my $nexty = $y->[$j];
229 push @numy, ref($nexty) || defined $nexty && (~$nexty&$nexty) eq 0
231 return 1 if $numx && $numy[$j] && $nextx==$nexty
241 my $ref = @_==1 && ref($_[0]) eq 'HASH' ? $_[0] : { @_ };
247 my $ref = @_==1 && ref($_[0]) eq 'HASH' ? $_[0] : { @_ };
248 [ grep { defined $ref->{$_} } keys %$ref ]
253 my ($s_val) = @_ ? $_[0] : $_;
254 my $s_ref = ref $s_val;
256 if ($s_ref eq 'CODE')
259 sub { my $c_val = $_[0];
260 return $s_val == $c_val if ref $c_val eq 'CODE';
261 return $s_val->(@$c_val) if ref $c_val eq 'ARRAY';
262 return $s_val->($c_val);
265 elsif ($s_ref eq "" && defined $s_val && (~$s_val&$s_val) eq 0) # NUMERIC SCALAR
268 sub { my $c_val = $_[0];
269 my $c_ref = ref $c_val;
270 return $s_val == $c_val if $c_ref eq ""
272 && (~$c_val&$c_val) eq 0;
273 return $s_val eq $c_val if $c_ref eq "";
274 return in([$s_val],$c_val) if $c_ref eq 'ARRAY';
275 return $c_val->($s_val) if $c_ref eq 'CODE';
276 return $c_val->call($s_val) if $c_ref eq 'Switch';
277 return scalar $s_val=~/$c_val/
278 if $c_ref eq 'Regexp';
279 return scalar $c_val->{$s_val}
284 elsif ($s_ref eq "") # STRING SCALAR
287 sub { my $c_val = $_[0];
288 my $c_ref = ref $c_val;
289 return $s_val eq $c_val if $c_ref eq "";
290 return in([$s_val],$c_val) if $c_ref eq 'ARRAY';
291 return $c_val->($s_val) if $c_ref eq 'CODE';
292 return $c_val->call($s_val) if $c_ref eq 'Switch';
293 return scalar $s_val=~/$c_val/
294 if $c_ref eq 'Regexp';
295 return scalar $c_val->{$s_val}
300 elsif ($s_ref eq 'ARRAY')
303 sub { my $c_val = $_[0];
304 my $c_ref = ref $c_val;
305 return in($s_val,[$c_val]) if $c_ref eq "";
306 return in($s_val,$c_val) if $c_ref eq 'ARRAY';
307 return $c_val->(@$s_val) if $c_ref eq 'CODE';
308 return $c_val->call(@$s_val)
309 if $c_ref eq 'Switch';
310 return scalar grep {$_=~/$c_val/} @$s_val
311 if $c_ref eq 'Regexp';
312 return scalar grep {$c_val->{$_}} @$s_val
317 elsif ($s_ref eq 'Regexp')
320 sub { my $c_val = $_[0];
321 my $c_ref = ref $c_val;
322 return $c_val=~/s_val/ if $c_ref eq "";
323 return scalar grep {$_=~/s_val/} @$c_val
324 if $c_ref eq 'ARRAY';
325 return $c_val->($s_val) if $c_ref eq 'CODE';
326 return $c_val->call($s_val) if $c_ref eq 'Switch';
327 return $s_val eq $c_val if $c_ref eq 'Regexp';
328 return grep {$_=~/$s_val/ && $c_val->{$_}} keys %$c_val
333 elsif ($s_ref eq 'HASH')
336 sub { my $c_val = $_[0];
337 my $c_ref = ref $c_val;
338 return $s_val->{$c_val} if $c_ref eq "";
339 return scalar grep {$s_val->{$_}} @$c_val
340 if $c_ref eq 'ARRAY';
341 return $c_val->($s_val) if $c_ref eq 'CODE';
342 return $c_val->call($s_val) if $c_ref eq 'Switch';
343 return grep {$_=~/$c_val/ && $s_val->{"$_"}} keys %$s_val
344 if $c_ref eq 'Regexp';
345 return $s_val==$c_val if $c_ref eq 'HASH';
349 elsif ($s_ref eq 'Switch')
352 sub { my $c_val = $_[0];
353 return $s_val == $c_val if ref $c_val eq 'Switch';
354 return $s_val->call(@$c_val)
355 if ref $c_val eq 'ARRAY';
356 return $s_val->call($c_val);
361 croak "Cannot switch on $s_ref";
366 sub case($) { local $SIG{__WARN__} = \&carp;
367 $::_S_W_I_T_C_H->(@_); }
371 my $placeholder = bless { arity=>1, impl=>sub{$_[1+$_[0]]} };
373 sub __() { $placeholder }
378 bless { arity=>0, impl=>sub{$_[$index]} };
388 my ($self,@args) = @_;
389 return $self->{impl}->(0,@args);
397 my ($left, $right, $reversed) = @_;
398 ($right,$left) = @_ if $reversed;
400 my $rop = ref $right eq 'Switch'
402 : bless { arity=>0, impl=>sub{$right} };
404 my $lop = ref $left eq 'Switch'
406 : bless { arity=>0, impl=>sub{$left} };
408 my $arity = $lop->{arity} + $rop->{arity};
412 impl => sub { my $start = shift;
413 return $op->($lop->{impl}->($start,@_),
414 $rop->{impl}->($start+$lop->{arity},@_));
427 my $lop = ref $left eq 'Switch'
429 : bless { arity=>0, impl=>sub{$left} };
431 my $arity = $lop->{arity};
435 impl => sub { $op->($lop->{impl}->(@_)) }
442 "+" => meta_bop {$_[0] + $_[1]},
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 "x" => meta_bop {$_[0] x $_[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 "==" => meta_bop {$_[0] == $_[1]},
457 "!=" => meta_bop {$_[0] != $_[1]},
458 "<=>" => meta_bop {$_[0] <=> $_[1]},
459 "lt" => meta_bop {$_[0] lt $_[1]},
460 "le" => meta_bop {$_[0] le $_[1]},
461 "gt" => meta_bop {$_[0] gt $_[1]},
462 "ge" => meta_bop {$_[0] ge $_[1]},
463 "eq" => meta_bop {$_[0] eq $_[1]},
464 "ne" => meta_bop {$_[0] ne $_[1]},
465 "cmp" => meta_bop {$_[0] cmp $_[1]},
466 "\&" => meta_bop {$_[0] & $_[1]},
467 "^" => meta_bop {$_[0] ^ $_[1]},
468 "|" => meta_bop {$_[0] | $_[1]},
469 "atan2" => meta_bop {atan2 $_[0], $_[1]},
471 "neg" => meta_uop {-$_[0]},
472 "!" => meta_uop {!$_[0]},
473 "~" => meta_uop {~$_[0]},
474 "cos" => meta_uop {cos $_[0]},
475 "sin" => meta_uop {sin $_[0]},
476 "exp" => meta_uop {exp $_[0]},
477 "abs" => meta_uop {abs $_[0]},
478 "log" => meta_uop {log $_[0]},
479 "sqrt" => meta_uop {sqrt $_[0]},
480 "bool" => sub { croak "Can't use && or || in expression containing __" },
482 # "&()" => sub { $_[0]->{impl} },
484 # "||" => meta_bop {$_[0] || $_[1]},
485 # "&&" => meta_bop {$_[0] && $_[1]},
495 Switch - A switch statement for Perl
499 This document describes version 2.09 of Switch,
500 released June 12, 2002.
508 case 1 { print "number 1" }
509 case "a" { print "string a" }
510 case [1..10,42] { print "number in list" }
511 case (@array) { print "number in list" }
512 case /\w+/ { print "pattern" }
513 case qr/\w+/ { print "pattern" }
514 case (%hash) { print "entry in hash" }
515 case (\%hash) { print "entry in hash" }
516 case (\&sub) { print "arg to subroutine" }
517 else { print "previous case not true" }
522 [Skip ahead to L<"DESCRIPTION"> if you don't care about the whys
523 and wherefores of this control structure]
525 In seeking to devise a "Swiss Army" case mechanism suitable for Perl,
526 it is useful to generalize this notion of distributed conditional
527 testing as far as possible. Specifically, the concept of "matching"
528 between the switch value and the various case values need not be
529 restricted to numeric (or string or referential) equality, as it is in other
530 languages. Indeed, as Table 1 illustrates, Perl
531 offers at least eighteen different ways in which two values could
534 Table 1: Matching a switch value ($s) with a case value ($c)
536 Switch Case Type of Match Implied Matching Code
538 ====== ===== ===================== =============
540 number same numeric or referential match if $s == $c;
543 object method result of method call match if $s->$c();
544 ref name match if defined $s->$c();
547 other other string equality match if $s eq $c;
551 string regexp pattern match match if $s =~ /$c/;
553 array scalar array entry existence match if 0<=$c && $c<@$s;
554 ref array entry definition match if defined $s->[$c];
555 array entry truth match if $s->[$c];
557 array array array intersection match if intersects(@$s, @$c);
558 ref ref (apply this table to
559 all pairs of elements
563 array regexp array grep match if grep /$c/, @$s;
566 hash scalar hash entry existence match if exists $s->{$c};
567 ref hash entry definition match if defined $s->{$c};
568 hash entry truth match if $s->{$c};
570 hash regexp hash grep match if grep /$c/, keys %$s;
573 sub scalar return value defn match if defined $s->($c);
574 ref return value truth match if $s->($c);
576 sub array return value defn match if defined $s->(@$c);
577 ref ref return value truth match if $s->(@$c);
580 In reality, Table 1 covers 31 alternatives, because only the equality and
581 intersection tests are commutative; in all other cases, the roles of
582 the C<$s> and C<$c> variables could be reversed to produce a
583 different test. For example, instead of testing a single hash for
584 the existence of a series of keys (C<match if exists $s-E<gt>{$c}>),
585 one could test for the existence of a single key in a series of hashes
586 (C<match if exists $c-E<gt>{$s}>).
588 As L<perltodo> observes, a Perl case mechanism must support all these
594 The Switch.pm module implements a generalized case mechanism that covers
595 the numerous possible combinations of switch and case values described above.
597 The module augments the standard Perl syntax with two new control
598 statements: C<switch> and C<case>. The C<switch> statement takes a
599 single scalar argument of any type, specified in parentheses.
600 C<switch> stores this value as the
601 current switch value in a (localized) control variable.
602 The value is followed by a block which may contain one or more
603 Perl statements (including the C<case> statement described below).
604 The block is unconditionally executed once the switch value has
607 A C<case> statement takes a single scalar argument (in mandatory
608 parentheses if it's a variable; otherwise the parens are optional) and
609 selects the appropriate type of matching between that argument and the
610 current switch value. The type of matching used is determined by the
611 respective types of the switch value and the C<case> argument, as
612 specified in Table 1. If the match is successful, the mandatory
613 block associated with the C<case> statement is executed.
615 In most other respects, the C<case> statement is semantically identical
616 to an C<if> statement. For example, it can be followed by an C<else>
617 clause, and can be used as a postfix statement qualifier.
619 However, when a C<case> block has been executed control is automatically
620 transferred to the statement after the immediately enclosing C<switch>
621 block, rather than to the next statement within the block. In other
622 words, the success of any C<case> statement prevents other cases in the
623 same scope from executing. But see L<"Allowing fall-through"> below.
625 Together these two new statements provide a fully generalized case
632 %special = ( woohoo => 1, d'oh => 1 );
637 case (%special) { print "homer\n"; } # if $special{$_}
638 case /a-z/i { print "alpha\n"; } # if $_ =~ /a-z/i
639 case [1..9] { print "small num\n"; } # if $_ in [1..9]
641 case { $_[0] >= 10 } { # if $_ >= 10
643 switch (sub{ $_[0] < $age } ) {
645 case 20 { print "teens\n"; } # if 20 < $age
646 case 30 { print "twenties\n"; } # if 30 < $age
647 else { print "history\n"; }
651 print "must be punctuation\n" case /\W/; # if $_ ~= /\W/
654 Note that C<switch>es can be nested within C<case> (or any other) blocks,
655 and a series of C<case> statements can try different types of matches
656 -- hash membership, pattern match, array intersection, simple equality,
657 etc. -- against the same switch value.
659 The use of intersection tests against an array reference is particularly
660 useful for aggregating integral cases:
664 switch ($_[0]) { case 0 { return 'zero' }
665 case [2,4,6,8] { return 'even' }
666 case [1,3,4,7,9] { return 'odd' }
667 case /[A-F]/i { return 'hex' }
672 =head2 Allowing fall-through
674 Fall-though (trying another case after one has already succeeded)
675 is usually a Bad Idea in a switch statement. However, this
676 is Perl, not a police state, so there I<is> a way to do it, if you must.
678 If a C<case> block executes an untargetted C<next>, control is
679 immediately transferred to the statement I<after> the C<case> statement
680 (i.e. usually another case), rather than out of the surrounding
686 case 1 { handle_num_1(); next } # and try next case...
687 case "1" { handle_str_1(); next } # and try next case...
688 case [0..9] { handle_num_any(); } # and we're done
689 case /\d/ { handle_dig_any(); next } # and try next case...
690 case /.*/ { handle_str_any(); next } # and try next case...
693 If $val held the number C<1>, the above C<switch> block would call the
694 first three C<handle_...> subroutines, jumping to the next case test
695 each time it encountered a C<next>. After the thrid C<case> block
696 was executed, control would jump to the end of the enclosing
699 On the other hand, if $val held C<10>, then only the last two C<handle_...>
700 subroutines would be called.
702 Note that this mechanism allows the notion of I<conditional fall-through>.
706 case [0..9] { handle_num_any(); next if $val < 7; }
707 case /\d/ { handle_dig_any(); }
710 If an untargetted C<last> statement is executed in a case block, this
711 immediately transfers control out of the enclosing C<switch> block
712 (in other words, there is an implicit C<last> at the end of each
713 normal C<case> block). Thus the previous example could also have been
717 case [0..9] { handle_num_any(); last if $val >= 7; next; }
718 case /\d/ { handle_dig_any(); }
722 =head2 Automating fall-through
724 In situations where case fall-through should be the norm, rather than an
725 exception, an endless succession of terminal C<next>s is tedious and ugly.
726 Hence, it is possible to reverse the default behaviour by specifying
727 the string "fallthrough" when importing the module. For example, the
728 following code is equivalent to the first example in L<"Allowing fall-through">:
730 use Switch 'fallthrough';
733 case 1 { handle_num_1(); }
734 case "1" { handle_str_1(); }
735 case [0..9] { handle_num_any(); last }
736 case /\d/ { handle_dig_any(); }
737 case /.*/ { handle_str_any(); }
740 Note the explicit use of a C<last> to preserve the non-fall-through
741 behaviour of the third case.
745 =head2 Alternative syntax
747 Perl 6 will provide a built-in switch statement with essentially the
748 same semantics as those offered by Switch.pm, but with a different
749 pair of keywords. In Perl 6 C<switch> will be spelled C<given>, and
750 C<case> will be pronounced C<when>. In addition, the C<when> statement
751 will not require switch or case values to be parenthesized.
753 This future syntax is also (largely) available via the Switch.pm module, by
754 importing it with the argument C<"Perl6">. For example:
759 when 1 { handle_num_1(); }
760 when ($str1) { handle_str_1(); }
761 when [0..9] { handle_num_any(); last }
762 when /\d/ { handle_dig_any(); }
763 when /.*/ { handle_str_any(); }
766 Note that scalars still need to be parenthesized, since they would be
769 Note too that you can mix and match both syntaxes by importing the module
772 use Switch 'Perl5', 'Perl6';
775 =head2 Higher-order Operations
777 One situation in which C<switch> and C<case> do not provide a good
778 substitute for a cascaded C<if>, is where a switch value needs to
779 be tested against a series of conditions. For example:
784 case sub { $_[0] < 10 } { return 'milk' }
785 case sub { $_[0] < 20 } { return 'coke' }
786 case sub { $_[0] < 30 } { return 'beer' }
787 case sub { $_[0] < 40 } { return 'wine' }
788 case sub { $_[0] < 50 } { return 'malt' }
789 case sub { $_[0] < 60 } { return 'Moet' }
790 else { return 'milk' }
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:
806 sub { $_[0] < 2 + $_[1] }
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)
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
856 of regexes specified with raw C<?...?> delimiters may cause mysterious
857 errors. The workaround is to use C<m?...?> instead.
861 Copyright (c) 1997-2001, Damian Conway. All Rights Reserved.
862 This module is free software. It may be used, redistributed
863 and/or modified under the same terms as Perl itself.