++PL_error_count;
}
-void
-Perl_assertref(pTHX_ OP *o)
-{
- int type = o->op_type;
- if (type != OP_AELEM && type != OP_HELEM && type != OP_GELEM) {
- yyerror(Perl_form(aTHX_ "Can't use subscript on %s", PL_op_desc[type]));
- if (type == OP_ENTERSUB || type == OP_RV2HV || type == OP_PADHV) {
- dTHR;
- SV *msg = sv_2mortal(
- Perl_newSVpvf(aTHX_ "(Did you mean $ or @ instead of %c?)\n",
- type == OP_ENTERSUB ? '&' : '%'));
- if (PL_in_eval & EVAL_WARNONLY)
- Perl_warn(aTHX_ "%_", msg);
- else if (PL_in_eval)
- sv_catsv(GvSV(PL_errgv), msg);
- else
- PerlIO_write(PerlIO_stderr(), SvPVX(msg), SvCUR(msg));
- }
- }
-}
-
/* "register" allocation */
PADOFFSET
Perl_op_free(pTHX_ OP *o)
{
register OP *kid, *nextkid;
+ OPCODE type;
if (!o || o->op_seq == (U16)-1)
return;
op_free(kid);
}
}
+ type = o->op_type;
+ if (type == OP_NULL)
+ type = o->op_targ;
+
+ /* COP* is not cleared by op_clear() so that we may track line
+ * numbers etc even after null() */
+ if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE)
+ cop_free((COP*)o);
+
+ op_clear(o);
+
+#ifdef PL_OP_SLAB_ALLOC
+ if ((char *) o == PL_OpPtr)
+ {
+ }
+#else
+ Safefree(o);
+#endif
+}
+STATIC void
+S_op_clear(pTHX_ OP *o)
+{
switch (o->op_type) {
- case OP_NULL:
- o->op_targ = 0; /* Was holding old type, if any. */
- break;
- case OP_ENTEREVAL:
- o->op_targ = 0; /* Was holding hints. */
+ case OP_NULL: /* Was holding old type, if any. */
+ case OP_ENTEREVAL: /* Was holding hints. */
+#ifdef USE_THREADS
+ case OP_THREADSV: /* Was holding index into thr->threadsv AV. */
+#endif
+ o->op_targ = 0;
break;
#ifdef USE_THREADS
case OP_ENTERITER:
if (!(o->op_flags & OPf_SPECIAL))
break;
/* FALL THROUGH */
- case OP_THREADSV:
- o->op_targ = 0; /* Was holding index into thr->threadsv AV. */
- break;
#endif /* USE_THREADS */
default:
if (!(o->op_flags & OPf_REF)
- || (PL_check[o->op_type] != FUNC_NAME_TO_PTR(Perl_ck_ftst)))
+ || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
break;
/* FALL THROUGH */
case OP_GVSV:
case OP_GV:
case OP_AELEMFAST:
SvREFCNT_dec(cGVOPo->op_gv);
- break;
- case OP_NEXTSTATE:
- case OP_DBSTATE:
- cop_free((COP*)o);
+ cGVOPo->op_gv = Nullgv;
break;
case OP_CONST:
SvREFCNT_dec(cSVOPo->op_sv);
+ cSVOPo->op_sv = Nullsv;
break;
case OP_GOTO:
case OP_NEXT:
break;
/* FALL THROUGH */
case OP_TRANS:
- if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF))
+ if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
SvREFCNT_dec(cSVOPo->op_sv);
- else
+ cSVOPo->op_sv = Nullsv;
+ }
+ else {
Safefree(cPVOPo->op_pv);
+ cPVOPo->op_pv = Nullch;
+ }
break;
case OP_SUBST:
op_free(cPMOPo->op_pmreplroot);
+ cPMOPo->op_pmreplroot = Nullop;
/* FALL THROUGH */
case OP_PUSHRE:
case OP_MATCH:
case OP_QR:
ReREFCNT_dec(cPMOPo->op_pmregexp);
+ cPMOPo->op_pmregexp = (REGEXP*)NULL;
break;
}
if (o->op_targ > 0)
pad_free(o->op_targ);
-
-#ifdef PL_OP_SLAB_ALLOC
- if ((char *) o == PL_OpPtr)
- {
- }
-#else
- Safefree(o);
-#endif
}
STATIC void
STATIC void
S_null(pTHX_ OP *o)
{
- if (o->op_type != OP_NULL && o->op_type != OP_THREADSV && o->op_targ > 0)
- pad_free(o->op_targ);
+ if (o->op_type == OP_NULL)
+ return;
+ op_clear(o);
o->op_targ = o->op_type;
o->op_type = OP_NULL;
o->op_ppaddr = PL_ppaddr[OP_NULL];
SV* sv;
U8 want;
- if (o->op_type == OP_NEXTSTATE || o->op_type == OP_DBSTATE ||
- (o->op_type == OP_NULL &&
- (o->op_targ == OP_NEXTSTATE || o->op_targ == OP_DBSTATE)))
+ if (o->op_type == OP_NEXTSTATE
+ || o->op_type == OP_SETSTATE
+ || o->op_type == OP_DBSTATE
+ || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
+ || o->op_targ == OP_SETSTATE
+ || o->op_targ == OP_DBSTATE)))
{
dTHR;
PL_curcop = (COP*)o; /* for warning below */
}
}
}
- null(o); /* don't execute a constant */
- SvREFCNT_dec(sv); /* don't even remember it */
+ null(o); /* don't execute or even remember it */
break;
case OP_POSTINC:
o->op_ppaddr = PL_ppaddr[OP_SCOPE];
kid = ((LISTOP*)o)->op_first;
if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE){
- cop_free((COP*)kid);
- null(kid);
+ kid->op_type = OP_SETSTATE;
+ kid->op_ppaddr = PL_ppaddr[OP_SETSTATE];
}
}
else
}
else {
OP *pack;
- OP *meth;
if (version->op_type != OP_CONST || !SvNIOK(vesv))
Perl_croak(aTHX_ "Version number must be constant number");
pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
/* Fake up a method call to VERSION */
- meth = newSVOP(OP_CONST, 0, newSVpvn("VERSION", 7));
veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
append_elem(OP_LIST,
prepend_elem(OP_LIST, pack, list(version)),
- newUNOP(OP_METHOD, 0, meth)));
+ newSVOP(OP_METHOD_NAMED, 0,
+ newSVpvn("VERSION", 7))));
}
}
else {
/* Make copy of id so we don't free it twice */
pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
- meth = newSVOP(OP_CONST, 0,
- aver
- ? newSVpvn("import", 6)
- : newSVpvn("unimport", 8)
- );
imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
append_elem(OP_LIST,
prepend_elem(OP_LIST, pack, list(arg)),
- newUNOP(OP_METHOD, 0, meth)));
+ newSVOP(OP_METHOD_NAMED, 0,
+ aver ? newSVpvn("import", 6)
+ : newSVpvn("unimport", 8))));
}
/* Fake up a require, handle override, if any */
for (; o; o = o->op_next) {
OPCODE type = o->op_type;
- if(sv && o->op_next == o)
+ if (sv && o->op_next == o)
return sv;
if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
continue;
kid->op_type = OP_GV;
SvREFCNT_dec(kid->op_sv);
kid->op_sv = SvREFCNT_inc(gv);
+ kid->op_ppaddr = PL_ppaddr[OP_GV];
}
}
return o;
}
OP *
+Perl_ck_method(pTHX_ OP *o)
+{
+ OP *kid = cUNOPo->op_first;
+ if (kid->op_type == OP_CONST) {
+ SV* sv = kSVOP->op_sv;
+ if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
+ OP *cmop;
+ sv_upgrade(sv, SVt_PVIV);
+ SvIOK_on(sv);
+ PERL_HASH(SvUVX(sv), SvPVX(sv), SvCUR(sv));
+ cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
+ kSVOP->op_sv = Nullsv;
+ op_free(o);
+ return cmop;
+ }
+ }
+ return o;
+}
+
+OP *
Perl_ck_null(pTHX_ OP *o)
{
return o;
o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
null(cvop); /* disable rv2cv */
tmpop = (SVOP*)((UNOP*)cvop)->op_first;
- if (tmpop->op_type == OP_GV) {
+ if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
cv = GvCVu(tmpop->op_sv);
- if (cv && SvPOK(cv) && !(o->op_private & OPpENTERSUB_AMPER)) {
+ if (!cv)
+ tmpop->op_private |= OPpEARLY_CV;
+ else if (SvPOK(cv)) {
namegv = CvANON(cv) ? (GV*)tmpop->op_sv : CvGV(cv);
proto = SvPV((SV*)cv, n_a);
}
}
}
- else if (cvop->op_type == OP_METHOD) {
+ else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
if (o2->op_type == OP_CONST)
o2->op_private &= ~OPpCONST_STRICT;
else if (o2->op_type == OP_LIST) {
case '$':
if (o2->op_type != OP_RV2SV
&& o2->op_type != OP_PADSV
+ && o2->op_type != OP_HELEM
+ && o2->op_type != OP_AELEM
&& o2->op_type != OP_THREADSV)
{
bad_type(arg, "scalar", gv_ename(namegv), o2);
PL_op_seqmax++;
PL_op = o;
switch (o->op_type) {
+ case OP_SETSTATE:
case OP_NEXTSTATE:
case OP_DBSTATE:
PL_curcop = ((COP*)o); /* for warnings */
}
goto nothin;
case OP_NULL:
- if (o->op_targ == OP_NEXTSTATE || o->op_targ == OP_DBSTATE)
+ if (o->op_targ == OP_NEXTSTATE
+ || o->op_targ == OP_DBSTATE
+ || o->op_targ == OP_SETSTATE)
+ {
PL_curcop = ((COP*)o);
+ }
goto nothin;
case OP_SCALAR:
case OP_LINESEQ:
<= 255 &&
i >= 0)
{
- SvREFCNT_dec(((SVOP*)pop)->op_sv);
null(o->op_next);
null(pop->op_next);
null(pop);
GvAVn(((GVOP*)o)->op_gv);
}
}
+ else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_UNSAFE)) {
+ GV *gv = cGVOPo->op_gv;
+ if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
+ /* XXX could check prototype here instead of just carping */
+ SV *sv = sv_newmortal();
+ gv_efullname3(sv, gv, Nullch);
+ Perl_warner(aTHX_ WARN_UNSAFE,
+ "%s() called too early to check prototype",
+ SvPV_nolen(sv));
+ }
+ }
+
o->op_seq = PL_op_seqmax++;
break;
projects / p5sagit/p5-mst-13.2.git / blobdiff