I don't think trying to bracket the hires time with lores
[p5sagit/p5-mst-13.2.git] / lib / Switch.pm
CommitLineData
3ed9f206 1package Switch;
2
3use strict;
4use vars qw($VERSION);
5use Carp;
6
d38ca171 7$VERSION = '2.06';
3ed9f206 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
74a6a946 17$::_S_W_I_T_C_H = sub { croak "case/when statement not in switch/given block" };
3ed9f206 18
19my $offset;
20my $fallthrough;
74a6a946 21my ($Perl5, $Perl6) = (0,0);
3ed9f206 22
23sub import
24{
3961318e 25 $DB::single = 1;
3ed9f206 26 $fallthrough = grep /\bfallthrough\b/, @_;
27 $offset = (caller)[2]+1;
a1813bef 28 filter_add({}) unless @_>1 && $_[1] eq 'noimport';
3ed9f206 29 my $pkg = caller;
30 no strict 'refs';
31 for ( qw( on_defined on_exists ) )
32 {
33 *{"${pkg}::$_"} = \&$_;
34 }
35 *{"${pkg}::__"} = \&__ if grep /__/, @_;
74a6a946 36 $Perl6 = 1 if grep(/Perl\s*6/i, @_);
37 $Perl5 = 1 if grep(/Perl\s*5/i, @_) || !grep(/Perl\s*6/i, @_);
3ed9f206 38 1;
39}
40
41sub unimport
42{
43 filter_del()
44}
45
46sub filter
47{
48 my($self) = @_ ;
49 local $Switch::file = (caller)[1];
50
51 my $status = 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;
56 # print STDERR $_;
57 return $status;
58}
59
60use Text::Balanced ':ALL';
61
62sub line
63{
64 my ($pretext,$offset) = @_;
74a6a946 65 ($pretext=~tr/\n/\n/)+($offset||0);
3ed9f206 66}
67
68sub is_block
69{
70 local $SIG{__WARN__}=sub{die$@};
71 local $^W=1;
72 my $ishash = defined eval 'my $hr='.$_[0];
73 undef $@;
74 return !$ishash;
75}
76
d38ca171 77
78my $EOP = qr/\n\n|\Z/;
79my $CUT = qr/\n=cut.*$EOP/;
80my $pod_or_DATA = qr/ ^=(?:head[1-4]|item) .*? $CUT
81 | ^=pod .*? $CUT
82 | ^=for .*? $EOP
83 | ^=begin \s* (\S+) .*? \n=end \s* \1 .*? $EOP
84 | ^__(DATA|END)__\n.*
85 /smx;
86
3ed9f206 87my $casecounter = 1;
88sub filter_blocks
89{
90 my ($source, $line) = @_;
74a6a946 91 return $source unless $Perl5 && $source =~ /case|switch/
92 || $Perl6 && $source =~ /when|given/;
3ed9f206 93 pos $source = 0;
94 my $text = "";
95 component: while (pos $source < length $source)
96 {
3961318e 97 if ($source =~ m/(\G\s*use\s+Switch\b)/gc)
3ed9f206 98 {
99 $text .= q{use Switch 'noimport'};
100 next component;
101 }
d38ca171 102 my @pos = Text::Balanced::_match_quotelike(\$source,qr/\s*/,1,0);
3ed9f206 103 if (defined $pos[0])
104 {
3961318e 105 $text .= " " . substr($source,$pos[2],$pos[18]-$pos[2]);
3ed9f206 106 next component;
107 }
d38ca171 108 if ($source =~ m/\G\s*($pod_or_DATA)/gc) {
109 next component;
110 }
3ed9f206 111 @pos = Text::Balanced::_match_variable(\$source,qr/\s*/);
112 if (defined $pos[0])
113 {
3961318e 114 $text .= " " . substr($source,$pos[0],$pos[4]-$pos[0]);
3ed9f206 115 next component;
116 }
117
74a6a946 118 if ($Perl5 && $source =~ m/\G(\n*)(\s*)(switch)\b(?=\s*[(])/gc
119 || $Perl6 && $source =~ m/\G(\n*)(\s*)(given)\b(?=\s*[(])/gc)
3ed9f206 120 {
74a6a946 121 my $keyword = $3;
3ed9f206 122 $text .= $1.$2.'S_W_I_T_C_H: while (1) ';
3961318e 123 @pos = Text::Balanced::_match_codeblock(\$source,qr/\s*/,qr/\(/,qr/\)/,qr/[[{(<]/,qr/[]})>]/,undef)
3ed9f206 124 or do {
74a6a946 125 die "Bad $keyword statement (problem in the parentheses?) near $Switch::file line ", line(substr($source,0,pos $source),$line), "\n";
3ed9f206 126 };
127 my $arg = filter_blocks(substr($source,$pos[0],$pos[4]-$pos[0]),line(substr($source,0,$pos[0]),$line));
128 $arg =~ s {^\s*[(]\s*%} { ( \\\%} ||
129 $arg =~ s {^\s*[(]\s*m\b} { ( qr} ||
130 $arg =~ s {^\s*[(]\s*/} { ( qr/} ||
131 $arg =~ s {^\s*[(]\s*qw} { ( \\qw};
132 @pos = Text::Balanced::_match_codeblock(\$source,qr/\s*/,qr/\{/,qr/\}/,qr/\{/,qr/\}/,undef)
133 or do {
74a6a946 134 die "Bad $keyword statement (problem in the code block?) near $Switch::file line ", line(substr($source,0, pos $source), $line), "\n";
3ed9f206 135 };
136 my $code = filter_blocks(substr($source,$pos[0],$pos[4]-$pos[0]),line(substr($source,0,$pos[0]),$line));
137 $code =~ s/{/{ local \$::_S_W_I_T_C_H; Switch::switch $arg;/;
138 $text .= $code . 'continue {last}';
139 next component;
140 }
74a6a946 141 elsif ($Perl5 && $source =~ m/\G(\s*)(case\b)(?!\s*=>)/gc
142 || $Perl6 && $source =~ m/\G(\s*)(when\b)(?!\s*=>)/gc)
3ed9f206 143 {
74a6a946 144 my $keyword = $2;
3ed9f206 145 $text .= $1."if (Switch::case";
146 if (@pos = Text::Balanced::_match_codeblock(\$source,qr/\s*/,qr/\{/,qr/\}/,qr/\{/,qr/\}/,undef)) {
147 my $code = substr($source,$pos[0],$pos[4]-$pos[0]);
148 $text .= " sub" if is_block $code;
149 $text .= " " . filter_blocks($code,line(substr($source,0,$pos[0]),$line)) . ")";
150 }
151 elsif (@pos = Text::Balanced::_match_codeblock(\$source,qr/\s*/,qr/[[(]/,qr/[])]/,qr/[[({]/,qr/[])}]/,undef)) {
152 my $code = filter_blocks(substr($source,$pos[0],$pos[4]-$pos[0]),line(substr($source,0,$pos[0]),$line));
153 $code =~ s {^\s*[(]\s*%} { ( \\\%} ||
154 $code =~ s {^\s*[(]\s*m\b} { ( qr} ||
155 $code =~ s {^\s*[(]\s*/} { ( qr/} ||
156 $code =~ s {^\s*[(]\s*qw} { ( \\qw};
157 $text .= " $code)";
158 }
74a6a946 159 elsif ($Perl6 && do{@pos = Text::Balanced::_match_variable(\$source,qr/\s*/)}) {
160 my $code = filter_blocks(substr($source,$pos[0],$pos[4]-$pos[0]),line(substr($source,0,$pos[0]),$line));
161 $code =~ s {^\s*%} { \%} ||
162 $code =~ s {^\s*@} { \@};
163 $text .= " $code)";
164 }
d38ca171 165 elsif ( @pos = Text::Balanced::_match_quotelike(\$source,qr/\s*/,1,0)) {
3ed9f206 166 my $code = substr($source,$pos[2],$pos[18]-$pos[2]);
167 $code = filter_blocks($code,line(substr($source,0,$pos[2]),$line));
168 $code =~ s {^\s*m} { qr} ||
169 $code =~ s {^\s*/} { qr/} ||
170 $code =~ s {^\s*qw} { \\qw};
171 $text .= " $code)";
172 }
74a6a946 173 elsif ($Perl5 && $source =~ m/\G\s*(([^\$\@{])[^\$\@{]*)(?=\s*{)/gc
174 || $Perl6 && $source =~ m/\G\s*([^:;]*)()/gc) {
3ed9f206 175 my $code = filter_blocks($1,line(substr($source,0,pos $source),$line));
176 $text .= ' \\' if $2 eq '%';
177 $text .= " $code)";
178 }
179 else {
74a6a946 180 die "Bad $keyword statement (invalid $keyword value?) near $Switch::file line ", line(substr($source,0,pos $source), $line), "\n";
3ed9f206 181 }
182
74a6a946 183 die "Missing colon or semi-colon after 'when' value near $Switch::file line ", line(substr($source,0,pos $source), $line), "\n"
184 unless !$Perl6 || $source =~ m/\G(\s*)(:|(?=;))/gc;
185
186 do{@pos = Text::Balanced::_match_codeblock(\$source,qr/\s*/,qr/\{/,qr/\}/,qr/\{/,qr/\}/,undef)}
3ed9f206 187 or do {
188 if ($source =~ m/\G\s*(?=([};]|\Z))/gc) {
189 $casecounter++;
190 next component;
191 }
74a6a946 192 die "Bad $keyword statement (problem in the code block?) near $Switch::file line ", line(substr($source,0,pos $source),$line), "\n";
3ed9f206 193 };
194 my $code = filter_blocks(substr($source,$pos[0],$pos[4]-$pos[0]),line(substr($source,0,$pos[0]),$line));
195 $code =~ s/}(?=\s*\Z)/;last S_W_I_T_C_H }/
196 unless $fallthrough;
197 $text .= "{ while (1) $code continue { goto C_A_S_E_$casecounter } last S_W_I_T_C_H; C_A_S_E_$casecounter: }";
198 $casecounter++;
199 next component;
200 }
201
d38ca171 202 $source =~ m/\G(\s*(-[sm]\s+|\w+|#.*\n|\W))/gc;
3ed9f206 203 $text .= $1;
204 }
205 $text;
206}
207
208
209
210sub in
211{
212 my ($x,$y) = @_;
213 my @numy;
214 for my $nextx ( @$x )
215 {
a1813bef 216 my $numx = ref($nextx) || defined $nextx && (~$nextx&$nextx) eq 0;
3ed9f206 217 for my $j ( 0..$#$y )
218 {
219 my $nexty = $y->[$j];
a1813bef 220 push @numy, ref($nexty) || defined $nexty && (~$nexty&$nexty) eq 0
3ed9f206 221 if @numy <= $j;
222 return 1 if $numx && $numy[$j] && $nextx==$nexty
223 || $nextx eq $nexty;
224
225 }
226 }
227 return "";
228}
229
230sub on_exists
231{
232 my $ref = @_==1 && ref($_[0]) eq 'HASH' ? $_[0] : { @_ };
233 [ keys %$ref ]
234}
235
236sub on_defined
237{
238 my $ref = @_==1 && ref($_[0]) eq 'HASH' ? $_[0] : { @_ };
239 [ grep { defined $ref->{$_} } keys %$ref ]
240}
241
242sub switch(;$)
243{
244 my ($s_val) = @_ ? $_[0] : $_;
245 my $s_ref = ref $s_val;
246
247 if ($s_ref eq 'CODE')
248 {
249 $::_S_W_I_T_C_H =
250 sub { my $c_val = $_[0];
251 return $s_val == $c_val if ref $c_val eq 'CODE';
252 return $s_val->(@$c_val) if ref $c_val eq 'ARRAY';
253 return $s_val->($c_val);
254 };
255 }
a1813bef 256 elsif ($s_ref eq "" && defined $s_val && (~$s_val&$s_val) eq 0) # NUMERIC SCALAR
3ed9f206 257 {
258 $::_S_W_I_T_C_H =
259 sub { my $c_val = $_[0];
260 my $c_ref = ref $c_val;
261 return $s_val == $c_val if $c_ref eq ""
a1813bef 262 && defined $c_val
3ed9f206 263 && (~$c_val&$c_val) eq 0;
264 return $s_val eq $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) if $c_ref eq 'Switch';
268 return scalar $s_val=~/$c_val/
269 if $c_ref eq 'Regexp';
270 return scalar $c_val->{$s_val}
271 if $c_ref eq 'HASH';
272 return;
273 };
274 }
275 elsif ($s_ref eq "") # STRING SCALAR
276 {
277 $::_S_W_I_T_C_H =
278 sub { my $c_val = $_[0];
279 my $c_ref = ref $c_val;
280 return $s_val eq $c_val if $c_ref eq "";
281 return in([$s_val],$c_val) if $c_ref eq 'ARRAY';
282 return $c_val->($s_val) if $c_ref eq 'CODE';
283 return $c_val->call($s_val) if $c_ref eq 'Switch';
284 return scalar $s_val=~/$c_val/
285 if $c_ref eq 'Regexp';
286 return scalar $c_val->{$s_val}
287 if $c_ref eq 'HASH';
288 return;
289 };
290 }
291 elsif ($s_ref eq 'ARRAY')
292 {
293 $::_S_W_I_T_C_H =
294 sub { my $c_val = $_[0];
295 my $c_ref = ref $c_val;
296 return in($s_val,[$c_val]) if $c_ref eq "";
297 return in($s_val,$c_val) if $c_ref eq 'ARRAY';
298 return $c_val->(@$s_val) if $c_ref eq 'CODE';
299 return $c_val->call(@$s_val)
300 if $c_ref eq 'Switch';
301 return scalar grep {$_=~/$c_val/} @$s_val
302 if $c_ref eq 'Regexp';
303 return scalar grep {$c_val->{$_}} @$s_val
304 if $c_ref eq 'HASH';
305 return;
306 };
307 }
308 elsif ($s_ref eq 'Regexp')
309 {
310 $::_S_W_I_T_C_H =
311 sub { my $c_val = $_[0];
312 my $c_ref = ref $c_val;
313 return $c_val=~/s_val/ if $c_ref eq "";
314 return scalar grep {$_=~/s_val/} @$c_val
315 if $c_ref eq 'ARRAY';
316 return $c_val->($s_val) if $c_ref eq 'CODE';
317 return $c_val->call($s_val) if $c_ref eq 'Switch';
318 return $s_val eq $c_val if $c_ref eq 'Regexp';
319 return grep {$_=~/$s_val/ && $c_val->{$_}} keys %$c_val
320 if $c_ref eq 'HASH';
321 return;
322 };
323 }
324 elsif ($s_ref eq 'HASH')
325 {
326 $::_S_W_I_T_C_H =
327 sub { my $c_val = $_[0];
328 my $c_ref = ref $c_val;
329 return $s_val->{$c_val} if $c_ref eq "";
330 return scalar grep {$s_val->{$_}} @$c_val
331 if $c_ref eq 'ARRAY';
332 return $c_val->($s_val) if $c_ref eq 'CODE';
333 return $c_val->call($s_val) if $c_ref eq 'Switch';
334 return grep {$_=~/$c_val/ && $s_val->{"$_"}} keys %$s_val
335 if $c_ref eq 'Regexp';
336 return $s_val==$c_val if $c_ref eq 'HASH';
337 return;
338 };
339 }
340 elsif ($s_ref eq 'Switch')
341 {
342 $::_S_W_I_T_C_H =
343 sub { my $c_val = $_[0];
344 return $s_val == $c_val if ref $c_val eq 'Switch';
345 return $s_val->call(@$c_val)
346 if ref $c_val eq 'ARRAY';
347 return $s_val->call($c_val);
348 };
349 }
350 else
351 {
352 croak "Cannot switch on $s_ref";
353 }
354 return 1;
355}
356
d38ca171 357sub case($) { local $SIG{__WARN__} = \&carp;
358 $::_S_W_I_T_C_H->(@_); }
3ed9f206 359
360# IMPLEMENT __
361
362my $placeholder = bless { arity=>1, impl=>sub{$_[1+$_[0]]} };
363
364sub __() { $placeholder }
365
366sub __arg($)
367{
368 my $index = $_[0]+1;
369 bless { arity=>0, impl=>sub{$_[$index]} };
370}
371
372sub hosub(&@)
373{
374 # WRITE THIS
375}
376
377sub call
378{
379 my ($self,@args) = @_;
380 return $self->{impl}->(0,@args);
381}
382
383sub meta_bop(&)
384{
385 my ($op) = @_;
386 sub
387 {
388 my ($left, $right, $reversed) = @_;
389 ($right,$left) = @_ if $reversed;
390
391 my $rop = ref $right eq 'Switch'
392 ? $right
393 : bless { arity=>0, impl=>sub{$right} };
394
395 my $lop = ref $left eq 'Switch'
396 ? $left
397 : bless { arity=>0, impl=>sub{$left} };
398
399 my $arity = $lop->{arity} + $rop->{arity};
400
401 return bless {
402 arity => $arity,
403 impl => sub { my $start = shift;
404 return $op->($lop->{impl}->($start,@_),
405 $rop->{impl}->($start+$lop->{arity},@_));
406 }
407 };
408 };
409}
410
411sub meta_uop(&)
412{
413 my ($op) = @_;
414 sub
415 {
416 my ($left) = @_;
417
418 my $lop = ref $left eq 'Switch'
419 ? $left
420 : bless { arity=>0, impl=>sub{$left} };
421
422 my $arity = $lop->{arity};
423
424 return bless {
425 arity => $arity,
426 impl => sub { $op->($lop->{impl}->(@_)) }
427 };
428 };
429}
430
431
432use overload
433 "+" => meta_bop {$_[0] + $_[1]},
434 "-" => meta_bop {$_[0] - $_[1]},
435 "*" => meta_bop {$_[0] * $_[1]},
436 "/" => meta_bop {$_[0] / $_[1]},
437 "%" => meta_bop {$_[0] % $_[1]},
438 "**" => meta_bop {$_[0] ** $_[1]},
439 "<<" => meta_bop {$_[0] << $_[1]},
440 ">>" => meta_bop {$_[0] >> $_[1]},
441 "x" => meta_bop {$_[0] x $_[1]},
442 "." => meta_bop {$_[0] . $_[1]},
443 "<" => meta_bop {$_[0] < $_[1]},
444 "<=" => meta_bop {$_[0] <= $_[1]},
445 ">" => meta_bop {$_[0] > $_[1]},
446 ">=" => meta_bop {$_[0] >= $_[1]},
447 "==" => meta_bop {$_[0] == $_[1]},
448 "!=" => meta_bop {$_[0] != $_[1]},
449 "<=>" => meta_bop {$_[0] <=> $_[1]},
450 "lt" => meta_bop {$_[0] lt $_[1]},
451 "le" => meta_bop {$_[0] le $_[1]},
452 "gt" => meta_bop {$_[0] gt $_[1]},
453 "ge" => meta_bop {$_[0] ge $_[1]},
454 "eq" => meta_bop {$_[0] eq $_[1]},
455 "ne" => meta_bop {$_[0] ne $_[1]},
456 "cmp" => meta_bop {$_[0] cmp $_[1]},
457 "\&" => meta_bop {$_[0] & $_[1]},
458 "^" => meta_bop {$_[0] ^ $_[1]},
459 "|" => meta_bop {$_[0] | $_[1]},
460 "atan2" => meta_bop {atan2 $_[0], $_[1]},
461
462 "neg" => meta_uop {-$_[0]},
463 "!" => meta_uop {!$_[0]},
464 "~" => meta_uop {~$_[0]},
465 "cos" => meta_uop {cos $_[0]},
466 "sin" => meta_uop {sin $_[0]},
467 "exp" => meta_uop {exp $_[0]},
468 "abs" => meta_uop {abs $_[0]},
469 "log" => meta_uop {log $_[0]},
470 "sqrt" => meta_uop {sqrt $_[0]},
471 "bool" => sub { croak "Can't use && or || in expression containing __" },
472
473 # "&()" => sub { $_[0]->{impl} },
474
475 # "||" => meta_bop {$_[0] || $_[1]},
476 # "&&" => meta_bop {$_[0] && $_[1]},
477 # fallback => 1,
478 ;
4791;
480
481__END__
482
483
484=head1 NAME
485
486Switch - A switch statement for Perl
487
488=head1 VERSION
489
d38ca171 490This document describes version 2.06 of Switch,
491released November 14, 2001.
3ed9f206 492
493=head1 SYNOPSIS
494
495 use Switch;
496
497 switch ($val) {
498
499 case 1 { print "number 1" }
500 case "a" { print "string a" }
501 case [1..10,42] { print "number in list" }
502 case (@array) { print "number in list" }
503 case /\w+/ { print "pattern" }
504 case qr/\w+/ { print "pattern" }
505 case (%hash) { print "entry in hash" }
506 case (\%hash) { print "entry in hash" }
507 case (\&sub) { print "arg to subroutine" }
508 else { print "previous case not true" }
509 }
510
511=head1 BACKGROUND
512
513[Skip ahead to L<"DESCRIPTION"> if you don't care about the whys
514and wherefores of this control structure]
515
516In seeking to devise a "Swiss Army" case mechanism suitable for Perl,
517it is useful to generalize this notion of distributed conditional
518testing as far as possible. Specifically, the concept of "matching"
519between the switch value and the various case values need not be
520restricted to numeric (or string or referential) equality, as it is in other
521languages. Indeed, as Table 1 illustrates, Perl
522offers at least eighteen different ways in which two values could
523generate a match.
524
525 Table 1: Matching a switch value ($s) with a case value ($c)
526
527 Switch Case Type of Match Implied Matching Code
528 Value Value
529 ====== ===== ===================== =============
530
531 number same numeric or referential match if $s == $c;
532 or ref equality
533
534 object method result of method call match if $s->$c();
535 ref name match if defined $s->$c();
536 or ref
537
538 other other string equality match if $s eq $c;
539 non-ref non-ref
540 scalar scalar
541
542 string regexp pattern match match if $s =~ /$c/;
543
544 array scalar array entry existence match if 0<=$c && $c<@$s;
545 ref array entry definition match if defined $s->[$c];
546 array entry truth match if $s->[$c];
547
548 array array array intersection match if intersects(@$s, @$c);
549 ref ref (apply this table to
550 all pairs of elements
551 $s->[$i] and
552 $c->[$j])
553
554 array regexp array grep match if grep /$c/, @$s;
555 ref
556
557 hash scalar hash entry existence match if exists $s->{$c};
558 ref hash entry definition match if defined $s->{$c};
559 hash entry truth match if $s->{$c};
560
561 hash regexp hash grep match if grep /$c/, keys %$s;
562 ref
563
564 sub scalar return value defn match if defined $s->($c);
565 ref return value truth match if $s->($c);
566
567 sub array return value defn match if defined $s->(@$c);
568 ref ref return value truth match if $s->(@$c);
569
570
571In reality, Table 1 covers 31 alternatives, because only the equality and
572intersection tests are commutative; in all other cases, the roles of
573the C<$s> and C<$c> variables could be reversed to produce a
574different test. For example, instead of testing a single hash for
575the existence of a series of keys (C<match if exists $s-E<gt>{$c}>),
576one could test for the existence of a single key in a series of hashes
577(C<match if exists $c-E<gt>{$s}>).
578
579As L<perltodo> observes, a Perl case mechanism must support all these
580"ways to do it".
581
582
583=head1 DESCRIPTION
584
585The Switch.pm module implements a generalized case mechanism that covers
586the numerous possible combinations of switch and case values described above.
587
588The module augments the standard Perl syntax with two new control
589statements: C<switch> and C<case>. The C<switch> statement takes a
590single scalar argument of any type, specified in parentheses.
591C<switch> stores this value as the
592current switch value in a (localized) control variable.
593The value is followed by a block which may contain one or more
594Perl statements (including the C<case> statement described below).
595The block is unconditionally executed once the switch value has
596been cached.
597
598A C<case> statement takes a single scalar argument (in mandatory
599parentheses if it's a variable; otherwise the parens are optional) and
600selects the appropriate type of matching between that argument and the
601current switch value. The type of matching used is determined by the
602respective types of the switch value and the C<case> argument, as
603specified in Table 1. If the match is successful, the mandatory
604block associated with the C<case> statement is executed.
605
606In most other respects, the C<case> statement is semantically identical
607to an C<if> statement. For example, it can be followed by an C<else>
608clause, and can be used as a postfix statement qualifier.
609
610However, when a C<case> block has been executed control is automatically
611transferred to the statement after the immediately enclosing C<switch>
612block, rather than to the next statement within the block. In other
613words, the success of any C<case> statement prevents other cases in the
614same scope from executing. But see L<"Allowing fall-through"> below.
615
616Together these two new statements provide a fully generalized case
617mechanism:
618
619 use Switch;
620
621 # AND LATER...
622
623 %special = ( woohoo => 1, d'oh => 1 );
624
625 while (<>) {
626 switch ($_) {
627
74a6a946 628 case (%special) { print "homer\n"; } # if $special{$_}
629 case /a-z/i { print "alpha\n"; } # if $_ =~ /a-z/i
630 case [1..9] { print "small num\n"; } # if $_ in [1..9]
3ed9f206 631
632 case { $_[0] >= 10 } { # if $_ >= 10
633 my $age = <>;
634 switch (sub{ $_[0] < $age } ) {
635
636 case 20 { print "teens\n"; } # if 20 < $age
637 case 30 { print "twenties\n"; } # if 30 < $age
638 else { print "history\n"; }
639 }
640 }
641
642 print "must be punctuation\n" case /\W/; # if $_ ~= /\W/
643 }
644
645Note that C<switch>es can be nested within C<case> (or any other) blocks,
646and a series of C<case> statements can try different types of matches
647-- hash membership, pattern match, array intersection, simple equality,
648etc. -- against the same switch value.
649
650The use of intersection tests against an array reference is particularly
651useful for aggregating integral cases:
652
653 sub classify_digit
654 {
655 switch ($_[0]) { case 0 { return 'zero' }
656 case [2,4,6,8] { return 'even' }
657 case [1,3,4,7,9] { return 'odd' }
658 case /[A-F]/i { return 'hex' }
659 }
660 }
661
662
663=head2 Allowing fall-through
664
665Fall-though (trying another case after one has already succeeded)
666is usually a Bad Idea in a switch statement. However, this
667is Perl, not a police state, so there I<is> a way to do it, if you must.
668
669If a C<case> block executes an untargetted C<next>, control is
670immediately transferred to the statement I<after> the C<case> statement
671(i.e. usually another case), rather than out of the surrounding
672C<switch> block.
673
674For example:
675
676 switch ($val) {
677 case 1 { handle_num_1(); next } # and try next case...
678 case "1" { handle_str_1(); next } # and try next case...
679 case [0..9] { handle_num_any(); } # and we're done
680 case /\d/ { handle_dig_any(); next } # and try next case...
681 case /.*/ { handle_str_any(); next } # and try next case...
682 }
683
684If $val held the number C<1>, the above C<switch> block would call the
685first three C<handle_...> subroutines, jumping to the next case test
686each time it encountered a C<next>. After the thrid C<case> block
687was executed, control would jump to the end of the enclosing
688C<switch> block.
689
690On the other hand, if $val held C<10>, then only the last two C<handle_...>
691subroutines would be called.
692
693Note that this mechanism allows the notion of I<conditional fall-through>.
694For example:
695
696 switch ($val) {
697 case [0..9] { handle_num_any(); next if $val < 7; }
698 case /\d/ { handle_dig_any(); }
699 }
700
701If an untargetted C<last> statement is executed in a case block, this
702immediately transfers control out of the enclosing C<switch> block
703(in other words, there is an implicit C<last> at the end of each
704normal C<case> block). Thus the previous example could also have been
705written:
706
707 switch ($val) {
708 case [0..9] { handle_num_any(); last if $val >= 7; next; }
709 case /\d/ { handle_dig_any(); }
710 }
711
712
713=head2 Automating fall-through
714
715In situations where case fall-through should be the norm, rather than an
716exception, an endless succession of terminal C<next>s is tedious and ugly.
717Hence, it is possible to reverse the default behaviour by specifying
718the string "fallthrough" when importing the module. For example, the
719following code is equivalent to the first example in L<"Allowing fall-through">:
720
721 use Switch 'fallthrough';
722
723 switch ($val) {
724 case 1 { handle_num_1(); }
725 case "1" { handle_str_1(); }
726 case [0..9] { handle_num_any(); last }
727 case /\d/ { handle_dig_any(); }
728 case /.*/ { handle_str_any(); }
729 }
730
731Note the explicit use of a C<last> to preserve the non-fall-through
732behaviour of the third case.
733
734
735
74a6a946 736=head2 Alternative syntax
737
738Perl 6 will provide a built-in switch statement with essentially the
739same semantics as those offered by Switch.pm, but with a different
740pair of keywords. In Perl 6 C<switch> with be spelled C<given>, and
741C<case> will be pronounced C<when>. In addition, the C<when> statement
742will use a colon between its case value and its block (removing the
743need to parenthesize variables.
744
745This future syntax is also available via the Switch.pm module, by
746importing it with the argument C<"Perl6">. For example:
747
748 use Switch 'Perl6';
749
750 given ($val) {
751 when 1 : { handle_num_1(); }
752 when $str1 : { handle_str_1(); }
753 when [0..9] : { handle_num_any(); last }
754 when /\d/ : { handle_dig_any(); }
755 when /.*/ : { handle_str_any(); }
756 }
757
758Note that you can mix and match both syntaxes by importing the module
759with:
760
761 use Switch 'Perl5', 'Perl6';
762
763
3ed9f206 764=head2 Higher-order Operations
765
766One situation in which C<switch> and C<case> do not provide a good
767substitute for a cascaded C<if>, is where a switch value needs to
768be tested against a series of conditions. For example:
769
770 sub beverage {
771 switch (shift) {
772
773 case sub { $_[0] < 10 } { return 'milk' }
774 case sub { $_[0] < 20 } { return 'coke' }
775 case sub { $_[0] < 30 } { return 'beer' }
776 case sub { $_[0] < 40 } { return 'wine' }
777 case sub { $_[0] < 50 } { return 'malt' }
778 case sub { $_[0] < 60 } { return 'Moet' }
779 else { return 'milk' }
780 }
781 }
782
783The need to specify each condition as a subroutine block is tiresome. To
784overcome this, when importing Switch.pm, a special "placeholder"
785subroutine named C<__> [sic] may also be imported. This subroutine
786converts (almost) any expression in which it appears to a reference to a
787higher-order function. That is, the expression:
788
789 use Switch '__';
790
791 __ < 2 + __
792
793is equivalent to:
794
795 sub { $_[0] < 2 + $_[1] }
796
797With C<__>, the previous ugly case statements can be rewritten:
798
799 case __ < 10 { return 'milk' }
800 case __ < 20 { return 'coke' }
801 case __ < 30 { return 'beer' }
802 case __ < 40 { return 'wine' }
803 case __ < 50 { return 'malt' }
804 case __ < 60 { return 'Moet' }
805 else { return 'milk' }
806
807The C<__> subroutine makes extensive use of operator overloading to
808perform its magic. All operations involving __ are overloaded to
809produce an anonymous subroutine that implements a lazy version
810of the original operation.
811
812The only problem is that operator overloading does not allow the
813boolean operators C<&&> and C<||> to be overloaded. So a case statement
814like this:
815
816 case 0 <= __ && __ < 10 { return 'digit' }
817
818doesn't act as expected, because when it is
819executed, it constructs two higher order subroutines
820and then treats the two resulting references as arguments to C<&&>:
821
822 sub { 0 <= $_[0] } && sub { $_[0] < 10 }
823
824This boolean expression is inevitably true, since both references are
825non-false. Fortunately, the overloaded C<'bool'> operator catches this
826situation and flags it as a error.
827
828=head1 DEPENDENCIES
829
830The module is implemented using Filter::Util::Call and Text::Balanced
831and requires both these modules to be installed.
832
833=head1 AUTHOR
834
835Damian Conway (damian@conway.org)
836
837=head1 BUGS
838
839There are undoubtedly serious bugs lurking somewhere in code this funky :-)
840Bug reports and other feedback are most welcome.
841
d38ca171 842=head1 LIMITATION
843
844Due to the heuristic nature of Switch.pm's source parsing, the presence
845of regexes specified with raw C<?...?> delimiters may cause mysterious
846errors. The workaround is to use C<m?...?> instead.
847
3ed9f206 848=head1 COPYRIGHT
849
55a1c97c 850 Copyright (c) 1997-2001, Damian Conway. All Rights Reserved.
851 This module is free software. It may be used, redistributed
852 and/or modified under the same terms as Perl itself.