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 statement not in switch block" };
25 $fallthrough = grep /\bfallthrough\b/, @_;
26 $offset = (caller)[2]+1;
27 filter_add({}) unless @_>1 && $_[1] ne '__';
30 for ( qw( on_defined on_exists ) )
32 *{"${pkg}::$_"} = \&$_;
34 *{"${pkg}::__"} = \&__ if grep /__/, @_;
46 local $Switch::file = (caller)[1];
49 $status = filter_read(10_000);
50 return $status if $status<0;
51 $_ = filter_blocks($_,$offset);
52 $_ = "# line $offset\n" . $_ if $offset; undef $offset;
57 use Text::Balanced ':ALL';
61 my ($pretext,$offset) = @_;
62 ($pretext=~tr/\n/\n/)+$offset,
67 local $SIG{__WARN__}=sub{die$@};
69 my $ishash = defined eval 'my $hr='.$_[0];
77 my ($source, $line) = @_;
78 return $source unless $source =~ /case|switch/;
81 component: while (pos $source < length $source)
83 if ($source =~ m/(\G\s*use\s+switch\b)/gc)
85 $text .= q{use Switch 'noimport'};
88 my @pos = Text::Balanced::_match_quotelike(\$source,qr/\s*/,1,1);
91 $text .= substr($source,$pos[2],$pos[18]-$pos[2]);
94 @pos = Text::Balanced::_match_variable(\$source,qr/\s*/);
97 $text .= substr($source,$pos[0],$pos[4]-$pos[0]);
101 if ($source =~ m/\G(\n*)(\s*)switch\b(?=\s*[(])/gc)
103 $text .= $1.$2.'S_W_I_T_C_H: while (1) ';
104 @pos = Text::Balanced::_match_codeblock(\$source,qr/\s*/,qr/\(/,qr/\)/,qr/\{/,qr/\}/,undef)
106 die "Bad switch statement (problem in the parentheses?) near $Switch::file line ", line(substr($source,0,pos $source),$line), "\n";
108 my $arg = filter_blocks(substr($source,$pos[0],$pos[4]-$pos[0]),line(substr($source,0,$pos[0]),$line));
109 $arg =~ s {^\s*[(]\s*%} { ( \\\%} ||
110 $arg =~ s {^\s*[(]\s*m\b} { ( qr} ||
111 $arg =~ s {^\s*[(]\s*/} { ( qr/} ||
112 $arg =~ s {^\s*[(]\s*qw} { ( \\qw};
113 @pos = Text::Balanced::_match_codeblock(\$source,qr/\s*/,qr/\{/,qr/\}/,qr/\{/,qr/\}/,undef)
115 die "Bad switch statement (problem in the code block?) near $Switch::file line ", line(substr($source,0, pos $source), $line), "\n";
117 my $code = filter_blocks(substr($source,$pos[0],$pos[4]-$pos[0]),line(substr($source,0,$pos[0]),$line));
118 $code =~ s/{/{ local \$::_S_W_I_T_C_H; Switch::switch $arg;/;
119 $text .= $code . 'continue {last}';
122 elsif ($source =~ m/\G(\s*)(case\b)(?!\s*=>)/gc)
124 $text .= $1."if (Switch::case";
125 if (@pos = Text::Balanced::_match_codeblock(\$source,qr/\s*/,qr/\{/,qr/\}/,qr/\{/,qr/\}/,undef)) {
126 my $code = substr($source,$pos[0],$pos[4]-$pos[0]);
127 $text .= " sub" if is_block $code;
128 $text .= " " . filter_blocks($code,line(substr($source,0,$pos[0]),$line)) . ")";
130 elsif (@pos = Text::Balanced::_match_codeblock(\$source,qr/\s*/,qr/[[(]/,qr/[])]/,qr/[[({]/,qr/[])}]/,undef)) {
131 my $code = filter_blocks(substr($source,$pos[0],$pos[4]-$pos[0]),line(substr($source,0,$pos[0]),$line));
132 $code =~ s {^\s*[(]\s*%} { ( \\\%} ||
133 $code =~ s {^\s*[(]\s*m\b} { ( qr} ||
134 $code =~ s {^\s*[(]\s*/} { ( qr/} ||
135 $code =~ s {^\s*[(]\s*qw} { ( \\qw};
138 elsif ( @pos = Text::Balanced::_match_quotelike(\$source,qr/\s*/,1,1)) {
139 my $code = substr($source,$pos[2],$pos[18]-$pos[2]);
140 $code = filter_blocks($code,line(substr($source,0,$pos[2]),$line));
141 $code =~ s {^\s*m} { qr} ||
142 $code =~ s {^\s*/} { qr/} ||
143 $code =~ s {^\s*qw} { \\qw};
146 elsif ($source =~ m/\G\s*(([^\$\@{])[^\$\@{]*)(?=\s*{)/gc) {
147 my $code = filter_blocks($1,line(substr($source,0,pos $source),$line));
148 $text .= ' \\' if $2 eq '%';
152 die "Bad case statement (invalid case value?) near $Switch::file line ", line(substr($source,0,pos $source), $line), "\n";
155 @pos = Text::Balanced::_match_codeblock(\$source,qr/\s*/,qr/\{/,qr/\}/,qr/\{/,qr/\}/,undef)
157 if ($source =~ m/\G\s*(?=([};]|\Z))/gc) {
161 die "Bad case statement (problem in the code block?) near $Switch::file line ", line(substr($source,0,pos $source),$line), "\n";
163 my $code = filter_blocks(substr($source,$pos[0],$pos[4]-$pos[0]),line(substr($source,0,$pos[0]),$line));
164 $code =~ s/}(?=\s*\Z)/;last S_W_I_T_C_H }/
166 $text .= "{ while (1) $code continue { goto C_A_S_E_$casecounter } last S_W_I_T_C_H; C_A_S_E_$casecounter: }";
171 $source =~ m/\G(\s*(\w+|#.*\n|\W))/gc;
183 for my $nextx ( @$x )
185 my $numx = ref($nextx) || (~$nextx&$nextx) eq 0;
186 for my $j ( 0..$#$y )
188 my $nexty = $y->[$j];
189 push @numy, ref($nexty) || (~$nexty&$nexty) eq 0
191 return 1 if $numx && $numy[$j] && $nextx==$nexty
201 my $ref = @_==1 && ref($_[0]) eq 'HASH' ? $_[0] : { @_ };
207 my $ref = @_==1 && ref($_[0]) eq 'HASH' ? $_[0] : { @_ };
208 [ grep { defined $ref->{$_} } keys %$ref ]
213 my ($s_val) = @_ ? $_[0] : $_;
214 my $s_ref = ref $s_val;
216 if ($s_ref eq 'CODE')
219 sub { my $c_val = $_[0];
220 return $s_val == $c_val if ref $c_val eq 'CODE';
221 return $s_val->(@$c_val) if ref $c_val eq 'ARRAY';
222 return $s_val->($c_val);
225 elsif ($s_ref eq "" && (~$s_val&$s_val) eq 0) # NUMERIC SCALAR
228 sub { my $c_val = $_[0];
229 my $c_ref = ref $c_val;
230 return $s_val == $c_val if $c_ref eq ""
231 && (~$c_val&$c_val) eq 0;
232 return $s_val eq $c_val if $c_ref eq "";
233 return in([$s_val],$c_val) if $c_ref eq 'ARRAY';
234 return $c_val->($s_val) if $c_ref eq 'CODE';
235 return $c_val->call($s_val) if $c_ref eq 'Switch';
236 return scalar $s_val=~/$c_val/
237 if $c_ref eq 'Regexp';
238 return scalar $c_val->{$s_val}
243 elsif ($s_ref eq "") # STRING SCALAR
246 sub { my $c_val = $_[0];
247 my $c_ref = ref $c_val;
248 return $s_val eq $c_val if $c_ref eq "";
249 return in([$s_val],$c_val) if $c_ref eq 'ARRAY';
250 return $c_val->($s_val) if $c_ref eq 'CODE';
251 return $c_val->call($s_val) if $c_ref eq 'Switch';
252 return scalar $s_val=~/$c_val/
253 if $c_ref eq 'Regexp';
254 return scalar $c_val->{$s_val}
259 elsif ($s_ref eq 'ARRAY')
262 sub { my $c_val = $_[0];
263 my $c_ref = ref $c_val;
264 return in($s_val,[$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)
268 if $c_ref eq 'Switch';
269 return scalar grep {$_=~/$c_val/} @$s_val
270 if $c_ref eq 'Regexp';
271 return scalar grep {$c_val->{$_}} @$s_val
276 elsif ($s_ref eq 'Regexp')
279 sub { my $c_val = $_[0];
280 my $c_ref = ref $c_val;
281 return $c_val=~/s_val/ if $c_ref eq "";
282 return scalar grep {$_=~/s_val/} @$c_val
283 if $c_ref eq 'ARRAY';
284 return $c_val->($s_val) if $c_ref eq 'CODE';
285 return $c_val->call($s_val) if $c_ref eq 'Switch';
286 return $s_val eq $c_val if $c_ref eq 'Regexp';
287 return grep {$_=~/$s_val/ && $c_val->{$_}} keys %$c_val
292 elsif ($s_ref eq 'HASH')
295 sub { my $c_val = $_[0];
296 my $c_ref = ref $c_val;
297 return $s_val->{$c_val} if $c_ref eq "";
298 return scalar grep {$s_val->{$_}} @$c_val
299 if $c_ref eq 'ARRAY';
300 return $c_val->($s_val) if $c_ref eq 'CODE';
301 return $c_val->call($s_val) if $c_ref eq 'Switch';
302 return grep {$_=~/$c_val/ && $s_val->{"$_"}} keys %$s_val
303 if $c_ref eq 'Regexp';
304 return $s_val==$c_val if $c_ref eq 'HASH';
308 elsif ($s_ref eq 'Switch')
311 sub { my $c_val = $_[0];
312 return $s_val == $c_val if ref $c_val eq 'Switch';
313 return $s_val->call(@$c_val)
314 if ref $c_val eq 'ARRAY';
315 return $s_val->call($c_val);
320 croak "Cannot switch on $s_ref";
325 sub case($) { $::_S_W_I_T_C_H->(@_); }
329 my $placeholder = bless { arity=>1, impl=>sub{$_[1+$_[0]]} };
331 sub __() { $placeholder }
336 bless { arity=>0, impl=>sub{$_[$index]} };
346 my ($self,@args) = @_;
347 return $self->{impl}->(0,@args);
355 my ($left, $right, $reversed) = @_;
356 ($right,$left) = @_ if $reversed;
358 my $rop = ref $right eq 'Switch'
360 : bless { arity=>0, impl=>sub{$right} };
362 my $lop = ref $left eq 'Switch'
364 : bless { arity=>0, impl=>sub{$left} };
366 my $arity = $lop->{arity} + $rop->{arity};
370 impl => sub { my $start = shift;
371 return $op->($lop->{impl}->($start,@_),
372 $rop->{impl}->($start+$lop->{arity},@_));
385 my $lop = ref $left eq 'Switch'
387 : bless { arity=>0, impl=>sub{$left} };
389 my $arity = $lop->{arity};
393 impl => sub { $op->($lop->{impl}->(@_)) }
400 "+" => meta_bop {$_[0] + $_[1]},
401 "-" => meta_bop {$_[0] - $_[1]},
402 "*" => meta_bop {$_[0] * $_[1]},
403 "/" => meta_bop {$_[0] / $_[1]},
404 "%" => meta_bop {$_[0] % $_[1]},
405 "**" => meta_bop {$_[0] ** $_[1]},
406 "<<" => meta_bop {$_[0] << $_[1]},
407 ">>" => meta_bop {$_[0] >> $_[1]},
408 "x" => meta_bop {$_[0] x $_[1]},
409 "." => meta_bop {$_[0] . $_[1]},
410 "<" => meta_bop {$_[0] < $_[1]},
411 "<=" => meta_bop {$_[0] <= $_[1]},
412 ">" => meta_bop {$_[0] > $_[1]},
413 ">=" => meta_bop {$_[0] >= $_[1]},
414 "==" => meta_bop {$_[0] == $_[1]},
415 "!=" => meta_bop {$_[0] != $_[1]},
416 "<=>" => meta_bop {$_[0] <=> $_[1]},
417 "lt" => meta_bop {$_[0] lt $_[1]},
418 "le" => meta_bop {$_[0] le $_[1]},
419 "gt" => meta_bop {$_[0] gt $_[1]},
420 "ge" => meta_bop {$_[0] ge $_[1]},
421 "eq" => meta_bop {$_[0] eq $_[1]},
422 "ne" => meta_bop {$_[0] ne $_[1]},
423 "cmp" => meta_bop {$_[0] cmp $_[1]},
424 "\&" => meta_bop {$_[0] & $_[1]},
425 "^" => meta_bop {$_[0] ^ $_[1]},
426 "|" => meta_bop {$_[0] | $_[1]},
427 "atan2" => meta_bop {atan2 $_[0], $_[1]},
429 "neg" => meta_uop {-$_[0]},
430 "!" => meta_uop {!$_[0]},
431 "~" => meta_uop {~$_[0]},
432 "cos" => meta_uop {cos $_[0]},
433 "sin" => meta_uop {sin $_[0]},
434 "exp" => meta_uop {exp $_[0]},
435 "abs" => meta_uop {abs $_[0]},
436 "log" => meta_uop {log $_[0]},
437 "sqrt" => meta_uop {sqrt $_[0]},
438 "bool" => sub { croak "Can't use && or || in expression containing __" },
440 # "&()" => sub { $_[0]->{impl} },
442 # "||" => meta_bop {$_[0] || $_[1]},
443 # "&&" => meta_bop {$_[0] && $_[1]},
453 Switch - A switch statement for Perl
457 This document describes version 2.01 of Switch,
458 released January 9, 2001.
466 case 1 { print "number 1" }
467 case "a" { print "string a" }
468 case [1..10,42] { print "number in list" }
469 case (@array) { print "number in list" }
470 case /\w+/ { print "pattern" }
471 case qr/\w+/ { print "pattern" }
472 case (%hash) { print "entry in hash" }
473 case (\%hash) { print "entry in hash" }
474 case (\&sub) { print "arg to subroutine" }
475 else { print "previous case not true" }
480 [Skip ahead to L<"DESCRIPTION"> if you don't care about the whys
481 and wherefores of this control structure]
483 In seeking to devise a "Swiss Army" case mechanism suitable for Perl,
484 it is useful to generalize this notion of distributed conditional
485 testing as far as possible. Specifically, the concept of "matching"
486 between the switch value and the various case values need not be
487 restricted to numeric (or string or referential) equality, as it is in other
488 languages. Indeed, as Table 1 illustrates, Perl
489 offers at least eighteen different ways in which two values could
492 Table 1: Matching a switch value ($s) with a case value ($c)
494 Switch Case Type of Match Implied Matching Code
496 ====== ===== ===================== =============
498 number same numeric or referential match if $s == $c;
501 object method result of method call match if $s->$c();
502 ref name match if defined $s->$c();
505 other other string equality match if $s eq $c;
509 string regexp pattern match match if $s =~ /$c/;
511 array scalar array entry existence match if 0<=$c && $c<@$s;
512 ref array entry definition match if defined $s->[$c];
513 array entry truth match if $s->[$c];
515 array array array intersection match if intersects(@$s, @$c);
516 ref ref (apply this table to
517 all pairs of elements
521 array regexp array grep match if grep /$c/, @$s;
524 hash scalar hash entry existence match if exists $s->{$c};
525 ref hash entry definition match if defined $s->{$c};
526 hash entry truth match if $s->{$c};
528 hash regexp hash grep match if grep /$c/, keys %$s;
531 sub scalar return value defn match if defined $s->($c);
532 ref return value truth match if $s->($c);
534 sub array return value defn match if defined $s->(@$c);
535 ref ref return value truth match if $s->(@$c);
538 In reality, Table 1 covers 31 alternatives, because only the equality and
539 intersection tests are commutative; in all other cases, the roles of
540 the C<$s> and C<$c> variables could be reversed to produce a
541 different test. For example, instead of testing a single hash for
542 the existence of a series of keys (C<match if exists $s-E<gt>{$c}>),
543 one could test for the existence of a single key in a series of hashes
544 (C<match if exists $c-E<gt>{$s}>).
546 As L<perltodo> observes, a Perl case mechanism must support all these
552 The Switch.pm module implements a generalized case mechanism that covers
553 the numerous possible combinations of switch and case values described above.
555 The module augments the standard Perl syntax with two new control
556 statements: C<switch> and C<case>. The C<switch> statement takes a
557 single scalar argument of any type, specified in parentheses.
558 C<switch> stores this value as the
559 current switch value in a (localized) control variable.
560 The value is followed by a block which may contain one or more
561 Perl statements (including the C<case> statement described below).
562 The block is unconditionally executed once the switch value has
565 A C<case> statement takes a single scalar argument (in mandatory
566 parentheses if it's a variable; otherwise the parens are optional) and
567 selects the appropriate type of matching between that argument and the
568 current switch value. The type of matching used is determined by the
569 respective types of the switch value and the C<case> argument, as
570 specified in Table 1. If the match is successful, the mandatory
571 block associated with the C<case> statement is executed.
573 In most other respects, the C<case> statement is semantically identical
574 to an C<if> statement. For example, it can be followed by an C<else>
575 clause, and can be used as a postfix statement qualifier.
577 However, when a C<case> block has been executed control is automatically
578 transferred to the statement after the immediately enclosing C<switch>
579 block, rather than to the next statement within the block. In other
580 words, the success of any C<case> statement prevents other cases in the
581 same scope from executing. But see L<"Allowing fall-through"> below.
583 Together these two new statements provide a fully generalized case
590 %special = ( woohoo => 1, d'oh => 1 );
595 case %special { print "homer\n"; } # if $special{$_}
596 case /a-z/i { print "alpha\n"; } # if $_ =~ /a-z/i
597 case [1..9] { print "small num\n"; } # if $_ in [1..9]
599 case { $_[0] >= 10 } { # if $_ >= 10
601 switch (sub{ $_[0] < $age } ) {
603 case 20 { print "teens\n"; } # if 20 < $age
604 case 30 { print "twenties\n"; } # if 30 < $age
605 else { print "history\n"; }
609 print "must be punctuation\n" case /\W/; # if $_ ~= /\W/
612 Note that C<switch>es can be nested within C<case> (or any other) blocks,
613 and a series of C<case> statements can try different types of matches
614 -- hash membership, pattern match, array intersection, simple equality,
615 etc. -- against the same switch value.
617 The use of intersection tests against an array reference is particularly
618 useful for aggregating integral cases:
622 switch ($_[0]) { case 0 { return 'zero' }
623 case [2,4,6,8] { return 'even' }
624 case [1,3,4,7,9] { return 'odd' }
625 case /[A-F]/i { return 'hex' }
630 =head2 Allowing fall-through
632 Fall-though (trying another case after one has already succeeded)
633 is usually a Bad Idea in a switch statement. However, this
634 is Perl, not a police state, so there I<is> a way to do it, if you must.
636 If a C<case> block executes an untargetted C<next>, control is
637 immediately transferred to the statement I<after> the C<case> statement
638 (i.e. usually another case), rather than out of the surrounding
644 case 1 { handle_num_1(); next } # and try next case...
645 case "1" { handle_str_1(); next } # and try next case...
646 case [0..9] { handle_num_any(); } # and we're done
647 case /\d/ { handle_dig_any(); next } # and try next case...
648 case /.*/ { handle_str_any(); next } # and try next case...
651 If $val held the number C<1>, the above C<switch> block would call the
652 first three C<handle_...> subroutines, jumping to the next case test
653 each time it encountered a C<next>. After the thrid C<case> block
654 was executed, control would jump to the end of the enclosing
657 On the other hand, if $val held C<10>, then only the last two C<handle_...>
658 subroutines would be called.
660 Note that this mechanism allows the notion of I<conditional fall-through>.
664 case [0..9] { handle_num_any(); next if $val < 7; }
665 case /\d/ { handle_dig_any(); }
668 If an untargetted C<last> statement is executed in a case block, this
669 immediately transfers control out of the enclosing C<switch> block
670 (in other words, there is an implicit C<last> at the end of each
671 normal C<case> block). Thus the previous example could also have been
675 case [0..9] { handle_num_any(); last if $val >= 7; next; }
676 case /\d/ { handle_dig_any(); }
680 =head2 Automating fall-through
682 In situations where case fall-through should be the norm, rather than an
683 exception, an endless succession of terminal C<next>s is tedious and ugly.
684 Hence, it is possible to reverse the default behaviour by specifying
685 the string "fallthrough" when importing the module. For example, the
686 following code is equivalent to the first example in L<"Allowing fall-through">:
688 use Switch 'fallthrough';
691 case 1 { handle_num_1(); }
692 case "1" { handle_str_1(); }
693 case [0..9] { handle_num_any(); last }
694 case /\d/ { handle_dig_any(); }
695 case /.*/ { handle_str_any(); }
698 Note the explicit use of a C<last> to preserve the non-fall-through
699 behaviour of the third case.
703 =head2 Higher-order Operations
705 One situation in which C<switch> and C<case> do not provide a good
706 substitute for a cascaded C<if>, is where a switch value needs to
707 be tested against a series of conditions. For example:
712 case sub { $_[0] < 10 } { return 'milk' }
713 case sub { $_[0] < 20 } { return 'coke' }
714 case sub { $_[0] < 30 } { return 'beer' }
715 case sub { $_[0] < 40 } { return 'wine' }
716 case sub { $_[0] < 50 } { return 'malt' }
717 case sub { $_[0] < 60 } { return 'Moet' }
718 else { return 'milk' }
722 The need to specify each condition as a subroutine block is tiresome. To
723 overcome this, when importing Switch.pm, a special "placeholder"
724 subroutine named C<__> [sic] may also be imported. This subroutine
725 converts (almost) any expression in which it appears to a reference to a
726 higher-order function. That is, the expression:
734 sub { $_[0] < 2 + $_[1] }
736 With C<__>, the previous ugly case statements can be rewritten:
738 case __ < 10 { return 'milk' }
739 case __ < 20 { return 'coke' }
740 case __ < 30 { return 'beer' }
741 case __ < 40 { return 'wine' }
742 case __ < 50 { return 'malt' }
743 case __ < 60 { return 'Moet' }
744 else { return 'milk' }
746 The C<__> subroutine makes extensive use of operator overloading to
747 perform its magic. All operations involving __ are overloaded to
748 produce an anonymous subroutine that implements a lazy version
749 of the original operation.
751 The only problem is that operator overloading does not allow the
752 boolean operators C<&&> and C<||> to be overloaded. So a case statement
755 case 0 <= __ && __ < 10 { return 'digit' }
757 doesn't act as expected, because when it is
758 executed, it constructs two higher order subroutines
759 and then treats the two resulting references as arguments to C<&&>:
761 sub { 0 <= $_[0] } && sub { $_[0] < 10 }
763 This boolean expression is inevitably true, since both references are
764 non-false. Fortunately, the overloaded C<'bool'> operator catches this
765 situation and flags it as a error.
769 The module is implemented using Filter::Util::Call and Text::Balanced
770 and requires both these modules to be installed.
774 Damian Conway (damian@conway.org)
778 There are undoubtedly serious bugs lurking somewhere in code this funky :-)
779 Bug reports and other feedback are most welcome.
783 Copyright (c) 1997-2000, Damian Conway. All Rights Reserved.
784 This module is free software; you can redistribute it and/or
785 modify it under the same terms as Perl itself.