/* op.c
*
- * Copyright (c) 1991-2002, Larry Wall
+ * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
+ * 2000, 2001, 2002, 2003, by Larry Wall and others
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
#define CHECKOP(type,o) \
((PL_op_mask && PL_op_mask[type]) \
? ( op_free((OP*)o), \
- Perl_croak(aTHX_ "%s trapped by operation mask", PL_op_desc[type]), \
+ Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \
Nullop ) \
: CALL_FPTR(PL_check[type])(aTHX_ (OP*)o))
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;
int maybe_scalar = 0;
/* [perl #17376]: this appears to be premature, and results in code such as
- C< my(%x); > executing in list mode rather than void mode */
+ C< our(%x); > executing in list mode rather than void mode */
#if 0
if (o->op_flags & OPf_PARENS)
list(o);
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
CALL_PEEP(PL_eval_start);
}
else {
- if (!o)
+ if (o->op_type == OP_STUB)
return;
PL_main_root = scope(sawparens(scalarvoid(o)));
PL_curcop = &PL_compiling;
{
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 ||
}
void
-Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg)
+Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
{
OP *pack;
OP *imop;
OP *veop;
- if (id->op_type != OP_CONST)
+ if (idop->op_type != OP_CONST)
Perl_croak(aTHX_ "Module name must be constant");
veop = Nullop;
if (version->op_type != OP_CONST || !SvNIOKp(vesv))
Perl_croak(aTHX_ "Version number must be constant number");
- /* Make copy of id so we don't free it twice */
- pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
+ /* Make copy of idop so we don't free it twice */
+ pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
/* Fake up a method call to VERSION */
meth = newSVpvn("VERSION",7);
/* Fake up an import/unimport */
if (arg && arg->op_type == OP_STUB)
imop = arg; /* no import on explicit () */
- else if (SvNIOKp(((SVOP*)id)->op_sv)) {
+ else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
imop = Nullop; /* use 5.0; */
}
else {
SV *meth;
- /* Make copy of id so we don't free it twice */
- pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
+ /* Make copy of idop so we don't free it twice */
+ pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
/* Fake up a method call to import/unimport */
meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);
Nullop,
append_elem(OP_LINESEQ,
append_elem(OP_LINESEQ,
- newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, id)),
+ newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, idop)),
newSTATEOP(0, Nullch, veop)),
newSTATEOP(0, Nullch, imop) ));
}
{
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);
if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
goto done;
- if (strEQ(s, "BEGIN")) {
+ if (strEQ(s, "BEGIN") && !PL_error_count) {
I32 oldscope = PL_scopestack_ix;
ENTER;
SAVECOPFILE(&PL_compiling);
CopSTASH_set(PL_curcop,stash);
}
- cv = newXS(name, const_sv_xsub, __FILE__);
+ cv = newXS(name, const_sv_xsub, savepv(CopFILE(PL_curcop)));
CvXSUBANY(cv).any_ptr = sv;
CvCONST_on(cv);
sv_setpv((SV*)cv, ""); /* prototype is "" */
}
}
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 */
OP *
Perl_ck_bitop(pTHX_ OP *o)
{
+#define OP_IS_NUMCOMPARE(op) \
+ ((op) == OP_LT || (op) == OP_I_LT || \
+ (op) == OP_GT || (op) == OP_I_GT || \
+ (op) == OP_LE || (op) == OP_I_LE || \
+ (op) == OP_GE || (op) == OP_I_GE || \
+ (op) == OP_EQ || (op) == OP_I_EQ || \
+ (op) == OP_NE || (op) == OP_I_NE || \
+ (op) == OP_NCMP || (op) == OP_I_NCMP)
o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
+ if (o->op_type == OP_BIT_OR
+ || o->op_type == OP_BIT_AND
+ || o->op_type == OP_BIT_XOR)
+ {
+ OPCODE typfirst = cBINOPo->op_first->op_type;
+ OPCODE typlast = cBINOPo->op_first->op_sibling->op_type;
+ if (OP_IS_NUMCOMPARE(typfirst) || OP_IS_NUMCOMPARE(typlast))
+ if (ckWARN(WARN_PRECEDENCE))
+ Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
+ "Possible precedence problem on bitwise %c operator",
+ o->op_type == OP_BIT_OR ? '|'
+ : o->op_type == OP_BIT_AND ? '&' : '^'
+ );
+ }
return o;
}
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);
}
o->op_flags &= ~OPf_KIDS;
op_null(o);
}
- else if (kid->op_type == OP_LINESEQ) {
+ else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
LOGOP *enter;
- kid->op_next = o->op_next;
cUNOPo->op_first = 0;
op_free(o);
op_free(o);
o = newop;
}
+ else {
+ if ((PL_hints & HINT_FILETEST_ACCESS) &&
+ OP_IS_FILETEST_ACCESS(o))
+ o->op_private |= OPpFT_ACCESS;
+ }
}
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());
}
else if (kid->op_type == OP_AELEM
|| kid->op_type == OP_HELEM)
{
- name = "__ANONIO__";
- len = 10;
- mod(kid,type);
+ OP *op;
+
+ name = 0;
+ if ((op = ((BINOP*)kid)->op_first)) {
+ SV *tmpstr = Nullsv;
+ char *a =
+ kid->op_type == OP_AELEM ?
+ "[]" : "{}";
+ if (((op->op_type == OP_RV2AV) ||
+ (op->op_type == OP_RV2HV)) &&
+ (op = ((UNOP*)op)->op_first) &&
+ (op->op_type == OP_GV)) {
+ /* packagevar $a[] or $h{} */
+ GV *gv = cGVOPx_gv(op);
+ if (gv)
+ tmpstr =
+ Perl_newSVpvf(aTHX_
+ "%s%c...%c",
+ GvNAME(gv),
+ a[0], a[1]);
+ }
+ else if (op->op_type == OP_PADAV
+ || op->op_type == OP_PADHV) {
+ /* lexicalvar $a[] or $h{} */
+ char *padname =
+ PAD_COMPNAME_PV(op->op_targ);
+ if (padname)
+ tmpstr =
+ Perl_newSVpvf(aTHX_
+ "%s%c...%c",
+ padname + 1,
+ a[0], a[1]);
+
+ }
+ if (tmpstr) {
+ name = savepv(SvPVX(tmpstr));
+ len = strlen(name);
+ sv_2mortal(tmpstr);
+ }
+ }
+ if (!name) {
+ name = "__ANONIO__";
+ len = 10;
+ }
+ mod(kid, type);
}
if (name) {
SV *namesv;
}
if (o->op_type == OP_BACKTICK)
return o;
+ {
+ /* In case of three-arg dup open remove strictness
+ * from the last arg if it is a bareword. */
+ OP *first = cLISTOPx(o)->op_first; /* The pushmark. */
+ OP *last = cLISTOPx(o)->op_last; /* The bareword. */
+ OP *oa;
+ char *mode;
+
+ if ((last->op_type == OP_CONST) && /* The bareword. */
+ (last->op_private & OPpCONST_BARE) &&
+ (last->op_private & OPpCONST_STRICT) &&
+ (oa = first->op_sibling) && /* The fh. */
+ (oa = oa->op_sibling) && /* The mode. */
+ SvPOK(((SVOP*)oa)->op_sv) &&
+ (mode = SvPVX(((SVOP*)oa)->op_sv)) &&
+ mode[0] == '>' && mode[1] == '&' && /* A dup open. */
+ (last == oa->op_sibling)) /* The bareword. */
+ last->op_private &= ~OPpCONST_STRICT;
+ }
return ck_fun(o);
}
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
projects / p5sagit/p5-mst-13.2.git / blobdiff