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 .= " " . 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 .= " " . substr($source,$pos[0],$pos[4]-$pos[0]);
117 if ($Perl5 && $source =~ m/\G(\n*)(\s*)(switch)\b(?=\s*[(])/gc
118 || $Perl6 && $source =~ m/\G(\n*)(\s*)(given)\b(?=\s*[(])/gc
119 || $Perl6 && $source =~ m/\G(\n*)(\s*)(given)\b(.*)(?=\{)/gc)
123 # print STDERR "[$arg]\n";
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)
149 $text .= $1."if (Switch::case";
150 if (@pos = Text::Balanced::_match_codeblock(\$source,qr/\s*/,qr/\{/,qr/\}/,qr/\{/,qr/\}/,undef)) {
151 my $code = substr($source,$pos[0],$pos[4]-$pos[0]);
152 $text .= " sub" if is_block $code;
153 $text .= " " . filter_blocks($code,line(substr($source,0,$pos[0]),$line)) . ")";
155 elsif (@pos = Text::Balanced::_match_codeblock(\$source,qr/\s*/,qr/[[(]/,qr/[])]/,qr/[[({]/,qr/[])}]/,undef)) {
156 my $code = filter_blocks(substr($source,$pos[0],$pos[4]-$pos[0]),line(substr($source,0,$pos[0]),$line));
157 $code =~ s {^\s*[(]\s*%} { ( \\\%} ||
158 $code =~ s {^\s*[(]\s*m\b} { ( qr} ||
159 $code =~ s {^\s*[(]\s*/} { ( qr/} ||
160 $code =~ s {^\s*[(]\s*qw} { ( \\qw};
163 elsif ($Perl6 && do{@pos = Text::Balanced::_match_variable(\$source,qr/\s*/)}) {
164 my $code = filter_blocks(substr($source,$pos[0],$pos[4]-$pos[0]),line(substr($source,0,$pos[0]),$line));
165 $code =~ s {^\s*%} { \%} ||
166 $code =~ s {^\s*@} { \@};
169 elsif ( @pos = Text::Balanced::_match_quotelike(\$source,qr/\s*/,1,0)) {
170 my $code = substr($source,$pos[2],$pos[18]-$pos[2]);
171 $code = filter_blocks($code,line(substr($source,0,$pos[2]),$line));
172 $code =~ s {^\s*m} { qr} ||
173 $code =~ s {^\s*/} { qr/} ||
174 $code =~ s {^\s*qw} { \\qw};
177 elsif ($Perl5 && $source =~ m/\G\s*(([^\$\@{])[^\$\@{]*)(?=\s*{)/gc
178 || $Perl6 && $source =~ m/\G\s*([^;{]*)()/gc) {
179 my $code = filter_blocks($1,line(substr($source,0,pos $source),$line));
180 $text .= ' \\' if $2 eq '%';
184 die "Bad $keyword statement (invalid $keyword value?) near $Switch::file line ", line(substr($source,0,pos $source), $line), "\n";
187 die "Missing opening brace or semi-colon after 'when' value near $Switch::file line ", line(substr($source,0,pos $source), $line), "\n"
188 unless !$Perl6 || $source =~ m/\G(\s*)(?=;|\{)/gc;
190 do{@pos = Text::Balanced::_match_codeblock(\$source,qr/\s*/,qr/\{/,qr/\}/,qr/\{/,qr/\}/,undef)}
192 if ($source =~ m/\G\s*(?=([};]|\Z))/gc) {
196 die "Bad $keyword statement (problem in the code block?) near $Switch::file line ", line(substr($source,0,pos $source),$line), "\n";
198 my $code = filter_blocks(substr($source,$pos[0],$pos[4]-$pos[0]),line(substr($source,0,$pos[0]),$line));
199 $code =~ s/}(?=\s*\Z)/;last S_W_I_T_C_H }/
201 $text .= "{ while (1) $code continue { goto C_A_S_E_$casecounter } last S_W_I_T_C_H; C_A_S_E_$casecounter: }";
206 $source =~ m/\G(\s*(-[sm]\s+|\w+|#.*\n|\W))/gc;
218 for my $nextx ( @$x )
220 my $numx = ref($nextx) || defined $nextx && (~$nextx&$nextx) eq 0;
221 for my $j ( 0..$#$y )
223 my $nexty = $y->[$j];
224 push @numy, ref($nexty) || defined $nexty && (~$nexty&$nexty) eq 0
226 return 1 if $numx && $numy[$j] && $nextx==$nexty
236 my $ref = @_==1 && ref($_[0]) eq 'HASH' ? $_[0] : { @_ };
242 my $ref = @_==1 && ref($_[0]) eq 'HASH' ? $_[0] : { @_ };
243 [ grep { defined $ref->{$_} } keys %$ref ]
248 my ($s_val) = @_ ? $_[0] : $_;
249 my $s_ref = ref $s_val;
251 if ($s_ref eq 'CODE')
254 sub { my $c_val = $_[0];
255 return $s_val == $c_val if ref $c_val eq 'CODE';
256 return $s_val->(@$c_val) if ref $c_val eq 'ARRAY';
257 return $s_val->($c_val);
260 elsif ($s_ref eq "" && defined $s_val && (~$s_val&$s_val) eq 0) # NUMERIC SCALAR
263 sub { my $c_val = $_[0];
264 my $c_ref = ref $c_val;
265 return $s_val == $c_val if $c_ref eq ""
267 && (~$c_val&$c_val) eq 0;
268 return $s_val eq $c_val if $c_ref eq "";
269 return in([$s_val],$c_val) if $c_ref eq 'ARRAY';
270 return $c_val->($s_val) if $c_ref eq 'CODE';
271 return $c_val->call($s_val) if $c_ref eq 'Switch';
272 return scalar $s_val=~/$c_val/
273 if $c_ref eq 'Regexp';
274 return scalar $c_val->{$s_val}
279 elsif ($s_ref eq "") # STRING SCALAR
282 sub { my $c_val = $_[0];
283 my $c_ref = ref $c_val;
284 return $s_val eq $c_val if $c_ref eq "";
285 return in([$s_val],$c_val) if $c_ref eq 'ARRAY';
286 return $c_val->($s_val) if $c_ref eq 'CODE';
287 return $c_val->call($s_val) if $c_ref eq 'Switch';
288 return scalar $s_val=~/$c_val/
289 if $c_ref eq 'Regexp';
290 return scalar $c_val->{$s_val}
295 elsif ($s_ref eq 'ARRAY')
298 sub { my $c_val = $_[0];
299 my $c_ref = ref $c_val;
300 return in($s_val,[$c_val]) if $c_ref eq "";
301 return in($s_val,$c_val) if $c_ref eq 'ARRAY';
302 return $c_val->(@$s_val) if $c_ref eq 'CODE';
303 return $c_val->call(@$s_val)
304 if $c_ref eq 'Switch';
305 return scalar grep {$_=~/$c_val/} @$s_val
306 if $c_ref eq 'Regexp';
307 return scalar grep {$c_val->{$_}} @$s_val
312 elsif ($s_ref eq 'Regexp')
315 sub { my $c_val = $_[0];
316 my $c_ref = ref $c_val;
317 return $c_val=~/s_val/ if $c_ref eq "";
318 return scalar grep {$_=~/s_val/} @$c_val
319 if $c_ref eq 'ARRAY';
320 return $c_val->($s_val) if $c_ref eq 'CODE';
321 return $c_val->call($s_val) if $c_ref eq 'Switch';
322 return $s_val eq $c_val if $c_ref eq 'Regexp';
323 return grep {$_=~/$s_val/ && $c_val->{$_}} keys %$c_val
328 elsif ($s_ref eq 'HASH')
331 sub { my $c_val = $_[0];
332 my $c_ref = ref $c_val;
333 return $s_val->{$c_val} if $c_ref eq "";
334 return scalar grep {$s_val->{$_}} @$c_val
335 if $c_ref eq 'ARRAY';
336 return $c_val->($s_val) if $c_ref eq 'CODE';
337 return $c_val->call($s_val) if $c_ref eq 'Switch';
338 return grep {$_=~/$c_val/ && $s_val->{"$_"}} keys %$s_val
339 if $c_ref eq 'Regexp';
340 return $s_val==$c_val if $c_ref eq 'HASH';
344 elsif ($s_ref eq 'Switch')
347 sub { my $c_val = $_[0];
348 return $s_val == $c_val if ref $c_val eq 'Switch';
349 return $s_val->call(@$c_val)
350 if ref $c_val eq 'ARRAY';
351 return $s_val->call($c_val);
356 croak "Cannot switch on $s_ref";
361 sub case($) { local $SIG{__WARN__} = \&carp;
362 $::_S_W_I_T_C_H->(@_); }
366 my $placeholder = bless { arity=>1, impl=>sub{$_[1+$_[0]]} };
368 sub __() { $placeholder }
373 bless { arity=>0, impl=>sub{$_[$index]} };
383 my ($self,@args) = @_;
384 return $self->{impl}->(0,@args);
392 my ($left, $right, $reversed) = @_;
393 ($right,$left) = @_ if $reversed;
395 my $rop = ref $right eq 'Switch'
397 : bless { arity=>0, impl=>sub{$right} };
399 my $lop = ref $left eq 'Switch'
401 : bless { arity=>0, impl=>sub{$left} };
403 my $arity = $lop->{arity} + $rop->{arity};
407 impl => sub { my $start = shift;
408 return $op->($lop->{impl}->($start,@_),
409 $rop->{impl}->($start+$lop->{arity},@_));
422 my $lop = ref $left eq 'Switch'
424 : bless { arity=>0, impl=>sub{$left} };
426 my $arity = $lop->{arity};
430 impl => sub { $op->($lop->{impl}->(@_)) }
437 "+" => meta_bop {$_[0] + $_[1]},
438 "-" => meta_bop {$_[0] - $_[1]},
439 "*" => meta_bop {$_[0] * $_[1]},
440 "/" => meta_bop {$_[0] / $_[1]},
441 "%" => meta_bop {$_[0] % $_[1]},
442 "**" => meta_bop {$_[0] ** $_[1]},
443 "<<" => meta_bop {$_[0] << $_[1]},
444 ">>" => meta_bop {$_[0] >> $_[1]},
445 "x" => meta_bop {$_[0] x $_[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 "==" => meta_bop {$_[0] == $_[1]},
452 "!=" => meta_bop {$_[0] != $_[1]},
453 "<=>" => meta_bop {$_[0] <=> $_[1]},
454 "lt" => meta_bop {$_[0] lt $_[1]},
455 "le" => meta_bop {$_[0] le $_[1]},
456 "gt" => meta_bop {$_[0] gt $_[1]},
457 "ge" => meta_bop {$_[0] ge $_[1]},
458 "eq" => meta_bop {$_[0] eq $_[1]},
459 "ne" => meta_bop {$_[0] ne $_[1]},
460 "cmp" => meta_bop {$_[0] cmp $_[1]},
461 "\&" => meta_bop {$_[0] & $_[1]},
462 "^" => meta_bop {$_[0] ^ $_[1]},
463 "|" => meta_bop {$_[0] | $_[1]},
464 "atan2" => meta_bop {atan2 $_[0], $_[1]},
466 "neg" => meta_uop {-$_[0]},
467 "!" => meta_uop {!$_[0]},
468 "~" => meta_uop {~$_[0]},
469 "cos" => meta_uop {cos $_[0]},
470 "sin" => meta_uop {sin $_[0]},
471 "exp" => meta_uop {exp $_[0]},
472 "abs" => meta_uop {abs $_[0]},
473 "log" => meta_uop {log $_[0]},
474 "sqrt" => meta_uop {sqrt $_[0]},
475 "bool" => sub { croak "Can't use && or || in expression containing __" },
477 # "&()" => sub { $_[0]->{impl} },
479 # "||" => meta_bop {$_[0] || $_[1]},
480 # "&&" => meta_bop {$_[0] && $_[1]},
490 Switch - A switch statement for Perl
494 This document describes version 2.09 of Switch,
495 released June 12, 2002.
503 case 1 { print "number 1" }
504 case "a" { print "string a" }
505 case [1..10,42] { print "number in list" }
506 case (@array) { print "number in list" }
507 case /\w+/ { print "pattern" }
508 case qr/\w+/ { print "pattern" }
509 case (%hash) { print "entry in hash" }
510 case (\%hash) { print "entry in hash" }
511 case (\&sub) { print "arg to subroutine" }
512 else { print "previous case not true" }
517 [Skip ahead to L<"DESCRIPTION"> if you don't care about the whys
518 and wherefores of this control structure]
520 In seeking to devise a "Swiss Army" case mechanism suitable for Perl,
521 it is useful to generalize this notion of distributed conditional
522 testing as far as possible. Specifically, the concept of "matching"
523 between the switch value and the various case values need not be
524 restricted to numeric (or string or referential) equality, as it is in other
525 languages. Indeed, as Table 1 illustrates, Perl
526 offers at least eighteen different ways in which two values could
529 Table 1: Matching a switch value ($s) with a case value ($c)
531 Switch Case Type of Match Implied Matching Code
533 ====== ===== ===================== =============
535 number same numeric or referential match if $s == $c;
538 object method result of method call match if $s->$c();
539 ref name match if defined $s->$c();
542 other other string equality match if $s eq $c;
546 string regexp pattern match match if $s =~ /$c/;
548 array scalar array entry existence match if 0<=$c && $c<@$s;
549 ref array entry definition match if defined $s->[$c];
550 array entry truth match if $s->[$c];
552 array array array intersection match if intersects(@$s, @$c);
553 ref ref (apply this table to
554 all pairs of elements
558 array regexp array grep match if grep /$c/, @$s;
561 hash scalar hash entry existence match if exists $s->{$c};
562 ref hash entry definition match if defined $s->{$c};
563 hash entry truth match if $s->{$c};
565 hash regexp hash grep match if grep /$c/, keys %$s;
568 sub scalar return value defn match if defined $s->($c);
569 ref return value truth match if $s->($c);
571 sub array return value defn match if defined $s->(@$c);
572 ref ref return value truth match if $s->(@$c);
575 In reality, Table 1 covers 31 alternatives, because only the equality and
576 intersection tests are commutative; in all other cases, the roles of
577 the C<$s> and C<$c> variables could be reversed to produce a
578 different test. For example, instead of testing a single hash for
579 the existence of a series of keys (C<match if exists $s-E<gt>{$c}>),
580 one could test for the existence of a single key in a series of hashes
581 (C<match if exists $c-E<gt>{$s}>).
583 As L<perltodo> observes, a Perl case mechanism must support all these
589 The Switch.pm module implements a generalized case mechanism that covers
590 the numerous possible combinations of switch and case values described above.
592 The module augments the standard Perl syntax with two new control
593 statements: C<switch> and C<case>. The C<switch> statement takes a
594 single scalar argument of any type, specified in parentheses.
595 C<switch> stores this value as the
596 current switch value in a (localized) control variable.
597 The value is followed by a block which may contain one or more
598 Perl statements (including the C<case> statement described below).
599 The block is unconditionally executed once the switch value has
602 A C<case> statement takes a single scalar argument (in mandatory
603 parentheses if it's a variable; otherwise the parens are optional) and
604 selects the appropriate type of matching between that argument and the
605 current switch value. The type of matching used is determined by the
606 respective types of the switch value and the C<case> argument, as
607 specified in Table 1. If the match is successful, the mandatory
608 block associated with the C<case> statement is executed.
610 In most other respects, the C<case> statement is semantically identical
611 to an C<if> statement. For example, it can be followed by an C<else>
612 clause, and can be used as a postfix statement qualifier.
614 However, when a C<case> block has been executed control is automatically
615 transferred to the statement after the immediately enclosing C<switch>
616 block, rather than to the next statement within the block. In other
617 words, the success of any C<case> statement prevents other cases in the
618 same scope from executing. But see L<"Allowing fall-through"> below.
620 Together these two new statements provide a fully generalized case
627 %special = ( woohoo => 1, d'oh => 1 );
632 case (%special) { print "homer\n"; } # if $special{$_}
633 case /a-z/i { print "alpha\n"; } # if $_ =~ /a-z/i
634 case [1..9] { print "small num\n"; } # if $_ in [1..9]
636 case { $_[0] >= 10 } { # if $_ >= 10
638 switch (sub{ $_[0] < $age } ) {
640 case 20 { print "teens\n"; } # if 20 < $age
641 case 30 { print "twenties\n"; } # if 30 < $age
642 else { print "history\n"; }
646 print "must be punctuation\n" case /\W/; # if $_ ~= /\W/
649 Note that C<switch>es can be nested within C<case> (or any other) blocks,
650 and a series of C<case> statements can try different types of matches
651 -- hash membership, pattern match, array intersection, simple equality,
652 etc. -- against the same switch value.
654 The use of intersection tests against an array reference is particularly
655 useful for aggregating integral cases:
659 switch ($_[0]) { case 0 { return 'zero' }
660 case [2,4,6,8] { return 'even' }
661 case [1,3,4,7,9] { return 'odd' }
662 case /[A-F]/i { return 'hex' }
667 =head2 Allowing fall-through
669 Fall-though (trying another case after one has already succeeded)
670 is usually a Bad Idea in a switch statement. However, this
671 is Perl, not a police state, so there I<is> a way to do it, if you must.
673 If a C<case> block executes an untargetted C<next>, control is
674 immediately transferred to the statement I<after> the C<case> statement
675 (i.e. usually another case), rather than out of the surrounding
681 case 1 { handle_num_1(); next } # and try next case...
682 case "1" { handle_str_1(); next } # and try next case...
683 case [0..9] { handle_num_any(); } # and we're done
684 case /\d/ { handle_dig_any(); next } # and try next case...
685 case /.*/ { handle_str_any(); next } # and try next case...
688 If $val held the number C<1>, the above C<switch> block would call the
689 first three C<handle_...> subroutines, jumping to the next case test
690 each time it encountered a C<next>. After the thrid C<case> block
691 was executed, control would jump to the end of the enclosing
694 On the other hand, if $val held C<10>, then only the last two C<handle_...>
695 subroutines would be called.
697 Note that this mechanism allows the notion of I<conditional fall-through>.
701 case [0..9] { handle_num_any(); next if $val < 7; }
702 case /\d/ { handle_dig_any(); }
705 If an untargetted C<last> statement is executed in a case block, this
706 immediately transfers control out of the enclosing C<switch> block
707 (in other words, there is an implicit C<last> at the end of each
708 normal C<case> block). Thus the previous example could also have been
712 case [0..9] { handle_num_any(); last if $val >= 7; next; }
713 case /\d/ { handle_dig_any(); }
717 =head2 Automating fall-through
719 In situations where case fall-through should be the norm, rather than an
720 exception, an endless succession of terminal C<next>s is tedious and ugly.
721 Hence, it is possible to reverse the default behaviour by specifying
722 the string "fallthrough" when importing the module. For example, the
723 following code is equivalent to the first example in L<"Allowing fall-through">:
725 use Switch 'fallthrough';
728 case 1 { handle_num_1(); }
729 case "1" { handle_str_1(); }
730 case [0..9] { handle_num_any(); last }
731 case /\d/ { handle_dig_any(); }
732 case /.*/ { handle_str_any(); }
735 Note the explicit use of a C<last> to preserve the non-fall-through
736 behaviour of the third case.
740 =head2 Alternative syntax
742 Perl 6 will provide a built-in switch statement with essentially the
743 same semantics as those offered by Switch.pm, but with a different
744 pair of keywords. In Perl 6 C<switch> will be spelled C<given>, and
745 C<case> will be pronounced C<when>. In addition, the C<when> statement
746 will not require switch or case values to be parenthesized.
748 This future syntax is also (largely) available via the Switch.pm module, by
749 importing it with the argument C<"Perl6">. For example:
754 when 1 { handle_num_1(); }
755 when ($str1) { handle_str_1(); }
756 when [0..9] { handle_num_any(); last }
757 when /\d/ { handle_dig_any(); }
758 when /.*/ { handle_str_any(); }
761 Note that scalars still need to be parenthesized, since they would be
764 Note too that you can mix and match both syntaxes by importing the module
767 use Switch 'Perl5', 'Perl6';
770 =head2 Higher-order Operations
772 One situation in which C<switch> and C<case> do not provide a good
773 substitute for a cascaded C<if>, is where a switch value needs to
774 be tested against a series of conditions. For example:
779 case sub { $_[0] < 10 } { return 'milk' }
780 case sub { $_[0] < 20 } { return 'coke' }
781 case sub { $_[0] < 30 } { return 'beer' }
782 case sub { $_[0] < 40 } { return 'wine' }
783 case sub { $_[0] < 50 } { return 'malt' }
784 case sub { $_[0] < 60 } { return 'Moet' }
785 else { return 'milk' }
789 The need to specify each condition as a subroutine block is tiresome. To
790 overcome this, when importing Switch.pm, a special "placeholder"
791 subroutine named C<__> [sic] may also be imported. This subroutine
792 converts (almost) any expression in which it appears to a reference to a
793 higher-order function. That is, the expression:
801 sub { $_[0] < 2 + $_[1] }
803 With C<__>, the previous ugly case statements can be rewritten:
805 case __ < 10 { return 'milk' }
806 case __ < 20 { return 'coke' }
807 case __ < 30 { return 'beer' }
808 case __ < 40 { return 'wine' }
809 case __ < 50 { return 'malt' }
810 case __ < 60 { return 'Moet' }
811 else { return 'milk' }
813 The C<__> subroutine makes extensive use of operator overloading to
814 perform its magic. All operations involving __ are overloaded to
815 produce an anonymous subroutine that implements a lazy version
816 of the original operation.
818 The only problem is that operator overloading does not allow the
819 boolean operators C<&&> and C<||> to be overloaded. So a case statement
822 case 0 <= __ && __ < 10 { return 'digit' }
824 doesn't act as expected, because when it is
825 executed, it constructs two higher order subroutines
826 and then treats the two resulting references as arguments to C<&&>:
828 sub { 0 <= $_[0] } && sub { $_[0] < 10 }
830 This boolean expression is inevitably true, since both references are
831 non-false. Fortunately, the overloaded C<'bool'> operator catches this
832 situation and flags it as a error.
836 The module is implemented using Filter::Util::Call and Text::Balanced
837 and requires both these modules to be installed.
841 Damian Conway (damian@conway.org)
845 There are undoubtedly serious bugs lurking somewhere in code this funky :-)
846 Bug reports and other feedback are most welcome.
850 Due to the heuristic nature of Switch.pm's source parsing, the presence
851 of regexes specified with raw C<?...?> delimiters may cause mysterious
852 errors. The workaround is to use C<m?...?> instead.
856 Copyright (c) 1997-2001, Damian Conway. All Rights Reserved.
857 This module is free software. It may be used, redistributed
858 and/or modified under the same terms as Perl itself.