Change 11509 by jhi@alpha on 2001/07/31 00:37:49
Upgrade to Switch 2.04, now with Perl 6 given+when.
Affected files ...
... //depot/perl/MANIFEST#510 edit
... //depot/perl/lib/Switch.pm#5 edit
... //depot/perl/lib/Switch/Changes#1 add
... //depot/perl/lib/Switch/README#1 add
... //depot/perl/lib/Switch/t/given_when.t#1 add
... //depot/perl/lib/Switch/t/switch_case.t#1 add
... //depot/perl/lib/Switch/test.pl#2 delete
Differences ...
==== //depot/perl/MANIFEST#510 (text) ====
Index: perl/MANIFEST
--- perl/MANIFEST.~1~ Mon Jul 30 18:45:06 2001
+++ perl/MANIFEST Mon Jul 30 18:45:06 2001
@@ -1094,7 +1094,10 @@
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
==== //depot/perl/lib/Switch.pm#5 (text) ====
Index: perl/lib/Switch.pm
--- perl/lib/Switch.pm.~1~ Mon Jul 30 18:45:06 2001
+++ perl/lib/Switch.pm Mon Jul 30 18:45:06 2001
@@ -4,7 +4,7 @@
use vars qw($VERSION);
use Carp;
-$VERSION = '2.03';
+$VERSION = '2.04';
# LOAD FILTERING MODULE...
@@ -14,10 +14,11 @@
# 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 @@
*{"${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 @@
sub line
{
my ($pretext,$offset) = @_;
- ($pretext=~tr/\n/\n/)+$offset,
+ ($pretext=~tr/\n/\n/)+($offset||0);
}
sub is_block
@@ -75,7 +78,8 @@
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 @@
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 @@
$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 @@
$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 @@
$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 @@
=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 @@
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 @@
+=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
==== //depot/perl/lib/Switch/Changes#1 (xtext) ====
Index: perl/lib/Switch/Changes
--- perl/lib/Switch/Changes.~1~ Mon Jul 30 18:45:06 2001
+++ perl/lib/Switch/Changes Mon Jul 30 18:45:06 2001
@@ -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
==== //depot/perl/lib/Switch/README#1 (text) ====
Index: perl/lib/Switch/README
--- perl/lib/Switch/README.~1~ Mon Jul 30 18:45:06 2001
+++ perl/lib/Switch/README Mon Jul 30 18:45:06 2001
@@ -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 ([EMAIL PROTECTED])
+
+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
+
+==============================================================================
==== //depot/perl/lib/Switch/t/given_when.t#1 (text) ====
Index: perl/lib/Switch/t/given_when.t
--- perl/lib/Switch/t/given_when.t.~1~ Mon Jul 30 18:45:06 2001
+++ perl/lib/Switch/t/given_when.t Mon Jul 30 18:45:06 2001
@@ -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;
+ }
+}
==== //depot/perl/lib/Switch/t/switch_case.t#1 (text) ====
Index: perl/lib/Switch/t/switch_case.t
--- perl/lib/Switch/t/switch_case.t.~1~ Mon Jul 30 18:45:06 2001
+++ perl/lib/Switch/t/switch_case.t Mon Jul 30 18:45:06 2001
@@ -0,0 +1,274 @@
+#! /usr/local/bin/perl -w
+
+use Carp;
+use Switch qw(__ 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-case THINGS;
+
+$case->{case} = { case => "case" };
+
+*case = \&case;
+
+# PREMATURE case
+
+eval { case 1 { ok(0) }; ok(0) } || ok(1);
+
+# H.O. FUNCS
+
+switch (__ > 2) {
+
+ case 1 { ok(0) } else { ok(1) }
+ case 2 { ok(0) } else { ok(1) }
+ case 3 { ok(1) } else { ok(0) }
+}
+
+switch (3) {
+
+ eval { case __ <= 1 || __ > 2 { ok(0) } } || ok(1);
+ case __ <= 2 { ok(0) };
+ case __ <= 3 { ok(1) };
+}
+
+# POSSIBLE ARGS: NUMERIC, STRING, ARRAY, HASH, REGEX, CODE
+
+# 1. NUMERIC SWITCH
+
+for (1..3)
+{
+ switch ($_) {
+ # SELF
+ case ($_) { ok(1) } else { ok(0) }
+
+ # NUMERIC
+ case (1) { ok ($_==1) } else { ok($_!=1) }
+ case 1 { ok ($_==1) } else { ok($_!=1) }
+ case (3) { ok ($_==3) } else { ok($_!=3) }
+ case (4) { ok (0) } else { ok(1) }
+ case (2) { ok ($_==2) } else { ok($_!=2) }
+
+ # STRING
+ case ('a') { ok (0) } else { ok(1) }
+ case 'a' { ok (0) } else { ok(1) }
+ case ('3') { ok ($_ == 3) } else { ok($_ != 3) }
+ case ('3.0') { ok (0) } else { ok(1) }
+
+ # ARRAY
+ case ([10,5,1]) { ok ($_==1) } else { ok($_!=1) }
+ case [10,5,1] { ok ($_==1) } else { ok($_!=1) }
+ case (['a','b']) { ok (0) } else { ok(1) }
+ case (['a','b',3]) { ok ($_==3) } else { ok ($_!=3) }
+ case (['a','b',2.0]) { ok ($_==2) } else { ok ($_!=2) }
+ case ([]) { ok (0) } else { ok(1) }
+
+ # HASH
+ case ({}) { ok (0) } else { ok (1) }
+ case {} { ok (0) } else { ok (1) }
+ case {1,1} { ok ($_==1) } else { ok($_!=1) }
+ case ({1=>1, 2=>0}) { ok ($_==1) } else { ok($_!=1) }
+
+ # SUB/BLOCK
+ case (sub {$_[0]==2}) { ok ($_==2) } else { ok($_!=2) }
+ case {$_[0]==2} { ok ($_==2) } else { ok($_!=2) }
+ case {0} { ok (0) } else { ok (1) } # ; -> SUB, NOT HASH
+ case {1} { ok (1) } else { ok (0) } # ; -> SUB, NOT HASH
+ }
+}
+
+
+# 2. STRING SWITCH
+
+for ('a'..'c','1')
+{
+ switch ($_) {
+ # SELF
+ case ($_) { ok(1) } else { ok(0) }
+
+ # NUMERIC
+ case (1) { ok ($_ !~ /[a-c]/) } else { ok ($_ =~ /[a-c]/) }
+ case (1.0) { ok ($_ !~ /[a-c]/) } else { ok ($_ =~ /[a-c]/) }
+
+ # STRING
+ case ('a') { ok ($_ eq 'a') } else { ok($_ ne 'a') }
+ case ('b') { ok ($_ eq 'b') } else { ok($_ ne 'b') }
+ case ('c') { ok ($_ eq 'c') } else { ok($_ ne 'c') }
+ case ('1') { ok ($_ eq '1') } else { ok($_ ne '1') }
+ case ('d') { ok (0) } else { ok (1) }
+
+ # ARRAY
+ case (['a','1']) { ok ($_ eq 'a' || $_ eq '1') }
+ else { ok ($_ ne 'a' && $_ ne '1') }
+ case (['z','2']) { ok (0) } else { ok(1) }
+ case ([]) { ok (0) } else { ok(1) }
+
+ # HASH
+ case ({}) { ok (0) } else { ok (1) }
+ case ({a=>'a', 1=>1, 2=>0}) { ok ($_ eq 'a' || $_ eq '1') }
+ else { ok ($_ ne 'a' && $_ ne '1') }
+
+ # SUB/BLOCK
+ case (sub{$_[0] eq 'a' }) { ok ($_ eq 'a') }
+ else { ok($_ ne 'a') }
+ case {$_[0] eq 'a'} { ok ($_ eq 'a') } else { ok($_ ne 'a') }
+ case {0} { ok (0) } else { ok (1) } # ; -> SUB, NOT HASH
+ case {1} { ok (1) } else { ok (0) } # ; -> SUB, NOT HASH
+ }
+}
+
+
+# 3. ARRAY SWITCH
+
+my $iteration = 0;
+for ([],[1,'a'],[2,'b'])
+{
+ switch ($_) {
+ $iteration++;
+ # SELF
+ case ($_) { ok(1) }
+
+ # NUMERIC
+ case (1) { ok ($iteration==2) } else { ok ($iteration!=2) }
+ case (1.0) { ok ($iteration==2) } else { ok ($iteration!=2) }
+
+ # STRING
+ case ('a') { ok ($iteration==2) } else { ok ($iteration!=2) }
+ case ('b') { ok ($iteration==3) } else { ok ($iteration!=3) }
+ case ('1') { ok ($iteration==2) } else { ok ($iteration!=2) }
+
+ # ARRAY
+ case (['a',2]) { ok ($iteration>=2) } else { ok ($iteration<2) }
+ case ([1,'a']) { ok ($iteration==2) } else { ok($iteration!=2) }
+ case ([]) { ok (0) } else { ok(1) }
+ case ([7..100]) { ok (0) } else { ok(1) }
+
+ # HASH
+ case ({}) { ok (0) } else { ok (1) }
+ case ({a=>'a', 1=>1, 2=>0}) { ok ($iteration==2) }
+ else { ok ($iteration!=2) }
+
+ # SUB/BLOCK
+ case {scalar grep /a/, @_} { ok ($iteration==2) }
+ else { ok ($iteration!=2) }
+ case (sub {scalar grep /a/, @_ }) { ok ($iteration==2) }
+ else { ok ($iteration!=2) }
+ case {0} { ok (0) } else { ok (1) } # ; -> SUB, NOT HASH
+ case {1} { ok (1) } else { ok (0) } # ; -> SUB, NOT HASH
+ }
+}
+
+
+# 4. HASH SWITCH
+
+$iteration = 0;
+for ({},{a=>1,b=>0})
+{
+ switch ($_) {
+ $iteration++;
+
+ # SELF
+ case ($_) { ok(1) } else { ok(0) }
+
+ # NUMERIC
+ case (1) { ok (0) } else { ok (1) }
+ case (1.0) { ok (0) } else { ok (1) }
+
+ # STRING
+ case ('a') { ok ($iteration==2) } else { ok ($iteration!=2) }
+ case ('b') { ok (0) } else { ok (1) }
+ case ('c') { ok (0) } else { ok (1) }
+
+ # ARRAY
+ case (['a',2]) { ok ($iteration==2) }
+ else { ok ($iteration!=2) }
+ case (['b','a']) { ok ($iteration==2) }
+ else { ok ($iteration!=2) }
+ case (['b','c']) { ok (0) } else { ok (1) }
+ case ([]) { ok (0) } else { ok(1) }
+ case ([7..100]) { ok (0) } else { ok(1) }
+
+ # HASH
+ case ({}) { ok (0) } else { ok (1) }
+ case ({a=>'a', 1=>1, 2=>0}) { ok (0) } else { ok (1) }
+
+ # SUB/BLOCK
+ case {$_[0]{a}} { ok ($iteration==2) }
+ else { ok ($iteration!=2) }
+ case (sub {$_[0]{a}}) { ok ($iteration==2) }
+ else { ok ($iteration!=2) }
+ case {0} { ok (0) } else { ok (1) } # ; -> SUB, NOT HASH
+ case {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} )
+{
+ switch ($_) {
+ $iteration++;
+ # SELF
+ case ($_) { ok(1) } else { ok(0) }
+
+ # NUMERIC
+ case (1) { ok ($iteration<=2) } else { ok ($iteration>2) }
+ case (1.0) { ok ($iteration<=2) } else { ok ($iteration>2) }
+ case (1.1) { ok ($iteration==1) } else { ok ($iteration!=1) }
+
+ # STRING
+ case ('a') { ok ($iteration==1) } else { ok ($iteration!=1) }
+ case ('b') { ok ($iteration==1) } else { ok ($iteration!=1) }
+ case ('c') { ok ($iteration==1) } else { ok ($iteration!=1) }
+ case ('1') { ok ($iteration<=2) } else { ok ($iteration>2) }
+
+ # ARRAY
+ case ([1, 'a']) { ok ($iteration<=2) }
+ else { ok ($iteration>2) }
+ case (['b','a']) { ok ($iteration==1) }
+ else { ok ($iteration!=1) }
+ case (['b','c']) { ok ($iteration==1) }
+ else { ok ($iteration!=1) }
+ case ([]) { ok ($iteration==1) } else { ok($iteration!=1) }
+ case ([7..100]) { ok ($iteration==1) }
+ else { ok($iteration!=1) }
+
+ # HASH
+ case ({}) { ok ($iteration==1) } else { ok ($iteration!=1) }
+ case ({a=>'a', 1=>1, 2=>0}) { ok ($iteration<=2) }
+ else { ok ($iteration>2) }
+
+ # SUB/BLOCK
+ case {$_[0]->{a}} { ok (0) } else { ok (1) }
+ case (sub {$_[0]{a}}) { ok (0) } else { ok (1) }
+ case {0} { ok (0) } else { ok (1) } # ; -> SUB, NOT HASH
+ case {1} { ok (0) } else { ok (1) } # ; -> SUB, NOT HASH
+ }
+}
+
+
+# NESTED SWITCHES
+
+for my $count (1..3)
+{
+ switch ([9,"a",11]) {
+ case (qr/\d/) {
+ switch ($count) {
+ case (1) { ok($count==1) }
+ else { ok($count!=1) }
+ case ([5,6]) { ok(0) } else { ok(1) }
+ }
+ }
+ ok(1) case (11);
+ }
+}
End of Patch.
