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