In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/2108cbcf2fd75bfcc7b9c01563db7063a67549cf?hp=700779a8627cf5e47eedfe20b1c2eb3c865afb11>
- Log ----------------------------------------------------------------- commit 2108cbcf2fd75bfcc7b9c01563db7063a67549cf Author: David Mitchell <[email protected]> Date: Mon Jan 2 16:37:27 2017 +0000 Handle chop(@a =~ tr///) RT #130198 'chop(@x =~ tr/1/1/)' crashed with an assertion failure. Ditto for chomp. There are two quirks which together cause this. First, the op tree for a tr// is different from other bind ops: $ perl -MO=Concise -e'$x =~ m/a/' 5 <@> leave[1 ref] vKP/REFC ->(end) 1 <0> enter ->2 2 <;> nextstate(main 1 -e:1) v:{ ->3 4 </> match(/"a"/) vKS ->5 - <1> ex-rv2sv sK/1 ->4 3 <#> gvsv[*x] s ->4 $ perl -MO=Concise -e'$x =~ tr/a/b/' 5 <@> leave[1 ref] vKP/REFC ->(end) 1 <0> enter ->2 2 <;> nextstate(main 1 -e:1) v:{ ->3 - <1> null vKS/2 ->5 - <1> ex-rv2sv sKRM/1 ->4 3 <#> gvsv[*x] s ->4 4 <"> trans sS ->5 Note that the argument for the match is a child of the match, while the arg of the trans is an (earlier) sibing of the trans (linked by a common null parent). The normal code path that croaks when e.g. a match is seen in an lvalue context, $ perl -e'chop(@a =~ /a/)' Can't modify pattern match (m//) in chop at -e line 1, near "/a/) is skipped, since lvalue() is only called for the first child of a null op. Fixing this is as simple as calling lvalue() on the RHS too if the RHS is a trans op. The second issue is that chop and chomp are special-cased not to flatten an array; so @b = 10..99; chop $a, @b, $c; pushes 3 items on the stack to pass to pp_chop, rather than 102. pp_chop() itself then iterates over any array args. The compiler was seeing the rv2av op in chop(@a =~ tr///) and was setting the OPf_REF (don't flatten) flag on it. Which then caused pp_trans to panic when its arg was an AV rather than a string. This second issue is now moot, since after the fix suggested above, we will have croaked before we reach the place where OPf_REF would be set. This commit adds lots of tests, since tr/a/a/ and tr/a/b/r are special-cased in terms of whether they are regarded as modifying the var they are bound to. ----------------------------------------------------------------------- Summary of changes: op.c | 27 +++++++++++++++++++++++++-- t/op/tr.t | 46 +++++++++++++++++++++++++++++++++++++++++++++- 2 files changed, 70 insertions(+), 3 deletions(-) diff --git a/op.c b/op.c index 394efef5df..339a9ce267 100644 --- a/op.c +++ b/op.c @@ -3164,9 +3164,32 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags) goto nomod; else if (!(o->op_flags & OPf_KIDS)) break; + if (o->op_targ != OP_LIST) { - op_lvalue(cBINOPo->op_first, type); - break; + OP *sib = OpSIBLING(cLISTOPo->op_first); + /* OP_TRANS and OP_TRANSR with argument have a weird optree + * that looks like + * + * null + * arg + * trans + * + * compared with things like OP_MATCH which have the argument + * as a child: + * + * match + * arg + * + * so handle specially to correctly get "Can't modify" croaks etc + */ + + if (sib && (sib->op_type == OP_TRANS || sib->op_type == OP_TRANSR)) + { + /* this should trigger a "Can't modify transliteration" err */ + op_lvalue(sib, type); + } + op_lvalue(cBINOPo->op_first, type); + break; } /* FALLTHROUGH */ case OP_LIST: diff --git a/t/op/tr.t b/t/op/tr.t index 47acd9e310..2ef2a68475 100644 --- a/t/op/tr.t +++ b/t/op/tr.t @@ -13,7 +13,7 @@ BEGIN { use utf8; -plan tests => 166; +plan tests => 214; # Test this first before we extend the stack with other operations. # This caused an asan failure due to a bad write past the end of the stack. @@ -656,4 +656,48 @@ for ("", nullrocow) { is($string, "A", 'tr// of \N{name} works for upper-Latin1'); } +# RT #130198 +# a tr/// that is cho(m)ped, possibly with an array as arg + +{ + use warnings; + + my ($s, @a); + + my $warn; + local $SIG{__WARN__ } = sub { $warn .= "@_" }; + + for my $c (qw(chop chomp)) { + for my $bind ('', '$s =~ ', '@a =~ ') { + for my $arg2 (qw(a b)) { + for my $r ('', 'r') { + $warn = ''; + # tr/a/b/ modifies its LHS, so if the LHS is an + # array, this should die. The special cases of tr/a/a/ + # and tr/a/b/r don't modify their LHS, so instead + # we croak because cho(m)p is trying to modify it. + # + my $exp = + ($r eq '' && $arg2 eq 'b' && $bind =~ /\@a/) + ? qr/Can't modify private array in transliteration/ + : qr{Can't modify transliteration \(tr///\) in $c}; + + my $expr = "$c(${bind}tr/a/$arg2/$r);"; + eval $expr; + like $@, $exp, "RT #130198 eval: $expr"; + + $exp = + $bind =~ /\@a/ + ? qr{^Applying transliteration \(tr///\) to \@a will act on scalar\(\@a\)} + : qr/^$/; + like $warn, $exp, "RT #130198 warn: $expr"; + } + } + } + } + + +} + + 1; -- Perl5 Master Repository
