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