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