This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Update to Switch 2.02.
[perl5.git] / lib / Switch.pm
CommitLineData
3ed9f206
JH
1package Switch;
2
3use strict;
4use vars qw($VERSION);
5use Carp;
6
3961318e 7$VERSION = '2.02';
3ed9f206
JH
8
9
10# LOAD FILTERING MODULE...
11use Filter::Util::Call;
12
13sub __();
14
15# CATCH ATTEMPTS TO CALL case OUTSIDE THE SCOPE OF ANY switch
16
17$::_S_W_I_T_C_H = sub { croak "case statement not in switch block" };
18
19my $offset;
20my $fallthrough;
3ed9f206
JH
21
22sub import
23{
3961318e 24 $DB::single = 1;
3ed9f206
JH
25 $fallthrough = grep /\bfallthrough\b/, @_;
26 $offset = (caller)[2]+1;
27 filter_add({}) unless @_>1 && $_[1] ne '__';
28 my $pkg = caller;
29 no strict 'refs';
30 for ( qw( on_defined on_exists ) )
31 {
32 *{"${pkg}::$_"} = \&$_;
33 }
34 *{"${pkg}::__"} = \&__ if grep /__/, @_;
35 1;
36}
37
38sub unimport
39{
40 filter_del()
41}
42
43sub filter
44{
45 my($self) = @_ ;
46 local $Switch::file = (caller)[1];
47
48 my $status = 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;
53 # print STDERR $_;
54 return $status;
55}
56
57use Text::Balanced ':ALL';
58
59sub line
60{
61 my ($pretext,$offset) = @_;
62 ($pretext=~tr/\n/\n/)+$offset,
63}
64
65sub is_block
66{
67 local $SIG{__WARN__}=sub{die$@};
68 local $^W=1;
69 my $ishash = defined eval 'my $hr='.$_[0];
70 undef $@;
71 return !$ishash;
72}
73
74my $casecounter = 1;
75sub filter_blocks
76{
77 my ($source, $line) = @_;
78 return $source unless $source =~ /case|switch/;
79 pos $source = 0;
80 my $text = "";
81 component: while (pos $source < length $source)
82 {
3961318e 83 if ($source =~ m/(\G\s*use\s+Switch\b)/gc)
3ed9f206
JH
84 {
85 $text .= q{use Switch 'noimport'};
86 next component;
87 }
88 my @pos = Text::Balanced::_match_quotelike(\$source,qr/\s*/,1,1);
89 if (defined $pos[0])
90 {
3961318e 91 $text .= " " . substr($source,$pos[2],$pos[18]-$pos[2]);
3ed9f206
JH
92 next component;
93 }
94 @pos = Text::Balanced::_match_variable(\$source,qr/\s*/);
95 if (defined $pos[0])
96 {
3961318e 97 $text .= " " . substr($source,$pos[0],$pos[4]-$pos[0]);
3ed9f206
JH
98 next component;
99 }
100
101 if ($source =~ m/\G(\n*)(\s*)switch\b(?=\s*[(])/gc)
102 {
103 $text .= $1.$2.'S_W_I_T_C_H: while (1) ';
3961318e 104 @pos = Text::Balanced::_match_codeblock(\$source,qr/\s*/,qr/\(/,qr/\)/,qr/[[{(<]/,qr/[]})>]/,undef)
3ed9f206
JH
105 or do {
106 die "Bad switch statement (problem in the parentheses?) near $Switch::file line ", line(substr($source,0,pos $source),$line), "\n";
107 };
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)
114 or do {
115 die "Bad switch statement (problem in the code block?) near $Switch::file line ", line(substr($source,0, pos $source), $line), "\n";
116 };
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}';
120 next component;
121 }
122 elsif ($source =~ m/\G(\s*)(case\b)(?!\s*=>)/gc)
123 {
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)) . ")";
129 }
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};
136 $text .= " $code)";
137 }
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};
144 $text .= " $code)";
145 }
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 '%';
149 $text .= " $code)";
150 }
151 else {
152 die "Bad case statement (invalid case value?) near $Switch::file line ", line(substr($source,0,pos $source), $line), "\n";
153 }
154
155 @pos = Text::Balanced::_match_codeblock(\$source,qr/\s*/,qr/\{/,qr/\}/,qr/\{/,qr/\}/,undef)
156 or do {
157 if ($source =~ m/\G\s*(?=([};]|\Z))/gc) {
158 $casecounter++;
159 next component;
160 }
161 die "Bad case statement (problem in the code block?) near $Switch::file line ", line(substr($source,0,pos $source),$line), "\n";
162 };
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 }/
165 unless $fallthrough;
166 $text .= "{ while (1) $code continue { goto C_A_S_E_$casecounter } last S_W_I_T_C_H; C_A_S_E_$casecounter: }";
167 $casecounter++;
168 next component;
169 }
170
171 $source =~ m/\G(\s*(\w+|#.*\n|\W))/gc;
172 $text .= $1;
173 }
174 $text;
175}
176
177
178
179sub in
180{
181 my ($x,$y) = @_;
182 my @numy;
183 for my $nextx ( @$x )
184 {
185 my $numx = ref($nextx) || (~$nextx&$nextx) eq 0;
186 for my $j ( 0..$#$y )
187 {
188 my $nexty = $y->[$j];
189 push @numy, ref($nexty) || (~$nexty&$nexty) eq 0
190 if @numy <= $j;
191 return 1 if $numx && $numy[$j] && $nextx==$nexty
192 || $nextx eq $nexty;
193
194 }
195 }
196 return "";
197}
198
199sub on_exists
200{
201 my $ref = @_==1 && ref($_[0]) eq 'HASH' ? $_[0] : { @_ };
202 [ keys %$ref ]
203}
204
205sub on_defined
206{
207 my $ref = @_==1 && ref($_[0]) eq 'HASH' ? $_[0] : { @_ };
208 [ grep { defined $ref->{$_} } keys %$ref ]
209}
210
211sub switch(;$)
212{
213 my ($s_val) = @_ ? $_[0] : $_;
214 my $s_ref = ref $s_val;
215
216 if ($s_ref eq 'CODE')
217 {
218 $::_S_W_I_T_C_H =
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);
223 };
224 }
225 elsif ($s_ref eq "" && (~$s_val&$s_val) eq 0) # NUMERIC SCALAR
226 {
227 $::_S_W_I_T_C_H =
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}
239 if $c_ref eq 'HASH';
240 return;
241 };
242 }
243 elsif ($s_ref eq "") # STRING SCALAR
244 {
245 $::_S_W_I_T_C_H =
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}
255 if $c_ref eq 'HASH';
256 return;
257 };
258 }
259 elsif ($s_ref eq 'ARRAY')
260 {
261 $::_S_W_I_T_C_H =
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
272 if $c_ref eq 'HASH';
273 return;
274 };
275 }
276 elsif ($s_ref eq 'Regexp')
277 {
278 $::_S_W_I_T_C_H =
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
288 if $c_ref eq 'HASH';
289 return;
290 };
291 }
292 elsif ($s_ref eq 'HASH')
293 {
294 $::_S_W_I_T_C_H =
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';
305 return;
306 };
307 }
308 elsif ($s_ref eq 'Switch')
309 {
310 $::_S_W_I_T_C_H =
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);
316 };
317 }
318 else
319 {
320 croak "Cannot switch on $s_ref";
321 }
322 return 1;
323}
324
325sub case($) { $::_S_W_I_T_C_H->(@_); }
326
327# IMPLEMENT __
328
329my $placeholder = bless { arity=>1, impl=>sub{$_[1+$_[0]]} };
330
331sub __() { $placeholder }
332
333sub __arg($)
334{
335 my $index = $_[0]+1;
336 bless { arity=>0, impl=>sub{$_[$index]} };
337}
338
339sub hosub(&@)
340{
341 # WRITE THIS
342}
343
344sub call
345{
346 my ($self,@args) = @_;
347 return $self->{impl}->(0,@args);
348}
349
350sub meta_bop(&)
351{
352 my ($op) = @_;
353 sub
354 {
355 my ($left, $right, $reversed) = @_;
356 ($right,$left) = @_ if $reversed;
357
358 my $rop = ref $right eq 'Switch'
359 ? $right
360 : bless { arity=>0, impl=>sub{$right} };
361
362 my $lop = ref $left eq 'Switch'
363 ? $left
364 : bless { arity=>0, impl=>sub{$left} };
365
366 my $arity = $lop->{arity} + $rop->{arity};
367
368 return bless {
369 arity => $arity,
370 impl => sub { my $start = shift;
371 return $op->($lop->{impl}->($start,@_),
372 $rop->{impl}->($start+$lop->{arity},@_));
373 }
374 };
375 };
376}
377
378sub meta_uop(&)
379{
380 my ($op) = @_;
381 sub
382 {
383 my ($left) = @_;
384
385 my $lop = ref $left eq 'Switch'
386 ? $left
387 : bless { arity=>0, impl=>sub{$left} };
388
389 my $arity = $lop->{arity};
390
391 return bless {
392 arity => $arity,
393 impl => sub { $op->($lop->{impl}->(@_)) }
394 };
395 };
396}
397
398
399use overload
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]},
428
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 __" },
439
440 # "&()" => sub { $_[0]->{impl} },
441
442 # "||" => meta_bop {$_[0] || $_[1]},
443 # "&&" => meta_bop {$_[0] && $_[1]},
444 # fallback => 1,
445 ;
4461;
447
448__END__
449
450
451=head1 NAME
452
453Switch - A switch statement for Perl
454
455=head1 VERSION
456
3961318e
JH
457This document describes version 2.02 of Switch,
458released April 26, 2001.
3ed9f206
JH
459
460=head1 SYNOPSIS
461
462 use Switch;
463
464 switch ($val) {
465
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" }
476 }
477
478=head1 BACKGROUND
479
480[Skip ahead to L<"DESCRIPTION"> if you don't care about the whys
481and wherefores of this control structure]
482
483In seeking to devise a "Swiss Army" case mechanism suitable for Perl,
484it is useful to generalize this notion of distributed conditional
485testing as far as possible. Specifically, the concept of "matching"
486between the switch value and the various case values need not be
487restricted to numeric (or string or referential) equality, as it is in other
488languages. Indeed, as Table 1 illustrates, Perl
489offers at least eighteen different ways in which two values could
490generate a match.
491
492 Table 1: Matching a switch value ($s) with a case value ($c)
493
494 Switch Case Type of Match Implied Matching Code
495 Value Value
496 ====== ===== ===================== =============
497
498 number same numeric or referential match if $s == $c;
499 or ref equality
500
501 object method result of method call match if $s->$c();
502 ref name match if defined $s->$c();
503 or ref
504
505 other other string equality match if $s eq $c;
506 non-ref non-ref
507 scalar scalar
508
509 string regexp pattern match match if $s =~ /$c/;
510
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];
514
515 array array array intersection match if intersects(@$s, @$c);
516 ref ref (apply this table to
517 all pairs of elements
518 $s->[$i] and
519 $c->[$j])
520
521 array regexp array grep match if grep /$c/, @$s;
522 ref
523
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};
527
528 hash regexp hash grep match if grep /$c/, keys %$s;
529 ref
530
531 sub scalar return value defn match if defined $s->($c);
532 ref return value truth match if $s->($c);
533
534 sub array return value defn match if defined $s->(@$c);
535 ref ref return value truth match if $s->(@$c);
536
537
538In reality, Table 1 covers 31 alternatives, because only the equality and
539intersection tests are commutative; in all other cases, the roles of
540the C<$s> and C<$c> variables could be reversed to produce a
541different test. For example, instead of testing a single hash for
542the existence of a series of keys (C<match if exists $s-E<gt>{$c}>),
543one could test for the existence of a single key in a series of hashes
544(C<match if exists $c-E<gt>{$s}>).
545
546As L<perltodo> observes, a Perl case mechanism must support all these
547"ways to do it".
548
549
550=head1 DESCRIPTION
551
552The Switch.pm module implements a generalized case mechanism that covers
553the numerous possible combinations of switch and case values described above.
554
555The module augments the standard Perl syntax with two new control
556statements: C<switch> and C<case>. The C<switch> statement takes a
557single scalar argument of any type, specified in parentheses.
558C<switch> stores this value as the
559current switch value in a (localized) control variable.
560The value is followed by a block which may contain one or more
561Perl statements (including the C<case> statement described below).
562The block is unconditionally executed once the switch value has
563been cached.
564
565A C<case> statement takes a single scalar argument (in mandatory
566parentheses if it's a variable; otherwise the parens are optional) and
567selects the appropriate type of matching between that argument and the
568current switch value. The type of matching used is determined by the
569respective types of the switch value and the C<case> argument, as
570specified in Table 1. If the match is successful, the mandatory
571block associated with the C<case> statement is executed.
572
573In most other respects, the C<case> statement is semantically identical
574to an C<if> statement. For example, it can be followed by an C<else>
575clause, and can be used as a postfix statement qualifier.
576
577However, when a C<case> block has been executed control is automatically
578transferred to the statement after the immediately enclosing C<switch>
579block, rather than to the next statement within the block. In other
580words, the success of any C<case> statement prevents other cases in the
581same scope from executing. But see L<"Allowing fall-through"> below.
582
583Together these two new statements provide a fully generalized case
584mechanism:
585
586 use Switch;
587
588 # AND LATER...
589
590 %special = ( woohoo => 1, d'oh => 1 );
591
592 while (<>) {
593 switch ($_) {
594
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]
598
599 case { $_[0] >= 10 } { # if $_ >= 10
600 my $age = <>;
601 switch (sub{ $_[0] < $age } ) {
602
603 case 20 { print "teens\n"; } # if 20 < $age
604 case 30 { print "twenties\n"; } # if 30 < $age
605 else { print "history\n"; }
606 }
607 }
608
609 print "must be punctuation\n" case /\W/; # if $_ ~= /\W/
610 }
611
612Note that C<switch>es can be nested within C<case> (or any other) blocks,
613and a series of C<case> statements can try different types of matches
614-- hash membership, pattern match, array intersection, simple equality,
615etc. -- against the same switch value.
616
617The use of intersection tests against an array reference is particularly
618useful for aggregating integral cases:
619
620 sub classify_digit
621 {
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' }
626 }
627 }
628
629
630=head2 Allowing fall-through
631
632Fall-though (trying another case after one has already succeeded)
633is usually a Bad Idea in a switch statement. However, this
634is Perl, not a police state, so there I<is> a way to do it, if you must.
635
636If a C<case> block executes an untargetted C<next>, control is
637immediately transferred to the statement I<after> the C<case> statement
638(i.e. usually another case), rather than out of the surrounding
639C<switch> block.
640
641For example:
642
643 switch ($val) {
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...
649 }
650
651If $val held the number C<1>, the above C<switch> block would call the
652first three C<handle_...> subroutines, jumping to the next case test
653each time it encountered a C<next>. After the thrid C<case> block
654was executed, control would jump to the end of the enclosing
655C<switch> block.
656
657On the other hand, if $val held C<10>, then only the last two C<handle_...>
658subroutines would be called.
659
660Note that this mechanism allows the notion of I<conditional fall-through>.
661For example:
662
663 switch ($val) {
664 case [0..9] { handle_num_any(); next if $val < 7; }
665 case /\d/ { handle_dig_any(); }
666 }
667
668If an untargetted C<last> statement is executed in a case block, this
669immediately transfers control out of the enclosing C<switch> block
670(in other words, there is an implicit C<last> at the end of each
671normal C<case> block). Thus the previous example could also have been
672written:
673
674 switch ($val) {
675 case [0..9] { handle_num_any(); last if $val >= 7; next; }
676 case /\d/ { handle_dig_any(); }
677 }
678
679
680=head2 Automating fall-through
681
682In situations where case fall-through should be the norm, rather than an
683exception, an endless succession of terminal C<next>s is tedious and ugly.
684Hence, it is possible to reverse the default behaviour by specifying
685the string "fallthrough" when importing the module. For example, the
686following code is equivalent to the first example in L<"Allowing fall-through">:
687
688 use Switch 'fallthrough';
689
690 switch ($val) {
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(); }
696 }
697
698Note the explicit use of a C<last> to preserve the non-fall-through
699behaviour of the third case.
700
701
702
703=head2 Higher-order Operations
704
705One situation in which C<switch> and C<case> do not provide a good
706substitute for a cascaded C<if>, is where a switch value needs to
707be tested against a series of conditions. For example:
708
709 sub beverage {
710 switch (shift) {
711
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' }
719 }
720 }
721
722The need to specify each condition as a subroutine block is tiresome. To
723overcome this, when importing Switch.pm, a special "placeholder"
724subroutine named C<__> [sic] may also be imported. This subroutine
725converts (almost) any expression in which it appears to a reference to a
726higher-order function. That is, the expression:
727
728 use Switch '__';
729
730 __ < 2 + __
731
732is equivalent to:
733
734 sub { $_[0] < 2 + $_[1] }
735
736With C<__>, the previous ugly case statements can be rewritten:
737
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' }
745
746The C<__> subroutine makes extensive use of operator overloading to
747perform its magic. All operations involving __ are overloaded to
748produce an anonymous subroutine that implements a lazy version
749of the original operation.
750
751The only problem is that operator overloading does not allow the
752boolean operators C<&&> and C<||> to be overloaded. So a case statement
753like this:
754
755 case 0 <= __ && __ < 10 { return 'digit' }
756
757doesn't act as expected, because when it is
758executed, it constructs two higher order subroutines
759and then treats the two resulting references as arguments to C<&&>:
760
761 sub { 0 <= $_[0] } && sub { $_[0] < 10 }
762
763This boolean expression is inevitably true, since both references are
764non-false. Fortunately, the overloaded C<'bool'> operator catches this
765situation and flags it as a error.
766
767=head1 DEPENDENCIES
768
769The module is implemented using Filter::Util::Call and Text::Balanced
770and requires both these modules to be installed.
771
772=head1 AUTHOR
773
774Damian Conway (damian@conway.org)
775
776=head1 BUGS
777
778There are undoubtedly serious bugs lurking somewhere in code this funky :-)
779Bug reports and other feedback are most welcome.
780
781=head1 COPYRIGHT
782
783Copyright (c) 1997-2000, Damian Conway. All Rights Reserved.
7a57cd46
JH
784This module is free software; you can redistribute it and/or
785modify it under the same terms as Perl itself.