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)) {