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