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));
}
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;
}
rcopied = TRUE;
}
- if (TARG != left) {
+ if (TARG != left) { /* not $l .= $r */
STRLEN llen;
const char* const lpv = SvPV_nomg_const(left, llen);
lbyte = !DO_UTF8(left);
else
SvUTF8_off(TARG);
}
- else { /* TARG == left */
- STRLEN llen;
+ else { /* $l .= $r */
if (!SvOK(TARG)) {
- if (left == right && ckWARN(WARN_UNINITIALIZED))
+ if (left == right && ckWARN(WARN_UNINITIALIZED)) /* $l .= $l */
report_uninit(right);
sv_setpvs(left, "");
}
- (void)SvPV_nomg_const(left, llen); /* Needed to set UTF8 flag */
- lbyte = !DO_UTF8(left);
+ lbyte = (SvROK(left) && SvTYPE(SvRV(left)) == SVt_REGEXP)
+ ? !DO_UTF8(SvRV(left)) : !DO_UTF8(left);
if (IN_BYTES)
SvUTF8_off(TARG);
}
if (!rcopied) {
if (left == right)
- /* $a.$a: do magic twice: tied might return different 2nd time */
+ /* $r.$r: do magic twice: tied might return different 2nd time */
SvGETMAGIC(right);
rpv = SvPV_nomg_const(right, rlen);
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)) {
{
dVAR; dSP;
if (SvTYPE(TOPs) >= SVt_PVAV || isGV_with_GP(TOPs))
- DIE(aTHX_ "%s", PL_no_modify);
+ Perl_croak_no_modify(aTHX);
if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
&& SvIVX(TOPs) != IV_MAX)
{
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;
}
SvROK_on(rv);
if (pkg) {
- HV* const stash = gv_stashpv(SvPV_nolen(pkg), GV_ADD);
+ HV *const stash = gv_stashsv(pkg, GV_ADD);
SvREFCNT_dec(pkg);
(void)sv_bless(rv, stash);
}
/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;
}
SvUPGRADE(sv, SVt_PV);
tmplen = SvLEN(sv); /* remember if already alloced */
- if (!tmplen && !SvREADONLY(sv))
- Sv_Grow(sv, 80); /* try short-buffering it */
+ if (!tmplen && !SvREADONLY(sv)) {
+ /* try short-buffering it. Please update t/op/readline.t
+ * if you change the growth length.
+ */
+ Sv_Grow(sv, 80);
+ }
offset = 0;
if (type == OP_RCATLINE && SvOK(sv)) {
if (!SvPOK(sv)) {
/* 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,
|| ( ((SvTYPE(TARG) == SVt_PVGV && isGV_with_GP(TARG))
|| SvTYPE(TARG) > SVt_PVLV)
&& !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
- DIE(aTHX_ "%s", PL_no_modify);
+ Perl_croak_no_modify(aTHX);
PUTBACK;
setup_match:
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 (!SvROK(sv)) {
+ 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 = amagic_deref_call(sv, to_cv_amg);
+ /* Don't SPAGAIN here. */
+ }
+ else {
const char *sym;
STRLEN len;
- if (sv == &PL_sv_yes) { /* unfound import, ignore */
- if (hasargs)
- SP = PL_stack_base + POPMARK;
- RETURN;
- }
- if (SvGMAGICAL(sv)) {
- mg_get(sv);
- if (SvROK(sv))
- goto got_rv;
- if (SvPOKp(sv)) {
- sym = SvPVX_const(sv);
- len = SvCUR(sv);
- } else {
- sym = NULL;
- len = 0;
- }
- }
- else {
- sym = SvPV_const(sv, len);
- }
+ sym = SvPV_nomg_const(sv, len);
if (!sym)
DIE(aTHX_ PL_no_usym, "a subroutine");
if (PL_op->op_private & HINT_STRICT_REFS)
cv = get_cvn_flags(sym, len, GV_ADD|SvUTF8(sv));
break;
}
- got_rv:
- {
- SV * const * sp = &sv; /* Used in tryAMAGICunDEREF macro. */
- tryAMAGICunDEREF(to_cv);
- }
cv = MUTABLE_CV(SvRV(sv));
if (SvTYPE(cv) == SVt_PVCV)
break;
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 ) {
SvGETMAGIC(sv);
if (!SvOK(sv)) {
if (SvREADONLY(sv))
- Perl_croak(aTHX_ "%s", PL_no_modify);
+ Perl_croak_no_modify(aTHX);
prepare_SV_for_RV(sv);
switch (to_what) {
case OPpDEREF_SV:
https://perl5.git.perl.org / perl5.git / blobdiff