From: Nicholas Clark Date: Mon, 19 Apr 2010 19:35:54 +0000 (+0100) Subject: Remove Switch from the core distribution. Get it from CPAN now. X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=75108aefc8b50fcf2f053da2df34756c7b269a1f;p=p5sagit%2Fp5-mst-13.2.git Remove Switch from the core distribution. Get it from CPAN now. --- diff --git a/MANIFEST b/MANIFEST index 8024fae..7195508 100644 --- a/MANIFEST +++ b/MANIFEST @@ -2811,15 +2811,6 @@ dist/Storable/t/tied.t See if Storable works dist/Storable/t/utf8hash.t See if Storable works dist/Storable/t/utf8.t See if Storable works dist/Storable/t/weak.t Can Storable store weakrefs -dist/Switch/Changes Changes for Switch.pm -dist/Switch/Makefile.PL Makefile.PL for Switch.pm -dist/Switch/MANIFEST MANIFEST for Switch.pm -dist/Switch/META.yml META.yml for Switch.pm -dist/Switch/README README for Switch.pm -dist/Switch/Switch.pm Switch for Perl -dist/Switch/t/given.t See if Perl 6 given (switch) works -dist/Switch/t/nested.t See if nested switch works -dist/Switch/t/switch.t See if Perl 5 switch works dist/Thread-Queue/lib/Thread/Queue.pm Thread-safe queues dist/Thread-Queue/t/01_basic.t Thread::Queue tests dist/Thread-Queue/t/02_refs.t Thread::Queue tests diff --git a/Porting/Maintainers.pl b/Porting/Maintainers.pl index 2d10b7c..d6bb9df 100755 --- a/Porting/Maintainers.pl +++ b/Porting/Maintainers.pl @@ -1374,16 +1374,6 @@ use File::Glob qw(:case); 'UPSTREAM' => 'blead', }, - 'Switch' => - { - 'MAINTAINER' => 'rgarcia', - 'DISTRIBUTION' => 'RGARCIA/Switch-2.15.tar.gz', - 'FILES' => q[dist/Switch], - 'CPAN' => 1, - 'UPSTREAM' => 'blead', - 'DEPRECATED' => 5.011, - }, - 'Sys::Syslog' => { 'MAINTAINER' => 'saper', diff --git a/dist/Switch/Changes b/dist/Switch/Changes deleted file mode 100644 index ece38d8..0000000 --- a/dist/Switch/Changes +++ /dev/null @@ -1,121 +0,0 @@ -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.05 Mon Sep 3 08:13:25 2001 - - - Changed licence for inclusion in core distribution - - - Added new test file for non-fallthrough and nested switches - - -2.06 Wed Nov 14 16:18:54 2001 - - - Fixed parsing of ternary operators in Switch'ed source code - (at the expense of no longer correctly parsing ?...? regexes) - (thanks Mark) - - - Fixed the parsing of embedded POD (thanks Brent) - - - Fixed bug encountered when -s or -m file test used (thanks Jochen) - - -2.07 Wed May 15 15:19:28 2002 - - - Corified tests - - - Updated "Perl6" syntax to reflect current design - (as far as possible -- can't eliminate need to parenthesize - variables, since they're ambiguous in Perl 5) - - -2.09 Wed Jun 12 22:13:30 2002 - - - Removed spurious debugging statement - - -2.10 Mon Dec 29 2003 - - - Introduce the "default" keyword for the Perl 6 syntax - - Raise the limitation on source file length to 1 million characters - -2.11 Wed Nov 22 2006 - - - Fix documentation issues - - Fix installation directory for perls >= 5.7.3 (Slaven Rezic) - -2.12 Mon Dec 11 2006 - - - Fix bug in parsing POD at end of document (Valentin Guignon) - -2.13 Sun Feb 25 2007 - - - Fix bug in parsing division statements (Wolfgang Laun) - -2.14 Mon Dec 29 2008 - - - Make Switch.pm skip POD like perl does - Patch provided by Daniel Klein - (bleadperl commit 39bcdda02ea582e7bdf8b0cf2e7186e89c6baea9) - - - Fix line numbering issues with POD filtered by Switch.pm - Patch provided by Daniel Klein - (bleadperl commit 6a9befb105d93024902eb178dab77655333f1829) - - - Switch.pm doesn't appear to support plain arrays and hashes in case(). - (bleadperl commit cd3d9d47255d3080961ba7b58c9a145c7b45b905) - - - Let us direct Switch questions to P5P. - (bleadperl commit b62fb10ea98565ce5572416500e1e3517cb17d33) - - - POD nits from Frank Wiegand - (bleadperl commit 3b46207fed7bf69caa32c27c04bd239cfb64cb53) - -2.15 Tue Oct 20 2009 - - Deprecate shipping Switch.pm in the core distribution. - (Nicholas Clark) - -2.16 Fri Oct 23 2009 - - For Perl 5.11+, install into 'site', not 'perl' - diff --git a/dist/Switch/MANIFEST b/dist/Switch/MANIFEST deleted file mode 100644 index 4c503299..0000000 --- a/dist/Switch/MANIFEST +++ /dev/null @@ -1,9 +0,0 @@ -Changes -MANIFEST -Makefile.PL -README -Switch.pm -t/given.t -t/nested.t -t/switch.t -META.yml Module meta-data (added by MakeMaker) diff --git a/dist/Switch/META.yml b/dist/Switch/META.yml deleted file mode 100644 index 2c42e24..0000000 --- a/dist/Switch/META.yml +++ /dev/null @@ -1,14 +0,0 @@ ---- #YAML:1.0 -name: Switch -version: 2.16 -abstract: ~ -license: ~ -author: ~ -generated_by: ExtUtils::MakeMaker version 6.42 -distribution_type: module -requires: - Filter::Util::Call: 0 - Text::Balanced: 0 -meta-spec: - url: http://module-build.sourceforge.net/META-spec-v1.3.html - version: 1.3 diff --git a/dist/Switch/Makefile.PL b/dist/Switch/Makefile.PL deleted file mode 100644 index 8d280f1..0000000 --- a/dist/Switch/Makefile.PL +++ /dev/null @@ -1,7 +0,0 @@ -use ExtUtils::MakeMaker; -WriteMakefile( - NAME => q[Switch], - VERSION_FROM => q[Switch.pm], - PREREQ_PM => { 'Filter::Util::Call' => 0, 'Text::Balanced' => 0 }, - INSTALLDIRS => ($] >= 5.00703 && $] < 5.011) ? 'perl' : 'site', -); diff --git a/dist/Switch/README b/dist/Switch/README deleted file mode 100644 index 6faf06b..0000000 --- a/dist/Switch/README +++ /dev/null @@ -1,26 +0,0 @@ -============================================================================== - Release of version 2.16 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 and C 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) - Maintained by Rafael Garcia-Suarez (rgarciasuarez@gmail.com) - and the Perl 5 porters (perl5-porters@gmail.com) - -COPYRIGHT - 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. diff --git a/dist/Switch/Switch.pm b/dist/Switch/Switch.pm deleted file mode 100644 index 2189ae0..0000000 --- a/dist/Switch/Switch.pm +++ /dev/null @@ -1,875 +0,0 @@ -package Switch; - -use strict; -use vars qw($VERSION); -use Carp; - -use if $] >= 5.011, 'deprecate'; - -$VERSION = '2.16'; - - -# LOAD FILTERING MODULE... -use Filter::Util::Call; - -sub __(); - -# CATCH ATTEMPTS TO CALL case OUTSIDE THE SCOPE OF ANY switch - -$::_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 -{ - $fallthrough = grep /\bfallthrough\b/, @_; - $offset = (caller)[2]+1; - 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; -} - -sub unimport -{ - filter_del() -} - -sub filter -{ - my($self) = @_ ; - local $Switch::file = (caller)[1]; - - my $status = 1; - $status = filter_read(1_000_000); - return $status if $status<0; - $_ = filter_blocks($_,$offset); - $_ = "# line $offset\n" . $_ if $offset; undef $offset; - return $status; -} - -use Text::Balanced ':ALL'; - -sub line -{ - my ($pretext,$offset) = @_; - ($pretext=~tr/\n/\n/)+($offset||0); -} - -sub is_block -{ - local $SIG{__WARN__}=sub{die$@}; - local $^W=1; - my $ishash = defined eval 'my $hr='.$_[0]; - undef $@; - 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 $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) - { - $text .= q{use Switch 'noimport'}; - next component; - } - my @pos = Text::Balanced::_match_quotelike(\$source,qr/\s*/,1,0); - if (defined $pos[0]) - { - 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 ($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) '; - 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 $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 ($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) - { - 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 .= " " 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*%} { ( \\\%} || - $code =~ s {^\s*[(]\s*m\b} { ( qr} || - $code =~ s {^\s*[(]\s*/} { ( qr/} || - $code =~ s {^\s*[(]\s*qw} { ( \\qw}; - $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,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 .= " " if $pos[0] < $pos[2]; - $text .= "$code)"; - } - 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 $keyword statement (invalid $keyword value?) near $Switch::file line ", line(substr($source,0,pos $source), $line), "\n"; - } - - 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 $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 }/ - unless $fallthrough; - $text .= "{ while (1) $code continue { goto C_A_S_E_$casecounter } last S_W_I_T_C_H; C_A_S_E_$casecounter: }"; - $casecounter++; - next component; - } - - $source =~ m/\G(\s*(-[sm]\s+|\w+|#.*\n|\W))/gc; - $text .= $1; - } - $text; -} - - - -sub in -{ - my ($x,$y) = @_; - my @numy; - for my $nextx ( @$x ) - { - my $numx = ref($nextx) || defined $nextx && (~$nextx&$nextx) eq 0; - for my $j ( 0..$#$y ) - { - my $nexty = $y->[$j]; - 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 ""; -} - -sub on_exists -{ - my $ref = @_==1 && ref($_[0]) eq 'HASH' ? $_[0] : { @_ }; - [ keys %$ref ] -} - -sub on_defined -{ - my $ref = @_==1 && ref($_[0]) eq 'HASH' ? $_[0] : { @_ }; - [ grep { defined $ref->{$_} } keys %$ref ] -} - -sub switch(;$) -{ - my ($s_val) = @_ ? $_[0] : $_; - my $s_ref = ref $s_val; - - if ($s_ref eq 'CODE') - { - $::_S_W_I_T_C_H = - sub { my $c_val = $_[0]; - return $s_val == $c_val if ref $c_val eq 'CODE'; - return $s_val->(@$c_val) if ref $c_val eq 'ARRAY'; - return $s_val->($c_val); - }; - } - 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 $c_val->($s_val) if $c_ref eq 'CODE'; - return $c_val->call($s_val) if $c_ref eq 'Switch'; - return scalar $s_val=~/$c_val/ - if $c_ref eq 'Regexp'; - return scalar $c_val->{$s_val} - if $c_ref eq 'HASH'; - return; - }; - } - elsif ($s_ref eq "") # STRING SCALAR - { - $::_S_W_I_T_C_H = - sub { my $c_val = $_[0]; - my $c_ref = ref $c_val; - return $s_val eq $c_val if $c_ref eq ""; - return in([$s_val],$c_val) if $c_ref eq 'ARRAY'; - return $c_val->($s_val) if $c_ref eq 'CODE'; - return $c_val->call($s_val) if $c_ref eq 'Switch'; - return scalar $s_val=~/$c_val/ - if $c_ref eq 'Regexp'; - return scalar $c_val->{$s_val} - if $c_ref eq 'HASH'; - return; - }; - } - elsif ($s_ref eq 'ARRAY') - { - $::_S_W_I_T_C_H = - sub { my $c_val = $_[0]; - my $c_ref = ref $c_val; - return in($s_val,[$c_val]) if $c_ref eq ""; - return in($s_val,$c_val) if $c_ref eq 'ARRAY'; - return $c_val->(@$s_val) if $c_ref eq 'CODE'; - return $c_val->call(@$s_val) - if $c_ref eq 'Switch'; - return scalar grep {$_=~/$c_val/} @$s_val - if $c_ref eq 'Regexp'; - return scalar grep {$c_val->{$_}} @$s_val - if $c_ref eq 'HASH'; - return; - }; - } - elsif ($s_ref eq 'Regexp') - { - $::_S_W_I_T_C_H = - sub { my $c_val = $_[0]; - my $c_ref = ref $c_val; - return $c_val=~/s_val/ if $c_ref eq ""; - return scalar grep {$_=~/s_val/} @$c_val - if $c_ref eq 'ARRAY'; - return $c_val->($s_val) if $c_ref eq 'CODE'; - return $c_val->call($s_val) if $c_ref eq 'Switch'; - return $s_val eq $c_val if $c_ref eq 'Regexp'; - return grep {$_=~/$s_val/ && $c_val->{$_}} keys %$c_val - if $c_ref eq 'HASH'; - return; - }; - } - elsif ($s_ref eq 'HASH') - { - $::_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 ""; - return scalar grep {$s_val->{$_}} @$c_val - if $c_ref eq 'ARRAY'; - return $c_val->($s_val) if $c_ref eq 'CODE'; - return $c_val->call($s_val) if $c_ref eq 'Switch'; - return grep {$_=~/$c_val/ && $s_val->{"$_"}} keys %$s_val - if $c_ref eq 'Regexp'; - return $s_val==$c_val if $c_ref eq 'HASH'; - return; - }; - } - elsif ($s_ref eq 'Switch') - { - $::_S_W_I_T_C_H = - sub { my $c_val = $_[0]; - return $s_val == $c_val if ref $c_val eq 'Switch'; - return $s_val->call(@$c_val) - if ref $c_val eq 'ARRAY'; - return $s_val->call($c_val); - }; - } - else - { - croak "Cannot switch on $s_ref"; - } - return 1; -} - -sub case($) { local $SIG{__WARN__} = \&carp; - $::_S_W_I_T_C_H->(@_); } - -# IMPLEMENT __ - -my $placeholder = bless { arity=>1, impl=>sub{$_[1+$_[0]]} }; - -sub __() { $placeholder } - -sub __arg($) -{ - my $index = $_[0]+1; - bless { arity=>0, impl=>sub{$_[$index]} }; -} - -sub hosub(&@) -{ - # WRITE THIS -} - -sub call -{ - my ($self,@args) = @_; - return $self->{impl}->(0,@args); -} - -sub meta_bop(&) -{ - my ($op) = @_; - sub - { - my ($left, $right, $reversed) = @_; - ($right,$left) = @_ if $reversed; - - my $rop = ref $right eq 'Switch' - ? $right - : bless { arity=>0, impl=>sub{$right} }; - - my $lop = ref $left eq 'Switch' - ? $left - : bless { arity=>0, impl=>sub{$left} }; - - my $arity = $lop->{arity} + $rop->{arity}; - - return bless { - arity => $arity, - impl => sub { my $start = shift; - return $op->($lop->{impl}->($start,@_), - $rop->{impl}->($start+$lop->{arity},@_)); - } - }; - }; -} - -sub meta_uop(&) -{ - my ($op) = @_; - sub - { - my ($left) = @_; - - my $lop = ref $left eq 'Switch' - ? $left - : bless { arity=>0, impl=>sub{$left} }; - - my $arity = $lop->{arity}; - - return bless { - arity => $arity, - impl => sub { $op->($lop->{impl}->(@_)) } - }; - }; -} - - -use overload - "+" => meta_bop {$_[0] + $_[1]}, - "-" => meta_bop {$_[0] - $_[1]}, - "*" => meta_bop {$_[0] * $_[1]}, - "/" => meta_bop {$_[0] / $_[1]}, - "%" => meta_bop {$_[0] % $_[1]}, - "**" => meta_bop {$_[0] ** $_[1]}, - "<<" => meta_bop {$_[0] << $_[1]}, - ">>" => meta_bop {$_[0] >> $_[1]}, - "x" => meta_bop {$_[0] x $_[1]}, - "." => meta_bop {$_[0] . $_[1]}, - "<" => meta_bop {$_[0] < $_[1]}, - "<=" => meta_bop {$_[0] <= $_[1]}, - ">" => meta_bop {$_[0] > $_[1]}, - ">=" => meta_bop {$_[0] >= $_[1]}, - "==" => meta_bop {$_[0] == $_[1]}, - "!=" => meta_bop {$_[0] != $_[1]}, - "<=>" => meta_bop {$_[0] <=> $_[1]}, - "lt" => meta_bop {$_[0] lt $_[1]}, - "le" => meta_bop {$_[0] le $_[1]}, - "gt" => meta_bop {$_[0] gt $_[1]}, - "ge" => meta_bop {$_[0] ge $_[1]}, - "eq" => meta_bop {$_[0] eq $_[1]}, - "ne" => meta_bop {$_[0] ne $_[1]}, - "cmp" => meta_bop {$_[0] cmp $_[1]}, - "\&" => meta_bop {$_[0] & $_[1]}, - "^" => meta_bop {$_[0] ^ $_[1]}, - "|" => meta_bop {$_[0] | $_[1]}, - "atan2" => meta_bop {atan2 $_[0], $_[1]}, - - "neg" => meta_uop {-$_[0]}, - "!" => meta_uop {!$_[0]}, - "~" => meta_uop {~$_[0]}, - "cos" => meta_uop {cos $_[0]}, - "sin" => meta_uop {sin $_[0]}, - "exp" => meta_uop {exp $_[0]}, - "abs" => meta_uop {abs $_[0]}, - "log" => meta_uop {log $_[0]}, - "sqrt" => meta_uop {sqrt $_[0]}, - "bool" => sub { croak "Can't use && or || in expression containing __" }, - - # "&()" => sub { $_[0]->{impl} }, - - # "||" => meta_bop {$_[0] || $_[1]}, - # "&&" => meta_bop {$_[0] && $_[1]}, - # fallback => 1, - ; -1; - -__END__ - - -=head1 NAME - -Switch - A switch statement for Perl - -=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 (\&sub) { print "arg to subroutine" } - else { print "previous case not true" } - } - -=head1 BACKGROUND - -[Skip ahead to L<"DESCRIPTION"> if you don't care about the whys -and wherefores of this control structure] - -In seeking to devise a "Swiss Army" case mechanism suitable for Perl, -it is useful to generalize this notion of distributed conditional -testing as far as possible. Specifically, the concept of "matching" -between the switch value and the various case values need not be -restricted to numeric (or string or referential) equality, as it is in other -languages. Indeed, as Table 1 illustrates, Perl -offers at least eighteen different ways in which two values could -generate a match. - - Table 1: Matching a switch value ($s) with a case value ($c) - - Switch Case Type of Match Implied Matching Code - Value Value - ====== ===== ===================== ============= - - number same numeric or referential match if $s == $c; - or ref equality - - object method result of method call match if $s->$c(); - ref name match if defined $s->$c(); - or ref - - other other string equality match if $s eq $c; - non-ref non-ref - scalar scalar - - string regexp pattern match match if $s =~ /$c/; - - array scalar array entry existence match if 0<=$c && $c<@$s; - ref array entry definition match if defined $s->[$c]; - array entry truth match if $s->[$c]; - - array array array intersection match if intersects(@$s, @$c); - ref ref (apply this table to - all pairs of elements - $s->[$i] and - $c->[$j]) - - array regexp array grep match if grep /$c/, @$s; - ref - - hash scalar hash entry existence match if exists $s->{$c}; - ref hash entry definition match if defined $s->{$c}; - hash entry truth match if $s->{$c}; - - hash regexp hash grep match if grep /$c/, keys %$s; - ref - - sub scalar return value defn match if defined $s->($c); - ref return value truth match if $s->($c); - - sub array return value defn match if defined $s->(@$c); - ref ref return value truth match if $s->(@$c); - - -In reality, Table 1 covers 31 alternatives, because only the equality and -intersection tests are commutative; in all other cases, the roles of -the C<$s> and C<$c> variables could be reversed to produce a -different test. For example, instead of testing a single hash for -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}>). - -=head1 DESCRIPTION - -The Switch.pm module implements a generalized case mechanism that covers -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 -single scalar argument of any type, specified in parentheses. -C stores this value as the -current switch value in a (localized) control variable. -The value is followed by a block which may contain one or more -Perl statements (including the C statement described below). -The block is unconditionally executed once the switch value has -been cached. - -A C statement takes a single scalar argument (in mandatory -parentheses if it's a variable; otherwise the parens are optional) and -selects the appropriate type of matching between that argument and the -current switch value. The type of matching used is determined by the -respective types of the switch value and the C argument, as -specified in Table 1. If the match is successful, the mandatory -block associated with the C statement is executed. - -In most other respects, the C statement is semantically identical -to an C statement. For example, it can be followed by an C -clause, and can be used as a postfix statement qualifier. - -However, when a C block has been executed control is automatically -transferred to the statement after the immediately enclosing C -block, rather than to the next statement within the block. In other -words, the success of any C statement prevents other cases in the -same scope from executing. But see L<"Allowing fall-through"> below. - -Together these two new statements provide a fully generalized case -mechanism: - - use Switch; - - # AND LATER... - - %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 } { 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, -and a series of C statements can try different types of matches --- hash membership, pattern match, array intersection, simple equality, -etc. -- against the same switch value. - -The use of intersection tests against an array reference is particularly -useful for aggregating integral cases: - - sub classify_digit - { - switch ($_[0]) { case 0 { return 'zero' } - case [2,4,6,8] { return 'even' } - case [1,3,5,7,9] { return 'odd' } - case /[A-F]/i { return 'hex' } - } - } - - -=head2 Allowing fall-through - -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 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. - -For example: - - switch ($val) { - case 1 { handle_num_1(); next } # and try next case... - case "1" { handle_str_1(); next } # and try next case... - case [0..9] { handle_num_any(); } # and we're done - case /\d/ { handle_dig_any(); next } # and try next case... - case /.*/ { handle_str_any(); next } # and try next case... - } - -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 third C block -was executed, control would jump to the end of the enclosing -C block. - -On the other hand, if $val held C<10>, then only the last two C -subroutines would be called. - -Note that this mechanism allows the notion of I. -For example: - - switch ($val) { - case [0..9] { handle_num_any(); next if $val < 7; } - case /\d/ { handle_dig_any(); } - } - -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 -written: - - switch ($val) { - case [0..9] { handle_num_any(); last if $val >= 7; next; } - case /\d/ { handle_dig_any(); } - } - - -=head2 Automating fall-through - -In situations where case fall-through should be the norm, rather than an -exception, an endless succession of terminal Cs is tedious and ugly. -Hence, it is possible to reverse the default behaviour by specifying -the string "fallthrough" when importing the module. For example, the -following code is equivalent to the first example in L<"Allowing fall-through">: - - use Switch 'fallthrough'; - - switch ($val) { - case 1 { handle_num_1(); } - case "1" { handle_str_1(); } - case [0..9] { handle_num_any(); last } - case /\d/ { handle_dig_any(); } - case /.*/ { handle_str_any(); } - } - -Note the explicit use of a C to preserve the non-fall-through -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 -substitute for a cascaded C, is where a switch value needs to -be tested against a series of conditions. For example: - - sub beverage { - switch (shift) { - 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 -converts (almost) any expression in which it appears to a reference to a -higher-order function. That is, the expression: - - use Switch '__'; - - __ < 2 - -is equivalent to: - - sub { $_[0] < 2 } - -With C<__>, the previous ugly case statements can be rewritten: - - case __ < 10 { return 'milk' } - case __ < 20 { return 'coke' } - case __ < 30 { return 'beer' } - case __ < 40 { return 'wine' } - case __ < 50 { return 'malt' } - case __ < 60 { return 'Moet' } - else { return 'milk' } - -The C<__> subroutine makes extensive use of operator overloading to -perform its magic. All operations involving __ are overloaded to -produce an anonymous subroutine that implements a lazy version -of the original operation. - -The only problem is that operator overloading does not allow the -boolean operators C<&&> and C<||> to be overloaded. So a case statement -like this: - - case 0 <= __ && __ < 10 { return 'digit' } - -doesn't act as expected, because when it is -executed, it constructs two higher order subroutines -and then treats the two resulting references as arguments to C<&&>: - - sub { 0 <= $_[0] } && sub { $_[0] < 10 } - -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 an error. - -=head1 DEPENDENCIES - -The module is implemented using Filter::Util::Call and Text::Balanced -and requires both these modules to be installed. - -=head1 AUTHOR - -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 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-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. diff --git a/dist/Switch/t/given.t b/dist/Switch/t/given.t deleted file mode 100644 index 2b56151..0000000 --- a/dist/Switch/t/given.t +++ /dev/null @@ -1,272 +0,0 @@ -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/dist/Switch/t/nested.t b/dist/Switch/t/nested.t deleted file mode 100644 index d10dff2..0000000 --- a/dist/Switch/t/nested.t +++ /dev/null @@ -1,35 +0,0 @@ -use Switch; - -print "1..4\n"; - -my $count = 1; -for my $count (1..3, 'four') -{ - switch ([$count]) - { - -=pod - -=head1 Test - -We also test if Switch is POD-friendly here - -=cut - - case qr/\d/ { - switch ($count) { - case 1 { print "ok 1\n" } - case [2,3] { print "ok $count\n" } - } - } - case 'four' { print "ok 4\n" } - } -} - -__END__ - -=head1 Another test - -Still friendly??? - -=cut diff --git a/dist/Switch/t/switch.t b/dist/Switch/t/switch.t deleted file mode 100644 index 280dcb2..0000000 --- a/dist/Switch/t/switch.t +++ /dev/null @@ -1,272 +0,0 @@ -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); - } -}