{
djSP;
if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
- Perl_croak(aTHX_ PL_no_modify);
+ DIE(aTHX_ PL_no_modify);
if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
SvIVX(TOPs) != IV_MAX)
{
dTARGET;
if (SvTYPE(hv) == SVt_PVAV)
hv = avhv_keys((AV*)hv);
-#ifdef IV_IS_QUAD
if (HvFILL(hv))
- Perl_sv_setpvf(aTHX_ TARG, "%" PERL_PRId64 "/%" PERL_PRId64,
- (Quad_t)HvFILL(hv), (Quad_t)HvMAX(hv) + 1);
-#else
- if (HvFILL(hv))
- Perl_sv_setpvf(aTHX_ TARG, "%ld/%ld",
- (long)HvFILL(hv), (long)HvMAX(hv) + 1);
-#endif
+ Perl_sv_setpvf(aTHX_ TARG, "%"IVdf"/%"IVdf,
+ (IV)HvFILL(hv), (IV)HvMAX(hv) + 1);
else
sv_setiv(TARG, 0);
if (SvREADONLY(TARG)
|| (SvTYPE(TARG) > SVt_PVLV
&& !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG))))
- Perl_croak(aTHX_ PL_no_modify);
+ DIE(aTHX_ PL_no_modify);
PUTBACK;
s = SvPV(TARG, len);
PMOP *newpm;
I32 gimme;
register PERL_CONTEXT *cx;
- struct block_sub cxsub;
+ SV *sv;
POPBLOCK(cx,newpm);
- POPSUB1(cx); /* Delay POPSUB2 until stack values are safe */
TAINT_NOT;
if (gimme == G_SCALAR) {
MARK = newsp + 1;
if (MARK <= SP) {
- if (cxsub.cv && CvDEPTH(cxsub.cv) > 1) {
+ if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
if (SvTEMP(TOPs)) {
*MARK = SvREFCNT_inc(TOPs);
FREETMPS;
}
PUTBACK;
- POPSUB2(); /* Stack values are safe: release CV and @_ ... */
+ POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
PL_curpm = newpm; /* ... and pop $1 et al */
LEAVE;
+ LEAVESUB(sv);
return pop_return();
}
PMOP *newpm;
I32 gimme;
register PERL_CONTEXT *cx;
- struct block_sub cxsub;
+ SV *sv;
POPBLOCK(cx,newpm);
- POPSUB1(cx); /* Delay POPSUB2 until stack values are safe */
TAINT_NOT;
if (gimme == G_SCALAR)
goto temporise;
if (gimme == G_ARRAY) {
- if (!CvLVALUE(cxsub.cv))
+ if (!CvLVALUE(cx->blk_sub.cv))
goto temporise_array;
EXTEND_MORTAL(SP - newsp);
for (mark = newsp + 1; mark <= SP; mark++) {
else {
/* Can be a localized value subject to deletion. */
PL_tmps_stack[++PL_tmps_ix] = *mark;
- SvREFCNT_inc(*mark);
+ (void)SvREFCNT_inc(*mark);
}
}
}
/* 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(cxsub.cv))
- Perl_croak(aTHX_ "Can't modify non-lvalue subroutine call");
+ if (!CvLVALUE(cx->blk_sub.cv)) {
+ POPSUB(cx,sv);
+ PL_curpm = newpm;
+ LEAVE;
+ LEAVESUB(sv);
+ DIE(aTHX_ "Can't modify non-lvalue subroutine call");
+ }
if (gimme == G_SCALAR) {
MARK = newsp + 1;
EXTEND_MORTAL(1);
if (MARK == SP) {
- if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY))
- Perl_croak(aTHX_ "Can't return a %s from lvalue subroutine",
+ if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
+ POPSUB(cx,sv);
+ PL_curpm = newpm;
+ LEAVE;
+ LEAVESUB(sv);
+ DIE(aTHX_ "Can't return a %s from lvalue subroutine",
SvREADONLY(TOPs) ? "readonly value" : "temporary");
+ }
else { /* Can be a localized value
* subject to deletion. */
PL_tmps_stack[++PL_tmps_ix] = *mark;
- SvREFCNT_inc(*mark);
+ (void)SvREFCNT_inc(*mark);
}
}
- else /* Should not happen? */
- Perl_croak(aTHX_ "%s returned from lvalue subroutine in scalar context",
+ else { /* Should not happen? */
+ POPSUB(cx,sv);
+ PL_curpm = newpm;
+ LEAVE;
+ LEAVESUB(sv);
+ DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
(MARK > SP ? "Empty array" : "Array"));
+ }
SP = MARK;
}
else if (gimme == G_ARRAY) {
EXTEND_MORTAL(SP - newsp);
for (mark = newsp + 1; mark <= SP; mark++) {
- if (SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY))
- /* Might be flattened array after $#array = */
- Perl_croak(aTHX_ "Can't return %s from lvalue subroutine",
+ if (SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
+ /* Might be flattened array after $#array = */
+ PUTBACK;
+ POPSUB(cx,sv);
+ PL_curpm = newpm;
+ LEAVE;
+ LEAVESUB(sv);
+ DIE(aTHX_ "Can't return %s from lvalue subroutine",
(*mark != &PL_sv_undef)
? (SvREADONLY(TOPs)
? "a readonly value" : "a temporary")
: "an uninitialized value");
+ }
else {
mortalize:
/* Can be a localized value subject to deletion. */
PL_tmps_stack[++PL_tmps_ix] = *mark;
- SvREFCNT_inc(*mark);
+ (void)SvREFCNT_inc(*mark);
}
}
}
temporise:
MARK = newsp + 1;
if (MARK <= SP) {
- if (cxsub.cv && CvDEPTH(cxsub.cv) > 1) {
+ if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
if (SvTEMP(TOPs)) {
*MARK = SvREFCNT_inc(TOPs);
FREETMPS;
}
PUTBACK;
- POPSUB2(); /* Stack values are safe: release CV and @_ ... */
+ POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
PL_curpm = newpm; /* ... and pop $1 et al */
LEAVE;
+ LEAVESUB(sv);
return pop_return();
}
|| !(sv = AvARRAY(av)[0]))
{
MUTEX_UNLOCK(CvMUTEXP(cv));
- Perl_croak(aTHX_ "no argument for locked method call");
+ DIE(aTHX_ "no argument for locked method call");
}
}
if (SvROK(sv))
while (MgOWNER(mg))
COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
MgOWNER(mg) = thr;
- DEBUG_S(PerlIO_printf(PerlIO_stderr(), "%p: pp_entersub lock %p\n",
+ DEBUG_S(PerlIO_printf(Perl_debug_log, "%p: pp_entersub lock %p\n",
thr, sv);)
MUTEX_UNLOCK(MgMUTEXP(mg));
- SAVEDESTRUCTOR(Perl_unlock_condpair, sv);
+ SAVEDESTRUCTOR_X(Perl_unlock_condpair, sv);
}
MUTEX_LOCK(CvMUTEXP(cv));
}
/* We already have a clone to use */
MUTEX_UNLOCK(CvMUTEXP(cv));
cv = *(CV**)svp;
- DEBUG_S(PerlIO_printf(PerlIO_stderr(),
+ DEBUG_S(PerlIO_printf(Perl_debug_log,
"entersub: %p already has clone %p:%s\n",
thr, cv, SvPEEK((SV*)cv)));
CvOWNER(cv) = thr;
SvREFCNT_inc(cv);
if (CvDEPTH(cv) == 0)
- SAVEDESTRUCTOR(unset_cvowner, (void*) cv);
+ SAVEDESTRUCTOR_X(unset_cvowner, (void*) cv);
}
else {
/* (2) => grab ownership of cv. (3) => make clone */
CvOWNER(cv) = thr;
SvREFCNT_inc(cv);
MUTEX_UNLOCK(CvMUTEXP(cv));
- DEBUG_S(PerlIO_printf(PerlIO_stderr(),
+ DEBUG_S(PerlIO_printf(Perl_debug_log,
"entersub: %p grabbing %p:%s in stash %s\n",
thr, cv, SvPEEK((SV*)cv), CvSTASH(cv) ?
HvNAME(CvSTASH(cv)) : "(none)"));
CV *clonecv;
SvREFCNT_inc(cv); /* don't let it vanish from under us */
MUTEX_UNLOCK(CvMUTEXP(cv));
- DEBUG_S((PerlIO_printf(PerlIO_stderr(),
+ DEBUG_S((PerlIO_printf(Perl_debug_log,
"entersub: %p cloning %p:%s\n",
thr, cv, SvPEEK((SV*)cv))));
/*
SvREFCNT_inc(cv);
}
DEBUG_S(if (CvDEPTH(cv) != 0)
- PerlIO_printf(PerlIO_stderr(), "depth %ld != 0\n",
+ PerlIO_printf(Perl_debug_log, "depth %ld != 0\n",
CvDEPTH(cv)););
- SAVEDESTRUCTOR(unset_cvowner, (void*) cv);
+ SAVEDESTRUCTOR_X(unset_cvowner, (void*) cv);
}
}
#endif /* USE_THREADS */
SV** ary;
#if 0
- DEBUG_S(PerlIO_printf(PerlIO_stderr(),
+ DEBUG_S(PerlIO_printf(Perl_debug_log,
"%p entersub preparing @_\n", thr));
#endif
av = (AV*)PL_curpad[0];
- if (AvREAL(av)) {
- av_clear(av);
- AvREAL_off(av);
- AvREIFY_on(av);
- }
+ assert(!AvREAL(av));
#ifndef USE_THREADS
cx->blk_sub.savearray = GvAV(PL_defgv);
GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
&& !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
sub_crush_depth(cv);
#if 0
- DEBUG_S(PerlIO_printf(PerlIO_stderr(),
+ DEBUG_S(PerlIO_printf(Perl_debug_log,
"%p entersub returning %p\n", thr, CvSTART(cv)));
#endif
RETURNOP(CvSTART(cv));
dTHR;
#endif /* DEBUGGING */
- DEBUG_S((PerlIO_printf(PerlIO_stderr(), "%p unsetting CvOWNER of %p:%s\n",
+ DEBUG_S((PerlIO_printf(Perl_debug_log, "%p unsetting CvOWNER of %p:%s\n",
thr, cv, SvPEEK((SV*)cv))));
MUTEX_LOCK(CvMUTEXP(cv));
DEBUG_S(if (CvDEPTH(cv) != 0)
- PerlIO_printf(PerlIO_stderr(), "depth %ld != 0\n",
+ PerlIO_printf(Perl_debug_log, "depth %ld != 0\n",
CvDEPTH(cv)););
assert(thr == CvOWNER(cv));
CvOWNER(cv) = 0;