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);
26 $fallthrough = grep /\bfallthrough\b/, @_;
27 $offset = (caller)[2]+1;
28 filter_add({}) unless @_>1 && $_[1] eq 'noimport';
31 for ( qw( on_defined on_exists ) )
33 *{"${pkg}::$_"} = \&$_;
35 *{"${pkg}::__"} = \&__ if grep /__/, @_;
36 $Perl6 = 1 if grep(/Perl\s*6/i, @_);
37 $Perl5 = 1 if grep(/Perl\s*5/i, @_) || !grep(/Perl\s*6/i, @_);
49 local $Switch::file = (caller)[1];
52 $status = filter_read(10_000);
53 return $status if $status<0;
54 $_ = filter_blocks($_,$offset);
55 $_ = "# line $offset\n" . $_ if $offset; undef $offset;
60 use Text::Balanced ':ALL';
64 my ($pretext,$offset) = @_;
65 ($pretext=~tr/\n/\n/)+($offset||0);
70 local $SIG{__WARN__}=sub{die$@};
72 my $ishash = defined eval 'my $hr='.$_[0];
78 my $EOP = qr/\n\n|\Z/;
79 my $CUT = qr/\n=cut.*$EOP/;
80 my $pod_or_DATA = qr/ ^=(?:head[1-4]|item) .*? $CUT
83 | ^=begin \s* (\S+) .*? \n=end \s* \1 .*? $EOP
90 my ($source, $line) = @_;
91 return $source unless $Perl5 && $source =~ /case|switch/
92 || $Perl6 && $source =~ /when|given/;
95 component: while (pos $source < length $source)
97 if ($source =~ m/(\G\s*use\s+Switch\b)/gc)
99 $text .= q{use Switch 'noimport'};
102 my @pos = Text::Balanced::_match_quotelike(\$source,qr/\s*/,1,0);
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 .= " " . 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)
122 $text .= $1.$2.'S_W_I_T_C_H: while (1) ';
123 @pos = Text::Balanced::_match_codeblock(\$source,qr/\s*/,qr/\(/,qr/\)/,qr/[[{(<]/,qr/[]})>]/,undef)
125 die "Bad $keyword statement (problem in the parentheses?) near $Switch::file line ", line(substr($source,0,pos $source),$line), "\n";
127 my $arg = filter_blocks(substr($source,$pos[0],$pos[4]-$pos[0]),line(substr($source,0,$pos[0]),$line));
128 $arg =~ s {^\s*[(]\s*%} { ( \\\%} ||
129 $arg =~ s {^\s*[(]\s*m\b} { ( qr} ||
130 $arg =~ s {^\s*[(]\s*/} { ( qr/} ||
131 $arg =~ s {^\s*[(]\s*qw} { ( \\qw};
132 @pos = Text::Balanced::_match_codeblock(\$source,qr/\s*/,qr/\{/,qr/\}/,qr/\{/,qr/\}/,undef)
134 die "Bad $keyword statement (problem in the code block?) near $Switch::file line ", line(substr($source,0, pos $source), $line), "\n";
136 my $code = filter_blocks(substr($source,$pos[0],$pos[4]-$pos[0]),line(substr($source,0,$pos[0]),$line));
137 $code =~ s/{/{ local \$::_S_W_I_T_C_H; Switch::switch $arg;/;
138 $text .= $code . 'continue {last}';
141 elsif ($Perl5 && $source =~ m/\G(\s*)(case\b)(?!\s*=>)/gc
142 || $Perl6 && $source =~ m/\G(\s*)(when\b)(?!\s*=>)/gc)
145 $text .= $1."if (Switch::case";
146 if (@pos = Text::Balanced::_match_codeblock(\$source,qr/\s*/,qr/\{/,qr/\}/,qr/\{/,qr/\}/,undef)) {
147 my $code = substr($source,$pos[0],$pos[4]-$pos[0]);
148 $text .= " sub" if is_block $code;
149 $text .= " " . filter_blocks($code,line(substr($source,0,$pos[0]),$line)) . ")";
151 elsif (@pos = Text::Balanced::_match_codeblock(\$source,qr/\s*/,qr/[[(]/,qr/[])]/,qr/[[({]/,qr/[])}]/,undef)) {
152 my $code = filter_blocks(substr($source,$pos[0],$pos[4]-$pos[0]),line(substr($source,0,$pos[0]),$line));
153 $code =~ s {^\s*[(]\s*%} { ( \\\%} ||
154 $code =~ s {^\s*[(]\s*m\b} { ( qr} ||
155 $code =~ s {^\s*[(]\s*/} { ( qr/} ||
156 $code =~ s {^\s*[(]\s*qw} { ( \\qw};
159 elsif ($Perl6 && do{@pos = Text::Balanced::_match_variable(\$source,qr/\s*/)}) {
160 my $code = filter_blocks(substr($source,$pos[0],$pos[4]-$pos[0]),line(substr($source,0,$pos[0]),$line));
161 $code =~ s {^\s*%} { \%} ||
162 $code =~ s {^\s*@} { \@};
165 elsif ( @pos = Text::Balanced::_match_quotelike(\$source,qr/\s*/,1,0)) {
166 my $code = substr($source,$pos[2],$pos[18]-$pos[2]);
167 $code = filter_blocks($code,line(substr($source,0,$pos[2]),$line));
168 $code =~ s {^\s*m} { qr} ||
169 $code =~ s {^\s*/} { qr/} ||
170 $code =~ s {^\s*qw} { \\qw};
173 elsif ($Perl5 && $source =~ m/\G\s*(([^\$\@{])[^\$\@{]*)(?=\s*{)/gc
174 || $Perl6 && $source =~ m/\G\s*([^:;]*)()/gc) {
175 my $code = filter_blocks($1,line(substr($source,0,pos $source),$line));
176 $text .= ' \\' if $2 eq '%';
180 die "Bad $keyword statement (invalid $keyword value?) near $Switch::file line ", line(substr($source,0,pos $source), $line), "\n";
183 die "Missing colon or semi-colon after 'when' value near $Switch::file line ", line(substr($source,0,pos $source), $line), "\n"
184 unless !$Perl6 || $source =~ m/\G(\s*)(:|(?=;))/gc;
186 do{@pos = Text::Balanced::_match_codeblock(\$source,qr/\s*/,qr/\{/,qr/\}/,qr/\{/,qr/\}/,undef)}
188 if ($source =~ m/\G\s*(?=([};]|\Z))/gc) {
192 die "Bad $keyword statement (problem in the code block?) near $Switch::file line ", line(substr($source,0,pos $source),$line), "\n";
194 my $code = filter_blocks(substr($source,$pos[0],$pos[4]-$pos[0]),line(substr($source,0,$pos[0]),$line));
195 $code =~ s/}(?=\s*\Z)/;last S_W_I_T_C_H }/
197 $text .= "{ while (1) $code continue { goto C_A_S_E_$casecounter } last S_W_I_T_C_H; C_A_S_E_$casecounter: }";
202 $source =~ m/\G(\s*(-[sm]\s+|\w+|#.*\n|\W))/gc;
214 for my $nextx ( @$x )
216 my $numx = ref($nextx) || defined $nextx && (~$nextx&$nextx) eq 0;
217 for my $j ( 0..$#$y )
219 my $nexty = $y->[$j];
220 push @numy, ref($nexty) || defined $nexty && (~$nexty&$nexty) eq 0
222 return 1 if $numx && $numy[$j] && $nextx==$nexty
232 my $ref = @_==1 && ref($_[0]) eq 'HASH' ? $_[0] : { @_ };
238 my $ref = @_==1 && ref($_[0]) eq 'HASH' ? $_[0] : { @_ };
239 [ grep { defined $ref->{$_} } keys %$ref ]
244 my ($s_val) = @_ ? $_[0] : $_;
245 my $s_ref = ref $s_val;
247 if ($s_ref eq 'CODE')
250 sub { my $c_val = $_[0];
251 return $s_val == $c_val if ref $c_val eq 'CODE';
252 return $s_val->(@$c_val) if ref $c_val eq 'ARRAY';
253 return $s_val->($c_val);
256 elsif ($s_ref eq "" && defined $s_val && (~$s_val&$s_val) eq 0) # NUMERIC SCALAR
259 sub { my $c_val = $_[0];
260 my $c_ref = ref $c_val;
261 return $s_val == $c_val if $c_ref eq ""
263 && (~$c_val&$c_val) eq 0;
264 return $s_val eq $c_val if $c_ref eq "";
265 return in([$s_val],$c_val) if $c_ref eq 'ARRAY';
266 return $c_val->($s_val) if $c_ref eq 'CODE';
267 return $c_val->call($s_val) if $c_ref eq 'Switch';
268 return scalar $s_val=~/$c_val/
269 if $c_ref eq 'Regexp';
270 return scalar $c_val->{$s_val}
275 elsif ($s_ref eq "") # STRING SCALAR
278 sub { my $c_val = $_[0];
279 my $c_ref = ref $c_val;
280 return $s_val eq $c_val if $c_ref eq "";
281 return in([$s_val],$c_val) if $c_ref eq 'ARRAY';
282 return $c_val->($s_val) if $c_ref eq 'CODE';
283 return $c_val->call($s_val) if $c_ref eq 'Switch';
284 return scalar $s_val=~/$c_val/
285 if $c_ref eq 'Regexp';
286 return scalar $c_val->{$s_val}
291 elsif ($s_ref eq 'ARRAY')
294 sub { my $c_val = $_[0];
295 my $c_ref = ref $c_val;
296 return in($s_val,[$c_val]) if $c_ref eq "";
297 return in($s_val,$c_val) if $c_ref eq 'ARRAY';
298 return $c_val->(@$s_val) if $c_ref eq 'CODE';
299 return $c_val->call(@$s_val)
300 if $c_ref eq 'Switch';
301 return scalar grep {$_=~/$c_val/} @$s_val
302 if $c_ref eq 'Regexp';
303 return scalar grep {$c_val->{$_}} @$s_val
308 elsif ($s_ref eq 'Regexp')
311 sub { my $c_val = $_[0];
312 my $c_ref = ref $c_val;
313 return $c_val=~/s_val/ if $c_ref eq "";
314 return scalar grep {$_=~/s_val/} @$c_val
315 if $c_ref eq 'ARRAY';
316 return $c_val->($s_val) if $c_ref eq 'CODE';
317 return $c_val->call($s_val) if $c_ref eq 'Switch';
318 return $s_val eq $c_val if $c_ref eq 'Regexp';
319 return grep {$_=~/$s_val/ && $c_val->{$_}} keys %$c_val
324 elsif ($s_ref eq 'HASH')
327 sub { my $c_val = $_[0];
328 my $c_ref = ref $c_val;
329 return $s_val->{$c_val} if $c_ref eq "";
330 return scalar grep {$s_val->{$_}} @$c_val
331 if $c_ref eq 'ARRAY';
332 return $c_val->($s_val) if $c_ref eq 'CODE';
333 return $c_val->call($s_val) if $c_ref eq 'Switch';
334 return grep {$_=~/$c_val/ && $s_val->{"$_"}} keys %$s_val
335 if $c_ref eq 'Regexp';
336 return $s_val==$c_val if $c_ref eq 'HASH';
340 elsif ($s_ref eq 'Switch')
343 sub { my $c_val = $_[0];
344 return $s_val == $c_val if ref $c_val eq 'Switch';
345 return $s_val->call(@$c_val)
346 if ref $c_val eq 'ARRAY';
347 return $s_val->call($c_val);
352 croak "Cannot switch on $s_ref";
357 sub case($) { local $SIG{__WARN__} = \&carp;
358 $::_S_W_I_T_C_H->(@_); }
362 my $placeholder = bless { arity=>1, impl=>sub{$_[1+$_[0]]} };
364 sub __() { $placeholder }
369 bless { arity=>0, impl=>sub{$_[$index]} };
379 my ($self,@args) = @_;
380 return $self->{impl}->(0,@args);
388 my ($left, $right, $reversed) = @_;
389 ($right,$left) = @_ if $reversed;
391 my $rop = ref $right eq 'Switch'
393 : bless { arity=>0, impl=>sub{$right} };
395 my $lop = ref $left eq 'Switch'
397 : bless { arity=>0, impl=>sub{$left} };
399 my $arity = $lop->{arity} + $rop->{arity};
403 impl => sub { my $start = shift;
404 return $op->($lop->{impl}->($start,@_),
405 $rop->{impl}->($start+$lop->{arity},@_));
418 my $lop = ref $left eq 'Switch'
420 : bless { arity=>0, impl=>sub{$left} };
422 my $arity = $lop->{arity};
426 impl => sub { $op->($lop->{impl}->(@_)) }
433 "+" => meta_bop {$_[0] + $_[1]},
434 "-" => meta_bop {$_[0] - $_[1]},
435 "*" => meta_bop {$_[0] * $_[1]},
436 "/" => meta_bop {$_[0] / $_[1]},
437 "%" => meta_bop {$_[0] % $_[1]},
438 "**" => meta_bop {$_[0] ** $_[1]},
439 "<<" => meta_bop {$_[0] << $_[1]},
440 ">>" => meta_bop {$_[0] >> $_[1]},
441 "x" => meta_bop {$_[0] x $_[1]},
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 "lt" => meta_bop {$_[0] lt $_[1]},
451 "le" => meta_bop {$_[0] le $_[1]},
452 "gt" => meta_bop {$_[0] gt $_[1]},
453 "ge" => meta_bop {$_[0] ge $_[1]},
454 "eq" => meta_bop {$_[0] eq $_[1]},
455 "ne" => meta_bop {$_[0] ne $_[1]},
456 "cmp" => meta_bop {$_[0] cmp $_[1]},
457 "\&" => meta_bop {$_[0] & $_[1]},
458 "^" => meta_bop {$_[0] ^ $_[1]},
459 "|" => meta_bop {$_[0] | $_[1]},
460 "atan2" => meta_bop {atan2 $_[0], $_[1]},
462 "neg" => meta_uop {-$_[0]},
463 "!" => meta_uop {!$_[0]},
464 "~" => meta_uop {~$_[0]},
465 "cos" => meta_uop {cos $_[0]},
466 "sin" => meta_uop {sin $_[0]},
467 "exp" => meta_uop {exp $_[0]},
468 "abs" => meta_uop {abs $_[0]},
469 "log" => meta_uop {log $_[0]},
470 "sqrt" => meta_uop {sqrt $_[0]},
471 "bool" => sub { croak "Can't use && or || in expression containing __" },
473 # "&()" => sub { $_[0]->{impl} },
475 # "||" => meta_bop {$_[0] || $_[1]},
476 # "&&" => meta_bop {$_[0] && $_[1]},
486 Switch - A switch statement for Perl
490 This document describes version 2.06 of Switch,
491 released November 14, 2001.
499 case 1 { print "number 1" }
500 case "a" { print "string a" }
501 case [1..10,42] { print "number in list" }
502 case (@array) { print "number in list" }
503 case /\w+/ { print "pattern" }
504 case qr/\w+/ { print "pattern" }
505 case (%hash) { print "entry in hash" }
506 case (\%hash) { print "entry in hash" }
507 case (\&sub) { print "arg to subroutine" }
508 else { print "previous case not true" }
513 [Skip ahead to L<"DESCRIPTION"> if you don't care about the whys
514 and wherefores of this control structure]
516 In seeking to devise a "Swiss Army" case mechanism suitable for Perl,
517 it is useful to generalize this notion of distributed conditional
518 testing as far as possible. Specifically, the concept of "matching"
519 between the switch value and the various case values need not be
520 restricted to numeric (or string or referential) equality, as it is in other
521 languages. Indeed, as Table 1 illustrates, Perl
522 offers at least eighteen different ways in which two values could
525 Table 1: Matching a switch value ($s) with a case value ($c)
527 Switch Case Type of Match Implied Matching Code
529 ====== ===== ===================== =============
531 number same numeric or referential match if $s == $c;
534 object method result of method call match if $s->$c();
535 ref name match if defined $s->$c();
538 other other string equality match if $s eq $c;
542 string regexp pattern match match if $s =~ /$c/;
544 array scalar array entry existence match if 0<=$c && $c<@$s;
545 ref array entry definition match if defined $s->[$c];
546 array entry truth match if $s->[$c];
548 array array array intersection match if intersects(@$s, @$c);
549 ref ref (apply this table to
550 all pairs of elements
554 array regexp array grep match if grep /$c/, @$s;
557 hash scalar hash entry existence match if exists $s->{$c};
558 ref hash entry definition match if defined $s->{$c};
559 hash entry truth match if $s->{$c};
561 hash regexp hash grep match if grep /$c/, keys %$s;
564 sub scalar return value defn match if defined $s->($c);
565 ref return value truth match if $s->($c);
567 sub array return value defn match if defined $s->(@$c);
568 ref ref return value truth match if $s->(@$c);
571 In reality, Table 1 covers 31 alternatives, because only the equality and
572 intersection tests are commutative; in all other cases, the roles of
573 the C<$s> and C<$c> variables could be reversed to produce a
574 different test. For example, instead of testing a single hash for
575 the existence of a series of keys (C<match if exists $s-E<gt>{$c}>),
576 one could test for the existence of a single key in a series of hashes
577 (C<match if exists $c-E<gt>{$s}>).
579 As L<perltodo> observes, a Perl case mechanism must support all these
585 The Switch.pm module implements a generalized case mechanism that covers
586 the numerous possible combinations of switch and case values described above.
588 The module augments the standard Perl syntax with two new control
589 statements: C<switch> and C<case>. The C<switch> statement takes a
590 single scalar argument of any type, specified in parentheses.
591 C<switch> stores this value as the
592 current switch value in a (localized) control variable.
593 The value is followed by a block which may contain one or more
594 Perl statements (including the C<case> statement described below).
595 The block is unconditionally executed once the switch value has
598 A C<case> statement takes a single scalar argument (in mandatory
599 parentheses if it's a variable; otherwise the parens are optional) and
600 selects the appropriate type of matching between that argument and the
601 current switch value. The type of matching used is determined by the
602 respective types of the switch value and the C<case> argument, as
603 specified in Table 1. If the match is successful, the mandatory
604 block associated with the C<case> statement is executed.
606 In most other respects, the C<case> statement is semantically identical
607 to an C<if> statement. For example, it can be followed by an C<else>
608 clause, and can be used as a postfix statement qualifier.
610 However, when a C<case> block has been executed control is automatically
611 transferred to the statement after the immediately enclosing C<switch>
612 block, rather than to the next statement within the block. In other
613 words, the success of any C<case> statement prevents other cases in the
614 same scope from executing. But see L<"Allowing fall-through"> below.
616 Together these two new statements provide a fully generalized case
623 %special = ( woohoo => 1, d'oh => 1 );
628 case (%special) { print "homer\n"; } # if $special{$_}
629 case /a-z/i { print "alpha\n"; } # if $_ =~ /a-z/i
630 case [1..9] { print "small num\n"; } # if $_ in [1..9]
632 case { $_[0] >= 10 } { # if $_ >= 10
634 switch (sub{ $_[0] < $age } ) {
636 case 20 { print "teens\n"; } # if 20 < $age
637 case 30 { print "twenties\n"; } # if 30 < $age
638 else { print "history\n"; }
642 print "must be punctuation\n" case /\W/; # if $_ ~= /\W/
645 Note that C<switch>es can be nested within C<case> (or any other) blocks,
646 and a series of C<case> statements can try different types of matches
647 -- hash membership, pattern match, array intersection, simple equality,
648 etc. -- against the same switch value.
650 The use of intersection tests against an array reference is particularly
651 useful for aggregating integral cases:
655 switch ($_[0]) { case 0 { return 'zero' }
656 case [2,4,6,8] { return 'even' }
657 case [1,3,4,7,9] { return 'odd' }
658 case /[A-F]/i { return 'hex' }
663 =head2 Allowing fall-through
665 Fall-though (trying another case after one has already succeeded)
666 is usually a Bad Idea in a switch statement. However, this
667 is Perl, not a police state, so there I<is> a way to do it, if you must.
669 If a C<case> block executes an untargetted C<next>, control is
670 immediately transferred to the statement I<after> the C<case> statement
671 (i.e. usually another case), rather than out of the surrounding
677 case 1 { handle_num_1(); next } # and try next case...
678 case "1" { handle_str_1(); next } # and try next case...
679 case [0..9] { handle_num_any(); } # and we're done
680 case /\d/ { handle_dig_any(); next } # and try next case...
681 case /.*/ { handle_str_any(); next } # and try next case...
684 If $val held the number C<1>, the above C<switch> block would call the
685 first three C<handle_...> subroutines, jumping to the next case test
686 each time it encountered a C<next>. After the thrid C<case> block
687 was executed, control would jump to the end of the enclosing
690 On the other hand, if $val held C<10>, then only the last two C<handle_...>
691 subroutines would be called.
693 Note that this mechanism allows the notion of I<conditional fall-through>.
697 case [0..9] { handle_num_any(); next if $val < 7; }
698 case /\d/ { handle_dig_any(); }
701 If an untargetted C<last> statement is executed in a case block, this
702 immediately transfers control out of the enclosing C<switch> block
703 (in other words, there is an implicit C<last> at the end of each
704 normal C<case> block). Thus the previous example could also have been
708 case [0..9] { handle_num_any(); last if $val >= 7; next; }
709 case /\d/ { handle_dig_any(); }
713 =head2 Automating fall-through
715 In situations where case fall-through should be the norm, rather than an
716 exception, an endless succession of terminal C<next>s is tedious and ugly.
717 Hence, it is possible to reverse the default behaviour by specifying
718 the string "fallthrough" when importing the module. For example, the
719 following code is equivalent to the first example in L<"Allowing fall-through">:
721 use Switch 'fallthrough';
724 case 1 { handle_num_1(); }
725 case "1" { handle_str_1(); }
726 case [0..9] { handle_num_any(); last }
727 case /\d/ { handle_dig_any(); }
728 case /.*/ { handle_str_any(); }
731 Note the explicit use of a C<last> to preserve the non-fall-through
732 behaviour of the third case.
736 =head2 Alternative syntax
738 Perl 6 will provide a built-in switch statement with essentially the
739 same semantics as those offered by Switch.pm, but with a different
740 pair of keywords. In Perl 6 C<switch> with be spelled C<given>, and
741 C<case> will be pronounced C<when>. In addition, the C<when> statement
742 will use a colon between its case value and its block (removing the
743 need to parenthesize variables.
745 This future syntax is also available via the Switch.pm module, by
746 importing it with the argument C<"Perl6">. For example:
751 when 1 : { handle_num_1(); }
752 when $str1 : { handle_str_1(); }
753 when [0..9] : { handle_num_any(); last }
754 when /\d/ : { handle_dig_any(); }
755 when /.*/ : { handle_str_any(); }
758 Note that you can mix and match both syntaxes by importing the module
761 use Switch 'Perl5', 'Perl6';
764 =head2 Higher-order Operations
766 One situation in which C<switch> and C<case> do not provide a good
767 substitute for a cascaded C<if>, is where a switch value needs to
768 be tested against a series of conditions. For example:
773 case sub { $_[0] < 10 } { return 'milk' }
774 case sub { $_[0] < 20 } { return 'coke' }
775 case sub { $_[0] < 30 } { return 'beer' }
776 case sub { $_[0] < 40 } { return 'wine' }
777 case sub { $_[0] < 50 } { return 'malt' }
778 case sub { $_[0] < 60 } { return 'Moet' }
779 else { return 'milk' }
783 The need to specify each condition as a subroutine block is tiresome. To
784 overcome this, when importing Switch.pm, a special "placeholder"
785 subroutine named C<__> [sic] may also be imported. This subroutine
786 converts (almost) any expression in which it appears to a reference to a
787 higher-order function. That is, the expression:
795 sub { $_[0] < 2 + $_[1] }
797 With C<__>, the previous ugly case statements can be rewritten:
799 case __ < 10 { return 'milk' }
800 case __ < 20 { return 'coke' }
801 case __ < 30 { return 'beer' }
802 case __ < 40 { return 'wine' }
803 case __ < 50 { return 'malt' }
804 case __ < 60 { return 'Moet' }
805 else { return 'milk' }
807 The C<__> subroutine makes extensive use of operator overloading to
808 perform its magic. All operations involving __ are overloaded to
809 produce an anonymous subroutine that implements a lazy version
810 of the original operation.
812 The only problem is that operator overloading does not allow the
813 boolean operators C<&&> and C<||> to be overloaded. So a case statement
816 case 0 <= __ && __ < 10 { return 'digit' }
818 doesn't act as expected, because when it is
819 executed, it constructs two higher order subroutines
820 and then treats the two resulting references as arguments to C<&&>:
822 sub { 0 <= $_[0] } && sub { $_[0] < 10 }
824 This boolean expression is inevitably true, since both references are
825 non-false. Fortunately, the overloaded C<'bool'> operator catches this
826 situation and flags it as a error.
830 The module is implemented using Filter::Util::Call and Text::Balanced
831 and requires both these modules to be installed.
835 Damian Conway (damian@conway.org)
839 There are undoubtedly serious bugs lurking somewhere in code this funky :-)
840 Bug reports and other feedback are most welcome.
844 Due to the heuristic nature of Switch.pm's source parsing, the presence
845 of regexes specified with raw C<?...?> delimiters may cause mysterious
846 errors. The workaround is to use C<m?...?> instead.
850 Copyright (c) 1997-2001, Damian Conway. All Rights Reserved.
851 This module is free software. It may be used, redistributed
852 and/or modified under the same terms as Perl itself.