Re: [perl #130198] chop(@x =~ tr///)

On Sat, Dec 31, 2016 at 12:45:21AM -0800, Hugo van der Sanden via RT wrote:
> On Fri, 30 Dec 2016 16:08:57 -0800, jkeenan wrote:
> > In 'perldoc -f tr', I see no documentation of anything like:
> > 
> > #####
> > @x =~ tr/1/1/
> > #####
> > 
> > So if that is essentially undefined behavior [...]
> 
> Well the docs say it expects to be supplied a string, and standard perl behaviours in such circumstances would be either to convert what is supplied into a string as best it can, or to give an error.
> 
> Consider the analagous behaviour for a pattern match:
> 
> % perl -wle '@x=(91..95); $y = (@x =~ /(\d+)/); print "$1 ($y)" if $y'
> Applying pattern match (m//) to @x will act on scalar(@x) at -e line 1.
> 5 (1)
> % perl -wle '@x=(91..95); $y = chop(@x =~ /(\d+)/); print "$1 ($y)" if $y'
> Applying pattern match (m//) to @x will act on scalar(@x) at -e line 1.
> Can't modify pattern match (m//) in chop at -e line 1, near "/(\d+)/)"
> Execution of -e aborted due to compilation errors.

This issue should be fixed by the following commit.

commit 2108cbcf2fd75bfcc7b9c01563db7063a67549cf
Author:     David Mitchell <davem@iabyn.com>
AuthorDate: Mon Jan 2 16:37:27 2017 +0000
Commit:     David Mitchell <davem@iabyn.com>
CommitDate: Mon Jan 2 16:52:34 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.


Affected files ...
    M	op.c
    M	t/op/tr.t

Differences ...

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


-- 
Justice is when you get what you deserve.
Law is when you get what you pay for.

• [perl #130198] chop(@x =~ tr///) by Hugo van der Sanden via RT
• Re: [perl #130198] chop(@x =~ tr///) by Dave Mitchell
• [perl #130198] chop(@x =~ tr///) by James E Keenan via RT