diff --git a/Changes b/Changes new file mode 100644 index 0000000..5ebed25 --- /dev/null +++ b/Changes @@ -0,0 +1,126 @@ +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' + +2.17 2014-03-18 + - tests fixed + - patch by Father Chrysostomos + - many warnings + - recommendation to use given/when diff --git a/MANIFEST b/MANIFEST new file mode 100644 index 0000000..dac29da --- /dev/null +++ b/MANIFEST @@ -0,0 +1,10 @@ +Changes +MANIFEST +Makefile.PL +README +Switch.pm +t/given.t +t/nested.t +t/switch.t +META.yml Module meta-data (added by MakeMaker) +META.json Module JSON meta-data (added by MakeMaker) diff --git a/META.json b/META.json new file mode 100644 index 0000000..7d487dd --- /dev/null +++ b/META.json @@ -0,0 +1,51 @@ +{ + "abstract" : "A switch statement for Perl, do not use if you can use given/when", + "author" : [ + "Damian Conway", + "Rafael Garcia-Suarez", + "Alexandr Ciornii" + ], + "dynamic_config" : 1, + "generated_by" : "ExtUtils::MakeMaker version 6.78, CPAN::Meta::Converter version 2.131490", + "license" : [ + "perl_5" + ], + "meta-spec" : { + "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", + "version" : "2" + }, + "name" : "Switch", + "no_index" : { + "directory" : [ + "t", + "inc" + ] + }, + "prereqs" : { + "build" : { + "requires" : { + "ExtUtils::MakeMaker" : "0" + } + }, + "configure" : { + "requires" : { + "ExtUtils::MakeMaker" : "0" + } + }, + "runtime" : { + "requires" : { + "Filter::Util::Call" : "0", + "Text::Balanced" : "2", + "if" : "0", + "perl" : "5.005" + } + } + }, + "release_status" : "stable", + "resources" : { + "repository" : { + "url" : "http://github.com/chorny/Switch" + } + }, + "version" : "2.17" +} diff --git a/META.yml b/META.yml new file mode 100644 index 0000000..65efde1 --- /dev/null +++ b/META.yml @@ -0,0 +1,29 @@ +--- +abstract: 'A switch statement for Perl, do not use if you can use given/when' +author: + - Damian Conway + - Rafael Garcia-Suarez + - Alexandr Ciornii +build_requires: + ExtUtils::MakeMaker: 0 +configure_requires: + ExtUtils::MakeMaker: 0 +dynamic_config: 1 +generated_by: 'ExtUtils::MakeMaker version 6.78, CPAN::Meta::Converter version 2.131490' +license: perl +meta-spec: + url: http://module-build.sourceforge.net/META-spec-v1.4.html + version: 1.4 +name: Switch +no_index: + directory: + - t + - inc +requires: + Filter::Util::Call: 0 + Text::Balanced: 2 + if: 0 + perl: 5.005 +resources: + repository: http://github.com/chorny/Switch +version: 2.17 diff --git a/Makefile.PL b/Makefile.PL new file mode 100644 index 0000000..e74456f --- /dev/null +++ b/Makefile.PL @@ -0,0 +1,54 @@ +use ExtUtils::MakeMaker; +WriteMakefile1( + LICENSE => 'perl', + MIN_PERL_VERSION => '5.005', + META_MERGE => { + resources => { + repository => 'http://github.com/chorny/Switch', + }, + }, + #BUILD_REQUIRES => { + #}, + + NAME => q[Switch], + VERSION_FROM => q[Switch.pm], + ABSTRACT_FROM => => q[Switch.pm], + AUTHOR => ['Damian Conway', 'Rafael Garcia-Suarez', 'Alexandr Ciornii'], + PREREQ_PM => { 'Filter::Util::Call' => 0, 'Text::Balanced' => 2, 'if' => 0, }, + INSTALLDIRS => ($] >= 5.00703 && $] < 5.011) ? 'perl' : 'site', + $^O =~/win/i ? ( + dist => { + TAR => 'ptar', + TARFLAGS => '-c -C -f', + }, + ) : (), +); + +sub WriteMakefile1 { #Compatibility code for old versions of EU::MM. Written by Alexandr Ciornii, version 0.23. Added by eumm-upgrade. + my %params=@_; + my $eumm_version=$ExtUtils::MakeMaker::VERSION; + $eumm_version=eval $eumm_version; + die "EXTRA_META is deprecated" if exists $params{EXTRA_META}; + die "License not specified" if not exists $params{LICENSE}; + if ($params{AUTHOR} and ref($params{AUTHOR}) eq 'ARRAY' and $eumm_version < 6.5705) { + $params{META_ADD}->{author}=$params{AUTHOR}; + $params{AUTHOR}=join(', ',@{$params{AUTHOR}}); + } + if ($params{TEST_REQUIRES} and $eumm_version < 6.64) { + $params{BUILD_REQUIRES}={ %{$params{BUILD_REQUIRES} || {}} , %{$params{TEST_REQUIRES}} }; + delete $params{TEST_REQUIRES}; + } + if ($params{BUILD_REQUIRES} and $eumm_version < 6.5503) { + #EUMM 6.5502 has problems with BUILD_REQUIRES + $params{PREREQ_PM}={ %{$params{PREREQ_PM} || {}} , %{$params{BUILD_REQUIRES}} }; + delete $params{BUILD_REQUIRES}; + } + delete $params{CONFIGURE_REQUIRES} if $eumm_version < 6.52; + delete $params{MIN_PERL_VERSION} if $eumm_version < 6.48; + delete $params{META_MERGE} if $eumm_version < 6.46; + delete $params{META_ADD} if $eumm_version < 6.46; + delete $params{LICENSE} if $eumm_version < 6.31; + + WriteMakefile(%params); +} + diff --git a/README b/README new file mode 100644 index 0000000..04fd981 --- /dev/null +++ b/README @@ -0,0 +1,26 @@ +============================================================================== + Release of version 2.17 of Switch +============================================================================== + + +NAME + Switch - A switch statement for Perl, do not use if you can use given/when + +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 Alexandr Ciornii (alexchorny@gmail.com) + Previously was maintained by Rafael Garcia-Suarez and perl5 porters. + +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/Switch.pm b/Switch.pm new file mode 100644 index 0000000..8c2544e --- /dev/null +++ b/Switch.pm @@ -0,0 +1,888 @@ +package Switch; + +use 5.005; +use strict; +use vars qw($VERSION); +use Carp; + +use if $] >= 5.011, 'deprecate'; + +$VERSION = '2.17'; + + +# 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, do not use if you can use given/when + +=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 +Alexandr Ciornii (alexchorny@gmail.com). Previously was maintained by +Rafael Garcia-Suarez and perl5 porters. + +=head1 BUGS + +There are undoubtedly serious bugs lurking somewhere in code this funky :-) +Bug reports and other feedback are most welcome. + +May create syntax errors in other parts of code. + +On perl 5.10.x may cause syntax error if "case" is present inside heredoc. + +In general, use given/when instead. It were introduced in perl 5.10.0. +Perl 5.10.0 was released in 2007. + +=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. + +May not work if sub prototypes are used (RT#33988). + +Regex captures in when are not available to code. + +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/t/given.t b/t/given.t new file mode 100644 index 0000000..8a52f57 --- /dev/null +++ b/t/given.t @@ -0,0 +1,272 @@ +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/t/nested.t b/t/nested.t new file mode 100644 index 0000000..d10dff2 --- /dev/null +++ b/t/nested.t @@ -0,0 +1,35 @@ +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/t/switch.t b/t/switch.t new file mode 100644 index 0000000..280dcb2 --- /dev/null +++ b/t/switch.t @@ -0,0 +1,272 @@ +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); + } +}