| [ Index ] |
PHP Cross Reference of Unnamed Project |
[Summary view] [Print] [Text view]
1 package Switch; 2 3 use strict; 4 use vars qw($VERSION); 5 use Carp; 6 7 $VERSION = '2.13'; 8 9 10 # LOAD FILTERING MODULE... 11 use Filter::Util::Call; 12 13 sub __(); 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 19 my $offset; 20 my $fallthrough; 21 my ($Perl5, $Perl6) = (0,0); 22 23 sub 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 40 sub unimport 41 { 42 filter_del() 43 } 44 45 sub 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 58 use Text::Balanced ':ALL'; 59 60 sub line 61 { 62 my ($pretext,$offset) = @_; 63 ($pretext=~tr/\n/\n/)+($offset||0); 64 } 65 66 sub 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 76 my $EOP = qr/\n|\Z/; 77 my $CUT = qr/\n=cut.*$EOP/; 78 my $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 85 my $casecounter = 1; 86 sub 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 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 } 116 next component; 117 } 118 if ($source =~ m/\G\s*($pod_or_DATA)/gc) { 119 next component; 120 } 121 @pos = Text::Balanced::_match_variable(\$source,qr/\s*/); 122 if (defined $pos[0]) 123 { 124 $text .= " " if $pos[0] < $pos[2]; 125 $text .= substr($source,$pos[0],$pos[4]-$pos[0]); 126 next component; 127 } 128 129 if ($Perl5 && $source =~ m/\G(\n*)(\s*)(switch)\b(?=\s*[(])/gc 130 || $Perl6 && $source =~ m/\G(\n*)(\s*)(given)\b(?=\s*[(])/gc 131 || $Perl6 && $source =~ m/\G(\n*)(\s*)(given)\b(.*)(?=\{)/gc) 132 { 133 my $keyword = $3; 134 my $arg = $4; 135 $text .= $1.$2.'S_W_I_T_C_H: while (1) '; 136 unless ($arg) { 137 @pos = Text::Balanced::_match_codeblock(\$source,qr/\s*/,qr/\(/,qr/\)/,qr/[[{(<]/,qr/[]})>]/,undef) 138 or do { 139 die "Bad $keyword statement (problem in the parentheses?) near $Switch::file line ", line(substr($source,0,pos $source),$line), "\n"; 140 }; 141 $arg = filter_blocks(substr($source,$pos[0],$pos[4]-$pos[0]),line(substr($source,0,$pos[0]),$line)); 142 } 143 $arg =~ s {^\s*[(]\s*%} { ( \\\%} || 144 $arg =~ s {^\s*[(]\s*m\b} { ( qr} || 145 $arg =~ s {^\s*[(]\s*/} { ( qr/} || 146 $arg =~ s {^\s*[(]\s*qw} { ( \\qw}; 147 @pos = Text::Balanced::_match_codeblock(\$source,qr/\s*/,qr/\{/,qr/\}/,qr/\{/,qr/\}/,undef) 148 or do { 149 die "Bad $keyword statement (problem in the code block?) near $Switch::file line ", line(substr($source,0, pos $source), $line), "\n"; 150 }; 151 my $code = filter_blocks(substr($source,$pos[0],$pos[4]-$pos[0]),line(substr($source,0,$pos[0]),$line)); 152 $code =~ s/{/{ local \$::_S_W_I_T_C_H; Switch::switch $arg;/; 153 $text .= $code . 'continue {last}'; 154 next component; 155 } 156 elsif ($Perl5 && $source =~ m/\G(\s*)(case\b)(?!\s*=>)/gc 157 || $Perl6 && $source =~ m/\G(\s*)(when\b)(?!\s*=>)/gc 158 || $Perl6 && $source =~ m/\G(\s*)(default\b)(?=\s*\{)/gc) 159 { 160 my $keyword = $2; 161 $text .= $1 . ($keyword eq "default" 162 ? "if (1)" 163 : "if (Switch::case"); 164 165 if ($keyword eq "default") { 166 # Nothing to do 167 } 168 elsif (@pos = Text::Balanced::_match_codeblock(\$source,qr/\s*/,qr/\{/,qr/\}/,qr/\{/,qr/\}/,undef)) { 169 my $code = substr($source,$pos[0],$pos[4]-$pos[0]); 170 $text .= " " if $pos[0] < $pos[2]; 171 $text .= "sub " if is_block $code; 172 $text .= filter_blocks($code,line(substr($source,0,$pos[0]),$line)) . ")"; 173 } 174 elsif (@pos = Text::Balanced::_match_codeblock(\$source,qr/\s*/,qr/[[(]/,qr/[])]/,qr/[[({]/,qr/[])}]/,undef)) { 175 my $code = filter_blocks(substr($source,$pos[0],$pos[4]-$pos[0]),line(substr($source,0,$pos[0]),$line)); 176 $code =~ s {^\s*[(]\s*%} { ( \\\%} || 177 $code =~ s {^\s*[(]\s*m\b} { ( qr} || 178 $code =~ s {^\s*[(]\s*/} { ( qr/} || 179 $code =~ s {^\s*[(]\s*qw} { ( \\qw}; 180 $text .= " " if $pos[0] < $pos[2]; 181 $text .= "$code)"; 182 } 183 elsif ($Perl6 && do{@pos = Text::Balanced::_match_variable(\$source,qr/\s*/)}) { 184 my $code = filter_blocks(substr($source,$pos[0],$pos[4]-$pos[0]),line(substr($source,0,$pos[0]),$line)); 185 $code =~ s {^\s*%} { \%} || 186 $code =~ s {^\s*@} { \@}; 187 $text .= " " if $pos[0] < $pos[2]; 188 $text .= "$code)"; 189 } 190 elsif ( @pos = Text::Balanced::_match_quotelike(\$source,qr/\s*/,1,0)) { 191 my $code = substr($source,$pos[2],$pos[18]-$pos[2]); 192 $code = filter_blocks($code,line(substr($source,0,$pos[2]),$line)); 193 $code =~ s {^\s*m} { qr} || 194 $code =~ s {^\s*/} { qr/} || 195 $code =~ s {^\s*qw} { \\qw}; 196 $text .= " " if $pos[0] < $pos[2]; 197 $text .= "$code)"; 198 } 199 elsif ($Perl5 && $source =~ m/\G\s*(([^\$\@{])[^\$\@{]*)(?=\s*{)/gc 200 || $Perl6 && $source =~ m/\G\s*([^;{]*)()/gc) { 201 my $code = filter_blocks($1,line(substr($source,0,pos $source),$line)); 202 $text .= ' \\' if $2 eq '%'; 203 $text .= " $code)"; 204 } 205 else { 206 die "Bad $keyword statement (invalid $keyword value?) near $Switch::file line ", line(substr($source,0,pos $source), $line), "\n"; 207 } 208 209 die "Missing opening brace or semi-colon after 'when' value near $Switch::file line ", line(substr($source,0,pos $source), $line), "\n" 210 unless !$Perl6 || $source =~ m/\G(\s*)(?=;|\{)/gc; 211 212 do{@pos = Text::Balanced::_match_codeblock(\$source,qr/\s*/,qr/\{/,qr/\}/,qr/\{/,qr/\}/,undef)} 213 or do { 214 if ($source =~ m/\G\s*(?=([};]|\Z))/gc) { 215 $casecounter++; 216 next component; 217 } 218 die "Bad $keyword statement (problem in the code block?) near $Switch::file line ", line(substr($source,0,pos $source),$line), "\n"; 219 }; 220 my $code = filter_blocks(substr($source,$pos[0],$pos[4]-$pos[0]),line(substr($source,0,$pos[0]),$line)); 221 $code =~ s/}(?=\s*\Z)/;last S_W_I_T_C_H }/ 222 unless $fallthrough; 223 $text .= "{ while (1) $code continue { goto C_A_S_E_$casecounter } last S_W_I_T_C_H; C_A_S_E_$casecounter: }"; 224 $casecounter++; 225 next component; 226 } 227 228 $source =~ m/\G(\s*(-[sm]\s+|\w+|#.*\n|\W))/gc; 229 $text .= $1; 230 } 231 $text; 232 } 233 234 235 236 sub in 237 { 238 my ($x,$y) = @_; 239 my @numy; 240 for my $nextx ( @$x ) 241 { 242 my $numx = ref($nextx) || defined $nextx && (~$nextx&$nextx) eq 0; 243 for my $j ( 0..$#$y ) 244 { 245 my $nexty = $y->[$j]; 246 push @numy, ref($nexty) || defined $nexty && (~$nexty&$nexty) eq 0 247 if @numy <= $j; 248 return 1 if $numx && $numy[$j] && $nextx==$nexty 249 || $nextx eq $nexty; 250 251 } 252 } 253 return ""; 254 } 255 256 sub on_exists 257 { 258 my $ref = @_==1 && ref($_[0]) eq 'HASH' ? $_[0] : { @_ }; 259 [ keys %$ref ] 260 } 261 262 sub on_defined 263 { 264 my $ref = @_==1 && ref($_[0]) eq 'HASH' ? $_[0] : { @_ }; 265 [ grep { defined $ref->{$_} } keys %$ref ] 266 } 267 268 sub switch(;$) 269 { 270 my ($s_val) = @_ ? $_[0] : $_; 271 my $s_ref = ref $s_val; 272 273 if ($s_ref eq 'CODE') 274 { 275 $::_S_W_I_T_C_H = 276 sub { my $c_val = $_[0]; 277 return $s_val == $c_val if ref $c_val eq 'CODE'; 278 return $s_val->(@$c_val) if ref $c_val eq 'ARRAY'; 279 return $s_val->($c_val); 280 }; 281 } 282 elsif ($s_ref eq "" && defined $s_val && (~$s_val&$s_val) eq 0) # NUMERIC SCALAR 283 { 284 $::_S_W_I_T_C_H = 285 sub { my $c_val = $_[0]; 286 my $c_ref = ref $c_val; 287 return $s_val == $c_val if $c_ref eq "" 288 && defined $c_val 289 && (~$c_val&$c_val) eq 0; 290 return $s_val eq $c_val if $c_ref eq ""; 291 return in([$s_val],$c_val) if $c_ref eq 'ARRAY'; 292 return $c_val->($s_val) if $c_ref eq 'CODE'; 293 return $c_val->call($s_val) if $c_ref eq 'Switch'; 294 return scalar $s_val=~/$c_val/ 295 if $c_ref eq 'Regexp'; 296 return scalar $c_val->{$s_val} 297 if $c_ref eq 'HASH'; 298 return; 299 }; 300 } 301 elsif ($s_ref eq "") # STRING SCALAR 302 { 303 $::_S_W_I_T_C_H = 304 sub { my $c_val = $_[0]; 305 my $c_ref = ref $c_val; 306 return $s_val eq $c_val if $c_ref eq ""; 307 return in([$s_val],$c_val) if $c_ref eq 'ARRAY'; 308 return $c_val->($s_val) if $c_ref eq 'CODE'; 309 return $c_val->call($s_val) if $c_ref eq 'Switch'; 310 return scalar $s_val=~/$c_val/ 311 if $c_ref eq 'Regexp'; 312 return scalar $c_val->{$s_val} 313 if $c_ref eq 'HASH'; 314 return; 315 }; 316 } 317 elsif ($s_ref eq 'ARRAY') 318 { 319 $::_S_W_I_T_C_H = 320 sub { my $c_val = $_[0]; 321 my $c_ref = ref $c_val; 322 return in($s_val,[$c_val]) if $c_ref eq ""; 323 return in($s_val,$c_val) if $c_ref eq 'ARRAY'; 324 return $c_val->(@$s_val) if $c_ref eq 'CODE'; 325 return $c_val->call(@$s_val) 326 if $c_ref eq 'Switch'; 327 return scalar grep {$_=~/$c_val/} @$s_val 328 if $c_ref eq 'Regexp'; 329 return scalar grep {$c_val->{$_}} @$s_val 330 if $c_ref eq 'HASH'; 331 return; 332 }; 333 } 334 elsif ($s_ref eq 'Regexp') 335 { 336 $::_S_W_I_T_C_H = 337 sub { my $c_val = $_[0]; 338 my $c_ref = ref $c_val; 339 return $c_val=~/s_val/ if $c_ref eq ""; 340 return scalar grep {$_=~/s_val/} @$c_val 341 if $c_ref eq 'ARRAY'; 342 return $c_val->($s_val) if $c_ref eq 'CODE'; 343 return $c_val->call($s_val) if $c_ref eq 'Switch'; 344 return $s_val eq $c_val if $c_ref eq 'Regexp'; 345 return grep {$_=~/$s_val/ && $c_val->{$_}} keys %$c_val 346 if $c_ref eq 'HASH'; 347 return; 348 }; 349 } 350 elsif ($s_ref eq 'HASH') 351 { 352 $::_S_W_I_T_C_H = 353 sub { my $c_val = $_[0]; 354 my $c_ref = ref $c_val; 355 return $s_val->{$c_val} if $c_ref eq ""; 356 return scalar grep {$s_val->{$_}} @$c_val 357 if $c_ref eq 'ARRAY'; 358 return $c_val->($s_val) if $c_ref eq 'CODE'; 359 return $c_val->call($s_val) if $c_ref eq 'Switch'; 360 return grep {$_=~/$c_val/ && $s_val->{"$_"}} keys %$s_val 361 if $c_ref eq 'Regexp'; 362 return $s_val==$c_val if $c_ref eq 'HASH'; 363 return; 364 }; 365 } 366 elsif ($s_ref eq 'Switch') 367 { 368 $::_S_W_I_T_C_H = 369 sub { my $c_val = $_[0]; 370 return $s_val == $c_val if ref $c_val eq 'Switch'; 371 return $s_val->call(@$c_val) 372 if ref $c_val eq 'ARRAY'; 373 return $s_val->call($c_val); 374 }; 375 } 376 else 377 { 378 croak "Cannot switch on $s_ref"; 379 } 380 return 1; 381 } 382 383 sub case($) { local $SIG{__WARN__} = \&carp; 384 $::_S_W_I_T_C_H->(@_); } 385 386 # IMPLEMENT __ 387 388 my $placeholder = bless { arity=>1, impl=>sub{$_[1+$_[0]]} }; 389 390 sub __() { $placeholder } 391 392 sub __arg($) 393 { 394 my $index = $_[0]+1; 395 bless { arity=>0, impl=>sub{$_[$index]} }; 396 } 397 398 sub hosub(&@) 399 { 400 # WRITE THIS 401 } 402 403 sub call 404 { 405 my ($self,@args) = @_; 406 return $self->{impl}->(0,@args); 407 } 408 409 sub meta_bop(&) 410 { 411 my ($op) = @_; 412 sub 413 { 414 my ($left, $right, $reversed) = @_; 415 ($right,$left) = @_ if $reversed; 416 417 my $rop = ref $right eq 'Switch' 418 ? $right 419 : bless { arity=>0, impl=>sub{$right} }; 420 421 my $lop = ref $left eq 'Switch' 422 ? $left 423 : bless { arity=>0, impl=>sub{$left} }; 424 425 my $arity = $lop->{arity} + $rop->{arity}; 426 427 return bless { 428 arity => $arity, 429 impl => sub { my $start = shift; 430 return $op->($lop->{impl}->($start,@_), 431 $rop->{impl}->($start+$lop->{arity},@_)); 432 } 433 }; 434 }; 435 } 436 437 sub meta_uop(&) 438 { 439 my ($op) = @_; 440 sub 441 { 442 my ($left) = @_; 443 444 my $lop = ref $left eq 'Switch' 445 ? $left 446 : bless { arity=>0, impl=>sub{$left} }; 447 448 my $arity = $lop->{arity}; 449 450 return bless { 451 arity => $arity, 452 impl => sub { $op->($lop->{impl}->(@_)) } 453 }; 454 }; 455 } 456 457 458 use overload 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 "<<" => meta_bop {$_[0] << $_[1]}, 466 ">>" => meta_bop {$_[0] >> $_[1]}, 467 "x" => meta_bop {$_[0] x $_[1]}, 468 "." => meta_bop {$_[0] . $_[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 "lt" => meta_bop {$_[0] lt $_[1]}, 477 "le" => meta_bop {$_[0] le $_[1]}, 478 "gt" => meta_bop {$_[0] gt $_[1]}, 479 "ge" => meta_bop {$_[0] ge $_[1]}, 480 "eq" => meta_bop {$_[0] eq $_[1]}, 481 "ne" => meta_bop {$_[0] ne $_[1]}, 482 "cmp" => meta_bop {$_[0] cmp $_[1]}, 483 "\&" => meta_bop {$_[0] & $_[1]}, 484 "^" => meta_bop {$_[0] ^ $_[1]}, 485 "|" => meta_bop {$_[0] | $_[1]}, 486 "atan2" => meta_bop {atan2 $_[0], $_[1]}, 487 488 "neg" => meta_uop {-$_[0]}, 489 "!" => meta_uop {!$_[0]}, 490 "~" => meta_uop {~$_[0]}, 491 "cos" => meta_uop {cos $_[0]}, 492 "sin" => meta_uop {sin $_[0]}, 493 "exp" => meta_uop {exp $_[0]}, 494 "abs" => meta_uop {abs $_[0]}, 495 "log" => meta_uop {log $_[0]}, 496 "sqrt" => meta_uop {sqrt $_[0]}, 497 "bool" => sub { croak "Can't use && or || in expression containing __" }, 498 499 # "&()" => sub { $_[0]->{impl} }, 500 501 # "||" => meta_bop {$_[0] || $_[1]}, 502 # "&&" => meta_bop {$_[0] && $_[1]}, 503 # fallback => 1, 504 ; 505 1; 506 507 __END__ 508 509 510 =head1 NAME 511 512 Switch - A switch statement for Perl 513 514 =head1 VERSION 515 516 This document describes version 2.11 of Switch, 517 released Nov 22, 2006. 518 519 =head1 SYNOPSIS 520 521 use Switch; 522 523 switch ($val) { 524 case 1 { print "number 1" } 525 case "a" { print "string a" } 526 case [1..10,42] { print "number in list" } 527 case (@array) { print "number in list" } 528 case /\w+/ { print "pattern" } 529 case qr/\w+/ { print "pattern" } 530 case (%hash) { print "entry in hash" } 531 case (\%hash) { print "entry in hash" } 532 case (\&sub) { print "arg to subroutine" } 533 else { print "previous case not true" } 534 } 535 536 =head1 BACKGROUND 537 538 [Skip ahead to L<"DESCRIPTION"> if you don't care about the whys 539 and wherefores of this control structure] 540 541 In seeking to devise a "Swiss Army" case mechanism suitable for Perl, 542 it is useful to generalize this notion of distributed conditional 543 testing as far as possible. Specifically, the concept of "matching" 544 between the switch value and the various case values need not be 545 restricted to numeric (or string or referential) equality, as it is in other 546 languages. Indeed, as Table 1 illustrates, Perl 547 offers at least eighteen different ways in which two values could 548 generate 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 596 In reality, Table 1 covers 31 alternatives, because only the equality and 597 intersection tests are commutative; in all other cases, the roles of 598 the C<$s> and C<$c> variables could be reversed to produce a 599 different test. For example, instead of testing a single hash for 600 the existence of a series of keys (C<match if exists $s-E<gt>{$c}>), 601 one could test for the existence of a single key in a series of hashes 602 (C<match if exists $c-E<gt>{$s}>). 603 604 =head1 DESCRIPTION 605 606 The Switch.pm module implements a generalized case mechanism that covers 607 most (but not all) of the numerous possible combinations of switch and case 608 values described above. 609 610 The module augments the standard Perl syntax with two new control 611 statements: C<switch> and C<case>. The C<switch> statement takes a 612 single scalar argument of any type, specified in parentheses. 613 C<switch> stores this value as the 614 current switch value in a (localized) control variable. 615 The value is followed by a block which may contain one or more 616 Perl statements (including the C<case> statement described below). 617 The block is unconditionally executed once the switch value has 618 been cached. 619 620 A C<case> statement takes a single scalar argument (in mandatory 621 parentheses if it's a variable; otherwise the parens are optional) and 622 selects the appropriate type of matching between that argument and the 623 current switch value. The type of matching used is determined by the 624 respective types of the switch value and the C<case> argument, as 625 specified in Table 1. If the match is successful, the mandatory 626 block associated with the C<case> statement is executed. 627 628 In most other respects, the C<case> statement is semantically identical 629 to an C<if> statement. For example, it can be followed by an C<else> 630 clause, and can be used as a postfix statement qualifier. 631 632 However, when a C<case> block has been executed control is automatically 633 transferred to the statement after the immediately enclosing C<switch> 634 block, rather than to the next statement within the block. In other 635 words, the success of any C<case> statement prevents other cases in the 636 same scope from executing. But see L<"Allowing fall-through"> below. 637 638 Together these two new statements provide a fully generalized case 639 mechanism: 640 641 use Switch; 642 643 # AND LATER... 644 645 %special = ( woohoo => 1, d'oh => 1 ); 646 647 while (<>) { 648 chomp; 649 switch ($_) { 650 case (%special) { print "homer\n"; } # if $special{$_} 651 case /[a-z]/i { print "alpha\n"; } # if $_ =~ /a-z/i 652 case [1..9] { print "small num\n"; } # if $_ in [1..9] 653 case { $_[0] >= 10 } { print "big num\n"; } # if $_ >= 10 654 print "must be punctuation\n" case /\W/; # if $_ ~= /\W/ 655 } 656 } 657 658 Note that C<switch>es can be nested within C<case> (or any other) blocks, 659 and a series of C<case> statements can try different types of matches 660 -- hash membership, pattern match, array intersection, simple equality, 661 etc. -- against the same switch value. 662 663 The use of intersection tests against an array reference is particularly 664 useful 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' } 670 case [1,3,5,7,9] { return 'odd' } 671 case /[A-F]/i { return 'hex' } 672 } 673 } 674 675 676 =head2 Allowing fall-through 677 678 Fall-though (trying another case after one has already succeeded) 679 is usually a Bad Idea in a switch statement. However, this 680 is Perl, not a police state, so there I<is> a way to do it, if you must. 681 682 If a C<case> block executes an untargeted C<next>, control is 683 immediately transferred to the statement I<after> the C<case> statement 684 (i.e. usually another case), rather than out of the surrounding 685 C<switch> block. 686 687 For 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 697 If $val held the number C<1>, the above C<switch> block would call the 698 first three C<handle_...> subroutines, jumping to the next case test 699 each time it encountered a C<next>. After the third C<case> block 700 was executed, control would jump to the end of the enclosing 701 C<switch> block. 702 703 On the other hand, if $val held C<10>, then only the last two C<handle_...> 704 subroutines would be called. 705 706 Note that this mechanism allows the notion of I<conditional fall-through>. 707 For example: 708 709 switch ($val) { 710 case [0..9] { handle_num_any(); next if $val < 7; } 711 case /\d/ { handle_dig_any(); } 712 } 713 714 If an untargeted C<last> statement is executed in a case block, this 715 immediately transfers control out of the enclosing C<switch> block 716 (in other words, there is an implicit C<last> at the end of each 717 normal C<case> block). Thus the previous example could also have been 718 written: 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 728 In situations where case fall-through should be the norm, rather than an 729 exception, an endless succession of terminal C<next>s is tedious and ugly. 730 Hence, it is possible to reverse the default behaviour by specifying 731 the string "fallthrough" when importing the module. For example, the 732 following 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 744 Note the explicit use of a C<last> to preserve the non-fall-through 745 behaviour of the third case. 746 747 748 749 =head2 Alternative syntax 750 751 Perl 6 will provide a built-in switch statement with essentially the 752 same semantics as those offered by Switch.pm, but with a different 753 pair of keywords. In Perl 6 C<switch> will be spelled C<given>, and 754 C<case> will be pronounced C<when>. In addition, the C<when> statement 755 will not require switch or case values to be parenthesized. 756 757 This future syntax is also (largely) available via the Switch.pm module, by 758 importing it with the argument C<"Perl6">. For example: 759 760 use Switch 'Perl6'; 761 762 given ($val) { 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(); } 768 default { handle anything else; } 769 } 770 771 Note that scalars still need to be parenthesized, since they would be 772 ambiguous in Perl 5. 773 774 Note too that you can mix and match both syntaxes by importing the module 775 with: 776 777 use Switch 'Perl5', 'Perl6'; 778 779 780 =head2 Higher-order Operations 781 782 One situation in which C<switch> and C<case> do not provide a good 783 substitute for a cascaded C<if>, is where a switch value needs to 784 be tested against a series of conditions. For example: 785 786 sub beverage { 787 switch (shift) { 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' } 795 } 796 } 797 798 (This is equivalent to writing C<case (sub { $_[0] < 10 })>, etc.; C<$_[0]> 799 is the argument to the anonymous subroutine.) 800 801 The need to specify each condition as a subroutine block is tiresome. To 802 overcome this, when importing Switch.pm, a special "placeholder" 803 subroutine named C<__> [sic] may also be imported. This subroutine 804 converts (almost) any expression in which it appears to a reference to a 805 higher-order function. That is, the expression: 806 807 use Switch '__'; 808 809 __ < 2 810 811 is equivalent to: 812 813 sub { $_[0] < 2 } 814 815 With 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 825 The C<__> subroutine makes extensive use of operator overloading to 826 perform its magic. All operations involving __ are overloaded to 827 produce an anonymous subroutine that implements a lazy version 828 of the original operation. 829 830 The only problem is that operator overloading does not allow the 831 boolean operators C<&&> and C<||> to be overloaded. So a case statement 832 like this: 833 834 case 0 <= __ && __ < 10 { return 'digit' } 835 836 doesn't act as expected, because when it is 837 executed, it constructs two higher order subroutines 838 and then treats the two resulting references as arguments to C<&&>: 839 840 sub { 0 <= $_[0] } && sub { $_[0] < 10 } 841 842 This boolean expression is inevitably true, since both references are 843 non-false. Fortunately, the overloaded C<'bool'> operator catches this 844 situation and flags it as a error. 845 846 =head1 DEPENDENCIES 847 848 The module is implemented using Filter::Util::Call and Text::Balanced 849 and requires both these modules to be installed. 850 851 =head1 AUTHOR 852 853 Damian Conway (damian@conway.org). The maintainer of this module is now Rafael 854 Garcia-Suarez (rgarciasuarez@gmail.com). 855 856 =head1 BUGS 857 858 There are undoubtedly serious bugs lurking somewhere in code this funky :-) 859 Bug reports and other feedback are most welcome. 860 861 =head1 LIMITATIONS 862 863 Due to the heuristic nature of Switch.pm's source parsing, the presence of 864 regexes with embedded newlines that are specified with raw C</.../> 865 delimiters and don't have a modifier C<//x> are indistinguishable from 866 code chunks beginning with the division operator C</>. As a workaround 867 you must use C<m/.../> or C<m?...?> for such patterns. Also, the presence 868 of regexes specified with raw C<?...?> delimiters may cause mysterious 869 errors. The workaround is to use C<m?...?> instead. 870 871 Due to the way source filters work in Perl, you can't use Switch inside 872 an string C<eval>. 873 874 If your source file is longer then 1 million characters and you have a 875 switch statement that crosses the 1 million (or 2 million, etc.) 876 character boundary you will get mysterious errors. The workaround is to 877 use smaller source files. 878 879 =head1 COPYRIGHT 880 881 Copyright (c) 1997-2006, Damian Conway. All Rights Reserved. 882 This module is free software. It may be used, redistributed 883 and/or modified under the same terms as Perl itself.
title
Description
Body
title
Description
Body
title
Description
Body
title
Body
| Generated: Tue Mar 17 22:47:18 2015 | Cross-referenced by PHPXref 0.7.1 |