X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=regexec.c;h=a3c7a7d6687f3165d8ddf07a03493024f6325e7e;hb=2a551100939323428e5b071089d183aafb961137;hp=157f426ac410cef33d0af5aa160da76b9cebedbf;hpb=cfc92286f9931e1e2fde8dfa311d278a597d5df9;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/regexec.c b/regexec.c
index 157f426..a3c7a7d 100644
--- a/regexec.c
+++ b/regexec.c
@@ -67,7 +67,8 @@
  *
  ****    Alterations to Henry's code are...
  ****
- ****    Copyright (c) 1991-2002, Larry Wall
+ ****    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
+ ****    2000, 2001, 2002, 2003, by Larry Wall and others
  ****
  ****    You may distribute under the terms of either the GNU General Public
  ****    License or the Artistic License, as specified in the README file.
@@ -400,6 +401,7 @@ Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos,
     char *i_strpos = strpos;
     SV *dsv = PERL_DEBUG_PAD_ZERO(0);
 #endif
+    RX_MATCH_UTF8_set(prog,do_utf8);
 
     if (prog->reganch & ROPT_UTF8) {
 	DEBUG_r(PerlIO_printf(Perl_debug_log,
@@ -543,7 +545,7 @@ Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos,
 	    goto fail_finish;
 	/* we may be pointing at the wrong string */
 	if (s && RX_MATCH_COPIED(prog))
-	    s = prog->subbeg + (s - SvPVX(sv));
+	    s = strbeg + (s - SvPVX(sv));
 	if (data)
 	    *data->scream_olds = s;
     }
@@ -851,10 +853,7 @@ Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos,
 	char *startpos = strbeg;
 
 	t = s;
-	if (prog->reganch & ROPT_UTF8) {	
-	    PL_regdata = prog->data;
-	    PL_bostr = startpos;
-	}
+	cache_re(prog);
 	s = find_byclass(prog, prog->regstclass, s, endpos, startpos, 1);
 	if (!s) {
 #ifdef DEBUGGING
@@ -1615,6 +1614,7 @@ Perl_regexec_flags(pTHX_ register regexp *prog, char *stringarg, register char *
     SV *dsv0 = PERL_DEBUG_PAD_ZERO(0);
     SV *dsv1 = PERL_DEBUG_PAD_ZERO(1);
 #endif
+    RX_MATCH_UTF8_set(prog,do_utf8);
 
     PL_regcc = 0;
 
@@ -1863,7 +1863,7 @@ Perl_regexec_flags(pTHX_ register regexp *prog, char *stringarg, register char *
 				  PL_multiline ? FBMrf_MULTILINE : 0))) ) {
 	    /* we may be pointing at the wrong string */
 	    if ((flags & REXEC_SCREAM) && RX_MATCH_COPIED(prog))
-		s = prog->subbeg + (s - SvPVX(sv));
+		s = strbeg + (s - SvPVX(sv));
 	    DEBUG_r( did_match = 1 );
 	    if (HOPc(s, -back_max) > last1) {
 		last1 = HOPc(s, -back_min);
@@ -1952,7 +1952,7 @@ Perl_regexec_flags(pTHX_ register regexp *prog, char *stringarg, register char *
 		    last = scream_olds; /* Only one occurrence. */
 		/* we may be pointing at the wrong string */
 		else if (RX_MATCH_COPIED(prog))
-		    s = prog->subbeg + (s - SvPVX(sv));
+		    s = strbeg + (s - SvPVX(sv));
 	    }
 	    else {
 		STRLEN len;
@@ -2020,17 +2020,28 @@ got_it:
 
     /* make sure $`, $&, $', and $digit will work later */
     if ( !(flags & REXEC_NOT_FIRST) ) {
-	if (RX_MATCH_COPIED(prog)) {
-	    Safefree(prog->subbeg);
-	    RX_MATCH_COPIED_off(prog);
-	}
+	RX_MATCH_COPY_FREE(prog);
 	if (flags & REXEC_COPY_STR) {
 	    I32 i = PL_regeol - startpos + (stringarg - strbeg);
-
-	    s = savepvn(strbeg, i);
-	    prog->subbeg = s;
+#ifdef PERL_COPY_ON_WRITE
+	    if ((SvIsCOW(sv)
+		 || (SvFLAGS(sv) & CAN_COW_MASK) == CAN_COW_FLAGS)) {
+		if (DEBUG_C_TEST) {
+		    PerlIO_printf(Perl_debug_log,
+				  "Copy on write: regexp capture, type %d\n",
+				  (int) SvTYPE(sv));
+		}
+		prog->saved_copy = sv_setsv_cow(prog->saved_copy, sv);
+		prog->subbeg = SvPVX(prog->saved_copy);
+		assert (SvPOKp(prog->saved_copy));
+	    } else
+#endif
+	    {
+		RX_MATCH_COPIED_on(prog);
+		s = savepvn(strbeg, i);
+		prog->subbeg = s;
+	    }
 	    prog->sublen = i;
-	    RX_MATCH_COPIED_on(prog);
 	}
 	else {
 	    prog->subbeg = strbeg;
@@ -2120,6 +2131,9 @@ S_regtry(pTHX_ regexp *prog, char *startpos)
 		$` inside (?{}) could fail... */
 	    PL_reg_oldsaved = prog->subbeg;
 	    PL_reg_oldsavedlen = prog->sublen;
+#ifdef PERL_COPY_ON_WRITE
+	    PL_nrs = prog->saved_copy;
+#endif
 	    RX_MATCH_COPIED_off(prog);
 	}
 	else
@@ -2850,13 +2864,17 @@ S_regmatch(pTHX_ regnode *prog)
 		    re_cc_state state;
 		    CHECKPOINT cp, lastcp;
                     int toggleutf;
+		    register SV *sv;
 
-		    if(SvROK(ret) || SvRMAGICAL(ret)) {
-			SV *sv = SvROK(ret) ? SvRV(ret) : ret;
-
-			if(SvMAGICAL(sv))
-			    mg = mg_find(sv, PERL_MAGIC_qr);
+		    if(SvROK(ret) && SvSMAGICAL(sv = SvRV(ret)))
+			mg = mg_find(sv, PERL_MAGIC_qr);
+		    else if (SvSMAGICAL(ret)) {
+			if (SvGMAGICAL(ret))
+			    sv_unmagic(ret, PERL_MAGIC_qr);
+			else
+			    mg = mg_find(ret, PERL_MAGIC_qr);
 		    }
+
 		    if (mg) {
 			re = (regexp *)mg->mg_obj;
 			(void)ReREFCNT_inc(re);
@@ -2873,7 +2891,8 @@ S_regmatch(pTHX_ regnode *prog)
                         if (DO_UTF8(ret)) pm.op_pmdynflags |= PMdf_DYN_UTF8;
 			re = CALLREGCOMP(aTHX_ t, t + len, &pm);
 			if (!(SvFLAGS(ret)
-			      & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)))
+			      & (SVs_TEMP | SVs_PADTMP | SVf_READONLY
+				| SVs_GMG)))
 			    sv_magic(ret,(SV*)ReREFCNT_inc(re),
 					PERL_MAGIC_qr,0,0);
 			PL_regprecomp = oprecomp;
@@ -4552,6 +4571,9 @@ restore_pos(pTHX_ void *arg)
 	if (PL_reg_oldsaved) {
 	    PL_reg_re->subbeg = PL_reg_oldsaved;
 	    PL_reg_re->sublen = PL_reg_oldsavedlen;
+#ifdef PERL_COPY_ON_WRITE
+	    PL_reg_re->saved_copy = PL_nrs;
+#endif
 	    RX_MATCH_COPIED_on(PL_reg_re);
 	}
 	PL_reg_magic->mg_len = PL_reg_oldpos;