[ Index ]

PHP Cross Reference of Unnamed Project

title

Body

[close]

/se3-unattended/var/se3/unattended/install/linuxaux/opt/perl/lib/5.10.0/ -> Switch.pm (source)

   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.


Generated: Tue Mar 17 22:47:18 2015 Cross-referenced by PHPXref 0.7.1