#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
STATIC void
S_no_bareword_allowed(pTHX_ OP *o)
{
- Perl_warn(aTHX_ "Bareword \"%s\" not allowed while \"strict subs\" in use",
- SvPV_nolen(cSVOPo->op_sv));
- ++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));
- }
- }
+ qerror(Perl_mess(aTHX_
+ "Bareword \"%s\" not allowed while \"strict subs\" in use",
+ SvPV_nolen(cSVOPo->op_sv)));
}
/* "register" allocation */
(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++;
null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
break;
}
+ else { /* lvalue subroutine call */
+ o->op_private |= OPpLVAL_INTRO;
+ if (type == OP_GREPSTART || type == OP_ENTERSUB) {
+ /* Backward compatibility mode: */
+ o->op_private |= OPpENTERSUB_INARGS;
+ break;
+ }
+ else { /* Compile-time error message: */
+ OP *kid = cUNOPo->op_first;
+ CV *cv;
+ OP *okid;
+
+ if (kid->op_type == OP_PUSHMARK)
+ goto skip_kids;
+ if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
+ Perl_croak(aTHX_
+ "panic: unexpected lvalue entersub "
+ "args: type/targ %ld:%ld",
+ (long)kid->op_type,kid->op_targ);
+ kid = kLISTOP->op_first;
+ skip_kids:
+ while (kid->op_sibling)
+ kid = kid->op_sibling;
+ if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
+ /* Indirect call */
+ if (kid->op_type == OP_METHOD_NAMED
+ || kid->op_type == OP_METHOD)
+ {
+ OP *newop;
+
+ if (kid->op_sibling || kid->op_next != kid) {
+ yyerror("panic: unexpected optree near method call");
+ break;
+ }
+
+ NewOp(1101, newop, 1, OP);
+ newop->op_type = OP_RV2CV;
+ newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
+ newop->op_next = newop;
+ kid->op_sibling = newop;
+ newop->op_private |= OPpLVAL_INTRO;
+ break;
+ }
+
+ if (kid->op_type != OP_RV2CV)
+ Perl_croak(aTHX_
+ "panic: unexpected lvalue entersub "
+ "entry via type/targ %ld:%ld",
+ (long)kid->op_type,kid->op_targ);
+ kid->op_private |= OPpLVAL_INTRO;
+ break; /* Postpone until runtime */
+ }
+
+ okid = kid;
+ kid = kUNOP->op_first;
+ if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
+ kid = kUNOP->op_first;
+ if (kid->op_type == OP_NULL)
+ Perl_croak(aTHX_
+ "Unexpected constant lvalue entersub "
+ "entry via type/targ %ld:%ld",
+ (long)kid->op_type,kid->op_targ);
+ if (kid->op_type != OP_GV) {
+ /* Restore RV2CV to check lvalueness */
+ restore_2cv:
+ if (kid->op_next && kid->op_next != kid) { /* Happens? */
+ okid->op_next = kid->op_next;
+ kid->op_next = okid;
+ }
+ else
+ okid->op_next = Nullop;
+ okid->op_type = OP_RV2CV;
+ okid->op_targ = 0;
+ okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
+ okid->op_private |= OPpLVAL_INTRO;
+ break;
+ }
+
+ cv = GvCV(kGVOP->op_gv);
+ if (!cv)
+ goto restore_2cv;
+ if (CvLVALUE(cv))
+ break;
+ }
+ }
/* FALL THROUGH */
default:
nomod:
break;
yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
(o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
- ? "do block" : PL_op_desc[o->op_type]),
+ ? "do block"
+ : (o->op_type == OP_ENTERSUB
+ ? "non-lvalue subroutine call"
+ : PL_op_desc[o->op_type])),
type ? PL_op_desc[type] : "local"));
return o;
}
-OP *
-Perl_my(pTHX_ OP *o)
+STATIC OP *
+S_dup_attrlist(pTHX_ OP *o)
+{
+ OP *rop = Nullop;
+
+ /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
+ * where the first kid is OP_PUSHMARK and the remaining ones
+ * are OP_CONST. We need to push the OP_CONST values.
+ */
+ if (o->op_type == OP_CONST)
+ rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc(cSVOPo->op_sv));
+ else {
+ assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
+ for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
+ if (o->op_type == OP_CONST)
+ rop = append_elem(OP_LIST, rop,
+ newSVOP(OP_CONST, o->op_flags,
+ SvREFCNT_inc(cSVOPo->op_sv)));
+ }
+ }
+ return rop;
+}
+
+STATIC void
+S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
+{
+ OP *modname; /* for 'use' */
+ SV *stashsv;
+
+ /* fake up C<use attributes $pkg,$rv,@attrs> */
+ ENTER; /* need to protect against side-effects of 'use' */
+ SAVEINT(PL_expect);
+ if (stash && HvNAME(stash))
+ stashsv = newSVpv(HvNAME(stash), 0);
+ else
+ stashsv = &PL_sv_no;
+#define ATTRSMODULE "attributes"
+ modname = newSVOP(OP_CONST, 0,
+ newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1));
+ modname->op_private |= OPpCONST_BARE;
+ /* that flag is required to make 'use' work right */
+ utilize(1, start_subparse(FALSE, 0),
+ Nullop, /* version */
+ modname,
+ prepend_elem(OP_LIST,
+ newSVOP(OP_CONST, 0, stashsv),
+ prepend_elem(OP_LIST,
+ newSVOP(OP_CONST, 0, newRV(target)),
+ dup_attrlist(attrs))));
+ LEAVE;
+}
+
+STATIC OP *
+S_my_kid(pTHX_ OP *o, OP *attrs)
{
OP *kid;
I32 type;
type = o->op_type;
if (type == OP_LIST) {
for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
- my(kid);
+ my_kid(kid, attrs);
} else if (type == OP_UNDEF) {
return o;
} else if (type != OP_PADSV &&
yyerror(Perl_form(aTHX_ "Can't declare %s in my", PL_op_desc[o->op_type]));
return o;
}
+ else if (attrs && type != OP_PUSHMARK) {
+ HV *stash;
+ SV *padsv;
+ SV **namesvp;
+
+ /* check for C<my Dog $spot> when deciding package */
+ namesvp = av_fetch(PL_comppad_name, o->op_targ, FALSE);
+ if (namesvp && *namesvp && SvOBJECT(*namesvp) && HvNAME(SvSTASH(*namesvp)))
+ stash = SvSTASH(*namesvp);
+ else
+ stash = PL_curstash;
+ padsv = PAD_SV(o->op_targ);
+ apply_attrs(stash, padsv, attrs);
+ }
o->op_flags |= OPf_MOD;
o->op_private |= OPpLVAL_INTRO;
return o;
}
OP *
+Perl_my_attrs(pTHX_ OP *o, OP *attrs)
+{
+ if (o->op_flags & OPf_PARENS)
+ list(o);
+ PL_in_my = FALSE;
+ PL_in_my_stash = Nullhv;
+ if (attrs)
+ SAVEFREEOP(attrs);
+ return my_kid(o, attrs);
+}
+
+OP *
+Perl_my(pTHX_ OP *o)
+{
+ return my_kid(o, Nullop);
+}
+
+OP *
Perl_sawparens(pTHX_ OP *o)
{
if (o)
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);
/* integerize op, unless it happens to be C<-foo>.
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 */
}
/* Fake up the BEGIN {}, which does its thing immediately. */
- newSUB(floor,
+ newATTRSUB(floor,
newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
Nullop,
+ Nullop,
append_elem(OP_LINESEQ,
append_elem(OP_LINESEQ,
newSTATEOP(0, Nullch, rqop),
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;
return sv;
}
+void
+Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
+{
+ if (o)
+ SAVEFREEOP(o);
+ if (proto)
+ SAVEFREEOP(proto);
+ if (attrs)
+ SAVEFREEOP(attrs);
+ if (block)
+ SAVEFREEOP(block);
+ Perl_croak(aTHX_ "\"my sub\" not yet implemented");
+}
+
CV *
Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
{
+ return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
+}
+
+CV *
+Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
+{
dTHR;
STRLEN n_a;
char *name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
GV *gv = gv_fetchpv(name ? name : "__ANON__",
- GV_ADDMULTI | (block ? 0 : GV_NOINIT), SVt_PVCV);
+ GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
+ SVt_PVCV);
char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
register CV *cv=0;
I32 ix;
SAVEFREEOP(o);
if (proto)
SAVEFREEOP(proto);
+ if (attrs)
+ SAVEFREEOP(attrs);
- if (SvTYPE(gv) != SVt_PVGV) { /* Prototype now, and had
+ if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
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)
if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
SV* const_sv;
bool const_changed = TRUE;
- if (!block) {
+ if (!block && !attrs) {
/* just a "sub foo;" when &foo is already defined */
SAVEFREESV(PL_compcv);
goto done;
/* ahem, death to those who redefine active sort subs */
if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
+ if (!block)
+ goto withattrs;
if(const_sv = cv_const_sv(cv))
const_changed = sv_cmp(const_sv, op_const_sv(block, Nullcv));
if ((const_sv && const_changed) || ckWARN(WARN_REDEFINE)
PL_curcop->cop_line = PL_copline;
Perl_warner(aTHX_ WARN_REDEFINE,
const_sv ? "Constant subroutine %s redefined"
- : "Subroutine %s redefined", name);
+ : "Subroutine %s redefined", name);
PL_curcop->cop_line = oldline;
}
SvREFCNT_dec(cv);
cv = Nullcv;
}
}
+ withattrs:
+ if (attrs) {
+ HV *stash;
+ SV *rcv;
+
+ /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
+ * before we clobber PL_compcv.
+ */
+ if (cv && !block) {
+ rcv = (SV*)cv;
+ if (CvGV(cv) && GvSTASH(CvGV(cv)) && HvNAME(GvSTASH(CvGV(cv))))
+ stash = GvSTASH(CvGV(cv));
+ else if (CvSTASH(cv) && HvNAME(CvSTASH(cv)))
+ stash = CvSTASH(cv);
+ else
+ stash = PL_curstash;
+ }
+ else {
+ /* possibly about to re-define existing subr -- ignore old cv */
+ rcv = (SV*)PL_compcv;
+ if (name && GvSTASH(gv) && HvNAME(GvSTASH(gv)))
+ stash = GvSTASH(gv);
+ else
+ stash = PL_curstash;
+ }
+ apply_attrs(stash, rcv, attrs);
+ }
if (cv) { /* must reuse cv if autoloaded */
+ if (!block) {
+ /* got here with just attrs -- work done, so bug out */
+ SAVEFREESV(PL_compcv);
+ goto done;
+ }
cv_undef(cv);
CvFLAGS(cv) = CvFLAGS(PL_compcv);
CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
}
}
- CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
+ if(CvLVALUE(cv)) {
+ CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0, scalarseq(block));
+ }
+ else {
+ CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
+ }
CvSTART(cv) = LINKLIST(CvROOT(cv));
CvROOT(cv)->op_next = 0;
peep(CvSTART(cv));
if(stash)
PL_curstash = PL_curcop->cop_stash = stash;
- newSUB(
+ newATTRSUB(
start_subparse(FALSE, 0),
newSVOP(OP_CONST, 0, newSVpv(name,0)),
newSVOP(OP_CONST, 0, &PL_sv_no), /* SvPV(&PL_sv_no) == "" -- GMB */
+ Nullop,
newSTATEOP(0, Nullch, newSVOP(OP_CONST, 0, sv))
);
OP *
Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
{
+ return newANONATTRSUB(floor, proto, Nullop, block);
+}
+
+OP *
+Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
+{
return newUNOP(OP_REFGEN, 0,
- newSVOP(OP_ANONCODE, 0, (SV*)newSUB(floor, 0, proto, block)));
+ newSVOP(OP_ANONCODE, 0,
+ (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
}
OP *
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;
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,
"(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");
}
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) {
+ if (kLISTOP->op_first->op_sibling->op_type == OP_PADSV
+ && kLISTOP->op_first->op_sibling->op_targ == kkid->op_targ)
+ return o;
+ }
+ else if (kid->op_type == OP_JOIN) {
+ /* do_join has problems if the arguments coincide with target.
+ In fact the second argument *can* safely coincide,
+ but ignore=pessimize this rare occasion. */
+ OP *arg = kLISTOP->op_first->op_sibling; /* Skip PUSHMARK */
+
+ while (arg) {
+ if (arg->op_type == OP_PADSV
+ && arg->op_targ == kkid->op_targ)
+ return o;
+ arg = arg->op_sibling;
+ }
+ }
+ else if (kid->op_type == OP_QUOTEMETA) {
+ /* quotemeta has problems if the argument coincides with target. */
+ if (kLISTOP->op_first->op_type == OP_PADSV
+ && kLISTOP->op_first->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 |= OPpSORT_NUMERIC;
if (k->op_type == OP_I_NCMP)
o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
- op_free(cLISTOPo->op_first->op_sibling); /* delete comparison block */
- cLISTOPo->op_first->op_sibling = cLISTOPo->op_last;
- cLISTOPo->op_children = 1;
+ kid = cLISTOPo->op_first->op_sibling;
+ cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
+ op_free(kid); /* then delete it */
+ cLISTOPo->op_children--;
}
OP *
}
OP *
+Perl_ck_join(pTHX_ OP *o)
+{
+ if (ckWARN(WARN_SYNTAX)) {
+ OP *kid = cLISTOPo->op_first->op_sibling;
+ if (kid && kid->op_type == OP_MATCH) {
+ char *pmstr = "STRING";
+ if (kPMOP->op_pmregexp)
+ pmstr = kPMOP->op_pmregexp->precomp;
+ Perl_warner(aTHX_ WARN_SYNTAX,
+ "/%s/ should probably be written as \"%s\"",
+ pmstr, pmstr);
+ }
+ }
+ return ck_fun(o);
+}
+
+OP *
Perl_ck_subr(pTHX_ OP *o)
{
dTHR;
I32 arg = 0;
STRLEN n_a;
+ o->op_private |= OPpENTERSUB_HASTARG;
for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
if (cvop->op_type == OP_RV2CV) {
SVOP* tmpop;
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);
dTHR;
register OP* oldop = 0;
STRLEN n_a;
+ OP *last_composite = Nullop;
if (!o || o->op_seq)
return;
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 */
o->op_seq = PL_op_seqmax++;
+ last_composite = Nullop;
break;
case OP_CONST:
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);
break;
}
+ case OP_RV2AV:
+ case OP_RV2HV:
+ if (!(o->op_flags & OPf_WANT)
+ || o->op_flags & OPf_WANT == OPf_WANT_LIST)
+ last_composite = o;
+ o->op_seq = PL_op_seqmax++;
+ break;
+
+ case OP_RETURN:
+ if (o->op_next->op_type != OP_LEAVESUBLV) {
+ o->op_seq = PL_op_seqmax++;
+ break;
+ }
+ /* FALL THROUGH */
+
+ case OP_LEAVESUBLV:
+ if (last_composite) {
+ OP *r = last_composite;
+
+ while (r->op_sibling)
+ r = r->op_sibling;
+ if (r->op_next == o
+ || (r->op_next->op_type == OP_LIST
+ && r->op_next->op_next == o))
+ {
+ if (last_composite->op_type == OP_RV2AV)
+ yyerror("Lvalue subs returning arrays not implemented yet");
+ else
+ yyerror("Lvalue subs returning hashes not implemented yet");
+ ;
+ }
+ }
+ /* FALL THROUGH */
+
default:
o->op_seq = PL_op_seqmax++;
break;