X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=op.c;h=7459ae6d4f6ecd09bdb36c12b7e4ccf27e5cb587;hb=e336de0d01f30cc4061b6d6a00d11df30fc67cd3;hp=f6857af9406d2ef2edf95dd10f2d84551436673f;hpb=dab48698179b4e8606409875b7121f225bcf46be;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/op.c b/op.c
index f6857af..7459ae6 100644
--- a/op.c
+++ b/op.c
@@ -86,9 +86,18 @@ assertref(OP *o)
     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));
+	}
     }
 }
 
@@ -1392,7 +1401,7 @@ my(OP *o)
 	for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
 	    my(kid);
     } else if (type == OP_UNDEF) {
-	return op;
+	return o;
     } else if (type != OP_PADSV &&
 	     type != OP_PADAV &&
 	     type != OP_PADHV &&
@@ -1564,7 +1573,7 @@ newPROG(OP *o)
 	    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);
@@ -3321,10 +3330,13 @@ newSUB(I32 floor, OP *o, OP *proto, OP *block)
 		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 || 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"
@@ -3454,7 +3466,7 @@ newSUB(I32 floor, OP *o, OP *proto, OP *block)
 	    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);
@@ -3504,6 +3516,33 @@ newSUB(I32 floor, OP *o, OP *proto, OP *block)
     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)
 {
@@ -3519,7 +3558,9 @@ 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);
@@ -3957,17 +3998,16 @@ ck_rvconst(register OP *o)
 	  "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
@@ -3979,9 +4019,12 @@ ck_rvconst(register OP *o)
 			    : 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;
 }
@@ -4246,7 +4289,7 @@ ck_index(OP *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);
 }
@@ -4733,7 +4776,7 @@ peep(register OP *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: