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