X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=regexec.c;h=cd3df4798635cb479a9ec559d34eec713c6b86f1;hb=9ec58fb7ec19e41fee2f2944750a45a2a85e4a03;hp=8f5278c254bde811374fe497597d23b9c7955636;hpb=05b4157f6fee2ece5589511f927d566b229523f9;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/regexec.c b/regexec.c
index 8f5278c..cd3df47 100644
--- a/regexec.c
+++ b/regexec.c
@@ -1434,9 +1434,14 @@ Perl_regexec_flags(pTHX_ register regexp *prog, char *stringarg, register char *
 	/* we have /x+whatever/ */
 	/* it must be a one character string (XXXX Except UTF?) */
 	char ch = SvPVX(prog->anchored_substr)[0];
+#ifdef DEBUGGING
+	int did_match = 0;
+#endif
+
 	if (UTF) {
 	    while (s < strend) {
 		if (*s == ch) {
+		    DEBUG_r( did_match = 1 );
 		    if (regtry(prog, s)) goto got_it;
 		    s += UTF8SKIP(s);
 		    while (s < strend && *s == ch)
@@ -1448,6 +1453,7 @@ Perl_regexec_flags(pTHX_ register regexp *prog, char *stringarg, register char *
 	else {
 	    while (s < strend) {
 		if (*s == ch) {
+		    DEBUG_r( did_match = 1 );
 		    if (regtry(prog, s)) goto got_it;
 		    s++;
 		    while (s < strend && *s == ch)
@@ -1456,6 +1462,9 @@ Perl_regexec_flags(pTHX_ register regexp *prog, char *stringarg, register char *
 		s++;
 	    }
 	}
+	DEBUG_r(did_match ||
+		PerlIO_printf(Perl_debug_log,
+			      "Did not find anchored character...\n"));
     }
     /*SUPPRESS 560*/
     else if (prog->anchored_substr != Nullsv
@@ -1471,6 +1480,9 @@ Perl_regexec_flags(pTHX_ register regexp *prog, char *stringarg, register char *
 			  -(I32)(CHR_SVLEN(must)
 				 - (SvTAIL(must) != 0) + back_min));
 	char *last1;		/* Last position checked before */
+#ifdef DEBUGGING
+	int did_match = 0;
+#endif
 
 	if (s > PL_bostr)
 	    last1 = HOPc(s, -1);
@@ -1489,6 +1501,7 @@ Perl_regexec_flags(pTHX_ register regexp *prog, char *stringarg, register char *
 		 : (s = fbm_instr((unsigned char*)HOP(s, back_min),
 				  (unsigned char*)strend, must, 
 				  PL_multiline ? FBMrf_MULTILINE : 0))) ) {
+	    DEBUG_r( did_match = 1 );
 	    if (HOPc(s, -back_max) > last1) {
 		last1 = HOPc(s, -back_min);
 		s = HOPc(s, -back_max);
@@ -1514,6 +1527,14 @@ Perl_regexec_flags(pTHX_ register regexp *prog, char *stringarg, register char *
 		}
 	    }
 	}
+	DEBUG_r(did_match ||
+		PerlIO_printf(Perl_debug_log, "Did not find %s substr `%s%.*s%s'%s...\n",
+			      ((must == prog->anchored_substr)
+			       ? "anchored" : "floating"),
+			      PL_colors[0],
+			      (int)(SvCUR(must) - (SvTAIL(must)!=0)),
+			      SvPVX(must),
+			      PL_colors[1], (SvTAIL(must) ? "$" : "")));
 	goto phooey;
     }
     else if ((c = prog->regstclass)) {
@@ -1522,6 +1543,7 @@ Perl_regexec_flags(pTHX_ register regexp *prog, char *stringarg, register char *
 	    strend = HOPc(strend, -(minlen - 1));
   	if (find_byclass(prog, c, s, strend, startpos, 0))
 	    goto got_it;
+	DEBUG_r(PerlIO_printf(Perl_debug_log, "Contradicts stclass...\n"));
     }
     else {
 	dontbother = 0;
@@ -1554,7 +1576,12 @@ Perl_regexec_flags(pTHX_ register regexp *prog, char *stringarg, register char *
 			last = strend;	/* matching `$' */
 		}
 	    }
-	    if (last == NULL) goto phooey; /* Should not happen! */
+	    if (last == NULL) {
+		DEBUG_r(PerlIO_printf(Perl_debug_log,
+				      "%sCan't trim the tail, match fails (should not happen)%s\n",
+				      PL_colors[4],PL_colors[5]));
+		goto phooey; /* Should not happen! */
+	    }
 	    dontbother = strend - last + prog->float_min_offset;
 	}
 	if (minlen && (dontbother < minlen))
@@ -1616,6 +1643,8 @@ got_it:
     return 1;
 
 phooey:
+    DEBUG_r(PerlIO_printf(Perl_debug_log, "%sMatch failed%s\n",
+			  PL_colors[4],PL_colors[5]));
     if (PL_reg_eval_set)
 	restore_pos(aTHXo_ 0);
     return 0;