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