X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=regexec.c;h=f53567e9a6c92521a46914d32b2fd65f2bc16e63;hb=47cadb06ccb7dbe87fdda243544a1ecb06fb104f;hp=1fc37fc2afbcb410333a5d84d242ad89e68682da;hpb=22c35a8c2392967a5ba6b5370695be464bd7012c;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/regexec.c b/regexec.c
index 1fc37fc..f53567e 100644
--- a/regexec.c
+++ b/regexec.c
@@ -37,6 +37,7 @@
 #  define Perl_regprop my_regprop
 /* *These* symbols are masked to allow static link. */
 #  define Perl_pregexec my_pregexec
+#  define Perl_reginitcolors my_reginitcolors 
 #endif 
 
 /*SUPPRESS 112*/
@@ -108,6 +109,7 @@ static CHECKPOINT regcppush _((I32 parenfloor));
 static char * regcppop _((void));
 static char * regcp_set_to _((I32 ss));
 static void cache_re _((regexp *prog));
+static void restore_pos _((void *arg));
 #endif
 
 #define REGINCLASS(p,c)  (*(p) ? reginclass(p,c) : ANYOF_TEST(p,c))
@@ -259,13 +261,25 @@ cache_re(regexp *prog)
     PL_regdata = prog->data;    
     PL_reg_re = prog;    
 }
-  
+
+STATIC void
+restore_pos(void *arg)
+{
+    dTHR;
+    if (PL_reg_eval_set) {    
+	PL_reg_magic->mg_len = PL_reg_oldpos;
+	PL_reg_eval_set = 0;
+	PL_curpm = PL_reg_oldcurpm;
+    }	
+}
+
+
 /*
  - regexec_flags - match a regexp against a string
  */
 I32
 regexec_flags(register regexp *prog, char *stringarg, register char *strend,
-	      char *strbeg, I32 minend, SV *screamer, void *data, U32 flags)
+	      char *strbeg, I32 minend, SV *sv, void *data, U32 flags)
 /* strend: pointer to null at end of string */
 /* strbeg: real beginning of string */
 /* minend: end of match must be >=minend after stringarg. */
