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