return off;
}
+/* free the body of an op without examining its contents.
+ * Always use this rather than FreeOp directly */
+
+void
+S_op_destroy(pTHX_ OP *o)
+{
+ if (o->op_latefree) {
+ o->op_latefreed = 1;
+ return;
+ }
+ FreeOp(o);
+}
+
+
/* Destructor */
void
if (!o || o->op_static)
return;
+ if (o->op_latefreed) {
+ if (o->op_latefree)
+ return;
+ goto do_free;
+ }
type = o->op_type;
if (o->op_private & OPpREFCOUNTED) {
cop_free((COP*)o);
op_clear(o);
+ if (o->op_latefree) {
+ o->op_latefreed = 1;
+ return;
+ }
+ do_free:
FreeOp(o);
#ifdef DEBUG_LEAKING_SCALARS
if (PL_op == o)
STATIC void
S_cop_free(pTHX_ COP* cop)
{
- Safefree(cop->cop_label); /* FIXME: treaddead ??? */
+ if (cop->cop_label) {
+#ifdef PERL_TRACK_MEMPOOL
+ Malloc_t ptr = (Malloc_t)(cop->cop_label - sTHX);
+ struct perl_memory_debug_header *const header
+ = (struct perl_memory_debug_header *)ptr;
+ /* Only the thread that allocated us can free us. */
+ if (header->interpreter == aTHX)
+#endif
+ {
+ Safefree(cop->cop_label);
+ cop->cop_label = NULL;
+ }
+ }
CopFILE_free(cop);
CopSTASH_free(cop);
if (! specialWARN(cop->cop_warnings))
else
scalar(kid);
}
- WITH_THR(PL_curcop = &PL_compiling);
+ PL_curcop = &PL_compiling;
break;
case OP_SCOPE:
case OP_LINESEQ:
else
scalar(kid);
}
- WITH_THR(PL_curcop = &PL_compiling);
+ PL_curcop = &PL_compiling;
break;
case OP_SORT:
if (ckWARN(WARN_VOID))
else
list(kid);
}
- WITH_THR(PL_curcop = &PL_compiling);
+ PL_curcop = &PL_compiling;
break;
case OP_SCOPE:
case OP_LINESEQ:
else
list(kid);
}
- WITH_THR(PL_curcop = &PL_compiling);
+ PL_curcop = &PL_compiling;
break;
case OP_REQUIRE:
/* all requires must return a boolean value */
type == OP_RV2AV ||
type == OP_RV2HV) { /* XXX does this let anything illegal in? */
if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
- yyerror(Perl_form(aTHX_ "Can't declare %s in %s",
+ yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
OP_DESC(o),
PL_in_my == KEY_our ? "our" : PL_in_my == KEY_state ? "state" : "my"));
} else if (attrs) {
{
const char * const desc
= PL_op_desc[(rtype == OP_SUBST || rtype == OP_TRANS)
- ? rtype : OP_MATCH];
+ ? (int)rtype : OP_MATCH];
const char * const sample = ((ltype == OP_RV2AV || ltype == OP_PADAV)
? "@array" : "%hash");
Perl_warner(aTHX_ packWARN(WARN_MISC),
if (o->op_type == OP_STUB) {
PL_comppad_name = 0;
PL_compcv = 0;
- FreeOp(o);
+ S_op_destroy(aTHX_ o);
return;
}
PL_main_root = scope(sawparens(scalarvoid(o)));
dVAR;
register OP *curop;
OP *newop;
- I32 type = o->op_type;
- SV *sv = NULL;
+ VOL I32 type = o->op_type;
+ SV * VOL sv = NULL;
int ret = 0;
I32 oldscope;
OP *old_next;
if (type == OP_RV2GV)
newop = newGVOP(OP_GV, 0, (GV*)sv);
else
- newop = newSVOP(OP_CONST, 0, sv);
+ newop = newSVOP(OP_CONST, 0, (SV*)sv);
op_getmad(o,newop,'f');
return newop;
pp_pushmark();
CALLRUNOPS(aTHX);
PL_op = curop;
+ assert (!(curop->op_flags & OPf_SPECIAL));
+ assert(curop->op_type == OP_RANGE);
pp_anonlist();
PL_tmps_floor = oldtmps_floor;
last->op_madprop = 0;
#endif
- FreeOp(last);
+ S_op_destroy(aTHX_ (OP*)last);
return (OP*)first;
}
o->op_type = (OPCODE)type;
o->op_ppaddr = PL_ppaddr[type];
o->op_flags = (U8)flags;
+ o->op_latefree = 0;
+ o->op_latefreed = 0;
o->op_next = o;
o->op_private = (U8)(0 | (flags >> 8));
{
dVAR;
SV * const tstr = ((SVOP*)expr)->op_sv;
- SV * const rstr = ((SVOP*)repl)->op_sv;
+ SV * const rstr = (repl->op_type == OP_NULL)
+ ? ((SVOP*)((LISTOP*)repl)->op_first)->op_sv
+ : ((SVOP*)repl)->op_sv;
STRLEN tlen;
STRLEN rlen;
const U8 *t = (U8*)SvPV_const(tstr, tlen);
bits = 8;
Safefree(cPVOPo->op_pv);
+ cPVOPo->op_pv = NULL;
cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
SvREFCNT_dec(listsv);
SvREFCNT_dec(transv);
if (DO_UTF8(pat))
pm->op_pmdynflags |= PMdf_UTF8;
/* FIXME - can we make this function take const char * args? */
- PM_SETRE(pm, CALLREGCOMP(aTHX_ (char*)p, (char*)p + plen, pm));
+ PM_SETRE(pm, CALLREGCOMP((char*)p, (char*)p + plen, pm));
if (strEQ("\\s+", PM_GETRE(pm)->precomp))
pm->op_pmflags |= PMf_WHITE;
#ifdef PERL_MAD
if (curop == repl
&& !(repl_has_vars
&& (!PM_GETRE(pm)
- || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
+ || PM_GETRE(pm)->extflags & RXf_EVAL_SEEN))) {
pm->op_pmflags |= PMf_CONST; /* const for long enough */
pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
prepend_elem(o->op_type, scalar(repl), o);
* to store these values, evil chicanery is done with SvCUR().
*/
- if (!(left->op_private & OPpLVAL_INTRO)) {
+ {
OP *lastop = o;
PL_generation++;
for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
if (curop != o)
o->op_private |= OPpASSIGN_COMMON;
}
+
+ if ( ((left->op_private & OPpLVAL_INTRO) || ckWARN(WARN_MISC))
+ && (left->op_type == OP_LIST
+ || (left->op_type == OP_NULL && left->op_targ == OP_LIST)))
+ {
+ OP* lop = ((LISTOP*)left)->op_first;
+ while (lop) {
+ if (lop->op_type == OP_PADSV ||
+ lop->op_type == OP_PADAV ||
+ lop->op_type == OP_PADHV ||
+ lop->op_type == OP_PADANY)
+ {
+ if (lop->op_private & OPpPAD_STATE) {
+ if (left->op_private & OPpLVAL_INTRO) {
+ o->op_private |= OPpASSIGN_STATE;
+ /* hijacking PADSTALE for uninitialized state variables */
+ SvPADSTALE_on(PAD_SVl(lop->op_targ));
+ }
+ else { /* we already checked for WARN_MISC before */
+ Perl_warner(aTHX_ packWARN(WARN_MISC), "State variable %s will be reinitialized",
+ PAD_COMPNAME_PV(lop->op_targ));
+ }
+ }
+ }
+ lop = lop->op_sibling;
+ }
+ }
+
if (right && right->op_type == OP_SPLIT) {
OP* tmpop = ((LISTOP*)right)->op_first;
if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
CopSTASH_set(cop, PL_curstash);
if (PERLDB_LINE && PL_curstash != PL_debstash) {
- SV * const * const svp = av_fetch(CopFILEAVx(PL_curcop), (I32)CopLINE(cop), FALSE);
- if (svp && *svp != &PL_sv_undef ) {
- (void)SvIOK_on(*svp);
- SvIV_set(*svp, PTR2IV(cop));
+ AV *av = CopFILEAVx(PL_curcop);
+ if (av) {
+ SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE);
+ if (svp && *svp != &PL_sv_undef ) {
+ (void)SvIOK_on(*svp);
+ SvIV_set(*svp, PTR2IV(cop));
+ }
}
}
LOOP *tmp;
NewOp(1234,tmp,1,LOOP);
Copy(loop,tmp,1,LISTOP);
- FreeOp(loop);
+ S_op_destroy(aTHX_ (OP*)loop);
loop = tmp;
}
#else
- loop = PerlMemShared_realloc(loop, sizeof(LOOP));
+ loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
#endif
loop->op_targ = padoff;
wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
/* for XSUBs CvFILE point directly to static memory; __FILE__ */
Safefree(CvFILE(cv));
}
- CvFILE(cv) = 0;
+ CvFILE(cv) = NULL;
#endif
if (!CvISXSUB(cv) && CvROOT(cv)) {
else
s = tname;
- if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
+ if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I' && *s != 'U')
goto done;
if (strEQ(s, "BEGIN") && !PL_error_count) {
av_store(PL_endav, 0, (SV*)cv);
GvCV(gv) = 0; /* cv has been hijacked */
}
+ else if (strEQ(s, "UNITCHECK") && !PL_error_count) {
+ /* It's never too late to run a unitcheck block */
+ if (!PL_unitcheckav)
+ PL_unitcheckav = newAV();
+ DEBUG_x( dump_sub(gv) );
+ av_unshift(PL_unitcheckav, 1);
+ av_store(PL_unitcheckav, 0, (SV*)cv);
+ GvCV(gv) = 0; /* cv has been hijacked */
+ }
else if (strEQ(s, "CHECK") && !PL_error_count) {
if (!PL_checkav)
PL_checkav = newAV();
cv = newXS_flags(name, const_sv_xsub, file, "", XS_DYNAMIC_FILENAME);
CvXSUBANY(cv).any_ptr = sv;
CvCONST_on(cv);
+ Safefree(file);
#ifdef USE_ITHREADS
if (stash)
OP *
Perl_newANONLIST(pTHX_ OP *o)
{
- return newUNOP(OP_REFGEN, 0,
- mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
+ return convert(OP_ANONLIST, OPf_SPECIAL, o);
}
OP *
Perl_newANONHASH(pTHX_ OP *o)
{
- return newUNOP(OP_REFGEN, 0,
- mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
+ return convert(OP_ANONHASH, OPf_SPECIAL, o);
}
OP *
}
OP *
-Perl_ck_say(pTHX_ OP *o)
-{
- o = ck_listiob(o);
- o->op_type = OP_PRINT;
- cLISTOPo->op_last = cLISTOPo->op_last->op_sibling
- = newSVOP(OP_CONST, 0, newSVpvs("\n"));
- return o;
-}
-
-OP *
Perl_ck_smartmatch(pTHX_ OP *o)
{
dVAR;
int optional = 0;
I32 arg = 0;
I32 contextclass = 0;
- char *e = NULL;
+ const char *e = NULL;
bool delete_op = 0;
o->op_private |= OPpENTERSUB_HASTARG;
proto_end = proto + len;
}
if (CvASSERTION(cv)) {
- if (PL_hints & HINT_ASSERTING) {
+ U32 asserthints = 0;
+ HV *const hinthv = GvHV(PL_hintgv);
+ if (hinthv) {
+ SV **svp = hv_fetchs(hinthv, "assertions", FALSE);
+ if (svp && *svp)
+ asserthints = SvUV(*svp);
+ }
+ if (asserthints & HINT_ASSERTING) {
if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
o->op_private |= OPpENTERSUB_DB;
}
else {
delete_op = 1;
- if (!(PL_hints & HINT_ASSERTIONSSEEN) && ckWARN(WARN_ASSERTIONS)) {
+ if (!(asserthints & HINT_ASSERTIONSSEEN) && ckWARN(WARN_ASSERTIONS)) {
Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
"Impossible to activate assertion call");
}
optional = 1;
proto++;
continue;
+ case '_':
+ /* _ must be at the end */
+ if (proto[1] && proto[1] != ';')
+ goto oops;
case '$':
proto++;
arg++;
prev = o2;
o2 = o2->op_sibling;
} /* while */
+ if (o2 == cvop && proto && *proto == '_') {
+ /* generate an access to $_ */
+ o2 = newDEFSVOP();
+ o2->op_sibling = prev->op_sibling;
+ prev->op_sibling = o2; /* instead of cvop */
+ }
if (proto && !optional && proto_end > proto &&
- (*proto != '@' && *proto != '%' && *proto != ';'))
+ (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
return too_few_arguments(o, gv_ename(namegv));
if(delete_op) {
#ifdef PERL_MAD
https://perl5.git.perl.org / perl5.git / blobdiff