X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp_hot.c;h=75bdb4fa98abc18d0033344ebca8b4d684bc0229;hb=9f6ab4074f86da83f9650997df3135d1f2daf062;hp=9b68c1caa7b7b3a2c5ce7d3d763a4e975dd31211;hpb=9d116dd7c895b17badf4ad422ae44da0c4df7bc2;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/pp_hot.c b/pp_hot.c
index 9b68c1c..75bdb4f 100644
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -28,6 +28,8 @@
 #include <sys/file.h>
 #endif
 
+#define HOP(pos,off) (IN_UTF8 ? utf8_hop(pos, off) : (pos + off))
+
 /* Hot code. */
 
 #ifdef USE_THREADS
@@ -39,10 +41,10 @@ unset_cvowner(void *cvarg)
     dTHR;
 #endif /* DEBUGGING */
 
-    DEBUG_L((PerlIO_printf(PerlIO_stderr(), "%p unsetting CvOWNER of %p:%s\n",
+    DEBUG_S((PerlIO_printf(PerlIO_stderr(), "%p unsetting CvOWNER of %p:%s\n",
 			   thr, cv, SvPEEK((SV*)cv))));
     MUTEX_LOCK(CvMUTEXP(cv));
-    DEBUG_L(if (CvDEPTH(cv) != 0)
+    DEBUG_S(if (CvDEPTH(cv) != 0)
 		PerlIO_printf(PerlIO_stderr(), "depth %ld != 0\n",
 			      CvDEPTH(cv)););
     assert(thr == CvOWNER(cv));
@@ -332,23 +334,25 @@ PP(pp_print)
 	RETURN;
     }
     if (!(io = GvIO(gv))) {
-	if (PL_dowarn) {
+	if (ckWARN(WARN_UNOPENED)) {
 	    SV* sv = sv_newmortal();
             gv_fullname3(sv, gv, Nullch);
-            warn("Filehandle %s never opened", SvPV(sv,PL_na));
+            warner(WARN_UNOPENED, "Filehandle %s never opened", SvPV(sv,PL_na));
         }
 
 	SETERRNO(EBADF,RMS$_IFI);
 	goto just_say_no;
     }
     else if (!(fp = IoOFP(io))) {
-	if (PL_dowarn)  {
+	if (ckWARN2(WARN_CLOSED, WARN_IO))  {
 	    SV* sv = sv_newmortal();
             gv_fullname3(sv, gv, Nullch);
 	    if (IoIFP(io))
-		warn("Filehandle %s opened only for input", SvPV(sv,PL_na));
-	    else
-		warn("print on closed filehandle %s", SvPV(sv,PL_na));
+		warner(WARN_IO, "Filehandle %s opened only for input", 
+				SvPV(sv,PL_na));
+	    else if (ckWARN(WARN_CLOSED))
+		warner(WARN_CLOSED, "print on closed filehandle %s", 
+				SvPV(sv,PL_na));
 	}
 	SETERRNO(EBADF,IoIFP(io)?RMS$_FAC:RMS$_IFI);
 	goto just_say_no;
@@ -435,8 +439,8 @@ PP(pp_rv2av)
 		    if (PL_op->op_flags & OPf_REF ||
 		      PL_op->op_private & HINT_STRICT_REFS)
 			DIE(no_usym, "an ARRAY");
-		    if (PL_dowarn)
-			warn(warn_uninit);
+		    if (ckWARN(WARN_UNINITIALIZED))
+			warner(WARN_UNINITIALIZED, warn_uninit);
 		    if (GIMME == G_ARRAY)
 			RETURN;
 		    RETPUSHUNDEF;
@@ -519,8 +523,8 @@ PP(pp_rv2hv)
 		    if (PL_op->op_flags & OPf_REF ||
 		      PL_op->op_private & HINT_STRICT_REFS)
 			DIE(no_usym, "a HASH");
-		    if (PL_dowarn)
-			warn(warn_uninit);
+		    if (ckWARN(WARN_UNINITIALIZED))
+			warner(WARN_UNINITIALIZED, warn_uninit);
 		    if (GIMME == G_ARRAY) {
 			SP--;
 			RETURN;
@@ -658,14 +662,14 @@ PP(pp_aassign)
 		if (relem == lastrelem) {
 		    if (*relem) {
 			HE *didstore;
-			if (PL_dowarn) {
+			if (ckWARN(WARN_UNSAFE)) {
 			    if (relem == firstrelem &&
 				SvROK(*relem) &&
 				( SvTYPE(SvRV(*relem)) == SVt_PVAV ||
 				  SvTYPE(SvRV(*relem)) == SVt_PVHV ) )
-				warn("Reference found where even-sized list expected");
+				warner(WARN_UNSAFE, "Reference found where even-sized list expected");
 			    else
-				warn("Odd number of elements in hash assignment");
+				warner(WARN_UNSAFE, "Odd number of elements in hash assignment");
 			}
 			tmpstr = NEWSV(29,0);
 			didstore = hv_store_ent(hash,*relem,tmpstr,0);
@@ -879,17 +883,20 @@ play_it_again:
 	if (!(rx->reganch & ROPT_NOSCAN)) { /* Floating checkstring. */
 	    if ( screamer ) {
 		I32 p = -1;
+		char *b;
 		
 		if (PL_screamfirst[BmRARE(rx->check_substr)] < 0)
 		    goto nope;
-		else if (!(s = screaminstr(TARG, rx->check_substr, 
-					   rx->check_offset_min, 0, &p, 0)))
+
+		b = (char*)HOP((U8*)s, rx->check_offset_min);
+		if (!(s = screaminstr(TARG, rx->check_substr, b - s, 0, &p, 0)))
 		    goto nope;
-		else if ((rx->reganch & ROPT_CHECK_ALL)
+
+		if ((rx->reganch & ROPT_CHECK_ALL)
 			 && !PL_sawampersand && !SvTAIL(rx->check_substr))
 		    goto yup;
 	    }
-	    else if (!(s = fbm_instr((unsigned char*)s + rx->check_offset_min,
+	    else if (!(s = fbm_instr((unsigned char*)HOP((U8*)s, rx->check_offset_min),
 				     (unsigned char*)strend, 
 				     rx->check_substr, 0)))
 		goto nope;
@@ -897,7 +904,7 @@ play_it_again:
 		goto yup;
 	    if (s && rx->check_offset_max < s - t) {
 		++BmUSEFUL(rx->check_substr);
-		s -= rx->check_offset_max;
+		s = (char*)HOP((U8*)s, -rx->check_offset_max);
 	    }
 	    else
 		s = t;
@@ -906,13 +913,13 @@ play_it_again:
 	   beginning of match, and the match is anchored at s. */
 	else if (!PL_multiline) {	/* Anchored near beginning of string. */
 	    I32 slen;
-	    if (*SvPVX(rx->check_substr) != s[rx->check_offset_min]
+	    char *b = (char*)HOP((U8*)s, rx->check_offset_min);
+	    if (*SvPVX(rx->check_substr) != *b
 		|| ((slen = SvCUR(rx->check_substr)) > 1
-		    && memNE(SvPVX(rx->check_substr), 
-			     s + rx->check_offset_min, slen)))
+		    && memNE(SvPVX(rx->check_substr), b, slen)))
 		goto nope;
 	}
-	if (!rx->naughty && --BmUSEFUL(rx->check_substr) < 0
+	if (!(rx->reganch & ROPT_NAUGHTY) && --BmUSEFUL(rx->check_substr) < 0
 	    && rx->check_substr == rx->float_substr) {
 	    SvREFCNT_dec(rx->check_substr);
 	    rx->check_substr = Nullsv;	/* opt is being useless */
@@ -1213,8 +1220,9 @@ do_readline(void)
 	    SP--;
     }
     if (!fp) {
-	if (PL_dowarn && io && !(IoFLAGS(io) & IOf_START))
-	    warn("Read on closed filehandle <%s>", GvENAME(PL_last_in_gv));
+	if (ckWARN(WARN_CLOSED) && io && !(IoFLAGS(io) & IOf_START))
+	    warner(WARN_CLOSED,
+		   "Read on closed filehandle <%s>", GvENAME(PL_last_in_gv));
 	if (gimme == G_SCALAR) {
 	    (void)SvOK_off(TARG);
 	    PUSHTARG;
@@ -1250,8 +1258,12 @@ do_readline(void)
 		IoFLAGS(io) |= IOf_START;
 	    }
 	    else if (type == OP_GLOB) {
-		if (!do_close(PL_last_in_gv, FALSE))
-		    warn("internal error: glob failed");
+		if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_CLOSED)) {
+		    warner(WARN_CLOSED,
+			   "glob failed (child exited with status %d%s)",
+			   STATUS_CURRENT >> 8,
+			   (STATUS_CURRENT & 0xFF) ? ", core dumped" : "");
+		}
 	    }
 	    if (gimme == G_SCALAR) {
 		(void)SvOK_off(TARG);
@@ -1624,19 +1636,22 @@ PP(pp_subst)
 	if (!(rx->reganch & ROPT_NOSCAN)) { /* It floats. */
 	    if (screamer) {
 		I32 p = -1;
+		char *b;
 		
 		if (PL_screamfirst[BmRARE(rx->check_substr)] < 0)
 		    goto nope;
-		else if (!(s = screaminstr(TARG, rx->check_substr, rx->check_offset_min, 0, &p, 0)))
+
+		b = (char*)HOP((U8*)s, rx->check_offset_min);
+		if (!(s = screaminstr(TARG, rx->check_substr, b - s, 0, &p, 0)))
 		    goto nope;
 	    }
-	    else if (!(s = fbm_instr((unsigned char*)s + rx->check_offset_min, 
+	    else if (!(s = fbm_instr((unsigned char*)HOP((U8*)s, rx->check_offset_min), 
 				     (unsigned char*)strend,
 				     rx->check_substr, 0)))
 		goto nope;
 	    if (s && rx->check_offset_max < s - m) {
 		++BmUSEFUL(rx->check_substr);
-		s -= rx->check_offset_max;
+		s = (char*)HOP((U8*)s, -rx->check_offset_max);
 	    }
 	    else
 		s = m;
@@ -1645,13 +1660,13 @@ PP(pp_subst)
 	   beginning of match, and the match is anchored at s. */
 	else if (!PL_multiline) { /* Anchored at beginning of string. */
 	    I32 slen;
-	    if (*SvPVX(rx->check_substr) != s[rx->check_offset_min]
+	    char *b = (char*)HOP((U8*)s, rx->check_offset_min);
+	    if (*SvPVX(rx->check_substr) != *b
 		|| ((slen = SvCUR(rx->check_substr)) > 1
-		    && memNE(SvPVX(rx->check_substr), 
-			     s + rx->check_offset_min, slen)))
+		    && memNE(SvPVX(rx->check_substr), b, slen)))
 		goto nope;
 	}
-	if (!rx->naughty && --BmUSEFUL(rx->check_substr) < 0
+	if (!(rx->reganch & ROPT_NAUGHTY) && --BmUSEFUL(rx->check_substr) < 0
 	    && rx->check_substr == rx->float_substr) {
 	    SvREFCNT_dec(rx->check_substr);
 	    rx->check_substr = Nullsv;	/* opt is being useless */
@@ -2091,7 +2106,7 @@ PP(pp_entersub)
 	    while (MgOWNER(mg))
 		COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
 	    MgOWNER(mg) = thr;
-	    DEBUG_L(PerlIO_printf(PerlIO_stderr(), "%p: pp_entersub lock %p\n",
+	    DEBUG_S(PerlIO_printf(PerlIO_stderr(), "%p: pp_entersub lock %p\n",
 				  thr, sv);)
 	    MUTEX_UNLOCK(MgMUTEXP(mg));
 	    SvREFCNT_inc(sv);	/* Keep alive until magic_mutexfree */
@@ -2135,7 +2150,7 @@ PP(pp_entersub)
 	    /* We already have a clone to use */
 	    MUTEX_UNLOCK(CvMUTEXP(cv));
 	    cv = *(CV**)svp;
-	    DEBUG_L(PerlIO_printf(PerlIO_stderr(),
+	    DEBUG_S(PerlIO_printf(PerlIO_stderr(),
 				  "entersub: %p already has clone %p:%s\n",
 				  thr, cv, SvPEEK((SV*)cv)));
 	    CvOWNER(cv) = thr;
@@ -2149,7 +2164,7 @@ PP(pp_entersub)
 		CvOWNER(cv) = thr;
 		SvREFCNT_inc(cv);
 		MUTEX_UNLOCK(CvMUTEXP(cv));
-		DEBUG_L(PerlIO_printf(PerlIO_stderr(),
+		DEBUG_S(PerlIO_printf(PerlIO_stderr(),
 			    "entersub: %p grabbing %p:%s in stash %s\n",
 			    thr, cv, SvPEEK((SV*)cv), CvSTASH(cv) ?
 	    			HvNAME(CvSTASH(cv)) : "(none)"));
@@ -2158,7 +2173,7 @@ PP(pp_entersub)
 		CV *clonecv;
 		SvREFCNT_inc(cv); /* don't let it vanish from under us */
 		MUTEX_UNLOCK(CvMUTEXP(cv));
-		DEBUG_L((PerlIO_printf(PerlIO_stderr(),
+		DEBUG_S((PerlIO_printf(PerlIO_stderr(),
 				       "entersub: %p cloning %p:%s\n",
 				       thr, cv, SvPEEK((SV*)cv))));
 		/*
@@ -2175,7 +2190,7 @@ PP(pp_entersub)
 		cv = clonecv;
 		SvREFCNT_inc(cv);
 	    }
-	    DEBUG_L(if (CvDEPTH(cv) != 0)
+	    DEBUG_S(if (CvDEPTH(cv) != 0)
 			PerlIO_printf(PerlIO_stderr(), "depth %ld != 0\n",
 				      CvDEPTH(cv)););
 	    SAVEDESTRUCTOR(unset_cvowner, (void*) cv);
@@ -2260,7 +2275,7 @@ PP(pp_entersub)
 	if (CvDEPTH(cv) < 2)
 	    (void)SvREFCNT_inc(cv);
 	else {	/* save temporaries on recursion? */
-	    if (CvDEPTH(cv) == 100 && PL_dowarn 
+	    if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION)
 		  && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
 		sub_crush_depth(cv);
 	    if (CvDEPTH(cv) > AvFILLp(padlist)) {
@@ -2325,7 +2340,7 @@ PP(pp_entersub)
 	    SV** ary;
 
 #if 0
-	    DEBUG_L(PerlIO_printf(PerlIO_stderr(),
+	    DEBUG_S(PerlIO_printf(PerlIO_stderr(),
 	    			  "%p entersub preparing @_\n", thr));
 #endif
 	    av = (AV*)PL_curpad[0];
@@ -2363,7 +2378,7 @@ PP(pp_entersub)
 	    }
 	}
 #if 0
-	DEBUG_L(PerlIO_printf(PerlIO_stderr(),
+	DEBUG_S(PerlIO_printf(PerlIO_stderr(),
 			      "%p entersub returning %p\n", thr, CvSTART(cv)));
 #endif
 	RETURNOP(CvSTART(cv));
@@ -2374,11 +2389,12 @@ void
 sub_crush_depth(CV *cv)
 {
     if (CvANON(cv))
-	warn("Deep recursion on anonymous subroutine");
+	warner(WARN_RECURSION, "Deep recursion on anonymous subroutine");
     else {
 	SV* tmpstr = sv_newmortal();
 	gv_efullname3(tmpstr, CvGV(cv), Nullch);
-	warn("Deep recursion on subroutine \"%s\"", SvPVX(tmpstr));
+	warner(WARN_RECURSION, "Deep recursion on subroutine \"%s\"", 
+		SvPVX(tmpstr));
     }
 }