@@ -315,7 +329,7 @@ regexec_flags(register regexp *prog, char *stringarg, register char *strend,
 
     /* Check validity of program. */
     if (UCHARAT(prog->program) != REG_MAGIC) {
-	FAIL("corrupted regexp program");
+	croak("corrupted regexp program");
     }
 
     PL_reg_flags = 0;
@@ -327,6 +341,7 @@ regexec_flags(register regexp *prog, char *stringarg, register char *strend,
     /* Mark beginning of line for ^ and lookbehind. */
     PL_regbol = startpos;
     PL_bostr  = strbeg;
+    PL_reg_sv = sv;
 
     /* Mark end of line for $ (and such) */
     PL_regeol = strend;
@@ -349,9 +364,9 @@ regexec_flags(register regexp *prog, char *stringarg, register char *strend,
 	start_shift = prog->check_offset_min;	/* okay to underestimate on CC */
 	/* Should be nonnegative! */
 	end_shift = minlen - start_shift - CHR_SVLEN(prog->check_substr);
-	if (screamer) {
+	if (flags & REXEC_SCREAM) {
 	    if (PL_screamfirst[BmRARE(prog->check_substr)] >= 0)
-		    s = screaminstr(screamer, prog->check_substr, 
+		    s = screaminstr(sv, prog->check_substr, 
 				    start_shift + (stringarg - strbeg),
 				    end_shift, &scream_pos, 0);
 	    else
@@ -388,8 +403,8 @@ regexec_flags(register regexp *prog, char *stringarg, register char *strend,
 	    s = startpos;
     }
 
-    DEBUG_r(
-	PerlIO_printf(Perl_debug_log, 
+    DEBUG_r(if (!PL_colorset) reginitcolors());
+    DEBUG_r(PerlIO_printf(Perl_debug_log, 
 		      "%sMatching%s `%s%.60s%s%s' against `%s%.*s%s%s'\n",
 		      PL_colors[4],PL_colors[5],PL_colors[0],
 		      prog->precomp,
@@ -401,14 +416,23 @@ regexec_flags(register regexp *prog, char *stringarg, register char *strend,
 		      (strend - startpos > 60 ? "..." : ""))
 	);
 
+    if (prog->reganch & ROPT_GPOS_SEEN) {
+	MAGIC *mg;
+
+	if (!(flags & REXEC_IGNOREPOS) && sv && SvTYPE(sv) >= SVt_PVMG
+	    && SvMAGIC(sv) && (mg = mg_find(sv, 'g')) && mg->mg_len >= 0)
+	    PL_reg_ganch = strbeg + mg->mg_len;
+	else
+	    PL_reg_ganch = startpos;
+    }
+
     /* Simplest case:  anchored match need be tried only once. */
     /*  [unless only anchor is BOL and multiline is set] */
-    if (prog->reganch & ROPT_ANCH) {
+    if (prog->reganch & (ROPT_ANCH & ~ROPT_ANCH_GPOS)) {
 	if (regtry(prog, startpos))
 	    goto got_it;
-	else if (!(prog->reganch & ROPT_ANCH_GPOS) &&
-		 (PL_multiline || (prog->reganch & ROPT_IMPLICIT)
-		  || (prog->reganch & ROPT_ANCH_MBOL)))
+	else if (PL_multiline || (prog->reganch & ROPT_IMPLICIT)
+		 || (prog->reganch & ROPT_ANCH_MBOL)) /* XXXX SBOL? */
 	{
 	    if (minlen)
 		dontbother = minlen - 1;
@@ -417,13 +441,17 @@ regexec_flags(register regexp *prog, char *stringarg, register char *strend,
 	    if (s > startpos)
 		s--;
 	    while (s < strend) {
-		if (*s++ == '\n') {	/* don't need utf8skip here */
+		if (*s++ == '\n') {	/* don't need PL_utf8skip here */
 		    if (s < strend && regtry(prog, s))
 			goto got_it;
 		}
 	    }
 	}
 	goto phooey;
+    } else if (prog->reganch & ROPT_ANCH_GPOS) {
+	if (regtry(prog, PL_reg_ganch))
+	    goto got_it;
+	goto phooey;
     }
 
     /* Messy cases:  unanchored match. */
@@ -479,8 +507,8 @@ regexec_flags(register regexp *prog, char *stringarg, register char *strend,
 	dontbother = end_shift;
 	strend = HOPc(strend, -dontbother);
 	while ( (s <= last) &&
-		(screamer 
-		 ? (s = screaminstr(screamer, must, HOPc(s, back_min) - strbeg,
+		((flags & REXEC_SCREAM) 
+		 ? (s = screaminstr(sv, must, HOPc(s, back_min) - strbeg,
 				    end_shift, &scream_pos, 0))
 		 : (s = fbm_instr((unsigned char*)HOP(s, back_min),
 				  (unsigned char*)strend, must, 0))) ) {
@@ -912,8 +940,8 @@ regexec_flags(register regexp *prog, char *stringarg, register char *strend,
 	    char *last;
 	    I32 oldpos = scream_pos;
 
-	    if (screamer) {
-		last = screaminstr(screamer, prog->float_substr, s - strbeg,
+	    if (flags & REXEC_SCREAM) {
+		last = screaminstr(sv, prog->float_substr, s - strbeg,
 				   end_shift, &scream_pos, 1); /* last one */
 		if (!last) {
 		    last = scream_olds; /* Only one occurence. */
@@ -983,15 +1011,20 @@ got_it:
 	    }
 	}
     }
-    /* Preserve the current value of $^R */
-    if (oreplsv != GvSV(PL_replgv)) {
-	sv_setsv(oreplsv, GvSV(PL_replgv));/* So that when GvSV(replgv) is
-					   restored, the value remains
-					   the same. */
+    if (PL_reg_eval_set) {
+	/* Preserve the current value of $^R */
+	if (oreplsv != GvSV(PL_replgv))
+	    sv_setsv(oreplsv, GvSV(PL_replgv));/* So that when GvSV(replgv) is
+						  restored, the value remains
+						  the same. */
+	restore_pos(0);
     }
+    
     return 1;
 
 phooey:
+    if (PL_reg_eval_set)
+	restore_pos(0);
     return 0;
 }
 
@@ -1008,6 +1041,8 @@ regtry(regexp *prog, char *startpos)
     CHECKPOINT lastcp;
 
     if ((prog->reganch & ROPT_EVAL_SEEN) && !PL_reg_eval_set) {
+	MAGIC *mg;
+
 	PL_reg_eval_set = RS_init;
 	DEBUG_r(DEBUG_s(
 	    PerlIO_printf(Perl_debug_log, "  setting stack tmpbase at %i\n",
@@ -1020,13 +1055,42 @@ regtry(regexp *prog, char *startpos)
 	/* Apparently this is not needed, judging by wantarray. */
 	/* SAVEINT(cxstack[cxstack_ix].blk_gimme);
 	   cxstack[cxstack_ix].blk_gimme = G_SCALAR; */
+
+	if (PL_reg_sv) {
+	    /* Make $_ available to executed code. */
+	    if (PL_reg_sv != DEFSV) {
+		/* SAVE_DEFSV does *not* suffice here for USE_THREADS */
+		SAVESPTR(DEFSV);
+		DEFSV = PL_reg_sv;
+	    }
+	
+	    if (!(SvTYPE(PL_reg_sv) >= SVt_PVMG && SvMAGIC(PL_reg_sv) 
+		  && (mg = mg_find(PL_reg_sv, 'g')))) {
+		/* prepare for quick setting of pos */
+		sv_magic(PL_reg_sv, (SV*)0, 'g', Nullch, 0);
+		mg = mg_find(PL_reg_sv, 'g');
+		mg->mg_len = -1;
+	    }
+	    PL_reg_magic    = mg;
+	    PL_reg_oldpos   = mg->mg_len;
+	    SAVEDESTRUCTOR(restore_pos, 0);
+        }
+	if (!PL_reg_curpm)
+	    New(22,PL_reg_curpm, 1, PMOP);
+	PL_reg_curpm->op_pmregexp = prog;
+	PL_reg_oldcurpm = PL_curpm;
+	PL_curpm = PL_reg_curpm;
+	prog->subbeg = PL_bostr;
+	prog->subend = PL_regeol;	/* strend may have been modified */
     }
+    prog->startp[0] = startpos;
     PL_reginput = startpos;
     PL_regstartp = prog->startp;
     PL_regendp = prog->endp;
     PL_reglastparen = &prog->lastparen;
     prog->lastparen = 0;
     PL_regsize = 0;
+    DEBUG_r(PL_reg_starttry = startpos);
     if (PL_reg_start_tmpl <= prog->nparens) {
 	PL_reg_start_tmpl = prog->nparens*3/2 + 3;
         if(PL_reg_start_tmp)
@@ -1035,17 +1099,19 @@ regtry(regexp *prog, char *startpos)
             New(22,PL_reg_start_tmp, PL_reg_start_tmpl, char*);
     }
 
+    /* XXXX What this code is doing here?!!!  There should be no need
+       to do this again and again, PL_reglastparen should take care of
+       this!  */
     sp = prog->startp;
     ep = prog->endp;
     if (prog->nparens) {
-	for (i = prog->nparens; i >= 0; i--) {
-	    *sp++ = NULL;
-	    *ep++ = NULL;
+	for (i = prog->nparens; i >= 1; i--) {
+	    *++sp = NULL;
+	    *++ep = NULL;
 	}
     }
     REGCP_SET;
     if (regmatch(prog->program + 1)) {
-	prog->startp[0] = startpos;
 	prog->endp[0] = PL_reginput;
 	return 1;
     }
@@ -1106,15 +1172,23 @@ regmatch(regnode *prog)
 	    int docolor = *PL_colors[0];
 	    int taill = (docolor ? 10 : 7); /* 3 chars for "> <" */
 	    int l = (PL_regeol - locinput > taill ? taill : PL_regeol - locinput);
+	    /* The part of the string before starttry has one color
+	       (pref0_len chars), between starttry and current
+	       position another one (pref_len - pref0_len chars),
+	       after the current position the third one.
+	       We assume that pref0_len <= pref_len, otherwise we
+	       decrease pref0_len.  */
 	    int pref_len = (locinput - PL_bostr > (5 + taill) - l 
 			    ? (5 + taill) - l : locinput - PL_bostr);
-	    int pref0_len = pref_len  - (locinput - PL_reginput);
+	    int pref0_len = pref_len  - (locinput - PL_reg_starttry);
 
 	    if (l + pref_len < (5 + taill) && l < PL_regeol - locinput)
 		l = ( PL_regeol - locinput > (5 + taill) - pref_len 
 		      ? (5 + taill) - pref_len : PL_regeol - locinput);
 	    if (pref0_len < 0)
 		pref0_len = 0;
+	    if (pref0_len > pref_len)
+		pref0_len = pref_len;
 	    regprop(prop, scan);
 	    PerlIO_printf(Perl_debug_log, 
 			  "%4i <%s%.*s%s%s%.*s%s%s%s%.*s%s>%*s|%3d:%*s%s\n",
@@ -1159,7 +1233,7 @@ regmatch(regnode *prog)
 		break;
 	    sayNO;
 	case GPOS:
-	    if (locinput == PL_regbol)
+	    if (locinput == PL_reg_ganch)
 		break;
 	    sayNO;
 	case EOL:
@@ -1185,7 +1259,7 @@ regmatch(regnode *prog)
 	    break;
 	case SANYUTF8:
 	    if (nextchr & 0x80) {
-		locinput += utf8skip[nextchr];
+		locinput += PL_utf8skip[nextchr];
 		if (locinput > PL_regeol)
 		    sayNO;
 		nextchr = UCHARAT(locinput);
@@ -1202,7 +1276,7 @@ regmatch(regnode *prog)
 	    break;
 	case ANYUTF8:
 	    if (nextchr & 0x80) {
-		locinput += utf8skip[nextchr];
+		locinput += PL_utf8skip[nextchr];
 		if (locinput > PL_regeol)
 		    sayNO;
 		nextchr = UCHARAT(locinput);
@@ -1278,7 +1352,7 @@ regmatch(regnode *prog)
 		sayNO;
 	    if (locinput >= PL_regeol)
 		sayNO;
-	    locinput += utf8skip[nextchr];
+	    locinput += PL_utf8skip[nextchr];
 	    nextchr = UCHARAT(locinput);
 	    break;
 	case ANYOF:
@@ -1315,7 +1389,7 @@ regmatch(regnode *prog)
 		{
 		    sayNO;
 		}
-		locinput += utf8skip[nextchr];
+		locinput += PL_utf8skip[nextchr];
 		nextchr = UCHARAT(locinput);
 		break;
 	    }
@@ -1348,7 +1422,7 @@ regmatch(regnode *prog)
 		{
 		    sayNO;
 		}
-		locinput += utf8skip[nextchr];
+		locinput += PL_utf8skip[nextchr];
 		nextchr = UCHARAT(locinput);
 		break;
 	    }
@@ -1420,7 +1494,7 @@ regmatch(regnode *prog)
 		{
 		    sayNO;
 		}
-		locinput += utf8skip[nextchr];
+		locinput += PL_utf8skip[nextchr];
 		nextchr = UCHARAT(locinput);
 		break;
 	    }
@@ -1453,7 +1527,7 @@ regmatch(regnode *prog)
 		{
 		    sayNO;
 		}
-		locinput += utf8skip[nextchr];
+		locinput += PL_utf8skip[nextchr];
 		nextchr = UCHARAT(locinput);
 		break;
 	    }
@@ -1471,7 +1545,7 @@ regmatch(regnode *prog)
 	    if (nextchr & 0x80) {
 		if (!(swash_fetch(PL_utf8_digit,(U8*)locinput)))
 		    sayNO;
-		locinput += utf8skip[nextchr];
+		locinput += PL_utf8skip[nextchr];
 		nextchr = UCHARAT(locinput);
 		break;
 	    }
@@ -1492,7 +1566,7 @@ regmatch(regnode *prog)
 	    if (nextchr & 0x80) {
 		if (swash_fetch(PL_utf8_digit,(U8*)locinput))
 		    sayNO;
-		locinput += utf8skip[nextchr];
+		locinput += PL_utf8skip[nextchr];
 		nextchr = UCHARAT(locinput);
 		break;
 	    }
@@ -1503,7 +1577,7 @@ regmatch(regnode *prog)
 	case CLUMP:
 	    if (locinput >= PL_regeol || swash_fetch(PL_utf8_mark,(U8*)locinput))
 		sayNO;
-	    locinput += utf8skip[nextchr];
+	    locinput += PL_utf8skip[nextchr];
 	    while (locinput < PL_regeol && swash_fetch(PL_utf8_mark,(U8*)locinput))
 		locinput += UTF8SKIP(locinput);
 	    if (locinput > PL_regeol)
@@ -1591,6 +1665,8 @@ regmatch(regnode *prog)
 	    PL_op = (OP_4tree*)PL_regdata->data[n];
 	    DEBUG_r( PerlIO_printf(Perl_debug_log, "  re_eval 0x%x\n", PL_op) );
 	    PL_curpad = AvARRAY((AV*)PL_regdata->data[n + 1]);
+	    PL_reg_magic->mg_len = locinput - PL_bostr;
+	    PL_regendp[0] = locinput;
 
 	    CALLRUNOPS();			/* Scalar context. */
 	    SPAGAIN;
@@ -2128,6 +2204,50 @@ regmatch(regnode *prog)
 		    sayNO;
 		locinput = PL_reginput;
 		REGCP_SET;
+		if (c1 != -1000) {
+		    char *e = locinput + n - ln; /* Should not check after this */
+		    char *old = locinput;
+
+		    if (e >= PL_regeol || (n == REG_INFTY))
+			e = PL_regeol - 1;
+		    while (1) {
+			/* Find place 'next' could work */
+			if (c1 == c2) {
+			    while (locinput <= e && *locinput != c1)
+				locinput++;
+			} else {
+			    while (locinput <= e 
+				   && *locinput != c1
+				   && *locinput != c2)
+				locinput++;			    
+			}
+			if (locinput > e) 
+			    sayNO;
+			/* PL_reginput == old now */
+			if (locinput != old) {
+			    ln = 1;	/* Did some */
+			    if (regrepeat(scan, locinput - old) <
+				 locinput - old)
+				sayNO;
+			}
+			/* PL_reginput == locinput now */
+			if (paren) {
+			    if (ln) {
+				PL_regstartp[paren] = HOPc(locinput, -1);
+				PL_regendp[paren] = locinput;
+			    }
+			    else
+				PL_regendp[paren] = NULL;
+			}
+			if (regmatch(next))
+			    sayYES;
+			PL_reginput = locinput;	/* Could be reset... */
+			REGCP_UNWIND;
+			/* Couldn't or didn't -- move forward. */
+			old = locinput++;
+		    }
+		}
+		else
 		while (n >= ln || (n == REG_INFTY && ln > 0)) { /* ln overflow ? */
 		    /* If it could work, try it. */
 		    if (c1 == -1000 ||
@@ -2255,10 +2375,20 @@ regmatch(regnode *prog)
 	case UNLESSM:
 	    n = 0;
 	    if (scan->flags) {
-		s = HOPMAYBEc(locinput, -scan->flags);
-		if (!s)
-		    goto say_yes;
-		PL_reginput = s;
+		if (UTF) {		/* XXXX This is absolutely
+					   broken, we read before
+					   start of string. */
+		    s = HOPMAYBEc(locinput, -scan->flags);
+		    if (!s)
+			goto say_yes;
+		    PL_reginput = s;
+		}
+		else {
+		    if (locinput < PL_bostr + scan->flags) 
+			goto say_yes;
+		    PL_reginput = locinput - scan->flags;
+		    goto do_ifmatch;
+		}
 	    }
 	    else
 		PL_reginput = locinput;
@@ -2266,10 +2396,20 @@ regmatch(regnode *prog)
 	case IFMATCH:
 	    n = 1;
 	    if (scan->flags) {
-		s = HOPMAYBEc(locinput, -scan->flags);
-		if (!s)
-		    goto say_no;
-		PL_reginput = s;
+		if (UTF) {		/* XXXX This is absolutely
+					   broken, we read before
+					   start of string. */
+		    s = HOPMAYBEc(locinput, -scan->flags);
+		    if (!s || s < PL_bostr)
+			goto say_no;
+		    PL_reginput = s;
+		}
+		else {
+		    if (locinput < PL_bostr + scan->flags) 
+			goto say_no;
+		    PL_reginput = locinput - scan->flags;
+		    goto do_ifmatch;
+		}
 	    }
 	    else
 		PL_reginput = locinput;
@@ -2305,7 +2445,7 @@ regmatch(regnode *prog)
 	default:
 	    PerlIO_printf(PerlIO_stderr(), "%lx %d\n",
 			  (unsigned long)scan, OP(scan));
-	    FAIL("regexp memory corruption");
+	    croak("regexp memory corruption");
 	}
 	scan = next;
     }
@@ -2314,7 +2454,7 @@ regmatch(regnode *prog)
     * We get here only if there's trouble -- normally "case END" is
     * the terminating point.
     */
-    FAIL("corrupted regexp pointers");
+    croak("corrupted regexp pointers");
     /*NOTREACHED*/
     sayNO;
 
@@ -2601,7 +2741,7 @@ regrepeat_hard(regnode *p, I32 max, I32 *lp)
 }
 
 /*
- - regclass - determine if a character falls into a character class
+ - reginclass - determine if a character falls into a character class
  */
 
 STATIC bool