summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--dist/B-Deparse/Deparse.pm2
-rw-r--r--ext/B/B.xs4
-rw-r--r--ext/B/B/Concise.pm3
-rw-r--r--op.c33
-rw-r--r--pp.c7
-rw-r--r--t/op/tr.t23
-rw-r--r--toke.c11
7 files changed, 67 insertions, 16 deletions
diff --git a/dist/B-Deparse/Deparse.pm b/dist/B-Deparse/Deparse.pm
index f40ae96747..bec809ef8f 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 b32816c15b..4651e468ba 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 53afe83cac..fa90ade820 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", ">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 795de09cff..7a6dbcdb83 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 de72d4e21c..1386f386ce 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 3f85e43758..52574b0ae9 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 64be92293d..70b1dfdf4e 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) {
View Lorry Controller Status