-
Notifications
You must be signed in to change notification settings - Fork 542
New issue
Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.
By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.
Already on GitHub? Sign in to your account
Symbol::delete_package does not free certain memory associated with package::ISA #10392
Comments
From dev@airwave.comWe find it convenient to construct dynamic packages in our code for various purposes, and have created internal tools for manipulating these packages. We have found that the use of these packages seems to be associated with memory leaks which impair our code's operation when it runs for weeks or months at a time, and believe we have tracked the problem to a deficiency in Symbol::delete_package. When we call Symbol::delete_package, we expect that all traces of the package in question would disappear. (We recognize that the package is not removed from %INC and manage to do so ourselves.) However, it seems that there is still some memory left over which is not freed. The memory appears to be located somewhere in Perl-guts (we have tried to track it with Devel::Leak and found nothing) and seems to be associated with the contents of the magic @ISA variable in the package: somewhere about 80 bytes per package if @ISA contains a single empty string, more if there is a more complicated inheritance pattern, none if @ISA is the empty list. A script to reproduce this issue follows. This code not only leaks memory on our internal build of Perl 5.10.1, but we have also found it to leak on stock perl 5.8.8 from CentOS and on stock perl 5.10.1 on Ubuntu 10.04. (The script uses the Linux/proc/ filesystem as a convenient way to display memory usage; I'm sure that it can be adapted to another platform readily enough). use strict; use Symbol; @a::ISA = qw(UNIVERSAL); my $leak_more = 1; # my $handle; for my $count (0..20_000) { memstats() unless $count % 5000; # Devel::Leak::CheckSV($handle); sub memstats { Perl Info
|
From dev@airwave.comFor completeness (and to see whether an upgrade would make the problem |
dev@airwave.com - Status changed from 'new' to 'open' |
From dev@airwave.comwhoops! i think that's *your* workflow I just clicked. |
dev@airwave.com - Status changed from 'open' to 'new' |
From webmasters@ctosonline.orgThis was caused by change 31239/70cd14 which fixes *ISA=[] to call mro_isa_changed_in. The actual underlying cause is explained in mro’s manpage, under mro::get_isarev: Currently, this list only grows, it never shrinks. This was a If it doesn’t happen often, then the cost will not be incurred very often. Normally, the list of parent classes is cached, so Perl_mro_isa_changed_in can be made to compare it with the new list and delete isarev entries as appropriate. This may not be very efficient, but, again, it won’t happen very often, as the existing cached list will normally be empty. S_hfreeentries is the only other routine that clears the cache, so I can make that remove isarev entries, too. If I write a patch for this, is there any remote possibility of its being applied, or would it be a waste of time? Another possibility for fixing this particular case is to add a function to mro:: for deleting isarev entries for particular classes. Then Symbol::delete_package could be made to use that. |
The RT System itself - Status changed from 'new' to 'open' |
From @nwc10On Sun, Jul 25, 2010 at 12:57:02PM -0700, webmasters@ctosonline.org wrote:
The documentation you quoted continues with: The fact that a class which no longer truly "isa" this class at Yes, finding an efficient way to fix this would be useful and welcomed. Nicholas Clark |
From @cpansproutOn Jul 27, 2010, at 7:25 AM, Nicholas Clark wrote:
OK, now for the next set of questions: This script shows a regression in 5.10, with regard to stash assignments. I can rearrange packages to my heart’s content without triggering mro_isa_changed_in. @a'ISA = 'b'; sub c'bark { warn "Woof!" } $a = bless [], a; @e'ISA = 'd'; $a->bark; # Woof! in 5.10; Bow-wow! in 5.8 print *{"b::"},"\n"; # Shows that it still thinks it is *e:: For my proposed isarev changes to work, every stash (or the glob containing the stash) needs to know whether it is still part of the main stash hierarchy, or whether it has been orphaned, so that it won’t delete isarev entries that do not belong to it. In the script above, ‘delete $::{'b::'}’ needs to trigger mro_isa_changed_in and the return value flagged such that it knows not to For instance, c and d could both inherit from f. Without such a flag, @{*{$$b{'ISA::'}}{ARRAY}} = () will remove a from f’s isarev, which shouldn’t happen. The flags on SVs seem to be a rather crowded space. Am I right in thinking hashes cannot have get-magic? If that is the case, I can re-use SVs_GMG for this purpose. And then each stash needs to know its effective name, as opposed to its original name (see the last line of the script above). What would be the best way to do this? Store it in magic? |
From @nwc10On Sun, Aug 01, 2010 at 12:17:36PM -0700, Father Chrysostomos wrote: [snip pathological but interesting example]
I don't know with 100% certainty, but I see tests on SvGMAGICAL() in hv.c, if (vtbl->svt_get && !(mg->mg_flags & MGf_GSKIP)) and magic vtables in perl.h which have the svt_get function pointer set, such MGVTBL_SET( so I'm assuming that yes, it is used.
Having any magic on all stashes is a measurable performance hit. For a while Also, if it's easier to implement, I don't see a problem with using the global Nicholas Clark |
From @cpansproutOn Aug 2, 2010, at 2:34 AM, Nicholas Clark wrote:
If you are suggesting adding new fields to the xpvhv_aux struct, what do I need to know about alignment issues? (After doing some research, it now looks as though I just need one more field; viz., a HEK* to store an alternate name.)
Doesn’t that just affect method caches? What about isa caches? Looking through the isa code, I haven’t yet seen anything that checks PL_sub_generation, but I may have missed it. If PL_sub_generation does not invalidate isa caches, would it be appropriate to add a new PL_isa_generation variable?
And I now realise that such would be very inefficient anyway, as nested classes have nothing to do with inheritance. (*p:: = *PPI:: would have to iterate through 94 packages, recalculating the linear isa cache, etc. *p:: = delete $::{"PPI"} would do that iteration twice.) Father Chrysostomos |
From @cpansproutOn Aug 8, 2010, at 12:22 PM, Father Chrysostomos wrote:
Oops. I meant delete $::{"PPI::"}, of course. |
From @iabynOn Sun, Aug 08, 2010 at 12:22:13PM -0700, Father Chrysostomos wrote:
Note that hv_clear and hv_undef may remove the aux struct, so you may not -- |
From @cpansproutOn Aug 18, 2010, at 9:47 AM, Dave Mitchell wrote:
What happens to the name currently stored in there when that happens? |
From @cpansproutOn Aug 8, 2010, at 12:22 PM, Father Chrysostomos wrote:
I think we will have to live with this inefficiency. Anyway, most of the time I alias packages, it’s just for a few. The most common example in my code is ‘use DDS’ which loads DDS.pm, which aliases DDS:: to Data'Dump'Streamer::. |
From @cpansproutInline Patchdiff -Nup blead-75176-isarev0/MANIFEST blead-75176-isarev1/MANIFEST
--- blead-75176-isarev0/MANIFEST 2010-08-20 23:12:47.000000000 -0700
+++ blead-75176-isarev1/MANIFEST 2010-06-23 22:24:35.000000000 -0700
@@ -4356,7 +4356,6 @@ t/mro/package_aliases.t mro tests
t/mro/pkg_gen.t mro tests
t/mro/recursion_c3.t mro tests
t/mro/recursion_dfs.t mro tests
-t/mro/stash-manip.t Test stash manipulation & inheritance
t/mro/vulcan_c3.t mro tests
t/mro/vulcan_dfs.t mro tests
toke.c The tokener
diff -Nup blead-75176-isarev0/dump.c blead-75176-isarev1/dump.c
--- blead-75176-isarev0/dump.c 2010-06-03 05:53:11.000000000 -0700
+++ blead-75176-isarev1/dump.c 2010-08-20 22:56:59.000000000 -0700
@@ -1867,7 +1867,11 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO
dumpops, pvlim);
}
if (meta->isa) {
- Perl_dump_indent(aTHX_ level, file, " ISA = 0x%"UVxf"\n",
+ Perl_dump_indent(aTHX_
+ level, file,
+ meta->isa_gen == PL_isa_generation
+ ? " ISA = 0x%"UVxf"\n"
+ : " ISA = 0x%"UVxf (stale)"\n",
PTR2UV(meta->isa));
do_sv_dump(level+1, file, MUTABLE_SV(meta->isa), nest+1, maxnest,
dumpops, pvlim);
diff -Nup blead-75176-isarev0/embedvar.h blead-75176-isarev1/embedvar.h
--- blead-75176-isarev0/embedvar.h 2010-06-04 09:14:20.000000000 -0700
+++ blead-75176-isarev1/embedvar.h 2010-08-14 06:25:25.000000000 -0700
@@ -160,6 +160,7 @@
#define PL_incgv (vTHX->Iincgv)
#define PL_initav (vTHX->Iinitav)
#define PL_inplace (vTHX->Iinplace)
+#define PL_isa_generation (vTHX->Iisa_generation)
#define PL_isarev (vTHX->Iisarev)
#define PL_known_layers (vTHX->Iknown_layers)
#define PL_last_in_gv (vTHX->Ilast_in_gv)
@@ -489,6 +490,7 @@
#define PL_Iincgv PL_incgv
#define PL_Iinitav PL_initav
#define PL_Iinplace PL_inplace
+#define PL_Iisa_generation PL_isa_generation
#define PL_Iisarev PL_isarev
#define PL_Iknown_layers PL_known_layers
#define PL_Ilast_in_gv PL_last_in_gv
diff -Nup blead-75176-isarev0/hv.c blead-75176-isarev1/hv.c
--- blead-75176-isarev0/hv.c 2010-06-05 05:47:09.000000000 -0700
+++ blead-75176-isarev1/hv.c 2010-08-20 20:41:21.000000000 -0700
@@ -712,6 +712,14 @@ Perl_hv_common(pTHX_ HV *hv, SV *keysv,
} else if (action & HV_FETCH_ISSTORE) {
SvREFCNT_dec(HeVAL(entry));
HeVAL(entry) = val;
+
+ /* If this is a stash and the key ends with ::, then some-
+ one is aliasing (or moving) a package. */
+ if (HvNAME(hv)) {
+ if (keysv) key = SvPV(keysv, klen);
+ if (key[klen-2] == ':' && key[klen-1] == ':')
+ MRO_INVALIDATE_ISA;
+ }
}
} else if (HeVAL(entry) == &PL_sv_placeholder) {
/* if we find a placeholder, we pretend we haven't found
@@ -1061,6 +1069,14 @@ S_hv_delete_common(pTHX_ HV *hv, SV *key
xhv->xhv_keys--; /* HvTOTALKEYS(hv)-- */
if (xhv->xhv_keys == 0)
HvHASKFLAGS_off(hv);
+
+ /* If this is a stash and the key ends with ::, then someone is
+ deleting a package. */
+ if (HvNAME(hv)) {
+ if (keysv) key = SvPV(keysv, klen);
+ if (key[klen-2] == ':' && key[klen-1] == ':')
+ MRO_INVALIDATE_ISA;
+ }
}
return sv;
}
diff -Nup blead-75176-isarev0/hv.h blead-75176-isarev1/hv.h
--- blead-75176-isarev0/hv.h 2010-05-21 12:02:12.000000000 -0700
+++ blead-75176-isarev1/hv.h 2010-08-20 22:53:07.000000000 -0700
@@ -59,15 +59,27 @@ struct mro_meta {
HV *mro_nextmethod; /* next::method caching */
U32 cache_gen; /* Bumping this invalidates our method cache */
U32 pkg_gen; /* Bumps when local methods/@ISA change */
+ /* When isa_gen differs from PL_isa_generation, then isa needs to be
+ updated. */
+ U32 isa_gen;
const struct mro_alg *mro_which; /* which mro alg is in use? */
HV *isa; /* Everything this class @ISA */
};
#define MRO_GET_PRIVATE_DATA(smeta, which) \
- (((smeta)->mro_which && (which) == (smeta)->mro_which) \
+ (( \
+ (smeta)->mro_which && (which) == (smeta)->mro_which \
+ && (smeta)->isa_gen == PL_isa_generation \
+ ) \
? (smeta)->mro_linear_current \
: Perl_mro_get_private_data(aTHX_ (smeta), (which)))
+#ifdef PERL_CORE
+ /* This needs to invalidate the sub cache as well as the isa cache, as the
+ former is obviously stale when the latter is. */
+ #define MRO_INVALIDATE_ISA ++PL_isa_generation, ++PL_sub_generation
+#endif
+
/* Subject to change.
Don't access this directly.
*/
diff -Nup blead-75176-isarev0/intrpvar.h blead-75176-isarev1/intrpvar.h
--- blead-75176-isarev0/intrpvar.h 2010-06-07 10:25:10.000000000 -0700
+++ blead-75176-isarev1/intrpvar.h 2010-08-14 06:24:33.000000000 -0700
@@ -335,6 +335,7 @@ PERLVAR(Icheckav, AV *) /* names of CHE
PERLVAR(Iinitav, AV *) /* names of INIT subroutines */
PERLVAR(Istrtab, HV *) /* shared string table */
PERLVARI(Isub_generation,U32,1) /* incr to invalidate method cache */
+PERLVARI(Iisa_generation,U32,1) /* incr to invalidate isa caches */
/* funky return mechanisms */
PERLVAR(Iforkprocess, int) /* so do_open |- can return proc# */
diff -Nup blead-75176-isarev0/mro.c blead-75176-isarev1/mro.c
--- blead-75176-isarev0/mro.c 2010-05-24 08:49:15.000000000 -0700
+++ blead-75176-isarev1/mro.c 2010-08-20 23:05:09.000000000 -0700
@@ -37,6 +37,22 @@ Perl_mro_get_private_data(pTHX_ struct m
SV **data;
PERL_ARGS_ASSERT_MRO_GET_PRIVATE_DATA;
+ /* If the isa caches have been invalidated, free any existing private
+ data to avoid leaks the next time they are set. */
+ if (smeta->isa_gen != PL_isa_generation) {
+ if (smeta->mro_linear_all) {
+ SvREFCNT_dec(MUTABLE_SV(smeta->mro_linear_all));
+ smeta->mro_linear_all = NULL;
+ /* This is just acting as a shortcut pointer. */
+ smeta->mro_linear_current = NULL;
+ } else if (smeta->mro_linear_current) {
+ /* Only the current MRO is stored, so this owns the data. */
+ SvREFCNT_dec(smeta->mro_linear_current);
+ smeta->mro_linear_current = NULL;
+ }
+ return NULL;
+ }
+
data = (SV **)Perl_hv_common(aTHX_ smeta->mro_linear_all, NULL,
which->name, which->length, which->kflags,
HV_FETCH_JUST_SV, NULL, which->hash);
@@ -63,6 +79,7 @@ Perl_mro_set_private_data(pTHX_ struct m
memory on a hash with 1 element - store it direct, and signal
this by leaving the would-be-hash NULL. */
smeta->mro_linear_current = data;
+ smeta->isa_gen = PL_isa_generation;
return data;
} else {
HV *const hv = newHV();
@@ -86,6 +103,7 @@ Perl_mro_set_private_data(pTHX_ struct m
/* If we've been asked to store the private data for the current MRO,
then cache it. */
smeta->mro_linear_current = data;
+ smeta->isa_gen = PL_isa_generation;
}
if (!Perl_hv_common(aTHX_ smeta->mro_linear_all, NULL,
@@ -142,6 +160,7 @@ Perl_mro_meta_init(pTHX_ HV* stash)
HvAUX(stash)->xhv_mro_meta = newmeta;
newmeta->cache_gen = 1;
newmeta->pkg_gen = 1;
+ newmeta->isa_gen = 0;
newmeta->mro_which = &dfs_alg;
return newmeta;
@@ -177,7 +196,10 @@ Perl_mro_meta_dup(pTHX_ struct mro_meta*
= MUTABLE_HV(sv_dup_inc((const SV *)newmeta->mro_nextmethod, param));
if (newmeta->isa)
newmeta->isa
- = MUTABLE_HV(sv_dup_inc((const SV *)newmeta->isa, param));
+ /* Skip cloning ->isa if isa_gen is off. */
+ = newmeta->isa_gen == PL_isa_generation
+ ? MUTABLE_HV(sv_dup_inc((const SV *)newmeta->isa, param))
+ : NULL;
return newmeta;
}
@@ -401,6 +423,13 @@ Perl_mro_get_linear_isa(pTHX_ HV *stash)
meta = HvMROMETA(stash);
if (!meta->mro_which)
Perl_croak(aTHX_ "panic: invalid MRO!");
+
+ /* Make sure meta->isa does not contain stale data after we return. */
+ if (meta->isa && meta->isa_gen != PL_isa_generation) {
+ SvREFCNT_dec(meta->isa);
+ meta->isa = NULL;
+ }
+
return meta->mro_which->resolve(aTHX_ stash, 0);
}
diff -Nup blead-75176-isarev0/perlapi.h blead-75176-isarev1/perlapi.h
--- blead-75176-isarev0/perlapi.h 2010-06-04 09:14:20.000000000 -0700
+++ blead-75176-isarev1/perlapi.h 2010-08-14 06:25:25.000000000 -0700
@@ -356,6 +356,8 @@ END_EXTERN_C
#define PL_initav (*Perl_Iinitav_ptr(aTHX))
#undef PL_inplace
#define PL_inplace (*Perl_Iinplace_ptr(aTHX))
+#undef PL_isa_generation
+#define PL_isa_generation (*Perl_Iisa_generation_ptr(aTHX))
#undef PL_isarev
#define PL_isarev (*Perl_Iisarev_ptr(aTHX))
#undef PL_known_layers
diff -Nup blead-75176-isarev0/sv.c blead-75176-isarev1/sv.c
--- blead-75176-isarev0/sv.c 2010-06-04 09:14:20.000000000 -0700
+++ blead-75176-isarev1/sv.c 2010-08-20 20:42:09.000000000 -0700
@@ -3609,7 +3609,7 @@ copy-ish functions and macros use this u
static void
S_glob_assign_glob(pTHX_ SV *const dstr, SV *const sstr, const int dtype)
{
- I32 mro_changes = 0; /* 1 = method, 2 = isa */
+ I32 mro_changes = 0; /* 1 = method, 2 = isa, 3 = PL_isa_generation */
PERL_ARGS_ASSERT_GLOB_ASSIGN_GLOB;
@@ -3655,8 +3655,16 @@ S_glob_assign_glob(pTHX_ SV *const dstr,
mro_changes = 1;
}
- if(strEQ(GvNAME((const GV *)dstr),"ISA"))
- mro_changes = 2;
+ {
+ const char * const name = GvNAME((const GV *)dstr);
+ if(strEQ(name,"ISA"))
+ mro_changes = 2;
+ else {
+ const STRLEN len = GvNAMELEN(sstr);
+ if (name[len-2] == ':' && name[len-1] == ':') mro_changes = 3;
+ }
+ }
+
gp_free(MUTABLE_GV(dstr));
isGV_with_GP_off(dstr);
@@ -3673,6 +3681,7 @@ S_glob_assign_glob(pTHX_ SV *const dstr,
}
GvMULTI_on(dstr);
if(mro_changes == 2) mro_isa_changed_in(GvSTASH(dstr));
+ else if(mro_changes == 3) MRO_INVALIDATE_ISA;
else if(mro_changes) mro_method_changed_in(GvSTASH(dstr));
return;
}
@@ -12255,6 +12264,7 @@ perl_clone_using(PerlInterpreter *proto_
PL_initav = av_dup_inc(proto_perl->Iinitav, param);
PL_sub_generation = proto_perl->Isub_generation;
+ PL_isa_generation = proto_perl->Iisa_generation;
PL_isarev = hv_dup_inc(proto_perl->Iisarev, param);
/* funky return mechanisms */
diff -Nup blead-75176-isarev0/universal.c blead-75176-isarev1/universal.c
--- blead-75176-isarev0/universal.c 2010-05-31 15:15:11.000000000 -0700
+++ blead-75176-isarev1/universal.c 2010-08-12 22:10:07.000000000 -0700
@@ -41,7 +41,7 @@ S_get_isa_hash(pTHX_ HV *const stash)
PERL_ARGS_ASSERT_GET_ISA_HASH;
- if (!meta->isa) {
+ if (!meta->isa || meta->isa_gen != PL_isa_generation) {
AV *const isa = mro_get_linear_isa(stash);
if (!meta->isa) {
HV *const isa_hash = newHV();
@@ -63,6 +63,7 @@ S_get_isa_hash(pTHX_ HV *const stash)
SvREADONLY_on(isa_hash);
meta->isa = isa_hash;
+ meta->isa_gen = PL_isa_generation;
}
}
return meta->isa;
@@ -78,7 +79,10 @@ S_isa_lookup(pTHX_ HV *stash, const char
{
dVAR;
const struct mro_meta *const meta = HvMROMETA(stash);
- HV *const isa = meta->isa ? meta->isa : S_get_isa_hash(aTHX_ stash);
+ HV *const isa
+ = meta->isa && meta->isa_gen == PL_isa_generation
+ ? meta->isa
+ : S_get_isa_hash(aTHX_ stash);
STRLEN len = strlen(name);
const HV *our_stash;
diff -Nurp blead-75176-isarev0/t/mro/stash-manip.t blead-75176-isarev1/t/mro/stash-manip.t
--- blead-75176-isarev0/t/mro/stash-manip.t 1969-12-31 16:00:00.000000000 -0800
+++ blead-75176-isarev1/t/mro/stash-manip.t 2010-08-20 20:43:31.000000000 -0700
@@ -0,0 +1,61 @@
+#!./perl
+
+use strict;
+#use warnings;
+BEGIN {
+ unless (-d 'blib') {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+ require q(./test.pl);
+}
+
+plan(tests => 4);
+
+
+# Test that replacing a package by assigning to a stash element invalidates
+# the isa caches
+{
+ @Pet::ISA = "Tike";
+ @Tike::ISA = "Barker";
+
+ sub Barker::speak { "Woof!" }
+ sub Latrator::speak { "Bow-wow!" }
+
+ my $pet = bless [], "Pet";
+
+ @Dog::ISA = 'Latrator';
+ my $tike_glob = $::{'Tike::'};
+ $::{'Tike::'} = $::{'Dog::'};
+
+ is $pet->speak, 'Bow-wow!', # Woof! in 5.10/12; Bow-wow! in 5.8 and 5.14
+ 'rearranging packages by assigning to a stash elem updates isa caches';
+
+ undef $tike_glob;
+ is $pet->speak, 'Bow-wow!',
+ 'isa caches are up to date after the replaced stash is freed';
+}
+
+# Another hylactic example: Test that deleting stash elements containing
+# subpackages also invalidates the isa cache.
+{
+ @Pet::ISA = ("Cur", "Hound");
+ @Cur::ISA = "Hylactete";
+
+ sub Hylactete::speak { "Arff!" }
+ sub Hound::speak { "Woof!" }
+
+ my $pet = bless [], "Pet";
+
+ my $life_raft = delete $::{'Cur::'};
+
+ is $pet->speak, 'Woof!',
+ 'deleting a stash from its parent stash invalidates the isa caches';
+
+ undef $life_raft;
+ is $pet->speak, 'Woof!',
+ 'the deleted stash is gone completely when freed';
+}
+
+
+ |
From @cpansproutInline Patchdiff -Nup blead-75176-isarev0/embed.fnc blead-75176-isarev1/embed.fnc
--- blead-75176-isarev0/embed.fnc 2010-06-13 07:28:11.000000000 -0700
+++ blead-75176-isarev1/embed.fnc 2010-08-22 17:10:15.000000000 -0700
@@ -2361,6 +2361,7 @@ sd |AV* |mro_get_linear_isa_dfs|NN HV* s
: Used in hv.c, mg.c, pp.c, sv.c
pd |void |mro_isa_changed_in|NN HV* stash
Apd |void |mro_method_changed_in |NN HV* stash
+pdx |void |mro_package_moved |NN const HV *stash
: Only used in perl.c
p |void |boot_core_mro
Apon |void |sys_init |NN int* argc|NN char*** argv
diff -Nup blead-75176-isarev0/embed.h blead-75176-isarev1/embed.h
--- blead-75176-isarev0/embed.h 2010-06-05 15:42:10.000000000 -0700
+++ blead-75176-isarev1/embed.h 2010-08-22 11:16:16.000000000 -0700
@@ -2052,6 +2052,7 @@
#endif
#define mro_method_changed_in Perl_mro_method_changed_in
#ifdef PERL_CORE
+#define mro_package_moved Perl_mro_package_moved
#define boot_core_mro Perl_boot_core_mro
#endif
#if defined(USE_ITHREADS)
@@ -4501,6 +4502,7 @@
#endif
#define mro_method_changed_in(a) Perl_mro_method_changed_in(aTHX_ a)
#ifdef PERL_CORE
+#define mro_package_moved(a) Perl_mro_package_moved(aTHX_ a)
#define boot_core_mro() Perl_boot_core_mro(aTHX)
#endif
#ifdef PERL_CORE
diff -Nup blead-75176-isarev0/hv.c blead-75176-isarev1/hv.c
--- blead-75176-isarev0/hv.c 2010-06-05 05:47:09.000000000 -0700
+++ blead-75176-isarev1/hv.c 2010-08-22 14:55:08.000000000 -0700
@@ -710,8 +710,32 @@ Perl_hv_common(pTHX_ HV *hv, SV *keysv,
}
HeVAL(entry) = val;
} else if (action & HV_FETCH_ISSTORE) {
- SvREFCNT_dec(HeVAL(entry));
+ bool moving_package = FALSE;
+ SV *old_val = HeVAL(entry);
+
+ /* If this is a stash and the key ends with ::, then some-
+ one is aliasing (or moving) a package. */
+ if (HvNAME(hv)) {
+ if (keysv) key = SvPV(keysv, klen);
+ if (klen > 1
+ && key[klen-2] == ':' && key[klen-1] == ':') {
+ if(SvTYPE(old_val) == SVt_PVGV) {
+ const HV * const old_stash
+ = GvHV((GV *)old_val);
+ if(old_stash && HvNAME(old_stash))
+ mro_package_moved(old_stash);
+ }
+ moving_package = TRUE;
+ }
+ }
+
+ SvREFCNT_dec(old_val);
HeVAL(entry) = val;
+
+ if (moving_package && SvTYPE(val) == SVt_PVGV) {
+ const HV * const stash = GvHV((GV *)val);
+ if (stash && HvNAME(stash)) mro_package_moved(stash);
+ }
}
} else if (HeVAL(entry) == &PL_sv_placeholder) {
/* if we find a placeholder, we pretend we haven't found
@@ -1054,6 +1078,18 @@ S_hv_delete_common(pTHX_ HV *hv, SV *key
HvPLACEHOLDERS(hv)++;
} else {
*oentry = HeNEXT(entry);
+
+ /* If this is a stash and the key ends with ::, then someone is
+ deleting a package. */
+ if (sv && HvNAME(hv)) {
+ if (keysv) key = SvPV(keysv, klen);
+ if (klen > 1 && key[klen-2] == ':' && key[klen-1] == ':'
+ && SvTYPE(sv) == SVt_PVGV) {
+ const HV * const stash = GvHV((GV *)sv);
+ if (stash && HvNAME(stash)) mro_package_moved(stash);
+ }
+ }
+
if (SvOOK(hv) && entry == HvAUX(hv)->xhv_eiter /* HvEITER(hv) */)
HvLAZYDEL_on(hv);
else
diff -Nup blead-75176-isarev0/mro.c blead-75176-isarev1/mro.c
--- blead-75176-isarev0/mro.c 2010-05-24 08:49:15.000000000 -0700
+++ blead-75176-isarev1/mro.c 2010-08-22 17:10:33.000000000 -0700
@@ -549,6 +550,56 @@ Perl_mro_isa_changed_in(pTHX_ HV* stash)
}
/*
+=for apidoc mro_package_moved
+
+Invalidates isa caches on this stash, on all subpackages nested inside it,
+and on the subclasses of all those.
+
+=cut
+*/
+void
+Perl_mro_package_moved(pTHX_ const HV *stash)
+{
+ register XPVHV* xhv;
+ register HE *entry;
+ I32 riter = -1;
+
+ PERL_ARGS_ASSERT_MRO_PACKAGE_MOVED;
+
+ mro_isa_changed_in((HV *)stash);
+
+ if(!HvARRAY(stash)) return;
+
+ /* This is partly based on code in hv_iternext_flags. We are not call-
+ ing that here, as we want to avoid resetting the hash iterator. */
+
+ xhv = (XPVHV*)SvANY(stash);
+
+ /* Skip the entire loop if the hash is empty. */
+ if (HvUSEDKEYS(stash)) {
+ while (++riter <= (I32)xhv->xhv_max) {
+ entry = (HvARRAY(stash))[riter];
+
+ /* Iterate through the entries in this list */
+ for(; entry; entry = HeNEXT(entry)) {
+ const char* key;
+ I32 len;
+
+ /* If this entry is a placeholder, don't count it.
+ Try the next. */
+ if (HeVAL(entry) == &PL_sv_placeholder) continue;
+
+ key = hv_iterkey(entry, &len);
+ if(len > 1 && key[len-2] == ':' && key[len-1] == ':') {
+ const HV * const stash = GvHV(HeVAL(entry));
+ if(stash && HvNAME(stash)) mro_package_moved(stash);
+ }
+ }
+ }
+ }
+}
+
+/*
=for apidoc mro_method_changed_in
Invalidates method caching on any child classes
diff -Nup blead-75176-isarev0/proto.h blead-75176-isarev1/proto.h
--- blead-75176-isarev0/proto.h 2010-06-13 07:28:11.000000000 -0700
+++ blead-75176-isarev1/proto.h 2010-08-22 17:10:37.000000000 -0700
@@ -6889,6 +6889,11 @@ PERL_CALLCONV void Perl_mro_method_chang
#define PERL_ARGS_ASSERT_MRO_METHOD_CHANGED_IN \
assert(stash)
+PERL_CALLCONV void Perl_mro_package_moved(pTHX_ const HV *stash)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_MRO_PACKAGE_MOVED \
+ assert(stash)
+
PERL_CALLCONV void Perl_boot_core_mro(pTHX);
PERL_CALLCONV void Perl_sys_init(int* argc, char*** argv)
__attribute__nonnull__(1)
diff -Nup blead-75176-isarev0/sv.c blead-75176-isarev1/sv.c
--- blead-75176-isarev0/sv.c 2010-06-04 09:14:20.000000000 -0700
+++ blead-75176-isarev1/sv.c 2010-08-22 17:08:09.000000000 -0700
@@ -3609,7 +3609,8 @@ copy-ish functions and macros use this u
static void
S_glob_assign_glob(pTHX_ SV *const dstr, SV *const sstr, const int dtype)
{
- I32 mro_changes = 0; /* 1 = method, 2 = isa */
+ I32 mro_changes = 0; /* 1 = method, 2 = isa, 3 = recursive isa */
+ HV *old_stash;
PERL_ARGS_ASSERT_GLOB_ASSIGN_GLOB;
@@ -3655,8 +3656,23 @@ S_glob_assign_glob(pTHX_ SV *const dstr,
mro_changes = 1;
}
- if(strEQ(GvNAME((const GV *)dstr),"ISA"))
- mro_changes = 2;
+ /* We don’t need to check the name of the destination if it was not a
+ glob to begin with. */
+ if(dtype == SVt_PVGV) {
+ const char * const name = GvNAME((const GV *)dstr);
+ if(strEQ(name,"ISA"))
+ mro_changes = 2;
+ else {
+ const STRLEN len = GvNAMELEN(dstr);
+ if (len > 1 && name[len-2] == ':' && name[len-1] == ':') {
+ mro_changes = 3;
+
+ /* Set aside the old stash, so we can reset isa caches on
+ its subclasses. */
+ old_stash = GvHV(dstr);
+ }
+ }
+ }
gp_free(MUTABLE_GV(dstr));
isGV_with_GP_off(dstr);
@@ -3673,6 +3689,11 @@ S_glob_assign_glob(pTHX_ SV *const dstr,
}
GvMULTI_on(dstr);
if(mro_changes == 2) mro_isa_changed_in(GvSTASH(dstr));
+ else if(mro_changes == 3) {
+ const HV * const stash = GvHV(dstr);
+ if(stash && HvNAME(stash)) mro_package_moved(stash);
+ if(old_stash && HvNAME(old_stash)) mro_package_moved(old_stash);
+ }
else if(mro_changes) mro_method_changed_in(GvSTASH(dstr));
return;
}
diff -Nurp blead-75176-isarev0/t/mro/stash-manip.t blead-75176-isarev1/t/mro/stash-manip.t
--- blead-75176-isarev0/t/mro/stash-manip.t 1969-12-31 16:00:00.000000000 -0800
+++ blead-75176-isarev1/t/mro/stash-manip.t 2010-08-22 14:42:16.000000000 -0700
@@ -0,0 +1,80 @@
+#!./perl
+
+use strict;
+#use warnings;
+BEGIN {
+ unless (-d 'blib') {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+ require q(./test.pl);
+}
+
+plan(tests => 6);
+
+
+# Test that replacing a package by assigning to a stash element invalidates
+# the isa caches
+{
+ @Pet::ISA = "Tike";
+ @Tike::ISA = "Barker";
+
+ sub Barker::speak { "Woof!" }
+ sub Latrator::speak { "Bow-wow!" }
+
+ my $pet = bless [], "Pet";
+
+ @Dog::ISA = 'Latrator';
+ my $tike_glob = $::{'Tike::'};
+ $::{'Tike::'} = $::{'Dog::'};
+
+ is $pet->speak, 'Bow-wow!', # Woof! in 5.10/12; Bow-wow! in 5.8 and 5.14
+ 'rearranging packages by assigning to a stash elem updates isa caches';
+
+ undef $tike_glob;
+ is $pet->speak, 'Bow-wow!',
+ 'isa caches are up to date after the replaced stash is freed';
+}
+
+# Similar test, but with nested packages
+{
+ @ThePet::ISA = "The::Tike";
+ @The::Tike::ISA = "TheBarker";
+
+ sub TheBarker::speak { "Woof!" }
+ sub TheLatrator::speak { "Bow-wow!" }
+
+ my $pet = bless [], "ThePet";
+
+ @A::Tike::ISA = 'TheLatrator';
+ my $the_glob = $::{'The::'};
+ $::{'The::'} = $::{'A::'};
+
+ is $pet->speak, 'Bow-wow!',
+ 'moving nested packages by assigning to a stash elem updates isa caches';
+
+ undef $the_glob;
+ is $pet->speak, 'Bow-wow!',
+ 'isa caches are up to date after the replaced nested stash is freed';
+}
+
+# Another hylactic example: Test that deleting stash elements containing
+# subpackages also invalidates the isa cache.
+{
+ @Pet::ISA = ("Cur", "Hound");
+ @Cur::ISA = "Hylactete";
+
+ sub Hylactete::speak { "Arff!" }
+ sub Hound::speak { "Woof!" }
+
+ my $pet = bless [], "Pet";
+
+ my $life_raft = delete $::{'Cur::'};
+
+ is $pet->speak, 'Woof!',
+ 'deleting a stash from its parent stash invalidates the isa caches';
+
+ undef $life_raft;
+ is $pet->speak, 'Woof!',
+ 'the deleted stash is gone completely when freed';
+} |
From @cpansproutOops. I forgot the main part of the message and just sent the postscript. Here it is: Begin forwarded message:
I tried PL_sub_generation, and found that it doesn’t work. I tried adding PL_isa_generation (attached, in case you want to see it; not for application), which worked, but then I realised that it would mean iterating through *all* packages afterwards to reconstruct PL_isarev. So I’ve used a different approach with the other patch attached (1. reset isa...). When a stash is manipulated, it calls mro_isa_changed_in on the affected packages and iterates through their subpackages, doing the same. It does not yet take into account all methods of manipulating the stashes. More patches will follow. What does this have to do with the original bug? Initially I planned to fix the isarev leaks by making appropriate adjustments to it whenever an @ISA is modified or a stash is freed. But, since stashes can be detached from the main tree of stashes ( In the process of experimenting with that, I found that such stash manipulations already fail to update isa caches, which, too, would cause my proposed isarev changes to introduce regressions. So that’s what this patch is for.
|
From @cpansproutInline Patchdiff -Nup blead-75176-isarev0/MANIFEST blead-75176-isarev1/MANIFEST
--- blead-75176-isarev0/MANIFEST 2010-08-20 23:12:47.000000000 -0700
+++ blead-75176-isarev1/MANIFEST 2010-06-23 22:24:35.000000000 -0700
@@ -4356,7 +4356,6 @@ t/mro/package_aliases.t mro tests
t/mro/pkg_gen.t mro tests
t/mro/recursion_c3.t mro tests
t/mro/recursion_dfs.t mro tests
-t/mro/stash-manip.t Test stash manipulation & inheritance
t/mro/vulcan_c3.t mro tests
t/mro/vulcan_dfs.t mro tests
toke.c The tokener
diff -Nup blead-75176-isarev0/dump.c blead-75176-isarev1/dump.c
--- blead-75176-isarev0/dump.c 2010-06-03 05:53:11.000000000 -0700
+++ blead-75176-isarev1/dump.c 2010-08-20 22:56:59.000000000 -0700
@@ -1867,7 +1867,11 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO
dumpops, pvlim);
}
if (meta->isa) {
- Perl_dump_indent(aTHX_ level, file, " ISA = 0x%"UVxf"\n",
+ Perl_dump_indent(aTHX_
+ level, file,
+ meta->isa_gen == PL_isa_generation
+ ? " ISA = 0x%"UVxf"\n"
+ : " ISA = 0x%"UVxf (stale)"\n",
PTR2UV(meta->isa));
do_sv_dump(level+1, file, MUTABLE_SV(meta->isa), nest+1, maxnest,
dumpops, pvlim);
diff -Nup blead-75176-isarev0/embedvar.h blead-75176-isarev1/embedvar.h
--- blead-75176-isarev0/embedvar.h 2010-06-04 09:14:20.000000000 -0700
+++ blead-75176-isarev1/embedvar.h 2010-08-14 06:25:25.000000000 -0700
@@ -160,6 +160,7 @@
#define PL_incgv (vTHX->Iincgv)
#define PL_initav (vTHX->Iinitav)
#define PL_inplace (vTHX->Iinplace)
+#define PL_isa_generation (vTHX->Iisa_generation)
#define PL_isarev (vTHX->Iisarev)
#define PL_known_layers (vTHX->Iknown_layers)
#define PL_last_in_gv (vTHX->Ilast_in_gv)
@@ -489,6 +490,7 @@
#define PL_Iincgv PL_incgv
#define PL_Iinitav PL_initav
#define PL_Iinplace PL_inplace
+#define PL_Iisa_generation PL_isa_generation
#define PL_Iisarev PL_isarev
#define PL_Iknown_layers PL_known_layers
#define PL_Ilast_in_gv PL_last_in_gv
diff -Nup blead-75176-isarev0/hv.c blead-75176-isarev1/hv.c
--- blead-75176-isarev0/hv.c 2010-06-05 05:47:09.000000000 -0700
+++ blead-75176-isarev1/hv.c 2010-08-20 20:41:21.000000000 -0700
@@ -712,6 +712,14 @@ Perl_hv_common(pTHX_ HV *hv, SV *keysv,
} else if (action & HV_FETCH_ISSTORE) {
SvREFCNT_dec(HeVAL(entry));
HeVAL(entry) = val;
+
+ /* If this is a stash and the key ends with ::, then some-
+ one is aliasing (or moving) a package. */
+ if (HvNAME(hv)) {
+ if (keysv) key = SvPV(keysv, klen);
+ if (key[klen-2] == ':' && key[klen-1] == ':')
+ MRO_INVALIDATE_ISA;
+ }
}
} else if (HeVAL(entry) == &PL_sv_placeholder) {
/* if we find a placeholder, we pretend we haven't found
@@ -1061,6 +1069,14 @@ S_hv_delete_common(pTHX_ HV *hv, SV *key
xhv->xhv_keys--; /* HvTOTALKEYS(hv)-- */
if (xhv->xhv_keys == 0)
HvHASKFLAGS_off(hv);
+
+ /* If this is a stash and the key ends with ::, then someone is
+ deleting a package. */
+ if (HvNAME(hv)) {
+ if (keysv) key = SvPV(keysv, klen);
+ if (key[klen-2] == ':' && key[klen-1] == ':')
+ MRO_INVALIDATE_ISA;
+ }
}
return sv;
}
diff -Nup blead-75176-isarev0/hv.h blead-75176-isarev1/hv.h
--- blead-75176-isarev0/hv.h 2010-05-21 12:02:12.000000000 -0700
+++ blead-75176-isarev1/hv.h 2010-08-20 22:53:07.000000000 -0700
@@ -59,15 +59,27 @@ struct mro_meta {
HV *mro_nextmethod; /* next::method caching */
U32 cache_gen; /* Bumping this invalidates our method cache */
U32 pkg_gen; /* Bumps when local methods/@ISA change */
+ /* When isa_gen differs from PL_isa_generation, then isa needs to be
+ updated. */
+ U32 isa_gen;
const struct mro_alg *mro_which; /* which mro alg is in use? */
HV *isa; /* Everything this class @ISA */
};
#define MRO_GET_PRIVATE_DATA(smeta, which) \
- (((smeta)->mro_which && (which) == (smeta)->mro_which) \
+ (( \
+ (smeta)->mro_which && (which) == (smeta)->mro_which \
+ && (smeta)->isa_gen == PL_isa_generation \
+ ) \
? (smeta)->mro_linear_current \
: Perl_mro_get_private_data(aTHX_ (smeta), (which)))
+#ifdef PERL_CORE
+ /* This needs to invalidate the sub cache as well as the isa cache, as the
+ former is obviously stale when the latter is. */
+ #define MRO_INVALIDATE_ISA ++PL_isa_generation, ++PL_sub_generation
+#endif
+
/* Subject to change.
Don't access this directly.
*/
diff -Nup blead-75176-isarev0/intrpvar.h blead-75176-isarev1/intrpvar.h
--- blead-75176-isarev0/intrpvar.h 2010-06-07 10:25:10.000000000 -0700
+++ blead-75176-isarev1/intrpvar.h 2010-08-14 06:24:33.000000000 -0700
@@ -335,6 +335,7 @@ PERLVAR(Icheckav, AV *) /* names of CHE
PERLVAR(Iinitav, AV *) /* names of INIT subroutines */
PERLVAR(Istrtab, HV *) /* shared string table */
PERLVARI(Isub_generation,U32,1) /* incr to invalidate method cache */
+PERLVARI(Iisa_generation,U32,1) /* incr to invalidate isa caches */
/* funky return mechanisms */
PERLVAR(Iforkprocess, int) /* so do_open |- can return proc# */
diff -Nup blead-75176-isarev0/mro.c blead-75176-isarev1/mro.c
--- blead-75176-isarev0/mro.c 2010-05-24 08:49:15.000000000 -0700
+++ blead-75176-isarev1/mro.c 2010-08-20 23:05:09.000000000 -0700
@@ -37,6 +37,22 @@ Perl_mro_get_private_data(pTHX_ struct m
SV **data;
PERL_ARGS_ASSERT_MRO_GET_PRIVATE_DATA;
+ /* If the isa caches have been invalidated, free any existing private
+ data to avoid leaks the next time they are set. */
+ if (smeta->isa_gen != PL_isa_generation) {
+ if (smeta->mro_linear_all) {
+ SvREFCNT_dec(MUTABLE_SV(smeta->mro_linear_all));
+ smeta->mro_linear_all = NULL;
+ /* This is just acting as a shortcut pointer. */
+ smeta->mro_linear_current = NULL;
+ } else if (smeta->mro_linear_current) {
+ /* Only the current MRO is stored, so this owns the data. */
+ SvREFCNT_dec(smeta->mro_linear_current);
+ smeta->mro_linear_current = NULL;
+ }
+ return NULL;
+ }
+
data = (SV **)Perl_hv_common(aTHX_ smeta->mro_linear_all, NULL,
which->name, which->length, which->kflags,
HV_FETCH_JUST_SV, NULL, which->hash);
@@ -63,6 +79,7 @@ Perl_mro_set_private_data(pTHX_ struct m
memory on a hash with 1 element - store it direct, and signal
this by leaving the would-be-hash NULL. */
smeta->mro_linear_current = data;
+ smeta->isa_gen = PL_isa_generation;
return data;
} else {
HV *const hv = newHV();
@@ -86,6 +103,7 @@ Perl_mro_set_private_data(pTHX_ struct m
/* If we've been asked to store the private data for the current MRO,
then cache it. */
smeta->mro_linear_current = data;
+ smeta->isa_gen = PL_isa_generation;
}
if (!Perl_hv_common(aTHX_ smeta->mro_linear_all, NULL,
@@ -142,6 +160,7 @@ Perl_mro_meta_init(pTHX_ HV* stash)
HvAUX(stash)->xhv_mro_meta = newmeta;
newmeta->cache_gen = 1;
newmeta->pkg_gen = 1;
+ newmeta->isa_gen = 0;
newmeta->mro_which = &dfs_alg;
return newmeta;
@@ -177,7 +196,10 @@ Perl_mro_meta_dup(pTHX_ struct mro_meta*
= MUTABLE_HV(sv_dup_inc((const SV *)newmeta->mro_nextmethod, param));
if (newmeta->isa)
newmeta->isa
- = MUTABLE_HV(sv_dup_inc((const SV *)newmeta->isa, param));
+ /* Skip cloning ->isa if isa_gen is off. */
+ = newmeta->isa_gen == PL_isa_generation
+ ? MUTABLE_HV(sv_dup_inc((const SV *)newmeta->isa, param))
+ : NULL;
return newmeta;
}
@@ -401,6 +423,13 @@ Perl_mro_get_linear_isa(pTHX_ HV *stash)
meta = HvMROMETA(stash);
if (!meta->mro_which)
Perl_croak(aTHX_ "panic: invalid MRO!");
+
+ /* Make sure meta->isa does not contain stale data after we return. */
+ if (meta->isa && meta->isa_gen != PL_isa_generation) {
+ SvREFCNT_dec(meta->isa);
+ meta->isa = NULL;
+ }
+
return meta->mro_which->resolve(aTHX_ stash, 0);
}
diff -Nup blead-75176-isarev0/perlapi.h blead-75176-isarev1/perlapi.h
--- blead-75176-isarev0/perlapi.h 2010-06-04 09:14:20.000000000 -0700
+++ blead-75176-isarev1/perlapi.h 2010-08-14 06:25:25.000000000 -0700
@@ -356,6 +356,8 @@ END_EXTERN_C
#define PL_initav (*Perl_Iinitav_ptr(aTHX))
#undef PL_inplace
#define PL_inplace (*Perl_Iinplace_ptr(aTHX))
+#undef PL_isa_generation
+#define PL_isa_generation (*Perl_Iisa_generation_ptr(aTHX))
#undef PL_isarev
#define PL_isarev (*Perl_Iisarev_ptr(aTHX))
#undef PL_known_layers
diff -Nup blead-75176-isarev0/sv.c blead-75176-isarev1/sv.c
--- blead-75176-isarev0/sv.c 2010-06-04 09:14:20.000000000 -0700
+++ blead-75176-isarev1/sv.c 2010-08-20 20:42:09.000000000 -0700
@@ -3609,7 +3609,7 @@ copy-ish functions and macros use this u
static void
S_glob_assign_glob(pTHX_ SV *const dstr, SV *const sstr, const int dtype)
{
- I32 mro_changes = 0; /* 1 = method, 2 = isa */
+ I32 mro_changes = 0; /* 1 = method, 2 = isa, 3 = PL_isa_generation */
PERL_ARGS_ASSERT_GLOB_ASSIGN_GLOB;
@@ -3655,8 +3655,16 @@ S_glob_assign_glob(pTHX_ SV *const dstr,
mro_changes = 1;
}
- if(strEQ(GvNAME((const GV *)dstr),"ISA"))
- mro_changes = 2;
+ {
+ const char * const name = GvNAME((const GV *)dstr);
+ if(strEQ(name,"ISA"))
+ mro_changes = 2;
+ else {
+ const STRLEN len = GvNAMELEN(sstr);
+ if (name[len-2] == ':' && name[len-1] == ':') mro_changes = 3;
+ }
+ }
+
gp_free(MUTABLE_GV(dstr));
isGV_with_GP_off(dstr);
@@ -3673,6 +3681,7 @@ S_glob_assign_glob(pTHX_ SV *const dstr,
}
GvMULTI_on(dstr);
if(mro_changes == 2) mro_isa_changed_in(GvSTASH(dstr));
+ else if(mro_changes == 3) MRO_INVALIDATE_ISA;
else if(mro_changes) mro_method_changed_in(GvSTASH(dstr));
return;
}
@@ -12255,6 +12264,7 @@ perl_clone_using(PerlInterpreter *proto_
PL_initav = av_dup_inc(proto_perl->Iinitav, param);
PL_sub_generation = proto_perl->Isub_generation;
+ PL_isa_generation = proto_perl->Iisa_generation;
PL_isarev = hv_dup_inc(proto_perl->Iisarev, param);
/* funky return mechanisms */
diff -Nup blead-75176-isarev0/universal.c blead-75176-isarev1/universal.c
--- blead-75176-isarev0/universal.c 2010-05-31 15:15:11.000000000 -0700
+++ blead-75176-isarev1/universal.c 2010-08-12 22:10:07.000000000 -0700
@@ -41,7 +41,7 @@ S_get_isa_hash(pTHX_ HV *const stash)
PERL_ARGS_ASSERT_GET_ISA_HASH;
- if (!meta->isa) {
+ if (!meta->isa || meta->isa_gen != PL_isa_generation) {
AV *const isa = mro_get_linear_isa(stash);
if (!meta->isa) {
HV *const isa_hash = newHV();
@@ -63,6 +63,7 @@ S_get_isa_hash(pTHX_ HV *const stash)
SvREADONLY_on(isa_hash);
meta->isa = isa_hash;
+ meta->isa_gen = PL_isa_generation;
}
}
return meta->isa;
@@ -78,7 +79,10 @@ S_isa_lookup(pTHX_ HV *stash, const char
{
dVAR;
const struct mro_meta *const meta = HvMROMETA(stash);
- HV *const isa = meta->isa ? meta->isa : S_get_isa_hash(aTHX_ stash);
+ HV *const isa
+ = meta->isa && meta->isa_gen == PL_isa_generation
+ ? meta->isa
+ : S_get_isa_hash(aTHX_ stash);
STRLEN len = strlen(name);
const HV *our_stash;
diff -Nurp blead-75176-isarev0/t/mro/stash-manip.t blead-75176-isarev1/t/mro/stash-manip.t
--- blead-75176-isarev0/t/mro/stash-manip.t 1969-12-31 16:00:00.000000000 -0800
+++ blead-75176-isarev1/t/mro/stash-manip.t 2010-08-20 20:43:31.000000000 -0700
@@ -0,0 +1,61 @@
+#!./perl
+
+use strict;
+#use warnings;
+BEGIN {
+ unless (-d 'blib') {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+ require q(./test.pl);
+}
+
+plan(tests => 4);
+
+
+# Test that replacing a package by assigning to a stash element invalidates
+# the isa caches
+{
+ @Pet::ISA = "Tike";
+ @Tike::ISA = "Barker";
+
+ sub Barker::speak { "Woof!" }
+ sub Latrator::speak { "Bow-wow!" }
+
+ my $pet = bless [], "Pet";
+
+ @Dog::ISA = 'Latrator';
+ my $tike_glob = $::{'Tike::'};
+ $::{'Tike::'} = $::{'Dog::'};
+
+ is $pet->speak, 'Bow-wow!', # Woof! in 5.10/12; Bow-wow! in 5.8 and 5.14
+ 'rearranging packages by assigning to a stash elem updates isa caches';
+
+ undef $tike_glob;
+ is $pet->speak, 'Bow-wow!',
+ 'isa caches are up to date after the replaced stash is freed';
+}
+
+# Another hylactic example: Test that deleting stash elements containing
+# subpackages also invalidates the isa cache.
+{
+ @Pet::ISA = ("Cur", "Hound");
+ @Cur::ISA = "Hylactete";
+
+ sub Hylactete::speak { "Arff!" }
+ sub Hound::speak { "Woof!" }
+
+ my $pet = bless [], "Pet";
+
+ my $life_raft = delete $::{'Cur::'};
+
+ is $pet->speak, 'Woof!',
+ 'deleting a stash from its parent stash invalidates the isa caches';
+
+ undef $life_raft;
+ is $pet->speak, 'Woof!',
+ 'the deleted stash is gone completely when freed';
+}
+
+
+ |
From @cpansproutInline Patchdiff -Nup blead-75176-isarev0/embed.fnc blead-75176-isarev1/embed.fnc
--- blead-75176-isarev0/embed.fnc 2010-06-13 07:28:11.000000000 -0700
+++ blead-75176-isarev1/embed.fnc 2010-08-22 17:10:15.000000000 -0700
@@ -2361,6 +2361,7 @@ sd |AV* |mro_get_linear_isa_dfs|NN HV* s
: Used in hv.c, mg.c, pp.c, sv.c
pd |void |mro_isa_changed_in|NN HV* stash
Apd |void |mro_method_changed_in |NN HV* stash
+pdx |void |mro_package_moved |NN const HV *stash
: Only used in perl.c
p |void |boot_core_mro
Apon |void |sys_init |NN int* argc|NN char*** argv
diff -Nup blead-75176-isarev0/embed.h blead-75176-isarev1/embed.h
--- blead-75176-isarev0/embed.h 2010-06-05 15:42:10.000000000 -0700
+++ blead-75176-isarev1/embed.h 2010-08-22 11:16:16.000000000 -0700
@@ -2052,6 +2052,7 @@
#endif
#define mro_method_changed_in Perl_mro_method_changed_in
#ifdef PERL_CORE
+#define mro_package_moved Perl_mro_package_moved
#define boot_core_mro Perl_boot_core_mro
#endif
#if defined(USE_ITHREADS)
@@ -4501,6 +4502,7 @@
#endif
#define mro_method_changed_in(a) Perl_mro_method_changed_in(aTHX_ a)
#ifdef PERL_CORE
+#define mro_package_moved(a) Perl_mro_package_moved(aTHX_ a)
#define boot_core_mro() Perl_boot_core_mro(aTHX)
#endif
#ifdef PERL_CORE
diff -Nup blead-75176-isarev0/hv.c blead-75176-isarev1/hv.c
--- blead-75176-isarev0/hv.c 2010-06-05 05:47:09.000000000 -0700
+++ blead-75176-isarev1/hv.c 2010-08-22 14:55:08.000000000 -0700
@@ -710,8 +710,32 @@ Perl_hv_common(pTHX_ HV *hv, SV *keysv,
}
HeVAL(entry) = val;
} else if (action & HV_FETCH_ISSTORE) {
- SvREFCNT_dec(HeVAL(entry));
+ bool moving_package = FALSE;
+ SV *old_val = HeVAL(entry);
+
+ /* If this is a stash and the key ends with ::, then some-
+ one is aliasing (or moving) a package. */
+ if (HvNAME(hv)) {
+ if (keysv) key = SvPV(keysv, klen);
+ if (klen > 1
+ && key[klen-2] == ':' && key[klen-1] == ':') {
+ if(SvTYPE(old_val) == SVt_PVGV) {
+ const HV * const old_stash
+ = GvHV((GV *)old_val);
+ if(old_stash && HvNAME(old_stash))
+ mro_package_moved(old_stash);
+ }
+ moving_package = TRUE;
+ }
+ }
+
+ SvREFCNT_dec(old_val);
HeVAL(entry) = val;
+
+ if (moving_package && SvTYPE(val) == SVt_PVGV) {
+ const HV * const stash = GvHV((GV *)val);
+ if (stash && HvNAME(stash)) mro_package_moved(stash);
+ }
}
} else if (HeVAL(entry) == &PL_sv_placeholder) {
/* if we find a placeholder, we pretend we haven't found
@@ -1054,6 +1078,18 @@ S_hv_delete_common(pTHX_ HV *hv, SV *key
HvPLACEHOLDERS(hv)++;
} else {
*oentry = HeNEXT(entry);
+
+ /* If this is a stash and the key ends with ::, then someone is
+ deleting a package. */
+ if (sv && HvNAME(hv)) {
+ if (keysv) key = SvPV(keysv, klen);
+ if (klen > 1 && key[klen-2] == ':' && key[klen-1] == ':'
+ && SvTYPE(sv) == SVt_PVGV) {
+ const HV * const stash = GvHV((GV *)sv);
+ if (stash && HvNAME(stash)) mro_package_moved(stash);
+ }
+ }
+
if (SvOOK(hv) && entry == HvAUX(hv)->xhv_eiter /* HvEITER(hv) */)
HvLAZYDEL_on(hv);
else
diff -Nup blead-75176-isarev0/mro.c blead-75176-isarev1/mro.c
--- blead-75176-isarev0/mro.c 2010-05-24 08:49:15.000000000 -0700
+++ blead-75176-isarev1/mro.c 2010-08-22 17:10:33.000000000 -0700
@@ -549,6 +550,56 @@ Perl_mro_isa_changed_in(pTHX_ HV* stash)
}
/*
+=for apidoc mro_package_moved
+
+Invalidates isa caches on this stash, on all subpackages nested inside it,
+and on the subclasses of all those.
+
+=cut
+*/
+void
+Perl_mro_package_moved(pTHX_ const HV *stash)
+{
+ register XPVHV* xhv;
+ register HE *entry;
+ I32 riter = -1;
+
+ PERL_ARGS_ASSERT_MRO_PACKAGE_MOVED;
+
+ mro_isa_changed_in((HV *)stash);
+
+ if(!HvARRAY(stash)) return;
+
+ /* This is partly based on code in hv_iternext_flags. We are not call-
+ ing that here, as we want to avoid resetting the hash iterator. */
+
+ xhv = (XPVHV*)SvANY(stash);
+
+ /* Skip the entire loop if the hash is empty. */
+ if (HvUSEDKEYS(stash)) {
+ while (++riter <= (I32)xhv->xhv_max) {
+ entry = (HvARRAY(stash))[riter];
+
+ /* Iterate through the entries in this list */
+ for(; entry; entry = HeNEXT(entry)) {
+ const char* key;
+ I32 len;
+
+ /* If this entry is a placeholder, don't count it.
+ Try the next. */
+ if (HeVAL(entry) == &PL_sv_placeholder) continue;
+
+ key = hv_iterkey(entry, &len);
+ if(len > 1 && key[len-2] == ':' && key[len-1] == ':') {
+ const HV * const stash = GvHV(HeVAL(entry));
+ if(stash && HvNAME(stash)) mro_package_moved(stash);
+ }
+ }
+ }
+ }
+}
+
+/*
=for apidoc mro_method_changed_in
Invalidates method caching on any child classes
diff -Nup blead-75176-isarev0/proto.h blead-75176-isarev1/proto.h
--- blead-75176-isarev0/proto.h 2010-06-13 07:28:11.000000000 -0700
+++ blead-75176-isarev1/proto.h 2010-08-22 17:10:37.000000000 -0700
@@ -6889,6 +6889,11 @@ PERL_CALLCONV void Perl_mro_method_chang
#define PERL_ARGS_ASSERT_MRO_METHOD_CHANGED_IN \
assert(stash)
+PERL_CALLCONV void Perl_mro_package_moved(pTHX_ const HV *stash)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_MRO_PACKAGE_MOVED \
+ assert(stash)
+
PERL_CALLCONV void Perl_boot_core_mro(pTHX);
PERL_CALLCONV void Perl_sys_init(int* argc, char*** argv)
__attribute__nonnull__(1)
diff -Nup blead-75176-isarev0/sv.c blead-75176-isarev1/sv.c
--- blead-75176-isarev0/sv.c 2010-06-04 09:14:20.000000000 -0700
+++ blead-75176-isarev1/sv.c 2010-08-22 17:08:09.000000000 -0700
@@ -3609,7 +3609,8 @@ copy-ish functions and macros use this u
static void
S_glob_assign_glob(pTHX_ SV *const dstr, SV *const sstr, const int dtype)
{
- I32 mro_changes = 0; /* 1 = method, 2 = isa */
+ I32 mro_changes = 0; /* 1 = method, 2 = isa, 3 = recursive isa */
+ HV *old_stash;
PERL_ARGS_ASSERT_GLOB_ASSIGN_GLOB;
@@ -3655,8 +3656,23 @@ S_glob_assign_glob(pTHX_ SV *const dstr,
mro_changes = 1;
}
- if(strEQ(GvNAME((const GV *)dstr),"ISA"))
- mro_changes = 2;
+ /* We don’t need to check the name of the destination if it was not a
+ glob to begin with. */
+ if(dtype == SVt_PVGV) {
+ const char * const name = GvNAME((const GV *)dstr);
+ if(strEQ(name,"ISA"))
+ mro_changes = 2;
+ else {
+ const STRLEN len = GvNAMELEN(dstr);
+ if (len > 1 && name[len-2] == ':' && name[len-1] == ':') {
+ mro_changes = 3;
+
+ /* Set aside the old stash, so we can reset isa caches on
+ its subclasses. */
+ old_stash = GvHV(dstr);
+ }
+ }
+ }
gp_free(MUTABLE_GV(dstr));
isGV_with_GP_off(dstr);
@@ -3673,6 +3689,11 @@ S_glob_assign_glob(pTHX_ SV *const dstr,
}
GvMULTI_on(dstr);
if(mro_changes == 2) mro_isa_changed_in(GvSTASH(dstr));
+ else if(mro_changes == 3) {
+ const HV * const stash = GvHV(dstr);
+ if(stash && HvNAME(stash)) mro_package_moved(stash);
+ if(old_stash && HvNAME(old_stash)) mro_package_moved(old_stash);
+ }
else if(mro_changes) mro_method_changed_in(GvSTASH(dstr));
return;
}
diff -Nurp blead-75176-isarev0/t/mro/stash-manip.t blead-75176-isarev1/t/mro/stash-manip.t
--- blead-75176-isarev0/t/mro/stash-manip.t 1969-12-31 16:00:00.000000000 -0800
+++ blead-75176-isarev1/t/mro/stash-manip.t 2010-08-22 14:42:16.000000000 -0700
@@ -0,0 +1,80 @@
+#!./perl
+
+use strict;
+#use warnings;
+BEGIN {
+ unless (-d 'blib') {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+ require q(./test.pl);
+}
+
+plan(tests => 6);
+
+
+# Test that replacing a package by assigning to a stash element invalidates
+# the isa caches
+{
+ @Pet::ISA = "Tike";
+ @Tike::ISA = "Barker";
+
+ sub Barker::speak { "Woof!" }
+ sub Latrator::speak { "Bow-wow!" }
+
+ my $pet = bless [], "Pet";
+
+ @Dog::ISA = 'Latrator';
+ my $tike_glob = $::{'Tike::'};
+ $::{'Tike::'} = $::{'Dog::'};
+
+ is $pet->speak, 'Bow-wow!', # Woof! in 5.10/12; Bow-wow! in 5.8 and 5.14
+ 'rearranging packages by assigning to a stash elem updates isa caches';
+
+ undef $tike_glob;
+ is $pet->speak, 'Bow-wow!',
+ 'isa caches are up to date after the replaced stash is freed';
+}
+
+# Similar test, but with nested packages
+{
+ @ThePet::ISA = "The::Tike";
+ @The::Tike::ISA = "TheBarker";
+
+ sub TheBarker::speak { "Woof!" }
+ sub TheLatrator::speak { "Bow-wow!" }
+
+ my $pet = bless [], "ThePet";
+
+ @A::Tike::ISA = 'TheLatrator';
+ my $the_glob = $::{'The::'};
+ $::{'The::'} = $::{'A::'};
+
+ is $pet->speak, 'Bow-wow!',
+ 'moving nested packages by assigning to a stash elem updates isa caches';
+
+ undef $the_glob;
+ is $pet->speak, 'Bow-wow!',
+ 'isa caches are up to date after the replaced nested stash is freed';
+}
+
+# Another hylactic example: Test that deleting stash elements containing
+# subpackages also invalidates the isa cache.
+{
+ @Pet::ISA = ("Cur", "Hound");
+ @Cur::ISA = "Hylactete";
+
+ sub Hylactete::speak { "Arff!" }
+ sub Hound::speak { "Woof!" }
+
+ my $pet = bless [], "Pet";
+
+ my $life_raft = delete $::{'Cur::'};
+
+ is $pet->speak, 'Woof!',
+ 'deleting a stash from its parent stash invalidates the isa caches';
+
+ undef $life_raft;
+ is $pet->speak, 'Woof!',
+ 'the deleted stash is gone completely when freed';
+} |
From @cpansprout |
From @cpansproutOn Aug 22, 2010, at 5:46 PM, Father Chrysostomos wrote:
And I forgot to add the new test to MANIFEST. Here’s a patch for that. |
From @cpansproutInline Patchdiff -Nup blead-75176-isarev0/MANIFEST blead-75176-isarev1/MANIFEST
--- blead-75176-isarev0/MANIFEST 2010-08-22 20:19:02.000000000 -0700
+++ blead-75176-isarev1/MANIFEST 2010-08-20 23:12:47.000000000 -0700
@@ -4356,6 +4356,7 @@ t/mro/package_aliases.t mro tests
t/mro/pkg_gen.t mro tests
t/mro/recursion_c3.t mro tests
t/mro/recursion_dfs.t mro tests
+t/mro/stash-manip.t Test stash manipulation & inheritance
t/mro/vulcan_c3.t mro tests
t/mro/vulcan_dfs.t mro tests
toke.c The tokener |
From @iabynOn Sun, Aug 22, 2010 at 12:11:27PM -0700, Father Chrysostomos wrote:
See S_hfreeentries: it special-cases adding name back at the end. -- |
From @iabynOn Mon, Aug 23, 2010 at 12:50:20PM +0100, Dave Mitchell wrote:
In fact I'm tempted to modify this code so that the aux structure -- |
From @cpansproutOn Aug 22, 2010, at 5:46 PM, Father Chrysostomos wrote:
Here is a patch that deals with a couple more ways of manipulating stashes. I plan to work on assignment to empty stash elements next (or any stash elements that are not globs). I can do this by using PVLVs. But there are two approaches: 1. Do it just for access from Perl by adding it to pp_helem. Number 1 makes it too easy for XS code to make changes without triggering mro_package_moved. mro_package_moved will also have to be made public (and probably given a better name). So in both cases, XS code will have to be modified (if there is any that plays with stashes). But in case 2 only code that is currently potentially buggy will have to change. I prefer number 2. |
From @cpansproutFrom: Father Chrysostomos <sprout@cpan.org> [perl #75176] Make more ways to manipulate stashes reset isa caches This makes string-to-glob assignment and hashref-to-glob assignment Inline Patchdiff -Nup blead-75176-isarev1/sv.c blead-75176-isarev2/sv.c
--- blead-75176-isarev1/sv.c 2010-08-22 17:08:09.000000000 -0700
+++ blead-75176-isarev2/sv.c 2010-08-27 15:01:21.000000000 -0700
@@ -3800,7 +3800,14 @@ S_glob_assign_ref(pTHX_ SV *const dstr,
&& CopSTASH_ne(PL_curcop, GvSTASH(dstr))) {
GvFLAGS(dstr) |= import_flag;
}
- if (stype == SVt_PVAV && strEQ(GvNAME((GV*)dstr), "ISA")) {
+ if (stype == SVt_PVHV) {
+ const char * const name = GvNAME((GV*)dstr);
+ const STRLEN len = GvNAMELEN(dstr);
+ if (len > 1 && name[len-2] == ':' && name[len-1] == ':')
+ if(HvNAME(dref)) mro_package_moved((HV *)dref);
+ if(HvNAME(sref)) mro_package_moved((HV *)sref);
+ }
+ else if (stype == SVt_PVAV && strEQ(GvNAME((GV*)dstr), "ISA")) {
sv_magic(sref, dstr, PERL_MAGIC_isa, NULL, 0);
mro_isa_changed_in(GvSTASH(dstr));
}
@@ -4043,9 +4050,27 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, regi
else {
GV *gv = gv_fetchsv(sstr, GV_ADD, SVt_PVGV);
if (dstr != (const SV *)gv) {
+ const char * const name = GvNAME((const GV *)dstr);
+ const STRLEN len = GvNAMELEN(dstr);
+ HV *old_stash;
+ bool reset_isa = FALSE;
+ if (len > 1 && name[len-2] == ':' && name[len-1] == ':') {
+ /* Set aside the old stash, so we can reset isa caches
+ on its subclasses. */
+ old_stash = GvHV(dstr);
+ reset_isa = TRUE;
+ }
+
if (GvGP(dstr))
gp_free(MUTABLE_GV(dstr));
GvGP(dstr) = gp_ref(GvGP(gv));
+
+ if (reset_isa) {
+ const HV * const stash = GvHV(dstr);
+ if(stash && HvNAME(stash)) mro_package_moved(stash);
+ if(old_stash && HvNAME(old_stash))
+ mro_package_moved(old_stash);
+ }
}
}
}
diff -Nurp blead-75176-isarev1/t/mro/stash-manip.t blead-75176-isarev2/t/mro/stash-manip.t
--- blead-75176-isarev1/t/mro/stash-manip.t 2010-08-22 14:55:49.000000000 -0700
+++ blead-75176-isarev2/t/mro/stash-manip.t 2010-08-27 15:01:07.000000000 -0700
@@ -10,55 +10,89 @@ BEGIN {
require q(./test.pl);
}
-plan(tests => 6);
+plan(tests => 8);
-# Test that replacing a package by assigning to a stash element invalidates
-# the isa caches
-{
- @Pet::ISA = "Tike";
- @Tike::ISA = "Barker";
-
- sub Barker::speak { "Woof!" }
- sub Latrator::speak { "Bow-wow!" }
-
- my $pet = bless [], "Pet";
-
- @Dog::ISA = 'Latrator';
- my $tike_glob = $::{'Tike::'};
- $::{'Tike::'} = $::{'Dog::'};
-
- is $pet->speak, 'Bow-wow!', # Woof! in 5.10/12; Bow-wow! in 5.8 and 5.14
- 'rearranging packages by assigning to a stash elem updates isa caches';
-
- undef $tike_glob;
- is $pet->speak, 'Bow-wow!',
- 'isa caches are up to date after the replaced stash is freed';
+# Test that replacing a package by assigning to an existing stash element
+# invalidates the isa caches
+for(
+ {
+ name => 'assigning a glob to a stash element',
+ code => '$life_raft = $::{"Left::"}; $::{"Left::"} = $::{"Right::"}',
+ },
+ {
+ name => 'assigning a string to a stash element',
+ code => '$life_raft = $::{"Left::"}; $::{"Left::"} = "Right::"',
+ },
+ {
+ name => 'assigning a stashref to a stash element',
+ code => '$life_raft = \%Left::; $::{"Left::"} = \%Right::',
+ },
+) {
+ fresh_perl_is
+ q~
+ @Subclass::ISA = "Left";
+ @Left::ISA = "TopLeft";
+
+ sub TopLeft::speak { "Woof!" }
+ sub TopRight::speak { "Bow-wow!" }
+
+ my $thing = bless [], "Subclass";
+
+ @Right::ISA = 'TopRight';
+ my $life_raft;
+ __code__;
+
+ print $thing->speak, "\n";
+
+ undef $life_raft;
+ print $thing->speak, "\n";
+ ~ =~ s\__code__\$$_{code}\r,
+ "Bow-wow!\nBow-wow!\n",
+ {},
+ "replacing packages by $$_{name} updates isa caches";
}
# Similar test, but with nested packages
-{
- @ThePet::ISA = "The::Tike";
- @The::Tike::ISA = "TheBarker";
-
- sub TheBarker::speak { "Woof!" }
- sub TheLatrator::speak { "Bow-wow!" }
-
- my $pet = bless [], "ThePet";
-
- @A::Tike::ISA = 'TheLatrator';
- my $the_glob = $::{'The::'};
- $::{'The::'} = $::{'A::'};
-
- is $pet->speak, 'Bow-wow!',
- 'moving nested packages by assigning to a stash elem updates isa caches';
-
- undef $the_glob;
- is $pet->speak, 'Bow-wow!',
- 'isa caches are up to date after the replaced nested stash is freed';
+for(
+ {
+ name => 'assigning a glob to a stash element',
+ code => '$life_raft = $::{"Left::"}; $::{"Left::"} = $::{"Right::"}',
+ },
+ {
+ name => 'assigning a string to a stash element',
+ code => '$life_raft = $::{"Left::"}; $::{"Left::"} = "Right::"',
+ },
+ {
+ name => 'assigning a stashref to a stash element',
+ code => '$life_raft = \%Left::; $::{"Left::"} = \%Right::',
+ },
+) {
+ fresh_perl_is
+ q~
+ @Subclass::ISA = "Left::Side";
+ @Left::Side::ISA = "TopLeft";
+
+ sub TopLeft::speak { "Woof!" }
+ sub TopRight::speak { "Bow-wow!" }
+
+ my $thing = bless [], "Subclass";
+
+ @Right::Side::ISA = 'TopRight';
+ my $life_raft;
+ __code__;
+
+ print $thing->speak, "\n";
+
+ undef $life_raft;
+ print $thing->speak, "\n";
+ ~ =~ s\__code__\$$_{code}\r,
+ "Bow-wow!\nBow-wow!\n",
+ {},
+ "replacing nested packages by $$_{name} updates isa caches";
}
-# Another hylactic example: Test that deleting stash elements containing
+# Test that deleting stash elements containing
# subpackages also invalidates the isa cache.
{
@Pet::ISA = ("Cur", "Hound"); |
From @demerphqOn 29 August 2010 23:09, Father Chrysostomos <sprout@cpan.org> wrote:
+ if (stype == SVt_PVHV) { Did you miss a { } there? From the indenting it looks like the if () yves -- |
From @cpansproutOn Aug 29, 2010, at 3:20 PM, demerphq wrote:
Thank you for catching that. Here is a fixed version. |
From @cpansproutFrom: Father Chrysostomos <sprout@cpan.org> [perl #75176] Make more ways to manipulate stashes reset isa caches This makes string-to-glob assignment and hashref-to-glob assignment Inline Patchdiff -Nup blead-75176-isarev1/sv.c blead-75176-isarev2/sv.c
--- blead-75176-isarev1/sv.c 2010-08-22 17:08:09.000000000 -0700
+++ blead-75176-isarev2/sv.c 2010-08-29 15:52:37.000000000 -0700
@@ -3800,7 +3800,15 @@ S_glob_assign_ref(pTHX_ SV *const dstr,
&& CopSTASH_ne(PL_curcop, GvSTASH(dstr))) {
GvFLAGS(dstr) |= import_flag;
}
- if (stype == SVt_PVAV && strEQ(GvNAME((GV*)dstr), "ISA")) {
+ if (stype == SVt_PVHV) {
+ const char * const name = GvNAME((GV*)dstr);
+ const STRLEN len = GvNAMELEN(dstr);
+ if (len > 1 && name[len-2] == ':' && name[len-1] == ':') {
+ if(HvNAME(dref)) mro_package_moved((HV *)dref);
+ if(HvNAME(sref)) mro_package_moved((HV *)sref);
+ }
+ }
+ else if (stype == SVt_PVAV && strEQ(GvNAME((GV*)dstr), "ISA")) {
sv_magic(sref, dstr, PERL_MAGIC_isa, NULL, 0);
mro_isa_changed_in(GvSTASH(dstr));
}
@@ -4043,9 +4051,27 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, regi
else {
GV *gv = gv_fetchsv(sstr, GV_ADD, SVt_PVGV);
if (dstr != (const SV *)gv) {
+ const char * const name = GvNAME((const GV *)dstr);
+ const STRLEN len = GvNAMELEN(dstr);
+ HV *old_stash;
+ bool reset_isa = FALSE;
+ if (len > 1 && name[len-2] == ':' && name[len-1] == ':') {
+ /* Set aside the old stash, so we can reset isa caches
+ on its subclasses. */
+ old_stash = GvHV(dstr);
+ reset_isa = TRUE;
+ }
+
if (GvGP(dstr))
gp_free(MUTABLE_GV(dstr));
GvGP(dstr) = gp_ref(GvGP(gv));
+
+ if (reset_isa) {
+ const HV * const stash = GvHV(dstr);
+ if(stash && HvNAME(stash)) mro_package_moved(stash);
+ if(old_stash && HvNAME(old_stash))
+ mro_package_moved(old_stash);
+ }
}
}
}
diff -Nurp blead-75176-isarev1/t/mro/stash-manip.t blead-75176-isarev2/t/mro/stash-manip.t
--- blead-75176-isarev1/t/mro/stash-manip.t 2010-08-22 14:55:49.000000000 -0700
+++ blead-75176-isarev2/t/mro/stash-manip.t 2010-08-27 15:01:07.000000000 -0700
@@ -10,55 +10,89 @@ BEGIN {
require q(./test.pl);
}
-plan(tests => 6);
+plan(tests => 8);
-# Test that replacing a package by assigning to a stash element invalidates
-# the isa caches
-{
- @Pet::ISA = "Tike";
- @Tike::ISA = "Barker";
-
- sub Barker::speak { "Woof!" }
- sub Latrator::speak { "Bow-wow!" }
-
- my $pet = bless [], "Pet";
-
- @Dog::ISA = 'Latrator';
- my $tike_glob = $::{'Tike::'};
- $::{'Tike::'} = $::{'Dog::'};
-
- is $pet->speak, 'Bow-wow!', # Woof! in 5.10/12; Bow-wow! in 5.8 and 5.14
- 'rearranging packages by assigning to a stash elem updates isa caches';
-
- undef $tike_glob;
- is $pet->speak, 'Bow-wow!',
- 'isa caches are up to date after the replaced stash is freed';
+# Test that replacing a package by assigning to an existing stash element
+# invalidates the isa caches
+for(
+ {
+ name => 'assigning a glob to a stash element',
+ code => '$life_raft = $::{"Left::"}; $::{"Left::"} = $::{"Right::"}',
+ },
+ {
+ name => 'assigning a string to a stash element',
+ code => '$life_raft = $::{"Left::"}; $::{"Left::"} = "Right::"',
+ },
+ {
+ name => 'assigning a stashref to a stash element',
+ code => '$life_raft = \%Left::; $::{"Left::"} = \%Right::',
+ },
+) {
+ fresh_perl_is
+ q~
+ @Subclass::ISA = "Left";
+ @Left::ISA = "TopLeft";
+
+ sub TopLeft::speak { "Woof!" }
+ sub TopRight::speak { "Bow-wow!" }
+
+ my $thing = bless [], "Subclass";
+
+ @Right::ISA = 'TopRight';
+ my $life_raft;
+ __code__;
+
+ print $thing->speak, "\n";
+
+ undef $life_raft;
+ print $thing->speak, "\n";
+ ~ =~ s\__code__\$$_{code}\r,
+ "Bow-wow!\nBow-wow!\n",
+ {},
+ "replacing packages by $$_{name} updates isa caches";
}
# Similar test, but with nested packages
-{
- @ThePet::ISA = "The::Tike";
- @The::Tike::ISA = "TheBarker";
-
- sub TheBarker::speak { "Woof!" }
- sub TheLatrator::speak { "Bow-wow!" }
-
- my $pet = bless [], "ThePet";
-
- @A::Tike::ISA = 'TheLatrator';
- my $the_glob = $::{'The::'};
- $::{'The::'} = $::{'A::'};
-
- is $pet->speak, 'Bow-wow!',
- 'moving nested packages by assigning to a stash elem updates isa caches';
-
- undef $the_glob;
- is $pet->speak, 'Bow-wow!',
- 'isa caches are up to date after the replaced nested stash is freed';
+for(
+ {
+ name => 'assigning a glob to a stash element',
+ code => '$life_raft = $::{"Left::"}; $::{"Left::"} = $::{"Right::"}',
+ },
+ {
+ name => 'assigning a string to a stash element',
+ code => '$life_raft = $::{"Left::"}; $::{"Left::"} = "Right::"',
+ },
+ {
+ name => 'assigning a stashref to a stash element',
+ code => '$life_raft = \%Left::; $::{"Left::"} = \%Right::',
+ },
+) {
+ fresh_perl_is
+ q~
+ @Subclass::ISA = "Left::Side";
+ @Left::Side::ISA = "TopLeft";
+
+ sub TopLeft::speak { "Woof!" }
+ sub TopRight::speak { "Bow-wow!" }
+
+ my $thing = bless [], "Subclass";
+
+ @Right::Side::ISA = 'TopRight';
+ my $life_raft;
+ __code__;
+
+ print $thing->speak, "\n";
+
+ undef $life_raft;
+ print $thing->speak, "\n";
+ ~ =~ s\__code__\$$_{code}\r,
+ "Bow-wow!\nBow-wow!\n",
+ {},
+ "replacing nested packages by $$_{name} updates isa caches";
}
-# Another hylactic example: Test that deleting stash elements containing
+# Test that deleting stash elements containing
# subpackages also invalidates the isa cache.
{
@Pet::ISA = ("Cur", "Hound"); |
From @cpansproutOn Aug 22, 2010, at 5:46 PM, Father Chrysostomos wrote:
That patch can cause a bus error, so here is a new version. The third patch no longer applies with this version, so here is a new version of that, too (3b). |
From @cpansproutFrom: Father Chrysostomos <sprout@cpan.org> [perl #75176] Reset isa on stash manipulation This only applies to glob-to-glob assignments and deletions of stash It adds mro_package_moved, a private function that iterates through Inline Patchdiff -up blead-75176-isarev0/embed.fnc blead-75176-isarev1/embed.fnc
--- blead-75176-isarev0/embed.fnc 2010-06-13 07:28:11.000000000 -0700
+++ blead-75176-isarev1/embed.fnc 2010-08-22 17:10:15.000000000 -0700
@@ -2361,6 +2361,7 @@ sd |AV* |mro_get_linear_isa_dfs|NN HV* s
: Used in hv.c, mg.c, pp.c, sv.c
pd |void |mro_isa_changed_in|NN HV* stash
Apd |void |mro_method_changed_in |NN HV* stash
+pdx |void |mro_package_moved |NN const HV *stash
: Only used in perl.c
p |void |boot_core_mro
Apon |void |sys_init |NN int* argc|NN char*** argv
diff -up blead-75176-isarev0/embed.h blead-75176-isarev1/embed.h
--- blead-75176-isarev0/embed.h 2010-06-05 15:42:10.000000000 -0700
+++ blead-75176-isarev1/embed.h 2010-08-22 11:16:16.000000000 -0700
@@ -2052,6 +2052,7 @@
#endif
#define mro_method_changed_in Perl_mro_method_changed_in
#ifdef PERL_CORE
+#define mro_package_moved Perl_mro_package_moved
#define boot_core_mro Perl_boot_core_mro
#endif
#if defined(USE_ITHREADS)
@@ -4501,6 +4502,7 @@
#endif
#define mro_method_changed_in(a) Perl_mro_method_changed_in(aTHX_ a)
#ifdef PERL_CORE
+#define mro_package_moved(a) Perl_mro_package_moved(aTHX_ a)
#define boot_core_mro() Perl_boot_core_mro(aTHX)
#endif
#ifdef PERL_CORE
diff -up blead-75176-isarev0/hv.c blead-75176-isarev1/hv.c
--- blead-75176-isarev0/hv.c 2010-06-05 05:47:09.000000000 -0700
+++ blead-75176-isarev1/hv.c 2010-08-22 14:55:08.000000000 -0700
@@ -710,8 +710,32 @@ Perl_hv_common(pTHX_ HV *hv, SV *keysv,
}
HeVAL(entry) = val;
} else if (action & HV_FETCH_ISSTORE) {
- SvREFCNT_dec(HeVAL(entry));
+ bool moving_package = FALSE;
+ SV *old_val = HeVAL(entry);
+
+ /* If this is a stash and the key ends with ::, then some-
+ one is aliasing (or moving) a package. */
+ if (HvNAME(hv)) {
+ if (keysv) key = SvPV(keysv, klen);
+ if (klen > 1
+ && key[klen-2] == ':' && key[klen-1] == ':') {
+ if(SvTYPE(old_val) == SVt_PVGV) {
+ const HV * const old_stash
+ = GvHV((GV *)old_val);
+ if(old_stash && HvNAME(old_stash))
+ mro_package_moved(old_stash);
+ }
+ moving_package = TRUE;
+ }
+ }
+
+ SvREFCNT_dec(old_val);
HeVAL(entry) = val;
+
+ if (moving_package && SvTYPE(val) == SVt_PVGV) {
+ const HV * const stash = GvHV((GV *)val);
+ if (stash && HvNAME(stash)) mro_package_moved(stash);
+ }
}
} else if (HeVAL(entry) == &PL_sv_placeholder) {
/* if we find a placeholder, we pretend we haven't found
@@ -1054,6 +1078,18 @@ S_hv_delete_common(pTHX_ HV *hv, SV *key
HvPLACEHOLDERS(hv)++;
} else {
*oentry = HeNEXT(entry);
+
+ /* If this is a stash and the key ends with ::, then someone is
+ deleting a package. */
+ if (sv && HvNAME(hv)) {
+ if (keysv) key = SvPV(keysv, klen);
+ if (klen > 1 && key[klen-2] == ':' && key[klen-1] == ':'
+ && SvTYPE(sv) == SVt_PVGV) {
+ const HV * const stash = GvHV((GV *)sv);
+ if (stash && HvNAME(stash)) mro_package_moved(stash);
+ }
+ }
+
if (SvOOK(hv) && entry == HvAUX(hv)->xhv_eiter /* HvEITER(hv) */)
HvLAZYDEL_on(hv);
else
diff -up blead-75176-isarev0/mro.c blead-75176-isarev1/mro.c
--- blead-75176-isarev0/mro.c 2010-05-24 08:49:15.000000000 -0700
+++ blead-75176-isarev1/mro.c 2010-09-04 23:30:33.000000000 -0700
@@ -549,6 +550,56 @@ Perl_mro_isa_changed_in(pTHX_ HV* stash)
}
/*
+=for apidoc mro_package_moved
+
+Invalidates isa caches on this stash, on all subpackages nested inside it,
+and on the subclasses of all those.
+
+=cut
+*/
+void
+Perl_mro_package_moved(pTHX_ const HV *stash)
+{
+ register XPVHV* xhv;
+ register HE *entry;
+ I32 riter = -1;
+
+ PERL_ARGS_ASSERT_MRO_PACKAGE_MOVED;
+
+ mro_isa_changed_in((HV *)stash);
+
+ if(!HvARRAY(stash)) return;
+
+ /* This is partly based on code in hv_iternext_flags. We are not call-
+ ing that here, as we want to avoid resetting the hash iterator. */
+
+ xhv = (XPVHV*)SvANY(stash);
+
+ /* Skip the entire loop if the hash is empty. */
+ if (HvUSEDKEYS(stash)) {
+ while (++riter <= (I32)xhv->xhv_max) {
+ entry = (HvARRAY(stash))[riter];
+
+ /* Iterate through the entries in this list */
+ for(; entry; entry = HeNEXT(entry)) {
+ const char* key;
+ I32 len;
+
+ /* If this entry is not a glob, ignore it.
+ Try the next. */
+ if (!isGV(HeVAL(entry))) continue;
+
+ key = hv_iterkey(entry, &len);
+ if(len > 1 && key[len-2] == ':' && key[len-1] == ':') {
+ const HV * const stash = GvHV(HeVAL(entry));
+ if(stash && HvNAME(stash)) mro_package_moved(stash);
+ }
+ }
+ }
+ }
+}
+
+/*
=for apidoc mro_method_changed_in
Invalidates method caching on any child classes
diff -up blead-75176-isarev0/proto.h blead-75176-isarev1/proto.h
--- blead-75176-isarev0/proto.h 2010-06-13 07:28:11.000000000 -0700
+++ blead-75176-isarev1/proto.h 2010-08-22 17:10:37.000000000 -0700
@@ -6889,6 +6889,11 @@ PERL_CALLCONV void Perl_mro_method_chang
#define PERL_ARGS_ASSERT_MRO_METHOD_CHANGED_IN \
assert(stash)
+PERL_CALLCONV void Perl_mro_package_moved(pTHX_ const HV *stash)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_MRO_PACKAGE_MOVED \
+ assert(stash)
+
PERL_CALLCONV void Perl_boot_core_mro(pTHX);
PERL_CALLCONV void Perl_sys_init(int* argc, char*** argv)
__attribute__nonnull__(1)
diff -up blead-75176-isarev0/sv.c blead-75176-isarev1/sv.c
--- blead-75176-isarev0/sv.c 2010-06-04 09:14:20.000000000 -0700
+++ blead-75176-isarev1/sv.c 2010-08-22 17:08:09.000000000 -0700
@@ -3609,7 +3609,8 @@ copy-ish functions and macros use this u
static void
S_glob_assign_glob(pTHX_ SV *const dstr, SV *const sstr, const int dtype)
{
- I32 mro_changes = 0; /* 1 = method, 2 = isa */
+ I32 mro_changes = 0; /* 1 = method, 2 = isa, 3 = recursive isa */
+ HV *old_stash;
PERL_ARGS_ASSERT_GLOB_ASSIGN_GLOB;
@@ -3655,8 +3656,23 @@ S_glob_assign_glob(pTHX_ SV *const dstr,
mro_changes = 1;
}
- if(strEQ(GvNAME((const GV *)dstr),"ISA"))
- mro_changes = 2;
+ /* We don’t need to check the name of the destination if it was not a
+ glob to begin with. */
+ if(dtype == SVt_PVGV) {
+ const char * const name = GvNAME((const GV *)dstr);
+ if(strEQ(name,"ISA"))
+ mro_changes = 2;
+ else {
+ const STRLEN len = GvNAMELEN(dstr);
+ if (len > 1 && name[len-2] == ':' && name[len-1] == ':') {
+ mro_changes = 3;
+
+ /* Set aside the old stash, so we can reset isa caches on
+ its subclasses. */
+ old_stash = GvHV(dstr);
+ }
+ }
+ }
gp_free(MUTABLE_GV(dstr));
isGV_with_GP_off(dstr);
@@ -3673,6 +3689,11 @@ S_glob_assign_glob(pTHX_ SV *const dstr,
}
GvMULTI_on(dstr);
if(mro_changes == 2) mro_isa_changed_in(GvSTASH(dstr));
+ else if(mro_changes == 3) {
+ const HV * const stash = GvHV(dstr);
+ if(stash && HvNAME(stash)) mro_package_moved(stash);
+ if(old_stash && HvNAME(old_stash)) mro_package_moved(old_stash);
+ }
else if(mro_changes) mro_method_changed_in(GvSTASH(dstr));
return;
}
diff -Nurp blead-75176-isarev0/t/mro/stash-manip.t blead-75176-isarev1/t/mro/stash-manip.t
--- blead-75176-isarev0/t/mro/stash-manip.t 1969-12-31 16:00:00.000000000 -0800
+++ blead-75176-isarev1/t/mro/stash-manip.t 2010-09-04 23:29:16.000000000 -0700
@@ -0,0 +1,83 @@
+#!./perl
+
+use strict;
+#use warnings;
+BEGIN {
+ unless (-d 'blib') {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+ require q(./test.pl);
+}
+
+plan(tests => 6);
+
+
+# Test that replacing a package by assigning to an existing stash element
+# invalidates the isa caches
+{
+ @Subclass::ISA = "Left";
+ @Left::ISA = "TopLeft";
+
+ sub TopLeft::speak { "Woof!" }
+ sub TopRight::speak { "Bow-wow!" }
+
+ my $thing = bless [], "Subclass";
+
+ # mro_package_moved needs to know to skip non-globs
+ $Right::{"gleck::"} = 3;
+
+ @Right::ISA = 'TopRight';
+ my $life_raft = $::{'Left::'};
+ $::{'Left::'} = $::{'Right::'};
+
+ is $thing->speak, 'Bow-wow!',
+ 'rearranging packages by assigning to a stash elem updates isa caches';
+
+ undef $life_raft;
+ is $thing->speak, 'Bow-wow!',
+ 'isa caches are up to date after the replaced stash is freed';
+}
+
+# Similar test, but with nested packages
+{
+ @Subclass::ISA = "Left::Side";
+ @Left::Side::ISA = "TopLeft";
+
+ sub TopLeft::speak { "Woof!" }
+ sub TopRight::speak { "Bow-wow!" }
+
+ my $thing = bless [], "Subclass";
+
+ @Right::Side::ISA = 'TopRight';
+ my $life_raft = $::{'Left::'};
+ $::{'Left::'} = $::{'Right::'};
+
+ is $thing->speak, 'Bow-wow!',
+ 'moving nested packages by assigning to a stash elem updates isa caches';
+
+ undef $life_raft;
+ is $thing->speak, 'Bow-wow!',
+ 'isa caches are up to date after the replaced nested stash is freed';
+}
+
+# Test that deleting stash elements containing
+# subpackages also invalidates the isa cache.
+{
+ @Pet::ISA = ("Cur", "Hound");
+ @Cur::ISA = "Hylactete";
+
+ sub Hylactete::speak { "Arff!" }
+ sub Hound::speak { "Woof!" }
+
+ my $pet = bless [], "Pet";
+
+ my $life_raft = delete $::{'Cur::'};
+
+ is $pet->speak, 'Woof!',
+ 'deleting a stash from its parent stash invalidates the isa caches';
+
+ undef $life_raft;
+ is $pet->speak, 'Woof!',
+ 'the deleted stash is gone completely when freed';
+} |
From @cpansproutFrom: Father Chrysostomos <sprout@cpan.org> [perl #75176] Make more ways to manipulate stashes reset isa caches This makes string-to-glob assignment and hashref-to-glob assignment Inline Patchdiff -Nup blead-75176-isarev1/sv.c blead-75176-isarev2/sv.c
--- blead-75176-isarev1/sv.c 2010-08-22 17:08:09.000000000 -0700
+++ blead-75176-isarev2/sv.c 2010-08-29 15:52:37.000000000 -0700
@@ -3800,7 +3800,15 @@ S_glob_assign_ref(pTHX_ SV *const dstr,
&& CopSTASH_ne(PL_curcop, GvSTASH(dstr))) {
GvFLAGS(dstr) |= import_flag;
}
- if (stype == SVt_PVAV && strEQ(GvNAME((GV*)dstr), "ISA")) {
+ if (stype == SVt_PVHV) {
+ const char * const name = GvNAME((GV*)dstr);
+ const STRLEN len = GvNAMELEN(dstr);
+ if (len > 1 && name[len-2] == ':' && name[len-1] == ':') {
+ if(HvNAME(dref)) mro_package_moved((HV *)dref);
+ if(HvNAME(sref)) mro_package_moved((HV *)sref);
+ }
+ }
+ else if (stype == SVt_PVAV && strEQ(GvNAME((GV*)dstr), "ISA")) {
sv_magic(sref, dstr, PERL_MAGIC_isa, NULL, 0);
mro_isa_changed_in(GvSTASH(dstr));
}
@@ -4043,9 +4051,27 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, regi
else {
GV *gv = gv_fetchsv(sstr, GV_ADD, SVt_PVGV);
if (dstr != (const SV *)gv) {
+ const char * const name = GvNAME((const GV *)dstr);
+ const STRLEN len = GvNAMELEN(dstr);
+ HV *old_stash;
+ bool reset_isa = FALSE;
+ if (len > 1 && name[len-2] == ':' && name[len-1] == ':') {
+ /* Set aside the old stash, so we can reset isa caches
+ on its subclasses. */
+ old_stash = GvHV(dstr);
+ reset_isa = TRUE;
+ }
+
if (GvGP(dstr))
gp_free(MUTABLE_GV(dstr));
GvGP(dstr) = gp_ref(GvGP(gv));
+
+ if (reset_isa) {
+ const HV * const stash = GvHV(dstr);
+ if(stash && HvNAME(stash)) mro_package_moved(stash);
+ if(old_stash && HvNAME(old_stash))
+ mro_package_moved(old_stash);
+ }
}
}
}
diff -rup blead-75176-isarev1/t/mro/stash-manip.t blead-75176-isarev2/t/mro/stash-manip.t
--- blead-75176-isarev1/t/mro/stash-manip.t 2010-09-04 23:29:16.000000000 -0700
+++ blead-75176-isarev2/t/mro/stash-manip.t 2010-09-04 23:39:13.000000000 -0700
@@ -10,55 +10,89 @@ BEGIN {
require q(./test.pl);
}
-plan(tests => 6);
+plan(tests => 8);
# Test that replacing a package by assigning to an existing stash element
# invalidates the isa caches
-{
- @Subclass::ISA = "Left";
- @Left::ISA = "TopLeft";
-
- sub TopLeft::speak { "Woof!" }
- sub TopRight::speak { "Bow-wow!" }
-
- my $thing = bless [], "Subclass";
-
- # mro_package_moved needs to know to skip non-globs
- $Right::{"gleck::"} = 3;
-
- @Right::ISA = 'TopRight';
- my $life_raft = $::{'Left::'};
- $::{'Left::'} = $::{'Right::'};
-
- is $thing->speak, 'Bow-wow!',
- 'rearranging packages by assigning to a stash elem updates isa caches';
-
- undef $life_raft;
- is $thing->speak, 'Bow-wow!',
- 'isa caches are up to date after the replaced stash is freed';
+for(
+ {
+ name => 'assigning a glob to a stash element',
+ code => '$life_raft = $::{"Left::"}; $::{"Left::"} = $::{"Right::"}',
+ },
+ {
+ name => 'assigning a string to a stash element',
+ code => '$life_raft = $::{"Left::"}; $::{"Left::"} = "Right::"',
+ },
+ {
+ name => 'assigning a stashref to a stash element',
+ code => '$life_raft = \%Left::; $::{"Left::"} = \%Right::',
+ },
+) {
+ fresh_perl_is
+ q~
+ @Subclass::ISA = "Left";
+ @Left::ISA = "TopLeft";
+
+ sub TopLeft::speak { "Woof!" }
+ sub TopRight::speak { "Bow-wow!" }
+
+ my $thing = bless [], "Subclass";
+
+ # mro_package_moved needs to know to skip non-globs
+ $Right::{"gleck::"} = 3;
+
+ @Right::ISA = 'TopRight';
+ my $life_raft;
+ __code__;
+
+ print $thing->speak, "\n";
+
+ undef $life_raft;
+ print $thing->speak, "\n";
+ ~ =~ s\__code__\$$_{code}\r,
+ "Bow-wow!\nBow-wow!\n",
+ {},
+ "replacing packages by $$_{name} updates isa caches";
}
# Similar test, but with nested packages
-{
- @Subclass::ISA = "Left::Side";
- @Left::Side::ISA = "TopLeft";
-
- sub TopLeft::speak { "Woof!" }
- sub TopRight::speak { "Bow-wow!" }
-
- my $thing = bless [], "Subclass";
-
- @Right::Side::ISA = 'TopRight';
- my $life_raft = $::{'Left::'};
- $::{'Left::'} = $::{'Right::'};
-
- is $thing->speak, 'Bow-wow!',
- 'moving nested packages by assigning to a stash elem updates isa caches';
-
- undef $life_raft;
- is $thing->speak, 'Bow-wow!',
- 'isa caches are up to date after the replaced nested stash is freed';
+for(
+ {
+ name => 'assigning a glob to a stash element',
+ code => '$life_raft = $::{"Left::"}; $::{"Left::"} = $::{"Right::"}',
+ },
+ {
+ name => 'assigning a string to a stash element',
+ code => '$life_raft = $::{"Left::"}; $::{"Left::"} = "Right::"',
+ },
+ {
+ name => 'assigning a stashref to a stash element',
+ code => '$life_raft = \%Left::; $::{"Left::"} = \%Right::',
+ },
+) {
+ fresh_perl_is
+ q~
+ @Subclass::ISA = "Left::Side";
+ @Left::Side::ISA = "TopLeft";
+
+ sub TopLeft::speak { "Woof!" }
+ sub TopRight::speak { "Bow-wow!" }
+
+ my $thing = bless [], "Subclass";
+
+ @Right::Side::ISA = 'TopRight';
+ my $life_raft;
+ __code__;
+
+ print $thing->speak, "\n";
+
+ undef $life_raft;
+ print $thing->speak, "\n";
+ ~ =~ s\__code__\$$_{code}\r,
+ "Bow-wow!\nBow-wow!\n",
+ {},
+ "replacing nested packages by $$_{name} updates isa caches";
}
# Test that deleting stash elements containing |
From @cpansproutOn Aug 29, 2010, at 2:09 PM, Father Chrysostomos wrote:
Here is a patch for this. I used approach number 1 because number 2 proved to be far more complicated than I had thought, and probably too risky. I am not so sure now that mro_package_moved needs to be made public. But we could change that later if necessary. I did not bother with a mathom for mro_isa_changed_in, since this patch relies on the fix for #77362, which changes behaviour in a way that is not suitable for maint. (There are many other bugs that can occur more often as a result of that fix.) |
From @cpansproutFrom: Father Chrysostomos <sprout@cpan.org> [perl #75176] Make assignment to undef stash elems reset caches This makes assignment to undefined or nonexistent stash elements It does this by creating PVLVs with defelem magic in pp_helem if the Because it is necessary to invalidate isa caches on the subclasses of Inline Patchdiff -up blead-75176-isarev3.base/embed.fnc blead-75176-isarev3/embed.fnc
--- blead-75176-isarev3.base/embed.fnc 2010-09-04 06:30:03.000000000 -0700
+++ blead-75176-isarev3/embed.fnc 2010-09-04 20:22:22.000000000 -0700
@@ -2370,7 +2370,8 @@ Apd |AV* |mro_get_linear_isa|NN HV* stas
sd |AV* |mro_get_linear_isa_dfs|NN HV* stash|U32 level
#endif
: Used in hv.c, mg.c, pp.c, sv.c
-pd |void |mro_isa_changed_in|NN HV* stash
+md |void |mro_isa_changed_in|NN HV* stash
+pd |void |mro_isa_changed_in3|NULLOK HV* stash|NULLOK const char *stashname|STRLEN stashname_len
Apd |void |mro_method_changed_in |NN HV* stash
pdx |void |mro_package_moved |NN const HV *stash
: Only used in perl.c
diff -up blead-75176-isarev3.base/embed.h blead-75176-isarev3/embed.h
--- blead-75176-isarev3.base/embed.h 2010-09-04 06:30:03.000000000 -0700
+++ blead-75176-isarev3/embed.h 2010-09-04 20:22:51.000000000 -0700
@@ -2064,7 +2064,7 @@
#endif
#endif
#ifdef PERL_CORE
-#define mro_isa_changed_in Perl_mro_isa_changed_in
+#define mro_isa_changed_in3 Perl_mro_isa_changed_in3
#endif
#define mro_method_changed_in Perl_mro_method_changed_in
#ifdef PERL_CORE
@@ -4526,7 +4526,7 @@
#endif
#endif
#ifdef PERL_CORE
-#define mro_isa_changed_in(a) Perl_mro_isa_changed_in(aTHX_ a)
+#define mro_isa_changed_in3(a,b,c) Perl_mro_isa_changed_in3(aTHX_ a,b,c)
#endif
#define mro_method_changed_in(a) Perl_mro_method_changed_in(aTHX_ a)
#ifdef PERL_CORE
diff -up blead-75176-isarev3.base/hv.h blead-75176-isarev3/hv.h
--- blead-75176-isarev3.base/hv.h 2010-05-21 12:02:12.000000000 -0700
+++ blead-75176-isarev3/hv.h 2010-09-04 20:34:13.000000000 -0700
@@ -67,6 +67,7 @@ struct mro_meta {
(((smeta)->mro_which && (which) == (smeta)->mro_which) \
? (smeta)->mro_linear_current \
: Perl_mro_get_private_data(aTHX_ (smeta), (which)))
+#define mro_isa_changed_in(stash) mro_isa_changed_in3(stash, NULL, 0)
/* Subject to change.
Don't access this directly.
diff -up blead-75176-isarev3.base/mg.c blead-75176-isarev3/mg.c
--- blead-75176-isarev3.base/mg.c 2010-08-20 18:55:11.000000000 -0700
+++ blead-75176-isarev3/mg.c 2010-09-04 20:42:40.000000000 -0700
@@ -2183,7 +2183,12 @@ Perl_magic_getdefelem(pTHX_ SV *sv, MAGI
if ((I32)LvTARGOFF(sv) <= AvFILL(av))
targ = AvARRAY(av)[LvTARGOFF(sv)];
}
- if (targ && (targ != &PL_sv_undef)) {
+ if (targ
+ && (
+ (targ != &PL_sv_undef && LvTYPE(sv) == 'y')
+ || (isGV(targ) && !SvFAKE(targ))
+ )
+ ) {
/* somebody else defined it for us */
SvREFCNT_dec(LvTARG(sv));
LvTARG(sv) = SvREFCNT_inc_simple_NN(targ);
@@ -2203,9 +2208,46 @@ int
Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
{
PERL_ARGS_ASSERT_MAGIC_SETDEFELEM;
- PERL_UNUSED_ARG(mg);
if (LvTARGLEN(sv))
+ {
+ if (LvTYPE(sv) == 'y')
vivify_defelem(sv);
+ else if (mg->mg_obj) { /* stash element */
+ SV *value = NULL;
+ SV * const ahv = LvTARG(sv);
+ HE * const he = hv_fetch_ent(MUTABLE_HV(ahv), mg->mg_obj, TRUE, 0);
+ HV *old_stash = NULL;
+
+ if (he)
+ value = HeVAL(he);
+ if (!value || value == &PL_sv_undef)
+ Perl_croak(aTHX_ PL_no_helem_sv, SVfARG(mg->mg_obj));
+
+ if (isGV(value)) old_stash = GvHV(MUTABLE_GV(value));
+
+ sv_setsv(value, sv);
+ SvSETMAGIC(value);
+
+ if (old_stash && HvNAME(old_stash)) mro_package_moved(old_stash);
+ else {
+ /* Oh dear! This package does not exist. */
+ STRLEN klen;
+ const char * const key = SvPV_const(mg->mg_obj, klen);
+ mro_isa_changed_in3(NULL, key, klen-2 /* strip :: */);
+ }
+ if (isGV(value)) {
+ const HV * const new_stash = GvHV(MUTABLE_GV(value));
+ if (new_stash && HvNAME(new_stash))
+ mro_package_moved(new_stash);
+ }
+
+ /* If it turns out there was a real glob in the hash element, we
+ can go ahead and make the lvalue point straight to it. */
+ if (isGV(value) && !SvFAKE(value)) vivify_defelem(sv);
+
+ return 0;
+ }
+ }
if (LvTARG(sv)) {
sv_setsv(LvTARG(sv), sv);
SvSETMAGIC(LvTARG(sv));
diff -up blead-75176-isarev3.base/mro.c blead-75176-isarev3/mro.c
--- blead-75176-isarev3.base/mro.c 2010-09-04 06:30:03.000000000 -0700
+++ blead-75176-isarev3/mro.c 2010-09-04 20:33:41.000000000 -0700
@@ -411,10 +411,22 @@ Takes the necessary steps (cache invalid
when the @ISA of the given package has changed. Invoked
by the C<setisa> magic, should not need to invoke directly.
+=for apidoc mro_isa_changed_in3
+
+Takes the necessary steps (cache invalidations, mostly)
+when the @ISA of the given package has changed. Invoked
+by the C<setisa> magic, should not need to invoke directly.
+
+The stash can be passed as the first argument, or its name and length as
+the second and third (or both). If just the name is passed and the stash
+does not exist, then only the subclasses' method and isa caches will be
+invalidated.
+
=cut
*/
void
-Perl_mro_isa_changed_in(pTHX_ HV* stash)
+Perl_mro_isa_changed_in3(pTHX_ HV* stash, const char *stashname,
+ STRLEN stashname_len)
{
dVAR;
HV* isarev;
@@ -423,35 +435,39 @@ Perl_mro_isa_changed_in(pTHX_ HV* stash)
SV** svp;
I32 items;
bool is_universal;
- struct mro_meta * meta;
-
- const char * const stashname = HvNAME_get(stash);
- const STRLEN stashname_len = HvNAMELEN_get(stash);
+ struct mro_meta * meta = NULL;
- PERL_ARGS_ASSERT_MRO_ISA_CHANGED_IN;
+ if(!stashname && stash) {
+ stashname = HvNAME_get(stash);
+ stashname_len = HvNAMELEN_get(stash);
+ }
+ else if(!stash)
+ stash = gv_stashpvn(stashname, stashname_len, 0 /* don't add */);
if(!stashname)
Perl_croak(aTHX_ "Can't call mro_isa_changed_in() on anonymous symbol table");
- /* wipe out the cached linearizations for this stash */
- meta = HvMROMETA(stash);
- if (meta->mro_linear_all) {
+ if(stash) {
+ /* wipe out the cached linearizations for this stash */
+ meta = HvMROMETA(stash);
+ if (meta->mro_linear_all) {
SvREFCNT_dec(MUTABLE_SV(meta->mro_linear_all));
meta->mro_linear_all = NULL;
/* This is just acting as a shortcut pointer. */
meta->mro_linear_current = NULL;
- } else if (meta->mro_linear_current) {
+ } else if (meta->mro_linear_current) {
/* Only the current MRO is stored, so this owns the data. */
SvREFCNT_dec(meta->mro_linear_current);
meta->mro_linear_current = NULL;
- }
- if (meta->isa) {
+ }
+ if (meta->isa) {
SvREFCNT_dec(meta->isa);
meta->isa = NULL;
- }
+ }
- /* Inc the package generation, since our @ISA changed */
- meta->pkg_gen++;
+ /* Inc the package generation, since our @ISA changed */
+ meta->pkg_gen++;
+ }
/* Wipe the global method cache if this package
is UNIVERSAL or one of its parents */
@@ -465,12 +481,12 @@ Perl_mro_isa_changed_in(pTHX_ HV* stash)
is_universal = TRUE;
}
else { /* Wipe the local method cache otherwise */
- meta->cache_gen++;
+ if(meta) meta->cache_gen++;
is_universal = FALSE;
}
/* wipe next::method cache too */
- if(meta->mro_nextmethod) hv_clear(meta->mro_nextmethod);
+ if(meta && meta->mro_nextmethod) hv_clear(meta->mro_nextmethod);
/* Iterate the isarev (classes that are our children),
wiping out their linearization, method and isa caches */
@@ -511,6 +527,9 @@ Perl_mro_isa_changed_in(pTHX_ HV* stash)
3) Add everything from our isarev to their isarev
*/
+ /* This only applies if the stash exists. */
+ if(!stash) return;
+
/* We're starting at the 2nd element, skipping ourselves here */
linear_mro = mro_get_linear_isa(stash);
svp = AvARRAY(linear_mro) + 1;
diff -up blead-75176-isarev3.base/pp_hot.c blead-75176-isarev3/pp_hot.c
--- blead-75176-isarev3.base/pp_hot.c 2010-09-04 09:37:13.000000000 -0700
+++ blead-75176-isarev3/pp_hot.c 2010-09-04 22:27:05.000000000 -0700
@@ -1823,15 +1823,22 @@ PP(pp_helem)
he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
svp = he ? &HeVAL(he) : NULL;
if (lval) {
- if (!svp || *svp == &PL_sv_undef) {
+ bool stash_elem = FALSE;
+ if (HvNAME(hv) && (!svp || !isGV(*svp))) {
+ STRLEN klen = 0;
+ const char * const key = SvPV_const(keysv, klen);
+ if (klen > 1 && key[klen-2] == ':' && key[klen-1] == ':')
+ stash_elem = TRUE;
+ }
+ if (!svp || *svp == &PL_sv_undef || stash_elem) {
SV* lv;
SV* key2;
- if (!defer) {
+ if (!defer && !stash_elem) {
DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
}
lv = sv_newmortal();
sv_upgrade(lv, SVt_PVLV);
- LvTYPE(lv) = 'y';
+ LvTYPE(lv) = stash_elem ? '*' : 'y';
sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, NULL, 0);
SvREFCNT_dec(key2); /* sv_magic() increments refcount */
LvTARG(lv) = SvREFCNT_inc_simple(hv);
diff -up blead-75176-isarev3.base/proto.h blead-75176-isarev3/proto.h
--- blead-75176-isarev3.base/proto.h 2010-09-04 06:30:03.000000000 -0700
+++ blead-75176-isarev3/proto.h 2010-09-04 20:22:51.000000000 -0700
@@ -6914,11 +6914,10 @@ STATIC AV* S_mro_get_linear_isa_dfs(pTHX
assert(stash)
#endif
-PERL_CALLCONV void Perl_mro_isa_changed_in(pTHX_ HV* stash)
- __attribute__nonnull__(pTHX_1);
-#define PERL_ARGS_ASSERT_MRO_ISA_CHANGED_IN \
- assert(stash)
+/* PERL_CALLCONV void mro_isa_changed_in(pTHX_ HV* stash)
+ __attribute__nonnull__(pTHX_1); */
+PERL_CALLCONV void Perl_mro_isa_changed_in3(pTHX_ HV* stash, const char *stashname, STRLEN stashname_len);
PERL_CALLCONV void Perl_mro_method_changed_in(pTHX_ HV* stash)
__attribute__nonnull__(pTHX_1);
#define PERL_ARGS_ASSERT_MRO_METHOD_CHANGED_IN \
diff -up blead-75176-isarev3.base/sv.h blead-75176-isarev3/sv.h
--- blead-75176-isarev3.base/sv.h 2010-08-20 18:55:11.000000000 -0700
+++ blead-75176-isarev3/sv.h 2010-09-04 09:39:08.000000000 -0700
@@ -465,8 +465,18 @@ struct xpvlv {
STRLEN xlv_targoff;
STRLEN xlv_targlen;
SV* xlv_targ;
- char xlv_type; /* k=keys .=pos x=substr v=vec /=join/re
- * y=alem/helem/iter t=tie T=tied HE */
+ char xlv_type;
+ /* Values for xlv_type:
+ k keys
+ . pos
+ x substr
+ v vec
+ / join/re
+ y alem/helem/iter
+ * stash elem
+ t tie
+ T tied HE
+ */
};
/* This structure works in 3 ways - regular scalar, GV with GP, or fast
diff -rup blead-75176-isarev3.base/t/mro/stash-manip.t blead-75176-isarev3/t/mro/stash-manip.t
--- blead-75176-isarev3.base/t/mro/stash-manip.t 2010-09-04 06:30:19.000000000 -0700
+++ blead-75176-isarev3/t/mro/stash-manip.t 2010-09-04 18:39:41.000000000 -0700
@@ -10,7 +10,7 @@ BEGIN {
require q(./test.pl);
}
-plan(tests => 8);
+plan(tests => 18);
# Test that replacing a package by assigning to an existing stash element
@@ -112,3 +112,112 @@ for(
is $pet->speak, 'Woof!',
'the deleted stash is gone completely when freed';
}
+
+# Test that assignment to a nonexistent stash element updates caches
+#
+# This is what we have at first (Blank does not exist):
+#
+# Blank Parent
+# \ /
+# Subclass
+#
+# Then we make Blank an alias for Another::Class, resulting in:
+#
+# Another::Parent
+# |
+# |
+# Another::Class Parent
+# \ /
+# \ /
+# Subclass
+#
+# Subclass’s isa cache needs to be updated to include Another::Parent.
+#
+for(
+ {
+ name => 'assigning a glob to a nonexistent stash element',
+ code => '$::{"Blank::"} = *Another::Class::',
+ },
+ {
+ name => 'assigning a glob to nonexistent elem via list assignment',
+ code => '($foo, $::{"Blank::"}) = (frelp => *Another::Class::)',
+ },
+ {
+ name => 'assigning a glob to nonexistent element through a sub arg',
+ code => 'sub{$_[0] = *Another::Class::}->($::{"Blank::"})',
+ },
+ {
+ name => 'list assignment of a glob to nonexistent elem via a sub arg',
+ code => 'sub{($foo,$_[0]) = (fr=>*Another::Class::)}->($::{"Blank::"})',
+ },
+) {
+ fresh_perl_is
+ q~
+ @Subclass::ISA = ("Blank", "Parent");
+
+ sub Parent::speak { "Woof!" }
+ @Another::Class::ISA = "Another::Parent";
+ sub Another::Parent::speak { "Bow-wow!" }
+
+ my $thing = bless [], "Subclass";
+ $thing -> speak; # cache the method
+
+ __code__; # make Blank an alias to Another::Class
+
+ print $thing->speak, "\n";
+ ~ =~ s\__code__\$$_{code}\r,
+ "Bow-wow!\n",
+ {},
+ "$$_{name} updates isa caches";
+}
+
+# Assignment to undef (but existing) stash elements
+# The same diagrams apply to this, too. Here $::{"Blank::"} is undef,
+# rather than nonexistent.
+for(
+ {
+ name => 'assigning a glob to an undef stash element',
+ code => '$::{"Blank::"} = *Another::Class::',
+ },
+ {
+ name => 'assigning a glob to an undef stash elem via list assignment',
+ code => '($foo, $::{"Blank::"}) = (frelp => *Another::Class::)',
+ },
+ {
+ name => 'assigning a glob to an undef stash element through a sub arg',
+ code => 'sub{$_[0] = *Another::Class::}->($::{"Blank::"})',
+ },
+ {
+ name => 'list assignment of a glob to undef stash elem via a sub arg',
+ code => 'sub{($foo,$_[0]) = (fr=>*Another::Class::)}->($::{"Blank::"})',
+ },
+ {
+ name => 'assigning a glob to undef stash elem that has been referenced',
+ code => '$foo = \$::{"Blank::"}; $::{"Blank::"} = *Another::Class::',
+ },
+ {
+ name => 'assigning a glob to an undef stash elem through a reference',
+ code => '${\$::{"Blank::"}} = *Another::Class::',
+ },
+) {
+ fresh_perl_is
+ q~
+ @Subclass::ISA = ("Blank", "Parent");
+
+ sub Parent::speak { "Woof!" }
+ @Another::Class::ISA = "Another::Parent";
+ sub Another::Parent::speak { "Bow-wow!" }
+
+ my $thing = bless [], "Subclass";
+ $thing -> speak; # cache the method
+ $::{"Blank::"} = undef;
+
+ __code__; # make Blank an alias to Another::Class
+
+ print $thing->speak, "\n";
+ ~ =~ s\__code__\$$_{code}\r,
+ "Bow-wow!\n",
+ {},
+ "$$_{name} updates isa caches";
+}
+ |
From @cpansproutOn Sun Sep 05 13:15:28 2010, sprout wrote:
Applied as c8bbf67. |
From [Unknown Contact. See original ticket]On Sun Sep 05 13:15:28 2010, sprout wrote:
Applied as c8bbf67. |
From @cpansproutOn Sun Aug 22 20:21:25 2010, sprout wrote:
I’m now putting the tests in package_alias.t or whatever it’s called, so |
From [Unknown Contact. See original ticket]On Sun Aug 22 20:21:25 2010, sprout wrote:
I’m now putting the tests in package_alias.t or whatever it’s called, so |
From @cpansproutOn Sun Sep 05 13:15:28 2010, sprout wrote:
3b has been applied as 1c93aaac75354eeef. |
From [Unknown Contact. See original ticket]On Sun Sep 05 13:15:28 2010, sprout wrote:
3b has been applied as 1c93aaac75354eeef. |
From @cpansproutOn Sat Oct 09 23:06:49 2010, sprout wrote:
Er, actually 3e79609. |
From [Unknown Contact. See original ticket]On Sat Oct 09 23:06:49 2010, sprout wrote:
Er, actually 3e79609. |
From @cpansproutOn Sun Sep 05 13:18:02 2010, sprout wrote:
That fourth patch is no good. Not only does it have mistakes, but the • It only works with top-level packages And I now think that assignments to empty stash elements should not be |
From [Unknown Contact. See original ticket]On Sun Sep 05 13:18:02 2010, sprout wrote:
That fourth patch is no good. Not only does it have mistakes, but the • It only works with top-level packages And I now think that assignments to empty stash elements should not be |
From @cpansproutNow fixed by 80ebaca and a couple dozen patches leading up to it. |
@cpansprout - Status changed from 'open' to 'resolved' |
Migrated from rt.perl.org#75176 (status was 'resolved')
Searchable as RT75176$
The text was updated successfully, but these errors were encountered: