[Phoenix-pm] switch
Scott Walters
scott at illogics.org
Fri Dec 9 08:39:28 PST 2005
----- Forwarded message from Robin Houston <robin at cpan.org> -----
Return-Path: perl5-porters-return-107265-scott=slowass.net at perl.org
X-Original-To: scott at slowass.net
Delivered-To: scott at slowass.net
Received: from lists.develooper.com (x6.develooper.com [63.251.223.186])
by slowass.net (Postfix) with SMTP id 570C2553A5
for <scott at slowass.net>; Fri, 9 Dec 2005 13:24:36 +0000 (GMT)
Received: (qmail 21404 invoked by uid 514); 9 Dec 2005 13:16:02 -0000
Mailing-List: contact perl5-porters-help at perl.org; run by ezmlm
Precedence: bulk
list-help: <mailto:perl5-porters-help at perl.org>
list-unsubscribe: <mailto:perl5-porters-unsubscribe at perl.org>
list-post: <mailto:perl5-porters at perl.org>
X-List-Archive: <http://nntp.perl.org/group/perl.perl5.porters/107265>
List-Id: <perl5-porters.perl.org>
Delivered-To: mailing list perl5-porters at perl.org
Received: (qmail 21392 invoked from network); 9 Dec 2005 13:16:01 -0000
Delivered-To: perl5-porters at perl.org
X-Spam-Status: No, hits=-2.6 required=8.0
tests=BAYES_00
X-Spam-Check-By: la.mx.develooper.com
Received-SPF: pass (x1.develooper.com: local policy)
Date: Fri, 9 Dec 2005 13:13:51 +0000
From: Robin Houston <robin at cpan.org>
To: Perl 5 Porters <perl5-porters at perl.org>
Cc: damian at conway.org
Subject: switch
Message-ID: <20051209131351.GA1365 at rpc142.cs.man.ac.uk>
Mime-Version: 1.0
Content-Type: text/plain; charset=us-ascii
Content-Disposition: inline
User-Agent: Mutt/1.4i
X-Spam-Score: -1.9 (-)
X-Scanner: exiscan for exim4 (http://duncanthrax.net/exiscan/) *1Eki4f-0004yA-KH*nAiyRiQn5Dk*
X-Virus-Checked: Checked
Dear all,
I guess it's time for me to stick my head above the parapet and show
you what I've been doing with this.
Based on the exchanges with Damian, I have decided *not* to try and
ape the behaviour of Switch.pm. Instead I have tried to follow the
Perl 6 spec as closely as seemed reasonable.
To avoid breaking any existing code, the new syntax is enabled by
a new lexically-scoped pragma "use feature". So you need to
use feature "switch";
before using the feature.
This enables the keywords "given", "when", "default" and "break",
and does some DWIMmery with "continue" so that it can be used as
a control operator in addition to its usual purpose.
(Of course the "feature" mechanism is extensible, and I hope it
will be used for other new syntactic features in future.)
There are two main changes from the Perl 6 behaviour, both more
or less forced by fundamental differences between Perls 5 and 6:
1) The topic, $_, is dynamically rather than lexically scoped.
In Perl 6, $_ is always lexically bound to an enclosing block,
but that's not how it works in Perl 5.
2) Parentheses are required around the argument to given()
and when(). In Perl 6, parentheses are optional almost
everywhere, which is made possible by the fact that
whitespace is significant. Again, that's not how Perl 5
works: in Perl 5, C<$foo{2}> means the same as C<$foo {2}>.
given() and when() both have some magic fairy dust that silently
takes a reference to an array or hash. For example:
$ ./perl -Ilib -MO=Deparse -e 'use feature "switch"; given(my @foo) {1}'
use feature ('switch');
given (\my(@foo)) {
'???';
}
-e syntax OK
when() has some additional magic, whereby if its argument is
a comparison, a filetest, a sub/method call, or a regex match,
then it matches just when its argument is true, instead of
doing a smart match. This lets you do things like:
given($age) {
when ($_ < 18) { print "Too young\n" }
when ($_ > 99) { print "Too old\n" }
}
You can also use when-blocks in a foreach loop:
my $i = 0;
for(@ages) {
++ $i;
when ($_ < 18) { print "Applicant $i is too young\n" }
when ($_ > 99) { print "Applicant $i is too old\n" }
}
The main unfinished area is in the smart-match semantics:
S_smartmatch in pp_ctl.c is very much a work in progress.
This is really a design question, and a thorny one at that.
There's a big question mark in my mind over the right way
to treat a blessed reference that has overloaded string/numeric
values. (Should it be treated like a reference, or like a
string/number?) One TODO item is to make it possible to
overload smart match behaviour explicitly, using something
like
use overload '~~' => sub { ... };
Comparing two arrays is supposed to do an elementwise smartmatch,
(this is not yet implemented) which would mean you could do
given(@tree) {
when ([1, [2,3], [4,5]]) {
# @tree is deeply equal to [1, [2,3], [4,5]]
}
}
but what about:
my $dt = [];
push @$dt, $dt;
given($dt) {
when ($dt) {
# Oh dear! An infinite loop
}
}
?
Of course we could detect loops explicitly, and that may well be
the best thing to do.
Anyway, there are a lot of decisions to be made about the way
smart-matching should work, and I'd really appreciate some input.
All comments welcome.
Robin
PS. Patch applies with patch -p1. After applying, you need to run:
perl keywords.pl
perl opcode.pl
perl embed.pl
perl regen_perly.pl
Here it is:
diff -bru -X /Users/robin/.perl-patch.ignore perl-before/MANIFEST perl-after/MANIFEST
--- perl-before/MANIFEST 2005-12-07 13:30:43.000000000 +0000
+++ perl-after/MANIFEST 2005-12-09 10:52:17.000000000 +0000
@@ -1528,6 +1528,8 @@
lib/fastcwd.pl a faster but more dangerous getcwd
lib/Fatal.pm Make errors in functions/builtins fatal
lib/Fatal.t See if Fatal works
+lib/feature.pm Pragma to enable new syntax
+lib/feature.t See if features work
lib/fields.pm Set up object field names for pseudo-hash-using classes
lib/File/Basename.pm Emulate the basename program
lib/File/Basename.t See if File::Basename works
@@ -2936,6 +2938,7 @@
t/japh/abigail.t Obscure tests
t/lib/1_compile.t See if the various libraries and extensions compile
t/lib/commonsense.t See if configuration meets basic needs
+t/lib/common.pl Helper for lib/{warnings,feature}.t
t/lib/compmod.pl Helper for 1_compile.t
t/lib/contains_pod.xr Pod-Parser test file
t/lib/cygwin.t Builtin cygwin function tests
@@ -2958,6 +2961,8 @@
t/lib/dprof/test8_t Perl code profiler tests
t/lib/dprof/test8_v Perl code profiler tests
t/lib/dprof/V.pm Perl code profiler tests
+t/lib/feature/nonesuch Tests for enabling/disabling nonexistent feature
+t/lib/feature/switch Tests for enabling/disabling switch feature
t/lib/Filter/Simple/ExportTest.pm Helper file for Filter::Simple tests
t/lib/Filter/Simple/FilterOnlyTest.pm Helper file for Filter::Simple tests
t/lib/Filter/Simple/FilterTest.pm Helper file for Filter::Simple tests
@@ -3191,6 +3196,7 @@
t/op/subst.t See if substitution works
t/op/subst_wamp.t See if substitution works with $& present
t/op/sub.t See if subroutines work
+t/op/switch.t See if switches (given/when) work
t/op/sysio.t See if sysread and syswrite work
t/op/taint.t See if tainting works
t/op/threads.t Misc. tests for perl features with threads
diff -bru -X /Users/robin/.perl-patch.ignore perl-before/cop.h perl-after/cop.h
--- perl-before/cop.h 2005-11-11 05:25:04.000000000 +0000
+++ perl-after/cop.h 2005-12-08 16:33:08.000000000 +0000
@@ -419,6 +419,16 @@
if (cx->blk_loop.iterary && cx->blk_loop.iterary != PL_curstack)\
SvREFCNT_dec(cx->blk_loop.iterary);
+/* given/when context */
+struct block_givwhen {
+ OP *leave_op;
+};
+
+#define PUSHGIVEN(cx) \
+ cx->blk_givwhen.leave_op = cLOGOP->op_other;
+
+#define PUSHWHEN PUSHGIVEN
+
/* context common to subroutines, evals and loops */
struct block {
I32 blku_oldsp; /* stack pointer to copy stuff down to */
@@ -432,6 +442,7 @@
struct block_sub blku_sub;
struct block_eval blku_eval;
struct block_loop blku_loop;
+ struct block_givwhen blku_givwhen;
} blk_u;
};
#define blk_oldsp cx_u.cx_blk.blku_oldsp
@@ -443,6 +454,7 @@
#define blk_sub cx_u.cx_blk.blk_u.blku_sub
#define blk_eval cx_u.cx_blk.blk_u.blku_eval
#define blk_loop cx_u.cx_blk.blk_u.blku_loop
+#define blk_givwhen cx_u.cx_blk.blk_u.blku_givwhen
/* Enter a block. */
#define PUSHBLOCK(cx,t,sp) CXINC, cx = &cxstack[cxstack_ix], \
@@ -545,6 +557,8 @@
#define CXt_SUBST 4
#define CXt_BLOCK 5
#define CXt_FORMAT 6
+#define CXt_GIVEN 7
+#define CXt_WHEN 8
/* private flags for CXt_SUB and CXt_NULL */
#define CXp_MULTICALL 0x00000400 /* part of a multicall (so don't
@@ -554,8 +568,10 @@
#define CXp_REAL 0x00000100 /* truly eval'', not a lookalike */
#define CXp_TRYBLOCK 0x00000200 /* eval{}, not eval'' or similar */
-#ifdef USE_ITHREADS
/* private flags for CXt_LOOP */
+#define CXp_FOREACH 0x00000200 /* a foreach loop */
+#define CXp_DEFGV 0x00000400 /* foreach using $_ */
+#ifdef USE_ITHREADS
# define CXp_PADVAR 0x00000100 /* itervar lives on pad, iterdata
has pad offset; if not set,
iterdata holds GV* */
@@ -570,6 +586,10 @@
== (CXt_EVAL|CXp_REAL))
#define CxTRYBLOCK(c) (((c)->cx_type & (CXt_EVAL|CXp_TRYBLOCK)) \
== (CXt_EVAL|CXp_TRYBLOCK))
+#define CxFOREACH(c) (((c)->cx_type & (CXt_LOOP|CXp_FOREACH)) \
+ == (CXt_LOOP|CXp_FOREACH))
+#define CxFOREACHDEF(c) (((c)->cx_type & (CXt_LOOP|CXp_FOREACH|CXp_DEFGV))\
+ == (CXt_LOOP|CXp_FOREACH|CXp_DEFGV))
#define CXINC (cxstack_ix < cxstack_max ? ++cxstack_ix : (cxstack_ix = cxinc()))
diff -bru -X /Users/robin/.perl-patch.ignore perl-before/embed.fnc perl-after/embed.fnc
--- perl-before/embed.fnc 2005-12-07 16:17:11.000000000 +0000
+++ perl-after/embed.fnc 2005-12-09 12:11:56.000000000 +0000
@@ -509,6 +509,7 @@
Ap |void |newFORM |I32 floor|NULLOK OP* o|NULLOK OP* block
Apa |OP* |newFOROP |I32 flags|NULLOK char* label|line_t forline \
|NULLOK OP* sv|NN OP* expr|NULLOK OP* block|NULLOK OP* cont
+Apa |OP* |newGIVENOP |NN OP* cond|NN OP* block
Apa |OP* |newLOGOP |I32 optype|I32 flags|NN OP* left|NN OP* right
Apa |OP* |newLOOPEX |I32 type|NN OP* label
Apa |OP* |newLOOPOP |I32 flags|I32 debuggable|NULLOK OP* expr|NULLOK OP* block
@@ -552,6 +553,7 @@
Apda |SV* |newSVrv |NN SV* rv|NULLOK const char* classname
Apda |SV* |newSVsv |NULLOK SV* old
Apa |OP* |newUNOP |I32 type|I32 flags|NULLOK OP* first
+Apa |OP* |newWHENOP |NULLOK OP* cond|NN OP* block
Apa |OP* |newWHILEOP |I32 flags|I32 debuggable|NULLOK LOOP* loop \
|I32 whileline|NULLOK OP* expr|NULLOK OP* block|NULLOK OP* cont \
|I32 has_my
@@ -1172,15 +1174,19 @@
sR |OP* |doparseform |NN SV *sv
snR |bool |num_overflow |NV value|I32 fldsize|I32 frcsize
sR |I32 |dopoptoeval |I32 startingblock
+sR |I32 |dopoptogiven |I32 startingblock
sR |I32 |dopoptolabel |NN const char *label
sR |I32 |dopoptoloop |I32 startingblock
sR |I32 |dopoptosub |I32 startingblock
sR |I32 |dopoptosub_at |NN const PERL_CONTEXT* cxstk|I32 startingblock
+sR |I32 |dopoptowhen |I32 startingblock
s |void |save_lines |NULLOK AV *array|NN SV *sv
sR |OP* |doeval |int gimme|NULLOK OP** startop|NULLOK CV* outside|U32 seq
sR |PerlIO *|doopen_pm |NN const char *name|NN const char *mode
sR |bool |path_is_absolute|NN const char *name
sR |I32 |run_user_filter|int idx|NN SV *buf_sv|int maxlen
+s |void |smartmatch
+s |void |when_callback |NN SV* sub_ref|NN SV* arg
#endif
#if defined(PERL_IN_PP_HOT_C) || defined(PERL_DECL_PROT)
@@ -1343,6 +1349,7 @@
s |void |incline |NN char *s
s |int |intuit_method |NN char *s|NULLOK GV *gv
s |int |intuit_more |NN char *s
+s |bool |keyword_is_enabled|I32 kw
s |I32 |lop |I32 f|int x|NN char *s
rs |void |missingterm |NULLOK char *s
s |void |no_op |NN const char *what|NULLOK char *s
diff -bru -X /Users/robin/.perl-patch.ignore perl-before/ext/B/B/Deparse.pm perl-after/ext/B/B/Deparse.pm
--- perl-before/ext/B/B/Deparse.pm 2005-10-31 17:27:59.000000000 +0000
+++ perl-after/ext/B/B/Deparse.pm 2005-12-08 16:33:08.000000000 +0000
@@ -19,7 +19,7 @@
CVf_METHOD CVf_LOCKED CVf_LVALUE CVf_ASSERTION
PMf_KEEP PMf_GLOBAL PMf_CONTINUE PMf_EVAL PMf_ONCE PMf_SKIPWHITE
PMf_MULTILINE PMf_SINGLELINE PMf_FOLD PMf_EXTENDED);
-$VERSION = 0.72;
+$VERSION = 0.73;
use strict;
use vars qw/$AUTOLOAD/;
use warnings ();
@@ -116,6 +116,11 @@
# - option to use Data::Dumper for constants
# - more bug fixes
# - discovered lots more bugs not yet fixed
+#
+# ...
+#
+# Changes between 0.72 and 0.73
+# - support new switch constructs
# Todo:
# (See also BUGS section at the end of this file)
@@ -1632,6 +1637,37 @@
sub pp_lock { unop(@_, "lock") }
+sub pp_continue { unop(@_, "continue"); }
+sub pp_break {
+ my ($self, $op) = @_;
+ return "" if $op->flags & OPf_SPECIAL;
+ unop(@_, "break");
+}
+
+sub givwhen {
+ my $self = shift;
+ my($op, $cx, $givwhen) = @_;
+
+ my $enterop = $op->first;
+ my ($head, $block);
+ if ($enterop->flags & OPf_SPECIAL) {
+ $head = "default";
+ $block = $self->deparse($enterop->first, 0);
+ }
+ else {
+ my $cond = $enterop->first;
+ $head = "$givwhen (".$self->deparse($cond, 1).")";
+ $block = $self->deparse($cond->sibling, 0);
+ }
+
+ return "$head {\n".
+ "\t$block\n".
+ "\b}\cK";
+}
+
+sub pp_leavegiven { givwhen(@_, "given"); }
+sub pp_leavewhen { givwhen(@_, "when"); }
+
sub pp_exists {
my $self = shift;
my($op, $cx) = @_;
diff -bru -X /Users/robin/.perl-patch.ignore perl-before/ext/B/t/concise-xs.t perl-after/ext/B/t/concise-xs.t
--- perl-before/ext/B/t/concise-xs.t 2005-11-12 19:19:07.000000000 +0000
+++ perl-after/ext/B/t/concise-xs.t 2005-12-08 16:33:08.000000000 +0000
@@ -94,6 +94,7 @@
use Carp;
use Test::More tests => ( 1 * !!$Config::Config{useithreads}
+ 3 * ($] > 5.009)
+ + 10 * ($] >= 5.009003)
+ 777 );
require_ok("B::Concise");
diff -bru -X /Users/robin/.perl-patch.ignore perl-before/ext/Opcode/Opcode.pm perl-after/ext/Opcode/Opcode.pm
--- perl-before/ext/Opcode/Opcode.pm 2005-08-02 12:09:07.000000000 +0100
+++ perl-after/ext/Opcode/Opcode.pm 2005-12-08 16:33:08.000000000 +0000
@@ -416,6 +416,10 @@
entertry leavetry -- can be used to 'hide' fatal errors
+ entergiven leavegiven
+ enterwhen leavewhen
+ break continue
+
custom -- where should this go
=item :base_math
diff -bru -X /Users/robin/.perl-patch.ignore perl-before/keywords.pl perl-after/keywords.pl
--- perl-before/keywords.pl 2005-05-11 09:24:13.000000000 +0100
+++ perl-after/keywords.pl 2005-12-08 16:33:08.000000000 +0000
@@ -68,6 +68,7 @@
bind
binmode
bless
+break
caller
chdir
chmod
@@ -85,6 +86,7 @@
crypt
dbmclose
dbmopen
+default
defined
delete
die
@@ -142,6 +144,7 @@
getservent
getsockname
getsockopt
+given
glob
gmtime
goto
@@ -289,6 +292,7 @@
waitpid
wantarray
warn
+when
while
write
x
diff -bru -X /Users/robin/.perl-patch.ignore perl-before/lib/warnings.t perl-after/lib/warnings.t
--- perl-before/lib/warnings.t 2005-06-17 13:05:39.000000000 +0100
+++ perl-after/lib/warnings.t 2005-12-09 12:31:46.000000000 +0000
@@ -4,201 +4,7 @@
chdir 't' if -d 't';
@INC = '../lib';
$ENV{PERL5LIB} = '../lib';
- require Config; import Config;
- require './test.pl';
}
-use File::Path;
-use File::Spec::Functions;
-
-$| = 1;
-
-my $Is_MacOS = $^O eq 'MacOS';
-my $tmpfile = "tmp0000";
-1 while -e ++$tmpfile;
-END { if ($tmpfile) { 1 while unlink $tmpfile} }
-
-my @prgs = () ;
-my @w_files = () ;
-
-if (@ARGV)
- { print "ARGV = [@ARGV]\n" ;
- if ($^O eq 'MacOS') {
- @w_files = map { s#^#:lib:warnings:#; $_ } @ARGV
- } else {
- @w_files = map { s#^#./lib/warnings/#; $_ } @ARGV
- }
- }
-else
- { @w_files = sort glob(catfile(curdir(), "lib", "warnings", "*")) }
-
-my $files = 0;
-foreach my $file (@w_files) {
-
- next if $file =~ /(~|\.orig|,v)$/;
- next if $file =~ /perlio$/ && !(find PerlIO::Layer 'perlio');
- next if -d $file;
-
- open F, "<$file" or die "Cannot open $file: $!\n" ;
- my $line = 0;
- while (<F>) {
- $line++;
- last if /^__END__/ ;
- }
-
- {
- local $/ = undef;
- $files++;
- @prgs = (@prgs, $file, split "\n########\n", <F>) ;
- }
- close F ;
-}
-
-undef $/;
-
-plan tests => (scalar(@prgs)-$files);
-
-
-
-for (@prgs){
- unless (/\n/)
- {
- print "# From $_\n";
- next;
- }
- my $switch = "";
- my @temps = () ;
- my @temp_path = () ;
- if (s/^\s*-\w+//){
- $switch = $&;
- }
- my($prog,$expected) = split(/\nEXPECT\n/, $_);
- my ($todo, $todo_reason);
- $todo = $prog =~ s/^#\s*TODO(.*)\n//m and $todo_reason = $1;
- if ( $prog =~ /--FILE--/) {
- my(@files) = split(/\n--FILE--\s*([^\s\n]*)\s*\n/, $prog) ;
- shift @files ;
- die "Internal error test $test didn't split into pairs, got " .
- scalar(@files) . "[" . join("%%%%", @files) ."]\n"
- if @files % 2 ;
- while (@files > 2) {
- my $filename = shift @files ;
- my $code = shift @files ;
- push @temps, $filename ;
- if ($filename =~ m#(.*)/#) {
- mkpath($1);
- push(@temp_path, $1);
- }
- open F, ">$filename" or die "Cannot open $filename: $!\n" ;
- print F $code ;
- close F or die "Cannot close $filename: $!\n";
- }
- shift @files ;
- $prog = shift @files ;
- }
-
- # fix up some paths
- if ($^O eq 'MacOS') {
- $prog =~ s|require "./abc(d)?";|require ":abc$1";|g;
- $prog =~ s|"\."|":"|g;
- }
-
- open TEST, ">$tmpfile" or die "Cannot open >$tmpfile: $!";
- print TEST q{
- BEGIN {
- open(STDERR, ">&STDOUT")
- or die "Can't dup STDOUT->STDERR: $!;";
- }
- };
- print TEST "\n#line 1\n"; # So the line numbers don't get messed up.
- print TEST $prog,"\n";
- close TEST or die "Cannot close $tmpfile: $!";
- my $results = runperl( switches => [$switch], stderr => 1, progfile => $tmpfile );
- my $status = $?;
- $results =~ s/\n+$//;
- # allow expected output to be written as if $prog is on STDIN
- $results =~ s/tmp\d+/-/g;
- if ($^O eq 'VMS') {
- # some tests will trigger VMS messages that won't be expected
- $results =~ s/\n?%[A-Z]+-[SIWEF]-[A-Z]+,.*//;
-
- # pipes double these sometimes
- $results =~ s/\n\n/\n/g;
- }
-# bison says 'parse error' instead of 'syntax error',
-# various yaccs may or may not capitalize 'syntax'.
- $results =~ s/^(syntax|parse) error/syntax error/mig;
- # allow all tests to run when there are leaks
- $results =~ s/Scalars leaked: \d+\n//g;
-
- # fix up some paths
- if ($^O eq 'MacOS') {
- $results =~ s|:abc\.pm\b|abc.pm|g;
- $results =~ s|:abc(d)?\b|./abc$1|g;
- }
-
- $expected =~ s/\n+$//;
- my $prefix = ($results =~ s#^PREFIX(\n|$)##) ;
- # any special options? (OPTIONS foo bar zap)
- my $option_regex = 0;
- my $option_random = 0;
- if ($expected =~ s/^OPTIONS? (.+)\n//) {
- foreach my $option (split(' ', $1)) {
- if ($option eq 'regex') { # allow regular expressions
- $option_regex = 1;
- }
- elsif ($option eq 'random') { # all lines match, but in any order
- $option_random = 1;
- }
- else {
- die "$0: Unknown OPTION '$option'\n";
- }
- }
- }
- die "$0: can't have OPTION regex and random\n"
- if $option_regex + option_random > 1;
- my $ok = 1;
- if ( $results =~ s/^SKIPPED\n//) {
- print "$results\n" ;
- }
- elsif ($option_random)
- {
- $ok = randomMatch($results, $expected);
- }
- elsif (($prefix && (( $option_regex && $results !~ /^$expected/) ||
- (!$option_regex && $results !~ /^\Q$expected/))) or
- (!$prefix && (( $option_regex && $results !~ /^$expected/) ||
- (!$option_regex && $results ne $expected)))) {
- my $err_line = "PROG: $switch\n$prog\n" .
- "EXPECTED:\n$expected\n" .
- "GOT:\n$results\n";
- if ($todo) {
- $err_line =~ s/^/# /mg;
- print $err_line; # Harness can't filter it out from STDERR.
- }
- else {
- print STDERR $err_line;
- }
- $ok = 0;
- }
-
- $TODO = $todo ? $todo_reason : 0;
- ok($ok);
-
- foreach (@temps)
- { unlink $_ if $_ }
- foreach (@temp_path)
- { rmtree $_ if -d $_ }
-}
-
-sub randomMatch
-{
- my $got = shift ;
- my $expected = shift;
-
- my @got = sort split "\n", $got ;
- my @expected = sort split "\n", $expected ;
-
- return "@got" eq "@expected";
-
-}
+our $pragma_name = "warnings";
+require "../t/lib/common.pl";
diff -bru -X /Users/robin/.perl-patch.ignore perl-before/op.c perl-after/op.c
--- perl-before/op.c 2005-12-06 17:52:16.000000000 +0000
+++ perl-after/op.c 2005-12-08 16:33:08.000000000 +0000
@@ -820,6 +820,8 @@
case OP_AND:
case OP_DOR:
case OP_COND_EXPR:
+ case OP_ENTERGIVEN:
+ case OP_ENTERWHEN:
for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
scalarvoid(kid);
break;
@@ -841,6 +843,8 @@
case OP_LEAVELOOP:
case OP_LINESEQ:
case OP_LIST:
+ case OP_LEAVEGIVEN:
+ case OP_LEAVEWHEN:
for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
scalarvoid(kid);
break;
@@ -4031,6 +4035,139 @@
return o;
}
+/* These construct the optree fragments representing given()
+ and when() blocks.
+
+ entergiven and enterwhen are LOGOPs; the op_other pointer
+ points up to the associated leave op. We need this so we
+ can put it in the context and make break/continue work.
+ (Also, of course, pp_enterwhen will jump straight to
+ op_other if the match fails.)
+ */
+
+STATIC
+OP *
+S_newGIVWHENOP(pTHX_ OP *cond, U8 private, OP *block,
+ I32 enter_opcode, I32 leave_opcode)
+{
+ LOGOP *enterop;
+ OP *o;
+ OP *cond_start;
+
+ NewOp(1101, enterop, 1, LOGOP);
+ enterop->op_type = enter_opcode;
+ enterop->op_ppaddr = PL_ppaddr[enter_opcode];
+ enterop->op_flags = (U8) OPf_KIDS;
+ enterop->op_private = private;
+
+ if (cond) {
+ /* if the condition is a literal array or hash
+ (or @{ ... } etc), make a reference to it.
+ */
+ if (cond->op_type == OP_RV2AV
+ || cond->op_type == OP_PADAV
+ || cond->op_type == OP_RV2HV
+ || cond->op_type == OP_PADHV)
+
+ cond = newUNOP(OP_REFGEN,
+ 0, mod(cond, OP_REFGEN));
+
+ enterop->op_first = scalar(cond);
+ cond->op_sibling = block;
+ cond_start = LINKLIST(cond);
+ }
+ else {
+ /* This is a default {} block */
+ enterop->op_first = block;
+ enterop->op_flags |= OPf_SPECIAL;
+ }
+
+ CHECKOP(enter_opcode, enterop);
+ o = newUNOP(leave_opcode, 0, (OP *) enterop);
+
+ if (cond) {
+ o->op_next = cond_start;
+ cond->op_next = (OP *) enterop;
+ }
+ else
+ o->op_next = (OP *) enterop;
+
+ enterop->op_next = LINKLIST(block);
+ block->op_next = enterop->op_other = o;
+
+ return o;
+}
+
+/* Does this look like a boolean operation? For these purposes
+ a boolean operation is:
+ - a subroutine call [*]
+ - a logical connective
+ - a comparison operator
+ - a filetest operator, with the exception of -s -M -A -C
+ - exists() or eof()
+ - /$re/
+
+ [*] possibly surprising
+ */
+STATIC
+bool
+S_looks_like_bool(OP *o)
+{
+ if (!o) return FALSE;
+
+ switch(o->op_type) {
+ case OP_ENTERSUB:
+
+ case OP_NOT: case OP_AND: case OP_OR:
+ case OP_XOR: /* Note that OP_DOR is not here */
+
+ case OP_EQ: case OP_NE: case OP_LT:
+ case OP_GT: case OP_LE: case OP_GE:
+
+ case OP_I_EQ: case OP_I_NE: case OP_I_LT:
+ case OP_I_GT: case OP_I_LE: case OP_I_GE:
+
+ case OP_SEQ: case OP_SNE: case OP_SLT:
+ case OP_SGT: case OP_SLE: case OP_SGE:
+
+ case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
+ case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
+ case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
+ case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
+ case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
+ case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
+ case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
+ case OP_FTTEXT: case OP_FTBINARY:
+
+ case OP_EXISTS: case OP_MATCH: case OP_EOF:
+
+ return TRUE;
+
+ default:
+ return FALSE;
+ }
+}
+
+OP *
+Perl_newGIVENOP(pTHX_ OP *cond, OP *block)
+{
+ assert( cond );
+ return S_newGIVWHENOP(aTHX_
+ cond, 0,
+ block,
+ OP_ENTERGIVEN, OP_LEAVEGIVEN);
+}
+
+/* If cond is null, this is a default {} block */
+OP *
+Perl_newWHENOP(pTHX_ OP *cond, OP *block)
+{
+ return S_newGIVWHENOP(aTHX_
+ cond, (S_looks_like_bool(cond) ? OPpWHEN_BOOL : 0),
+ append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
+ OP_ENTERWHEN, OP_LEAVEWHEN);
+}
+
/*
=for apidoc cv_undef
diff -bru -X /Users/robin/.perl-patch.ignore perl-before/op.h perl-after/op.h
--- perl-before/op.h 2005-12-06 17:52:16.000000000 +0000
+++ perl-after/op.h 2005-12-08 16:33:08.000000000 +0000
@@ -110,6 +110,8 @@
* (runtime property) */
/* On OP_AELEMFAST, indiciates pad var */
/* On OP_REQUIRE, was seen as CORE::require */
+ /* On OP_ENTERWHEN, there's no condition */
+ /* On OP_BREAK, an implicit break */
/* old names; don't use in new code, but don't break them, either */
#define OPf_LIST OPf_WANT_LIST
@@ -238,6 +240,9 @@
/* Private for OP_(MAP|GREP)(WHILE|START) */
#define OPpGREP_LEX 2 /* iterate over lexical $_ */
+/* Private for OP_ENTERWHEN */
+#define OPpWHEN_BOOL 1 /* treat arg as boolean (don't match) */
+
struct op {
BASEOP
};
diff -bru -X /Users/robin/.perl-patch.ignore perl-before/opcode.pl perl-after/opcode.pl
--- perl-before/opcode.pl 2005-12-01 12:19:34.000000000 +0000
+++ perl-after/opcode.pl 2005-12-08 16:33:08.000000000 +0000
@@ -1019,6 +1019,13 @@
dor defined or (//) ck_null |
dorassign defined or assignment (//=) ck_null s|
+entergiven given() ck_null d|
+leavegiven leave given block ck_null 1
+enterwhen when() ck_null d|
+leavewhen leave when block ck_null 1
+break break ck_null 0
+continue continue ck_null 0
+
# Add new ops before this, the custom operator.
custom unknown custom operator ck_null 0
diff -bru -X /Users/robin/.perl-patch.ignore perl-before/opnames.h perl-after/opnames.h
--- perl-before/opnames.h 2005-06-09 10:51:29.000000000 +0100
+++ perl-after/opnames.h 2005-12-08 16:57:25.000000000 +0000
@@ -367,11 +367,17 @@
OP_METHOD_NAMED,/* 350 */
OP_DOR, /* 351 */
OP_DORASSIGN, /* 352 */
- OP_CUSTOM, /* 353 */
+ OP_ENTERGIVEN, /* 353 */
+ OP_LEAVEGIVEN, /* 354 */
+ OP_ENTERWHEN, /* 355 */
+ OP_LEAVEWHEN, /* 356 */
+ OP_BREAK, /* 357 */
+ OP_CONTINUE, /* 358 */
+ OP_CUSTOM, /* 359 */
OP_max
} opcode;
-#define MAXO 354
+#define MAXO 360
#define OP_phoney_INPUT_ONLY -1
#define OP_phoney_OUTPUT_ONLY -2
diff -bru -X /Users/robin/.perl-patch.ignore perl-before/perl.h perl-after/perl.h
--- perl-before/perl.h 2005-12-01 16:10:09.000000000 +0000
+++ perl-after/perl.h 2005-12-08 16:33:08.000000000 +0000
@@ -4019,6 +4019,9 @@
"LOOP",
"SUBST",
"BLOCK",
+ "FORMAT",
+ "GIVEN",
+ "WHEN"
};
#else
EXTCONST char* PL_block_type[];
diff -bru -X /Users/robin/.perl-patch.ignore perl-before/perl_keyword.pl perl-after/perl_keyword.pl
--- perl-before/perl_keyword.pl 2005-05-09 09:08:36.000000000 +0100
+++ perl-after/perl_keyword.pl 2005-12-08 16:33:08.000000000 +0000
@@ -5,34 +5,35 @@
use strict;
use warnings;
-my @pos = qw(__DATA__ __END__ AUTOLOAD BEGIN CHECK DESTROY do delete defined
- END else eval elsif exists for format foreach grep goto glob INIT
- if last local m my map next no our pos print printf package
- prototype q qr qq qw qx redo return require s scalar sort split
- study sub tr tie tied use undef until untie unless while y);
+my @pos = qw(__DATA__ __END__ AUTOLOAD BEGIN CHECK DESTROY default defined
+ delete do END else eval elsif exists for format foreach given grep
+ goto glob INIT if last local m my map next no our pos print printf
+ package prototype q qr qq qw qx redo return require s scalar sort
+ split study sub tr tie tied use undef until untie unless when while
+ y);
my @neg = qw(__FILE__ __LINE__ __PACKAGE__ and abs alarm atan2 accept bless
- bind binmode CORE cmp chr cos chop close chdir chomp chmod chown
- crypt chroot caller connect closedir continue die dump dbmopen
- dbmclose eq eof err exp exit exec each endgrent endpwent
- endnetent endhostent endservent endprotoent fork fcntl flock
- fileno formline getppid getpgrp getpwent getpwnam getpwuid
- getpeername getprotoent getpriority getprotobyname
- getprotobynumber gethostbyname gethostbyaddr gethostent
- getnetbyname getnetbyaddr getnetent getservbyname getservbyport
- getservent getsockname getsockopt getgrent getgrnam getgrgid
- getlogin getc gt ge gmtime hex int index ioctl join keys kill lt
- le lc log link lock lstat length listen lcfirst localtime mkdir
- msgctl msgget msgrcv msgsnd ne not or ord oct open opendir pop
- push pack pipe quotemeta ref read rand recv rmdir reset rename
- rindex reverse readdir readlink readline readpipe rewinddir seek
- send semop select semctl semget setpgrp seekdir setpwent setgrent
- setnetent setsockopt sethostent setservent setpriority
- setprotoent shift shmctl shmget shmread shmwrite shutdown sin
- sleep socket socketpair sprintf splice sqrt srand stat substr
- system symlink syscall sysopen sysread sysseek syswrite tell time
- times telldir truncate uc utime umask unpack unlink unshift
- ucfirst values vec warn wait write waitpid wantarray x xor);
+ break bind binmode CORE cmp chr cos chop close chdir chomp chmod
+ chown crypt chroot caller connect closedir continue die dump
+ dbmopen dbmclose eq eof err exp exit exec each endgrent endpwent
+ endnetent endhostent endservent endprotoent fork fcntl flock fileno
+ formline getppid getpgrp getpwent getpwnam getpwuid getpeername
+ getprotoent getpriority getprotobyname getprotobynumber
+ gethostbyname gethostbyaddr gethostent getnetbyname getnetbyaddr
+ getnetent getservbyname getservbyport getservent getsockname
+ getsockopt getgrent getgrnam getgrgid getlogin getc gt ge gmtime
+ hex int index ioctl join keys kill lt le lc log link lock lstat
+ length listen lcfirst localtime mkdir msgctl msgget msgrcv msgsnd
+ ne not or ord oct open opendir pop push pack pipe quotemeta ref
+ read rand recv rmdir reset rename rindex reverse readdir readlink
+ readline readpipe rewinddir seek send semop select semctl semget
+ setpgrp seekdir setpwent setgrent setnetent setsockopt sethostent
+ setservent setpriority setprotoent shift shmctl shmget shmread
+ shmwrite shutdown sin sleep socket socketpair sprintf splice sqrt
+ srand stat substr system symlink syscall sysopen sysread sysseek
+ syswrite tell time times telldir truncate uc utime umask unpack
+ unlink unshift ucfirst values vec warn wait write waitpid wantarray
+ x xor);
my %pos = map { ($_ => 1) } @pos;
diff -bru -X /Users/robin/.perl-patch.ignore perl-before/perly.y perl-after/perly.y
--- perl-before/perly.y 2005-10-13 10:34:41.000000000 +0100
+++ perl-after/perly.y 2005-12-08 16:33:08.000000000 +0000
@@ -41,6 +41,7 @@
%token <pval> LABEL
%token <ival> FORMAT SUB ANONSUB PACKAGE USE
%token <ival> WHILE UNTIL IF UNLESS ELSE ELSIF CONTINUE FOR
+%token <ival> GIVEN WHEN DEFAULT
%token <ival> LOOPEX DOTDOT
%token <ival> FUNC0 FUNC1 FUNC UNIOP LSTOP
%token <ival> RELOP EQOP MULOP ADDOP
@@ -57,6 +58,7 @@
%type <opval> formname subname proto subbody cont my_scalar
%type <opval> subattrlist myattrlist mysubrout myattrterm myterm
%type <opval> termbinop termunop anonymous termdo
+%type <opval> switch case
%type <pval> label
%nonassoc PREC_LOW
@@ -146,6 +148,10 @@
line : label cond
{ $$ = newSTATEOP(0, $1, $2); }
| loop /* loops add their own labels */
+ | switch /* ... and so do switches */
+ { $$ = $1; }
+ | label case
+ { $$ = newSTATEOP(0, $1, $2); }
| label ';'
{ if ($1 != Nullch) {
$$ = newSTATEOP(0, $1, newOP(OP_NULL, 0));
@@ -200,6 +206,14 @@
newCONDOP(0, $4, scope($6), $7)); }
;
+/* Cases for a switch statement */
+case : WHEN '(' remember mexpr ')' mblock
+ { $$ = block_end($3,
+ newWHENOP($4, scope($6))); }
+ | DEFAULT block
+ { $$ = newWHENOP(0, scope($2)); }
+ ;
+
/* Continue blocks */
cont : /* NULL */
{ $$ = Nullop; }
@@ -253,6 +267,14 @@
NOLINE, Nullop, $2, $3, 0)); }
;
+/* Switch blocks */
+switch : label GIVEN '(' remember mexpr ')' mblock
+ { PL_copline = (line_t) $2;
+ $$ = block_end($4,
+ newSTATEOP(0, $1,
+ newGIVENOP($5, scope($7)) )); }
+ ;
+
/* determine whether there are any new my declarations */
mintro : /* NULL */
{ $$ = (PL_min_intro_pending &&
diff -bru -X /Users/robin/.perl-patch.ignore perl-before/pod/perldiag.pod perl-after/pod/perldiag.pod
--- perl-before/pod/perldiag.pod 2005-12-05 16:48:14.000000000 +0000
+++ perl-after/pod/perldiag.pod 2005-12-08 16:33:08.000000000 +0000
@@ -491,6 +491,13 @@
(F) Only hard references may be blessed. This is how Perl "enforces"
encapsulation of objects. See L<perlobj>.
+=item Can't "break" in a loop topicaizer
+(F) You called C<break>, but you're in a C<foreach> block rather than
+a C<given> block. You probably meant to use C<next> or C<last>.
+
+=item Can't "break" outside a given block
+(F) You called C<break>, but you're not inside a C<given> block.
+
=item Can't call method "%s" in empty package "%s"
(F) You called a method correctly, and it correctly indicated a package
@@ -566,6 +573,10 @@
(F) Certain types of SVs, in particular real symbol table entries
(typeglobs), can't be forced to stop being what they are.
+=item Can't "continue" outside a when block
+(F) You called C<continue>, but you're not inside a C<when>
+or C<default> block.
+
=item Can't create pipe mailbox
(P) An error peculiar to VMS. The process is suffering from exhausted
@@ -1144,6 +1155,12 @@
value that prints out looking like SCALAR(0xdecaf). Use the $1 form
instead.
+=item Can't use "when" outside a topicalizer
+(F) You have used a when() block that is neither inside a C<foreach>
+loop nor a C<given> block. (Note that this error is issued on exit
+from the C<when> block, so you won't get the error if the match fails,
+or if you use an explicit C<continue>.)
+
=item Can't weaken a nonreference
(F) You attempted to weaken something that was not a reference. Only
diff -bru -X /Users/robin/.perl-patch.ignore perl-before/pp_ctl.c perl-after/pp_ctl.c
--- perl-before/pp_ctl.c 2005-12-06 17:52:16.000000000 +0000
+++ perl-after/pp_ctl.c 2005-12-09 12:22:21.000000000 +0000
@@ -1192,7 +1192,9 @@
"loop",
"substitution",
"block",
- "format"
+ "format",
+ "given",
+ "when"
};
STATIC I32
@@ -1208,6 +1210,8 @@
case CXt_FORMAT:
case CXt_EVAL:
case CXt_NULL:
+ case CXt_GIVEN:
+ case CXt_WHEN:
if (ckWARN(WARN_EXITING))
Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
context_name[CxTYPE(cx)], OP_NAME(PL_op));
@@ -1227,6 +1231,8 @@
return i;
}
+
+
I32
Perl_dowantarray(pTHX)
{
@@ -1335,6 +1341,45 @@
return i;
}
+STATIC I32
+S_dopoptogiven(pTHX_ I32 startingblock)
+{
+ I32 i;
+ for (i = startingblock; i >= 0; i--) {
+ register const PERL_CONTEXT *cx = &cxstack[i];
+ switch (CxTYPE(cx)) {
+ default:
+ continue;
+ case CXt_GIVEN:
+ DEBUG_l( Perl_deb(aTHX_ "(Found given #%ld)\n", (long)i));
+ return i;
+ case CXt_LOOP:
+ if (CxFOREACHDEF(cx)) {
+ DEBUG_l( Perl_deb(aTHX_ "(Found foreach #%ld)\n", (long)i));
+ return i;
+ }
+ }
+ }
+ return i;
+}
+
+STATIC I32
+S_dopoptowhen(pTHX_ I32 startingblock)
+{
+ I32 i;
+ for (i = startingblock; i >= 0; i--) {
+ register const PERL_CONTEXT *cx = &cxstack[i];
+ switch (CxTYPE(cx)) {
+ default:
+ continue;
+ case CXt_WHEN:
+ DEBUG_l( Perl_deb(aTHX_ "(Found when #%ld)\n", (long)i));
+ return i;
+ }
+ }
+ return i;
+}
+
void
Perl_dounwind(pTHX_ I32 cxix)
{
@@ -1726,7 +1771,7 @@
register PERL_CONTEXT *cx;
const I32 gimme = GIMME_V;
SV **svp;
- U32 cxtype = CXt_LOOP;
+ U32 cxtype = CXt_LOOP | CXp_FOREACH;
#ifdef USE_ITHREADS
void *iterdata;
#endif
@@ -1751,6 +1796,8 @@
}
else {
GV * const gv = (GV*)POPs;
+ if (gv == PL_defgv)
+ cxtype |= CXp_DEFGV;
svp = &GvSV(gv); /* symbol table variable */
SAVEGENERICSV(*svp);
*svp = NEWSV(0,0);
@@ -3586,6 +3633,292 @@
RETURN;
}
+PP(pp_entergiven)
+{
+ dVAR; dSP;
+ register PERL_CONTEXT *cx;
+ const I32 gimme = GIMME_V;
+ SV **defsv_p = &GvSV(PL_defgv);
+
+ ENTER;
+ SAVETMPS;
+ SAVEGENERICSV(*defsv_p);
+ *defsv_p = newSVsv(POPs);
+ SAVECLEARSV(*defsv_p);
+
+ PUSHBLOCK(cx, CXt_GIVEN, SP);
+ PUSHGIVEN(cx);
+
+ RETURN;
+}
+
+PP(pp_leavegiven)
+{
+ dVAR; dSP;
+ register PERL_CONTEXT *cx;
+ I32 gimme;
+ SV **newsp;
+ PMOP *newpm;
+ SV **mark;
+
+ POPBLOCK(cx,newpm);
+ assert(CxTYPE(cx) == CXt_GIVEN);
+ mark = newsp;
+
+ SP = newsp;
+ PUTBACK;
+
+ PL_curpm = newpm; /* pop $1 et al */
+
+ LEAVE;
+
+ return NORMAL;
+}
+
+/* Helper routine used by S_smartmatch to make callbacks.
+ */
+STATIC void
+S_when_callback(pTHX_ SV *sub_ref, SV *arg)
+{
+ dSP;
+ I32 c;
+
+ ENTER;
+ SAVETMPS;
+ PUSHMARK(SP);
+ PUSHs(arg);
+ PUTBACK;
+ c = call_sv(SvRV(sub_ref), G_SCALAR);
+ SPAGAIN;
+ if (c == 0)
+ PUSHs(&PL_sv_no);
+ else if (SvTEMP(TOPs))
+ SvREFCNT_inc(TOPs);
+ FREETMPS;
+ LEAVE;
+ PUTBACK;
+}
+
+/* Do a smart match, using the stack.
+ (This is pp_smartmatch in all but name.)
+ */
+STATIC void
+S_smartmatch(pTHX)
+{
+ dSP;
+ /* Should smart match semantics be overloadable? */
+
+ SV * d = TOPs;
+ SV * e = TOPm1s;
+
+ SV * ref;
+ SV * other;
+ bool both_are_refs = FALSE;
+ U32 ref_type, other_type;
+
+ /* We shall have to be very careful only to invoke mg_get()
+ once for each argument.
+
+ It's possible that d is magical if we're in a for() loop,
+ or if $_ has been explicitly assigned to.
+ */
+ if (d) {
+ /* This is a really cheesy way of avoiding multiple mg_gets. */
+ if (SvGMAGICAL(d))
+ TOPs = d = sv_mortalcopy(d);
+ }
+ else
+ /* Since it's undef, we're never going to look at the stacked
+ value, so there's no need to change it.
+ */
+ d = &PL_sv_undef;
+
+ assert(e);
+ if (SvGMAGICAL(e))
+ /* More cheese */
+ TOPm1s = e = sv_mortalcopy(e);
+
+ /* It's possible that we could speed up the below by using
+ a cunning switch() based on the SvFLAGS of d and e.
+ */
+
+ /* If either is undef, they must both be: */
+ if (!SvOK(d) || !SvOK(e)) {
+ (void) POPs;
+ TOPs = ( (!SvOK(d) && !SvOK(e)) ? &PL_sv_yes : &PL_sv_no );
+ PUTBACK;
+ return;
+ }
+ /* If both are numeric, compare as numbers */
+ else if ( (SvIOK(d) || SvNOK(d)) && (SvIOK(e) || SvNOK(e)) ) {
+ if ((PL_curcop->op_private & HINT_INTEGER) == HINT_INTEGER)
+ (void) pp_i_eq();
+ else
+ (void) pp_eq();
+ return;
+ }
+ /* if neither is a reference, compare as strings */
+ else if (!SvROK(d) && !SvROK(e)) {
+ (void) pp_seq();
+ return;
+ }
+
+ /* From this point onwards, at least one argument
+ * is a reference.
+ */
+
+ if (SvROK(d)) {
+ ref = d;
+ other = e;
+ if (SvROK(e)) {
+ both_are_refs = TRUE;
+ other_type = SvTYPE(SvRV(other));
+ }
+ }
+ else {
+ ref = e;
+ other = d;
+ }
+ ref_type = SvTYPE(SvRV(ref));
+
+ if (both_are_refs)
+ {
+ /* If both are code references, check referential equality */
+ if (ref_type == SVt_PVCV && other_type == SVt_PVCV)
+ {
+ (void) pp_i_eq();
+ return;
+ }
+ /* XXX - other possibilities here */
+ }
+
+ sp -= 2; /* Pop both args */
+ PUTBACK;
+
+ /* If just one is a code reference, call it with the other
+ as an argument. */
+ if (ref_type == SVt_PVCV)
+ return when_callback(ref, other);
+ else if (other_type == SVt_PVCV)
+ return when_callback(other, ref);
+
+ /* If both are arrays, check deep equality */
+
+ /* Give up */
+ Perl_croak(aTHX_ "Don't know how to compare");
+}
+
+PP(pp_enterwhen)
+{
+ dVAR; dSP;
+ register PERL_CONTEXT *cx;
+ const I32 gimme = GIMME_V;
+
+ if (!(PL_op->op_flags & OPf_SPECIAL))
+ {
+ /* Not a default {} block, so there's a condition to check */
+ if (0 == (PL_op->op_private & OPpWHEN_BOOL))
+ {
+ XPUSHs(GvSV(PL_defgv));
+ PUTBACK;
+ smartmatch();
+ SPAGAIN;
+ }
+
+
+ /* This is essentially an optimization: if the match
+ fails, we don't want to push a context and then
+ pop it again right away, so we skip straight
+ to the op that follows the leavewhen.
+ */
+ if (!SvTRUEx(POPs))
+ return cLOGOP->op_other->op_next;
+ }
+
+ ENTER;
+ SAVETMPS;
+
+ PUSHBLOCK(cx, CXt_WHEN, SP);
+ PUSHWHEN(cx);
+
+ RETURN;
+}
+
+PP(pp_leavewhen)
+{
+ dVAR; dSP;
+ register PERL_CONTEXT *cx;
+ I32 gimme;
+ SV **newsp;
+ PMOP *newpm;
+
+ POPBLOCK(cx,newpm);
+ assert(CxTYPE(cx) == CXt_WHEN);
+
+ SP = newsp;
+ PUTBACK;
+
+ PL_curpm = newpm; /* pop $1 et al */
+
+ LEAVE;
+ return NORMAL;
+}
+
+PP(pp_continue)
+{
+ dVAR;
+ I32 cxix;
+ register PERL_CONTEXT *cx;
+ I32 inner;
+
+ cxix = dopoptowhen(cxstack_ix);
+ if (cxix < 0)
+ DIE(aTHX_ "Can't \"continue\" outside a when block");
+ if (cxix < cxstack_ix)
+ dounwind(cxix);
+
+ /* clear off anything above the scope we're re-entering */
+ inner = PL_scopestack_ix;
+ TOPBLOCK(cx);
+ if (PL_scopestack_ix < inner)
+ leave_scope(PL_scopestack[PL_scopestack_ix]);
+ PL_curcop = cx->blk_oldcop;
+ return cx->blk_givwhen.leave_op;
+}
+
+PP(pp_break)
+{
+ dVAR;
+ I32 cxix;
+ register PERL_CONTEXT *cx;
+ I32 inner;
+
+ cxix = dopoptogiven(cxstack_ix);
+ if (cxix < 0) {
+ if (PL_op->op_flags & OPf_SPECIAL)
+ DIE(aTHX_ "Can't use when() outside a topicalizer");
+ else
+ DIE(aTHX_ "Can't \"break\" outside a given block");
+ }
+ if (CxFOREACH(&cxstack[cxix]) && (0 == (PL_op->op_flags & OPf_SPECIAL)))
+ DIE(aTHX_ "Can't \"break\" in a loop topicalizer");
+
+ if (cxix < cxstack_ix)
+ dounwind(cxix);
+
+ /* clear off anything above the scope we're re-entering */
+ inner = PL_scopestack_ix;
+ TOPBLOCK(cx);
+ if (PL_scopestack_ix < inner)
+ leave_scope(PL_scopestack[PL_scopestack_ix]);
+ PL_curcop = cx->blk_oldcop;
+
+ if (CxFOREACH(cx))
+ return cx->blk_loop.next_op;
+ else
+ return cx->blk_givwhen.leave_op;
+}
+
STATIC OP *
S_doparseform(pTHX_ SV *sv)
{
diff -bru -X /Users/robin/.perl-patch.ignore perl-before/sv.h perl-after/sv.h
--- perl-before/sv.h 2005-11-19 00:48:26.000000000 +0000
+++ perl-after/sv.h 2005-12-08 16:33:08.000000000 +0000
@@ -116,7 +116,7 @@
};
struct av {
- _SV_HEAD(XPVAV*); /* pointer to xpvcv body */
+ _SV_HEAD(XPVAV*); /* pointer to xpvav body */
_SV_HEAD_UNION;
};
@@ -131,7 +131,7 @@
};
#undef _SV_HEAD
-#undef _SV_HEAD_UNION /* insure no pollution */
+#undef _SV_HEAD_UNION /* ensure no pollution */
/*
=head1 SV Manipulation Functions
diff -bru -X /Users/robin/.perl-patch.ignore perl-before/t/op/cproto.t perl-after/t/op/cproto.t
--- perl-before/t/op/cproto.t 2005-05-03 17:11:55.000000000 +0100
+++ perl-after/t/op/cproto.t 2005-12-08 16:33:08.000000000 +0000
@@ -47,7 +47,7 @@
closedir (*)
cmp unknown
connect (*$)
-continue unknown
+continue ()
cos (;$)
crypt ($$)
dbmclose (\%)
diff -bru -X /Users/robin/.perl-patch.ignore perl-before/toke.c perl-after/toke.c
--- perl-before/toke.c 2005-12-06 17:52:17.000000000 +0000
+++ perl-after/toke.c 2005-12-08 16:50:04.000000000 +0000
@@ -219,6 +219,7 @@
{ BITOROP, TOKENTYPE_OPNUM, "BITOROP" },
{ COLONATTR, TOKENTYPE_NONE, "COLONATTR" },
{ CONTINUE, TOKENTYPE_NONE, "CONTINUE" },
+ { DEFAULT, TOKENTYPE_NONE, "DEFAULT" },
{ DO, TOKENTYPE_NONE, "DO" },
{ DOLSHARP, TOKENTYPE_NONE, "DOLSHARP" },
{ DORDOR, TOKENTYPE_NONE, "DORDOR" },
@@ -234,6 +235,7 @@
{ FUNC0SUB, TOKENTYPE_OPVAL, "FUNC0SUB" },
{ FUNC1, TOKENTYPE_OPNUM, "FUNC1" },
{ FUNCMETH, TOKENTYPE_OPVAL, "FUNCMETH" },
+ { GIVEN, TOKENTYPE_IVAL, "GIVEN" },
{ HASHBRACK, TOKENTYPE_NONE, "HASHBRACK" },
{ IF, TOKENTYPE_IVAL, "IF" },
{ LABEL, TOKENTYPE_PVAL, "LABEL" },
@@ -269,6 +271,7 @@
{ UNLESS, TOKENTYPE_IVAL, "UNLESS" },
{ UNTIL, TOKENTYPE_IVAL, "UNTIL" },
{ USE, TOKENTYPE_IVAL, "USE" },
+ { WHEN, TOKENTYPE_IVAL, "WHEN" },
{ WHILE, TOKENTYPE_IVAL, "WHILE" },
{ WORD, TOKENTYPE_OPVAL, "WORD" },
{ 0, TOKENTYPE_NONE, 0 }
@@ -455,6 +458,33 @@
}
/*
+ * S_keyword_is_enabled
+ * Check whether the keyword is currently enabled.
+ * (Some keywords may be enabled and disabled using the 'feature' pragma.)
+ */
+STATIC bool
+S_keyword_is_enabled(I32 kw)
+{
+ switch (kw) {
+ case KEY_given:
+ case KEY_when:
+ case KEY_default:
+ case -KEY_break:
+ /* continue is a keyword in any case. See
+ case KEY_continue below.
+ */
+ {
+ HV * const hinthv = GvHV(PL_hintgv);
+ if (!hinthv || !hv_exists(hinthv, "switch", 6))
+ return FALSE;
+ }
+ /* FALL THROUGH */
+ default:
+ return TRUE;
+ }
+}
+
+/*
* Perl_deprecate
*/
@@ -4102,6 +4132,10 @@
TERM(WORD);
}
+ /* Some keywords are enabled by the 'feature' pragma */
+ if (!keyword_is_enabled(tmp))
+ tmp = 0;
+
if (tmp < 0) { /* second-class keyword? */
GV *ogv = Nullgv; /* override (winner) */
GV *hgv = Nullgv; /* hidden (loser) */
@@ -4552,11 +4586,32 @@
case KEY_bless:
LOP(OP_BLESS,XTERM);
+ case KEY_break:
+ FUN0(OP_BREAK);
+
case KEY_chop:
UNI(OP_CHOP);
case KEY_continue:
+ /* When 'use switch' is in effect, continue has a dual
+ life as a control operator. */
+ {
+ HV * const hinthv = GvHV(PL_hintgv);
+ if (!hinthv || !hv_exists(hinthv, "switch", 6))
PREBLOCK(CONTINUE);
+ else {
+ /* We have to disambiguate the two senses of
+ "continue". If the next token is a '{' then
+ treat it as the start of a continue block;
+ otherwise treat it as a control operator.
+ */
+ s = skipspace(s);
+ if (*s == '{')
+ PREBLOCK(CONTINUE);
+ else
+ FUN0(OP_CONTINUE);
+ }
+ }
case KEY_chdir:
(void)gv_fetchpv("ENV",TRUE, SVt_PVHV); /* may use HOME */
@@ -4601,6 +4656,9 @@
case KEY_chroot:
UNI(OP_CHROOT);
+ case KEY_default:
+ PREBLOCK(DEFAULT);
+
case KEY_do:
s = skipspace(s);
if (*s == '{')
@@ -4823,6 +4881,10 @@
case KEY_getlogin:
FUN0(OP_GETLOGIN);
+ case KEY_given:
+ yylval.ival = CopLINE(PL_curcop);
+ OPERATOR(GIVEN);
+
case KEY_glob:
set_csh();
LOP(OP_GLOB,XTERM);
@@ -5495,6 +5557,10 @@
case KEY_vec:
LOP(OP_VEC,XTERM);
+ case KEY_when:
+ yylval.ival = CopLINE(PL_curcop);
+ OPERATOR(WHEN);
+
case KEY_while:
yylval.ival = CopLINE(PL_curcop);
OPERATOR(WHILE);
@@ -6140,7 +6206,7 @@
goto unknown;
}
- case 4: /* 40 tokens of length 4 */
+ case 4: /* 41 tokens of length 4 */
switch (name[0])
{
case 'C':
@@ -6570,8 +6636,9 @@
}
case 'w':
- if (name[1] == 'a')
+ switch (name[1])
{
+ case 'a':
switch (name[2])
{
case 'i':
@@ -6593,6 +6660,12 @@
default:
goto unknown;
}
+
+ case 'h':
+ if (name[2] == 'e' &&
+ name[3] == 'n')
+ { /* when */
+ return KEY_when;
}
goto unknown;
@@ -6601,7 +6674,11 @@
goto unknown;
}
- case 5: /* 36 tokens of length 5 */
+ default:
+ goto unknown;
+ }
+
+ case 5: /* 38 tokens of length 5 */
switch (name[0])
{
case 'B':
@@ -6654,8 +6731,10 @@
}
case 'b':
- if (name[1] == 'l' &&
- name[2] == 'e' &&
+ switch (name[1])
+ {
+ case 'l':
+ if (name[2] == 'e' &&
name[3] == 's' &&
name[4] == 's')
{ /* bless */
@@ -6664,6 +6743,20 @@
goto unknown;
+ case 'r':
+ if (name[2] == 'e' &&
+ name[3] == 'a' &&
+ name[4] == 'k')
+ { /* break */
+ return -KEY_break;
+ }
+
+ goto unknown;
+
+ default:
+ goto unknown;
+ }
+
case 'c':
switch (name[1])
{
@@ -6777,6 +6870,17 @@
goto unknown;
}
+ case 'g':
+ if (name[1] == 'i' &&
+ name[2] == 'v' &&
+ name[3] == 'e' &&
+ name[4] == 'n')
+ { /* given */
+ return KEY_given;
+ }
+
+ goto unknown;
+
case 'i':
switch (name[1])
{
@@ -7513,7 +7617,7 @@
goto unknown;
}
- case 7: /* 28 tokens of length 7 */
+ case 7: /* 29 tokens of length 7 */
switch (name[0])
{
case 'D':
@@ -7584,9 +7688,22 @@
goto unknown;
case 'e':
- if (name[2] == 'f' &&
- name[3] == 'i' &&
- name[4] == 'n' &&
+ if (name[2] == 'f')
+ {
+ switch (name[3])
+ {
+ case 'a':
+ if (name[4] == 'u' &&
+ name[5] == 'l' &&
+ name[6] == 't')
+ { /* default */
+ return KEY_default;
+ }
+
+ goto unknown;
+
+ case 'i':
+ if (name[4] == 'n' &&
name[5] == 'e' &&
name[6] == 'd')
{ /* defined */
@@ -7598,6 +7715,13 @@
default:
goto unknown;
}
+ }
+
+ goto unknown;
+
+ default:
+ goto unknown;
+ }
case 'f':
if (name[1] == 'o' &&
@@ -9004,7 +9128,7 @@
while (s < PL_bufend && isSPACE(*s))
s++;
if (*s == ',') {
- int kw;
+ I32 kw;
*s = '\0'; /* XXX If we didn't do this, we could const a lot of toke.c */
kw = keyword(w, s - w) || get_cv(w, FALSE) != 0;
*s = ',';
@@ -9260,8 +9384,11 @@
*d = '\0';
while (s < send && SPACE_OR_TAB(*s)) s++;
if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
- if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest)) {
+ if (ckWARN(WARN_AMBIGUOUS)) {
+ const I32 kw = keyword(dest, d - dest);
const char *brack = *s == '[' ? "[...]" : "{...}";
+
+ if (keyword_is_enabled(kw))
Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
"Ambiguous use of %c{%s%s} resolved to %c%s%s",
funny, dest, brack, funny, dest, brack);
@@ -9293,9 +9420,12 @@
if (funny == '#')
funny = '@';
if (PL_lex_state == LEX_NORMAL) {
- if (ckWARN(WARN_AMBIGUOUS) &&
- (keyword(dest, d - dest) || get_cv(dest, FALSE)))
- {
+ if (ckWARN(WARN_AMBIGUOUS)) {
+ I32 kw = keyword(dest, d - dest);
+
+ if (!keyword_is_enabled(kw))
+ kw = 0;
+ if (kw || get_cv(dest, FALSE))
Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
"Ambiguous use of %c{%s} resolved to %c%s",
funny, dest, funny, dest);
--- /dev/null 2005-12-09 12:35:12.000000000 +0000
+++ perl-after/lib/feature.pm 2005-12-09 12:28:47.000000000 +0000
@@ -0,0 +1,106 @@
+package feature;
+
+our $VERSION = '1.00';
+$feature::hint_bits = 0x20000; # HINT_LOCALIZE_HH
+
+# Here are some notes that probably shouldn't be in the public
+# documentation, but which it's useful to have somewhere.
+#
+# Disabled keywords are not completely inaccessible when
+# the feature is disabled. Indeed, you can access them
+# by prefixing the keyword with CORE::
+# This is a feature, not a bug (though of course it can
+# be reclassified if it turns out to cause problems).
+#
+# One side-effect of the change is that C<prototype("CORE::continue")>
+# no longer throws the error C<Can't find an opnumber for "continue">.
+# One of the tests in t/op/cproto.t had to be changed to accommodate
+# this, but it really shouldn't affect real-world code.
+#
+# TODO:
+# - sort out the smartmatch semantics
+# - overloadable smartmatch
+# - add an explicit smartmatch op / feature?
+# - add a 'say' feature
+# - versioned features (use feature switch => 1.0) ?
+# (would allow us to make incompatible changes w/o breaking code)
+#
+# -- Robin 2005-12
+
+=head1 NAME
+
+feature - Perl pragma to enable new syntactic features
+
+=head1 SYNOPSIS
+
+ use feature 'switch';
+ given ($foo) {
+ when (1) { print "\$foo == 1\n" }
+ when ([2,3]) { print "\$foo == 2 || \$foo == 3\n" }
+ when (/^a[bc]d$/) { print "\$foo eq 'abd' || \$foo eq 'acd'\n" }
+ when ($_ > 100) { print "\$foo > 100\n" }
+ default { print "None of the above\n" }
+ }
+
+=head1 DESCRIPTION
+
+It is usually impossible to add new syntax to Perl without breaking
+some existing programs. This pragma provides a way to minimize that
+risk. New syntactic constructs can be enabled by C<use feature 'foo'>,
+and will be parsed only when the appropriate feature pragma is in
+scope.
+
+Currently, the only supported feature is 'switch'. This will change
+in the future.
+
+=head2 The 'switch' feature
+
+C<use feature 'switch'> tells the compiler to enable the Perl 6
+given/when construct from here to the end of the enclosing BLOCK.
+
+This description needs to be expanded with details of the construct.
+
+=head2 Smart matching
+
+The switch construct uses I<smart matching>, i.e. the match semantics
+depend on the type of data. The current behaviour is as follows:
+
+=cut
+
+sub import {
+ $^H |= $feature::hint_bits; # Need this or %^H won't work
+
+ my $class = shift;
+ if (@_ == 0) {
+ require Carp;
+ Carp->import("croak");
+ croak("No features specified");
+ }
+ for my $feature (@_) {
+ if ($feature ne 'switch') {
+ require Carp;
+ Carp->import("croak");
+ croak(sprintf('Feature "%s" is not supported by Perl %vd',
+ $feature, $^V));
+ }
+ }
+ $^H{switch} = 1;
+}
+
+sub unimport {
+ my $class = shift;
+
+ # A bare C<no feature> should disable *all* features
+ for my $feature (@_) {
+ if ($feature ne 'switch') {
+ require Carp;
+ Carp->import("croak");
+ croak(sprintf('Feature "%s" is not supported by Perl %vd',
+ $feature, $^V));
+ }
+ }
+
+ delete $^H{switch};
+}
+
+1;
--- /dev/null 2005-12-09 12:35:12.000000000 +0000
+++ perl-after/lib/feature.t 2005-12-09 12:31:39.000000000 +0000
@@ -0,0 +1,10 @@
+#!./perl
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ $ENV{PERL5LIB} = '../lib';
+}
+
+our $pragma_name = "feature";
+require "../t/lib/common.pl";
--- /dev/null 2005-12-09 12:35:12.000000000 +0000
+++ perl-after/t/lib/common.pl 2005-12-09 12:32:29.000000000 +0000
@@ -0,0 +1,206 @@
+# This code is used by lib/warnings.t and lib/feature.t
+
+BEGIN {
+ require Config; import Config;
+ require './test.pl';
+}
+
+use File::Path;
+use File::Spec::Functions;
+
+use strict;
+our $pragma_name;
+
+$| = 1;
+
+my $Is_MacOS = $^O eq 'MacOS';
+my $tmpfile = "tmp0000";
+1 while -e ++$tmpfile;
+END { if ($tmpfile) { 1 while unlink $tmpfile} }
+
+my @prgs = () ;
+my @w_files = () ;
+
+if (@ARGV)
+ { print "ARGV = [@ARGV]\n" ;
+ if ($^O eq 'MacOS') {
+ @w_files = map { s#^#:lib:$pragma_name:#; $_ } @ARGV
+ } else {
+ @w_files = map { s#^#./lib/$pragma_name/#; $_ } @ARGV
+ }
+ }
+else
+ { @w_files = sort glob(catfile(curdir(), "lib", $pragma_name, "*")) }
+
+my $files = 0;
+foreach my $file (@w_files) {
+
+ next if $file =~ /(~|\.orig|,v)$/;
+ next if $file =~ /perlio$/ && !(find PerlIO::Layer 'perlio');
+ next if -d $file;
+
+ open F, "<$file" or die "Cannot open $file: $!\n" ;
+ my $line = 0;
+ while (<F>) {
+ $line++;
+ last if /^__END__/ ;
+ }
+
+ {
+ local $/ = undef;
+ $files++;
+ @prgs = (@prgs, $file, split "\n########\n", <F>) ;
+ }
+ close F ;
+}
+
+undef $/;
+
+plan tests => (scalar(@prgs)-$files);
+
+
+
+for (@prgs){
+ unless (/\n/)
+ {
+ print "# From $_\n";
+ next;
+ }
+ my $switch = "";
+ my @temps = () ;
+ my @temp_path = () ;
+ if (s/^\s*-\w+//){
+ $switch = $&;
+ }
+ my($prog,$expected) = split(/\nEXPECT(?:\n|$)/, $_, 2);
+ my ($todo, $todo_reason);
+ $todo = $prog =~ s/^#\s*TODO(.*)\n//m and $todo_reason = $1;
+ if ( $prog =~ /--FILE--/) {
+ my(@files) = split(/\n--FILE--\s*([^\s\n]*)\s*\n/, $prog) ;
+ shift @files ;
+ die "Internal error: test $_ didn't split into pairs, got " .
+ scalar(@files) . "[" . join("%%%%", @files) ."]\n"
+ if @files % 2 ;
+ while (@files > 2) {
+ my $filename = shift @files ;
+ my $code = shift @files ;
+ push @temps, $filename ;
+ if ($filename =~ m#(.*)/#) {
+ mkpath($1);
+ push(@temp_path, $1);
+ }
+ open F, ">$filename" or die "Cannot open $filename: $!\n" ;
+ print F $code ;
+ close F or die "Cannot close $filename: $!\n";
+ }
+ shift @files ;
+ $prog = shift @files ;
+ }
+
+ # fix up some paths
+ if ($^O eq 'MacOS') {
+ $prog =~ s|require "./abc(d)?";|require ":abc$1";|g;
+ $prog =~ s|"\."|":"|g;
+ }
+
+ open TEST, ">$tmpfile" or die "Cannot open >$tmpfile: $!";
+ print TEST q{
+ BEGIN {
+ open(STDERR, ">&STDOUT")
+ or die "Can't dup STDOUT->STDERR: $!;";
+ }
+ };
+ print TEST "\n#line 1\n"; # So the line numbers don't get messed up.
+ print TEST $prog,"\n";
+ close TEST or die "Cannot close $tmpfile: $!";
+ my $results = runperl( switches => [$switch], stderr => 1, progfile => $tmpfile );
+ my $status = $?;
+ $results =~ s/\n+$//;
+ # allow expected output to be written as if $prog is on STDIN
+ $results =~ s/tmp\d+/-/g;
+ if ($^O eq 'VMS') {
+ # some tests will trigger VMS messages that won't be expected
+ $results =~ s/\n?%[A-Z]+-[SIWEF]-[A-Z]+,.*//;
+
+ # pipes double these sometimes
+ $results =~ s/\n\n/\n/g;
+ }
+# bison says 'parse error' instead of 'syntax error',
+# various yaccs may or may not capitalize 'syntax'.
+ $results =~ s/^(syntax|parse) error/syntax error/mig;
+ # allow all tests to run when there are leaks
+ $results =~ s/Scalars leaked: \d+\n//g;
+
+ # fix up some paths
+ if ($^O eq 'MacOS') {
+ $results =~ s|:abc\.pm\b|abc.pm|g;
+ $results =~ s|:abc(d)?\b|./abc$1|g;
+ }
+
+ $expected =~ s/\n+$//;
+ my $prefix = ($results =~ s#^PREFIX(\n|$)##) ;
+ # any special options? (OPTIONS foo bar zap)
+ my $option_regex = 0;
+ my $option_random = 0;
+ if ($expected =~ s/^OPTIONS? (.+)\n//) {
+ foreach my $option (split(' ', $1)) {
+ if ($option eq 'regex') { # allow regular expressions
+ $option_regex = 1;
+ }
+ elsif ($option eq 'random') { # all lines match, but in any order
+ $option_random = 1;
+ }
+ else {
+ die "$0: Unknown OPTION '$option'\n";
+ }
+ }
+ }
+ die "$0: can't have OPTION regex and random\n"
+ if $option_regex + $option_random > 1;
+ my $ok = 1;
+ if ( $results =~ s/^SKIPPED\n//) {
+ print "$results\n" ;
+ }
+ elsif ($option_random)
+ {
+ $ok = randomMatch($results, $expected);
+ }
+ elsif (($prefix && (( $option_regex && $results !~ /^$expected/) ||
+ (!$option_regex && $results !~ /^\Q$expected/))) or
+ (!$prefix && (( $option_regex && $results !~ /^$expected/) ||
+ (!$option_regex && $results ne $expected)))) {
+ my $err_line = "PROG: $switch\n$prog\n" .
+ "EXPECTED:\n$expected\n" .
+ "GOT:\n$results\n";
+ if ($todo) {
+ $err_line =~ s/^/# /mg;
+ print $err_line; # Harness can't filter it out from STDERR.
+ }
+ else {
+ print STDERR $err_line;
+ }
+ $ok = 0;
+ }
+
+ our $TODO = $todo ? $todo_reason : 0;
+ ok($ok);
+
+ foreach (@temps)
+ { unlink $_ if $_ }
+ foreach (@temp_path)
+ { rmtree $_ if -d $_ }
+}
+
+sub randomMatch
+{
+ my $got = shift ;
+ my $expected = shift;
+
+ my @got = sort split "\n", $got ;
+ my @expected = sort split "\n", $expected ;
+
+ return "@got" eq "@expected";
+
+}
+
+1;
--- /dev/null 2005-12-09 12:35:12.000000000 +0000
+++ perl-after/t/lib/feature/nonesuch 2005-12-08 16:33:08.000000000 +0000
@@ -0,0 +1,12 @@
+Test that non-existent features fail as expected.
+
+__END__
+use feature "nonesuch";
+EXPECT
+OPTIONS regex
+^Feature "nonesuch" is not supported by Perl [v0-9.]+ at - line 1
+########
+no feature "nonesuch";
+EXPECT
+OPTIONS regex
+^Feature "nonesuch" is not supported by Perl [v0-9.]+ at - line 1
--- /dev/null 2005-12-09 12:35:12.000000000 +0000
+++ perl-after/t/lib/feature/switch 2005-12-08 16:33:08.000000000 +0000
@@ -0,0 +1,158 @@
+Check the lexical scoping of the switch keywords.
+(The actual behaviour is tested in t/op/switch.t)
+
+__END__
+# No switch; given should be a bareword.
+use warnings;
+print STDOUT given;
+EXPECT
+Unquoted string "given" may clash with future reserved word at - line 3.
+given
+########
+# No switch; when should be a bareword.
+use warnings;
+print STDOUT when;
+EXPECT
+Unquoted string "when" may clash with future reserved word at - line 3.
+when
+########
+# No switch; default should be a bareword.
+use warnings;
+print STDOUT default;
+EXPECT
+Unquoted string "default" may clash with future reserved word at - line 3.
+default
+########
+# No switch; break should be a bareword.
+use warnings;
+print STDOUT break;
+EXPECT
+Unquoted string "break" may clash with future reserved word at - line 3.
+break
+########
+# No switch; but continue is still a keyword
+print STDOUT continue;
+EXPECT
+syntax error at - line 2, near "STDOUT continue"
+Execution of - aborted due to compilation errors.
+########
+# Use switch; so given is a keyword
+use feature 'switch';
+given("okay\n") { print }
+EXPECT
+okay
+########
+# Use switch; so when is a keyword
+use feature 'switch';
+given(1) { when(1) { print "okay" } }
+EXPECT
+okay
+########
+# Use switch; so default is a keyword
+use feature 'switch';
+given(1) { default { print "okay" } }
+EXPECT
+okay
+########
+# Use switch; so break is a keyword
+use feature 'switch';
+break;
+EXPECT
+Can't "break" outside a given block at - line 3.
+########
+# Use switch; so continue is a keyword
+use feature 'switch';
+continue;
+EXPECT
+Can't "continue" outside a when block at - line 3.
+########
+# switch out of scope; given should be a bareword.
+use warnings;
+{ use feature 'switch';
+ given (1) {print "Okay here\n";}
+}
+print STDOUT given;
+EXPECT
+Unquoted string "given" may clash with future reserved word at - line 6.
+Okay here
+given
+########
+# switch out of scope; when should be a bareword.
+use warnings;
+{ use feature 'switch';
+ given (1) { when(1) {print "Okay here\n";} }
+}
+print STDOUT when;
+EXPECT
+Unquoted string "when" may clash with future reserved word at - line 6.
+Okay here
+when
+########
+# switch out of scope; default should be a bareword.
+use warnings;
+{ use feature 'switch';
+ given (1) { default {print "Okay here\n";} }
+}
+print STDOUT default;
+EXPECT
+Unquoted string "default" may clash with future reserved word at - line 6.
+Okay here
+default
+########
+# switch out of scope; break should be a bareword.
+use warnings;
+{ use feature 'switch';
+ given (1) { break }
+}
+print STDOUT break;
+EXPECT
+Unquoted string "break" may clash with future reserved word at - line 6.
+break
+########
+# switch out of scope; continue should not work
+{ use feature 'switch';
+ given (1) { default {continue} }
+}
+print STDOUT continue;
+EXPECT
+syntax error at - line 5, near "STDOUT continue"
+Execution of - aborted due to compilation errors.
+########
+# C<no feature 'switch'> should work
+use warnings;
+use feature 'switch';
+given (1) { when(1) {print "Okay here\n";} }
+no feature 'switch';
+print STDOUT when;
+EXPECT
+Unquoted string "when" may clash with future reserved word at - line 6.
+Okay here
+when
+########
+# C<no feature> should work too
+use warnings;
+use feature 'switch';
+given (1) { when(1) {print "Okay here\n";} }
+no feature;
+print STDOUT when;
+EXPECT
+Unquoted string "when" may clash with future reserved word at - line 6.
+Okay here
+when
+########
+# Without the feature, no 'Unambiguous use of' warning:
+use warnings;
+ at break = ($break = "break");
+print ${break}, ${break[0]};
+EXPECT
+breakbreak
+########
+# With the feature, we get an 'Unambiguous use of' warning:
+use warnings;
+use feature 'switch';
+ at break = ($break = "break");
+print ${break}, ${break[0]};
+EXPECT
+Ambiguous use of ${break} resolved to $break at - line 5.
+Ambiguous use of ${break[...]} resolved to $break[...] at - line 5.
+breakbreak
--- /dev/null 2005-12-09 12:35:12.000000000 +0000
+++ perl-after/t/op/switch.t 2005-12-09 12:29:33.000000000 +0000
@@ -0,0 +1,534 @@
+#!./perl
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+
+use strict;
+use warnings;
+
+use Test::More tests => 67;
+
+# The behaviour of the switch pragma should be tested by lib/switch.t
+# using the tests in t/lib/switch/*. This file tests the behaviour of
+# the switch ops themselves.
+
+
+use feature 'switch';
+
+eval { continue };
+like($@, qr/^Can't "continue" outside/, "continue outside");
+
+eval { break };
+like($@, qr/^Can't "break" outside/, "break outside");
+
+# Scoping rules
+
+{
+ my $x = "foo";
+ given(my $x = "bar") {
+ is($x, "bar", "given scope starts");
+ }
+ is($x, "foo", "given scope ends");
+}
+
+sub be_true {1}
+
+given(my $x = "foo") {
+ when(be_true(my $x = "bar")) {
+ is($x, "bar", "given scope starts");
+ }
+ is($x, "foo", "given scope ends");
+}
+
+# Basic string/numeric comparisons and control flow
+
+{
+ my $ok = 0;
+ given(3) {
+ when(2) { $ok = 0; }
+ when(3) { $ok = 1; }
+ when(4) { $ok = 0; }
+ default { $ok = 0; }
+ }
+ ok($ok, "numeric comparison");
+}
+
+{
+ my $ok = 0;
+ use integer;
+ given(3.14159265) {
+ when(2) { $ok = 0; }
+ when(3) { $ok = 1; }
+ when(4) { $ok = 0; }
+ default { $ok = 0; }
+ }
+ ok($ok, "integer comparison");
+}
+
+{
+ my ($ok1, $ok2) = (0, 0);
+ given(3) {
+ when(3.1) { $ok1 = 0; }
+ when(3.0) { $ok1 = 1; continue }
+ when("3.0") { $ok2 = 0; }
+ default { $ok2 = 1; }
+ }
+ ok($ok1, "more numeric (pt. 1)");
+ ok($ok2, "more numeric (pt. 2)");
+}
+
+{
+ my $ok = 0;
+ given("c") {
+ when("b") { $ok = 0; }
+ when("c") { $ok = 1; }
+ when("d") { $ok = 0; }
+ default { $ok = 0; }
+ }
+ ok($ok, "string comparison");
+}
+
+{
+ my $ok = 0;
+ given("c") {
+ when("b") { $ok = 0; }
+ when("c") { $ok = 0; continue }
+ when("c") { $ok = 1; }
+ default { $ok = 0; }
+ }
+ ok($ok, "simple continue");
+}
+
+# Definedness
+{
+ my $ok = 1;
+ given (0) { when(undef) {$ok = 0} }
+ ok($ok, "Given(0) when(undef)");
+}
+{
+ my $undef;
+ my $ok = 1;
+ given (0) { when($undef) {$ok = 0} }
+ ok($ok, 'Given(0) when($undef)');
+}
+{
+ my $undef;
+ my $ok = 0;
+ given (0) { when($undef++) {$ok = 1} }
+ ok($ok, "Given(0) when($undef++)");
+}
+{
+ my $ok = 1;
+ given (undef) { when(0) {$ok = 0} }
+ ok($ok, "Given(undef) when(0)");
+}
+{
+ my $undef;
+ my $ok = 1;
+ given ($undef) { when(0) {$ok = 0} }
+ ok($ok, 'Given($undef) when(0)');
+}
+########
+{
+ my $ok = 1;
+ given ("") { when(undef) {$ok = 0} }
+ ok($ok, 'Given("") when(undef)');
+}
+{
+ my $undef;
+ my $ok = 1;
+ given ("") { when($undef) {$ok = 0} }
+ ok($ok, 'Given("") when($undef)');
+}
+{
+ my $undef;
+ my $ok = 1;
+ given ("") { when($undef++) {$ok = 0} }
+ ok($ok, 'Given("") when($undef++)');
+}
+{
+ my $ok = 1;
+ given (undef) { when("") {$ok = 0} }
+ ok($ok, 'Given(undef) when("")');
+}
+{
+ my $undef;
+ my $ok = 1;
+ given ($undef) { when("") {$ok = 0} }
+ ok($ok, 'Given($undef) when("")');
+}
+########
+{
+ my $ok = 0;
+ given (undef) { when(undef) {$ok = 1} }
+ ok($ok, "Given(undef) when(undef)");
+}
+{
+ my $undef;
+ my $ok = 0;
+ given (undef) { when($undef) {$ok = 1} }
+ ok($ok, 'Given(undef) when($undef)');
+}
+{
+ my $undef;
+ my $ok = 0;
+ given ($undef) { when(undef) {$ok = 1} }
+ ok($ok, 'Given($undef) when(undef)');
+}
+{
+ my $undef;
+ my $ok = 0;
+ given ($undef) { when($undef) {$ok = 1} }
+ ok($ok, 'Given($undef) when($undef)');
+}
+
+
+# Regular expressions
+{
+ my ($ok1, $ok2) = 0;
+ given("Hello, world!") {
+ when(/lo/)
+ { $ok1 = 1; continue}
+ when(/no/)
+ { $ok1 = 0; continue}
+ when(/^(Hello,|Goodbye cruel) world[!.?]/)
+ { $ok2 = 1; continue}
+ when(/^(Hello cruel|Goodbye,) world[!.?]/)
+ { $ok2 = 0; continue}
+ }
+ ok($ok1, "regex 1");
+ ok($ok2, "regex 2");
+}
+
+# Comparisons
+{
+ my $test = "explicit numeric comparison (<)";
+ my $twenty_five = 25;
+ given($twenty_five) {
+ when ($_ < 10) { fail($test) }
+ when ($_ < 20) { fail($test) }
+ when ($_ < 30) { pass($test) }
+ when ($_ < 40) { fail($test) }
+ }
+}
+
+{
+ use integer;
+ my $test = "explicit numeric comparison (integer <)";
+ my $twenty_five = 25;
+ given($twenty_five) {
+ when ($_ < 10) { fail($test) }
+ when ($_ < 20) { fail($test) }
+ when ($_ < 30) { pass($test) }
+ when ($_ < 40) { fail($test) }
+ }
+}
+
+{
+ my $test = "explicit numeric comparison (<=)";
+ my $twenty_five = 25;
+ given($twenty_five) {
+ when ($_ <= 10) { fail($test) }
+ when ($_ <= 20) { fail($test) }
+ when ($_ <= 30) { pass($test) }
+ when ($_ <= 40) { fail($test) }
+ }
+}
+
+{
+ use integer;
+ my $test = "explicit numeric comparison (integer <=)";
+ my $twenty_five = 25;
+ given($twenty_five) {
+ when ($_ <= 10) { fail($test) }
+ when ($_ <= 20) { fail($test) }
+ when ($_ <= 30) { pass($test) }
+ when ($_ <= 40) { fail($test) }
+ }
+}
+
+
+{
+ my $test = "explicit numeric comparison (>)";
+ my $twenty_five = 25;
+ given($twenty_five) {
+ when ($_ > 40) { fail($test) }
+ when ($_ > 30) { fail($test) }
+ when ($_ > 20) { pass($test) }
+ when ($_ > 10) { fail($test) }
+ }
+}
+
+{
+ my $test = "explicit numeric comparison (>=)";
+ my $twenty_five = 25;
+ given($twenty_five) {
+ when ($_ >= 40) { fail($test) }
+ when ($_ >= 30) { fail($test) }
+ when ($_ >= 20) { pass($test) }
+ when ($_ >= 10) { fail($test) }
+ }
+}
+
+{
+ use integer;
+ my $test = "explicit numeric comparison (integer >)";
+ my $twenty_five = 25;
+ given($twenty_five) {
+ when ($_ > 40) { fail($test) }
+ when ($_ > 30) { fail($test) }
+ when ($_ > 20) { pass($test) }
+ when ($_ > 10) { fail($test) }
+ }
+}
+
+{
+ use integer;
+ my $test = "explicit numeric comparison (integer >=)";
+ my $twenty_five = 25;
+ given($twenty_five) {
+ when ($_ >= 40) { fail($test) }
+ when ($_ >= 30) { fail($test) }
+ when ($_ >= 20) { pass($test) }
+ when ($_ >= 10) { fail($test) }
+ }
+}
+
+
+{
+ my $test = "explicit string comparison (lt)";
+ my $twenty_five = "25";
+ given($twenty_five) {
+ when ($_ lt "10") { fail($test) }
+ when ($_ lt "20") { fail($test) }
+ when ($_ lt "30") { pass($test) }
+ when ($_ lt "40") { fail($test) }
+ }
+}
+
+{
+ my $test = "explicit string comparison (le)";
+ my $twenty_five = "25";
+ given($twenty_five) {
+ when ($_ le "10") { fail($test) }
+ when ($_ le "20") { fail($test) }
+ when ($_ le "30") { pass($test) }
+ when ($_ le "40") { fail($test) }
+ }
+}
+
+{
+ my $test = "explicit string comparison (gt)";
+ my $twenty_five = 25;
+ given($twenty_five) {
+ when ($_ ge "40") { fail($test) }
+ when ($_ ge "30") { fail($test) }
+ when ($_ ge "20") { pass($test) }
+ when ($_ ge "10") { fail($test) }
+ }
+}
+
+{
+ my $test = "explicit string comparison (ge)";
+ my $twenty_five = 25;
+ given($twenty_five) {
+ when ($_ ge "40") { fail($test) }
+ when ($_ ge "30") { fail($test) }
+ when ($_ ge "20") { pass($test) }
+ when ($_ ge "10") { fail($test) }
+ }
+}
+
+# File tests
+# (How to be both thorough and portable? Pinch a few ideas
+# from t/op/filetest.t. We err on the side of portability for
+# the time being.)
+
+{
+ my ($ok_d, $ok_f, $ok_r);
+ given("op") {
+ when(-d) {$ok_d = 1; continue}
+ when(!-f) {$ok_f = 1; continue}
+ when(-r) {$ok_r = 1; continue}
+ }
+ ok($ok_d, "Filetest -d");
+ ok($ok_f, "Filetest -f");
+ ok($ok_r, "Filetest -r");
+}
+
+# Sub and method calls
+sub bar {"bar"}
+{
+ my $ok = 0;
+ given("foo") {
+ when(bar()) {$ok = 1}
+ }
+ ok($ok, "Sub call acts as boolean")
+}
+
+{
+ my $ok = 0;
+ given("foo") {
+ when(main->bar()) {$ok = 1}
+ }
+ ok($ok, "Class-method call acts as boolean")
+}
+
+{
+ my $ok = 0;
+ my $obj = bless [];
+ given("foo") {
+ when($obj->bar()) {$ok = 1}
+ }
+ ok($ok, "Object-method call acts as boolean")
+}
+
+# Make sure we aren't invoking the get-magic more than once
+
+{ # A helper class to count the number of accesses.
+ package FetchCounter;
+ sub TIESCALAR {
+ my ($class) = @_;
+ bless {value => undef, count => 0}, $class;
+ }
+ sub STORE {
+ my ($self, $val) = @_;
+ $self->{count} = 0;
+ $self->{value} = $val;
+ }
+ sub FETCH {
+ my ($self) = @_;
+ # Avoid pre/post increment here
+ $self->{count} = 1 + $self->{count};
+ $self->{value};
+ }
+ sub count {
+ my ($self) = @_;
+ $self->{count};
+ }
+}
+
+my $f = tie my $v, "FetchCounter";
+
+{ my $test_name = "Only one FETCH (in given)";
+ my $ok = 0;
+ given($v = 23) {
+ when(undef) {}
+ when(sub{0}->()) {}
+ when(21) {}
+ when("22") {}
+ when(23) {$ok = 1}
+ when(/24/) {$ok = 0}
+ }
+ ok($ok, "precheck: $test_name");
+ is($f->count(), 1, $test_name);
+}
+
+{ my $test_name = "Only one FETCH (numeric when)";
+ my $ok = 0;
+ $v = 23;
+ is($f->count(), 0, "Sanity check: $test_name");
+ given(23) {
+ when(undef) {}
+ when(sub{0}->()) {}
+ when(21) {}
+ when("22") {}
+ when($v) {$ok = 1}
+ when(/24/) {$ok = 0}
+ }
+ ok($ok, "precheck: $test_name");
+ is($f->count(), 1, $test_name);
+}
+
+{ my $test_name = "Only one FETCH (string when)";
+ my $ok = 0;
+ $v = "23";
+ is($f->count(), 0, "Sanity check: $test_name");
+ given("23") {
+ when(undef) {}
+ when(sub{0}->()) {}
+ when("21") {}
+ when("22") {}
+ when($v) {$ok = 1}
+ when(/24/) {$ok = 0}
+ }
+ ok($ok, "precheck: $test_name");
+ is($f->count(), 1, $test_name);
+}
+
+{ my $test_name = "Only one FETCH (undef)";
+ my $ok = 0;
+ $v = undef;
+ is($f->count(), 0, "Sanity check: $test_name");
+ given(my $undef) {
+ when(sub{0}->()) {}
+ when("21") {}
+ when("22") {}
+ when($v) {$ok = 1}
+ when(undef) {$ok = 0}
+ }
+ ok($ok, "precheck: $test_name");
+ is($f->count(), 1, $test_name);
+}
+
+# Loop topicalizer
+{
+ my $first = 1;
+ for (1, "two") {
+ when ("two") {
+ is($first, 0, "Loop: second");
+ eval {break};
+ like($@, qr/^Can't "break" in a loop topicalizer/,
+ q{Can't "break" in a loop topicalizer});
+ }
+ when (1) {
+ is($first, 1, "Loop: first");
+ $first = 0;
+ # Implicit break is okay
+ }
+ }
+}
+
+# Code references
+{
+ my $called_foo = 0;
+ sub foo {$called_foo = 1}
+ my $called_bar = 0;
+ sub bar {$called_bar = 1}
+ my ($matched_foo, $matched_bar) = (0, 0);
+ given(\&foo) {
+ when(\&bar) {$matched_bar = 1}
+ when(\&foo) {$matched_foo = 1}
+ }
+ is($called_foo, 0, "Code ref comparison: foo not called");
+ is($called_bar, 0, "Code ref comparison: bar not called");
+ is($matched_bar, 0, "Code ref didn't match different one");
+ is($matched_foo, 1, "Code ref did match itself");
+}
+
+sub contains_x {
+ my $x = shift;
+ return ($x =~ /x/);
+}
+{
+ my ($ok1, $ok2) = (0,0);
+ given("foxy!") {
+ when(contains_x($_))
+ { $ok1 = 1; continue }
+ when(\&contains_x)
+ { $ok2 = 1; continue }
+ }
+ is($ok1, 1, "Calling sub directly (true)");
+ is($ok2, 1, "Calling sub indirectly (true)");
+
+ given("foggy") {
+ when(contains_x($_))
+ { $ok1 = 2; continue }
+ when(\&contains_x)
+ { $ok2 = 2; continue }
+ }
+ is($ok1, 1, "Calling sub directly (true)");
+ is($ok2, 1, "Calling sub indirectly (true)");
+}
----- End forwarded message -----
More information about the Phoenix-pm
mailing list