}
}
+ if (
+ SvTEMP(right) && !SvSMAGICAL(right) && SvREFCNT(right) == 1 &&
+ (!isGV_with_GP(right) || SvFAKE(right)) && ckWARN(WARN_MISC)
+ )
+ Perl_warner(aTHX_
+ packWARN(WARN_MISC), "Useless assignment to a temporary"
+ );
SvSetMagicSV(right, left);
SETs(right);
RETURN;
{
dVAR; dSP;
AV * const av = PL_op->op_flags & OPf_SPECIAL
- ? MUTABLE_AV(PAD_SV(PL_op->op_targ)) : GvAV(cGVOP_gv);
+ ? MUTABLE_AV(PAD_SV(PL_op->op_targ)) : GvAVn(cGVOP_gv);
const U32 lval = PL_op->op_flags & OPf_MOD;
SV** const svp = av_fetch(av, PL_op->op_private, lval);
SV *sv = (svp ? *svp : &PL_sv_undef);
SETs(sv);
RETURN;
}
- else if (LVRET) {
+ else if (PL_op->op_private & OPpMAYBE_LVSUB) {
+ const I32 flags = is_lvalue_sub();
+ if (flags && !(flags & OPpENTERSUB_INARGS)) {
if (gimme != G_ARRAY)
goto croak_cant_return;
SETs(sv);
RETURN;
+ }
}
else if (PL_op->op_flags & OPf_MOD
&& PL_op->op_private & OPpLVAL_INTRO)
SETs(sv);
RETURN;
}
- else if (LVRET) {
+ else if (PL_op->op_private & OPpMAYBE_LVSUB) {
+ const I32 flags = is_lvalue_sub();
+ if (flags && !(flags & OPpENTERSUB_INARGS)) {
if (gimme != G_ARRAY)
goto croak_cant_return;
SETs(sv);
RETURN;
+ }
}
}
}
/* If there's a common identifier on both sides we have to take
* special care that assigning the identifier on the left doesn't
* clobber a value on the right that's used later in the list.
+ * Don't bother if LHS is just an empty hash or array.
*/
- if (PL_op->op_private & (OPpASSIGN_COMMON)) {
+
+ if ( (PL_op->op_private & OPpASSIGN_COMMON)
+ && (
+ firstlelem != lastlelem
+ || ! ((sv = *firstlelem))
+ || SvMAGICAL(sv)
+ || ! (SvTYPE(sv) == SVt_PVAV || SvTYPE(sv) == SVt_PVHV)
+ || (SvTYPE(sv) == SVt_PVAV && AvFILL((AV*)sv) != -1)
+ || (SvTYPE(sv) == SVt_PVHV && HvUSEDKEYS((HV*)sv) != 0)
+ )
+ ) {
EXTEND_MORTAL(lastrelem - firstrelem + 1);
for (relem = firstrelem; relem <= lastrelem; relem++) {
if ((sv = *relem)) {
break;
}
if (relem <= lastrelem) {
+ if (
+ SvTEMP(sv) && !SvSMAGICAL(sv) && SvREFCNT(sv) == 1 &&
+ (!isGV_with_GP(sv) || SvFAKE(sv)) && ckWARN(WARN_MISC)
+ )
+ Perl_warner(aTHX_
+ packWARN(WARN_MISC),
+ "Useless assignment to a temporary"
+ );
sv_setsv(sv, *relem);
*(relem++) = sv;
}
(void)sv_bless(rv, stash);
}
- if (RX_EXTFLAGS(rx) & RXf_TAINTED)
+ if (RX_EXTFLAGS(rx) & RXf_TAINTED) {
SvTAINTED_on(rv);
+ SvTAINTED_on(SvRV(rv));
+ }
XPUSHs(rv);
RETURN;
}
if (SvSCREAM(TARG))
r_flags |= REXEC_SCREAM;
-play_it_again:
+ play_it_again:
if (global && RX_OFFS(rx)[0].start != -1) {
t = s = RX_OFFS(rx)[0].end + truebase - RX_GOFS(rx);
if ((s + RX_MINLEN(rx)) > strend || s < truebase)
RETPUSHYES;
}
+/*
+A description of how taint works in pattern matching and substitution.
+
+While the pattern is being assembled/concatenated and them compiled,
+PL_tainted will get set if any component of the pattern is tainted, e.g.
+/.*$tainted/. At the end of pattern compilation, the RXf_TAINTED flag
+is set on the pattern if PL_tainted is set.
+
+When the pattern is copied, e.g. $r = qr/..../, the SV holding the ref to
+the pattern is marked as tainted. This means that subsequent usage, such
+as /x$r/, will set PL_tainted, and thus RXf_TAINTED, on the new pattern too.
+
+During execution of a pattern, locale-variant ops such as ALNUML set the
+local flag RF_tainted. At the end of execution, the engine sets the
+RXf_TAINTED_SEEN on the pattern if RF_tainted got set, or clears it
+otherwise.
+
+In addition, RXf_TAINTED_SEEN is used post-execution by the get magic code
+of $1 et al to indicate whether the returned value should be tainted.
+It is the responsibility of the caller of the pattern (i.e. pp_match,
+pp_subst etc) to set this flag for any other circumstances where $1 needs
+to be tainted.
+
+The taint behaviour of pp_subst (and pp_substcont) is quite complex.
+
+There are three possible sources of taint
+ * the source string
+ * the pattern (both compile- and run-time, RXf_TAINTED / RXf_TAINTED_SEEN)
+ * the replacement string (or expression under /e)
+
+There are four destinations of taint and they are affected by the sources
+according to the rules below:
+
+ * the return value (not including /r):
+ tainted by the source string and pattern, but only for the
+ number-of-iterations case; boolean returns aren't tainted;
+ * the modified string (or modified copy under /r):
+ tainted by the source string, pattern, and replacement strings;
+ * $1 et al:
+ tainted by the pattern, and under 'use re "taint"', by the source
+ string too;
+ * PL_taint - i.e. whether subsequent code (e.g. in a /e block) is tainted:
+ should always be unset before executing subsequent code.
+
+The overall action of pp_subst is:
+
+ * at the start, set bits in rxtainted indicating the taint status of
+ the various sources.
+
+ * After each pattern execution, update the SUBST_TAINT_PAT bit in
+ rxtainted if RXf_TAINTED_SEEN has been set, to indicate that the
+ pattern has subsequently become tainted via locale ops.
+
+ * If control is being passed to pp_substcont to execute a /e block,
+ save rxtainted in the CXt_SUBST block, for future use by
+ pp_substcont.
+
+ * Whenever control is being returned to perl code (either by falling
+ off the "end" of pp_subst/pp_substcont, or by entering a /e block),
+ use the flag bits in rxtainted to make all the appropriate types of
+ destination taint visible; e.g. set RXf_TAINTED_SEEN so that $1
+ et al will appear tainted.
+
+pp_match is just a simpler version of the above.
+
+*/
+
PP(pp_subst)
{
dVAR; dSP; dTARG;
I32 maxiters;
register I32 i;
bool once;
- U8 rxtainted;
+ U8 rxtainted = 0; /* holds various SUBST_TAINT_* flag bits.
+ See "how taint works" above */
char *orig;
U8 r_flags;
register REGEXP *rx = PM_GETRE(pm);
const I32 oldsave = PL_savestack_ix;
STRLEN slen;
bool doutf8 = FALSE;
- I32 matched;
#ifdef PERL_OLD_COPY_ON_WRITE
bool is_cow;
#endif
s = SvPV_mutable(TARG, len);
if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
force_on_match = 1;
- rxtainted = ((RX_EXTFLAGS(rx) & RXf_TAINTED) ||
- (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
- if (PL_tainted)
- rxtainted |= 2;
- TAINT_NOT;
+
+ /* only replace once? */
+ once = !(rpm->op_pmflags & PMf_GLOBAL);
+
+ /* See "how taint works" above */
+ if (PL_tainting) {
+ rxtainted = (
+ (SvTAINTED(TARG) ? SUBST_TAINT_STR : 0)
+ | ((RX_EXTFLAGS(rx) & RXf_TAINTED) ? SUBST_TAINT_PAT : 0)
+ | ((pm->op_pmflags & PMf_RETAINT) ? SUBST_TAINT_RETAINT : 0)
+ | ((once && !(rpm->op_pmflags & PMf_NONDESTRUCT))
+ ? SUBST_TAINT_BOOLRET : 0));
+ TAINT_NOT;
+ }
RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
s = CALLREG_INTUIT_START(rx, TARG, s, strend, r_flags, NULL);
if (!s)
- goto nope;
+ goto ret_no;
/* How to do it in subst? */
/* if ( (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
&& !PL_sawampersand
*/
}
- /* only replace once? */
- once = !(rpm->op_pmflags & PMf_GLOBAL);
- matched = CALLREGEXEC(rx, s, strend, orig, 0, TARG, NULL,
- r_flags | REXEC_CHECKED);
+ if (!CALLREGEXEC(rx, s, strend, orig, 0, TARG, NULL,
+ r_flags | REXEC_CHECKED))
+ {
+ ret_no:
+ SPAGAIN;
+ PUSHs(rpm->op_pmflags & PMf_NONDESTRUCT ? TARG : &PL_sv_no);
+ LEAVE_SCOPE(oldsave);
+ RETURN;
+ }
+
/* known replacement string? */
if (dstr) {
+ if (SvTAINTED(dstr))
+ rxtainted |= SUBST_TAINT_REPL;
/* Upgrade the source if the replacement is utf8 but the source is not,
* but only if it matched; see
* http://www.nntp.perl.org/group/perl.perl5.porters/2010/04/msg158809.html
*/
- if (matched && DO_UTF8(dstr) && ! DO_UTF8(TARG)) {
- const STRLEN new_len = sv_utf8_upgrade(TARG);
+ if (DO_UTF8(dstr) && ! DO_UTF8(TARG)) {
+ char * const orig_pvx = SvPVX(TARG);
+ const STRLEN new_len = sv_utf8_upgrade_nomg(TARG);
/* If the lengths are the same, the pattern contains only
* invariants, can keep going; otherwise, various internal markers
* could be off, so redo */
- if (new_len != len) {
+ if (new_len != len || orig_pvx != SvPVX(TARG)) {
goto setup_match;
}
}
&& !(RX_EXTFLAGS(rx) & RXf_LOOKBEHIND_SEEN)
&& (!doutf8 || SvUTF8(TARG)))
{
- if (!matched)
- {
- SPAGAIN;
- if (rpm->op_pmflags & PMf_NONDESTRUCT)
- PUSHs(TARG);
- else
- PUSHs(&PL_sv_no);
- LEAVE_SCOPE(oldsave);
- RETURN;
- }
+
#ifdef PERL_OLD_COPY_ON_WRITE
if (SvIsCOW(TARG)) {
assert (!force_on_match);
PL_curpm = pm;
SvSCREAM_off(TARG); /* disable possible screamer */
if (once) {
- rxtainted |= RX_MATCH_TAINTED(rx);
+ if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
+ rxtainted |= SUBST_TAINT_PAT;
m = orig + RX_OFFS(rx)[0].start;
d = orig + RX_OFFS(rx)[0].end;
s = orig;
else {
sv_chop(TARG, d);
}
- TAINT_IF(rxtainted & 1);
SPAGAIN;
- if (rpm->op_pmflags & PMf_NONDESTRUCT)
- PUSHs(TARG);
- else
- PUSHs(&PL_sv_yes);
+ PUSHs(rpm->op_pmflags & PMf_NONDESTRUCT ? TARG : &PL_sv_yes);
}
else {
do {
if (iters++ > maxiters)
DIE(aTHX_ "Substitution loop");
- rxtainted |= RX_MATCH_TAINTED(rx);
+ if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
+ rxtainted |= SUBST_TAINT_PAT;
m = RX_OFFS(rx)[0].start + orig;
if ((i = m - s)) {
if (s != d)
SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
Move(s, d, i+1, char); /* include the NUL */
}
- TAINT_IF(rxtainted & 1);
SPAGAIN;
if (rpm->op_pmflags & PMf_NONDESTRUCT)
PUSHs(TARG);
else
mPUSHi((I32)iters);
}
- (void)SvPOK_only_UTF8(TARG);
- TAINT_IF(rxtainted);
- if (SvSMAGICAL(TARG)) {
- PUTBACK;
- mg_set(TARG);
- SPAGAIN;
- }
- SvTAINT(TARG);
- if (doutf8)
- SvUTF8_on(TARG);
- LEAVE_SCOPE(oldsave);
- RETURN;
}
-
- if (matched)
- {
+ else {
if (force_on_match) {
force_on_match = 0;
s = SvPV_force(TARG, len);
#ifdef PERL_OLD_COPY_ON_WRITE
have_a_cow:
#endif
- rxtainted |= RX_MATCH_TAINTED(rx);
+ if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
+ rxtainted |= SUBST_TAINT_PAT;
dstr = newSVpvn_utf8(m, s-m, DO_UTF8(TARG));
SAVEFREESV(dstr);
PL_curpm = pm;
if (!c) {
register PERL_CONTEXT *cx;
SPAGAIN;
+ /* note that a whole bunch of local vars are saved here for
+ * use by pp_substcont: here's a list of them in case you're
+ * searching for places in this sub that uses a particular var:
+ * iters maxiters r_flags oldsave rxtainted orig dstr targ
+ * s m strend rx once */
PUSHSUBST(cx);
RETURNOP(cPMOP->op_pmreplrootu.op_pmreplroot);
}
do {
if (iters++ > maxiters)
DIE(aTHX_ "Substitution loop");
- rxtainted |= RX_MATCH_TAINTED(rx);
+ if (RX_MATCH_TAINTED(rx))
+ rxtainted |= SUBST_TAINT_PAT;
if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
m = s;
s = orig;
doutf8 |= DO_UTF8(dstr);
SvPV_set(dstr, NULL);
- TAINT_IF(rxtainted & 1);
SPAGAIN;
if (rpm->op_pmflags & PMf_NONDESTRUCT)
PUSHs(TARG);
else
mPUSHi((I32)iters);
+ }
+ (void)SvPOK_only_UTF8(TARG);
+ if (doutf8)
+ SvUTF8_on(TARG);
+
+ /* See "how taint works" above */
+ if (PL_tainting) {
+ if ((rxtainted & SUBST_TAINT_PAT) ||
+ ((rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT)) ==
+ (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
+ )
+ (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
+
+ if (!(rxtainted & SUBST_TAINT_BOOLRET)
+ && (rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT))
+ )
+ SvTAINTED_on(TOPs); /* taint return value */
+ else
+ SvTAINTED_off(TOPs); /* may have got tainted earlier */
- (void)SvPOK_only(TARG);
- if (doutf8)
- SvUTF8_on(TARG);
- TAINT_IF(rxtainted);
- SvSETMAGIC(TARG);
+ /* needed for mg_set below */
+ PL_tainted =
+ cBOOL(rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL));
SvTAINT(TARG);
- LEAVE_SCOPE(oldsave);
- RETURN;
}
- goto ret_no;
-
-nope:
-ret_no:
- SPAGAIN;
- if (rpm->op_pmflags & PMf_NONDESTRUCT)
- PUSHs(TARG);
- else
- PUSHs(&PL_sv_no);
+ SvSETMAGIC(TARG); /* PL_tainted must be correctly set for this mg_set */
+ TAINT_NOT;
LEAVE_SCOPE(oldsave);
RETURN;
}
I32 gimme;
register PERL_CONTEXT *cx;
SV *sv;
+ bool gmagic;
if (CxMULTICALL(&cxstack[cxstack_ix]))
return 0;
POPBLOCK(cx,newpm);
cxstack_ix++; /* temporarily protect top context */
+ gmagic = CxLVAL(cx) & OPpENTERSUB_DEREF;
TAINT_NOT;
if (gimme == G_SCALAR) {
*MARK = SvREFCNT_inc(TOPs);
FREETMPS;
sv_2mortal(*MARK);
+ if (gmagic) SvGETMAGIC(*MARK);
}
else {
sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
SvREFCNT_dec(sv);
}
}
+ else if (SvTEMP(TOPs)) {
+ *MARK = TOPs;
+ if (gmagic) SvGETMAGIC(TOPs);
+ }
else
- *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
+ *MARK = sv_mortalcopy(TOPs);
}
else {
MEXTEND(MARK, 0);
* subroutines too, so be backward compatible:
* cannot report errors. */
- /* Scalar context *is* possible, on the LHS of -> only,
- * as in f()->meth(). But this is not an lvalue. */
+ /* Scalar context *is* possible, on the LHS of ->. */
if (gimme == G_SCALAR)
- goto temporise;
+ goto rvalue;
if (gimme == G_ARRAY) {
mark = newsp + 1;
- /* We want an array here, but padav will have left us an arrayref for an lvalue,
- * so we need to expand it */
- if(SvTYPE(*mark) == SVt_PVAV) {
- AV *const av = MUTABLE_AV(*mark);
- const I32 maxarg = AvFILL(av) + 1;
- (void)POPs; /* get rid of the array ref */
- EXTEND(SP, maxarg);
- if (SvRMAGICAL(av)) {
- U32 i;
- for (i=0; i < (U32)maxarg; i++) {
- SV ** const svp = av_fetch(av, i, FALSE);
- SP[i+1] = svp
- ? SvGMAGICAL(*svp) ? (mg_get(*svp), *svp) : *svp
- : &PL_sv_undef;
- }
- }
- else {
- Copy(AvARRAY(av), SP+1, maxarg, SV*);
- }
- SP += maxarg;
- PUTBACK;
- }
if (!CvLVALUE(cx->blk_sub.cv))
- goto temporise_array;
+ goto rvalue_array;
EXTEND_MORTAL(SP - newsp);
for (mark = newsp + 1; mark <= SP; mark++) {
if (SvTEMP(*mark))
NOOP;
- else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
+ else if (SvFLAGS(*mark) & SVs_PADTMP
+ || (SvFLAGS(*mark) & (SVf_READONLY|SVf_FAKE))
+ == SVf_READONLY)
*mark = sv_mortalcopy(*mark);
else {
/* Can be a localized value subject to deletion. */
MARK = newsp + 1;
EXTEND_MORTAL(1);
if (MARK == SP) {
- /* Temporaries are bad unless they happen to have set magic
- * attached, such as the elements of a tied hash or array */
- if ((SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP) ||
+ if ((SvPADTMP(TOPs) ||
(SvFLAGS(TOPs) & (SVf_READONLY | SVf_FAKE))
== SVf_READONLY
) &&
SvREFCNT_inc_void(*mark);
}
}
- else { /* Should not happen? */
+ else {
+ /* sub:lvalue{} will take us here.
+ Presumably the case of a non-empty array never happens.
+ */
LEAVE;
cxstack_ix--;
POPSUB(cx,sv);
PL_curpm = newpm;
LEAVESUB(sv);
- DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
- (MARK > SP ? "Empty array" : "Array"));
+ DIE(aTHX_ "%s",
+ (MARK > SP
+ ? "Can't return undef from lvalue subroutine"
+ : "Array returned from lvalue subroutine in scalar "
+ "context"
+ )
+ );
}
SP = MARK;
}
EXTEND_MORTAL(SP - newsp);
for (mark = newsp + 1; mark <= SP; mark++) {
if (*mark != &PL_sv_undef
- && SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
+ && (SvPADTMP(*mark)
+ || (SvFLAGS(*mark) & (SVf_READONLY|SVf_FAKE))
+ == SVf_READONLY
+ )
+ ) {
/* Might be flattened array after $#array = */
PUTBACK;
LEAVE;
}
else {
if (gimme == G_SCALAR) {
- temporise:
+ rvalue:
MARK = newsp + 1;
if (MARK <= SP) {
if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
- if (SvTEMP(TOPs)) {
*MARK = SvREFCNT_inc(TOPs);
FREETMPS;
sv_2mortal(*MARK);
- }
- else {
- sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
- FREETMPS;
- *MARK = sv_mortalcopy(sv);
- SvREFCNT_dec(sv);
- }
}
else
- *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
+ *MARK = SvTEMP(TOPs)
+ ? TOPs
+ : sv_2mortal(SvREFCNT_inc_simple_NN(TOPs));
}
else {
MEXTEND(MARK, 0);
SP = MARK;
}
else if (gimme == G_ARRAY) {
- temporise_array:
+ rvalue_array:
for (MARK = newsp + 1; MARK <= SP; MARK++) {
- if (!SvTEMP(*MARK)) {
- *MARK = sv_mortalcopy(*MARK);
- TAINT_NOT; /* Each item is independent */
- }
+ if (!SvTEMP(*MARK))
+ *MARK = sv_2mortal(SvREFCNT_inc_simple_NN(*MARK));
+ }
+ }
+ }
+
+ if (CxLVAL(cx) & OPpENTERSUB_DEREF) {
+ assert(gimme == G_SCALAR);
+ SvGETMAGIC(TOPs);
+ if (!SvOK(TOPs)) {
+ U8 deref_type;
+ if (cx->blk_sub.retop->op_type == OP_RV2SV)
+ deref_type = OPpDEREF_SV;
+ else if (cx->blk_sub.retop->op_type == OP_RV2AV)
+ deref_type = OPpDEREF_AV;
+ else {
+ assert(cx->blk_sub.retop->op_type == OP_RV2HV);
+ deref_type = OPpDEREF_HV;
}
+ vivify_ref(TOPs, deref_type);
}
}
+
PUTBACK;
LEAVE;
https://perl5.git.perl.org / perl5.git / blobdiff