From @iabyn

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 2108cbc
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 ...

Inline Patch

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.

chop(@x =~ tr///) #15738

Description

Metadata

Metadata

Assignees

Labels

Type

Projects

Milestone

Relationships

Development

Issue actions