static PADOFFSET pad_findlex _((char* name, PADOFFSET newoff, U32 seq,
CV* startcv, I32 cx_ix));
static OP *newDEFSVOP _((void));
+static OP *new_logop _((I32 type, I32 flags, OP **firstp, OP **otherp));
static char*
gv_ename(GV *gv)
int type = o->op_type;
if (type != OP_AELEM && type != OP_HELEM) {
yyerror(form("Can't use subscript on %s", op_desc[type]));
- if (type == OP_ENTERSUB || type == OP_RV2HV || type == OP_PADHV)
- warn("(Did you mean $ or @ instead of %c?)\n",
- type == OP_ENTERSUB ? '&' : '%');
+ if (type == OP_ENTERSUB || type == OP_RV2HV || type == OP_PADHV) {
+ dTHR;
+ SV *msg = sv_2mortal(
+ newSVpvf("(Did you mean $ or @ instead of %c?)\n",
+ type == OP_ENTERSUB ? '&' : '%'));
+ if (in_eval & 2)
+ warn("%_", msg);
+ else if (in_eval)
+ sv_catsv(GvSV(errgv), msg);
+ else
+ PerlIO_write(PerlIO_stderr(), SvPVX(msg), SvCUR(msg));
+ }
}
}
}
static PADOFFSET
-#ifndef CAN_PROTOTYPE
-pad_findlex(name, newoff, seq, startcv, cx_ix)
-char *name;
-PADOFFSET newoff;
-U32 seq;
-CV* startcv;
-I32 cx_ix;
-#else
pad_findlex(char *name, PADOFFSET newoff, U32 seq, CV* startcv, I32 cx_ix)
-#endif
{
dTHR;
CV *cv;
}
SV *
-#ifndef CAN_PROTOTYPE
-pad_sv(po)
-PADOFFSET po;
-#else
pad_sv(PADOFFSET po)
-#endif /* CAN_PROTOTYPE */
{
dTHR;
#ifdef USE_THREADS
}
void
-#ifndef CAN_PROTOTYPE
-pad_free(po)
-PADOFFSET po;
-#else
pad_free(PADOFFSET po)
-#endif /* CAN_PROTOTYPE */
{
dTHR;
if (!curpad)
}
void
-#ifndef CAN_PROTOTYPE
-pad_swipe(po)
-PADOFFSET po;
-#else
pad_swipe(PADOFFSET po)
-#endif /* CAN_PROTOTYPE */
{
dTHR;
if (AvARRAY(comppad) != curpad)
sawampersand = TRUE;
SvREADONLY_on(sv);
/* FALL THROUGH */
+
+ /* XXX %! tied to Errno.pm needs to be added here.
+ * See gv_fetchpv(). */
+ /* case '!': */
+
default:
sv_magic(sv, 0, 0, name, 1);
}
return o;
}
-static I32 modcount;
-
OP *
mod(OP *o, I32 type)
{
else if (!type) {
o->op_private |= OPpLVAL_INTRO;
o->op_flags &= ~OPf_SPECIAL;
+ hints |= HINT_BLOCK_SCOPE;
}
else if (type != OP_GREPSTART && type != OP_ENTERSUB)
o->op_flags |= OPf_REF;
if (type == OP_LIST) {
for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
my(kid);
- }
- else if (type != OP_PADSV &&
+ } else if (type == OP_UNDEF) {
+ return o;
+ } else if (type != OP_PADSV &&
type != OP_PADAV &&
type != OP_PADHV &&
type != OP_PUSHMARK)
CV *cv = perl_get_cv("DB::postponed", FALSE);
if (cv) {
dSP;
- PUSHMARK(sp);
+ PUSHMARK(SP);
XPUSHs((SV*)compiling.cop_filegv);
PUTBACK;
perl_call_sv((SV*)cv, G_DISCARD);
if (type == OP_RV2GV)
return newGVOP(OP_GV, 0, (GV*)sv);
else {
- if ((SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK)) == SVf_NOK) {
+ /* 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)
+ {
IV iv = SvIV(sv);
- if ((double)iv == SvNV(sv)) { /* can we smush double to int */
+ if ((double)iv == SvNV(sv)) {
SvREFCNT_dec(sv);
sv = newSViv(iv);
}
}
if (list_assignment(left)) {
+ dTHR;
modcount = 0;
eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
left = mod(left, OP_AASSIGN);
OP *
newLOGOP(I32 type, I32 flags, OP *first, OP *other)
{
+ return new_logop(type, flags, &first, &other);
+}
+
+static OP *
+new_logop(I32 type, I32 flags, OP** firstp, OP** otherp)
+{
dTHR;
LOGOP *logop;
OP *o;
+ OP *first = *firstp;
+ OP *other = *otherp;
if (type == OP_XOR) /* Not short circuit, but here by precedence. */
return newBINOP(type, flags, scalar(first), scalar(other));
else
type = OP_AND;
o = first;
- first = cUNOPo->op_first;
+ first = *firstp = cUNOPo->op_first;
if (o->op_next)
first->op_next = o->op_next;
cUNOPo->op_first = Nullop;
warn("Probable precedence problem on %s", op_desc[type]);
if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
op_free(first);
+ *firstp = Nullop;
return other;
}
else {
op_free(other);
+ *otherp = Nullop;
return first;
}
}
case OP_NULL:
if (k2 && k2->op_type == OP_READLINE
&& (k2->op_flags & OPf_STACKED)
- && (k1->op_type == OP_RV2SV || k1->op_type == OP_PADSV))
+ && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
warnop = k2->op_type;
break;
|| (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
expr = newUNOP(OP_DEFINED, 0,
newASSIGNOP(0, newDEFSVOP(), 0, expr) );
+ } else if (expr->op_flags & OPf_KIDS) {
+ OP *k1 = ((UNOP*)expr)->op_first;
+ OP *k2 = (k1) ? k1->op_sibling : NULL;
+ switch (expr->op_type) {
+ case OP_NULL:
+ if (k2 && k2->op_type == OP_READLINE
+ && (k2->op_flags & OPf_STACKED)
+ && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
+ expr = newUNOP(OP_DEFINED, 0, expr);
+ break;
+
+ case OP_SASSIGN:
+ if (k1->op_type == OP_READDIR
+ || k1->op_type == OP_GLOB
+ || k1->op_type == OP_EACH)
+ expr = newUNOP(OP_DEFINED, 0, expr);
+ break;
+ }
}
}
listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
- o = newLOGOP(OP_AND, 0, expr, listop);
+ o = new_logop(OP_AND, 0, &expr, &listop);
- ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
+ if (listop)
+ ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
if (once && o != listop)
o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
|| (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
expr = newUNOP(OP_DEFINED, 0,
newASSIGNOP(0, newDEFSVOP(), 0, expr) );
+ } else if (expr && (expr->op_flags & OPf_KIDS)) {
+ OP *k1 = ((UNOP*)expr)->op_first;
+ OP *k2 = (k1) ? k1->op_sibling : NULL;
+ switch (expr->op_type) {
+ case OP_NULL:
+ if (k2 && k2->op_type == OP_READLINE
+ && (k2->op_flags & OPf_STACKED)
+ && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
+ expr = newUNOP(OP_DEFINED, 0, expr);
+ break;
+
+ case OP_SASSIGN:
+ if (k1->op_type == OP_READDIR
+ || k1->op_type == OP_GLOB
+ || k1->op_type == OP_EACH)
+ expr = newUNOP(OP_DEFINED, 0, expr);
+ break;
+ }
}
if (!block)
redo = LINKLIST(listop);
if (expr) {
- o = newLOGOP(OP_AND, 0, expr, scalar(listop));
+ copline = whileline;
+ scalar(listop);
+ o = new_logop(OP_AND, 0, &expr, &listop);
if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
op_free(expr); /* oops, it's a while (0) */
op_free((OP*)loop);
- return Nullop; /* (listop already freed by newLOGOP) */
+ return Nullop; /* listop already freed by new_logop */
}
- ((LISTOP*)listop)->op_last->op_next = condop =
- (o == listop ? redo : LINKLIST(o));
+ if (listop)
+ ((LISTOP*)listop)->op_last->op_next = condop =
+ (o == listop ? redo : LINKLIST(o));
if (!next)
next = condop;
}
}
OP *
-#ifndef CAN_PROTOTYPE
-newFOROP(flags,label,forline,sv,expr,block,cont)
-I32 flags;
-char *label;
-line_t forline;
-OP* sv;
-OP* expr;
-OP*block;
-OP*cont;
-#else
newFOROP(I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
-#endif /* CAN_PROTOTYPE */
{
LOOP *loop;
OP *wop;
SV *
cv_const_sv(CV *cv)
{
- OP *o;
- SV *sv;
-
if (!cv || !SvPOK(cv) || SvCUR(cv))
return Nullsv;
+ return op_const_sv(CvSTART(cv), cv);
+}
+
+SV *
+op_const_sv(OP *o, CV *cv)
+{
+ SV *sv = Nullsv;
+
+ if(!o)
+ return Nullsv;
+
+ if(o->op_type == OP_LINESEQ && cLISTOPo->op_first)
+ o = cLISTOPo->op_first->op_sibling;
- sv = Nullsv;
- for (o = CvSTART(cv); o; o = o->op_next) {
+ for (; o; o = o->op_next) {
OPCODE type = o->op_type;
-
+
+ if(sv && o->op_next == o)
+ return sv;
if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
continue;
if (type == OP_LEAVESUB || type == OP_RETURN)
return Nullsv;
if (type == OP_CONST)
sv = cSVOPo->op_sv;
- else if (type == OP_PADSV) {
+ else if (type == OP_PADSV && cv) {
AV* padav = (AV*)(AvARRAY(CvPADLIST(cv))[1]);
sv = padav ? AvARRAY(padav)[o->op_targ] : Nullsv;
if (!sv || (!SvREADONLY(sv) && SvREFCNT(sv) > 1))
{
dTHR;
char *name = o ? SvPVx(cSVOPo->op_sv, na) : Nullch;
- GV *gv = gv_fetchpv(name ? name : "__ANON__", GV_ADDMULTI, SVt_PVCV);
+ GV *gv = gv_fetchpv(name ? name : "__ANON__",
+ GV_ADDMULTI | (block ? 0 : GV_NOINIT), SVt_PVCV);
char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, na) : Nullch;
register CV *cv;
I32 ix;
if (proto)
SAVEFREEOP(proto);
+ 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))
+ warn("Runaway prototype");
+ cv_ckproto((CV*)gv, NULL, ps);
+ }
+ if (ps)
+ sv_setpv((SV*)gv, ps);
+ else
+ sv_setiv((SV*)gv, -1);
+ SvREFCNT_dec(compcv);
+ cv = compcv = NULL;
+ sub_generation++;
+ goto noblock;
+ }
+
if (!name || GvCVGEN(gv))
cv = Nullcv;
else if (cv = GvCV(gv)) {
/* already defined (or promised)? */
if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
SV* const_sv;
+ bool const_changed = TRUE;
if (!block) {
/* just a "sub foo;" when &foo is already defined */
SAVEFREESV(compcv);
goto done;
}
/* ahem, death to those who redefine active sort subs */
- if (curstack == sortstack && sortcop == CvSTART(cv))
+ if (curstackinfo->si_type == SI_SORT && sortcop == CvSTART(cv))
croak("Can't redefine active sort subroutine %s", name);
- const_sv = cv_const_sv(cv);
- if (const_sv || dowarn) {
+ if(const_sv = cv_const_sv(cv))
+ const_changed = sv_cmp(const_sv, op_const_sv(block, Nullcv));
+ if ((const_sv && const_changed) || dowarn && !(CvGV(cv) && GvSTASH(CvGV(cv))
+ && HvNAME(GvSTASH(CvGV(cv)))
+ && strEQ(HvNAME(GvSTASH(CvGV(cv))),
+ "autouse"))) {
line_t oldline = curcop->cop_line;
curcop->cop_line = copline;
warn(const_sv ? "Constant subroutine %s redefined"
}
}
if (!block) {
+ noblock:
copline = NOLINE;
LEAVE_SCOPE(floor);
return cv;
if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
&& (cv = GvCV(db_postponed))) {
dSP;
- PUSHMARK(sp);
+ PUSHMARK(SP);
XPUSHs(tmpstr);
PUTBACK;
perl_call_sv((SV*)cv, G_DISCARD);
ENTER;
SAVESPTR(compiling.cop_filegv);
SAVEI16(compiling.cop_line);
- SAVEI32(perldb);
save_svref(&rs);
sv_setsv(rs, nrs);
return cv;
}
+void
+newCONSTSUB(HV *stash, char *name, SV *sv)
+{
+ dTHR;
+ U32 oldhints = hints;
+ HV *old_cop_stash = curcop->cop_stash;
+ HV *old_curstash = curstash;
+ line_t oldline = curcop->cop_line;
+ curcop->cop_line = copline;
+
+ hints &= ~HINT_BLOCK_SCOPE;
+ if(stash)
+ curstash = curcop->cop_stash = stash;
+
+ newSUB(
+ start_subparse(FALSE, 0),
+ newSVOP(OP_CONST, 0, newSVpv(name,0)),
+ newSVOP(OP_CONST, 0, &sv_no), /* SvPV(&sv_no) == "" -- GMB */
+ newSTATEOP(0, Nullch, newSVOP(OP_CONST, 0, sv))
+ );
+
+ hints = oldhints;
+ curcop->cop_stash = old_cop_stash;
+ curstash = old_curstash;
+ curcop->cop_line = oldline;
+}
+
CV *
newXS(char *name, void (*subaddr) (CV *), char *filename)
{
}
else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
/* already defined (or promised) */
- if (dowarn) {
+ if (dowarn && !(CvGV(cv) && GvSTASH(CvGV(cv))
+ && HvNAME(GvSTASH(CvGV(cv)))
+ && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
line_t oldline = curcop->cop_line;
curcop->cop_line = copline;
warn("Subroutine %s redefined",name);
"Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
name, badthing);
}
- kid->op_type = OP_GV;
+ /*
+ * This is a little tricky. We only want to add the symbol if we
+ * didn't add it in the lexer. Otherwise we get duplicate strict
+ * warnings. But if we didn't add it in the lexer, we must at
+ * least pretend like we wanted to add it even if it existed before,
+ * or we get possible typo warnings. OPpCONST_ENTERED says
+ * whether the lexer already added THIS instance of this symbol.
+ */
iscv = (o->op_type == OP_RV2CV) * 2;
- for (gv = 0; !gv; iscv++) {
- /*
- * This is a little tricky. We only want to add the symbol if we
- * didn't add it in the lexer. Otherwise we get duplicate strict
- * warnings. But if we didn't add it in the lexer, we must at
- * least pretend like we wanted to add it even if it existed before,
- * or we get possible typo warnings. OPpCONST_ENTERED says
- * whether the lexer already added THIS instance of this symbol.
- */
+ do {
gv = gv_fetchpv(name,
iscv | !(kid->op_private & OPpCONST_ENTERED),
iscv
: o->op_type == OP_RV2HV
? SVt_PVHV
: SVt_PVGV);
+ } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
+ if (gv) {
+ kid->op_type = OP_GV;
+ SvREFCNT_dec(kid->op_sv);
+ kid->op_sv = SvREFCNT_inc(gv);
}
- SvREFCNT_dec(kid->op_sv);
- kid->op_sv = SvREFCNT_inc(gv);
}
return o;
}
if (o->op_flags & OPf_KIDS) {
OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
if (kid && kid->op_type == OP_CONST)
- fbm_compile(((SVOP*)kid)->op_sv);
+ fbm_compile(((SVOP*)kid)->op_sv, 0);
}
return ck_fun(o);
}
goto nothin;
case OP_NULL:
if (o->op_targ == OP_NEXTSTATE || o->op_targ == OP_DBSTATE)
- curcop = ((COP*)op);
+ curcop = ((COP*)o);
goto nothin;
case OP_SCALAR:
case OP_LINESEQ:
case OP_AND:
case OP_OR:
o->op_seq = op_seqmax++;
+ while (cLOGOP->op_other->op_type == OP_NULL)
+ cLOGOP->op_other = cLOGOP->op_other->op_next;
peep(cLOGOP->op_other);
break;
o->op_seq = op_seqmax++;
if (dowarn && o->op_next && o->op_next->op_type == OP_NEXTSTATE) {
if (o->op_next->op_sibling &&
+ o->op_next->op_sibling->op_type != OP_EXIT &&
+ o->op_next->op_sibling->op_type != OP_WARN &&
o->op_next->op_sibling->op_type != OP_DIE) {
line_t oldline = curcop->cop_line;
projects / p5sagit/p5-mst-13.2.git / blobdiff