diff options
-rw-r--r-- | MANIFEST | 5 | ||||
-rw-r--r-- | lib/Switch.pm | 80 | ||||
-rwxr-xr-x | lib/Switch/Changes | 50 | ||||
-rw-r--r-- | lib/Switch/README | 47 | ||||
-rw-r--r-- | lib/Switch/t/given_when.t | 274 | ||||
-rw-r--r-- | lib/Switch/t/switch_case.t (renamed from lib/Switch/test.pl) | 5 |
6 files changed, 439 insertions, 22 deletions
@@ -1094,7 +1094,10 @@ lib/strict.t See if strictures work lib/subs.pm Declare overriding subs lib/subs.t See if subroutine pseudo-importation works lib/Switch.pm Switch for Perl -lib/Switch/test.pl Test whether switch works +lib/Switch/Changes Switch for Perl +lib/Switch/README Switch for Perl +lib/Switch/t/given_when.t See if Perl 6 given (switch) works +lib/Switch/t/switch_case.t See if Perl 5 switch works lib/Symbol.pm Symbol table manipulation routines lib/Symbol.t See if Symbol works lib/syslog.pl Perl library supporting syslogging diff --git a/lib/Switch.pm b/lib/Switch.pm index 910002eb92..405d201f47 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.04'; # LOAD FILTERING MODULE... @@ -14,10 +14,11 @@ 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 { @@ -32,6 +33,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; } @@ -59,7 +62,7 @@ use Text::Balanced ':ALL'; sub line { my ($pretext,$offset) = @_; - ($pretext=~tr/\n/\n/)+$offset, + ($pretext=~tr/\n/\n/)+($offset||0); } sub is_block @@ -75,7 +78,8 @@ 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/; pos $source = 0; my $text = ""; component: while (pos $source < length $source) @@ -98,12 +102,14 @@ sub filter_blocks 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) { + my $keyword = $3; $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"; + 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)); $arg =~ s {^\s*[(]\s*%} { ( \\\%} || @@ -112,15 +118,17 @@ sub filter_blocks $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) { + my $keyword = $2; $text .= $1."if (Switch::case"; if (@pos = Text::Balanced::_match_codeblock(\$source,qr/\s*/,qr/\{/,qr/\}/,qr/\{/,qr/\}/,undef)) { my $code = substr($source,$pos[0],$pos[4]-$pos[0]); @@ -135,6 +143,12 @@ sub filter_blocks $code =~ s {^\s*[(]\s*qw} { ( \\qw}; $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)"; + } elsif ( @pos = Text::Balanced::_match_quotelike(\$source,qr/\s*/,1,1)) { my $code = substr($source,$pos[2],$pos[18]-$pos[2]); $code = filter_blocks($code,line(substr($source,0,$pos[2]),$line)); @@ -143,22 +157,26 @@ sub filter_blocks $code =~ s {^\s*qw} { \\qw}; $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 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; + + 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 }/ @@ -455,8 +473,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.04 of Switch, +released July 30, 2001. =head1 SYNOPSIS @@ -593,9 +611,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 +719,34 @@ 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<switch> with be spelled C<given>, and +C<case> will be pronounced C<when>. In addition, the C<when> statement +will use a colon between its case value and its block (removing the +need to parenthesize variables. + +This future syntax is also 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(); } + } + +Note 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 diff --git a/lib/Switch/Changes b/lib/Switch/Changes new file mode 100755 index 0000000000..2f74241474 --- /dev/null +++ b/lib/Switch/Changes @@ -0,0 +1,50 @@ +Revision history for Perl extension Switch. + +0.01 Wed Dec 15 05:58:01 1999 + - original version; created by h2xs 1.18 + + + +2.00 Mon Jan 8 17:12:20 2001 + + - Complete revamp (including syntactic and semantic changes) + in line with proposed Perl 6 semantics. + + +2.01 Tue Jan 9 07:19:02 2001 + + - Fixed infinite loop problem under 5.6.0 caused by change + in goto semantics between 5.00503 and 5.6.0 + (thanks Scott!) + + + +2.02 Thu Apr 26 12:01:06 2001 + + - Fixed unwarranted whitespace squeezing before quotelikes + (thanks Ray) + + - Fixed pernicious bug that cause switch to fail to recognize + certain complex switch values + + +2.03 Tue May 15 09:34:11 2001 + + - Fixed bug in 'fallthrough' specifications. + + - Silenced gratuitous warnings for undefined values as + switch or case values + + +2.04 Mon Jul 30 13:17:35 2001 + + - Suppressed 'undef value' warning under -w (thanks Michael) + + - Added support for Perl 6 given..when syntax + + +2.04 Mon Jul 30 13:17:35 2001 + + - Suppressed 'undef value' warning under -w (thanks Michael) + + - Added support for Perl 6 given..when syntax diff --git a/lib/Switch/README b/lib/Switch/README new file mode 100644 index 0000000000..d5a7d28989 --- /dev/null +++ b/lib/Switch/README @@ -0,0 +1,47 @@ +============================================================================== + Release of version 2.04 of Switch +============================================================================== + + +NAME + Switch - A switch statement for Perl + +DESCRIPTION + + Switch.pm provides the syntax and semantics for an explicit case + mechanism for Perl. The syntax is minimal, introducing only the + keywords C<switch> and C<case> and conforming to the general pattern + of existing Perl control structures. The semantics are particularly + rich, allowing any one (or more) of nearly 30 forms of matching to + be used when comparing a switch value with its various cases. + +AUTHOR + Damian Conway (damian@conway.org) + +COPYRIGHT + Copyright (c) 1997-2000, Damian Conway. All Rights Reserved. This module + is free software. It may be used, redistributed and/or modified under + the terms of the Perl Artistic License (see + http://www.perl.com/perl/misc/Artistic.html) + + +============================================================================== + +CHANGES IN VERSION 2.04 + + + - Suppressed 'undef value' warning under -w (thanks Michael) + + - Added support for Perl 6 given..when syntax + + +============================================================================== + +AVAILABILITY + +Switch has been uploaded to the CPAN +and is also available from: + + http://www.csse.monash.edu.au/~damian/CPAN/Switch.tar.gz + +============================================================================== diff --git a/lib/Switch/t/given_when.t b/lib/Switch/t/given_when.t new file mode 100644 index 0000000000..57e72de38d --- /dev/null +++ b/lib/Switch/t/given_when.t @@ -0,0 +1,274 @@ +#! /usr/local/bin/perl -w + +use Carp; +use Switch qw(Perl6 __ fallthrough); + +my($C,$M);sub ok{$C++;$M.=$_[0]?"ok $C\n":"not ok $C (line ".(caller)[2].")\n"} +END{print"1..$C\n$M"} + +# NON-when THINGS; + +$when->{when} = { when => "when" }; + +*when = \&when; + +# PREMATURE when + +eval { when 1: { ok(0) }; ok(0) } || ok(1); + +# H.O. FUNCS + +given (__ > 2) { + + when 1: { ok(0) } else { ok(1) } + when 2: { ok(0) } else { ok(1) } + when 3: { ok(1) } else { ok(0) } +} + +given (3) { + + eval { when __ <= 1 || __ > 2: { ok(0) } } || ok(1); + when __ <= 2: { ok(0) }; + when __ <= 3: { ok(1) }; +} + +# POSSIBLE ARGS: NUMERIC, STRING, ARRAY, HASH, REGEX, CODE + +# 1. NUMERIC SWITCH + +for (1..3) +{ + given ($_) { + # SELF + when $_: { ok(1) } else { ok(0) } + + # NUMERIC + when 1: { ok ($_==1) } else { ok($_!=1) } + when (1): { ok ($_==1) } else { ok($_!=1) } + when 3: { ok ($_==3) } else { ok($_!=3) } + when (4): { ok (0) } else { ok(1) } + when (2): { ok ($_==2) } else { ok($_!=2) } + + # STRING + when ('a'): { ok (0) } else { ok(1) } + when 'a' : { ok (0) } else { ok(1) } + when ('3'): { ok ($_ == 3) } else { ok($_ != 3) } + when ('3.0'): { ok (0) } else { ok(1) } + + # ARRAY + when ([10,5,1]): { ok ($_==1) } else { ok($_!=1) } + when [10,5,1]: { ok ($_==1) } else { ok($_!=1) } + when (['a','b']): { ok (0) } else { ok(1) } + when (['a','b',3]): { ok ($_==3) } else { ok ($_!=3) } + when (['a','b',2.0]) : { ok ($_==2) } else { ok ($_!=2) } + when ([]) : { ok (0) } else { ok(1) } + + # HASH + when ({}) : { ok (0) } else { ok (1) } + when {} : { ok (0) } else { ok (1) } + when {1,1} : { ok ($_==1) } else { ok($_!=1) } + when ({1=>1, 2=>0}) : { ok ($_==1) } else { ok($_!=1) } + + # SUB/BLOCK + when (sub {$_[0]==2}) : { ok ($_==2) } else { ok($_!=2) } + when {$_[0]==2} : { ok ($_==2) } else { ok($_!=2) } + when {0} : { ok (0) } else { ok (1) } # ; -> SUB, NOT HASH + when {1} : { ok (1) } else { ok (0) } # ; -> SUB, NOT HASH + } +} + + +# 2. STRING SWITCH + +for ('a'..'c','1') +{ + given ($_) { + # SELF + when ($_) : { ok(1) } else { ok(0) } + + # NUMERIC + when (1) : { ok ($_ !~ /[a-c]/) } else { ok ($_ =~ /[a-c]/) } + when (1.0) : { ok ($_ !~ /[a-c]/) } else { ok ($_ =~ /[a-c]/) } + + # STRING + when ('a') : { ok ($_ eq 'a') } else { ok($_ ne 'a') } + when ('b') : { ok ($_ eq 'b') } else { ok($_ ne 'b') } + when ('c') : { ok ($_ eq 'c') } else { ok($_ ne 'c') } + when ('1') : { ok ($_ eq '1') } else { ok($_ ne '1') } + when ('d') : { ok (0) } else { ok (1) } + + # ARRAY + when (['a','1']) : { ok ($_ eq 'a' || $_ eq '1') } + else { ok ($_ ne 'a' && $_ ne '1') } + when (['z','2']) : { ok (0) } else { ok(1) } + when ([]) : { ok (0) } else { ok(1) } + + # HASH + when ({}) : { ok (0) } else { ok (1) } + when ({a=>'a', 1=>1, 2=>0}) : { ok ($_ eq 'a' || $_ eq '1') } + else { ok ($_ ne 'a' && $_ ne '1') } + + # SUB/BLOCK + when (sub{$_[0] eq 'a' }) : { ok ($_ eq 'a') } + else { ok($_ ne 'a') } + when {$_[0] eq 'a'} : { ok ($_ eq 'a') } else { ok($_ ne 'a') } + when {0} : { ok (0) } else { ok (1) } # ; -> SUB, NOT HASH + when {1} : { ok (1) } else { ok (0) } # ; -> SUB, NOT HASH + } +} + + +# 3. ARRAY SWITCH + +my $iteration = 0; +for ([],[1,'a'],[2,'b']) +{ + given ($_) { + $iteration++; + # SELF + when ($_) : { ok(1) } + + # NUMERIC + when (1) : { ok ($iteration==2) } else { ok ($iteration!=2) } + when (1.0) : { ok ($iteration==2) } else { ok ($iteration!=2) } + + # STRING + when ('a') : { ok ($iteration==2) } else { ok ($iteration!=2) } + when ('b') : { ok ($iteration==3) } else { ok ($iteration!=3) } + when ('1') : { ok ($iteration==2) } else { ok ($iteration!=2) } + + # ARRAY + when (['a',2]) : { ok ($iteration>=2) } else { ok ($iteration<2) } + when ([1,'a']) : { ok ($iteration==2) } else { ok($iteration!=2) } + when ([]) : { ok (0) } else { ok(1) } + when ([7..100]) : { ok (0) } else { ok(1) } + + # HASH + when ({}) : { ok (0) } else { ok (1) } + when ({a=>'a', 1=>1, 2=>0}) : { ok ($iteration==2) } + else { ok ($iteration!=2) } + + # SUB/BLOCK + when {scalar grep /a/, @_} : { ok ($iteration==2) } + else { ok ($iteration!=2) } + when (sub {scalar grep /a/, @_ }) : { ok ($iteration==2) } + else { ok ($iteration!=2) } + when {0} : { ok (0) } else { ok (1) } # ; -> SUB, NOT HASH + when {1} : { ok (1) } else { ok (0) } # ; -> SUB, NOT HASH + } +} + + +# 4. HASH SWITCH + +$iteration = 0; +for ({},{a=>1,b=>0}) +{ + given ($_) { + $iteration++; + + # SELF + when ($_) : { ok(1) } else { ok(0) } + + # NUMERIC + when (1) : { ok (0) } else { ok (1) } + when (1.0) : { ok (0) } else { ok (1) } + + # STRING + when ('a') : { ok ($iteration==2) } else { ok ($iteration!=2) } + when ('b') : { ok (0) } else { ok (1) } + when ('c') : { ok (0) } else { ok (1) } + + # ARRAY + when (['a',2]) : { ok ($iteration==2) } + else { ok ($iteration!=2) } + when (['b','a']) : { ok ($iteration==2) } + else { ok ($iteration!=2) } + when (['b','c']) : { ok (0) } else { ok (1) } + when ([]) : { ok (0) } else { ok(1) } + when ([7..100]) : { ok (0) } else { ok(1) } + + # HASH + when ({}) : { ok (0) } else { ok (1) } + when ({a=>'a', 1=>1, 2=>0}) : { ok (0) } else { ok (1) } + + # SUB/BLOCK + when {$_[0]{a}} : { ok ($iteration==2) } + else { ok ($iteration!=2) } + when (sub {$_[0]{a}}) : { ok ($iteration==2) } + else { ok ($iteration!=2) } + when {0} : { ok (0) } else { ok (1) } # ; -> SUB, NOT HASH + when {1} : { ok (1) } else { ok (0) } # ; -> SUB, NOT HASH + } +} + + +# 5. CODE SWITCH + +$iteration = 0; +for ( sub {1}, + sub { return 0 unless @_; + my ($data) = @_; + my $type = ref $data; + return $type eq 'HASH' && $data->{a} + || $type eq 'Regexp' && 'a' =~ /$data/ + || $type eq "" && $data eq '1'; + }, + sub {0} ) +{ + given ($_) { + $iteration++; + # SELF + when ($_) : { ok(1) } else { ok(0) } + + # NUMERIC + when (1) : { ok ($iteration<=2) } else { ok ($iteration>2) } + when (1.0) : { ok ($iteration<=2) } else { ok ($iteration>2) } + when (1.1) : { ok ($iteration==1) } else { ok ($iteration!=1) } + + # STRING + when ('a') : { ok ($iteration==1) } else { ok ($iteration!=1) } + when ('b') : { ok ($iteration==1) } else { ok ($iteration!=1) } + when ('c') : { ok ($iteration==1) } else { ok ($iteration!=1) } + when ('1') : { ok ($iteration<=2) } else { ok ($iteration>2) } + + # ARRAY + when ([1, 'a']) : { ok ($iteration<=2) } + else { ok ($iteration>2) } + when (['b','a']) : { ok ($iteration==1) } + else { ok ($iteration!=1) } + when (['b','c']) : { ok ($iteration==1) } + else { ok ($iteration!=1) } + when ([]) : { ok ($iteration==1) } else { ok($iteration!=1) } + when ([7..100]) : { ok ($iteration==1) } + else { ok($iteration!=1) } + + # HASH + when ({}) : { ok ($iteration==1) } else { ok ($iteration!=1) } + when ({a=>'a', 1=>1, 2=>0}) : { ok ($iteration<=2) } + else { ok ($iteration>2) } + + # SUB/BLOCK + when {$_[0]->{a}} : { ok (0) } else { ok (1) } + when (sub {$_[0]{a}}) : { ok (0) } else { ok (1) } + when {0} : { ok (0) } else { ok (1) } # ; -> SUB, NOT HASH + when {1} : { ok (0) } else { ok (1) } # ; -> SUB, NOT HASH + } +} + + +# NESTED SWITCHES + +for my $count (1..3) +{ + given ([9,"a",11]) { + when (qr/\d/) : { + given ($count) { + when (1) : { ok($count==1) } + else { ok($count!=1) } + when ([5,6]) : { ok(0) } else { ok(1) } + } + } + ok(1) when 11; + } +} diff --git a/lib/Switch/test.pl b/lib/Switch/t/switch_case.t index d1a8af191f..7b147c0d9e 100644 --- a/lib/Switch/test.pl +++ b/lib/Switch/t/switch_case.t @@ -1,7 +1,4 @@ -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} +#! /usr/local/bin/perl -w use Carp; use Switch qw(__ fallthrough); |