This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Handle chop(@a =~ tr///)
authorDavid Mitchell <davem@iabyn.com>
Mon, 2 Jan 2017 16:37:27 +0000 (16:37 +0000)
committerDavid Mitchell <davem@iabyn.com>
Mon, 2 Jan 2017 16:52:34 +0000 (16:52 +0000)
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.

op.c
t/op/tr.t

diff --git a/op.c b/op.c
index 394efef..339a9ce 100644 (file)
--- 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:
index 47acd9e..2ef2a68 100644 (file)
--- 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;