}
}
+ 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; SvGETMAGIC(TOPs);
- tryAMAGICunTARGET(iter_amg, 0);
+ tryAMAGICunTARGET(iter_amg, 0, 0);
PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--);
if (!isGV_with_GP(PL_last_in_gv)) {
if (SvROK(PL_last_in_gv) && isGV_with_GP(SvRV(PL_last_in_gv)))
dSP;
XPUSHs(MUTABLE_SV(PL_last_in_gv));
PUTBACK;
- pp_rv2gv();
+ Perl_pp_rv2gv(aTHX);
PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--);
}
}
PP(pp_aelemfast)
{
dVAR; dSP;
- AV * const av = PL_op->op_flags & OPf_SPECIAL
- ? MUTABLE_AV(PAD_SV(PL_op->op_targ)) : GvAV(cGVOP_gv);
+ AV * const av = PL_op->op_type == OP_AELEMFAST_LEX
+ ? 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);
PP(pp_print)
{
dVAR; dSP; dMARK; dORIGMARK;
- IO *io;
register PerlIO *fp;
MAGIC *mg;
GV * const gv
= (PL_op->op_flags & OPf_STACKED) ? MUTABLE_GV(*++MARK) : PL_defoutgv;
+ IO *io = GvIO(gv);
- if (gv && (io = GvIO(gv))
+ if (io
&& (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
{
had_magic:
Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
++SP;
}
- PUSHMARK(MARK - 1);
- *MARK = SvTIED_obj(MUTABLE_SV(io), mg);
- PUTBACK;
- ENTER_with_name("call_PRINT");
- if( PL_op->op_type == OP_SAY ) {
- /* local $\ = "\n" */
- SAVEGENERICSV(PL_ors_sv);
- PL_ors_sv = newSVpvs("\n");
- }
- call_method("PRINT", G_SCALAR);
- LEAVE_with_name("call_PRINT");
- SPAGAIN;
- MARK = ORIGMARK + 1;
- *MARK = *SP;
- SP = MARK;
- RETURN;
+ return Perl_tied_method(aTHX_ "PRINT", mark - 1, MUTABLE_SV(io),
+ mg,
+ (G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK
+ | (PL_op->op_type == OP_SAY
+ ? TIED_METHOD_SAY : 0)), sp - mark);
}
- if (!(io = GvIO(gv))) {
+ if (!io) {
if ( gv && GvEGVx(gv) && (io = GvIO(GvEGV(gv)))
&& (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
goto had_magic;
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 (is_pp_rv2av) {
AV *const av = MUTABLE_AV(sv);
- /* The guts of pp_rv2av, with no intenting change to preserve history
+ /* The guts of pp_rv2av, with no intending change to preserve history
(until such time as we get tools that can do blame annotation across
whitespace changes. */
- if (gimme == G_ARRAY) {
- const I32 maxarg = AvFILL(av) + 1;
- (void)POPs; /* XXXX May be optimized away? */
- EXTEND(SP, maxarg);
- if (SvRMAGICAL(av)) {
- U32 i;
- for (i=0; i < (U32)maxarg; i++) {
- SV ** const svp = av_fetch(av, i, FALSE);
- /* See note in pp_helem, and bug id #27839 */
- SP[i+1] = svp
- ? SvGMAGICAL(*svp) ? (mg_get(*svp), *svp) : *svp
- : &PL_sv_undef;
+ if (gimme == G_ARRAY) {
+ const I32 maxarg = AvFILL(av) + 1;
+ (void)POPs; /* XXXX May be optimized away? */
+ EXTEND(SP, maxarg);
+ if (SvRMAGICAL(av)) {
+ U32 i;
+ for (i=0; i < (U32)maxarg; i++) {
+ SV ** const svp = av_fetch(av, i, FALSE);
+ /* See note in pp_helem, and bug id #27839 */
+ SP[i+1] = svp
+ ? SvGMAGICAL(*svp) ? (mg_get(*svp), *svp) : *svp
+ : &PL_sv_undef;
+ }
+ }
+ else {
+ Copy(AvARRAY(av), SP+1, maxarg, SV*);
}
+ SP += maxarg;
}
- else {
- Copy(AvARRAY(av), SP+1, maxarg, SV*);
+ else if (gimme == G_SCALAR) {
+ dTARGET;
+ const I32 maxarg = AvFILL(av) + 1;
+ SETi(maxarg);
}
- SP += maxarg;
- }
- else if (gimme == G_SCALAR) {
- dTARGET;
- const I32 maxarg = AvFILL(av) + 1;
- SETi(maxarg);
- }
} else {
/* The guts of pp_rv2hv */
- if (gimme == G_ARRAY) { /* array wanted */
- *PL_stack_sp = sv;
- return do_kv();
- }
- else if (gimme == G_SCALAR) {
- dTARGET;
- TARG = Perl_hv_scalar(aTHX_ MUTABLE_HV(sv));
- SPAGAIN;
- SETTARG;
- }
+ if (gimme == G_ARRAY) { /* array wanted */
+ *PL_stack_sp = sv;
+ return Perl_do_kv(aTHX);
+ }
+ else if (gimme == G_SCALAR) {
+ dTARGET;
+ TARG = Perl_hv_scalar(aTHX_ MUTABLE_HV(sv));
+ SPAGAIN;
+ SETTARG;
+ }
}
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)
&& !SvROK(TARG)) /* Cannot trust since INTUIT cannot guess ^ */
goto yup;
}
- if (CALLREGEXEC(rx, (char*)s, (char *)strend, (char*)truebase,
- minmatch, TARG, NUM2PTR(void*, gpos), r_flags))
- {
- PL_curpm = pm;
- if (dynpm->op_pmflags & PMf_ONCE) {
+ if (!CALLREGEXEC(rx, (char*)s, (char *)strend, (char*)truebase,
+ minmatch, TARG, NUM2PTR(void*, gpos), r_flags))
+ goto ret_no;
+
+ PL_curpm = pm;
+ if (dynpm->op_pmflags & PMf_ONCE) {
#ifdef USE_ITHREADS
- SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
+ SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
#else
- dynpm->op_pmflags |= PMf_USED;
+ dynpm->op_pmflags |= PMf_USED;
#endif
- }
- goto gotcha;
}
- else
- goto ret_no;
- /*NOTREACHED*/
gotcha:
if (rxtainted)
const I32 gimme = GIMME_V;
if (io) {
- MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
+ const MAGIC *const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
if (mg) {
- PUSHMARK(SP);
- XPUSHs(SvTIED_obj(MUTABLE_SV(io), mg));
- PUTBACK;
- ENTER_with_name("call_READLINE");
- call_method("READLINE", gimme);
- LEAVE_with_name("call_READLINE");
- SPAGAIN;
+ Perl_tied_method(aTHX_ "READLINE", SP, MUTABLE_SV(io), mg, gimme, 0);
if (gimme == G_SCALAR) {
- SV* const result = POPs;
- SvSetSV_nosteal(TARG, result);
- PUSHTARG;
+ SPAGAIN;
+ SvSetSV_nosteal(TARG, TOPs);
+ SETTARG;
}
- RETURN;
+ return NORMAL;
}
}
fp = NULL;
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;
}
}
#endif
&& (I32)clen <= RX_MINLENRET(rx) && (once || !(r_flags & REXEC_COPY_STR))
&& !(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;
- }
+ && (!doutf8 || SvUTF8(TARG)))
+ {
+
#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);
- dstr = newSVpvn_utf8(m, s-m, DO_UTF8(TARG));
- SAVEFREESV(dstr);
+ if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
+ rxtainted |= SUBST_TAINT_PAT;
+ dstr = newSVpvn_flags(m, s-m, SVs_TEMP | (DO_UTF8(TARG) ? SVf_UTF8 : 0));
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 = newsp + 1;
if (MARK <= SP) {
if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
- if (SvTEMP(TOPs)) {
+ if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1) {
*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) && SvREFCNT(TOPs) == 1) {
+ *MARK = TOPs;
+ if (gmagic) SvGETMAGIC(TOPs);
+ }
else
- *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
+ *MARK = sv_mortalcopy(TOPs);
}
else {
MEXTEND(MARK, 0);
}
else if (gimme == G_ARRAY) {
for (MARK = newsp + 1; MARK <= SP; MARK++) {
- if (!SvTEMP(*MARK)) {
+ if (!SvTEMP(*MARK) || SvREFCNT(*MARK) != 1) {
*MARK = sv_mortalcopy(*MARK);
TAINT_NOT; /* Each item is independent */
}
POPBLOCK(cx,newpm);
cxstack_ix++; /* temporarily protect top context */
+ assert(CvLVALUE(cx->blk_sub.cv));
TAINT_NOT;
* 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)
*mark = sv_mortalcopy(*mark);
else {
/* Can be a localized value subject to deletion. */
}
}
else if (CxLVAL(cx)) { /* Leave it as it is if we can. */
- /* Here we go for robustness, not for speed, so we change all
- * the refcounts so the caller gets a live guy. Cannot set
- * TEMP, so sv_2mortal is out of question. */
- if (!CvLVALUE(cx->blk_sub.cv)) {
- LEAVE;
- cxstack_ix--;
- POPSUB(cx,sv);
- PL_curpm = newpm;
- LEAVESUB(sv);
- DIE(aTHX_ "Can't modify non-lvalue subroutine call");
- }
if (gimme == G_SCALAR) {
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