In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/e660c409f22c1a7f1be06f3ef5168a7a09a5835a?hp=aff539aa0fc970a7b080a077309522932e179d10>
- Log ----------------------------------------------------------------- commit e660c409f22c1a7f1be06f3ef5168a7a09a5835a Author: Father Chrysostomos <[email protected]> Date: Tue Oct 28 16:52:18 2014 -0700 [perl #122782] map{no strict;...} etc. After the lexer (toke.c) has decided in the case of âmap{â or âprint{â that it has a block, not a hash constructor, it has then preceded to treat the contents as an expression. Since it is the parser (perly.y) that ultimately decides whether it is an expression or statement, most of the time things just work. But in those cases where the lexer behaves differently whether it is expect- ing a statement or expression, it usually just does the wrong thing. Most notable is map {no strict;...}, which dies with â"no" not allowed in expressionâ. See the RT ticket for more examples of the term/statement discrepancies. This commit changes it to expect a statement most of the time. These changes also apply to the contents of ${...}, which has always fol- lowed the same rules. Two cases where it used simply to dwim that would break with a statement expectation are special-cased, to pre- serve backward-compatibility as much as possible. See the comments added to toke. We already have an exception for âsubâ in the case of ${sub{...}}, which is not treated as $sub{...} as happens with other barewords, so this is consistent with that. M t/base/lex.t M t/lib/croak/toke M t/op/lex.t M t/uni/variables.t M toke.c commit 00e40766a52e90fea69000c44dbc74c62133f696 Author: Father Chrysostomos <[email protected]> Date: Tue Oct 28 14:34:28 2014 -0700 [perl #122829] Flip-flop under recursion Each recursion level of a sub was maintaining separate states for flip-flop operators within the sub, contrary to the documentation. This commit makes different recursion levels share the same internal state. Closures have been keeping separate state, so I have preserved that behaviour. This makes flip-flop state have the same scope as state variables, so the pad entries used by flip-flop operators can be allocated just like state vars. M op.c M pad.c M t/op/flip.t commit ebe6eeaa0bc3a3ef60bc8a046621fd57729b08cd Author: Father Chrysostomos <[email protected]> Date: Tue Oct 28 14:34:10 2014 -0700 split.t: More tests for perl #123057 There are three different variants to split-to-array, so test that op_lvalue_flags can handle all three. M t/op/split.t commit 9a63e366d1167a528e8df0d80c9d85c0830d63e9 Author: Father Chrysostomos <[email protected]> Date: Mon Oct 27 04:09:03 2014 -0700 Consistent spaces after dots in perlapi.pod M dump.c M op.c ----------------------------------------------------------------------- Summary of changes: dump.c | 2 +- op.c | 24 ++++++++++++++---------- pad.c | 5 ----- t/base/lex.t | 32 +++++++++++++++++++++++++++++++- t/lib/croak/toke | 5 +++++ t/op/flip.t | 37 ++++++++++++++++++++++++++++++++++++- t/op/lex.t | 7 ++++++- t/op/split.t | 11 +++++++++-- t/uni/variables.t | 17 ++++++++--------- toke.c | 30 ++++++++++++++++++++++++++---- 10 files changed, 136 insertions(+), 34 deletions(-) diff --git a/dump.c b/dump.c index a8956c9..2d9e019 100644 --- a/dump.c +++ b/dump.c @@ -96,7 +96,7 @@ S_append_flags(pTHX_ SV *sv, U32 flags, const struct flag_to_name *start, Escapes at most the first "count" chars of pv and puts the results into dsv such that the size of the escaped string will not exceed "max" chars -and will not contain any incomplete escape sequences. The number of bytes +and will not contain any incomplete escape sequences. The number of bytes escaped will be returned in the STRLEN *escaped parameter if it is not null. When the dsv parameter is null no escaping actually occurs, but the number of bytes that would be escaped were it not null will be calculated. diff --git a/op.c b/op.c index 59a3541..f9ae54a 100644 --- a/op.c +++ b/op.c @@ -3614,9 +3614,10 @@ Perl_op_unscope(pTHX_ OP *o) /* =for apidoc Am|int|block_start|int full -Handles compile-time scope entry. Arranges for hints to be restored on block +Handles compile-time scope entry. +Arranges for hints to be restored on block exit and also handles pad sequence numbers to make lexical variables scope -right. Returns a savestack index for use with C<block_end>. +right. Returns a savestack index for use with C<block_end>. =cut */ @@ -3640,7 +3641,8 @@ Perl_block_start(pTHX_ int full) /* =for apidoc Am|OP *|block_end|I32 floor|OP *seq -Handles compile-time scope exit. I<floor> is the savestack index returned by +Handles compile-time scope exit. I<floor> +is the savestack index returned by C<block_start>, and I<seq> is the body of the block. Returns the block, possibly modified. @@ -4304,7 +4306,7 @@ into the specified I<type>, calling its check function, allocating a target if it needs one, and folding constants. A list-type op is usually constructed one kid at a time via C<newLISTOP>, -C<op_prepend_elem> and C<op_append_elem>. Then finally it is passed to +C<op_prepend_elem> and C<op_append_elem>. Then finally it is passed to C<op_convert> to make it the right type. =cut @@ -4553,10 +4555,10 @@ Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first) =for apidoc Am|OP *|newMETHOP|I32 type|I32 flags|OP *first Constructs, checks, and returns an op of method type with a method name -evaluated at runtime. I<type> is the opcode. I<flags> gives the eight +evaluated at runtime. I<type> is the opcode. I<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS> will be set automatically, and, shifted up eight bits, the eight bits of C<op_private>, except that -the bit with value 1 is automatically set. I<dynamic_meth> supplies an +the bit with value 1 is automatically set. I<dynamic_meth> supplies an op which evaluates method name; it is consumed by this function and become part of the constructed op tree. Supported optypes: OP_METHOD. @@ -4605,9 +4607,9 @@ Perl_newMETHOP (pTHX_ I32 type, I32 flags, OP* dynamic_meth) { =for apidoc Am|OP *|newMETHOP_named|I32 type|I32 flags|SV *const_meth Constructs, checks, and returns an op of method type with a constant -method name. I<type> is the opcode. I<flags> gives the eight bits of +method name. I<type> is the opcode. I<flags> gives the eight bits of C<op_flags>, and, shifted up eight bits, the eight bits of -C<op_private>. I<const_meth> supplies a constant method name; +C<op_private>. I<const_meth> supplies a constant method name; it must be a shared COW string. Supported optypes: OP_METHOD_NAMED. @@ -6832,9 +6834,11 @@ Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right) left->op_next = flip; right->op_next = flop; - range->op_targ = pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK, 0, 0); + range->op_targ = + pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0); sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV); - flip->op_targ = pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK, 0, 0);; + flip->op_targ = + pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);; sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV); SvPADTMP_on(PAD_SV(flip->op_targ)); diff --git a/pad.c b/pad.c index 6cc5da7..3981ac1 100644 --- a/pad.c +++ b/pad.c @@ -2379,12 +2379,7 @@ Perl_pad_push(pTHX_ PADLIST *padlist, int depth) else if (sigil == '%') sv = MUTABLE_SV(newHV()); else - { sv = newSV(0); - /* For flip-flop targets: */ - if (oldpad[ix] && SvPADTMP(oldpad[ix])) - SvPADTMP_on(sv); - } av_store(newpad, ix, sv); } } diff --git a/t/base/lex.t b/t/base/lex.t index 7604ee1..a9072ac 100644 --- a/t/base/lex.t +++ b/t/base/lex.t @@ -1,6 +1,6 @@ #!./perl -print "1..93\n"; +print "1..101\n"; $x = 'x'; @@ -444,3 +444,33 @@ print "not " unless (eval '${Function_with_side_effects,\$_}' || $@) eq "sidekick function called"; print "ok $test - \${...} where {...} looks like hash\n"; $test++; + +@_ = map{BEGIN {$_122782 = 'tst2'}; "rhu$_"} 'barb2'; +print "not " unless "@_" eq 'rhubarb2'; +print "ok $test - map{BEGIN...\n"; $test++; +print "not " unless $_122782 eq 'tst2'; +print "ok $test - map{BEGIN...\n"; $test++; +${ +=pod +blah blah blah +=cut +\$_ } = 42; +print "not "unless $_ == 42; +print "ok $test - \${ <newline> =pod\n"; $test++; +@_ = map{ +=pod +blah blah blah +=cut +$_+1 } 1; +print "not "unless "@_" eq 2; +print "ok $test - map{ <newline> =pod\n"; $test++; +eval { ${...}++ }; +print "not " unless $@ =~ /^Unimplemented at /; +print "ok $test - \${...} (literal triple-dot)\n"; $test++; +eval { () = map{...} @_ }; +print "not " unless $@ =~ /^Unimplemented at /; +print "ok $test - map{...} (literal triple-dot)\n"; $test++; +print "not " unless &{sub :lvalue { "a" }} eq "a"; +print "ok $test - &{sub :lvalue...}\n"; $test++; +print "not " unless ref+(map{sub :lvalue { "a" }} 1)[0] eq "CODE"; +print "ok $test - map{sub :lvalue...}\n"; $test++; diff --git a/t/lib/croak/toke b/t/lib/croak/toke index 9c8dd54..2943c7b 100644 --- a/t/lib/croak/toke +++ b/t/lib/croak/toke @@ -30,6 +30,11 @@ EXPECT Missing right brace on \N{} or unescaped left brace after \N at - line 1, within pattern Execution of - aborted due to compilation errors. ######## +# NAME map{for our *a... +map{for our *a (1..10) {$_.=$x}} +EXPECT +Missing $ on loop variable at - line 1. +######## # NAME Missing name in "my sub" use feature 'lexical_subs'; my sub; EXPECT diff --git a/t/op/flip.t b/t/op/flip.t index 95260f8..ea8c67d 100644 --- a/t/op/flip.t +++ b/t/op/flip.t @@ -5,7 +5,7 @@ BEGIN { require "./test.pl"; } -plan(12); +plan(13); @a = (1,2,3,4,5,6,7,8,9,10,11,12); @b = (); @@ -66,3 +66,38 @@ ok(scalar(15..0)); push @_, \scalar(0..0) for 1,2; isnt $_[0], $_[1], '\scalar($a..$b) gives a different scalar each time'; + +# This evil little example from ticket #122829 abused the fact that each +# recursion level maintained its own flip-flip state. The following com- +# ment describes how it *used* to work. + +# This routine maintains multiple flip-flop states, each with its own +# numeric ID, starting from 1. Pass the ID as the argument. +sub f { + my $depth = shift() - 1; + return f($depth) if $depth; + return /3/../5/; +} +{ + my $accumulator; + for(1..20) { + if (f(1)) { + my $outer = $_; + for(1..10){ + $accumulator .= "$outer $_\n" if f(2); + } + } + } + is $accumulator, <<EOT, 'recursion shares state'; +3 1 +3 2 +3 3 +3 4 +3 5 +13 1 +13 2 +13 3 +13 4 +13 5 +EOT +} diff --git a/t/op/lex.t b/t/op/lex.t index 5af8538..25ae754 100644 --- a/t/op/lex.t +++ b/t/op/lex.t @@ -4,7 +4,7 @@ use warnings; BEGIN { chdir 't' if -d 't'; require './test.pl'; } -plan(tests => 8); +plan(tests => 10); { no warnings 'deprecated'; @@ -88,3 +88,8 @@ is runperl( ."2.\n", 'no buffer corruption with multiline *{...expr...}' ; + +$_ = "rhubarb"; +is ${no strict; \$_}, "rhubarb", '${no strict; ...}'; +is join("", map{no strict; "rhu$_" } "barb"), 'rhubarb', + 'map{no strict;...}'; diff --git a/t/op/split.t b/t/op/split.t index 51e0d1d..9afdd6e 100644 --- a/t/op/split.t +++ b/t/op/split.t @@ -6,7 +6,7 @@ BEGIN { set_up_inc('../lib'); } -plan tests => 123; +plan tests => 125; $FS = ':'; @@ -507,4 +507,11 @@ is "@aaa", "f o o b a r b a z", is "@a", "a b c", '() = split-to-array'; (@a = split //, "abc") = 1..10; -is "@a", '1 2 3', 'assignment to split-to-array'; +is "@a", '1 2 3', 'assignment to split-to-array (pmtarget/package array)'; +{ + my @a; + (@a = split //, "abc") = 1..10; + is "@a", '1 2 3', 'assignment to split-to-array (targ/lexical)'; +} +(@{\@a} = split //, "abc") = 1..10; +is "@a", '1 2 3', 'assignment to split-to-array (stacked)'; diff --git a/t/uni/variables.t b/t/uni/variables.t index e8259e5..5ccf7e7 100644 --- a/t/uni/variables.t +++ b/t/uni/variables.t @@ -16,22 +16,21 @@ no warnings qw(misc reserved); plan (tests => 66900); -# ${single:colon} should not be valid syntax +# ${single:colon} should not be treated as a simple variable, but as a +# block with a label inside. { no strict; local $@; - eval "\${\x{30cd}single:\x{30cd}colon} = 1"; - like($@, - qr/syntax error .* near "\x{30cd}single:/, - '${\x{30cd}single:\x{30cd}colon} should not be valid syntax' - ); + eval "\${\x{30cd}single:\x{30cd}colon} = 'label, not var'"; + is ${"\x{30cd}colon"}, 'label, not var', + '${\x{30cd}single:\x{30cd}colon} should be block-label'; local $@; no utf8; - evalbytes '${single:colon} = 1'; - like($@, - qr/syntax error .* near "single:/, + evalbytes '${single:colon} = "block/label, not var"'; + is($::colon, + 'block/label, not var', '...same with ${single:colon}' ); } diff --git a/toke.c b/toke.c index f71cfcd..25a9ccc 100644 --- a/toke.c +++ b/toke.c @@ -5501,9 +5501,10 @@ Perl_yylex(pTHX) OPERATOR(HASHBRACK); } if (PL_expect == XREF && PL_oldoldbufptr != PL_last_lop) { - /* ${...} or @{...} etc., but not print {...} */ - PL_expect = XTERM; - break; + /* ${...} or @{...} etc., but not print {...} + * Skip the disambiguation and treat this as a block. + */ + goto block_expectation; } /* This hack serves to disambiguate a pair of curlies * as being a block or an anon hash. Normally, expectation @@ -5587,7 +5588,28 @@ Perl_yylex(pTHX) || (*t == '=' && t[1] == '>'))) OPERATOR(HASHBRACK); if (PL_expect == XREF) - PL_expect = XTERM; + { + block_expectation: + /* If there is an opening brace or 'sub:', treat it + as a term to make ${{...}}{k} and &{sub:attr...} + dwim. Otherwise, treat it as a statement, so + map {no strict; ...} works. + */ + s = skipspace(s); + if (*s == '{') { + PL_expect = XTERM; + break; + } + if (strnEQ(s, "sub", 3)) { + d = s + 3; + d = skipspace(d); + if (*d == ':') { + PL_expect = XTERM; + break; + } + } + PL_expect = XSTATE; + } else { PL_lex_brackstack[PL_lex_brackets-1] = XSTATE; PL_expect = XSTATE; -- Perl5 Master Repository
