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] eq 'noimport';
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) || defined $nextx && (~$nextx&$nextx) eq 0;
186 for my $j ( 0..$#$y )
188 my $nexty = $y->[$j];
189 push @numy, ref($nexty) || defined $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 "" && defined $s_val && (~$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 ""
232 && (~$c_val&$c_val) eq 0;
233 return $s_val eq $c_val if $c_ref eq "";
234 return in([$s_val],$c_val) if $c_ref eq 'ARRAY';
235 return $c_val->($s_val) if $c_ref eq 'CODE';
236 return $c_val->call($s_val) if $c_ref eq 'Switch';
237 return scalar $s_val=~/$c_val/
238 if $c_ref eq 'Regexp';
239 return scalar $c_val->{$s_val}
244 elsif ($s_ref eq "") # STRING SCALAR
247 sub { my $c_val = $_[0];
248 my $c_ref = ref $c_val;
249 return $s_val eq $c_val if $c_ref eq "";
250 return in([$s_val],$c_val) if $c_ref eq 'ARRAY';
251 return $c_val->($s_val) if $c_ref eq 'CODE';
252 return $c_val->call($s_val) if $c_ref eq 'Switch';
253 return scalar $s_val=~/$c_val/
254 if $c_ref eq 'Regexp';
255 return scalar $c_val->{$s_val}
260 elsif ($s_ref eq 'ARRAY')
263 sub { my $c_val = $_[0];
264 my $c_ref = ref $c_val;
265 return in($s_val,[$c_val]) if $c_ref eq "";
266 return in($s_val,$c_val) if $c_ref eq 'ARRAY';
267 return $c_val->(@$s_val) if $c_ref eq 'CODE';
268 return $c_val->call(@$s_val)
269 if $c_ref eq 'Switch';
270 return scalar grep {$_=~/$c_val/} @$s_val
271 if $c_ref eq 'Regexp';
272 return scalar grep {$c_val->{$_}} @$s_val
277 elsif ($s_ref eq 'Regexp')
280 sub { my $c_val = $_[0];
281 my $c_ref = ref $c_val;
282 return $c_val=~/s_val/ if $c_ref eq "";
283 return scalar grep {$_=~/s_val/} @$c_val
284 if $c_ref eq 'ARRAY';
285 return $c_val->($s_val) if $c_ref eq 'CODE';
286 return $c_val->call($s_val) if $c_ref eq 'Switch';
287 return $s_val eq $c_val if $c_ref eq 'Regexp';
288 return grep {$_=~/$s_val/ && $c_val->{$_}} keys %$c_val
293 elsif ($s_ref eq 'HASH')
296 sub { my $c_val = $_[0];
297 my $c_ref = ref $c_val;
298 return $s_val->{$c_val} if $c_ref eq "";
299 return scalar grep {$s_val->{$_}} @$c_val
300 if $c_ref eq 'ARRAY';
301 return $c_val->($s_val) if $c_ref eq 'CODE';
302 return $c_val->call($s_val) if $c_ref eq 'Switch';
303 return grep {$_=~/$c_val/ && $s_val->{"$_"}} keys %$s_val
304 if $c_ref eq 'Regexp';
305 return $s_val==$c_val if $c_ref eq 'HASH';
309 elsif ($s_ref eq 'Switch')
312 sub { my $c_val = $_[0];
313 return $s_val == $c_val if ref $c_val eq 'Switch';
314 return $s_val->call(@$c_val)
315 if ref $c_val eq 'ARRAY';
316 return $s_val->call($c_val);
321 croak "Cannot switch on $s_ref";
326 sub case($) { $::_S_W_I_T_C_H->(@_); }
330 my $placeholder = bless { arity=>1, impl=>sub{$_[1+$_[0]]} };
332 sub __() { $placeholder }
337 bless { arity=>0, impl=>sub{$_[$index]} };
347 my ($self,@args) = @_;
348 return $self->{impl}->(0,@args);
356 my ($left, $right, $reversed) = @_;
357 ($right,$left) = @_ if $reversed;
359 my $rop = ref $right eq 'Switch'
361 : bless { arity=>0, impl=>sub{$right} };
363 my $lop = ref $left eq 'Switch'
365 : bless { arity=>0, impl=>sub{$left} };
367 my $arity = $lop->{arity} + $rop->{arity};
371 impl => sub { my $start = shift;
372 return $op->($lop->{impl}->($start,@_),
373 $rop->{impl}->($start+$lop->{arity},@_));
386 my $lop = ref $left eq 'Switch'
388 : bless { arity=>0, impl=>sub{$left} };
390 my $arity = $lop->{arity};
394 impl => sub { $op->($lop->{impl}->(@_)) }
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 ">>" => meta_bop {$_[0] >> $_[1]},
409 "x" => meta_bop {$_[0] x $_[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 "<=>" => meta_bop {$_[0] <=> $_[1]},
418 "lt" => meta_bop {$_[0] lt $_[1]},
419 "le" => meta_bop {$_[0] le $_[1]},
420 "gt" => meta_bop {$_[0] gt $_[1]},
421 "ge" => meta_bop {$_[0] ge $_[1]},
422 "eq" => meta_bop {$_[0] eq $_[1]},
423 "ne" => meta_bop {$_[0] ne $_[1]},
424 "cmp" => meta_bop {$_[0] cmp $_[1]},
425 "\&" => meta_bop {$_[0] & $_[1]},
426 "^" => meta_bop {$_[0] ^ $_[1]},
427 "|" => meta_bop {$_[0] | $_[1]},
428 "atan2" => meta_bop {atan2 $_[0], $_[1]},
430 "neg" => meta_uop {-$_[0]},
431 "!" => meta_uop {!$_[0]},
432 "~" => meta_uop {~$_[0]},
433 "cos" => meta_uop {cos $_[0]},
434 "sin" => meta_uop {sin $_[0]},
435 "exp" => meta_uop {exp $_[0]},
436 "abs" => meta_uop {abs $_[0]},
437 "log" => meta_uop {log $_[0]},
438 "sqrt" => meta_uop {sqrt $_[0]},
439 "bool" => sub { croak "Can't use && or || in expression containing __" },
441 # "&()" => sub { $_[0]->{impl} },
443 # "||" => meta_bop {$_[0] || $_[1]},
444 # "&&" => meta_bop {$_[0] && $_[1]},
454 Switch - A switch statement for Perl
458 This document describes version 2.03 of Switch,
459 released May 15, 2001.
467 case 1 { print "number 1" }
468 case "a" { print "string a" }
469 case [1..10,42] { print "number in list" }
470 case (@array) { print "number in list" }
471 case /\w+/ { print "pattern" }
472 case qr/\w+/ { print "pattern" }
473 case (%hash) { print "entry in hash" }
474 case (\%hash) { print "entry in hash" }
475 case (\&sub) { print "arg to subroutine" }
476 else { print "previous case not true" }
481 [Skip ahead to L<"DESCRIPTION"> if you don't care about the whys
482 and wherefores of this control structure]
484 In seeking to devise a "Swiss Army" case mechanism suitable for Perl,
485 it is useful to generalize this notion of distributed conditional
486 testing as far as possible. Specifically, the concept of "matching"
487 between the switch value and the various case values need not be
488 restricted to numeric (or string or referential) equality, as it is in other
489 languages. Indeed, as Table 1 illustrates, Perl
490 offers at least eighteen different ways in which two values could
493 Table 1: Matching a switch value ($s) with a case value ($c)
495 Switch Case Type of Match Implied Matching Code
497 ====== ===== ===================== =============
499 number same numeric or referential match if $s == $c;
502 object method result of method call match if $s->$c();
503 ref name match if defined $s->$c();
506 other other string equality match if $s eq $c;
510 string regexp pattern match match if $s =~ /$c/;
512 array scalar array entry existence match if 0<=$c && $c<@$s;
513 ref array entry definition match if defined $s->[$c];
514 array entry truth match if $s->[$c];
516 array array array intersection match if intersects(@$s, @$c);
517 ref ref (apply this table to
518 all pairs of elements
522 array regexp array grep match if grep /$c/, @$s;
525 hash scalar hash entry existence match if exists $s->{$c};
526 ref hash entry definition match if defined $s->{$c};
527 hash entry truth match if $s->{$c};
529 hash regexp hash grep match if grep /$c/, keys %$s;
532 sub scalar return value defn match if defined $s->($c);
533 ref return value truth match if $s->($c);
535 sub array return value defn match if defined $s->(@$c);
536 ref ref return value truth match if $s->(@$c);
539 In reality, Table 1 covers 31 alternatives, because only the equality and
540 intersection tests are commutative; in all other cases, the roles of
541 the C<$s> and C<$c> variables could be reversed to produce a
542 different test. For example, instead of testing a single hash for
543 the existence of a series of keys (C<match if exists $s-E<gt>{$c}>),
544 one could test for the existence of a single key in a series of hashes
545 (C<match if exists $c-E<gt>{$s}>).
547 As L<perltodo> observes, a Perl case mechanism must support all these
553 The Switch.pm module implements a generalized case mechanism that covers
554 the numerous possible combinations of switch and case values described above.
556 The module augments the standard Perl syntax with two new control
557 statements: C<switch> and C<case>. The C<switch> statement takes a
558 single scalar argument of any type, specified in parentheses.
559 C<switch> stores this value as the
560 current switch value in a (localized) control variable.
561 The value is followed by a block which may contain one or more
562 Perl statements (including the C<case> statement described below).
563 The block is unconditionally executed once the switch value has
566 A C<case> statement takes a single scalar argument (in mandatory
567 parentheses if it's a variable; otherwise the parens are optional) and
568 selects the appropriate type of matching between that argument and the
569 current switch value. The type of matching used is determined by the
570 respective types of the switch value and the C<case> argument, as
571 specified in Table 1. If the match is successful, the mandatory
572 block associated with the C<case> statement is executed.
574 In most other respects, the C<case> statement is semantically identical
575 to an C<if> statement. For example, it can be followed by an C<else>
576 clause, and can be used as a postfix statement qualifier.
578 However, when a C<case> block has been executed control is automatically
579 transferred to the statement after the immediately enclosing C<switch>
580 block, rather than to the next statement within the block. In other
581 words, the success of any C<case> statement prevents other cases in the
582 same scope from executing. But see L<"Allowing fall-through"> below.
584 Together these two new statements provide a fully generalized case
591 %special = ( woohoo => 1, d'oh => 1 );
596 case %special { print "homer\n"; } # if $special{$_}
597 case /a-z/i { print "alpha\n"; } # if $_ =~ /a-z/i
598 case [1..9] { print "small num\n"; } # if $_ in [1..9]
600 case { $_[0] >= 10 } { # if $_ >= 10
602 switch (sub{ $_[0] < $age } ) {
604 case 20 { print "teens\n"; } # if 20 < $age
605 case 30 { print "twenties\n"; } # if 30 < $age
606 else { print "history\n"; }
610 print "must be punctuation\n" case /\W/; # if $_ ~= /\W/
613 Note that C<switch>es can be nested within C<case> (or any other) blocks,
614 and a series of C<case> statements can try different types of matches
615 -- hash membership, pattern match, array intersection, simple equality,
616 etc. -- against the same switch value.
618 The use of intersection tests against an array reference is particularly
619 useful for aggregating integral cases:
623 switch ($_[0]) { case 0 { return 'zero' }
624 case [2,4,6,8] { return 'even' }
625 case [1,3,4,7,9] { return 'odd' }
626 case /[A-F]/i { return 'hex' }
631 =head2 Allowing fall-through
633 Fall-though (trying another case after one has already succeeded)
634 is usually a Bad Idea in a switch statement. However, this
635 is Perl, not a police state, so there I<is> a way to do it, if you must.
637 If a C<case> block executes an untargetted C<next>, control is
638 immediately transferred to the statement I<after> the C<case> statement
639 (i.e. usually another case), rather than out of the surrounding
645 case 1 { handle_num_1(); next } # and try next case...
646 case "1" { handle_str_1(); next } # and try next case...
647 case [0..9] { handle_num_any(); } # and we're done
648 case /\d/ { handle_dig_any(); next } # and try next case...
649 case /.*/ { handle_str_any(); next } # and try next case...
652 If $val held the number C<1>, the above C<switch> block would call the
653 first three C<handle_...> subroutines, jumping to the next case test
654 each time it encountered a C<next>. After the thrid C<case> block
655 was executed, control would jump to the end of the enclosing
658 On the other hand, if $val held C<10>, then only the last two C<handle_...>
659 subroutines would be called.
661 Note that this mechanism allows the notion of I<conditional fall-through>.
665 case [0..9] { handle_num_any(); next if $val < 7; }
666 case /\d/ { handle_dig_any(); }
669 If an untargetted C<last> statement is executed in a case block, this
670 immediately transfers control out of the enclosing C<switch> block
671 (in other words, there is an implicit C<last> at the end of each
672 normal C<case> block). Thus the previous example could also have been
676 case [0..9] { handle_num_any(); last if $val >= 7; next; }
677 case /\d/ { handle_dig_any(); }
681 =head2 Automating fall-through
683 In situations where case fall-through should be the norm, rather than an
684 exception, an endless succession of terminal C<next>s is tedious and ugly.
685 Hence, it is possible to reverse the default behaviour by specifying
686 the string "fallthrough" when importing the module. For example, the
687 following code is equivalent to the first example in L<"Allowing fall-through">:
689 use Switch 'fallthrough';
692 case 1 { handle_num_1(); }
693 case "1" { handle_str_1(); }
694 case [0..9] { handle_num_any(); last }
695 case /\d/ { handle_dig_any(); }
696 case /.*/ { handle_str_any(); }
699 Note the explicit use of a C<last> to preserve the non-fall-through
700 behaviour of the third case.
704 =head2 Higher-order Operations
706 One situation in which C<switch> and C<case> do not provide a good
707 substitute for a cascaded C<if>, is where a switch value needs to
708 be tested against a series of conditions. For example:
713 case sub { $_[0] < 10 } { return 'milk' }
714 case sub { $_[0] < 20 } { return 'coke' }
715 case sub { $_[0] < 30 } { return 'beer' }
716 case sub { $_[0] < 40 } { return 'wine' }
717 case sub { $_[0] < 50 } { return 'malt' }
718 case sub { $_[0] < 60 } { return 'Moet' }
719 else { return 'milk' }
723 The need to specify each condition as a subroutine block is tiresome. To
724 overcome this, when importing Switch.pm, a special "placeholder"
725 subroutine named C<__> [sic] may also be imported. This subroutine
726 converts (almost) any expression in which it appears to a reference to a
727 higher-order function. That is, the expression:
735 sub { $_[0] < 2 + $_[1] }
737 With C<__>, the previous ugly case statements can be rewritten:
739 case __ < 10 { return 'milk' }
740 case __ < 20 { return 'coke' }
741 case __ < 30 { return 'beer' }
742 case __ < 40 { return 'wine' }
743 case __ < 50 { return 'malt' }
744 case __ < 60 { return 'Moet' }
745 else { return 'milk' }
747 The C<__> subroutine makes extensive use of operator overloading to
748 perform its magic. All operations involving __ are overloaded to
749 produce an anonymous subroutine that implements a lazy version
750 of the original operation.
752 The only problem is that operator overloading does not allow the
753 boolean operators C<&&> and C<||> to be overloaded. So a case statement
756 case 0 <= __ && __ < 10 { return 'digit' }
758 doesn't act as expected, because when it is
759 executed, it constructs two higher order subroutines
760 and then treats the two resulting references as arguments to C<&&>:
762 sub { 0 <= $_[0] } && sub { $_[0] < 10 }
764 This boolean expression is inevitably true, since both references are
765 non-false. Fortunately, the overloaded C<'bool'> operator catches this
766 situation and flags it as a error.
770 The module is implemented using Filter::Util::Call and Text::Balanced
771 and requires both these modules to be installed.
775 Damian Conway (damian@conway.org)
779 There are undoubtedly serious bugs lurking somewhere in code this funky :-)
780 Bug reports and other feedback are most welcome.
784 Copyright (c) 1997-2000, Damian Conway. All Rights Reserved.
785 This module is free software; you can redistribute it and/or
786 modify it under the same terms as Perl itself.