/* op.c
*
- * Copyright (c) 1991-2002, Larry Wall
+ * Copyright (c) 1991-2003, Larry Wall
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
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 */
return off;
}
-
-#ifdef USE_5005THREADS
-/* find_threadsv is not reentrant */
-PADOFFSET
-Perl_find_threadsv(pTHX_ const char *name)
-{
- char *p;
- PADOFFSET key;
- SV **svp;
- /* We currently only handle names of a single character */
- p = strchr(PL_threadsv_names, *name);
- if (!p)
- return NOT_IN_PAD;
- key = p - PL_threadsv_names;
- MUTEX_LOCK(&thr->mutex);
- svp = av_fetch(thr->threadsv, key, FALSE);
- if (svp)
- MUTEX_UNLOCK(&thr->mutex);
- else {
- SV *sv = NEWSV(0, 0);
- av_store(thr->threadsv, key, sv);
- thr->threadsvp = AvARRAY(thr->threadsv);
- MUTEX_UNLOCK(&thr->mutex);
- /*
- * Some magic variables used to be automagically initialised
- * in gv_fetchpv. Those which are now per-thread magicals get
- * initialised here instead.
- */
- switch (*name) {
- case '_':
- break;
- case ';':
- sv_setpv(sv, "\034");
- sv_magic(sv, 0, PERL_MAGIC_sv, name, 1);
- break;
- case '&':
- case '`':
- case '\'':
- PL_sawampersand = TRUE;
- /* FALL THROUGH */
- case '1':
- case '2':
- case '3':
- case '4':
- case '5':
- case '6':
- case '7':
- case '8':
- case '9':
- SvREADONLY_on(sv);
- /* FALL THROUGH */
-
- /* XXX %! tied to Errno.pm needs to be added here.
- * See gv_fetchpv(). */
- /* case '!': */
-
- default:
- sv_magic(sv, 0, PERL_MAGIC_sv, name, 1);
- }
- DEBUG_S(PerlIO_printf(Perl_error_log,
- "find_threadsv: new SV %p for $%s%c\n",
- sv, (*name < 32) ? "^" : "",
- (*name < 32) ? toCTRL(*name) : *name));
- }
- return key;
-}
-#endif /* USE_5005THREADS */
-
/* Destructor */
void
switch (o->op_type) {
case OP_NULL: /* Was holding old type, if any. */
case OP_ENTEREVAL: /* Was holding hints. */
-#ifdef USE_5005THREADS
- case OP_THREADSV: /* Was holding index into thr->threadsv AV. */
-#endif
o->op_targ = 0;
break;
-#ifdef USE_5005THREADS
- case OP_ENTERITER:
- if (!(o->op_flags & OPf_SPECIAL))
- break;
- /* FALL THROUGH */
-#endif /* USE_5005THREADS */
default:
if (!(o->op_flags & OPf_REF)
|| (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
case OP_CONST:
SvREFCNT_dec(cSVOPo->op_sv);
cSVOPo->op_sv = Nullsv;
+#ifdef USE_ITHREADS
+ /** Bug #15654
+ Even if op_clear does a pad_free for the target of the op,
+ pad_free doesn't actually remove the sv that exists in the bad
+ instead it lives on. This results in that it could be reused as
+ a target later on when the pad was reallocated.
+ **/
+ if(o->op_targ) {
+ pad_swipe(o->op_targ,1);
+ o->op_targ = 0;
+ }
+#endif
break;
case OP_GOTO:
case OP_NEXT:
case OP_GGRNAM:
case OP_GGRGID:
case OP_GETLOGIN:
+ case OP_PROTOTYPE:
func_ops:
if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
useless = OP_DESC(o);
case OP_RV2AV:
case OP_RV2HV:
- if (!type && cUNOPo->op_first->op_type != OP_GV)
- Perl_croak(aTHX_ "Can't localize through a reference");
if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
PL_modcount = RETURN_UNLIMITED_NUMBER;
return o; /* Treat \(@foo) like ordinary list. */
PL_modcount = RETURN_UNLIMITED_NUMBER;
break;
case OP_RV2SV:
- if (!type && cUNOPo->op_first->op_type != OP_GV)
- Perl_croak(aTHX_ "Can't localize through a reference");
ref(cUNOPo->op_first, o->op_type);
/* FALL THROUGH */
case OP_GV:
}
break;
-#ifdef USE_5005THREADS
- case OP_THREADSV:
- PL_modcount++; /* XXX ??? */
- break;
-#endif /* USE_5005THREADS */
-
case OP_PUSHMARK:
break;
o->op_type = OP_LEAVE;
o->op_ppaddr = PL_ppaddr[OP_LEAVE];
}
- else {
- if (o->op_type == OP_LINESEQ) {
- OP *kid;
- o->op_type = OP_SCOPE;
- o->op_ppaddr = PL_ppaddr[OP_SCOPE];
- kid = ((LISTOP*)o)->op_first;
- if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
- op_null(kid);
- }
- else
- o = newLISTOP(OP_SCOPE, 0, o, Nullop);
+ else if (o->op_type == OP_LINESEQ) {
+ OP *kid;
+ o->op_type = OP_SCOPE;
+ o->op_ppaddr = PL_ppaddr[OP_SCOPE];
+ kid = ((LISTOP*)o)->op_first;
+ if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
+ op_null(kid);
}
+ else
+ o = newLISTOP(OP_SCOPE, 0, o, Nullop);
}
return o;
}
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();
Perl_block_end(pTHX_ I32 floor, OP *seq)
{
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;
LEAVE_SCOPE(floor);
PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
if (needblockscope)
STATIC OP *
S_newDEFSVOP(pTHX)
{
-#ifdef USE_5005THREADS
- OP *o = newOP(OP_THREADSV, 0);
- o->op_targ = find_threadsv("_");
- return o;
-#else
return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
-#endif /* USE_5005THREADS */
}
void
{
if (o->op_type == OP_LIST) {
OP *o2;
-#ifdef USE_5005THREADS
- o2 = newOP(OP_THREADSV, 0);
- o2->op_targ = find_threadsv(";");
-#else
o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
-#endif /* USE_5005THREADS */
o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
}
return o;
op_free(o);
if (type == OP_RV2GV)
return newGVOP(OP_GV, 0, (GV*)sv);
- else {
- /* try to smush double to int, but don't smush -2.0 to -2 */
- if ((SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK)) == SVf_NOK &&
- type != OP_NEGATE)
- {
-#ifdef PERL_PRESERVE_IVUV
- /* Only bother to attempt to fold to IV if
- most operators will benefit */
- SvIV_please(sv);
-#endif
- }
- return newSVOP(OP_CONST, 0, sv);
- }
+ return newSVOP(OP_CONST, 0, sv);
nope:
return o;
if (CopLINE(PL_curcop) < PL_multi_end)
CopLINE_set(PL_curcop, (line_t)PL_multi_end);
}
-#ifdef USE_5005THREADS
- else if (repl->op_type == OP_THREADSV
- && strchr("&`'123456789+",
- PL_threadsv_names[repl->op_targ]))
- {
- curop = 0;
- }
-#endif /* USE_5005THREADS */
else if (repl->op_type == OP_CONST)
curop = repl;
else {
OP *lastop = 0;
for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
-#ifdef USE_5005THREADS
- if (curop->op_type == OP_THREADSV) {
- repl_has_vars = 1;
- if (strchr("&`'123456789+", curop->op_private))
- break;
- }
-#else
if (curop->op_type == OP_GV) {
GV *gv = cGVOPx_gv(curop);
repl_has_vars = 1;
- if (strchr("&`'123456789+", *GvENAME(gv)))
+ if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
break;
}
-#endif /* USE_5005THREADS */
else if (curop->op_type == OP_RV2CV)
break;
else if (curop->op_type == OP_RV2SV ||
}
{
line_t ocopline = PL_copline;
+ COP *ocurcop = PL_curcop;
int oexpect = PL_expect;
utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
veop, modname, imop);
PL_expect = oexpect;
PL_copline = ocopline;
+ PL_curcop = ocurcop;
}
}
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;
Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
}
else {
-#ifdef USE_5005THREADS
- padoff = find_threadsv("_");
- iterflags |= OPf_SPECIAL;
-#else
sv = newGVOP(OP_GV, 0, PL_defgv);
-#endif
}
if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
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_5005THREADS
- if (CvMUTEXP(cv)) {
- MUTEX_DESTROY(CvMUTEXP(cv));
- Safefree(CvMUTEXP(cv));
- CvMUTEXP(cv) = 0;
- }
-#endif /* USE_5005THREADS */
-
#ifdef USE_ITHREADS
if (CvFILE(cv) && !CvXSUB(cv)) {
/* for XSUBs CvFILE point directly to static memory; __FILE__ */
#endif
if (!CvXSUB(cv) && CvROOT(cv)) {
-#ifdef USE_5005THREADS
- if (CvDEPTH(cv) || (CvOWNER(cv) && CvOWNER(cv) != thr))
- Perl_croak(aTHX_ "Can't undef active subroutine");
-#else
if (CvDEPTH(cv))
Perl_croak(aTHX_ "Can't undef active subroutine");
-#endif /* USE_5005THREADS */
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;
CvGV(cv) = gv;
CvFILE_set_from_cop(cv, PL_curcop);
CvSTASH(cv) = PL_curstash;
-#ifdef USE_5005THREADS
- CvOWNER(cv) = 0;
- if (!CvMUTEXP(cv)) {
- New(666, CvMUTEXP(cv), 1, perl_mutex);
- MUTEX_INIT(CvMUTEXP(cv));
- }
-#endif /* USE_5005THREADS */
if (ps)
sv_setpv((SV*)cv, ps);
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);
}
}
CvGV(cv) = gv;
-#ifdef USE_5005THREADS
- New(666, CvMUTEXP(cv), 1, perl_mutex);
- MUTEX_INIT(CvMUTEXP(cv));
- CvOWNER(cv) = 0;
-#endif /* USE_5005THREADS */
(void)gv_fetchfile(filename);
CvFILE(cv) = filename; /* NOTE: not copied, as it is expected to be
an external constant string */
if (o->op_flags & OPf_KIDS) {
if (cLISTOPo->op_first->op_type == OP_STUB) {
op_free(o);
- o = newUNOP(type, OPf_SPECIAL,
- newGVOP(OP_GV, 0, gv_fetchpv("main::ARGV", TRUE, SVt_PVAV)));
+ o = newUNOP(type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
}
return ck_fun(o);
}
else {
op_free(o);
if (type == OP_FTTTY)
- o = newGVOP(type, OPf_REF, gv_fetchpv("main::STDIN", TRUE,
- SVt_PVIO));
+ o = newGVOP(type, OPf_REF, PL_stdingv);
else
o = newUNOP(type, 0, newDEFSVOP());
}
OP *argop;
op_free(o);
-#ifdef USE_5005THREADS
- if (!CvUNIQUE(PL_compcv)) {
- argop = newOP(OP_PADAV, OPf_REF);
- argop->op_targ = 0; /* PAD_SV(0) is @_ */
- }
- else {
- argop = newUNOP(OP_RV2AV, 0,
- scalar(newGVOP(OP_GV, 0,
- gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
- }
-#else
argop = newUNOP(OP_RV2AV, 0,
- scalar(newGVOP(OP_GV, 0, !CvUNIQUE(PL_compcv) ?
- PL_defgv : gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
-#endif /* USE_5005THREADS */
+ scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
return newUNOP(type, 0, scalar(argop));
}
return scalar(modkids(ck_fun(o), type));
I32 contextclass = 0;
char *e = 0;
STRLEN n_a;
+ bool delete=0;
o->op_private |= OPpENTERSUB_HASTARG;
for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
cv = GvCVu(gv);
if (!cv)
tmpop->op_private |= OPpEARLY_CV;
- else if (SvPOK(cv)) {
- namegv = CvANON(cv) ? gv : CvGV(cv);
- proto = SvPV((SV*)cv, n_a);
+ else {
+ if (SvPOK(cv)) {
+ namegv = CvANON(cv) ? gv : CvGV(cv);
+ proto = SvPV((SV*)cv, n_a);
+ }
+ if (CvASSERTION(cv)) {
+ if (PL_hints & HINT_ASSERTING) {
+ if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
+ o->op_private |= OPpENTERSUB_DB;
+ }
+ else {
+ delete=1;
+ if (ckWARN(WARN_ASSERTIONS) && !(PL_hints & HINT_ASSERTIONSSEEN)) {
+ Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
+ "Impossible to activate assertion call");
+ }
+ }
+ }
}
}
}
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
if (proto && !optional &&
(*proto && *proto != '@' && *proto != '%' && *proto != ';'))
return too_few_arguments(o, gv_ename(namegv));
+ if(delete) {
+ op_free(o);
+ o=newSVOP(OP_CONST, 0, newSViv(0));
+ }
return o;
}
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