This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
DB_File-1.78
[perl5.git] / lib / Switch.pm
CommitLineData
3ed9f206
JH
1package Switch;
2
3use strict;
4use vars qw($VERSION);
5use Carp;
6
a1813bef 7$VERSION = '2.03';
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;
a1813bef 27 filter_add({}) unless @_>1 && $_[1] eq 'noimport';
3ed9f206
JH
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 {
a1813bef 185 my $numx = ref($nextx) || defined $nextx && (~$nextx&$nextx) eq 0;
3ed9f206
JH
186 for my $j ( 0..$#$y )
187 {
188 my $nexty = $y->[$j];
a1813bef 189 push @numy, ref($nexty) || defined $nexty && (~$nexty&$nexty) eq 0
3ed9f206
JH
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 }
a1813bef 225 elsif ($s_ref eq "" && defined $s_val && (~$s_val&$s_val) eq 0) # NUMERIC SCALAR
3ed9f206
JH
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 ""
a1813bef 231 && defined $c_val
3ed9f206
JH
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}
240 if $c_ref eq 'HASH';
241 return;
242 };
243 }
244 elsif ($s_ref eq "") # STRING SCALAR
245 {
246 $::_S_W_I_T_C_H =
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}
256 if $c_ref eq 'HASH';
257 return;
258 };
259 }
260 elsif ($s_ref eq 'ARRAY')
261 {
262 $::_S_W_I_T_C_H =
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
273 if $c_ref eq 'HASH';
274 return;
275 };
276 }
277 elsif ($s_ref eq 'Regexp')
278 {
279 $::_S_W_I_T_C_H =
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
289 if $c_ref eq 'HASH';
290 return;
291 };
292 }
293 elsif ($s_ref eq 'HASH')
294 {
295 $::_S_W_I_T_C_H =
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';
306 return;
307 };
308 }
309 elsif ($s_ref eq 'Switch')
310 {
311 $::_S_W_I_T_C_H =
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);
317 };
318 }
319 else
320 {
321 croak "Cannot switch on $s_ref";
322 }
323 return 1;
324}
325
326sub case($) { $::_S_W_I_T_C_H->(@_); }
327
328# IMPLEMENT __
329
330my $placeholder = bless { arity=>1, impl=>sub{$_[1+$_[0]]} };
331
332sub __() { $placeholder }
333
334sub __arg($)
335{
336 my $index = $_[0]+1;
337 bless { arity=>0, impl=>sub{$_[$index]} };
338}
339
340sub hosub(&@)
341{
342 # WRITE THIS
343}
344
345sub call
346{
347 my ($self,@args) = @_;
348 return $self->{impl}->(0,@args);
349}
350
351sub meta_bop(&)
352{
353 my ($op) = @_;
354 sub
355 {
356 my ($left, $right, $reversed) = @_;
357 ($right,$left) = @_ if $reversed;
358
359 my $rop = ref $right eq 'Switch'
360 ? $right
361 : bless { arity=>0, impl=>sub{$right} };
362
363 my $lop = ref $left eq 'Switch'
364 ? $left
365 : bless { arity=>0, impl=>sub{$left} };
366
367 my $arity = $lop->{arity} + $rop->{arity};
368
369 return bless {
370 arity => $arity,
371 impl => sub { my $start = shift;
372 return $op->($lop->{impl}->($start,@_),
373 $rop->{impl}->($start+$lop->{arity},@_));
374 }
375 };
376 };
377}
378
379sub meta_uop(&)
380{
381 my ($op) = @_;
382 sub
383 {
384 my ($left) = @_;
385
386 my $lop = ref $left eq 'Switch'
387 ? $left
388 : bless { arity=>0, impl=>sub{$left} };
389
390 my $arity = $lop->{arity};
391
392 return bless {
393 arity => $arity,
394 impl => sub { $op->($lop->{impl}->(@_)) }
395 };
396 };
397}
398
399
400use overload
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]},
429
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 __" },
440
441 # "&()" => sub { $_[0]->{impl} },
442
443 # "||" => meta_bop {$_[0] || $_[1]},
444 # "&&" => meta_bop {$_[0] && $_[1]},
445 # fallback => 1,
446 ;
4471;
448
449__END__
450
451
452=head1 NAME
453
454Switch - A switch statement for Perl
455
456=head1 VERSION
457
a1813bef
JH
458This document describes version 2.03 of Switch,
459released May 15, 2001.
3ed9f206
JH
460
461=head1 SYNOPSIS
462
463 use Switch;
464
465 switch ($val) {
466
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" }
477 }
478
479=head1 BACKGROUND
480
481[Skip ahead to L<"DESCRIPTION"> if you don't care about the whys
482and wherefores of this control structure]
483
484In seeking to devise a "Swiss Army" case mechanism suitable for Perl,
485it is useful to generalize this notion of distributed conditional
486testing as far as possible. Specifically, the concept of "matching"
487between the switch value and the various case values need not be
488restricted to numeric (or string or referential) equality, as it is in other
489languages. Indeed, as Table 1 illustrates, Perl
490offers at least eighteen different ways in which two values could
491generate a match.
492
493 Table 1: Matching a switch value ($s) with a case value ($c)
494
495 Switch Case Type of Match Implied Matching Code
496 Value Value
497 ====== ===== ===================== =============
498
499 number same numeric or referential match if $s == $c;
500 or ref equality
501
502 object method result of method call match if $s->$c();
503 ref name match if defined $s->$c();
504 or ref
505
506 other other string equality match if $s eq $c;
507 non-ref non-ref
508 scalar scalar
509
510 string regexp pattern match match if $s =~ /$c/;
511
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];
515
516 array array array intersection match if intersects(@$s, @$c);
517 ref ref (apply this table to
518 all pairs of elements
519 $s->[$i] and
520 $c->[$j])
521
522 array regexp array grep match if grep /$c/, @$s;
523 ref
524
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};
528
529 hash regexp hash grep match if grep /$c/, keys %$s;
530 ref
531
532 sub scalar return value defn match if defined $s->($c);
533 ref return value truth match if $s->($c);
534
535 sub array return value defn match if defined $s->(@$c);
536 ref ref return value truth match if $s->(@$c);
537
538
539In reality, Table 1 covers 31 alternatives, because only the equality and
540intersection tests are commutative; in all other cases, the roles of
541the C<$s> and C<$c> variables could be reversed to produce a
542different test. For example, instead of testing a single hash for
543the existence of a series of keys (C<match if exists $s-E<gt>{$c}>),
544one could test for the existence of a single key in a series of hashes
545(C<match if exists $c-E<gt>{$s}>).
546
547As L<perltodo> observes, a Perl case mechanism must support all these
548"ways to do it".
549
550
551=head1 DESCRIPTION
552
553The Switch.pm module implements a generalized case mechanism that covers
554the numerous possible combinations of switch and case values described above.
555
556The module augments the standard Perl syntax with two new control
557statements: C<switch> and C<case>. The C<switch> statement takes a
558single scalar argument of any type, specified in parentheses.
559C<switch> stores this value as the
560current switch value in a (localized) control variable.
561The value is followed by a block which may contain one or more
562Perl statements (including the C<case> statement described below).
563The block is unconditionally executed once the switch value has
564been cached.
565
566A C<case> statement takes a single scalar argument (in mandatory
567parentheses if it's a variable; otherwise the parens are optional) and
568selects the appropriate type of matching between that argument and the
569current switch value. The type of matching used is determined by the
570respective types of the switch value and the C<case> argument, as
571specified in Table 1. If the match is successful, the mandatory
572block associated with the C<case> statement is executed.
573
574In most other respects, the C<case> statement is semantically identical
575to an C<if> statement. For example, it can be followed by an C<else>
576clause, and can be used as a postfix statement qualifier.
577
578However, when a C<case> block has been executed control is automatically
579transferred to the statement after the immediately enclosing C<switch>
580block, rather than to the next statement within the block. In other
581words, the success of any C<case> statement prevents other cases in the
582same scope from executing. But see L<"Allowing fall-through"> below.
583
584Together these two new statements provide a fully generalized case
585mechanism:
586
587 use Switch;
588
589 # AND LATER...
590
591 %special = ( woohoo => 1, d'oh => 1 );
592
593 while (<>) {
594 switch ($_) {
595
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]
599
600 case { $_[0] >= 10 } { # if $_ >= 10
601 my $age = <>;
602 switch (sub{ $_[0] < $age } ) {
603
604 case 20 { print "teens\n"; } # if 20 < $age
605 case 30 { print "twenties\n"; } # if 30 < $age
606 else { print "history\n"; }
607 }
608 }
609
610 print "must be punctuation\n" case /\W/; # if $_ ~= /\W/
611 }
612
613Note that C<switch>es can be nested within C<case> (or any other) blocks,
614and a series of C<case> statements can try different types of matches
615-- hash membership, pattern match, array intersection, simple equality,
616etc. -- against the same switch value.
617
618The use of intersection tests against an array reference is particularly
619useful for aggregating integral cases:
620
621 sub classify_digit
622 {
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' }
627 }
628 }
629
630
631=head2 Allowing fall-through
632
633Fall-though (trying another case after one has already succeeded)
634is usually a Bad Idea in a switch statement. However, this
635is Perl, not a police state, so there I<is> a way to do it, if you must.
636
637If a C<case> block executes an untargetted C<next>, control is
638immediately transferred to the statement I<after> the C<case> statement
639(i.e. usually another case), rather than out of the surrounding
640C<switch> block.
641
642For example:
643
644 switch ($val) {
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...
650 }
651
652If $val held the number C<1>, the above C<switch> block would call the
653first three C<handle_...> subroutines, jumping to the next case test
654each time it encountered a C<next>. After the thrid C<case> block
655was executed, control would jump to the end of the enclosing
656C<switch> block.
657
658On the other hand, if $val held C<10>, then only the last two C<handle_...>
659subroutines would be called.
660
661Note that this mechanism allows the notion of I<conditional fall-through>.
662For example:
663
664 switch ($val) {
665 case [0..9] { handle_num_any(); next if $val < 7; }
666 case /\d/ { handle_dig_any(); }
667 }
668
669If an untargetted C<last> statement is executed in a case block, this
670immediately transfers control out of the enclosing C<switch> block
671(in other words, there is an implicit C<last> at the end of each
672normal C<case> block). Thus the previous example could also have been
673written:
674
675 switch ($val) {
676 case [0..9] { handle_num_any(); last if $val >= 7; next; }
677 case /\d/ { handle_dig_any(); }
678 }
679
680
681=head2 Automating fall-through
682
683In situations where case fall-through should be the norm, rather than an
684exception, an endless succession of terminal C<next>s is tedious and ugly.
685Hence, it is possible to reverse the default behaviour by specifying
686the string "fallthrough" when importing the module. For example, the
687following code is equivalent to the first example in L<"Allowing fall-through">:
688
689 use Switch 'fallthrough';
690
691 switch ($val) {
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(); }
697 }
698
699Note the explicit use of a C<last> to preserve the non-fall-through
700behaviour of the third case.
701
702
703
704=head2 Higher-order Operations
705
706One situation in which C<switch> and C<case> do not provide a good
707substitute for a cascaded C<if>, is where a switch value needs to
708be tested against a series of conditions. For example:
709
710 sub beverage {
711 switch (shift) {
712
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' }
720 }
721 }
722
723The need to specify each condition as a subroutine block is tiresome. To
724overcome this, when importing Switch.pm, a special "placeholder"
725subroutine named C<__> [sic] may also be imported. This subroutine
726converts (almost) any expression in which it appears to a reference to a
727higher-order function. That is, the expression:
728
729 use Switch '__';
730
731 __ < 2 + __
732
733is equivalent to:
734
735 sub { $_[0] < 2 + $_[1] }
736
737With C<__>, the previous ugly case statements can be rewritten:
738
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' }
746
747The C<__> subroutine makes extensive use of operator overloading to
748perform its magic. All operations involving __ are overloaded to
749produce an anonymous subroutine that implements a lazy version
750of the original operation.
751
752The only problem is that operator overloading does not allow the
753boolean operators C<&&> and C<||> to be overloaded. So a case statement
754like this:
755
756 case 0 <= __ && __ < 10 { return 'digit' }
757
758doesn't act as expected, because when it is
759executed, it constructs two higher order subroutines
760and then treats the two resulting references as arguments to C<&&>:
761
762 sub { 0 <= $_[0] } && sub { $_[0] < 10 }
763
764This boolean expression is inevitably true, since both references are
765non-false. Fortunately, the overloaded C<'bool'> operator catches this
766situation and flags it as a error.
767
768=head1 DEPENDENCIES
769
770The module is implemented using Filter::Util::Call and Text::Balanced
771and requires both these modules to be installed.
772
773=head1 AUTHOR
774
775Damian Conway (damian@conway.org)
776
777=head1 BUGS
778
779There are undoubtedly serious bugs lurking somewhere in code this funky :-)
780Bug reports and other feedback are most welcome.
781
782=head1 COPYRIGHT
783
784Copyright (c) 1997-2000, Damian Conway. All Rights Reserved.
7a57cd46
JH
785This module is free software; you can redistribute it and/or
786modify it under the same terms as Perl itself.