|
Packit |
b80439 |
package Switch;
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
use 5.005;
|
|
Packit |
b80439 |
use strict;
|
|
Packit |
b80439 |
use vars qw($VERSION);
|
|
Packit |
b80439 |
use Carp;
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
use if $] >= 5.011, 'deprecate';
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
$VERSION = '2.17';
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
# LOAD FILTERING MODULE...
|
|
Packit |
b80439 |
use Filter::Util::Call;
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
sub __();
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
# CATCH ATTEMPTS TO CALL case OUTSIDE THE SCOPE OF ANY switch
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
$::_S_W_I_T_C_H = sub { croak "case/when statement not in switch/given block" };
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
my $offset;
|
|
Packit |
b80439 |
my $fallthrough;
|
|
Packit |
b80439 |
my ($Perl5, $Perl6) = (0,0);
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
sub import
|
|
Packit |
b80439 |
{
|
|
Packit Service |
9f5357 |
my ($class) = @_;
|
|
Packit Service |
9f5357 |
my $self = bless {}, $class;
|
|
Packit |
b80439 |
$fallthrough = grep /\bfallthrough\b/, @_;
|
|
Packit |
b80439 |
$offset = (caller)[2]+1;
|
|
Packit Service |
9f5357 |
filter_add($self) unless @_>1 && $_[1] eq 'noimport';
|
|
Packit |
b80439 |
my $pkg = caller;
|
|
Packit |
b80439 |
no strict 'refs';
|
|
Packit |
b80439 |
for ( qw( on_defined on_exists ) )
|
|
Packit |
b80439 |
{
|
|
Packit |
b80439 |
*{"${pkg}::$_"} = \&$;;
|
|
Packit |
b80439 |
}
|
|
Packit |
b80439 |
*{"${pkg}::__"} = \&__ if grep /__/, @_;
|
|
Packit |
b80439 |
$Perl6 = 1 if grep(/Perl\s*6/i, @_);
|
|
Packit |
b80439 |
$Perl5 = 1 if grep(/Perl\s*5/i, @_) || !grep(/Perl\s*6/i, @_);
|
|
Packit |
b80439 |
1;
|
|
Packit |
b80439 |
}
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
sub unimport
|
|
Packit |
b80439 |
{
|
|
Packit |
b80439 |
filter_del()
|
|
Packit |
b80439 |
}
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
sub filter
|
|
Packit |
b80439 |
{
|
|
Packit |
b80439 |
my($self) = @_ ;
|
|
Packit |
b80439 |
local $Switch::file = (caller)[1];
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
my $status = 1;
|
|
Packit |
b80439 |
$status = filter_read(1_000_000);
|
|
Packit |
b80439 |
return $status if $status<0;
|
|
Packit |
b80439 |
$_ = filter_blocks($_,$offset);
|
|
Packit |
b80439 |
$_ = "# line $offset\n" . $_ if $offset; undef $offset;
|
|
Packit |
b80439 |
return $status;
|
|
Packit |
b80439 |
}
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
use Text::Balanced ':ALL';
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
sub line
|
|
Packit |
b80439 |
{
|
|
Packit |
b80439 |
my ($pretext,$offset) = @_;
|
|
Packit |
b80439 |
($pretext=~tr/\n/\n/)+($offset||0);
|
|
Packit |
b80439 |
}
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
sub is_block
|
|
Packit |
b80439 |
{
|
|
Packit |
b80439 |
local $SIG{__WARN__}=sub{die$@};
|
|
Packit |
b80439 |
local $^W=1;
|
|
Packit |
b80439 |
my $ishash = defined eval 'my $hr='.$_[0];
|
|
Packit |
b80439 |
undef $@;
|
|
Packit |
b80439 |
return !$ishash;
|
|
Packit |
b80439 |
}
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
my $pod_or_DATA = qr/ ^=[A-Za-z] .*? ^=cut (?![A-Za-z]) .*? $
|
|
Packit |
b80439 |
| ^__(DATA|END)__\n.*
|
|
Packit |
b80439 |
/smx;
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
my $casecounter = 1;
|
|
Packit |
b80439 |
sub filter_blocks
|
|
Packit |
b80439 |
{
|
|
Packit |
b80439 |
my ($source, $line) = @_;
|
|
Packit |
b80439 |
return $source unless $Perl5 && $source =~ /case|switch/
|
|
Packit |
b80439 |
|| $Perl6 && $source =~ /when|given|default/;
|
|
Packit |
b80439 |
pos $source = 0;
|
|
Packit |
b80439 |
my $text = "";
|
|
Packit |
b80439 |
component: while (pos $source < length $source)
|
|
Packit |
b80439 |
{
|
|
Packit |
b80439 |
if ($source =~ m/(\G\s*use\s+Switch\b)/gc)
|
|
Packit |
b80439 |
{
|
|
Packit |
b80439 |
$text .= q{use Switch 'noimport'};
|
|
Packit |
b80439 |
next component;
|
|
Packit |
b80439 |
}
|
|
Packit |
b80439 |
my @pos = Text::Balanced::_match_quotelike(\$source,qr/\s*/,1,0);
|
|
Packit |
b80439 |
if (defined $pos[0])
|
|
Packit |
b80439 |
{
|
|
Packit |
b80439 |
my $pre = substr($source,$pos[0],$pos[1]); # matched prefix
|
|
Packit |
b80439 |
my $iEol;
|
|
Packit |
b80439 |
if( substr($source,$pos[4],$pos[5]) eq '/' && # 1st delimiter
|
|
Packit |
b80439 |
substr($source,$pos[2],$pos[3]) eq '' && # no op like 'm'
|
|
Packit |
b80439 |
index( substr($source,$pos[16],$pos[17]), 'x' ) == -1 && # no //x
|
|
Packit |
b80439 |
($iEol = index( $source, "\n", $pos[4] )) > 0 &&
|
|
Packit |
b80439 |
$iEol < $pos[8] ){ # embedded newlines
|
|
Packit |
b80439 |
# If this is a pattern, it isn't compatible with Switch. Backup past 1st '/'.
|
|
Packit |
b80439 |
pos( $source ) = $pos[6];
|
|
Packit |
b80439 |
$text .= $pre . substr($source,$pos[2],$pos[6]-$pos[2]);
|
|
Packit |
b80439 |
} else {
|
|
Packit |
b80439 |
$text .= $pre . substr($source,$pos[2],$pos[18]-$pos[2]);
|
|
Packit |
b80439 |
}
|
|
Packit |
b80439 |
next component;
|
|
Packit |
b80439 |
}
|
|
Packit |
b80439 |
if ($source =~ m/(\G\s*$pod_or_DATA)/gc) {
|
|
Packit |
b80439 |
$text .= $1;
|
|
Packit |
b80439 |
next component;
|
|
Packit |
b80439 |
}
|
|
Packit |
b80439 |
@pos = Text::Balanced::_match_variable(\$source,qr/\s*/);
|
|
Packit |
b80439 |
if (defined $pos[0])
|
|
Packit |
b80439 |
{
|
|
Packit |
b80439 |
$text .= " " if $pos[0] < $pos[2];
|
|
Packit |
b80439 |
$text .= substr($source,$pos[0],$pos[4]-$pos[0]);
|
|
Packit |
b80439 |
next component;
|
|
Packit |
b80439 |
}
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
if ($Perl5 && $source =~ m/\G(\n*)(\s*)(switch)\b(?=\s*[(])/gc
|
|
Packit |
b80439 |
|| $Perl6 && $source =~ m/\G(\n*)(\s*)(given)\b(?=\s*[(])/gc
|
|
Packit |
b80439 |
|| $Perl6 && $source =~ m/\G(\n*)(\s*)(given)\b(.*)(?=\{)/gc)
|
|
Packit |
b80439 |
{
|
|
Packit |
b80439 |
my $keyword = $3;
|
|
Packit |
b80439 |
my $arg = $4;
|
|
Packit |
b80439 |
$text .= $1.$2.'S_W_I_T_C_H: while (1) ';
|
|
Packit |
b80439 |
unless ($arg) {
|
|
Packit |
b80439 |
@pos = Text::Balanced::_match_codeblock(\$source,qr/\s*/,qr/\(/,qr/\)/,qr/[[{(<]/,qr/[]})>]/,undef)
|
|
Packit |
b80439 |
or do {
|
|
Packit |
b80439 |
die "Bad $keyword statement (problem in the parentheses?) near $Switch::file line ", line(substr($source,0,pos $source),$line), "\n";
|
|
Packit |
b80439 |
};
|
|
Packit |
b80439 |
$arg = filter_blocks(substr($source,$pos[0],$pos[4]-$pos[0]),line(substr($source,0,$pos[0]),$line));
|
|
Packit |
b80439 |
}
|
|
Packit |
b80439 |
$arg =~ s {^\s*[(]\s*%} { ( \\\%} ||
|
|
Packit |
b80439 |
$arg =~ s {^\s*[(]\s*m\b} { ( qr} ||
|
|
Packit |
b80439 |
$arg =~ s {^\s*[(]\s*/} { ( qr/} ||
|
|
Packit |
b80439 |
$arg =~ s {^\s*[(]\s*qw} { ( \\qw};
|
|
Packit |
b80439 |
@pos = Text::Balanced::_match_codeblock(\$source,qr/\s*/,qr/\{/,qr/\}/,qr/\{/,qr/\}/,undef)
|
|
Packit |
b80439 |
or do {
|
|
Packit |
b80439 |
die "Bad $keyword statement (problem in the code block?) near $Switch::file line ", line(substr($source,0, pos $source), $line), "\n";
|
|
Packit |
b80439 |
};
|
|
Packit |
b80439 |
my $code = filter_blocks(substr($source,$pos[0],$pos[4]-$pos[0]),line(substr($source,0,$pos[0]),$line));
|
|
Packit |
b80439 |
$code =~ s/{/{ local \$::_S_W_I_T_C_H; Switch::switch($arg);/;
|
|
Packit |
b80439 |
$text .= $code . 'continue {last}';
|
|
Packit |
b80439 |
next component;
|
|
Packit |
b80439 |
}
|
|
Packit |
b80439 |
elsif ($Perl5 && $source =~ m/\G(\s*)(case\b)(?!\s*=>)/gc
|
|
Packit |
b80439 |
|| $Perl6 && $source =~ m/\G(\s*)(when\b)(?!\s*=>)/gc
|
|
Packit |
b80439 |
|| $Perl6 && $source =~ m/\G(\s*)(default\b)(?=\s*\{)/gc)
|
|
Packit |
b80439 |
{
|
|
Packit |
b80439 |
my $keyword = $2;
|
|
Packit |
b80439 |
$text .= $1 . ($keyword eq "default"
|
|
Packit |
b80439 |
? "if (1)"
|
|
Packit |
b80439 |
: "if (Switch::case");
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
if ($keyword eq "default") {
|
|
Packit |
b80439 |
# Nothing to do
|
|
Packit |
b80439 |
}
|
|
Packit |
b80439 |
elsif (@pos = Text::Balanced::_match_codeblock(\$source,qr/\s*/,qr/\{/,qr/\}/,qr/\{/,qr/\}/,undef)) {
|
|
Packit |
b80439 |
my $code = substr($source,$pos[0],$pos[4]-$pos[0]);
|
|
Packit |
b80439 |
$text .= " " if $pos[0] < $pos[2];
|
|
Packit |
b80439 |
$text .= "sub " if is_block $code;
|
|
Packit |
b80439 |
$text .= filter_blocks($code,line(substr($source,0,$pos[0]),$line)) . ")";
|
|
Packit |
b80439 |
}
|
|
Packit |
b80439 |
elsif (@pos = Text::Balanced::_match_codeblock(\$source,qr/\s*/,qr/[[(]/,qr/[])]/,qr/[[({]/,qr/[])}]/,undef)) {
|
|
Packit |
b80439 |
my $code = filter_blocks(substr($source,$pos[0],$pos[4]-$pos[0]),line(substr($source,0,$pos[0]),$line));
|
|
Packit |
b80439 |
$code =~ s {^\s*[(]\s*%} { ( \\\%} ||
|
|
Packit |
b80439 |
$code =~ s {^\s*[(]\s*m\b} { ( qr} ||
|
|
Packit |
b80439 |
$code =~ s {^\s*[(]\s*/} { ( qr/} ||
|
|
Packit |
b80439 |
$code =~ s {^\s*[(]\s*qw} { ( \\qw};
|
|
Packit |
b80439 |
$text .= " " if $pos[0] < $pos[2];
|
|
Packit |
b80439 |
$text .= "$code)";
|
|
Packit |
b80439 |
}
|
|
Packit |
b80439 |
elsif ($Perl6 && do{@pos = Text::Balanced::_match_variable(\$source,qr/\s*/)}) {
|
|
Packit |
b80439 |
my $code = filter_blocks(substr($source,$pos[0],$pos[4]-$pos[0]),line(substr($source,0,$pos[0]),$line));
|
|
Packit |
b80439 |
$code =~ s {^\s*%} { \%} ||
|
|
Packit |
b80439 |
$code =~ s {^\s*@} { \@};
|
|
Packit |
b80439 |
$text .= " " if $pos[0] < $pos[2];
|
|
Packit |
b80439 |
$text .= "$code)";
|
|
Packit |
b80439 |
}
|
|
Packit |
b80439 |
elsif ( @pos = Text::Balanced::_match_quotelike(\$source,qr/\s*/,1,0)) {
|
|
Packit |
b80439 |
my $code = substr($source,$pos[2],$pos[18]-$pos[2]);
|
|
Packit |
b80439 |
$code = filter_blocks($code,line(substr($source,0,$pos[2]),$line));
|
|
Packit |
b80439 |
$code =~ s {^\s*m} { qr} ||
|
|
Packit |
b80439 |
$code =~ s {^\s*/} { qr/} ||
|
|
Packit |
b80439 |
$code =~ s {^\s*qw} { \\qw};
|
|
Packit |
b80439 |
$text .= " " if $pos[0] < $pos[2];
|
|
Packit |
b80439 |
$text .= "$code)";
|
|
Packit |
b80439 |
}
|
|
Packit |
b80439 |
elsif ($Perl5 && $source =~ m/\G\s*(([^\$\@{])[^\$\@{]*)(?=\s*{)/gc
|
|
Packit |
b80439 |
|| $Perl6 && $source =~ m/\G\s*([^;{]*)()/gc) {
|
|
Packit |
b80439 |
my $code = filter_blocks($1,line(substr($source,0,pos $source),$line));
|
|
Packit |
b80439 |
$text .= ' \\' if $2 eq '%';
|
|
Packit |
b80439 |
$text .= " $code)";
|
|
Packit |
b80439 |
}
|
|
Packit |
b80439 |
else {
|
|
Packit |
b80439 |
die "Bad $keyword statement (invalid $keyword value?) near $Switch::file line ", line(substr($source,0,pos $source), $line), "\n";
|
|
Packit |
b80439 |
}
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
die "Missing opening brace or semi-colon after 'when' value near $Switch::file line ", line(substr($source,0,pos $source), $line), "\n"
|
|
Packit |
b80439 |
unless !$Perl6 || $source =~ m/\G(\s*)(?=;|\{)/gc;
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
do{@pos = Text::Balanced::_match_codeblock(\$source,qr/\s*/,qr/\{/,qr/\}/,qr/\{/,qr/\}/,undef)}
|
|
Packit |
b80439 |
or do {
|
|
Packit |
b80439 |
if ($source =~ m/\G\s*(?=([};]|\Z))/gc) {
|
|
Packit |
b80439 |
$casecounter++;
|
|
Packit |
b80439 |
next component;
|
|
Packit |
b80439 |
}
|
|
Packit |
b80439 |
die "Bad $keyword statement (problem in the code block?) near $Switch::file line ", line(substr($source,0,pos $source),$line), "\n";
|
|
Packit |
b80439 |
};
|
|
Packit |
b80439 |
my $code = filter_blocks(substr($source,$pos[0],$pos[4]-$pos[0]),line(substr($source,0,$pos[0]),$line));
|
|
Packit |
b80439 |
$code =~ s/}(?=\s*\Z)/;last S_W_I_T_C_H }/
|
|
Packit |
b80439 |
unless $fallthrough;
|
|
Packit |
b80439 |
$text .= "{ while (1) $code continue { goto C_A_S_E_$casecounter } last S_W_I_T_C_H; C_A_S_E_$casecounter: }";
|
|
Packit |
b80439 |
$casecounter++;
|
|
Packit |
b80439 |
next component;
|
|
Packit |
b80439 |
}
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
$source =~ m/\G(\s*(-[sm]\s+|\w+|#.*\n|\W))/gc;
|
|
Packit |
b80439 |
$text .= $1;
|
|
Packit |
b80439 |
}
|
|
Packit |
b80439 |
$text;
|
|
Packit |
b80439 |
}
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
sub in
|
|
Packit |
b80439 |
{
|
|
Packit |
b80439 |
my ($x,$y) = @_;
|
|
Packit |
b80439 |
my @numy;
|
|
Packit |
b80439 |
for my $nextx ( @$x )
|
|
Packit |
b80439 |
{
|
|
Packit |
b80439 |
my $numx = ref($nextx) || defined $nextx && (~$nextx&$nextx) eq 0;
|
|
Packit |
b80439 |
for my $j ( 0..$#$y )
|
|
Packit |
b80439 |
{
|
|
Packit |
b80439 |
my $nexty = $y->[$j];
|
|
Packit |
b80439 |
push @numy, ref($nexty) || defined $nexty && (~$nexty&$nexty) eq 0
|
|
Packit |
b80439 |
if @numy <= $j;
|
|
Packit |
b80439 |
return 1 if $numx && $numy[$j] && $nextx==$nexty
|
|
Packit |
b80439 |
|| $nextx eq $nexty;
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
}
|
|
Packit |
b80439 |
}
|
|
Packit |
b80439 |
return "";
|
|
Packit |
b80439 |
}
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
sub on_exists
|
|
Packit |
b80439 |
{
|
|
Packit |
b80439 |
my $ref = @_==1 && ref($_[0]) eq 'HASH' ? $_[0] : { @_ };
|
|
Packit |
b80439 |
[ keys %$ref ]
|
|
Packit |
b80439 |
}
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
sub on_defined
|
|
Packit |
b80439 |
{
|
|
Packit |
b80439 |
my $ref = @_==1 && ref($_[0]) eq 'HASH' ? $_[0] : { @_ };
|
|
Packit |
b80439 |
[ grep { defined $ref->{$_} } keys %$ref ]
|
|
Packit |
b80439 |
}
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
sub switch(;$)
|
|
Packit |
b80439 |
{
|
|
Packit |
b80439 |
my ($s_val) = @_ ? $_[0] : $_;
|
|
Packit |
b80439 |
my $s_ref = ref $s_val;
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
if ($s_ref eq 'CODE')
|
|
Packit |
b80439 |
{
|
|
Packit |
b80439 |
$::_S_W_I_T_C_H =
|
|
Packit |
b80439 |
sub { my $c_val = $_[0];
|
|
Packit |
b80439 |
return $s_val == $c_val if ref $c_val eq 'CODE';
|
|
Packit |
b80439 |
return $s_val->(@$c_val) if ref $c_val eq 'ARRAY';
|
|
Packit |
b80439 |
return $s_val->($c_val);
|
|
Packit |
b80439 |
};
|
|
Packit |
b80439 |
}
|
|
Packit |
b80439 |
elsif ($s_ref eq "" && defined $s_val && (~$s_val&$s_val) eq 0) # NUMERIC SCALAR
|
|
Packit |
b80439 |
{
|
|
Packit |
b80439 |
$::_S_W_I_T_C_H =
|
|
Packit |
b80439 |
sub { my $c_val = $_[0];
|
|
Packit |
b80439 |
my $c_ref = ref $c_val;
|
|
Packit |
b80439 |
return $s_val == $c_val if $c_ref eq ""
|
|
Packit |
b80439 |
&& defined $c_val
|
|
Packit |
b80439 |
&& (~$c_val&$c_val) eq 0;
|
|
Packit |
b80439 |
return $s_val eq $c_val if $c_ref eq "";
|
|
Packit |
b80439 |
return in([$s_val],$c_val) if $c_ref eq 'ARRAY';
|
|
Packit |
b80439 |
return $c_val->($s_val) if $c_ref eq 'CODE';
|
|
Packit |
b80439 |
return $c_val->call($s_val) if $c_ref eq 'Switch';
|
|
Packit |
b80439 |
return scalar $s_val=~/$c_val/
|
|
Packit |
b80439 |
if $c_ref eq 'Regexp';
|
|
Packit |
b80439 |
return scalar $c_val->{$s_val}
|
|
Packit |
b80439 |
if $c_ref eq 'HASH';
|
|
Packit |
b80439 |
return;
|
|
Packit |
b80439 |
};
|
|
Packit |
b80439 |
}
|
|
Packit |
b80439 |
elsif ($s_ref eq "") # STRING SCALAR
|
|
Packit |
b80439 |
{
|
|
Packit |
b80439 |
$::_S_W_I_T_C_H =
|
|
Packit |
b80439 |
sub { my $c_val = $_[0];
|
|
Packit |
b80439 |
my $c_ref = ref $c_val;
|
|
Packit |
b80439 |
return $s_val eq $c_val if $c_ref eq "";
|
|
Packit |
b80439 |
return in([$s_val],$c_val) if $c_ref eq 'ARRAY';
|
|
Packit |
b80439 |
return $c_val->($s_val) if $c_ref eq 'CODE';
|
|
Packit |
b80439 |
return $c_val->call($s_val) if $c_ref eq 'Switch';
|
|
Packit |
b80439 |
return scalar $s_val=~/$c_val/
|
|
Packit |
b80439 |
if $c_ref eq 'Regexp';
|
|
Packit |
b80439 |
return scalar $c_val->{$s_val}
|
|
Packit |
b80439 |
if $c_ref eq 'HASH';
|
|
Packit |
b80439 |
return;
|
|
Packit |
b80439 |
};
|
|
Packit |
b80439 |
}
|
|
Packit |
b80439 |
elsif ($s_ref eq 'ARRAY')
|
|
Packit |
b80439 |
{
|
|
Packit |
b80439 |
$::_S_W_I_T_C_H =
|
|
Packit |
b80439 |
sub { my $c_val = $_[0];
|
|
Packit |
b80439 |
my $c_ref = ref $c_val;
|
|
Packit |
b80439 |
return in($s_val,[$c_val]) if $c_ref eq "";
|
|
Packit |
b80439 |
return in($s_val,$c_val) if $c_ref eq 'ARRAY';
|
|
Packit |
b80439 |
return $c_val->(@$s_val) if $c_ref eq 'CODE';
|
|
Packit |
b80439 |
return $c_val->call(@$s_val)
|
|
Packit |
b80439 |
if $c_ref eq 'Switch';
|
|
Packit |
b80439 |
return scalar grep {$_=~/$c_val/} @$s_val
|
|
Packit |
b80439 |
if $c_ref eq 'Regexp';
|
|
Packit |
b80439 |
return scalar grep {$c_val->{$_}} @$s_val
|
|
Packit |
b80439 |
if $c_ref eq 'HASH';
|
|
Packit |
b80439 |
return;
|
|
Packit |
b80439 |
};
|
|
Packit |
b80439 |
}
|
|
Packit |
b80439 |
elsif ($s_ref eq 'Regexp')
|
|
Packit |
b80439 |
{
|
|
Packit |
b80439 |
$::_S_W_I_T_C_H =
|
|
Packit |
b80439 |
sub { my $c_val = $_[0];
|
|
Packit |
b80439 |
my $c_ref = ref $c_val;
|
|
Packit |
b80439 |
return $c_val=~/s_val/ if $c_ref eq "";
|
|
Packit |
b80439 |
return scalar grep {$_=~/s_val/} @$c_val
|
|
Packit |
b80439 |
if $c_ref eq 'ARRAY';
|
|
Packit |
b80439 |
return $c_val->($s_val) if $c_ref eq 'CODE';
|
|
Packit |
b80439 |
return $c_val->call($s_val) if $c_ref eq 'Switch';
|
|
Packit |
b80439 |
return $s_val eq $c_val if $c_ref eq 'Regexp';
|
|
Packit |
b80439 |
return grep {$_=~/$s_val/ && $c_val->{$_}} keys %$c_val
|
|
Packit |
b80439 |
if $c_ref eq 'HASH';
|
|
Packit |
b80439 |
return;
|
|
Packit |
b80439 |
};
|
|
Packit |
b80439 |
}
|
|
Packit |
b80439 |
elsif ($s_ref eq 'HASH')
|
|
Packit |
b80439 |
{
|
|
Packit |
b80439 |
$::_S_W_I_T_C_H =
|
|
Packit |
b80439 |
sub { my $c_val = $_[0];
|
|
Packit |
b80439 |
my $c_ref = ref $c_val;
|
|
Packit |
b80439 |
return $s_val->{$c_val} if $c_ref eq "";
|
|
Packit |
b80439 |
return scalar grep {$s_val->{$_}} @$c_val
|
|
Packit |
b80439 |
if $c_ref eq 'ARRAY';
|
|
Packit |
b80439 |
return $c_val->($s_val) if $c_ref eq 'CODE';
|
|
Packit |
b80439 |
return $c_val->call($s_val) if $c_ref eq 'Switch';
|
|
Packit |
b80439 |
return grep {$_=~/$c_val/ && $s_val->{"$_"}} keys %$s_val
|
|
Packit |
b80439 |
if $c_ref eq 'Regexp';
|
|
Packit |
b80439 |
return $s_val==$c_val if $c_ref eq 'HASH';
|
|
Packit |
b80439 |
return;
|
|
Packit |
b80439 |
};
|
|
Packit |
b80439 |
}
|
|
Packit |
b80439 |
elsif ($s_ref eq 'Switch')
|
|
Packit |
b80439 |
{
|
|
Packit |
b80439 |
$::_S_W_I_T_C_H =
|
|
Packit |
b80439 |
sub { my $c_val = $_[0];
|
|
Packit |
b80439 |
return $s_val == $c_val if ref $c_val eq 'Switch';
|
|
Packit |
b80439 |
return $s_val->call(@$c_val)
|
|
Packit |
b80439 |
if ref $c_val eq 'ARRAY';
|
|
Packit |
b80439 |
return $s_val->call($c_val);
|
|
Packit |
b80439 |
};
|
|
Packit |
b80439 |
}
|
|
Packit |
b80439 |
else
|
|
Packit |
b80439 |
{
|
|
Packit |
b80439 |
croak "Cannot switch on $s_ref";
|
|
Packit |
b80439 |
}
|
|
Packit |
b80439 |
return 1;
|
|
Packit |
b80439 |
}
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
sub case($) { local $SIG{__WARN__} = \&carp;
|
|
Packit |
b80439 |
$::_S_W_I_T_C_H->(@_); }
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
# IMPLEMENT __
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
my $placeholder = bless { arity=>1, impl=>sub{$_[1+$_[0]]} };
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
sub __() { $placeholder }
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
sub __arg($)
|
|
Packit |
b80439 |
{
|
|
Packit |
b80439 |
my $index = $_[0]+1;
|
|
Packit |
b80439 |
bless { arity=>0, impl=>sub{$_[$index]} };
|
|
Packit |
b80439 |
}
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
sub hosub(&@)
|
|
Packit |
b80439 |
{
|
|
Packit |
b80439 |
# WRITE THIS
|
|
Packit |
b80439 |
}
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
sub call
|
|
Packit |
b80439 |
{
|
|
Packit |
b80439 |
my ($self,@args) = @_;
|
|
Packit |
b80439 |
return $self->{impl}->(0,@args);
|
|
Packit |
b80439 |
}
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
sub meta_bop(&)
|
|
Packit |
b80439 |
{
|
|
Packit |
b80439 |
my ($op) = @_;
|
|
Packit |
b80439 |
sub
|
|
Packit |
b80439 |
{
|
|
Packit |
b80439 |
my ($left, $right, $reversed) = @_;
|
|
Packit |
b80439 |
($right,$left) = @_ if $reversed;
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
my $rop = ref $right eq 'Switch'
|
|
Packit |
b80439 |
? $right
|
|
Packit |
b80439 |
: bless { arity=>0, impl=>sub{$right} };
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
my $lop = ref $left eq 'Switch'
|
|
Packit |
b80439 |
? $left
|
|
Packit |
b80439 |
: bless { arity=>0, impl=>sub{$left} };
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
my $arity = $lop->{arity} + $rop->{arity};
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
return bless {
|
|
Packit |
b80439 |
arity => $arity,
|
|
Packit |
b80439 |
impl => sub { my $start = shift;
|
|
Packit |
b80439 |
return $op->($lop->{impl}->($start,@_),
|
|
Packit |
b80439 |
$rop->{impl}->($start+$lop->{arity},@_));
|
|
Packit |
b80439 |
}
|
|
Packit |
b80439 |
};
|
|
Packit |
b80439 |
};
|
|
Packit |
b80439 |
}
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
sub meta_uop(&)
|
|
Packit |
b80439 |
{
|
|
Packit |
b80439 |
my ($op) = @_;
|
|
Packit |
b80439 |
sub
|
|
Packit |
b80439 |
{
|
|
Packit |
b80439 |
my ($left) = @_;
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
my $lop = ref $left eq 'Switch'
|
|
Packit |
b80439 |
? $left
|
|
Packit |
b80439 |
: bless { arity=>0, impl=>sub{$left} };
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
my $arity = $lop->{arity};
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
return bless {
|
|
Packit |
b80439 |
arity => $arity,
|
|
Packit |
b80439 |
impl => sub { $op->($lop->{impl}->(@_)) }
|
|
Packit |
b80439 |
};
|
|
Packit |
b80439 |
};
|
|
Packit |
b80439 |
}
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
use overload
|
|
Packit |
b80439 |
"+" => meta_bop {$_[0] + $_[1]},
|
|
Packit |
b80439 |
"-" => meta_bop {$_[0] - $_[1]},
|
|
Packit |
b80439 |
"*" => meta_bop {$_[0] * $_[1]},
|
|
Packit |
b80439 |
"/" => meta_bop {$_[0] / $_[1]},
|
|
Packit |
b80439 |
"%" => meta_bop {$_[0] % $_[1]},
|
|
Packit |
b80439 |
"**" => meta_bop {$_[0] ** $_[1]},
|
|
Packit |
b80439 |
"<<" => meta_bop {$_[0] << $_[1]},
|
|
Packit |
b80439 |
">>" => meta_bop {$_[0] >> $_[1]},
|
|
Packit |
b80439 |
"x" => meta_bop {$_[0] x $_[1]},
|
|
Packit |
b80439 |
"." => meta_bop {$_[0] . $_[1]},
|
|
Packit |
b80439 |
"<" => meta_bop {$_[0] < $_[1]},
|
|
Packit |
b80439 |
"<=" => meta_bop {$_[0] <= $_[1]},
|
|
Packit |
b80439 |
">" => meta_bop {$_[0] > $_[1]},
|
|
Packit |
b80439 |
">=" => meta_bop {$_[0] >= $_[1]},
|
|
Packit |
b80439 |
"==" => meta_bop {$_[0] == $_[1]},
|
|
Packit |
b80439 |
"!=" => meta_bop {$_[0] != $_[1]},
|
|
Packit |
b80439 |
"<=>" => meta_bop {$_[0] <=> $_[1]},
|
|
Packit |
b80439 |
"lt" => meta_bop {$_[0] lt $_[1]},
|
|
Packit |
b80439 |
"le" => meta_bop {$_[0] le $_[1]},
|
|
Packit |
b80439 |
"gt" => meta_bop {$_[0] gt $_[1]},
|
|
Packit |
b80439 |
"ge" => meta_bop {$_[0] ge $_[1]},
|
|
Packit |
b80439 |
"eq" => meta_bop {$_[0] eq $_[1]},
|
|
Packit |
b80439 |
"ne" => meta_bop {$_[0] ne $_[1]},
|
|
Packit |
b80439 |
"cmp" => meta_bop {$_[0] cmp $_[1]},
|
|
Packit |
b80439 |
"\&" => meta_bop {$_[0] & $_[1]},
|
|
Packit |
b80439 |
"^" => meta_bop {$_[0] ^ $_[1]},
|
|
Packit |
b80439 |
"|" => meta_bop {$_[0] | $_[1]},
|
|
Packit |
b80439 |
"atan2" => meta_bop {atan2 $_[0], $_[1]},
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
"neg" => meta_uop {-$_[0]},
|
|
Packit |
b80439 |
"!" => meta_uop {!$_[0]},
|
|
Packit |
b80439 |
"~" => meta_uop {~$_[0]},
|
|
Packit |
b80439 |
"cos" => meta_uop {cos $_[0]},
|
|
Packit |
b80439 |
"sin" => meta_uop {sin $_[0]},
|
|
Packit |
b80439 |
"exp" => meta_uop {exp $_[0]},
|
|
Packit |
b80439 |
"abs" => meta_uop {abs $_[0]},
|
|
Packit |
b80439 |
"log" => meta_uop {log $_[0]},
|
|
Packit |
b80439 |
"sqrt" => meta_uop {sqrt $_[0]},
|
|
Packit |
b80439 |
"bool" => sub { croak "Can't use && or || in expression containing __" },
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
# "&()" => sub { $_[0]->{impl} },
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
# "||" => meta_bop {$_[0] || $_[1]},
|
|
Packit |
b80439 |
# "&&" => meta_bop {$_[0] && $_[1]},
|
|
Packit |
b80439 |
# fallback => 1,
|
|
Packit |
b80439 |
;
|
|
Packit |
b80439 |
1;
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
__END__
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
=head1 NAME
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
Switch - A switch statement for Perl, do not use if you can use given/when
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
=head1 SYNOPSIS
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
use Switch;
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
switch ($val) {
|
|
Packit |
b80439 |
case 1 { print "number 1" }
|
|
Packit |
b80439 |
case "a" { print "string a" }
|
|
Packit |
b80439 |
case [1..10,42] { print "number in list" }
|
|
Packit |
b80439 |
case (\@array) { print "number in list" }
|
|
Packit |
b80439 |
case /\w+/ { print "pattern" }
|
|
Packit |
b80439 |
case qr/\w+/ { print "pattern" }
|
|
Packit |
b80439 |
case (\%hash) { print "entry in hash" }
|
|
Packit |
b80439 |
case (\&sub) { print "arg to subroutine" }
|
|
Packit |
b80439 |
else { print "previous case not true" }
|
|
Packit |
b80439 |
}
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
=head1 BACKGROUND
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
[Skip ahead to L<"DESCRIPTION"> if you don't care about the whys
|
|
Packit |
b80439 |
and wherefores of this control structure]
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
In seeking to devise a "Swiss Army" case mechanism suitable for Perl,
|
|
Packit |
b80439 |
it is useful to generalize this notion of distributed conditional
|
|
Packit |
b80439 |
testing as far as possible. Specifically, the concept of "matching"
|
|
Packit |
b80439 |
between the switch value and the various case values need not be
|
|
Packit |
b80439 |
restricted to numeric (or string or referential) equality, as it is in other
|
|
Packit |
b80439 |
languages. Indeed, as Table 1 illustrates, Perl
|
|
Packit |
b80439 |
offers at least eighteen different ways in which two values could
|
|
Packit |
b80439 |
generate a match.
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
Table 1: Matching a switch value ($s) with a case value ($c)
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
Switch Case Type of Match Implied Matching Code
|
|
Packit |
b80439 |
Value Value
|
|
Packit |
b80439 |
====== ===== ===================== =============
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
number same numeric or referential match if $s == $c;
|
|
Packit |
b80439 |
or ref equality
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
object method result of method call match if $s->$c();
|
|
Packit |
b80439 |
ref name match if defined $s->$c();
|
|
Packit |
b80439 |
or ref
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
other other string equality match if $s eq $c;
|
|
Packit |
b80439 |
non-ref non-ref
|
|
Packit |
b80439 |
scalar scalar
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
string regexp pattern match match if $s =~ /$c/;
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
array scalar array entry existence match if 0<=$c && $c<@$s;
|
|
Packit |
b80439 |
ref array entry definition match if defined $s->[$c];
|
|
Packit |
b80439 |
array entry truth match if $s->[$c];
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
array array array intersection match if intersects(@$s, @$c);
|
|
Packit |
b80439 |
ref ref (apply this table to
|
|
Packit |
b80439 |
all pairs of elements
|
|
Packit |
b80439 |
$s->[$i] and
|
|
Packit |
b80439 |
$c->[$j])
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
array regexp array grep match if grep /$c/, @$s;
|
|
Packit |
b80439 |
ref
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
hash scalar hash entry existence match if exists $s->{$c};
|
|
Packit |
b80439 |
ref hash entry definition match if defined $s->{$c};
|
|
Packit |
b80439 |
hash entry truth match if $s->{$c};
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
hash regexp hash grep match if grep /$c/, keys %$s;
|
|
Packit |
b80439 |
ref
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
sub scalar return value defn match if defined $s->($c);
|
|
Packit |
b80439 |
ref return value truth match if $s->($c);
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
sub array return value defn match if defined $s->(@$c);
|
|
Packit |
b80439 |
ref ref return value truth match if $s->(@$c);
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
In reality, Table 1 covers 31 alternatives, because only the equality and
|
|
Packit |
b80439 |
intersection tests are commutative; in all other cases, the roles of
|
|
Packit |
b80439 |
the C<$s> and C<$c> variables could be reversed to produce a
|
|
Packit |
b80439 |
different test. For example, instead of testing a single hash for
|
|
Packit |
b80439 |
the existence of a series of keys (C<match if exists $s-E<gt>{$c}>),
|
|
Packit |
b80439 |
one could test for the existence of a single key in a series of hashes
|
|
Packit |
b80439 |
(C<match if exists $c-E<gt>{$s}>).
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
=head1 DESCRIPTION
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
The Switch.pm module implements a generalized case mechanism that covers
|
|
Packit |
b80439 |
most (but not all) of the numerous possible combinations of switch and case
|
|
Packit |
b80439 |
values described above.
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
The module augments the standard Perl syntax with two new control
|
|
Packit |
b80439 |
statements: C<switch> and C<case>. The C<switch> statement takes a
|
|
Packit |
b80439 |
single scalar argument of any type, specified in parentheses.
|
|
Packit |
b80439 |
C<switch> stores this value as the
|
|
Packit |
b80439 |
current switch value in a (localized) control variable.
|
|
Packit |
b80439 |
The value is followed by a block which may contain one or more
|
|
Packit |
b80439 |
Perl statements (including the C<case> statement described below).
|
|
Packit |
b80439 |
The block is unconditionally executed once the switch value has
|
|
Packit |
b80439 |
been cached.
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
A C<case> statement takes a single scalar argument (in mandatory
|
|
Packit |
b80439 |
parentheses if it's a variable; otherwise the parens are optional) and
|
|
Packit |
b80439 |
selects the appropriate type of matching between that argument and the
|
|
Packit |
b80439 |
current switch value. The type of matching used is determined by the
|
|
Packit |
b80439 |
respective types of the switch value and the C<case> argument, as
|
|
Packit |
b80439 |
specified in Table 1. If the match is successful, the mandatory
|
|
Packit |
b80439 |
block associated with the C<case> statement is executed.
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
In most other respects, the C<case> statement is semantically identical
|
|
Packit |
b80439 |
to an C<if> statement. For example, it can be followed by an C<else>
|
|
Packit |
b80439 |
clause, and can be used as a postfix statement qualifier.
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
However, when a C<case> block has been executed control is automatically
|
|
Packit |
b80439 |
transferred to the statement after the immediately enclosing C<switch>
|
|
Packit |
b80439 |
block, rather than to the next statement within the block. In other
|
|
Packit |
b80439 |
words, the success of any C<case> statement prevents other cases in the
|
|
Packit |
b80439 |
same scope from executing. But see L<"Allowing fall-through"> below.
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
Together these two new statements provide a fully generalized case
|
|
Packit |
b80439 |
mechanism:
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
use Switch;
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
# AND LATER...
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
%special = ( woohoo => 1, d'oh => 1 );
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
while (<>) {
|
|
Packit |
b80439 |
chomp;
|
|
Packit |
b80439 |
switch ($_) {
|
|
Packit |
b80439 |
case (%special) { print "homer\n"; } # if $special{$_}
|
|
Packit |
b80439 |
case /[a-z]/i { print "alpha\n"; } # if $_ =~ /a-z/i
|
|
Packit |
b80439 |
case [1..9] { print "small num\n"; } # if $_ in [1..9]
|
|
Packit |
b80439 |
case { $_[0] >= 10 } { print "big num\n"; } # if $_ >= 10
|
|
Packit |
b80439 |
print "must be punctuation\n" case /\W/; # if $_ ~= /\W/
|
|
Packit |
b80439 |
}
|
|
Packit |
b80439 |
}
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
Note that C<switch>es can be nested within C<case> (or any other) blocks,
|
|
Packit |
b80439 |
and a series of C<case> statements can try different types of matches
|
|
Packit |
b80439 |
-- hash membership, pattern match, array intersection, simple equality,
|
|
Packit |
b80439 |
etc. -- against the same switch value.
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
The use of intersection tests against an array reference is particularly
|
|
Packit |
b80439 |
useful for aggregating integral cases:
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
sub classify_digit
|
|
Packit |
b80439 |
{
|
|
Packit |
b80439 |
switch ($_[0]) { case 0 { return 'zero' }
|
|
Packit |
b80439 |
case [2,4,6,8] { return 'even' }
|
|
Packit |
b80439 |
case [1,3,5,7,9] { return 'odd' }
|
|
Packit |
b80439 |
case /[A-F]/i { return 'hex' }
|
|
Packit |
b80439 |
}
|
|
Packit |
b80439 |
}
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
=head2 Allowing fall-through
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
Fall-though (trying another case after one has already succeeded)
|
|
Packit |
b80439 |
is usually a Bad Idea in a switch statement. However, this
|
|
Packit |
b80439 |
is Perl, not a police state, so there I<is> a way to do it, if you must.
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
If a C<case> block executes an untargeted C<next>, control is
|
|
Packit |
b80439 |
immediately transferred to the statement I<after> the C<case> statement
|
|
Packit |
b80439 |
(i.e. usually another case), rather than out of the surrounding
|
|
Packit |
b80439 |
C<switch> block.
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
For example:
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
switch ($val) {
|
|
Packit |
b80439 |
case 1 { handle_num_1(); next } # and try next case...
|
|
Packit |
b80439 |
case "1" { handle_str_1(); next } # and try next case...
|
|
Packit |
b80439 |
case [0..9] { handle_num_any(); } # and we're done
|
|
Packit |
b80439 |
case /\d/ { handle_dig_any(); next } # and try next case...
|
|
Packit |
b80439 |
case /.*/ { handle_str_any(); next } # and try next case...
|
|
Packit |
b80439 |
}
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
If $val held the number C<1>, the above C<switch> block would call the
|
|
Packit |
b80439 |
first three C<handle_...> subroutines, jumping to the next case test
|
|
Packit |
b80439 |
each time it encountered a C<next>. After the third C<case> block
|
|
Packit |
b80439 |
was executed, control would jump to the end of the enclosing
|
|
Packit |
b80439 |
C<switch> block.
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
On the other hand, if $val held C<10>, then only the last two C<handle_...>
|
|
Packit |
b80439 |
subroutines would be called.
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
Note that this mechanism allows the notion of I<conditional fall-through>.
|
|
Packit |
b80439 |
For example:
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
switch ($val) {
|
|
Packit |
b80439 |
case [0..9] { handle_num_any(); next if $val < 7; }
|
|
Packit |
b80439 |
case /\d/ { handle_dig_any(); }
|
|
Packit |
b80439 |
}
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
If an untargeted C<last> statement is executed in a case block, this
|
|
Packit |
b80439 |
immediately transfers control out of the enclosing C<switch> block
|
|
Packit |
b80439 |
(in other words, there is an implicit C<last> at the end of each
|
|
Packit |
b80439 |
normal C<case> block). Thus the previous example could also have been
|
|
Packit |
b80439 |
written:
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
switch ($val) {
|
|
Packit |
b80439 |
case [0..9] { handle_num_any(); last if $val >= 7; next; }
|
|
Packit |
b80439 |
case /\d/ { handle_dig_any(); }
|
|
Packit |
b80439 |
}
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
=head2 Automating fall-through
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
In situations where case fall-through should be the norm, rather than an
|
|
Packit |
b80439 |
exception, an endless succession of terminal C<next>s is tedious and ugly.
|
|
Packit |
b80439 |
Hence, it is possible to reverse the default behaviour by specifying
|
|
Packit |
b80439 |
the string "fallthrough" when importing the module. For example, the
|
|
Packit |
b80439 |
following code is equivalent to the first example in L<"Allowing fall-through">:
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
use Switch 'fallthrough';
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
switch ($val) {
|
|
Packit |
b80439 |
case 1 { handle_num_1(); }
|
|
Packit |
b80439 |
case "1" { handle_str_1(); }
|
|
Packit |
b80439 |
case [0..9] { handle_num_any(); last }
|
|
Packit |
b80439 |
case /\d/ { handle_dig_any(); }
|
|
Packit |
b80439 |
case /.*/ { handle_str_any(); }
|
|
Packit |
b80439 |
}
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
Note the explicit use of a C<last> to preserve the non-fall-through
|
|
Packit |
b80439 |
behaviour of the third case.
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
=head2 Alternative syntax
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
Perl 6 will provide a built-in switch statement with essentially the
|
|
Packit |
b80439 |
same semantics as those offered by Switch.pm, but with a different
|
|
Packit |
b80439 |
pair of keywords. In Perl 6 C<switch> will be spelled C<given>, and
|
|
Packit |
b80439 |
C<case> will be pronounced C<when>. In addition, the C<when> statement
|
|
Packit |
b80439 |
will not require switch or case values to be parenthesized.
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
This future syntax is also (largely) available via the Switch.pm module, by
|
|
Packit |
b80439 |
importing it with the argument C<"Perl6">. For example:
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
use Switch 'Perl6';
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
given ($val) {
|
|
Packit |
b80439 |
when 1 { handle_num_1(); }
|
|
Packit |
b80439 |
when ($str1) { handle_str_1(); }
|
|
Packit |
b80439 |
when [0..9] { handle_num_any(); last }
|
|
Packit |
b80439 |
when /\d/ { handle_dig_any(); }
|
|
Packit |
b80439 |
when /.*/ { handle_str_any(); }
|
|
Packit |
b80439 |
default { handle anything else; }
|
|
Packit |
b80439 |
}
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
Note that scalars still need to be parenthesized, since they would be
|
|
Packit |
b80439 |
ambiguous in Perl 5.
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
Note too that you can mix and match both syntaxes by importing the module
|
|
Packit |
b80439 |
with:
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
use Switch 'Perl5', 'Perl6';
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
=head2 Higher-order Operations
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
One situation in which C<switch> and C<case> do not provide a good
|
|
Packit |
b80439 |
substitute for a cascaded C<if>, is where a switch value needs to
|
|
Packit |
b80439 |
be tested against a series of conditions. For example:
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
sub beverage {
|
|
Packit |
b80439 |
switch (shift) {
|
|
Packit |
b80439 |
case { $_[0] < 10 } { return 'milk' }
|
|
Packit |
b80439 |
case { $_[0] < 20 } { return 'coke' }
|
|
Packit |
b80439 |
case { $_[0] < 30 } { return 'beer' }
|
|
Packit |
b80439 |
case { $_[0] < 40 } { return 'wine' }
|
|
Packit |
b80439 |
case { $_[0] < 50 } { return 'malt' }
|
|
Packit |
b80439 |
case { $_[0] < 60 } { return 'Moet' }
|
|
Packit |
b80439 |
else { return 'milk' }
|
|
Packit |
b80439 |
}
|
|
Packit |
b80439 |
}
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
(This is equivalent to writing C<case (sub { $_[0] < 10 })>, etc.; C<$_[0]>
|
|
Packit |
b80439 |
is the argument to the anonymous subroutine.)
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
The need to specify each condition as a subroutine block is tiresome. To
|
|
Packit |
b80439 |
overcome this, when importing Switch.pm, a special "placeholder"
|
|
Packit |
b80439 |
subroutine named C<__> [sic] may also be imported. This subroutine
|
|
Packit |
b80439 |
converts (almost) any expression in which it appears to a reference to a
|
|
Packit |
b80439 |
higher-order function. That is, the expression:
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
use Switch '__';
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
__ < 2
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
is equivalent to:
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
sub { $_[0] < 2 }
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
With C<__>, the previous ugly case statements can be rewritten:
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
case __ < 10 { return 'milk' }
|
|
Packit |
b80439 |
case __ < 20 { return 'coke' }
|
|
Packit |
b80439 |
case __ < 30 { return 'beer' }
|
|
Packit |
b80439 |
case __ < 40 { return 'wine' }
|
|
Packit |
b80439 |
case __ < 50 { return 'malt' }
|
|
Packit |
b80439 |
case __ < 60 { return 'Moet' }
|
|
Packit |
b80439 |
else { return 'milk' }
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
The C<__> subroutine makes extensive use of operator overloading to
|
|
Packit |
b80439 |
perform its magic. All operations involving __ are overloaded to
|
|
Packit |
b80439 |
produce an anonymous subroutine that implements a lazy version
|
|
Packit |
b80439 |
of the original operation.
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
The only problem is that operator overloading does not allow the
|
|
Packit |
b80439 |
boolean operators C<&&> and C<||> to be overloaded. So a case statement
|
|
Packit |
b80439 |
like this:
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
case 0 <= __ && __ < 10 { return 'digit' }
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
doesn't act as expected, because when it is
|
|
Packit |
b80439 |
executed, it constructs two higher order subroutines
|
|
Packit |
b80439 |
and then treats the two resulting references as arguments to C<&&>:
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
sub { 0 <= $_[0] } && sub { $_[0] < 10 }
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
This boolean expression is inevitably true, since both references are
|
|
Packit |
b80439 |
non-false. Fortunately, the overloaded C<'bool'> operator catches this
|
|
Packit |
b80439 |
situation and flags it as an error.
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
=head1 DEPENDENCIES
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
The module is implemented using Filter::Util::Call and Text::Balanced
|
|
Packit |
b80439 |
and requires both these modules to be installed.
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
=head1 AUTHOR
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
Damian Conway (damian@conway.org). This module is now maintained by
|
|
Packit |
b80439 |
Alexandr Ciornii (alexchorny@gmail.com). Previously was maintained by
|
|
Packit |
b80439 |
Rafael Garcia-Suarez and perl5 porters.
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
=head1 BUGS
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
There are undoubtedly serious bugs lurking somewhere in code this funky :-)
|
|
Packit |
b80439 |
Bug reports and other feedback are most welcome.
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
May create syntax errors in other parts of code.
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
On perl 5.10.x may cause syntax error if "case" is present inside heredoc.
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
In general, use given/when instead. It were introduced in perl 5.10.0.
|
|
Packit |
b80439 |
Perl 5.10.0 was released in 2007.
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
=head1 LIMITATIONS
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
Due to the heuristic nature of Switch.pm's source parsing, the presence of
|
|
Packit |
b80439 |
regexes with embedded newlines that are specified with raw C</.../>
|
|
Packit |
b80439 |
delimiters and don't have a modifier C<//x> are indistinguishable from
|
|
Packit |
b80439 |
code chunks beginning with the division operator C. As a workaround
|
|
Packit |
b80439 |
you must use C<m/.../> or C<m?...?> for such patterns. Also, the presence
|
|
Packit |
b80439 |
of regexes specified with raw C delimiters may cause mysterious
|
|
Packit |
b80439 |
errors. The workaround is to use C<m?...?> instead.
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
Due to the way source filters work in Perl, you can't use Switch inside
|
|
Packit |
b80439 |
an string C<eval>.
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
May not work if sub prototypes are used (RT#33988).
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
Regex captures in when are not available to code.
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
If your source file is longer then 1 million characters and you have a
|
|
Packit |
b80439 |
switch statement that crosses the 1 million (or 2 million, etc.)
|
|
Packit |
b80439 |
character boundary you will get mysterious errors. The workaround is to
|
|
Packit |
b80439 |
use smaller source files.
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
=head1 COPYRIGHT
|
|
Packit |
b80439 |
|
|
Packit |
b80439 |
Copyright (c) 1997-2008, Damian Conway. All Rights Reserved.
|
|
Packit |
b80439 |
This module is free software. It may be used, redistributed
|
|
Packit |
b80439 |
and/or modified under the same terms as Perl itself.
|
|
Packit |
b80439 |
|