Re: [perl #20683] [fix] Better Patch

Message-ID: <20030223181639.GA18713@ratsnest.hole>

p4raw-id: //depot/perl@18782

9 files changed, 46 insertions, 11 deletions

diff --git a/embed.fnc b/embed.fnc
index 1866e1f2e1..90c93d027d 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -408,6 +408,7 @@ p	|int	|magic_setmglob	|SV* sv|MAGIC* mg
 p	|int	|magic_setnkeys	|SV* sv|MAGIC* mg
 p	|int	|magic_setpack	|SV* sv|MAGIC* mg
 p	|int	|magic_setpos	|SV* sv|MAGIC* mg
+p	|int	|magic_setregexp|SV* sv|MAGIC* mg
 p	|int	|magic_setsig	|SV* sv|MAGIC* mg
 p	|int	|magic_setsubstr|SV* sv|MAGIC* mg
 p	|int	|magic_settaint	|SV* sv|MAGIC* mg
diff --git a/embed.h b/embed.h
index a5bb315483..b4a4658150 100644
--- a/embed.h
+++ b/embed.h
@@ -580,6 +580,9 @@
 #define magic_setpos		Perl_magic_setpos
 #endif
 #ifdef PERL_CORE
+#define magic_setregexp		Perl_magic_setregexp
+#endif
+#ifdef PERL_CORE
 #define magic_setsig		Perl_magic_setsig
 #endif
 #ifdef PERL_CORE
@@ -3038,6 +3041,9 @@
 #define magic_setpos(a,b)	Perl_magic_setpos(aTHX_ a,b)
 #endif
 #ifdef PERL_CORE
+#define magic_setregexp(a,b)	Perl_magic_setregexp(aTHX_ a,b)
+#endif
+#ifdef PERL_CORE
 #define magic_setsig(a,b)	Perl_magic_setsig(aTHX_ a,b)
 #endif
 #ifdef PERL_CORE
diff --git a/ext/Devel/Peek/Peek.t b/ext/Devel/Peek/Peek.t
index a6b001c9cf..30d4e623b3 100644
--- a/ext/Devel/Peek/Peek.t
+++ b/ext/Devel/Peek/Peek.t
@@ -264,7 +264,7 @@ do_test(15,
   RV = $ADDR
   SV = PVMG\\($ADDR\\) at $ADDR
     REFCNT = 1
-    FLAGS = \\(OBJECT,RMG\\)
+    FLAGS = \\(OBJECT,SMG\\)
     IV = 0
     NV = 0
     PV = 0
diff --git a/mg.c b/mg.c
index 58a5cd5460..c0f6c16590 100644
--- a/mg.c
+++ b/mg.c
@@ -1818,6 +1818,13 @@ Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
 }
 
 int
+Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
+{
+    sv_unmagic(sv, PERL_MAGIC_qr);
+    return 0;
+}
+
+int
 Perl_magic_freeregexp(pTHX_ SV *sv, MAGIC *mg)
 {
     regexp *re = (regexp *)mg->mg_obj;
diff --git a/perl.h b/perl.h
index f5a4d98467..da62eb4c23 100644
--- a/perl.h
+++ b/perl.h
@@ -3487,7 +3487,7 @@ EXT MGVTBL PL_vtbl_defelem = {MEMBER_TO_FPTR(Perl_magic_getdefelem),
     					MEMBER_TO_FPTR(Perl_magic_setdefelem),
 					0,	0,	0};
 
-EXT MGVTBL PL_vtbl_regexp = {0,0,0,0, MEMBER_TO_FPTR(Perl_magic_freeregexp)};
+EXT MGVTBL PL_vtbl_regexp = {0, MEMBER_TO_FPTR(Perl_magic_setregexp),0,0, MEMBER_TO_FPTR(Perl_magic_freeregexp)};
 EXT MGVTBL PL_vtbl_regdata = {0, 0, MEMBER_TO_FPTR(Perl_magic_regdata_cnt), 0, 0};
 EXT MGVTBL PL_vtbl_regdatum = {MEMBER_TO_FPTR(Perl_magic_regdatum_get),
 			       MEMBER_TO_FPTR(Perl_magic_regdatum_set), 0, 0, 0};
diff --git a/proto.h b/proto.h
index ec3fd342e7..976ff9c9c6 100644
--- a/proto.h
+++ b/proto.h
@@ -444,6 +444,7 @@ PERL_CALLCONV int	Perl_magic_setmglob(pTHX_ SV* sv, MAGIC* mg);
 PERL_CALLCONV int	Perl_magic_setnkeys(pTHX_ SV* sv, MAGIC* mg);
 PERL_CALLCONV int	Perl_magic_setpack(pTHX_ SV* sv, MAGIC* mg);
 PERL_CALLCONV int	Perl_magic_setpos(pTHX_ SV* sv, MAGIC* mg);
+PERL_CALLCONV int	Perl_magic_setregexp(pTHX_ SV* sv, MAGIC* mg);
 PERL_CALLCONV int	Perl_magic_setsig(pTHX_ SV* sv, MAGIC* mg);
 PERL_CALLCONV int	Perl_magic_setsubstr(pTHX_ SV* sv, MAGIC* mg);
 PERL_CALLCONV int	Perl_magic_settaint(pTHX_ SV* sv, MAGIC* mg);
diff --git a/regexec.c b/regexec.c
index 4135d3622f..ebe7883b60 100644
--- a/regexec.c
+++ b/regexec.c
@@ -2867,13 +2867,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);
@@ -2890,7 +2894,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;
diff --git a/sv.c b/sv.c
index b132a1e6f3..d9d0e6fab4 100644
--- a/sv.c
+++ b/sv.c
@@ -2966,7 +2966,7 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags)
 		case SVt_PVMG:
 		    if ( ((SvFLAGS(sv) &
 			   (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
-			  == (SVs_OBJECT|SVs_RMG))
+			  == (SVs_OBJECT|SVs_SMG))
 			 && (mg = mg_find(sv, PERL_MAGIC_qr))) {
 			regexp *re = (regexp *)mg->mg_obj;
 
diff --git a/t/op/pat.t b/t/op/pat.t
index fe70e12725..40a265882c 100755
--- a/t/op/pat.t
+++ b/t/op/pat.t
@@ -6,7 +6,7 @@
 
 $| = 1;
 
-print "1..988\n";
+print "1..990\n";
 
 BEGIN {
     chdir 't' if -d 't';
@@ -3108,5 +3108,20 @@ ok("bbbbac" =~ /$pattern/ && $1 eq 'a', "[perl #3547]");
     ok ( "0" =~ /\p{N}+\z/, "[perl #19767] variant test" );
 }
 
-# last test 988
+{
+
+    $p = 1;
+    foreach (1,2,3,4) {
+	    $p++ if /(??{ $p })/
+    }
+    ok ($p == 5, "[perl #20683] (??{ }) returns stale values");
+    { package P; $a=1; sub TIESCALAR { bless[] } sub FETCH { $a++ } }
+    tie $p, P;
+    foreach (1,2,3,4) {
+	    /(??{ $p })/
+    }
+    ok ( $p == 5, "(??{ }) returns stale values");
+}
+
+# last test 990