This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Fix a number of documentation issues in Switch.pm (code examples
[perl5.git] / lib / Switch.pm
CommitLineData
3ed9f206
JH
1package Switch;
2
3use strict;
4use vars qw($VERSION);
5use Carp;
6
4ca17203 7$VERSION = '2.10_01';
3ed9f206
JH
8
9
10# LOAD FILTERING MODULE...
11use Filter::Util::Call;
12
13sub __();
14
15# CATCH ATTEMPTS TO CALL case OUTSIDE THE SCOPE OF ANY switch
16
74a6a946 17$::_S_W_I_T_C_H = sub { croak "case/when statement not in switch/given block" };
3ed9f206
JH
18
19my $offset;
20my $fallthrough;
74a6a946 21my ($Perl5, $Perl6) = (0,0);
3ed9f206
JH
22
23sub import
24{
25 $fallthrough = grep /\bfallthrough\b/, @_;
26 $offset = (caller)[2]+1;
a1813bef 27 filter_add({}) unless @_>1 && $_[1] eq 'noimport';
3ed9f206
JH
28 my $pkg = caller;
29 no strict 'refs';
30 for ( qw( on_defined on_exists ) )
31 {
32 *{"${pkg}::$_"} = \&$_;
33 }
34 *{"${pkg}::__"} = \&__ if grep /__/, @_;
74a6a946
JH
35 $Perl6 = 1 if grep(/Perl\s*6/i, @_);
36 $Perl5 = 1 if grep(/Perl\s*5/i, @_) || !grep(/Perl\s*6/i, @_);
3ed9f206
JH
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
JH
52 return $status if $status<0;
53 $_ = filter_blocks($_,$offset);
54 $_ = "# line $offset\n" . $_ if $offset; undef $offset;
3ed9f206
JH
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
JH
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
JH
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
JH
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
JH
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
JH
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
JH
101 if (defined $pos[0])
102 {
b2486830
RGS
103 my $pre = substr($source,$pos[0],$pos[1]); # matched prefix
104 $text .= $pre . substr($source,$pos[2],$pos[18]-$pos[2]);
3ed9f206
JH
105 next component;
106 }
d38ca171
JH
107 if ($source =~ m/\G\s*($pod_or_DATA)/gc) {
108 next component;
109 }
3ed9f206
JH
110 @pos = Text::Balanced::_match_variable(\$source,qr/\s*/);
111 if (defined $pos[0])
112 {
52d8c818
RK
113 $text .= " " if $pos[0] < $pos[2];
114 $text .= substr($source,$pos[0],$pos[4]-$pos[0]);
3ed9f206
JH
115 next component;
116 }
117
74a6a946 118 if ($Perl5 && $source =~ m/\G(\n*)(\s*)(switch)\b(?=\s*[(])/gc
6596d39b
JH
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
JH
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
JH
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
JH
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
RGS
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
RGS
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
RK
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
JH
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
RK
169 $text .= " " if $pos[0] < $pos[2];
170 $text .= "$code)";
3ed9f206 171 }
74a6a946
JH
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
RK
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
JH
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
RK
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
JH
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
JH
196 }
197
6596d39b
JH
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
JH
200
201 do{@pos = Text::Balanced::_match_codeblock(\$source,qr/\s*/,qr/\{/,qr/\}/,qr/\{/,qr/\}/,undef)}
3ed9f206
JH
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
JH
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
JH
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
JH
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
JH
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
JH
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
JH
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
JH
372sub case($) { local $SIG{__WARN__} = \&carp;
373 $::_S_W_I_T_C_H->(@_); }
3ed9f206
JH
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
b2486830
RGS
505This document describes version 2.10 of Switch,
506released Dec 29, 2003.
3ed9f206
JH
507
508=head1 SYNOPSIS
509
510 use Switch;
511
512 switch ($val) {
513
514 case 1 { print "number 1" }
515 case "a" { print "string a" }
516 case [1..10,42] { print "number in list" }
517 case (@array) { print "number in list" }
518 case /\w+/ { print "pattern" }
519 case qr/\w+/ { print "pattern" }
520 case (%hash) { print "entry in hash" }
521 case (\%hash) { print "entry in hash" }
522 case (\&sub) { print "arg to subroutine" }
523 else { print "previous case not true" }
524 }
525
526=head1 BACKGROUND
527
528[Skip ahead to L<"DESCRIPTION"> if you don't care about the whys
529and wherefores of this control structure]
530
531In seeking to devise a "Swiss Army" case mechanism suitable for Perl,
532it is useful to generalize this notion of distributed conditional
533testing as far as possible. Specifically, the concept of "matching"
534between the switch value and the various case values need not be
535restricted to numeric (or string or referential) equality, as it is in other
536languages. Indeed, as Table 1 illustrates, Perl
537offers at least eighteen different ways in which two values could
538generate a match.
539
540 Table 1: Matching a switch value ($s) with a case value ($c)
541
542 Switch Case Type of Match Implied Matching Code
543 Value Value
544 ====== ===== ===================== =============
545
546 number same numeric or referential match if $s == $c;
547 or ref equality
548
549 object method result of method call match if $s->$c();
550 ref name match if defined $s->$c();
551 or ref
552
553 other other string equality match if $s eq $c;
554 non-ref non-ref
555 scalar scalar
556
557 string regexp pattern match match if $s =~ /$c/;
558
559 array scalar array entry existence match if 0<=$c && $c<@$s;
560 ref array entry definition match if defined $s->[$c];
561 array entry truth match if $s->[$c];
562
563 array array array intersection match if intersects(@$s, @$c);
564 ref ref (apply this table to
565 all pairs of elements
566 $s->[$i] and
567 $c->[$j])
568
569 array regexp array grep match if grep /$c/, @$s;
570 ref
571
572 hash scalar hash entry existence match if exists $s->{$c};
573 ref hash entry definition match if defined $s->{$c};
574 hash entry truth match if $s->{$c};
575
576 hash regexp hash grep match if grep /$c/, keys %$s;
577 ref
578
579 sub scalar return value defn match if defined $s->($c);
580 ref return value truth match if $s->($c);
581
582 sub array return value defn match if defined $s->(@$c);
583 ref ref return value truth match if $s->(@$c);
584
585
586In reality, Table 1 covers 31 alternatives, because only the equality and
587intersection tests are commutative; in all other cases, the roles of
588the C<$s> and C<$c> variables could be reversed to produce a
589different test. For example, instead of testing a single hash for
590the existence of a series of keys (C<match if exists $s-E<gt>{$c}>),
591one could test for the existence of a single key in a series of hashes
592(C<match if exists $c-E<gt>{$s}>).
593
594As L<perltodo> observes, a Perl case mechanism must support all these
595"ways to do it".
596
597
598=head1 DESCRIPTION
599
600The Switch.pm module implements a generalized case mechanism that covers
601the numerous possible combinations of switch and case values described above.
602
603The module augments the standard Perl syntax with two new control
604statements: C<switch> and C<case>. The C<switch> statement takes a
605single scalar argument of any type, specified in parentheses.
606C<switch> stores this value as the
607current switch value in a (localized) control variable.
608The value is followed by a block which may contain one or more
609Perl statements (including the C<case> statement described below).
610The block is unconditionally executed once the switch value has
611been cached.
612
613A C<case> statement takes a single scalar argument (in mandatory
614parentheses if it's a variable; otherwise the parens are optional) and
615selects the appropriate type of matching between that argument and the
616current switch value. The type of matching used is determined by the
617respective types of the switch value and the C<case> argument, as
618specified in Table 1. If the match is successful, the mandatory
619block associated with the C<case> statement is executed.
620
621In most other respects, the C<case> statement is semantically identical
622to an C<if> statement. For example, it can be followed by an C<else>
623clause, and can be used as a postfix statement qualifier.
624
625However, when a C<case> block has been executed control is automatically
626transferred to the statement after the immediately enclosing C<switch>
627block, rather than to the next statement within the block. In other
628words, the success of any C<case> statement prevents other cases in the
629same scope from executing. But see L<"Allowing fall-through"> below.
630
631Together these two new statements provide a fully generalized case
632mechanism:
633
634 use Switch;
635
636 # AND LATER...
637
638 %special = ( woohoo => 1, d'oh => 1 );
639
640 while (<>) {
6bd77ab2 641 chomp;
3ed9f206 642 switch ($_) {
74a6a946 643 case (%special) { print "homer\n"; } # if $special{$_}
6bd77ab2 644 case /[a-z]/i { print "alpha\n"; } # if $_ =~ /a-z/i
74a6a946 645 case [1..9] { print "small num\n"; } # if $_ in [1..9]
6bd77ab2 646 case { $_[0] >= 10 } { print "big num\n"; } # if $_ >= 10
3ed9f206 647 print "must be punctuation\n" case /\W/; # if $_ ~= /\W/
6bd77ab2 648 }
3ed9f206
JH
649 }
650
651Note that C<switch>es can be nested within C<case> (or any other) blocks,
652and a series of C<case> statements can try different types of matches
653-- hash membership, pattern match, array intersection, simple equality,
654etc. -- against the same switch value.
655
656The use of intersection tests against an array reference is particularly
657useful for aggregating integral cases:
658
659 sub classify_digit
660 {
661 switch ($_[0]) { case 0 { return 'zero' }
662 case [2,4,6,8] { return 'even' }
6bd77ab2 663 case [1,3,5,7,9] { return 'odd' }
3ed9f206
JH
664 case /[A-F]/i { return 'hex' }
665 }
666 }
667
668
669=head2 Allowing fall-through
670
671Fall-though (trying another case after one has already succeeded)
672is usually a Bad Idea in a switch statement. However, this
673is Perl, not a police state, so there I<is> a way to do it, if you must.
674
3c4b39be 675If a C<case> block executes an untargeted C<next>, control is
3ed9f206
JH
676immediately transferred to the statement I<after> the C<case> statement
677(i.e. usually another case), rather than out of the surrounding
678C<switch> block.
679
680For example:
681
682 switch ($val) {
683 case 1 { handle_num_1(); next } # and try next case...
684 case "1" { handle_str_1(); next } # and try next case...
685 case [0..9] { handle_num_any(); } # and we're done
686 case /\d/ { handle_dig_any(); next } # and try next case...
687 case /.*/ { handle_str_any(); next } # and try next case...
688 }
689
690If $val held the number C<1>, the above C<switch> block would call the
691first three C<handle_...> subroutines, jumping to the next case test
6bd77ab2 692each time it encountered a C<next>. After the third C<case> block
3ed9f206
JH
693was executed, control would jump to the end of the enclosing
694C<switch> block.
695
696On the other hand, if $val held C<10>, then only the last two C<handle_...>
697subroutines would be called.
698
699Note that this mechanism allows the notion of I<conditional fall-through>.
700For example:
701
702 switch ($val) {
703 case [0..9] { handle_num_any(); next if $val < 7; }
704 case /\d/ { handle_dig_any(); }
705 }
706
3c4b39be 707If an untargeted C<last> statement is executed in a case block, this
3ed9f206
JH
708immediately transfers control out of the enclosing C<switch> block
709(in other words, there is an implicit C<last> at the end of each
710normal C<case> block). Thus the previous example could also have been
711written:
712
713 switch ($val) {
714 case [0..9] { handle_num_any(); last if $val >= 7; next; }
715 case /\d/ { handle_dig_any(); }
716 }
717
718
719=head2 Automating fall-through
720
721In situations where case fall-through should be the norm, rather than an
722exception, an endless succession of terminal C<next>s is tedious and ugly.
723Hence, it is possible to reverse the default behaviour by specifying
724the string "fallthrough" when importing the module. For example, the
725following code is equivalent to the first example in L<"Allowing fall-through">:
726
727 use Switch 'fallthrough';
728
729 switch ($val) {
730 case 1 { handle_num_1(); }
731 case "1" { handle_str_1(); }
732 case [0..9] { handle_num_any(); last }
733 case /\d/ { handle_dig_any(); }
734 case /.*/ { handle_str_any(); }
735 }
736
737Note the explicit use of a C<last> to preserve the non-fall-through
738behaviour of the third case.
739
740
741
74a6a946
JH
742=head2 Alternative syntax
743
744Perl 6 will provide a built-in switch statement with essentially the
745same semantics as those offered by Switch.pm, but with a different
693b9afd 746pair of keywords. In Perl 6 C<switch> will be spelled C<given>, and
74a6a946 747C<case> will be pronounced C<when>. In addition, the C<when> statement
6596d39b 748will not require switch or case values to be parenthesized.
74a6a946 749
6596d39b 750This future syntax is also (largely) available via the Switch.pm module, by
74a6a946
JH
751importing it with the argument C<"Perl6">. For example:
752
753 use Switch 'Perl6';
754
755 given ($val) {
6596d39b
JH
756 when 1 { handle_num_1(); }
757 when ($str1) { handle_str_1(); }
758 when [0..9] { handle_num_any(); last }
759 when /\d/ { handle_dig_any(); }
760 when /.*/ { handle_str_any(); }
b2486830 761 default { handle anything else; }
74a6a946
JH
762 }
763
6596d39b
JH
764Note that scalars still need to be parenthesized, since they would be
765ambiguous in Perl 5.
766
767Note too that you can mix and match both syntaxes by importing the module
74a6a946
JH
768with:
769
770 use Switch 'Perl5', 'Perl6';
771
772
3ed9f206
JH
773=head2 Higher-order Operations
774
775One situation in which C<switch> and C<case> do not provide a good
776substitute for a cascaded C<if>, is where a switch value needs to
777be tested against a series of conditions. For example:
778
779 sub beverage {
780 switch (shift) {
6bd77ab2
RGS
781 case { $_[0] < 10 } { return 'milk' }
782 case { $_[0] < 20 } { return 'coke' }
783 case { $_[0] < 30 } { return 'beer' }
784 case { $_[0] < 40 } { return 'wine' }
785 case { $_[0] < 50 } { return 'malt' }
786 case { $_[0] < 60 } { return 'Moet' }
787 else { return 'milk' }
3ed9f206
JH
788 }
789 }
790
6bd77ab2
RGS
791(This is equivalent to writing C<case (sub { $_[0] < 10 })>, etc.; C<$_[0]>
792is the argument to the anonymous subroutine.)
793
3ed9f206
JH
794The need to specify each condition as a subroutine block is tiresome. To
795overcome this, when importing Switch.pm, a special "placeholder"
796subroutine named C<__> [sic] may also be imported. This subroutine
797converts (almost) any expression in which it appears to a reference to a
798higher-order function. That is, the expression:
799
800 use Switch '__';
801
6bd77ab2 802 __ < 2
3ed9f206
JH
803
804is equivalent to:
805
6bd77ab2 806 sub { $_[0] < 2 }
3ed9f206
JH
807
808With C<__>, the previous ugly case statements can be rewritten:
809
810 case __ < 10 { return 'milk' }
811 case __ < 20 { return 'coke' }
812 case __ < 30 { return 'beer' }
813 case __ < 40 { return 'wine' }
814 case __ < 50 { return 'malt' }
815 case __ < 60 { return 'Moet' }
816 else { return 'milk' }
817
818The C<__> subroutine makes extensive use of operator overloading to
819perform its magic. All operations involving __ are overloaded to
820produce an anonymous subroutine that implements a lazy version
821of the original operation.
822
823The only problem is that operator overloading does not allow the
824boolean operators C<&&> and C<||> to be overloaded. So a case statement
825like this:
826
827 case 0 <= __ && __ < 10 { return 'digit' }
828
829doesn't act as expected, because when it is
830executed, it constructs two higher order subroutines
831and then treats the two resulting references as arguments to C<&&>:
832
833 sub { 0 <= $_[0] } && sub { $_[0] < 10 }
834
835This boolean expression is inevitably true, since both references are
836non-false. Fortunately, the overloaded C<'bool'> operator catches this
837situation and flags it as a error.
838
839=head1 DEPENDENCIES
840
841The module is implemented using Filter::Util::Call and Text::Balanced
842and requires both these modules to be installed.
843
844=head1 AUTHOR
845
e9a641f9
RGS
846Damian Conway (damian@conway.org). The maintainer of this module is now Rafael
847Garcia-Suarez (rgarciasuarez@free.fr).
3ed9f206
JH
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
b2486830 854=head1 LIMITATIONS
d38ca171
JH
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
b2486830
RGS
860Due to the way source filters work in Perl, you can't use Switch inside
861an string C<eval>.
862
863If your source file is longer then 1 million characters and you have a
864switch statement that crosses the 1 million (or 2 million, etc.)
865character boundary you will get mysterious errors. The workaround is to
866use smaller source files.
867
3ed9f206
JH
868=head1 COPYRIGHT
869
6bd77ab2 870 Copyright (c) 1997-2006, Damian Conway. All Rights Reserved.
55a1c97c
JH
871 This module is free software. It may be used, redistributed
872 and/or modified under the same terms as Perl itself.