S_no_bareword_allowed(pTHX_ OP *o)
{
qerror(Perl_mess(aTHX_
- "Bareword \"%s\" not allowed while \"strict subs\" in use",
- SvPV_nolen(cSVOPo_sv)));
+ "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
+ cSVOPo_sv));
}
/* "register" allocation */
Perl_block_start(pTHX_ int full)
{
int retval = PL_savestack_ix;
+ /* If there were syntax errors, don't try to start a block */
+ if (PL_yynerrs) return retval;
pad_block_start(full);
SAVEHINTS();
{
int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
line_t copline = PL_copline;
- /* there should be a nextstate in every block */
- OP* retval = seq ? scalarseq(seq) : newSTATEOP(0, Nullch, seq);
- PL_copline = copline; /* XXX newSTATEOP may reset PL_copline */
+ OP* retval = scalarseq(seq);
+ /* If there were syntax errors, don't try to close a block */
+ if (PL_yynerrs) return retval;
+ if (!seq) {
+ /* scalarseq() gave us an OP_STUB */
+ retval->op_flags |= OPf_PARENS;
+ /* there should be a nextstate in every block */
+ retval = newSTATEOP(0, Nullch, retval);
+ PL_copline = copline; /* XXX newSTATEOP may reset PL_copline */
+ }
LEAVE_SCOPE(floor);
PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
if (needblockscope)
curop->op_type == OP_PADANY)
{
if (PAD_COMPNAME_GEN(curop->op_targ)
- == PL_generation)
+ == (STRLEN)PL_generation)
break;
PAD_COMPNAME_GEN(curop->op_targ)
= PL_generation;
return o;
}
+/*
+=for apidoc cv_undef
+
+Clear out all the active components of a CV. This can happen either
+by an explicit C<undef &foo>, or by the reference count going to zero.
+In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
+children can still follow the full lexical scope chain.
+
+=cut
+*/
+
void
Perl_cv_undef(pTHX_ CV *cv)
{
- CV *outsidecv;
- CV *freecv = Nullcv;
-
#ifdef USE_ITHREADS
if (CvFILE(cv) && !CvXSUB(cv)) {
/* for XSUBs CvFILE point directly to static memory; __FILE__ */
Perl_croak(aTHX_ "Can't undef active subroutine");
ENTER;
- PAD_SAVE_SETNULLPAD;
+ PAD_SAVE_SETNULLPAD();
op_free(CvROOT(cv));
CvROOT(cv) = Nullop;
}
SvPOK_off((SV*)cv); /* forget prototype */
CvGV(cv) = Nullgv;
- outsidecv = CvOUTSIDE(cv);
- /* Since closure prototypes have the same lifetime as the containing
- * CV, they don't hold a refcount on the outside CV. This avoids
- * the refcount loop between the outer CV (which keeps a refcount to
- * the closure prototype in the pad entry for pp_anoncode()) and the
- * closure prototype, and the ensuing memory leak. --GSAR */
- if (!CvANON(cv) || CvCLONED(cv))
- freecv = outsidecv;
- CvOUTSIDE(cv) = Nullcv;
+
+ pad_undef(cv);
+
+ /* remove CvOUTSIDE unless this is an undef rather than a free */
+ if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
+ if (!CvWEAKOUTSIDE(cv))
+ SvREFCNT_dec(CvOUTSIDE(cv));
+ CvOUTSIDE(cv) = Nullcv;
+ }
if (CvCONST(cv)) {
SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
CvCONST_off(cv);
}
- pad_undef(cv, outsidecv);
- if (freecv)
- SvREFCNT_dec(freecv);
if (CvXSUB(cv)) {
CvXSUB(cv) = 0;
}
- CvFLAGS(cv) = 0;
+ /* delete all flags except WEAKOUTSIDE */
+ CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
}
void
if (name)
Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
if (SvPOK(cv))
- Perl_sv_catpvf(aTHX_ msg, " (%s)", SvPVX(cv));
+ Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (SV *)cv);
sv_catpv(msg, " vs ");
if (p)
Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
SAVEFREESV(PL_compcv);
goto done;
}
+ /* transfer PL_compcv to cv */
cv_undef(cv);
CvFLAGS(cv) = CvFLAGS(PL_compcv);
CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
+ CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
CvOUTSIDE(PL_compcv) = 0;
CvPADLIST(cv) = CvPADLIST(PL_compcv);
CvPADLIST(PL_compcv) = 0;
else {
/* force display of errors found but not reported */
sv_catpv(ERRSV, not_safe);
- Perl_croak(aTHX_ "%s", SvPVx(ERRSV, n_a));
+ Perl_croak(aTHX_ "%"SVf, ERRSV);
}
}
}
CvCONST_on(cv);
}
- /* If a potential closure prototype, don't keep a refcount on outer CV.
- * This is okay as the lifetime of the prototype is tied to the
- * lifetime of the outer CV. Avoids memory leak due to reference
- * loop. --GSAR */
- if (!name)
- SvREFCNT_dec(CvOUTSIDE(cv));
-
if (name || aname) {
char *s;
char *tname = (name ? name : aname);
continue;
default:
oops:
- Perl_croak(aTHX_ "Malformed prototype for %s: %s",
- gv_ename(namegv), SvPV((SV*)cv, n_a));
+ Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
+ gv_ename(namegv), cv);
}
}
else
for (; o; o = o->op_next) {
if (o->op_seq)
break;
- if (!PL_op_seqmax)
- PL_op_seqmax++;
+ /* The special value -1 is used by the B::C compiler backend to indicate
+ * that an op is statically defined and should not be freed */
+ if (!PL_op_seqmax || PL_op_seqmax == (U16)-1)
+ PL_op_seqmax = 1;
PL_op = o;
switch (o->op_type) {
case OP_SETSTATE:
if (cSVOPo->op_private & OPpCONST_STRICT)
no_bareword_allowed(o);
#ifdef USE_ITHREADS
+ case OP_METHOD_NAMED:
/* Relocate sv to the pad for thread safety.
* Despite being a "constant", the SV is written to,
* for reference counts, sv_upgrade() etc. */
if (cSVOP->op_sv) {
PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
- if (SvPADTMP(cSVOPo->op_sv)) {
+ if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
/* If op_sv is already a PADTMP then it is being used by
* some pad, so make a copy. */
sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
SV *sv = sv_newmortal();
gv_efullname3(sv, gv, Nullch);
Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
- "%s() called too early to check prototype",
- SvPV_nolen(sv));
+ "%"SVf"() called too early to check prototype",
+ sv);
}
}
else if (o->op_next->op_type == OP_READLINE