#define PERL_IN_OP_C
#include "perl.h"
-#ifdef PERL_OBJECT
-#define CHECKCALL this->*PL_check
-#else
-#define CHECKCALL *PL_check
-#endif
-
/* #define PL_OP_SLAB_ALLOC */
#ifdef PL_OP_SLAB_ALLOC
? ( op_free((OP*)o), \
Perl_croak(aTHX_ "%s trapped by operation mask", PL_op_desc[type]), \
Nullop ) \
- : (CHECKCALL[type])(aTHX_ (OP*)o))
+ : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o))
#define PAD_MAX 999999999
++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
(PL_hints & HINT_UTF8 && (name[1] & 0xc0) == 0xc0) ||
name[1] == '_' && (int)strlen(name) > 2))
{
- if (!isPRINT(name[1])) {
+ if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
/* 1999-02-27 mjd@plover.com */
char *p;
p = strchr(name, '\0');
PL_sv_objcount++;
}
av_store(PL_comppad_name, off, sv);
- SvNVX(sv) = (double)PAD_MAX;
+ SvNVX(sv) = (NV)PAD_MAX;
SvIVX(sv) = 0; /* Not yet introduced--see newSTATEOP */
if (!PL_min_intro_pending)
PL_min_intro_pending = off;
sv_upgrade(namesv, SVt_PVNV);
sv_setpv(namesv, name);
av_store(PL_comppad_name, newoff, namesv);
- SvNVX(namesv) = (double)PL_curcop->cop_seq;
+ SvNVX(namesv) = (NV)PL_curcop->cop_seq;
SvIVX(namesv) = PAD_MAX; /* A ref, intro immediately */
SvFAKE_on(namesv); /* A ref, not a real var */
if (SvOBJECT(sv)) { /* A typed var */
void
Perl_pad_leavemy(pTHX_ I32 fill)
{
+ dTHR;
I32 off;
SV **svp = AvARRAY(PL_comppad_name);
SV *sv;
if (PL_min_intro_pending && fill < PL_min_intro_pending) {
for (off = PL_max_intro_pending; off >= PL_min_intro_pending; off--) {
- if ((sv = svp[off]) && sv != &PL_sv_undef)
- Perl_warn(aTHX_ "%s never introduced", SvPVX(sv));
+ if ((sv = svp[off]) && sv != &PL_sv_undef && ckWARN_d(WARN_INTERNAL))
+ Perl_warner(aTHX_ WARN_INTERNAL, "%s never introduced", SvPVX(sv));
}
}
/* "Deintroduce" my variables that are leaving with this scope. */
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:
- Safefree(cCOPo->cop_label);
- SvREFCNT_dec(cCOPo->cop_filegv);
- if (cCOPo->cop_warnings != WARN_NONE && cCOPo->cop_warnings != WARN_ALL)
- SvREFCNT_dec(cCOPo->cop_warnings);
+ 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
+S_cop_free(pTHX_ COP* cop)
+{
+ Safefree(cop->cop_label);
+ SvREFCNT_dec(cop->cop_filegv);
+ if (! specialWARN(cop->cop_warnings))
+ SvREFCNT_dec(cop->cop_warnings);
}
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];
|| o->op_type == OP_RETURN)
return o;
+ if ((o->op_private & OPpTARGET_MY)
+ && (PL_opargs[o->op_type] & OA_TARGLEX)) /* OPp share the meaning */
+ return scalar(o); /* As if inside SASSIGN */
+
o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
switch (o->op_type) {
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 */
|| o->op_type == OP_RETURN)
return o;
+ if ((o->op_private & OPpTARGET_MY)
+ && (PL_opargs[o->op_type] & OA_TARGLEX)) /* OPp share the meaning */
+ return scalar(o); /* As if inside SASSIGN */
+
o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
switch (o->op_type) {
}
}
}
- 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_type == OP_RETURN)
return o;
+ if ((o->op_private & OPpTARGET_MY)
+ && (PL_opargs[o->op_type] & OA_TARGLEX)) /* OPp share the meaning */
+ return o; /* As if inside SASSIGN */
+
o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
switch (o->op_type) {
if (!o || PL_error_count)
return o;
+ if ((o->op_private & OPpTARGET_MY)
+ && (PL_opargs[o->op_type] & OA_TARGLEX)) /* OPp share the meaning */
+ return o;
+
switch (o->op_type) {
case OP_UNDEF:
PL_modcount++;
o->op_ppaddr = PL_ppaddr[OP_SCOPE];
kid = ((LISTOP*)o)->op_first;
if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE){
- SvREFCNT_dec(((COP*)kid)->cop_filegv);
- null(kid);
+ kid->op_type = OP_SETSTATE;
+ kid->op_ppaddr = PL_ppaddr[OP_SETSTATE];
}
}
else
SAVEHINTS();
PL_hints &= ~HINT_BLOCK_SCOPE;
SAVEPPTR(PL_compiling.cop_warnings);
- if (PL_compiling.cop_warnings != WARN_ALL &&
- PL_compiling.cop_warnings != WARN_NONE) {
+ if (! specialWARN(PL_compiling.cop_warnings)) {
PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
SAVEFREESV(PL_compiling.cop_warnings) ;
}
if (PL_opargs[type] & OA_RETSCALAR)
scalar(o);
- if (PL_opargs[type] & OA_TARGET)
+ if (PL_opargs[type] & OA_TARGET && !o->op_targ)
o->op_targ = pad_alloc(type, SVs_PADTMP);
- if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER))
+ /* integerize op, unless it happens to be C<-foo>.
+ * XXX should pp_i_negate() do magic string negation instead? */
+ if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
+ && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
+ && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
+ {
o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
+ }
if (!(PL_opargs[type] & OA_FOLDCONST))
goto nope;
goto nope; /* Don't try to run w/ errors */
for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
- if (curop->op_type != OP_CONST &&
+ if ((curop->op_type != OP_CONST ||
+ (curop->op_private & OPpCONST_BARE)) &&
curop->op_type != OP_LIST &&
curop->op_type != OP_SCALAR &&
curop->op_type != OP_NULL &&
type != OP_NEGATE)
{
IV iv = SvIV(sv);
- if ((double)iv == SvNV(sv)) {
+ if ((NV)iv == SvNV(sv)) {
SvREFCNT_dec(sv);
sv = newSViv(iv);
}
}
binop = (BINOP*)CHECKOP(type, binop);
- if (binop->op_next)
+ if (binop->op_next || binop->op_type != type)
return (OP*)binop;
binop->op_last = binop->op_first->op_sibling;
}
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 */
o = cUNOPo->op_first;
if (o->op_type == OP_COND_EXPR) {
- I32 t = list_assignment(cCONDOPo->op_first->op_sibling);
- I32 f = list_assignment(cCONDOPo->op_first->op_sibling->op_sibling);
+ I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
+ I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
if (t && f)
return TRUE;
}
cop->cop_seq = seq;
cop->cop_arybase = PL_curcop->cop_arybase;
- if (PL_curcop->cop_warnings == WARN_NONE
- || PL_curcop->cop_warnings == WARN_ALL)
+ if (specialWARN(PL_curcop->cop_warnings))
cop->cop_warnings = PL_curcop->cop_warnings ;
else
cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
if ((sv = svp[i]) && sv != &PL_sv_undef && !SvIVX(sv)) {
SvIVX(sv) = PAD_MAX; /* Don't know scope end yet. */
- SvNVX(sv) = (double)PL_cop_seqmax;
+ SvNVX(sv) = (NV)PL_cop_seqmax;
}
}
PL_min_intro_pending = 0;
Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
{
dTHR;
- CONDOP *condop;
+ LOGOP *logop;
+ OP *start;
OP *o;
if (!falseop)
list(trueop);
scalar(falseop);
}
- NewOp(1101, condop, 1, CONDOP);
+ NewOp(1101, logop, 1, LOGOP);
+ logop->op_type = OP_COND_EXPR;
+ logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
+ logop->op_first = first;
+ logop->op_flags = flags | OPf_KIDS;
+ logop->op_private = 1 | (flags >> 8);
+ logop->op_other = LINKLIST(trueop);
+ logop->op_next = LINKLIST(falseop);
- condop->op_type = OP_COND_EXPR;
- condop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
- condop->op_first = first;
- condop->op_flags = flags | OPf_KIDS;
- condop->op_true = LINKLIST(trueop);
- condop->op_false = LINKLIST(falseop);
- condop->op_private = 1 | (flags >> 8);
/* establish postfix order */
- condop->op_next = LINKLIST(first);
- first->op_next = (OP*)condop;
+ start = LINKLIST(first);
+ first->op_next = (OP*)logop;
first->op_sibling = trueop;
trueop->op_sibling = falseop;
- o = newUNOP(OP_NULL, 0, (OP*)condop);
+ o = newUNOP(OP_NULL, 0, (OP*)logop);
- trueop->op_next = o;
- falseop->op_next = o;
+ trueop->op_next = falseop->op_next = o;
+ o->op_next = start;
return o;
}
Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
{
dTHR;
- CONDOP *condop;
+ LOGOP *range;
OP *flip;
OP *flop;
+ OP *leftstart;
OP *o;
- NewOp(1101, condop, 1, CONDOP);
+ NewOp(1101, range, 1, LOGOP);
- condop->op_type = OP_RANGE;
- condop->op_ppaddr = PL_ppaddr[OP_RANGE];
- condop->op_first = left;
- condop->op_flags = OPf_KIDS;
- condop->op_true = LINKLIST(left);
- condop->op_false = LINKLIST(right);
- condop->op_private = 1 | (flags >> 8);
+ range->op_type = OP_RANGE;
+ range->op_ppaddr = PL_ppaddr[OP_RANGE];
+ range->op_first = left;
+ range->op_flags = OPf_KIDS;
+ leftstart = LINKLIST(left);
+ range->op_other = LINKLIST(right);
+ range->op_private = 1 | (flags >> 8);
left->op_sibling = right;
- condop->op_next = (OP*)condop;
- flip = newUNOP(OP_FLIP, flags, (OP*)condop);
+ range->op_next = (OP*)range;
+ flip = newUNOP(OP_FLIP, flags, (OP*)range);
flop = newUNOP(OP_FLOP, 0, flip);
o = newUNOP(OP_NULL, 0, flop);
linklist(flop);
+ range->op_next = leftstart;
left->op_next = flip;
right->op_next = flop;
- condop->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
- sv_upgrade(PAD_SV(condop->op_targ), SVt_PVNV);
+ range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
+ sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
* treated as min/max values by 'pp_iterinit'.
*/
UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
- CONDOP* range = (CONDOP*) flip->op_first;
+ LOGOP* range = (LOGOP*) flip->op_first;
OP* left = range->op_first;
OP* right = left->op_sibling;
LISTOP* listop;
range->op_first = Nullop;
listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
- listop->op_first->op_next = range->op_true;
- left->op_next = range->op_false;
+ listop->op_first->op_next = range->op_next;
+ left->op_next = range->op_other;
right->op_next = (OP*)listop;
listop->op_next = listop->op_first;
void
Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
{
- if ((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) {
+ dTHR;
+
+ if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_UNSAFE)) {
SV* msg = sv_newmortal();
SV* name = Nullsv;
Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
else
sv_catpv(msg, "none");
- Perl_warn(aTHX_ "%_", msg);
+ Perl_warner(aTHX_ WARN_UNSAFE, "%_", msg);
}
}
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;
if (SvTYPE(gv) != SVt_PVGV) { /* Prototype now, and had
maximum a prototype before. */
if (SvTYPE(gv) > SVt_NULL) {
- if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1))
- Perl_warn(aTHX_ "Runaway prototype");
+ if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
+ && ckWARN_d(WARN_UNSAFE))
+ {
+ Perl_warner(aTHX_ WARN_UNSAFE, "Runaway prototype");
+ }
cv_ckproto((CV*)gv, NULL, ps);
}
if (ps)
break;
default:
- Perl_warn(aTHX_ "oops: oopsAV");
+ if (ckWARN_d(WARN_INTERNAL))
+ Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsAV");
break;
}
return o;
OP *
Perl_oopsHV(pTHX_ OP *o)
{
+ dTHR;
+
switch (o->op_type) {
case OP_PADSV:
case OP_PADAV:
break;
default:
- Perl_warn(aTHX_ "oops: oopsHV");
+ if (ckWARN_d(WARN_INTERNAL))
+ Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsHV");
break;
}
return o;
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;
char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
OP *newop = newAVREF(newGVOP(OP_GV, 0,
gv_fetchpv(name, TRUE, SVt_PVAV) ));
+#ifdef IV_IS_QUAD
+ if (ckWARN(WARN_SYNTAX))
+ Perl_warner(aTHX_ WARN_SYNTAX,
+ "Array @%s missing the @ in argument %" PERL_PRId64 " of %s()",
+ name, (IV)numargs, PL_op_desc[type]);
+#else
if (ckWARN(WARN_SYNTAX))
Perl_warner(aTHX_ WARN_SYNTAX,
"Array @%s missing the @ in argument %ld of %s()",
name, (long)numargs, PL_op_desc[type]);
+#endif
op_free(kid);
kid = newop;
kid->op_sibling = sibl;
char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
OP *newop = newHVREF(newGVOP(OP_GV, 0,
gv_fetchpv(name, TRUE, SVt_PVHV) ));
+#ifdef IV_IS_QUAD
+ if (ckWARN(WARN_SYNTAX))
+ Perl_warner(aTHX_ WARN_SYNTAX,
+ "Hash %%%s missing the %% in argument %" PERL_PRId64 " of %s()",
+ name, (IV)numargs, PL_op_desc[type]);
+#else
if (ckWARN(WARN_SYNTAX))
Perl_warner(aTHX_ WARN_SYNTAX,
"Hash %%%s missing the %% in argument %ld of %s()",
name, (long)numargs, PL_op_desc[type]);
+#endif
op_free(kid);
kid = newop;
kid->op_sibling = sibl;
Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
{
dTHR;
- if (ckWARN(WARN_DEPRECATED)) {
- switch (cUNOPo->op_first->op_type) {
- case OP_RV2AV:
- case OP_PADAV:
- case OP_AASSIGN: /* Is this a good idea? */
- Perl_warner(aTHX_ WARN_DEPRECATED, "defined(@array) is deprecated (and not really meaningful)");
- Perl_warner(aTHX_ WARN_DEPRECATED, "(Maybe you should just omit the defined()?)\n");
- break;
- case OP_RV2HV:
- case OP_PADHV:
- Perl_warner(aTHX_ WARN_DEPRECATED, "defined(%hash) is deprecated (and not really meaningful)");
- Perl_warner(aTHX_ WARN_DEPRECATED, "(Maybe you should just omit the defined()?)\n");
- break;
- default:
- /* no warning */
+ if ((o->op_flags & OPf_KIDS) && ckWARN(WARN_DEPRECATED)) {
+ switch (cUNOPo->op_first->op_type) {
+ case OP_RV2AV:
+ break; /* Globals via GV can be undef */
+ case OP_PADAV:
+ case OP_AASSIGN: /* Is this a good idea? */
+ Perl_warner(aTHX_ WARN_DEPRECATED,
+ "defined(@array) is deprecated");
+ Perl_warner(aTHX_ WARN_DEPRECATED,
+ "(Maybe you should just omit the defined()?)\n");
break;
- }
+ case OP_RV2HV:
+ break; /* Globals via GV can be undef */
+ case OP_PADHV:
+ Perl_warner(aTHX_ WARN_DEPRECATED,
+ "defined(%hash) is deprecated");
+ Perl_warner(aTHX_ WARN_DEPRECATED,
+ "(Maybe you should just omit the defined()?)\n");
+ break;
+ default:
+ /* no warning */
+ break;
+ }
}
return ck_rfun(o);
}
}
OP *
+Perl_ck_sassign(pTHX_ OP *o)
+{
+ OP *kid = cLISTOPo->op_first;
+ /* has a disposable target? */
+ if ((PL_opargs[kid->op_type] & OA_TARGLEX)
+ && !(kid->op_flags & OPf_STACKED))
+ {
+ OP *kkid = kid->op_sibling;
+
+ /* Can just relocate the target. */
+ if (kkid && kkid->op_type == OP_PADSV
+ && !(kkid->op_private & OPpLVAL_INTRO))
+ {
+ /* Concat has problems if target is equal to right arg. */
+ if (kid->op_type == OP_CONCAT
+ && kLISTOP->op_first->op_sibling->op_type == OP_PADSV
+ && kLISTOP->op_first->op_sibling->op_targ == kkid->op_targ)
+ {
+ return o;
+ }
+ kid->op_targ = kkid->op_targ;
+ /* Now we do not need PADSV and SASSIGN. */
+ kid->op_sibling = o->op_sibling; /* NULL */
+ cLISTOPo->op_first = NULL;
+ op_free(o);
+ op_free(kkid);
+ kid->op_private |= OPpTARGET_MY; /* Used for context settings */
+ return kid;
+ }
+ }
+ return o;
+}
+
+OP *
Perl_ck_scmp(pTHX_ OP *o)
{
o->op_private = 0;
}
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);
if (kid->op_type == OP_NULL)
kid = (SVOP*)kid->op_sibling;
- if (kid &&
- kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE))
+ if (kid && kid->op_type == OP_CONST &&
+ (kid->op_private & OPpCONST_BARE))
+ {
o->op_flags |= OPf_SPECIAL;
+ kid->op_private &= ~OPpCONST_STRICT;
+ }
}
return ck_fun(o);
}
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 */
if (cSVOPo->op_private & OPpCONST_STRICT)
no_bareword_allowed(o);
/* FALL THROUGH */
- case OP_CONCAT:
- case OP_JOIN:
case OP_UC:
case OP_UCFIRST:
case OP_LC:
case OP_LCFIRST:
+ if ( o->op_next && o->op_next->op_type == OP_STRINGIFY
+ && !(o->op_next->op_private & OPpTARGET_MY) )
+ null(o->op_next);
+ o->op_seq = PL_op_seqmax++;
+ break;
+ case OP_CONCAT:
+ case OP_JOIN:
case OP_QUOTEMETA:
- if (o->op_next && o->op_next->op_type == OP_STRINGIFY)
+ if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
+ if (o->op_next->op_private & OPpTARGET_MY) {
+ if ((o->op_flags & OPf_STACKED) /* chained concats */
+ || (o->op_type == OP_CONCAT
+ /* Concat has problems if target is equal to right arg. */
+ && (((LISTOP*)o)->op_first->op_sibling->op_type
+ == OP_PADSV)
+ && (((LISTOP*)o)->op_first->op_sibling->op_targ
+ == o->op_next->op_targ))) {
+ goto ignore_optimization;
+ } else {
+ o->op_targ = o->op_next->op_targ;
+ o->op_private |= OPpTARGET_MY;
+ }
+ }
null(o->op_next);
+ }
+ ignore_optimization:
o->op_seq = PL_op_seqmax++;
break;
case OP_STUB:
}
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;
case OP_GREPWHILE:
case OP_AND:
case OP_OR:
+ case OP_ANDASSIGN:
+ case OP_ORASSIGN:
+ case OP_COND_EXPR:
+ case OP_RANGE:
o->op_seq = PL_op_seqmax++;
while (cLOGOP->op_other->op_type == OP_NULL)
cLOGOP->op_other = cLOGOP->op_other->op_next;
peep(cLOGOP->op_other);
break;
- case OP_COND_EXPR:
- o->op_seq = PL_op_seqmax++;
- peep(cCONDOP->op_true);
- peep(cCONDOP->op_false);
- break;
-
case OP_ENTERLOOP:
o->op_seq = PL_op_seqmax++;
peep(cLOOP->op_redoop);
projects / p5sagit/p5-mst-13.2.git / blobdiff