Blob Blame Raw
diff -up perl-5.8.8/embed.fnc.U32025 perl-5.8.8/embed.fnc
--- perl-5.8.8/embed.fnc.U32025	2008-08-27 10:32:39.000000000 -0400
+++ perl-5.8.8/embed.fnc	2008-08-27 10:33:11.000000000 -0400
@@ -1277,6 +1277,9 @@ s	|bool	|utf8_mg_pos	|NN SV *sv|NN MAGIC
 s	|bool	|utf8_mg_pos_init	|NN SV *sv|NN MAGIC **mgp \
 				|NN STRLEN **cachep|I32 i|I32 offsetp \
 				|NN const U8 *s|NN const U8 *start
+s	|U32	|process_sub	|NN CV *const current_sub|U32 how_many_in_pad \
+				|NN const SV *const target|NN SV *const rv \
+				|const bool on
 s	|void	|reset_amagic	|NN SV *rv|const bool on
 #endif
 
diff -up perl-5.8.8/embed.h.U32025 perl-5.8.8/embed.h
--- perl-5.8.8/embed.h.U32025	2008-08-27 10:33:27.000000000 -0400
+++ perl-5.8.8/embed.h	2008-08-27 10:34:01.000000000 -0400
@@ -1349,6 +1349,7 @@
 #ifdef PERL_CORE
 #define utf8_mg_pos		S_utf8_mg_pos
 #define utf8_mg_pos_init	S_utf8_mg_pos_init
+#define process_sub		S_process_sub
 #define reset_amagic		S_reset_amagic
 #endif
 #endif
@@ -3393,6 +3394,7 @@
 #ifdef PERL_CORE
 #define utf8_mg_pos(a,b,c,d,e,f,g,h,i)	S_utf8_mg_pos(aTHX_ a,b,c,d,e,f,g,h,i)
 #define utf8_mg_pos_init(a,b,c,d,e,f,g)	S_utf8_mg_pos_init(aTHX_ a,b,c,d,e,f,g)
+#define process_sub(a,b,c,d,e)	S_process_sub(aTHX_ a,b,c,d,e)
 #define reset_amagic(a,b)	S_reset_amagic(aTHX_ a,b)
 #endif
 #endif
diff -up perl-5.8.8/proto.h.U32025 perl-5.8.8/proto.h
--- perl-5.8.8/proto.h.U32025	2008-08-27 10:34:10.000000000 -0400
+++ perl-5.8.8/proto.h	2008-08-27 10:34:42.000000000 -0400
@@ -1876,6 +1876,7 @@ STATIC I32	S_expect_number(pTHX_ char** 
 #
 STATIC bool	S_utf8_mg_pos(pTHX_ SV *sv, MAGIC **mgp, STRLEN **cachep, I32 i, I32 *offsetp, I32 uoff, const U8 **sp, const U8 *start, const U8 *send);
 STATIC bool	S_utf8_mg_pos_init(pTHX_ SV *sv, MAGIC **mgp, STRLEN **cachep, I32 i, I32 offsetp, const U8 *s, const U8 *start);
+STATIC U32	S_process_sub(pTHX_ CV *const current_sub, U32 how_many_in_pad, const SV *const target, SV *const rv, const bool on);
 STATIC void	S_reset_amagic(pTHX_ SV *rv, const bool on);
 #endif
 
diff -up perl-5.8.8/sv.c.U32025 perl-5.8.8/sv.c
--- perl-5.8.8/sv.c.U32025	2008-08-27 10:28:34.000000000 -0400
+++ perl-5.8.8/sv.c	2008-08-27 10:32:28.000000000 -0400
@@ -7993,6 +7993,47 @@ Perl_sv_setref_pvn(pTHX_ SV *rv, const c
     return rv;
 }
 
+/* For this subroutine, for each level of recursion, check the pad for either
+   direct pointers to the target object, or perl references to it.
+   We assume that arrays and hashes (and deeper structures) in lexicals
+   rarely point to objects.  */
+static U32
+S_process_sub(pTHX_ CV *const current_sub, U32 how_many_in_pad,
+	      const SV *const target, SV *const rv, const bool on) {
+    AV *const padlist = CvPADLIST(current_sub);
+    long depth = CvDEPTH(current_sub);
+
+    while (depth > 0) {
+	AV *const curpad = (AV*) AvARRAY(padlist)[depth];
+	SV ** const start = AvARRAY(curpad);
+	SV ** end = start + AvFILLp(curpad);
+
+	while (end >= start) {
+	    SV *const sv = *end--;
+	    if (sv == target) {
+		if (--how_many_in_pad == 0) {
+		    /* We have found them all.  */
+		    return 0;
+		}
+	    } else if ((sv->sv_flags & SVf_ROK) == SVf_ROK
+		       && SvRV(sv) == target
+		       && sv != rv) {
+		if (on)
+		    SvAMAGIC_on(sv);
+		else
+		    SvAMAGIC_off(sv);
+		if (--how_many_in_pad == 0) {
+		    /* We have found them all.  */
+		    return 0;
+		}
+	    }
+	}
+	--depth;
+    };
+    return how_many_in_pad;
+}
+
+
 /* This is a hack to cope with reblessing from class with overloading magic to
    one without (or the other way).  Search for every reference pointing to the
    object.  Can't use S_visit() because we would need to pass a parameter to
@@ -8031,6 +8072,11 @@ S_reset_amagic(pTHX_ SV *rv, const bool 
        the object (but no arrays, hashes, pads, typeglobs or other things)
        pointing to it.
 
+       Actually, need to extend that to any pad in the call chain, and any
+       temporaries. Fortunately, we can do this in a way that doesn't involve
+       visiting any location twice, so we don't need to keep track of what
+       we've seen.
+
        The first case is likely to involve quite a small search.
        The second case is O(n) on the number of SVs, but we can make it
        terminate early if we find every reference is accounted for by an RV.
@@ -8039,7 +8085,7 @@ S_reset_amagic(pTHX_ SV *rv, const bool 
     {
 	/* So before trying the large O(n) linear search of all SVs, start by
 	   seeing if we can find the other references as temporaries on the
-	   stack or in the current pad.
+	   stack or in the pads of the current subroutine call chain.
 
 	   This avoids the big search for constructions such as
 	   my $string = ...;
@@ -8060,9 +8106,7 @@ S_reset_amagic(pTHX_ SV *rv, const bool 
 			/* We have found them all.  */
 			return;
 		    }
