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