allow non-variable as lhs of non-updating tr///

Message-Id: <E13JEgd-0003fy-00@libra.cus.cam.ac.uk>

(aka ID 20000730.002)

p4raw-id: //depot/perl@6471

diff --git a/op.c b/op.c
index 14c5573..86bd419 100644 (file)
--- a/op.c
+++ b/op.c
@@ -1988,7 +1988,9 @@ Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
        right->op_type == OP_SUBST ||
        right->op_type == OP_TRANS)) {
        right->op_flags |= OPf_STACKED;
-       if (right->op_type != OP_MATCH)
+       if (right->op_type != OP_MATCH &&
+            ! (right->op_type == OP_TRANS &&
+               right->op_private & OPpTRANS_IDENTICAL))
            left = mod(left, right->op_type);
        if (right->op_type == OP_TRANS)
            o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);

diff --git a/t/op/tr.t b/t/op/tr.t
index 2c1c4fd..ea665c7 100755 (executable)
--- a/t/op/tr.t
+++ b/t/op/tr.t
@@ -5,7 +5,7 @@ BEGIN {
     unshift @INC, "../lib";
 }
 
-print "1..23\n";
+print "1..27\n";
 
 $_ = "abcdefghijklmnopqrstuvwxyz";
 
@@ -146,3 +146,20 @@ eval "tr/m-d/ /";
 print (($@ =~ /^Invalid \[\] range "m-d" in transliteration operator/) 
        ? '' : 'not ', "ok 23\n");
 
+# 24: test cannot update if read-only
+eval '$1 =~ tr/x/y/';
+print (($@ =~ /^Modification of a read-only value attempted/) ? '' : 'not ',
+       "ok 24\n");
+
+# 25: test can count read-only
+'abcdef' =~ /(bcd)/;
+print (( eval '$1 =~ tr/abcd//' == 3) ? '' : 'not ', "ok 25\n");
+
+# 26: test lhs OK if not updating
+print ((eval '"123" =~ tr/12//' == 2) ? '' : 'not ', "ok 26\n");
+
+# 27: test lhs bad if updating
+eval '"123" =~ tr/1/1/';
+print (($@ =~ m|^Can't modify constant item in transliteration \(tr///\)|)
+       ? '' : 'not ', "ok 27\n");
+