use vars qw($VERSION);
use Carp;
-$VERSION = '2.01';
+use if $] >= 5.011, 'deprecate';
+$VERSION = '2.14_01';
+
# LOAD FILTERING MODULE...
use Filter::Util::Call;
# CATCH ATTEMPTS TO CALL case OUTSIDE THE SCOPE OF ANY switch
-$::_S_W_I_T_C_H = sub { croak "case statement not in switch block" };
+$::_S_W_I_T_C_H = sub { croak "case/when statement not in switch/given block" };
my $offset;
my $fallthrough;
-my $nextlabel = 1;
+my ($Perl5, $Perl6) = (0,0);
sub import
{
$fallthrough = grep /\bfallthrough\b/, @_;
$offset = (caller)[2]+1;
- filter_add({}) unless @_>1 && $_[1] ne '__';
+ filter_add({}) unless @_>1 && $_[1] eq 'noimport';
my $pkg = caller;
no strict 'refs';
for ( qw( on_defined on_exists ) )
*{"${pkg}::$_"} = \&$_;
}
*{"${pkg}::__"} = \&__ if grep /__/, @_;
+ $Perl6 = 1 if grep(/Perl\s*6/i, @_);
+ $Perl5 = 1 if grep(/Perl\s*5/i, @_) || !grep(/Perl\s*6/i, @_);
1;
}
local $Switch::file = (caller)[1];
my $status = 1;
- $status = filter_read(10_000);
+ $status = filter_read(1_000_000);
return $status if $status<0;
$_ = filter_blocks($_,$offset);
$_ = "# line $offset\n" . $_ if $offset; undef $offset;
- # print STDERR $_;
return $status;
}
sub line
{
my ($pretext,$offset) = @_;
- ($pretext=~tr/\n/\n/)+$offset,
+ ($pretext=~tr/\n/\n/)+($offset||0);
}
sub is_block
return !$ishash;
}
+my $pod_or_DATA = qr/ ^=[A-Za-z] .*? ^=cut (?![A-Za-z]) .*? $
+ | ^__(DATA|END)__\n.*
+ /smx;
+
my $casecounter = 1;
sub filter_blocks
{
my ($source, $line) = @_;
- return $source unless $source =~ /case|switch/;
+ return $source unless $Perl5 && $source =~ /case|switch/
+ || $Perl6 && $source =~ /when|given|default/;
pos $source = 0;
my $text = "";
component: while (pos $source < length $source)
{
- if ($source =~ m/(\G\s*use\s+switch\b)/gc)
+ if ($source =~ m/(\G\s*use\s+Switch\b)/gc)
{
$text .= q{use Switch 'noimport'};
next component;
}
- my @pos = Text::Balanced::_match_quotelike(\$source,qr/\s*/,1,1);
+ my @pos = Text::Balanced::_match_quotelike(\$source,qr/\s*/,1,0);
if (defined $pos[0])
{
- $text .= substr($source,$pos[2],$pos[18]-$pos[2]);
+ my $pre = substr($source,$pos[0],$pos[1]); # matched prefix
+ my $iEol;
+ if( substr($source,$pos[4],$pos[5]) eq '/' && # 1st delimiter
+ substr($source,$pos[2],$pos[3]) eq '' && # no op like 'm'
+ index( substr($source,$pos[16],$pos[17]), 'x' ) == -1 && # no //x
+ ($iEol = index( $source, "\n", $pos[4] )) > 0 &&
+ $iEol < $pos[8] ){ # embedded newlines
+ # If this is a pattern, it isn't compatible with Switch. Backup past 1st '/'.
+ pos( $source ) = $pos[6];
+ $text .= $pre . substr($source,$pos[2],$pos[6]-$pos[2]);
+ } else {
+ $text .= $pre . substr($source,$pos[2],$pos[18]-$pos[2]);
+ }
+ next component;
+ }
+ if ($source =~ m/(\G\s*$pod_or_DATA)/gc) {
+ $text .= $1;
next component;
}
@pos = Text::Balanced::_match_variable(\$source,qr/\s*/);
if (defined $pos[0])
{
+ $text .= " " if $pos[0] < $pos[2];
$text .= substr($source,$pos[0],$pos[4]-$pos[0]);
next component;
}
- if ($source =~ m/\G(\n*)(\s*)switch\b(?=\s*[(])/gc)
+ if ($Perl5 && $source =~ m/\G(\n*)(\s*)(switch)\b(?=\s*[(])/gc
+ || $Perl6 && $source =~ m/\G(\n*)(\s*)(given)\b(?=\s*[(])/gc
+ || $Perl6 && $source =~ m/\G(\n*)(\s*)(given)\b(.*)(?=\{)/gc)
{
+ my $keyword = $3;
+ my $arg = $4;
$text .= $1.$2.'S_W_I_T_C_H: while (1) ';
- @pos = Text::Balanced::_match_codeblock(\$source,qr/\s*/,qr/\(/,qr/\)/,qr/\{/,qr/\}/,undef)
- or do {
- die "Bad switch statement (problem in the parentheses?) near $Switch::file line ", line(substr($source,0,pos $source),$line), "\n";
- };
- my $arg = filter_blocks(substr($source,$pos[0],$pos[4]-$pos[0]),line(substr($source,0,$pos[0]),$line));
+ unless ($arg) {
+ @pos = Text::Balanced::_match_codeblock(\$source,qr/\s*/,qr/\(/,qr/\)/,qr/[[{(<]/,qr/[]})>]/,undef)
+ or do {
+ die "Bad $keyword statement (problem in the parentheses?) near $Switch::file line ", line(substr($source,0,pos $source),$line), "\n";
+ };
+ $arg = filter_blocks(substr($source,$pos[0],$pos[4]-$pos[0]),line(substr($source,0,$pos[0]),$line));
+ }
$arg =~ s {^\s*[(]\s*%} { ( \\\%} ||
$arg =~ s {^\s*[(]\s*m\b} { ( qr} ||
$arg =~ s {^\s*[(]\s*/} { ( qr/} ||
$arg =~ s {^\s*[(]\s*qw} { ( \\qw};
@pos = Text::Balanced::_match_codeblock(\$source,qr/\s*/,qr/\{/,qr/\}/,qr/\{/,qr/\}/,undef)
or do {
- die "Bad switch statement (problem in the code block?) near $Switch::file line ", line(substr($source,0, pos $source), $line), "\n";
+ die "Bad $keyword statement (problem in the code block?) near $Switch::file line ", line(substr($source,0, pos $source), $line), "\n";
};
my $code = filter_blocks(substr($source,$pos[0],$pos[4]-$pos[0]),line(substr($source,0,$pos[0]),$line));
$code =~ s/{/{ local \$::_S_W_I_T_C_H; Switch::switch $arg;/;
$text .= $code . 'continue {last}';
next component;
}
- elsif ($source =~ m/\G(\s*)(case\b)(?!\s*=>)/gc)
+ elsif ($Perl5 && $source =~ m/\G(\s*)(case\b)(?!\s*=>)/gc
+ || $Perl6 && $source =~ m/\G(\s*)(when\b)(?!\s*=>)/gc
+ || $Perl6 && $source =~ m/\G(\s*)(default\b)(?=\s*\{)/gc)
{
- $text .= $1."if (Switch::case";
- if (@pos = Text::Balanced::_match_codeblock(\$source,qr/\s*/,qr/\{/,qr/\}/,qr/\{/,qr/\}/,undef)) {
+ my $keyword = $2;
+ $text .= $1 . ($keyword eq "default"
+ ? "if (1)"
+ : "if (Switch::case");
+
+ if ($keyword eq "default") {
+ # Nothing to do
+ }
+ elsif (@pos = Text::Balanced::_match_codeblock(\$source,qr/\s*/,qr/\{/,qr/\}/,qr/\{/,qr/\}/,undef)) {
my $code = substr($source,$pos[0],$pos[4]-$pos[0]);
- $text .= " sub" if is_block $code;
- $text .= " " . filter_blocks($code,line(substr($source,0,$pos[0]),$line)) . ")";
+ $text .= " " if $pos[0] < $pos[2];
+ $text .= "sub " if is_block $code;
+ $text .= filter_blocks($code,line(substr($source,0,$pos[0]),$line)) . ")";
}
elsif (@pos = Text::Balanced::_match_codeblock(\$source,qr/\s*/,qr/[[(]/,qr/[])]/,qr/[[({]/,qr/[])}]/,undef)) {
my $code = filter_blocks(substr($source,$pos[0],$pos[4]-$pos[0]),line(substr($source,0,$pos[0]),$line));
$code =~ s {^\s*[(]\s*m\b} { ( qr} ||
$code =~ s {^\s*[(]\s*/} { ( qr/} ||
$code =~ s {^\s*[(]\s*qw} { ( \\qw};
- $text .= " $code)";
+ $text .= " " if $pos[0] < $pos[2];
+ $text .= "$code)";
}
- elsif ( @pos = Text::Balanced::_match_quotelike(\$source,qr/\s*/,1,1)) {
+ elsif ($Perl6 && do{@pos = Text::Balanced::_match_variable(\$source,qr/\s*/)}) {
+ my $code = filter_blocks(substr($source,$pos[0],$pos[4]-$pos[0]),line(substr($source,0,$pos[0]),$line));
+ $code =~ s {^\s*%} { \%} ||
+ $code =~ s {^\s*@} { \@};
+ $text .= " " if $pos[0] < $pos[2];
+ $text .= "$code)";
+ }
+ elsif ( @pos = Text::Balanced::_match_quotelike(\$source,qr/\s*/,1,0)) {
my $code = substr($source,$pos[2],$pos[18]-$pos[2]);
$code = filter_blocks($code,line(substr($source,0,$pos[2]),$line));
$code =~ s {^\s*m} { qr} ||
$code =~ s {^\s*/} { qr/} ||
$code =~ s {^\s*qw} { \\qw};
- $text .= " $code)";
+ $text .= " " if $pos[0] < $pos[2];
+ $text .= "$code)";
}
- elsif ($source =~ m/\G\s*(([^\$\@{])[^\$\@{]*)(?=\s*{)/gc) {
+ elsif ($Perl5 && $source =~ m/\G\s*(([^\$\@{])[^\$\@{]*)(?=\s*{)/gc
+ || $Perl6 && $source =~ m/\G\s*([^;{]*)()/gc) {
my $code = filter_blocks($1,line(substr($source,0,pos $source),$line));
$text .= ' \\' if $2 eq '%';
$text .= " $code)";
}
else {
- die "Bad case statement (invalid case value?) near $Switch::file line ", line(substr($source,0,pos $source), $line), "\n";
+ die "Bad $keyword statement (invalid $keyword value?) near $Switch::file line ", line(substr($source,0,pos $source), $line), "\n";
}
- @pos = Text::Balanced::_match_codeblock(\$source,qr/\s*/,qr/\{/,qr/\}/,qr/\{/,qr/\}/,undef)
+ die "Missing opening brace or semi-colon after 'when' value near $Switch::file line ", line(substr($source,0,pos $source), $line), "\n"
+ unless !$Perl6 || $source =~ m/\G(\s*)(?=;|\{)/gc;
+
+ do{@pos = Text::Balanced::_match_codeblock(\$source,qr/\s*/,qr/\{/,qr/\}/,qr/\{/,qr/\}/,undef)}
or do {
if ($source =~ m/\G\s*(?=([};]|\Z))/gc) {
$casecounter++;
next component;
}
- die "Bad case statement (problem in the code block?) near $Switch::file line ", line(substr($source,0,pos $source),$line), "\n";
+ die "Bad $keyword statement (problem in the code block?) near $Switch::file line ", line(substr($source,0,pos $source),$line), "\n";
};
my $code = filter_blocks(substr($source,$pos[0],$pos[4]-$pos[0]),line(substr($source,0,$pos[0]),$line));
$code =~ s/}(?=\s*\Z)/;last S_W_I_T_C_H }/
next component;
}
- $source =~ m/\G(\s*(\w+|#.*\n|\W))/gc;
+ $source =~ m/\G(\s*(-[sm]\s+|\w+|#.*\n|\W))/gc;
$text .= $1;
}
$text;
my @numy;
for my $nextx ( @$x )
{
- my $numx = ref($nextx) || (~$nextx&$nextx) eq 0;
+ my $numx = ref($nextx) || defined $nextx && (~$nextx&$nextx) eq 0;
for my $j ( 0..$#$y )
{
my $nexty = $y->[$j];
- push @numy, ref($nexty) || (~$nexty&$nexty) eq 0
+ push @numy, ref($nexty) || defined $nexty && (~$nexty&$nexty) eq 0
if @numy <= $j;
return 1 if $numx && $numy[$j] && $nextx==$nexty
|| $nextx eq $nexty;
return $s_val->($c_val);
};
}
- elsif ($s_ref eq "" && (~$s_val&$s_val) eq 0) # NUMERIC SCALAR
+ elsif ($s_ref eq "" && defined $s_val && (~$s_val&$s_val) eq 0) # NUMERIC SCALAR
{
$::_S_W_I_T_C_H =
sub { my $c_val = $_[0];
my $c_ref = ref $c_val;
return $s_val == $c_val if $c_ref eq ""
+ && defined $c_val
&& (~$c_val&$c_val) eq 0;
return $s_val eq $c_val if $c_ref eq "";
return in([$s_val],$c_val) if $c_ref eq 'ARRAY';
return 1;
}
-sub case($) { $::_S_W_I_T_C_H->(@_); }
+sub case($) { local $SIG{__WARN__} = \&carp;
+ $::_S_W_I_T_C_H->(@_); }
# IMPLEMENT __
=head1 VERSION
-This document describes version 2.01 of Switch,
-released January 9, 2001.
+This document describes version 2.14 of Switch,
+released Dec 29, 2008.
=head1 SYNOPSIS
- use Switch;
+ use Switch;
- switch ($val) {
-
- case 1 { print "number 1" }
- case "a" { print "string a" }
- case [1..10,42] { print "number in list" }
- case (@array) { print "number in list" }
- case /\w+/ { print "pattern" }
- case qr/\w+/ { print "pattern" }
- case (%hash) { print "entry in hash" }
- case (\%hash) { print "entry in hash" }
- case (\&sub) { print "arg to subroutine" }
- else { print "previous case not true" }
- }
+ switch ($val) {
+ case 1 { print "number 1" }
+ case "a" { print "string a" }
+ case [1..10,42] { print "number in list" }
+ case (\@array) { print "number in list" }
+ case /\w+/ { print "pattern" }
+ case qr/\w+/ { print "pattern" }
+ case (\%hash) { print "entry in hash" }
+ case (\&sub) { print "arg to subroutine" }
+ else { print "previous case not true" }
+ }
=head1 BACKGROUND
one could test for the existence of a single key in a series of hashes
(C<match if exists $c-E<gt>{$s}>).
-As L<perltodo> observes, a Perl case mechanism must support all these
-"ways to do it".
-
-
=head1 DESCRIPTION
The Switch.pm module implements a generalized case mechanism that covers
-the numerous possible combinations of switch and case values described above.
+most (but not all) of the numerous possible combinations of switch and case
+values described above.
The module augments the standard Perl syntax with two new control
statements: C<switch> and C<case>. The C<switch> statement takes a
%special = ( woohoo => 1, d'oh => 1 );
while (<>) {
+ chomp;
switch ($_) {
-
- case %special { print "homer\n"; } # if $special{$_}
- case /a-z/i { print "alpha\n"; } # if $_ =~ /a-z/i
- case [1..9] { print "small num\n"; } # if $_ in [1..9]
-
- case { $_[0] >= 10 } { # if $_ >= 10
- my $age = <>;
- switch (sub{ $_[0] < $age } ) {
-
- case 20 { print "teens\n"; } # if 20 < $age
- case 30 { print "twenties\n"; } # if 30 < $age
- else { print "history\n"; }
- }
- }
-
+ case (%special) { print "homer\n"; } # if $special{$_}
+ case /[a-z]/i { print "alpha\n"; } # if $_ =~ /a-z/i
+ case [1..9] { print "small num\n"; } # if $_ in [1..9]
+ case { $_[0] >= 10 } { print "big num\n"; } # if $_ >= 10
print "must be punctuation\n" case /\W/; # if $_ ~= /\W/
+ }
}
Note that C<switch>es can be nested within C<case> (or any other) blocks,
{
switch ($_[0]) { case 0 { return 'zero' }
case [2,4,6,8] { return 'even' }
- case [1,3,4,7,9] { return 'odd' }
+ case [1,3,5,7,9] { return 'odd' }
case /[A-F]/i { return 'hex' }
}
}
is usually a Bad Idea in a switch statement. However, this
is Perl, not a police state, so there I<is> a way to do it, if you must.
-If a C<case> block executes an untargetted C<next>, control is
+If a C<case> block executes an untargeted C<next>, control is
immediately transferred to the statement I<after> the C<case> statement
(i.e. usually another case), rather than out of the surrounding
C<switch> block.
If $val held the number C<1>, the above C<switch> block would call the
first three C<handle_...> subroutines, jumping to the next case test
-each time it encountered a C<next>. After the thrid C<case> block
+each time it encountered a C<next>. After the third C<case> block
was executed, control would jump to the end of the enclosing
C<switch> block.
case /\d/ { handle_dig_any(); }
}
-If an untargetted C<last> statement is executed in a case block, this
+If an untargeted C<last> statement is executed in a case block, this
immediately transfers control out of the enclosing C<switch> block
(in other words, there is an implicit C<last> at the end of each
normal C<case> block). Thus the previous example could also have been
+=head2 Alternative syntax
+
+Perl 6 will provide a built-in switch statement with essentially the
+same semantics as those offered by Switch.pm, but with a different
+pair of keywords. In Perl 6 C<switch> will be spelled C<given>, and
+C<case> will be pronounced C<when>. In addition, the C<when> statement
+will not require switch or case values to be parenthesized.
+
+This future syntax is also (largely) available via the Switch.pm module, by
+importing it with the argument C<"Perl6">. For example:
+
+ use Switch 'Perl6';
+
+ given ($val) {
+ when 1 { handle_num_1(); }
+ when ($str1) { handle_str_1(); }
+ when [0..9] { handle_num_any(); last }
+ when /\d/ { handle_dig_any(); }
+ when /.*/ { handle_str_any(); }
+ default { handle anything else; }
+ }
+
+Note that scalars still need to be parenthesized, since they would be
+ambiguous in Perl 5.
+
+Note too that you can mix and match both syntaxes by importing the module
+with:
+
+ use Switch 'Perl5', 'Perl6';
+
+
=head2 Higher-order Operations
One situation in which C<switch> and C<case> do not provide a good
sub beverage {
switch (shift) {
-
- case sub { $_[0] < 10 } { return 'milk' }
- case sub { $_[0] < 20 } { return 'coke' }
- case sub { $_[0] < 30 } { return 'beer' }
- case sub { $_[0] < 40 } { return 'wine' }
- case sub { $_[0] < 50 } { return 'malt' }
- case sub { $_[0] < 60 } { return 'Moet' }
- else { return 'milk' }
+ case { $_[0] < 10 } { return 'milk' }
+ case { $_[0] < 20 } { return 'coke' }
+ case { $_[0] < 30 } { return 'beer' }
+ case { $_[0] < 40 } { return 'wine' }
+ case { $_[0] < 50 } { return 'malt' }
+ case { $_[0] < 60 } { return 'Moet' }
+ else { return 'milk' }
}
}
+(This is equivalent to writing C<case (sub { $_[0] < 10 })>, etc.; C<$_[0]>
+is the argument to the anonymous subroutine.)
+
The need to specify each condition as a subroutine block is tiresome. To
overcome this, when importing Switch.pm, a special "placeholder"
subroutine named C<__> [sic] may also be imported. This subroutine
use Switch '__';
- __ < 2 + __
+ __ < 2
is equivalent to:
- sub { $_[0] < 2 + $_[1] }
+ sub { $_[0] < 2 }
With C<__>, the previous ugly case statements can be rewritten:
This boolean expression is inevitably true, since both references are
non-false. Fortunately, the overloaded C<'bool'> operator catches this
-situation and flags it as a error.
+situation and flags it as an error.
=head1 DEPENDENCIES
=head1 AUTHOR
-Damian Conway (damian@conway.org)
+Damian Conway (damian@conway.org). This module is now maintained by Rafael
+Garcia-Suarez (rgarciasuarez@gmail.com) and more generally by the Perl 5
+Porters (perl5-porters@perl.org), as part of the Perl core.
=head1 BUGS
There are undoubtedly serious bugs lurking somewhere in code this funky :-)
Bug reports and other feedback are most welcome.
+=head1 LIMITATIONS
+
+Due to the heuristic nature of Switch.pm's source parsing, the presence of
+regexes with embedded newlines that are specified with raw C</.../>
+delimiters and don't have a modifier C<//x> are indistinguishable from
+code chunks beginning with the division operator C</>. As a workaround
+you must use C<m/.../> or C<m?...?> for such patterns. Also, the presence
+of regexes specified with raw C<?...?> delimiters may cause mysterious
+errors. The workaround is to use C<m?...?> instead.
+
+Due to the way source filters work in Perl, you can't use Switch inside
+an string C<eval>.
+
+If your source file is longer then 1 million characters and you have a
+switch statement that crosses the 1 million (or 2 million, etc.)
+character boundary you will get mysterious errors. The workaround is to
+use smaller source files.
+
=head1 COPYRIGHT
-Copyright (c) 1997-2000, Damian Conway. All Rights Reserved.
-This module is free software; you can redistribute it and/or
-modify it under the same terms as Perl itself.
+ Copyright (c) 1997-2008, Damian Conway. All Rights Reserved.
+ This module is free software. It may be used, redistributed
+ and/or modified under the same terms as Perl itself.
https://perl5.git.perl.org / perl5.git / blobdiff