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

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

p4raw-id: //depot/perl@18782

diff --git a/embed.fnc b/embed.fnc
index 1866e1f..90c93d0 100644 (file)
--- 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 a5bb315..b4a4658 100644 (file)
--- 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 a6b001c..30d4e62 100644 (file)
--- 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 58a5cd5..c0f6c16 100644 (file)
--- 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 f5a4d98..da62eb4 100644 (file)
--- 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 ec3fd34..976ff9c 100644 (file)
--- 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 4135d36..ebe7883 100644 (file)
--- 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 b132a1e..d9d0e6f 100644 (file)
--- 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 fe70e12..40a2658 100755 (executable)
--- 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