From bb16bae836f8e26795fbfac1361bf85da0d6a912 Mon Sep 17 00:00:00 2001 From: Father Chrysostomos Date: Tue, 2 Nov 2010 20:19:25 -0700 Subject: [PATCH] y///r --- dist/B-Deparse/Deparse.pm | 2 ++ ext/B/B.xs | 4 ++-- ext/B/B/Concise.pm | 3 ++- op.c | 33 ++++++++++++++++++++++++--------- pp.c | 7 ++++++- t/op/tr.t | 23 ++++++++++++++++++++++- toke.c | 11 +++++++++-- 7 files changed, 67 insertions(+), 16 deletions(-) diff --git a/dist/B-Deparse/Deparse.pm b/dist/B-Deparse/Deparse.pm index f40ae96..bec809e 100644 --- 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 --- 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 --- 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", "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 --- 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 --- 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 --- 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 --- 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) { -- 2.7.4