X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FSwitch.pm;h=d7658bac8493a938111bf9f4a24a06c4401bbcdc;hb=6d22e8706322aab39974e6e5d217f2b611af183d;hp=405d201f47c7e4820454d7e933c2fea6982f7c17;hpb=74a6a946f443cceaa57e35bcb28c0276e02a0ae8;p=p5sagit%2Fp5-mst-13.2.git diff --git a/lib/Switch.pm b/lib/Switch.pm index 405d201..d7658ba 100644 --- a/lib/Switch.pm +++ b/lib/Switch.pm @@ -4,7 +4,7 @@ use strict; use vars qw($VERSION); use Carp; -$VERSION = '2.04'; +$VERSION = '2.13'; # LOAD FILTERING MODULE... @@ -22,7 +22,6 @@ my ($Perl5, $Perl6) = (0,0); sub import { - $DB::single = 1; $fallthrough = grep /\bfallthrough\b/, @_; $offset = (caller)[2]+1; filter_add({}) unless @_>1 && $_[1] eq 'noimport'; @@ -49,11 +48,10 @@ sub filter 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; } @@ -74,12 +72,22 @@ sub is_block return !$ishash; } + +my $EOP = qr/\n|\Z/; +my $CUT = qr/\n=cut.*$EOP/; +my $pod_or_DATA = qr/ ^=(?:head[1-4]|item) .*? $CUT + | ^=pod .*? $CUT + | ^=for .*? $EOP + | ^=begin \s* (\S+) .*? \n=end \s* \1 .*? $EOP + | ^__(DATA|END)__\n.* + /smx; + my $casecounter = 1; sub filter_blocks { my ($source, $line) = @_; return $source unless $Perl5 && $source =~ /case|switch/ - || $Perl6 && $source =~ /when|given/; + || $Perl6 && $source =~ /when|given|default/; pos $source = 0; my $text = ""; component: while (pos $source < length $source) @@ -89,29 +97,49 @@ sub filter_blocks $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) { next component; } @pos = Text::Balanced::_match_variable(\$source,qr/\s*/); if (defined $pos[0]) { - $text .= " " . substr($source,$pos[0],$pos[4]-$pos[0]); + $text .= " " if $pos[0] < $pos[2]; + $text .= substr($source,$pos[0],$pos[4]-$pos[0]); next component; } 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(?=\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 $keyword 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/} || @@ -126,14 +154,22 @@ sub filter_blocks next component; } elsif ($Perl5 && $source =~ m/\G(\s*)(case\b)(?!\s*=>)/gc - || $Perl6 && $source =~ m/\G(\s*)(when\b)(?!\s*=>)/gc) + || $Perl6 && $source =~ m/\G(\s*)(when\b)(?!\s*=>)/gc + || $Perl6 && $source =~ m/\G(\s*)(default\b)(?=\s*\{)/gc) { my $keyword = $2; - $text .= $1."if (Switch::case"; - if (@pos = Text::Balanced::_match_codeblock(\$source,qr/\s*/,qr/\{/,qr/\}/,qr/\{/,qr/\}/,undef)) { + $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)); @@ -141,24 +177,27 @@ sub filter_blocks $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 ($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 .= " $code)"; + $text .= " " if $pos[0] < $pos[2]; + $text .= "$code)"; } - elsif ( @pos = Text::Balanced::_match_quotelike(\$source,qr/\s*/,1,1)) { + 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 ($Perl5 && $source =~ m/\G\s*(([^\$\@{])[^\$\@{]*)(?=\s*{)/gc - || $Perl6 && $source =~ m/\G\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)"; @@ -167,8 +206,8 @@ sub filter_blocks die "Bad $keyword statement (invalid $keyword value?) near $Switch::file line ", line(substr($source,0,pos $source), $line), "\n"; } - die "Missing colon 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; + 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 { @@ -186,7 +225,7 @@ sub filter_blocks next component; } - $source =~ m/\G(\s*(\w+|#.*\n|\W))/gc; + $source =~ m/\G(\s*(-[sm]\s+|\w+|#.*\n|\W))/gc; $text .= $1; } $text; @@ -341,7 +380,8 @@ sub switch(;$) return 1; } -sub case($) { $::_S_W_I_T_C_H->(@_); } +sub case($) { local $SIG{__WARN__} = \&carp; + $::_S_W_I_T_C_H->(@_); } # IMPLEMENT __ @@ -473,26 +513,25 @@ Switch - A switch statement for Perl =head1 VERSION -This document describes version 2.04 of Switch, -released July 30, 2001. +This document describes version 2.11 of Switch, +released Nov 22, 2006. =head1 SYNOPSIS - 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" } - } + 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" } + } =head1 BACKGROUND @@ -562,14 +601,11 @@ the existence of a series of keys (C{$c}>), one could test for the existence of a single key in a series of hashes (C{$s}>). -As L 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 and C. The C statement takes a @@ -609,23 +645,14 @@ mechanism: %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 /[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 { $_[0] >= 10 } { print "big num\n"; } # if $_ >= 10 print "must be punctuation\n" case /\W/; # if $_ ~= /\W/ + } } Note that Ces can be nested within C (or any other) blocks, @@ -640,7 +667,7 @@ useful for aggregating integral cases: { 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' } } } @@ -652,7 +679,7 @@ Fall-though (trying another case after one has already succeeded) is usually a Bad Idea in a switch statement. However, this is Perl, not a police state, so there I a way to do it, if you must. -If a C block executes an untargetted C, control is +If a C block executes an untargeted C, control is immediately transferred to the statement I the C statement (i.e. usually another case), rather than out of the surrounding C block. @@ -669,7 +696,7 @@ For example: If $val held the number C<1>, the above C block would call the first three C subroutines, jumping to the next case test -each time it encountered a C. After the thrid C block +each time it encountered a C. After the third C block was executed, control would jump to the end of the enclosing C block. @@ -684,7 +711,7 @@ For example: case /\d/ { handle_dig_any(); } } -If an untargetted C statement is executed in a case block, this +If an untargeted C statement is executed in a case block, this immediately transfers control out of the enclosing C block (in other words, there is an implicit C at the end of each normal C block). Thus the previous example could also have been @@ -723,25 +750,28 @@ behaviour of the third case. 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 with be spelled C, and +pair of keywords. In Perl 6 C will be spelled C, and C will be pronounced C. In addition, the C statement -will use a colon between its case value and its block (removing the -need to parenthesize variables. +will not require switch or case values to be parenthesized. -This future syntax is also available via the Switch.pm module, by +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(); } + 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 you can mix and match both syntaxes by importing the module +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'; @@ -755,17 +785,19 @@ be tested against a series of conditions. For example: 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, 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 @@ -774,11 +806,11 @@ higher-order function. That is, the expression: use Switch '__'; - __ < 2 + __ + __ < 2 is equivalent to: - sub { $_[0] < 2 + $_[1] } + sub { $_[0] < 2 } With C<__>, the previous ugly case statements can be rewritten: @@ -818,15 +850,34 @@ and requires both these modules to be installed. =head1 AUTHOR -Damian Conway (damian@conway.org) +Damian Conway (damian@conway.org). The maintainer of this module is now Rafael +Garcia-Suarez (rgarciasuarez@gmail.com). =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 are indistinguishable from +code chunks beginning with the division operator C. As a workaround +you must use C or C for such patterns. Also, the presence +of regexes specified with raw C delimiters may cause mysterious +errors. The workaround is to use C instead. + +Due to the way source filters work in Perl, you can't use Switch inside +an string C. + +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-2006, 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.