y///r

diff --git a/dist/B-Deparse/Deparse.pm b/dist/B-Deparse/Deparse.pm
index f40ae96..bec809e 100644 (file)
--- a/dist/B-Deparse/Deparse.pm
+++ b/dist/B-Deparse/Deparse.pm
@@ -4101,6 +4101,8 @@ sub pp_trans {
     return "tr" . double_delim($from, $to) . $flags;
 }
 
+sub pp_transr { &pp_trans . 'r' }
+
 sub re_dq_disambiguate {
     my ($first, $last) = @_;
     # Disambiguate "${foo}bar", "${foo}{bar}", "${foo}[1]"

diff --git a/ext/B/B.xs b/ext/B/B.xs
index b32816c..4651e46 100644 (file)
--- a/ext/B/B.xs
+++ b/ext/B/B.xs
@@ -1196,7 +1196,7 @@ PVOP_pv(o)
         * OP_TRANS uses op_pv to point to a table of 256 or >=258 shorts
         * whereas other PVOPs point to a null terminated string.
         */
-       if (o->op_type == OP_TRANS &&
+       if ((o->op_type == OP_TRANS || o->op_type == OP_TRANSR) &&
                (o->op_private & OPpTRANS_COMPLEMENT) &&
                !(o->op_private & OPpTRANS_DELETE))
        {
@@ -1204,7 +1204,7 @@ PVOP_pv(o)
            const short entries = 257 + tbl[256];
            ST(0) = newSVpvn_flags(o->op_pv, entries * sizeof(short), SVs_TEMP);
        }
-       else if (o->op_type == OP_TRANS) {
+       else if (o->op_type == OP_TRANS || o->op_type == OP_TRANSR) {
            ST(0) = newSVpvn_flags(o->op_pv, 256 * sizeof(short), SVs_TEMP);
        }
        else

diff --git a/ext/B/B/Concise.pm b/ext/B/B/Concise.pm
index 53afe83..fa90ade 100644 (file)
--- a/ext/B/B/Concise.pm
+++ b/ext/B/B/Concise.pm
@@ -604,6 +604,7 @@ $priv{"sassign"}{64} = "BKWARD";
 $priv{$_}{64} = "RTIME" for ("match", "subst", "substcont", "qr");
 @{$priv{"trans"}}{1,2,4,8,16,64} = ("<UTF", ">UTF", "IDENT", "SQUASH", "DEL",
                                    "COMPL", "GROWS");
+$priv{transr} = $priv{trans};
 $priv{"repeat"}{64} = "DOLIST";
 $priv{"leaveloop"}{64} = "CONT";
 $priv{$_}{4} = "DREFed" for (qw(rv2sv rv2av rv2hv));
@@ -836,7 +837,7 @@ sub concise_op {
        } else {
            $h{arg} = "($precomp)";
        }
-    } elsif ($h{class} eq "PVOP" and $h{name} ne "trans") {
+    } elsif ($h{class} eq "PVOP" and $h{name} !~ '^transr?\z') {
        $h{arg} = '("' . $op->pv . '")';
        $h{svval} = '"' . $op->pv . '"';
     } elsif ($h{class} eq "COP") {

diff --git a/op.c b/op.c
index 795de09..7a6dbcd 100644 (file)
--- a/op.c
+++ b/op.c
@@ -651,6 +651,7 @@ Perl_op_clear(pTHX_ OP *o)
            break;
        /* FALL THROUGH */
     case OP_TRANS:
+    case OP_TRANSR:
        if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
 #ifdef USE_ITHREADS
            if (cPADOPo->op_padix > 0) {
@@ -1144,7 +1145,7 @@ Perl_scalarvoid(pTHX_ OP *o)
     case OP_NOT:
        kid = cUNOPo->op_first;
        if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
-           kid->op_type != OP_TRANS) {
+           kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
                goto func_ops;
        }
        useless = "negative pattern binding (!~)";
@@ -1155,6 +1156,10 @@ Perl_scalarvoid(pTHX_ OP *o)
            useless = "non-destructive substitution (s///r)";
        break;
 
+    case OP_TRANSR:
+       useless = "non-destructive transliteration (tr///r)";
+       break;
+
     case OP_RV2GV:
     case OP_RV2SV:
     case OP_RV2AV:
@@ -1813,6 +1818,7 @@ S_scalar_mod_type(const OP *o, I32 type)
     case OP_CONCAT:
     case OP_SUBST:
     case OP_TRANS:
+    case OP_TRANSR:
     case OP_READ:
     case OP_SYSREAD:
     case OP_RECV:
@@ -2258,7 +2264,10 @@ Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
          || ltype == OP_PADHV) && ckWARN(WARN_MISC))
     {
       const char * const desc
-         = PL_op_desc[(rtype == OP_SUBST || rtype == OP_TRANS)
+         = PL_op_desc[(
+                         rtype == OP_SUBST || rtype == OP_TRANS
+                      || rtype == OP_TRANSR
+                      )
                       ? (int)rtype : OP_MATCH];
       const char * const sample = ((ltype == OP_RV2AV || ltype == OP_PADAV)
             ? "@array" : "%hash");
@@ -2274,14 +2283,16 @@ Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
        no_bareword_allowed(right);
     }
 
-    /* !~ doesn't make sense with s///r, so error on it for now */
+    /* !~ doesn't make sense with /r, so error on it for now */
     if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
        type == OP_NOT)
        yyerror("Using !~ with s///r doesn't make sense");
+    if (rtype == OP_TRANSR && type == OP_NOT)
+       yyerror("Using !~ with tr///r doesn't make sense");
 
     ismatchop = (rtype == OP_MATCH ||
                 rtype == OP_SUBST ||
-                rtype == OP_TRANS)
+                rtype == OP_TRANS || rtype == OP_TRANSR)
             && !(right->op_flags & OPf_SPECIAL);
     if (ismatchop && right->op_private & OPpTARGET_MY) {
        right->op_targ = 0;
@@ -2291,7 +2302,7 @@ Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
        OP *newleft;
 
        right->op_flags |= OPf_STACKED;
-       if (rtype != OP_MATCH &&
+       if (rtype != OP_MATCH && rtype != OP_TRANSR &&
             ! (rtype == OP_TRANS &&
                right->op_private & OPpTRANS_IDENTICAL) &&
            ! (rtype == OP_SUBST &&
@@ -2299,7 +2310,7 @@ Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
            newleft = op_lvalue(left, rtype);
        else
            newleft = left;
-       if (right->op_type == OP_TRANS)
+       if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
            o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
        else
            o = op_prepend_elem(rtype, scalar(newleft), right);
@@ -3824,7 +3835,10 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
 
     PERL_ARGS_ASSERT_PMRUNTIME;
 
-    if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
+    if (
+        o->op_type == OP_SUBST
+     || o->op_type == OP_TRANS || o->op_type == OP_TRANSR
+    ) {
        /* last element in list is the replacement; pop it */
        OP* kid;
        repl = cLISTOPx(expr)->op_last;
@@ -3846,7 +3860,7 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
        op_free(oe);
     }
 
-    if (o->op_type == OP_TRANS) {
+    if (o->op_type == OP_TRANS || o->op_type == OP_TRANSR) {
        return pmtrans(o, expr, repl);
     }
 
@@ -4996,6 +5010,7 @@ S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
                other = newUNOP(OP_NULL, OPf_SPECIAL, other);
            else if (other->op_type == OP_MATCH
                  || other->op_type == OP_SUBST
+                 || other->op_type == OP_TRANSR
                  || other->op_type == OP_TRANS)
                /* Mark the op as being unbindable with =~ */
                other->op_flags |= OPf_SPECIAL;
@@ -5152,7 +5167,7 @@ Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
        if (live->op_type == OP_LEAVE)
            live = newUNOP(OP_NULL, OPf_SPECIAL, live);
        else if (live->op_type == OP_MATCH || live->op_type == OP_SUBST
-             || live->op_type == OP_TRANS)
+             || live->op_type == OP_TRANS || live->op_type == OP_TRANSR)
            /* Mark the op as being unbindable with =~ */
            live->op_flags |= OPf_SPECIAL;
        return live;

diff --git a/pp.c b/pp.c
index de72d4e..1386f38 100644 (file)
--- a/pp.c
+++ b/pp.c
@@ -775,7 +775,12 @@ PP(pp_trans)
        EXTEND(SP,1);
     }
     TARG = sv_newmortal();
-    PUSHi(do_trans(sv));
+    if(PL_op->op_type == OP_TRANSR) {
+       SV * const newsv = newSVsv(sv);
+       do_trans(newsv);
+       mPUSHs(newsv);
+    }
+    else PUSHi(do_trans(sv));
     RETURN;
 }
 

diff --git a/t/op/tr.t b/t/op/tr.t
index 3f85e43..52574b0 100644 (file)
--- a/t/op/tr.t
+++ b/t/op/tr.t
@@ -6,7 +6,7 @@ BEGIN {
     require './test.pl';
 }
 
-plan tests => 119;
+plan tests => 128;
 
 my $Is_EBCDIC = (ord('i') == 0x89 & ord('J') == 0xd1);
 
@@ -44,6 +44,27 @@ is($_, "aBCDEFGHIJKLMNOPQRSTUVWXYz",    'partial uc');
 (my $g = 1.5) =~ tr/1/3/;
 is($x + $y + $f + $g, 71,   'tr cancels IOK and NOK');
 
+# /r
+$_ = 'adam';
+is y/dam/ve/rd, 'eve', '/r';
+is $_, 'adam', '/r leaves param alone';
+$g = 'ruby';
+is $g =~ y/bury/repl/r, 'perl', '/r with explicit param';
+is $g, 'ruby', '/r leaves explicit param alone';
+is "aaa" =~ y\a\b\r, 'bbb', '/r with constant param';
+ok !eval '$_ !~ y///r', "!~ y///r is forbidden";
+like $@, qr\^Using !~ with tr///r doesn't make sense\,
+  "!~ y///r error message";
+{
+  my $w;
+  my $wc;
+  local $SIG{__WARN__} = sub { $w = shift; ++$wc };
+  local $^W = 1;
+  eval 'y///r; 1';
+  like $w, qr '^Useless use of non-destructive transliteration \(tr///r\)',
+    '/r warns in void context';
+  is $wc, 1, '/r warns just once';
+}
 
 # perlbug [ID 20000511.005]
 $_ = 'fred';

diff --git a/toke.c b/toke.c
index 64be922..70b1dfd 100644 (file)
--- a/toke.c
+++ b/toke.c
@@ -2416,6 +2416,7 @@ S_sublex_push(pTHX)
     CopLINE_set(PL_curcop, (line_t)PL_multi_start);
 
     PL_lex_inwhat = PL_sublex_info.sub_inwhat;
+    if (PL_lex_inwhat == OP_TRANSR) PL_lex_inwhat = OP_TRANS;
     if (PL_lex_inwhat == OP_MATCH || PL_lex_inwhat == OP_QR || PL_lex_inwhat == OP_SUBST)
        PL_lex_inpat = PL_sublex_info.sub_op;
     else
@@ -2448,6 +2449,7 @@ S_sublex_done(pTHX)
     }
 
     /* Is there a right-hand side to take care of? (s//RHS/ or tr//RHS/) */
+    assert(PL_lex_inwhat != OP_TRANSR);
     if (PL_lex_repl && (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS)) {
        PL_linestr = PL_lex_repl;
        PL_lex_inpat = 0;
@@ -2615,6 +2617,7 @@ S_scan_const(pTHX_ char *start)
 
     PERL_ARGS_ASSERT_SCAN_CONST;
 
+    assert(PL_lex_inwhat != OP_TRANSR);
     if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
        /* If we are doing a trans and we know we want UTF8 set expectation */
        has_utf8   = PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF);
@@ -12100,6 +12103,7 @@ S_scan_trans(pTHX_ char *start)
     U8 squash;
     U8 del;
     U8 complement;
+    bool nondestruct = 0;
 #ifdef PERL_MAD
     char *modstart;
 #endif
@@ -12153,6 +12157,9 @@ S_scan_trans(pTHX_ char *start)
        case 's':
            squash = OPpTRANS_SQUASH;
            break;
+       case 'r':
+           nondestruct = 1;
+           break;
        default:
            goto no_more;
        }
@@ -12161,14 +12168,14 @@ S_scan_trans(pTHX_ char *start)
   no_more:
 
     tbl = (short *)PerlMemShared_calloc(complement&&!del?258:256, sizeof(short));
-    o = newPVOP(OP_TRANS, 0, (char*)tbl);
+    o = newPVOP(nondestruct ? OP_TRANSR : OP_TRANS, 0, (char*)tbl);
     o->op_private &= ~OPpTRANS_ALL;
     o->op_private |= del|squash|complement|
       (DO_UTF8(PL_lex_stuff)? OPpTRANS_FROM_UTF : 0)|
       (DO_UTF8(PL_lex_repl) ? OPpTRANS_TO_UTF   : 0);
 
     PL_lex_op = o;
-    pl_yylval.ival = OP_TRANS;
+    pl_yylval.ival = nondestruct ? OP_TRANSR : OP_TRANS;
 
 #ifdef PERL_MAD
     if (PL_madskills) {