PP(pp_sassign)
{
dVAR; dSP; dPOPTOPssrl;
- U32 wasfake = 0;
if (PL_op->op_private & OPpASSIGN_BACKWARDS) {
SV * const temp = left;
if (PL_op->op_private & OPpASSIGN_CV_TO_GV) {
SV * const cv = SvRV(left);
const U32 cv_type = SvTYPE(cv);
- const U32 gv_type = SvTYPE(right);
+ const bool is_gv = isGV_with_GP(right);
const bool got_coderef = cv_type == SVt_PVCV || cv_type == SVt_PVFM;
if (!got_coderef) {
/* Can do the optimisation if right (LVALUE) is not a typeglob,
left (RVALUE) is a reference to something, and we're in void
context. */
- if (!got_coderef && gv_type != SVt_PVGV && GIMME_V == G_VOID) {
+ if (!got_coderef && !is_gv && GIMME_V == G_VOID) {
/* Is the target symbol table currently empty? */
GV * const gv = gv_fetchsv(right, GV_NOINIT, SVt_PVGV);
if (SvTYPE(gv) != SVt_PVGV && !SvOK(gv)) {
}
/* Need to fix things up. */
- if (gv_type != SVt_PVGV) {
+ if (!is_gv) {
/* Need to fix GV. */
right = MUTABLE_SV(gv_fetchsv(right, GV_ADD, SVt_PVGV));
}
}
}
- /* Allow glob assignments like *$x = ..., which, when the glob has a
- SVf_FAKE flag, cannot be distinguished from $x = ... without looking
- at the op tree. */
- if( SvTYPE(right) == SVt_PVGV && cBINOP->op_last->op_type == OP_RV2GV
- && (wasfake = SvFLAGS(right) & SVf_FAKE) )
- SvFLAGS(right) &= ~SVf_FAKE;
SvSetMagicSV(right, left);
- if(wasfake) SvFLAGS(right) |= SVf_FAKE;
SETs(right);
RETURN;
}
PP(pp_unstack)
{
dVAR;
- I32 oldsave;
PERL_ASYNC_CHECK();
TAINT_NOT; /* Each statement is presumed innocent */
PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
FREETMPS;
- oldsave = PL_scopestack[PL_scopestack_ix - 1];
- LEAVE_SCOPE(oldsave);
+ if (!(PL_op->op_flags & OPf_SPECIAL)) {
+ I32 oldsave = PL_scopestack[PL_scopestack_ix - 1];
+ LEAVE_SCOPE(oldsave);
+ }
return NORMAL;
}
rbyte = !DO_UTF8(right);
}
if (lbyte != rbyte) {
+ /* sv_utf8_upgrade_nomg() may reallocate the stack */
+ PUTBACK;
if (lbyte)
sv_utf8_upgrade_nomg(TARG);
else {
sv_utf8_upgrade_nomg(right);
rpv = SvPV_nomg_const(right, rlen);
}
+ SPAGAIN;
}
sv_catpvn_nomg(TARG, rpv, rlen);
PP(pp_readline)
{
dVAR;
+ dSP; SvGETMAGIC(TOPs);
tryAMAGICunTARGET(iter, 0);
PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--);
if (!isGV_with_GP(PL_last_in_gv)) {
RETURN;
}
if (!(io = GvIO(gv))) {
- if ((GvEGVx(gv)) && (io = GvIO(GvEGV(gv)))
+ if ( gv && GvEGVx(gv) && (io = GvIO(GvEGV(gv)))
&& (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
goto had_magic;
if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
if (!(PL_op->op_private & OPpDEREFed))
SvGETMAGIC(sv);
if (SvROK(sv)) {
- tryAMAGICunDEREF_var(is_pp_rv2av ? to_av_amg : to_hv_amg);
+ sv = amagic_deref_call(sv, is_pp_rv2av ? to_av_amg : to_hv_amg);
+ SPAGAIN;
sv = SvRV(sv);
if (SvTYPE(sv) != type)
break;
case SVt_PVHV: { /* normal hash */
SV *tmpstr;
+ SV** topelem = relem;
hash = MUTABLE_HV(sv);
magic = SvMAGICAL(hash) != 0;
tmpstr = newSV(0);
if (*relem)
sv_setsv(tmpstr,*relem); /* value */
- *(relem++) = tmpstr;
- if (gimme != G_VOID && hv_exists_ent(hash, sv, 0))
- /* key overwrites an existing entry */
- duplicates += 2;
+ relem++;
+ if (gimme != G_VOID) {
+ if (hv_exists_ent(hash, sv, 0))
+ /* key overwrites an existing entry */
+ duplicates += 2;
+ else
+ if (gimme == G_ARRAY) {
+ /* copy element back: possibly to an earlier
+ * stack location if we encountered dups earlier */
+ *topelem++ = sv;
+ *topelem++ = tmpstr;
+ }
+ }
didstore = hv_store_ent(hash,sv,tmpstr,0);
if (magic) {
if (SvSMAGICAL(tmpstr))
SP = lastrelem;
else if (hash) {
if (duplicates) {
- /* Removes from the stack the entries which ended up as
- * duplicated keys in the hash (fix for [perl #24380]) */
- Move(firsthashrelem + duplicates,
- firsthashrelem, duplicates, SV**);
+ /* at this point we have removed the duplicate key/value
+ * pairs from the stack, but the remaining values may be
+ * wrong; i.e. with (a 1 a 2 b 3) on the stack we've removed
+ * the (a 2), but the stack now probably contains
+ * (a <freed> b 3), because { hv_save(a,1); hv_save(a,2) }
+ * obliterates the earlier key. So refresh all values. */
lastrelem -= duplicates;
+ relem = firsthashrelem;
+ while (relem < lastrelem) {
+ HE *he;
+ sv = *relem++;
+ he = hv_fetch_ent(hash, sv, 0, 0);
+ *relem++ = (he ? HeVAL(he) : &PL_sv_undef);
+ }
}
SP = lastrelem;
}
/g matches against large strings. So far a solution to this problem
appears to be quite tricky.
Test for the unsafe vars are TODO for now. */
- if (( !global && RX_NPARENS(rx))
- || SvTEMP(TARG) || PL_sawampersand ||
- (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY)))
+ if ( (!global && RX_NPARENS(rx))
+ || SvTEMP(TARG) || SvAMAGIC(TARG) || PL_sawampersand
+ || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY)))
r_flags |= REXEC_COPY_STR;
if (SvSCREAM(TARG))
r_flags |= REXEC_SCREAM;
/* In non-destructive replacement mode, duplicate target scalar so it
* remains unchanged. */
if (rpm->op_pmflags & PMf_NONDESTRUCT)
- TARG = newSVsv(TARG);
+ TARG = sv_2mortal(newSVsv(TARG));
#ifdef PERL_OLD_COPY_ON_WRITE
/* Awooga. Awooga. "bool" types that are actually char are dangerous,
if (SvTRUEx(POPs))
PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
++*PL_markstack_ptr;
+ FREETMPS;
LEAVE_with_name("grep_item"); /* exit inner scope */
/* All done yet? */
if (gimme == G_SCALAR)
goto temporise;
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;
EXTEND_MORTAL(SP - newsp);
MARK = newsp + 1;
EXTEND_MORTAL(1);
if (MARK == SP) {
- /* Temporaries are bad unless they happen to be elements
- * of a tied hash or array */
- if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY) &&
- !(SvRMAGICAL(TOPs) && mg_find(TOPs, PERL_MAGIC_tiedelem))) {
+ /* 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) ||
+ (SvFLAGS(TOPs) & (SVf_READONLY | SVf_FAKE))
+ == SVf_READONLY
+ ) &&
+ !SvSMAGICAL(TOPs)) {
LEAVE;
cxstack_ix--;
POPSUB(cx,sv);
case SVt_PVGV:
if (!isGV_with_GP(sv))
DIE(aTHX_ "Not a CODE reference");
+ we_have_a_glob:
if (!(cv = GvCVu((const GV *)sv))) {
HV *stash;
cv = sv_2cv(sv, &stash, &gv, 0);
goto try_autoload;
}
break;
+ case SVt_PVLV:
+ if(isGV_with_GP(sv)) goto we_have_a_glob;
+ /*FALLTHROUGH*/
default:
if (sv == &PL_sv_yes) { /* unfound import, ignore */
if (hasargs)
SP = PL_stack_base + POPMARK;
+ else
+ (void)POPMARK;
RETURN;
}
SvGETMAGIC(sv);
if (SvROK(sv)) {
- SV * const * sp = &sv; /* Used in tryAMAGICunDEREF macro. */
- tryAMAGICunDEREF(to_cv);
+ sv = amagic_deref_call(sv, to_cv_amg);
+ /* Don't SPAGAIN here. */
}
else {
const char *sym;
SAVETMPS;
retry:
+ if (CvCLONE(cv) && ! CvCLONED(cv))
+ DIE(aTHX_ "Closure prototype called");
if (!CvROOT(cv) && !CvXSUB(cv)) {
GV* autogv;
SV* sub_name;
/* CvXSUB(cv) must not be NULL because newXS() refuses NULL xsub address */
assert(CvXSUB(cv));
- CALL_FPTR(CvXSUB(cv))(aTHX_ cv);
+ CvXSUB(cv)(aTHX_ cv);
/* Enforce some sanity in scalar context. */
if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
https://perl5.git.perl.org / perl5.git / blobdiff