X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FSwitch.pm;h=84e28907e6b9a05d540892c7f9718d44919f3998;hb=efc8e943aad385721753037c6be3d8bf9a5c28d8;hp=910002eb92da58650d8ac963eef812a6d624ea9d;hpb=a1813bef83e5be961acf30502b3938f02b111905;p=p5sagit%2Fp5-mst-13.2.git diff --git a/lib/Switch.pm b/lib/Switch.pm index 910002e..84e2890 100644 --- a/lib/Switch.pm +++ b/lib/Switch.pm @@ -4,7 +4,7 @@ use strict; use vars qw($VERSION); use Carp; -$VERSION = '2.03'; +$VERSION = '2.10'; # LOAD FILTERING MODULE... @@ -14,14 +14,14 @@ sub __(); # 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 ($Perl5, $Perl6) = (0,0); sub import { - $DB::single = 1; $fallthrough = grep /\bfallthrough\b/, @_; $offset = (caller)[2]+1; filter_add({}) unless @_>1 && $_[1] eq 'noimport'; @@ -32,6 +32,8 @@ sub import *{"${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; } @@ -46,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; } @@ -59,7 +60,7 @@ use Text::Balanced ':ALL'; sub line { my ($pretext,$offset) = @_; - ($pretext=~tr/\n/\n/)+$offset, + ($pretext=~tr/\n/\n/)+($offset||0); } sub is_block @@ -71,11 +72,22 @@ sub is_block return !$ishash; } + +my $EOP = qr/\n\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 $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) @@ -85,47 +97,68 @@ 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 + $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 ($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)); @@ -133,32 +166,45 @@ 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 .= " " 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 ($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 }/ @@ -168,7 +214,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; @@ -323,7 +369,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 __ @@ -455,8 +502,8 @@ Switch - A switch statement for Perl =head1 VERSION -This document describes version 2.03 of Switch, -released May 15, 2001. +This document describes version 2.10 of Switch, +released Dec 29, 2003. =head1 SYNOPSIS @@ -593,9 +640,9 @@ mechanism: while (<>) { 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 (%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 = <>; @@ -701,6 +748,37 @@ behaviour of the third case. +=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 will be spelled C, and +C will be pronounced C. In addition, the C 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 and C do not provide a good @@ -779,8 +857,22 @@ Damian Conway (damian@conway.org) 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 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-2003, 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.