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];
80 my ($source, $line) = @_;
81 return $source unless $Perl5 && $source =~ /case|switch/
82 || $Perl6 && $source =~ /when|given/;
85 component: while (pos $source < length $source)
87 if ($source =~ m/(\G\s*use\s+Switch\b)/gc)
89 $text .= q{use Switch 'noimport'};
92 my @pos = Text::Balanced::_match_quotelike(\$source,qr/\s*/,1,1);
95 $text .= " " . substr($source,$pos[2],$pos[18]-$pos[2]);
98 @pos = Text::Balanced::_match_variable(\$source,qr/\s*/);
101 $text .= " " . substr($source,$pos[0],$pos[4]-$pos[0]);
105 if ($Perl5 && $source =~ m/\G(\n*)(\s*)(switch)\b(?=\s*[(])/gc
106 || $Perl6 && $source =~ m/\G(\n*)(\s*)(given)\b(?=\s*[(])/gc)
109 $text .= $1.$2.'S_W_I_T_C_H: while (1) ';
110 @pos = Text::Balanced::_match_codeblock(\$source,qr/\s*/,qr/\(/,qr/\)/,qr/[[{(<]/,qr/[]})>]/,undef)
112 die "Bad $keyword statement (problem in the parentheses?) near $Switch::file line ", line(substr($source,0,pos $source),$line), "\n";
114 my $arg = filter_blocks(substr($source,$pos[0],$pos[4]-$pos[0]),line(substr($source,0,$pos[0]),$line));
115 $arg =~ s {^\s*[(]\s*%} { ( \\\%} ||
116 $arg =~ s {^\s*[(]\s*m\b} { ( qr} ||
117 $arg =~ s {^\s*[(]\s*/} { ( qr/} ||
118 $arg =~ s {^\s*[(]\s*qw} { ( \\qw};
119 @pos = Text::Balanced::_match_codeblock(\$source,qr/\s*/,qr/\{/,qr/\}/,qr/\{/,qr/\}/,undef)
121 die "Bad $keyword statement (problem in the code block?) near $Switch::file line ", line(substr($source,0, pos $source), $line), "\n";
123 my $code = filter_blocks(substr($source,$pos[0],$pos[4]-$pos[0]),line(substr($source,0,$pos[0]),$line));
124 $code =~ s/{/{ local \$::_S_W_I_T_C_H; Switch::switch $arg;/;
125 $text .= $code . 'continue {last}';
128 elsif ($Perl5 && $source =~ m/\G(\s*)(case\b)(?!\s*=>)/gc
129 || $Perl6 && $source =~ m/\G(\s*)(when\b)(?!\s*=>)/gc)
132 $text .= $1."if (Switch::case";
133 if (@pos = Text::Balanced::_match_codeblock(\$source,qr/\s*/,qr/\{/,qr/\}/,qr/\{/,qr/\}/,undef)) {
134 my $code = substr($source,$pos[0],$pos[4]-$pos[0]);
135 $text .= " sub" if is_block $code;
136 $text .= " " . filter_blocks($code,line(substr($source,0,$pos[0]),$line)) . ")";
138 elsif (@pos = Text::Balanced::_match_codeblock(\$source,qr/\s*/,qr/[[(]/,qr/[])]/,qr/[[({]/,qr/[])}]/,undef)) {
139 my $code = filter_blocks(substr($source,$pos[0],$pos[4]-$pos[0]),line(substr($source,0,$pos[0]),$line));
140 $code =~ s {^\s*[(]\s*%} { ( \\\%} ||
141 $code =~ s {^\s*[(]\s*m\b} { ( qr} ||
142 $code =~ s {^\s*[(]\s*/} { ( qr/} ||
143 $code =~ s {^\s*[(]\s*qw} { ( \\qw};
146 elsif ($Perl6 && do{@pos = Text::Balanced::_match_variable(\$source,qr/\s*/)}) {
147 my $code = filter_blocks(substr($source,$pos[0],$pos[4]-$pos[0]),line(substr($source,0,$pos[0]),$line));
148 $code =~ s {^\s*%} { \%} ||
149 $code =~ s {^\s*@} { \@};
152 elsif ( @pos = Text::Balanced::_match_quotelike(\$source,qr/\s*/,1,1)) {
153 my $code = substr($source,$pos[2],$pos[18]-$pos[2]);
154 $code = filter_blocks($code,line(substr($source,0,$pos[2]),$line));
155 $code =~ s {^\s*m} { qr} ||
156 $code =~ s {^\s*/} { qr/} ||
157 $code =~ s {^\s*qw} { \\qw};
160 elsif ($Perl5 && $source =~ m/\G\s*(([^\$\@{])[^\$\@{]*)(?=\s*{)/gc
161 || $Perl6 && $source =~ m/\G\s*([^:;]*)()/gc) {
162 my $code = filter_blocks($1,line(substr($source,0,pos $source),$line));
163 $text .= ' \\' if $2 eq '%';
167 die "Bad $keyword statement (invalid $keyword value?) near $Switch::file line ", line(substr($source,0,pos $source), $line), "\n";
170 die "Missing colon or semi-colon after 'when' value near $Switch::file line ", line(substr($source,0,pos $source), $line), "\n"
171 unless !$Perl6 || $source =~ m/\G(\s*)(:|(?=;))/gc;
173 do{@pos = Text::Balanced::_match_codeblock(\$source,qr/\s*/,qr/\{/,qr/\}/,qr/\{/,qr/\}/,undef)}
175 if ($source =~ m/\G\s*(?=([};]|\Z))/gc) {
179 die "Bad $keyword statement (problem in the code block?) near $Switch::file line ", line(substr($source,0,pos $source),$line), "\n";
181 my $code = filter_blocks(substr($source,$pos[0],$pos[4]-$pos[0]),line(substr($source,0,$pos[0]),$line));
182 $code =~ s/}(?=\s*\Z)/;last S_W_I_T_C_H }/
184 $text .= "{ while (1) $code continue { goto C_A_S_E_$casecounter } last S_W_I_T_C_H; C_A_S_E_$casecounter: }";
189 $source =~ m/\G(\s*(\w+|#.*\n|\W))/gc;
201 for my $nextx ( @$x )
203 my $numx = ref($nextx) || defined $nextx && (~$nextx&$nextx) eq 0;
204 for my $j ( 0..$#$y )
206 my $nexty = $y->[$j];
207 push @numy, ref($nexty) || defined $nexty && (~$nexty&$nexty) eq 0
209 return 1 if $numx && $numy[$j] && $nextx==$nexty
219 my $ref = @_==1 && ref($_[0]) eq 'HASH' ? $_[0] : { @_ };
225 my $ref = @_==1 && ref($_[0]) eq 'HASH' ? $_[0] : { @_ };
226 [ grep { defined $ref->{$_} } keys %$ref ]
231 my ($s_val) = @_ ? $_[0] : $_;
232 my $s_ref = ref $s_val;
234 if ($s_ref eq 'CODE')
237 sub { my $c_val = $_[0];
238 return $s_val == $c_val if ref $c_val eq 'CODE';
239 return $s_val->(@$c_val) if ref $c_val eq 'ARRAY';
240 return $s_val->($c_val);
243 elsif ($s_ref eq "" && defined $s_val && (~$s_val&$s_val) eq 0) # NUMERIC SCALAR
246 sub { my $c_val = $_[0];
247 my $c_ref = ref $c_val;
248 return $s_val == $c_val if $c_ref eq ""
250 && (~$c_val&$c_val) eq 0;
251 return $s_val eq $c_val if $c_ref eq "";
252 return in([$s_val],$c_val) if $c_ref eq 'ARRAY';
253 return $c_val->($s_val) if $c_ref eq 'CODE';
254 return $c_val->call($s_val) if $c_ref eq 'Switch';
255 return scalar $s_val=~/$c_val/
256 if $c_ref eq 'Regexp';
257 return scalar $c_val->{$s_val}
262 elsif ($s_ref eq "") # STRING SCALAR
265 sub { my $c_val = $_[0];
266 my $c_ref = ref $c_val;
267 return $s_val eq $c_val if $c_ref eq "";
268 return in([$s_val],$c_val) if $c_ref eq 'ARRAY';
269 return $c_val->($s_val) if $c_ref eq 'CODE';
270 return $c_val->call($s_val) if $c_ref eq 'Switch';
271 return scalar $s_val=~/$c_val/
272 if $c_ref eq 'Regexp';
273 return scalar $c_val->{$s_val}
278 elsif ($s_ref eq 'ARRAY')
281 sub { my $c_val = $_[0];
282 my $c_ref = ref $c_val;
283 return in($s_val,[$c_val]) if $c_ref eq "";
284 return in($s_val,$c_val) if $c_ref eq 'ARRAY';
285 return $c_val->(@$s_val) if $c_ref eq 'CODE';
286 return $c_val->call(@$s_val)
287 if $c_ref eq 'Switch';
288 return scalar grep {$_=~/$c_val/} @$s_val
289 if $c_ref eq 'Regexp';
290 return scalar grep {$c_val->{$_}} @$s_val
295 elsif ($s_ref eq 'Regexp')
298 sub { my $c_val = $_[0];
299 my $c_ref = ref $c_val;
300 return $c_val=~/s_val/ if $c_ref eq "";
301 return scalar grep {$_=~/s_val/} @$c_val
302 if $c_ref eq 'ARRAY';
303 return $c_val->($s_val) if $c_ref eq 'CODE';
304 return $c_val->call($s_val) if $c_ref eq 'Switch';
305 return $s_val eq $c_val if $c_ref eq 'Regexp';
306 return grep {$_=~/$s_val/ && $c_val->{$_}} keys %$c_val
311 elsif ($s_ref eq 'HASH')
314 sub { my $c_val = $_[0];
315 my $c_ref = ref $c_val;
316 return $s_val->{$c_val} if $c_ref eq "";
317 return scalar grep {$s_val->{$_}} @$c_val
318 if $c_ref eq 'ARRAY';
319 return $c_val->($s_val) if $c_ref eq 'CODE';
320 return $c_val->call($s_val) if $c_ref eq 'Switch';
321 return grep {$_=~/$c_val/ && $s_val->{"$_"}} keys %$s_val
322 if $c_ref eq 'Regexp';
323 return $s_val==$c_val if $c_ref eq 'HASH';
327 elsif ($s_ref eq 'Switch')
330 sub { my $c_val = $_[0];
331 return $s_val == $c_val if ref $c_val eq 'Switch';
332 return $s_val->call(@$c_val)
333 if ref $c_val eq 'ARRAY';
334 return $s_val->call($c_val);
339 croak "Cannot switch on $s_ref";
344 sub case($) { $::_S_W_I_T_C_H->(@_); }
348 my $placeholder = bless { arity=>1, impl=>sub{$_[1+$_[0]]} };
350 sub __() { $placeholder }
355 bless { arity=>0, impl=>sub{$_[$index]} };
365 my ($self,@args) = @_;
366 return $self->{impl}->(0,@args);
374 my ($left, $right, $reversed) = @_;
375 ($right,$left) = @_ if $reversed;
377 my $rop = ref $right eq 'Switch'
379 : bless { arity=>0, impl=>sub{$right} };
381 my $lop = ref $left eq 'Switch'
383 : bless { arity=>0, impl=>sub{$left} };
385 my $arity = $lop->{arity} + $rop->{arity};
389 impl => sub { my $start = shift;
390 return $op->($lop->{impl}->($start,@_),
391 $rop->{impl}->($start+$lop->{arity},@_));
404 my $lop = ref $left eq 'Switch'
406 : bless { arity=>0, impl=>sub{$left} };
408 my $arity = $lop->{arity};
412 impl => sub { $op->($lop->{impl}->(@_)) }
419 "+" => meta_bop {$_[0] + $_[1]},
420 "-" => meta_bop {$_[0] - $_[1]},
421 "*" => meta_bop {$_[0] * $_[1]},
422 "/" => meta_bop {$_[0] / $_[1]},
423 "%" => meta_bop {$_[0] % $_[1]},
424 "**" => meta_bop {$_[0] ** $_[1]},
425 "<<" => meta_bop {$_[0] << $_[1]},
426 ">>" => meta_bop {$_[0] >> $_[1]},
427 "x" => meta_bop {$_[0] x $_[1]},
428 "." => meta_bop {$_[0] . $_[1]},
429 "<" => meta_bop {$_[0] < $_[1]},
430 "<=" => meta_bop {$_[0] <= $_[1]},
431 ">" => meta_bop {$_[0] > $_[1]},
432 ">=" => meta_bop {$_[0] >= $_[1]},
433 "==" => meta_bop {$_[0] == $_[1]},
434 "!=" => meta_bop {$_[0] != $_[1]},
435 "<=>" => meta_bop {$_[0] <=> $_[1]},
436 "lt" => meta_bop {$_[0] lt $_[1]},
437 "le" => meta_bop {$_[0] le $_[1]},
438 "gt" => meta_bop {$_[0] gt $_[1]},
439 "ge" => meta_bop {$_[0] ge $_[1]},
440 "eq" => meta_bop {$_[0] eq $_[1]},
441 "ne" => meta_bop {$_[0] ne $_[1]},
442 "cmp" => meta_bop {$_[0] cmp $_[1]},
443 "\&" => meta_bop {$_[0] & $_[1]},
444 "^" => meta_bop {$_[0] ^ $_[1]},
445 "|" => meta_bop {$_[0] | $_[1]},
446 "atan2" => meta_bop {atan2 $_[0], $_[1]},
448 "neg" => meta_uop {-$_[0]},
449 "!" => meta_uop {!$_[0]},
450 "~" => meta_uop {~$_[0]},
451 "cos" => meta_uop {cos $_[0]},
452 "sin" => meta_uop {sin $_[0]},
453 "exp" => meta_uop {exp $_[0]},
454 "abs" => meta_uop {abs $_[0]},
455 "log" => meta_uop {log $_[0]},
456 "sqrt" => meta_uop {sqrt $_[0]},
457 "bool" => sub { croak "Can't use && or || in expression containing __" },
459 # "&()" => sub { $_[0]->{impl} },
461 # "||" => meta_bop {$_[0] || $_[1]},
462 # "&&" => meta_bop {$_[0] && $_[1]},
472 Switch - A switch statement for Perl
476 This document describes version 2.04 of Switch,
477 released July 30, 2001.
485 case 1 { print "number 1" }
486 case "a" { print "string a" }
487 case [1..10,42] { print "number in list" }
488 case (@array) { print "number in list" }
489 case /\w+/ { print "pattern" }
490 case qr/\w+/ { print "pattern" }
491 case (%hash) { print "entry in hash" }
492 case (\%hash) { print "entry in hash" }
493 case (\&sub) { print "arg to subroutine" }
494 else { print "previous case not true" }
499 [Skip ahead to L<"DESCRIPTION"> if you don't care about the whys
500 and wherefores of this control structure]
502 In seeking to devise a "Swiss Army" case mechanism suitable for Perl,
503 it is useful to generalize this notion of distributed conditional
504 testing as far as possible. Specifically, the concept of "matching"
505 between the switch value and the various case values need not be
506 restricted to numeric (or string or referential) equality, as it is in other
507 languages. Indeed, as Table 1 illustrates, Perl
508 offers at least eighteen different ways in which two values could
511 Table 1: Matching a switch value ($s) with a case value ($c)
513 Switch Case Type of Match Implied Matching Code
515 ====== ===== ===================== =============
517 number same numeric or referential match if $s == $c;
520 object method result of method call match if $s->$c();
521 ref name match if defined $s->$c();
524 other other string equality match if $s eq $c;
528 string regexp pattern match match if $s =~ /$c/;
530 array scalar array entry existence match if 0<=$c && $c<@$s;
531 ref array entry definition match if defined $s->[$c];
532 array entry truth match if $s->[$c];
534 array array array intersection match if intersects(@$s, @$c);
535 ref ref (apply this table to
536 all pairs of elements
540 array regexp array grep match if grep /$c/, @$s;
543 hash scalar hash entry existence match if exists $s->{$c};
544 ref hash entry definition match if defined $s->{$c};
545 hash entry truth match if $s->{$c};
547 hash regexp hash grep match if grep /$c/, keys %$s;
550 sub scalar return value defn match if defined $s->($c);
551 ref return value truth match if $s->($c);
553 sub array return value defn match if defined $s->(@$c);
554 ref ref return value truth match if $s->(@$c);
557 In reality, Table 1 covers 31 alternatives, because only the equality and
558 intersection tests are commutative; in all other cases, the roles of
559 the C<$s> and C<$c> variables could be reversed to produce a
560 different test. For example, instead of testing a single hash for
561 the existence of a series of keys (C<match if exists $s-E<gt>{$c}>),
562 one could test for the existence of a single key in a series of hashes
563 (C<match if exists $c-E<gt>{$s}>).
565 As L<perltodo> observes, a Perl case mechanism must support all these
571 The Switch.pm module implements a generalized case mechanism that covers
572 the numerous possible combinations of switch and case values described above.
574 The module augments the standard Perl syntax with two new control
575 statements: C<switch> and C<case>. The C<switch> statement takes a
576 single scalar argument of any type, specified in parentheses.
577 C<switch> stores this value as the
578 current switch value in a (localized) control variable.
579 The value is followed by a block which may contain one or more
580 Perl statements (including the C<case> statement described below).
581 The block is unconditionally executed once the switch value has
584 A C<case> statement takes a single scalar argument (in mandatory
585 parentheses if it's a variable; otherwise the parens are optional) and
586 selects the appropriate type of matching between that argument and the
587 current switch value. The type of matching used is determined by the
588 respective types of the switch value and the C<case> argument, as
589 specified in Table 1. If the match is successful, the mandatory
590 block associated with the C<case> statement is executed.
592 In most other respects, the C<case> statement is semantically identical
593 to an C<if> statement. For example, it can be followed by an C<else>
594 clause, and can be used as a postfix statement qualifier.
596 However, when a C<case> block has been executed control is automatically
597 transferred to the statement after the immediately enclosing C<switch>
598 block, rather than to the next statement within the block. In other
599 words, the success of any C<case> statement prevents other cases in the
600 same scope from executing. But see L<"Allowing fall-through"> below.
602 Together these two new statements provide a fully generalized case
609 %special = ( woohoo => 1, d'oh => 1 );
614 case (%special) { print "homer\n"; } # if $special{$_}
615 case /a-z/i { print "alpha\n"; } # if $_ =~ /a-z/i
616 case [1..9] { print "small num\n"; } # if $_ in [1..9]
618 case { $_[0] >= 10 } { # if $_ >= 10
620 switch (sub{ $_[0] < $age } ) {
622 case 20 { print "teens\n"; } # if 20 < $age
623 case 30 { print "twenties\n"; } # if 30 < $age
624 else { print "history\n"; }
628 print "must be punctuation\n" case /\W/; # if $_ ~= /\W/
631 Note that C<switch>es can be nested within C<case> (or any other) blocks,
632 and a series of C<case> statements can try different types of matches
633 -- hash membership, pattern match, array intersection, simple equality,
634 etc. -- against the same switch value.
636 The use of intersection tests against an array reference is particularly
637 useful for aggregating integral cases:
641 switch ($_[0]) { case 0 { return 'zero' }
642 case [2,4,6,8] { return 'even' }
643 case [1,3,4,7,9] { return 'odd' }
644 case /[A-F]/i { return 'hex' }
649 =head2 Allowing fall-through
651 Fall-though (trying another case after one has already succeeded)
652 is usually a Bad Idea in a switch statement. However, this
653 is Perl, not a police state, so there I<is> a way to do it, if you must.
655 If a C<case> block executes an untargetted C<next>, control is
656 immediately transferred to the statement I<after> the C<case> statement
657 (i.e. usually another case), rather than out of the surrounding
663 case 1 { handle_num_1(); next } # and try next case...
664 case "1" { handle_str_1(); next } # and try next case...
665 case [0..9] { handle_num_any(); } # and we're done
666 case /\d/ { handle_dig_any(); next } # and try next case...
667 case /.*/ { handle_str_any(); next } # and try next case...
670 If $val held the number C<1>, the above C<switch> block would call the
671 first three C<handle_...> subroutines, jumping to the next case test
672 each time it encountered a C<next>. After the thrid C<case> block
673 was executed, control would jump to the end of the enclosing
676 On the other hand, if $val held C<10>, then only the last two C<handle_...>
677 subroutines would be called.
679 Note that this mechanism allows the notion of I<conditional fall-through>.
683 case [0..9] { handle_num_any(); next if $val < 7; }
684 case /\d/ { handle_dig_any(); }
687 If an untargetted C<last> statement is executed in a case block, this
688 immediately transfers control out of the enclosing C<switch> block
689 (in other words, there is an implicit C<last> at the end of each
690 normal C<case> block). Thus the previous example could also have been
694 case [0..9] { handle_num_any(); last if $val >= 7; next; }
695 case /\d/ { handle_dig_any(); }
699 =head2 Automating fall-through
701 In situations where case fall-through should be the norm, rather than an
702 exception, an endless succession of terminal C<next>s is tedious and ugly.
703 Hence, it is possible to reverse the default behaviour by specifying
704 the string "fallthrough" when importing the module. For example, the
705 following code is equivalent to the first example in L<"Allowing fall-through">:
707 use Switch 'fallthrough';
710 case 1 { handle_num_1(); }
711 case "1" { handle_str_1(); }
712 case [0..9] { handle_num_any(); last }
713 case /\d/ { handle_dig_any(); }
714 case /.*/ { handle_str_any(); }
717 Note the explicit use of a C<last> to preserve the non-fall-through
718 behaviour of the third case.
722 =head2 Alternative syntax
724 Perl 6 will provide a built-in switch statement with essentially the
725 same semantics as those offered by Switch.pm, but with a different
726 pair of keywords. In Perl 6 C<switch> with be spelled C<given>, and
727 C<case> will be pronounced C<when>. In addition, the C<when> statement
728 will use a colon between its case value and its block (removing the
729 need to parenthesize variables.
731 This future syntax is also available via the Switch.pm module, by
732 importing it with the argument C<"Perl6">. For example:
737 when 1 : { handle_num_1(); }
738 when $str1 : { handle_str_1(); }
739 when [0..9] : { handle_num_any(); last }
740 when /\d/ : { handle_dig_any(); }
741 when /.*/ : { handle_str_any(); }
744 Note that you can mix and match both syntaxes by importing the module
747 use Switch 'Perl5', 'Perl6';
750 =head2 Higher-order Operations
752 One situation in which C<switch> and C<case> do not provide a good
753 substitute for a cascaded C<if>, is where a switch value needs to
754 be tested against a series of conditions. For example:
759 case sub { $_[0] < 10 } { return 'milk' }
760 case sub { $_[0] < 20 } { return 'coke' }
761 case sub { $_[0] < 30 } { return 'beer' }
762 case sub { $_[0] < 40 } { return 'wine' }
763 case sub { $_[0] < 50 } { return 'malt' }
764 case sub { $_[0] < 60 } { return 'Moet' }
765 else { return 'milk' }
769 The need to specify each condition as a subroutine block is tiresome. To
770 overcome this, when importing Switch.pm, a special "placeholder"
771 subroutine named C<__> [sic] may also be imported. This subroutine
772 converts (almost) any expression in which it appears to a reference to a
773 higher-order function. That is, the expression:
781 sub { $_[0] < 2 + $_[1] }
783 With C<__>, the previous ugly case statements can be rewritten:
785 case __ < 10 { return 'milk' }
786 case __ < 20 { return 'coke' }
787 case __ < 30 { return 'beer' }
788 case __ < 40 { return 'wine' }
789 case __ < 50 { return 'malt' }
790 case __ < 60 { return 'Moet' }
791 else { return 'milk' }
793 The C<__> subroutine makes extensive use of operator overloading to
794 perform its magic. All operations involving __ are overloaded to
795 produce an anonymous subroutine that implements a lazy version
796 of the original operation.
798 The only problem is that operator overloading does not allow the
799 boolean operators C<&&> and C<||> to be overloaded. So a case statement
802 case 0 <= __ && __ < 10 { return 'digit' }
804 doesn't act as expected, because when it is
805 executed, it constructs two higher order subroutines
806 and then treats the two resulting references as arguments to C<&&>:
808 sub { 0 <= $_[0] } && sub { $_[0] < 10 }
810 This boolean expression is inevitably true, since both references are
811 non-false. Fortunately, the overloaded C<'bool'> operator catches this
812 situation and flags it as a error.
816 The module is implemented using Filter::Util::Call and Text::Balanced
817 and requires both these modules to be installed.
821 Damian Conway (damian@conway.org)
825 There are undoubtedly serious bugs lurking somewhere in code this funky :-)
826 Bug reports and other feedback are most welcome.
830 Copyright (c) 1997-2000, Damian Conway. All Rights Reserved.
831 This module is free software; you can redistribute it and/or
832 modify it under the same terms as Perl itself.