-		} else if (SvTYPE(sv) != SVTYPEMASK
-			   && (sv->sv_flags & SVf_ROK) == SVf_ROK
-			   && SvREFCNT(sv)
+		} else if ((sv->sv_flags & SVf_ROK) == SVf_ROK
 			   && SvRV(sv) == target
 			   && sv != rv) {
 		    if (on)
@@ -8079,26 +8123,50 @@ S_reset_amagic(pTHX_ SV *rv, const bool 
 	}
 
 	{
-	CV *const current_sub = find_runcv(NULL);
-	AV *const padlist = CvPADLIST(current_sub);
-	AV *const curpad = (AV*) AvARRAY(padlist)[CvDEPTH(current_sub)];
-	SV ** const start = AvARRAY(curpad);
-	SV ** end = start + AvFILLp(curpad);
+	    /* This code is pilfered from Perl_find_runcv  */
+	    PERL_SI	 *si;
 
-	while (end >= start) {
-	    SV *const sv = *end--;
-	    if (sv == target) {
-		if (--how_many_in_pad == 0) {
+	    for (si = PL_curstackinfo; si; si = si->si_prev) {
+		I32 ix;
+		for (ix = si->si_cxix; ix >= 0; ix--) {
+		    const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
+		    if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
+			CV * const cv = cx->blk_sub.cv;
+			/* Process all levels of recursion the first time we
+			   see a subroutine.  */
+			if (cx->blk_sub.olddepth + 1 == CvDEPTH(cv)) {
+			    how_many_in_pad = process_sub(cv, how_many_in_pad,
+							  target, rv, on);
+			    if (how_many_in_pad == 0) {
+				/* We have found them all.  */
+				return;
+			    }
+			}
+		    }
+		    else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx)) {
+			how_many_in_pad
+			    = process_sub(PL_compcv, how_many_in_pad, target,
+					  rv, on);
+			if (how_many_in_pad == 0) {
+			    /* We have found them all.  */
+			    return;
+			}
+		    }
+		}
+		how_many_in_pad
+		    = process_sub(PL_main_cv, how_many_in_pad, target, rv, on);
+		if (how_many_in_pad == 0) {
 		    /* We have found them all.  */
 		    return;
 		}
 	    }
 	}
-	}
     }
 
-    /* Right, didn't find all the other referneces were lexicals or temporaries
+    /* Right, didn't find all the other references were lexicals or temporaries
        in the pad, so need to do an exhaustive search to find all references.
+       It doesn't matter if we've already set the AMAGIC flag to the correct
+       value on some of the other references.
     */
 
     for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) {