Skip to content
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

Closed
p5pRT opened this issue May 18, 2010 · 47 comments
Closed

Comments

@p5pRT
Copy link
Collaborator

@p5pRT p5pRT commented May 18, 2010

Migrated from rt.perl.org#75176 (status was 'resolved')

Searchable as RT75176$

@p5pRT
Copy link
Collaborator Author

@p5pRT p5pRT commented May 18, 2010

From dev@airwave.com

We 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 warnings;

use Symbol;
# use Devel​::Leak;

@​a​::ISA = qw(UNIVERSAL);
@​b​::ISA = qw(a);
@​c​::ISA = qw(b);

my $leak_more = 1;
my $base = $leak_more ? 'c' : '';

# my $handle;
# Devel​::Leak​::NoteSV($handle);

for my $count (0..20_000) {
  no strict 'refs';
  *{"Foo​::${count}​::ISA"} = [$base];
  Symbol​::delete_package("Foo​::${count}");

  memstats() unless $count % 5000;
}

# Devel​::Leak​::CheckSV($handle);

sub memstats {
  system("cat/proc/$$/status | grep VmRSS");
}

Perl Info

Flags:
     category=library
     severity=medium
     module=Symbol

Site configuration information for perl 5.10.1:

Configured by Red Hat, Inc. at Mon Oct 19 16:15:38 PDT 2009.

Summary of my perl5 (revision 5 version 10 subversion 1) configuration:

   Platform:
     osname=linux, osvers=2.6.18-128.4.1.el5pae, archname=i386-linux-thread-multi
     uname='linux langley.corp.airwave.com 2.6.18-128.4.1.el5pae #1 smp tue aug 4 20:58:34 edt 2009 i686 i686 i386 gnulinux '
     config_args='-des -Doptimize=-O2 -g -m32 -march=i386 -mtune=generic -fasynchronous-unwind-tables -Dversion=5.10.1 -Dmyhostname=localhost -Dperladmin=root@localhost -Dcc=gcc -Dcf_by=Red Hat, Inc. -Dinstallprefix=/opt/airwave -Dprefix=/opt/airwave -Dprivlib=/opt/airwave/lib/perl5/5.10.1 -Dsitelib=/opt/airwave/local/lib/perl5/site_perl/5.10.1 -Dvendorlib=/opt/airwave/lib/perl5/vendor_perl/5.10.1 -Darchlib=/opt/airwave/lib/perl5/5.10.1/i386-linux-thread-multi -Dsitearch=/opt/airwave/local/lib/perl5/site_perl/5.10.1/i386-linux-thread-multi -Dvendorarch=/opt/airwave/lib/perl5/vendor_perl/5.10.1/i386-linux-thread-multi -Darchname=i386-linux-thread-multi -Dvendorprefix=/opt/airwave -Dsiteprefix=/opt/airwave/local -Duseshrplib -Dusethreads -Duseithreads -Duselargefiles -Dd_dosuid -Dd_semctl_semun -Di_db -Ui_ndbm -Di_gdbm -Di_shadow -Di_syslog -Dman3ext=3pm -Duseperlio -Dinstallusrbinperl=n -Ubincompat5005 -Uversiononly -Dpager=/usr/bin/less -isr -Dd_gethostent_r_proto -Ud_endhoste
  nt_r_proto -Ud_sethostent_r_proto -Ud_endprotoent_r_proto -Ud_setprotoent_r_proto -Ud_endservent_r_proto -Ud_setservent_r_proto -Dscriptdir=/opt/airwave/bin'
     hint=recommended, useposix=true, d_sigaction=define
     useithreads=define, usemultiplicity=define
     useperlio=define, d_sfio=undef, uselargefiles=define, usesocks=undef
     use64bitint=undef, use64bitall=undef, uselongdouble=undef
     usemymalloc=n, bincompat5005=undef
   Compiler:
     cc='gcc', ccflags ='-D_REENTRANT -D_GNU_SOURCE -DDEBUGGING -fno-strict-aliasing -pipe -fstack-protector -I/usr/local/include -D_LARGEFILE_SOURCE -D_FILE_OFFSET_BITS=64',
     optimize='-O2 -g -m32 -march=i386 -mtune=generic -fasynchronous-unwind-tables',
     cppflags='-D_REENTRANT -D_GNU_SOURCE -DDEBUGGING -fno-strict-aliasing -pipe -fstack-protector -I/usr/local/include'
     ccversion='', gccversion='4.1.2 20080704 (Red Hat 4.1.2-44)', gccosandvers=''
     intsize=4, longsize=4, ptrsize=4, doublesize=8, byteorder=1234
     d_longlong=define, longlongsize=8, d_longdbl=define, longdblsize=12
     ivtype='long', ivsize=4, nvtype='double', nvsize=8, Off_t='off_t', lseeksize=8
     alignbytes=4, prototype=define
   Linker and Libraries:
     ld='gcc', ldflags =' -fstack-protector -L/usr/local/lib'
     libpth=/usr/local/lib /lib /usr/lib
     libs=-lresolv -lnsl -lgdbm -ldb -ldl -lm -lcrypt -lutil -lpthread -lc
     perllibs=-lresolv -lnsl -ldl -lm -lcrypt -lutil -lpthread -lc
     libc=/lib/libc-2.5.so, so=so, useshrplib=true, libperl=libperl.so
     gnulibc_version='2.5'
   Dynamic Linking:
     dlsrc=dl_dlopen.xs, dlext=so, d_dlsymun=undef, ccdlflags='-Wl,-E -Wl,-rpath,/opt/airwave/lib/perl5/5.10.1/i386-linux-thread-multi/CORE'
     cccdlflags='-fPIC', lddlflags='-shared -O2 -g -m32 -march=i386 -mtune=generic -fasynchronous-unwind-tables -L/usr/local/lib -fstack-protector'

Locally applied patches:



@INC for perl 5.10.1:
     /root/svn/mercury/lib/perl
     /root/svn/devtoys/rally/lib
     /root/svn/devtoys/bug_emails
     /root/svn/devtoys/farm
     /opt/airwave/lib/perl5/5.10.1/i386-linux-thread-multi
     /opt/airwave/lib/perl5/5.10.1
     /opt/airwave/local/lib/perl5/site_perl/5.10.1/i386-linux-thread-multi
     /opt/airwave/local/lib/perl5/site_perl/5.10.1
     /opt/airwave/local/lib/perl5/site_perl/5.10.0/i386-linux-thread-multi
     /opt/airwave/local/lib/perl5/site_perl/5.10.0
     /opt/airwave/local/lib/perl5/site_perl
     /opt/airwave/lib/perl5/vendor_perl/5.10.1/i386-linux-thread-multi
     /opt/airwave/lib/perl5/vendor_perl/5.10.1
     /opt/airwave/lib/perl5/vendor_perl/5.10.0/i386-linux-thread-multi
     /opt/airwave/lib/perl5/vendor_perl/5.10.0
     /opt/airwave/lib/perl5/vendor_perl
     .


Environment for perl 5.10.1:
     HOME=/root
     LANG=en_US
     LANGUAGE (unset)
     LD_LIBRARY_PATH (unset)
     LOGDIR (unset)
     PATH=/usr/local/sbin:/usr/sbin:/sbin:/opt/airwave/local/bin:/opt/airwave/bin:/usr/local/sbin:/root/svn/mercury/bin:/usr/local/airwave/bin:/usr/java/jre/bin:/usr/java/jdk/bin:/var/airwave/support:/opt/condor/sbin:/opt/condor/bin:/opt/flex/bin:/opt/ant/bin:/usr/kerberos/sbin:/usr/kerberos/bin:/usr/local/bin:/sbin:/bin:/usr/sbin:/usr/bin:/root/bin
     PERL5LIB=/root/svn/mercury/lib/perl:/root/svn/devtoys/rally/lib:/root/svn/devtoys/bug_emails:/root/svn/devtoys/farm
     PERL_BADLANG (unset)
     SHELL=/bin/bash


@p5pRT
Copy link
Collaborator Author

@p5pRT p5pRT commented May 19, 2010

From dev@airwave.com

For completeness (and to see whether an upgrade would make the problem
just "go away") we compiled a version of Perl 5.12.0 and ran the script
there as well, but the memory leak was still present.

@p5pRT
Copy link
Collaborator Author

@p5pRT p5pRT commented May 19, 2010

dev@airwave.com - Status changed from 'new' to 'open'

@p5pRT
Copy link
Collaborator Author

@p5pRT p5pRT commented May 19, 2010

From dev@airwave.com

whoops! i think that's *your* workflow I just clicked.

@p5pRT
Copy link
Collaborator Author

@p5pRT p5pRT commented May 19, 2010

dev@airwave.com - Status changed from 'open' to 'new'

@p5pRT
Copy link
Collaborator Author

@p5pRT p5pRT commented Jul 25, 2010

From webmasters@ctosonline.org

This 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
  performance consideration (properly tracking and deleting isarev
  entries when someone removes an entry from an @​ISA is costly, and it
  doesn't happen often anyways).

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.

@p5pRT
Copy link
Collaborator Author

@p5pRT p5pRT commented Jul 25, 2010

The RT System itself - Status changed from 'new' to 'open'

@p5pRT
Copy link
Collaborator Author

@p5pRT p5pRT commented Jul 27, 2010

From @nwc10

On Sun, Jul 25, 2010 at 12​:57​:02PM -0700, webmasters@​ctosonline.org wrote​:

This 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
  performance consideration \(properly tracking and deleting isarev
  entries when someone removes an entry from an @​ISA is costly\, and it
  doesn't happen often anyways\)\.

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?

The documentation you quoted continues with​:

  The fact that a class which no longer truly "isa" this class at
  runtime remains on the list should be considered a quirky
  implementation detail which is subject to future change. It shouldn't
  be an issue as long as you're looking at this list for the same
  reasons the core code does​: as a performance optimization over having
  to search every class in existence.

Yes, finding an efficient way to fix this would be useful and welcomed.

Nicholas Clark

@p5pRT
Copy link
Collaborator Author

@p5pRT p5pRT commented Aug 1, 2010

From @cpansprout

On Jul 27, 2010, at 7​:25 AM, Nicholas Clark wrote​:

On Sun, Jul 25, 2010 at 12​:57​:02PM -0700, webmasters@​ctosonline.org wrote​:

This 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
 performance consideration \(properly tracking and deleting isarev
 entries when someone removes an entry from an @​ISA is costly\, and it
 doesn't happen often anyways\)\.

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?

The documentation you quoted continues with​:

The fact that a class which no longer truly "isa" this class at
runtime remains on the list should be considered a quirky
implementation detail which is subject to future change. It shouldn't
be an issue as long as you're looking at this list for the same
reasons the core code does​: as a performance optimization over having
to search every class in existence.

Yes, finding an efficient way to fix this would be useful and welcomed.

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';
@​b'ISA = 'c';

sub c'bark { warn "Woof!" }
sub d'bark { warn "Bow-wow!" }

$a = bless [], a;
$a->bark; # Woof!

@​e'ISA = 'd';
$b = delete $​::{'b​::'};
$​::{'b​::'} = delete $​::{'e​::'};

$a->bark; # Woof! in 5.10; Bow-wow! in 5.8
undef $b;
$a->bark; # Bow-wow!

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
remove isarev entries when its @​ISA is changed.

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?

@p5pRT
Copy link
Collaborator Author

@p5pRT p5pRT commented Aug 2, 2010

From @nwc10

On Sun, Aug 01, 2010 at 12​:17​:36PM -0700, Father Chrysostomos wrote​:

[snip pathological but interesting example]

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.

I don't know with 100% certainty, but I see tests on SvGMAGICAL() in hv.c,
this in mg.c​:

  if (vtbl->svt_get && !(mg->mg_flags & MGf_GSKIP))
  SvGMAGICAL_on(sv);

and magic vtables in perl.h which have the svt_get function pointer set, such
as

MGVTBL_SET(
  PL_vtbl_sigelem,
  MEMBER_TO_FPTR(Perl_magic_getsig),
  MEMBER_TO_FPTR(Perl_magic_setsig),
  0,
  MEMBER_TO_FPTR(Perl_magic_clearsig),
  0,
  0,
  0,
  0
);

so I'm assuming that yes, it is used.
To the best of my knowledge there are no free flag bits on PVHV, and no more
that can be scavenged.

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?

Having any magic on all stashes is a measurable performance hit. For a while
in 5.9.x there was magic on stashes to store weak reference backreferences
(no vtable actions for get or set) and that was enough to slow things down.
That's why there's all the "extra" code to allow hashes to store backreferences
in the hv_aux structure. I believe that that's the logical place to hang any
extra data needed for this.

Also, if it's easier to implement, I don't see a problem with using the global
sub generation counter to flag when someone has directly manipulated the tree
of stashes. It's not common, and I don't see an absolute need to calculate the
strict set of packages affected, and call mro_changed_in() for just them.

Nicholas Clark

@p5pRT
Copy link
Collaborator Author

@p5pRT p5pRT commented Aug 8, 2010

From @cpansprout

On Aug 2, 2010, at 2​:34 AM, Nicholas Clark wrote​:

That's why there's all the "extra" code to allow hashes to store backreferences
in the hv_aux structure. I believe that that's the logical place to hang any
extra data needed for this.

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

Also, if it's easier to implement, I don't see a problem with using the global
sub generation counter to flag when someone has directly manipulated the tree
of stashes.

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?

It's not common, and I don't see an absolute need to calculate the
strict set of packages affected, and call mro_changed_in() for just them.

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

@p5pRT
Copy link
Collaborator Author

@p5pRT p5pRT commented Aug 8, 2010

From @cpansprout

On Aug 8, 2010, at 12​:22 PM, Father Chrysostomos wrote​:

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

Oops. I meant delete $​::{"PPI​::"}, of course.

@p5pRT
Copy link
Collaborator Author

@p5pRT p5pRT commented Aug 18, 2010

From @iabyn

On Sun, Aug 08, 2010 at 12​:22​:13PM -0700, Father Chrysostomos 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.)

Note that hv_clear and hv_undef may remove the aux struct, so you may not
be able to rely on it always remaining.

--
In England there is a special word which means the last sunshine
of the summer. That word is "spring".

@p5pRT
Copy link
Collaborator Author

@p5pRT p5pRT commented Aug 22, 2010

From @cpansprout

On Aug 18, 2010, at 9​:47 AM, Dave Mitchell wrote​:

On Sun, Aug 08, 2010 at 12​:22​:13PM -0700, Father Chrysostomos 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.)

Note that hv_clear and hv_undef may remove the aux struct, so you may not
be able to rely on it always remaining.

What happens to the name currently stored in there when that happens?

@p5pRT
Copy link
Collaborator Author

@p5pRT p5pRT commented Aug 23, 2010

From @cpansprout

On Aug 8, 2010, at 12​:22 PM, Father Chrysostomos wrote​:

If PL_sub_generation does not invalidate isa caches, would it be appropriate to add a new PL_isa_generation variable?

It's not common, and I don't see an absolute need to calculate the
strict set of packages affected, and call mro_changed_in() for just them.

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

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​::.

@p5pRT
Copy link
Collaborator Author

@p5pRT p5pRT commented Aug 23, 2010

From @cpansprout

Inline Patch
diff -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';
+}
+
+
+
@p5pRT
Copy link
Collaborator Author

@p5pRT p5pRT commented Aug 23, 2010

From @cpansprout

Inline Patch
diff -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';
+}
@p5pRT
Copy link
Collaborator Author

@p5pRT p5pRT commented Aug 23, 2010

From @cpansprout

Oops. I forgot the main part of the message and just sent the postscript. Here it is​:

Begin forwarded message​:

From​: Father Chrysostomos
Date​: August 22, 2010 5​:39​:15 PM PDT
Cc​: Nicholas Clark, p5p
Subject​: Re​: [perl #75176] Symbol​::delete_package does not free certain memory associated with package​::ISA

On Aug 8, 2010, at 12​:22 PM, Father Chrysostomos wrote​:

If PL_sub_generation does not invalidate isa caches, would it be appropriate to add a new PL_isa_generation variable?

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 ($stash = delete $​::{"it​::"}), they need to know whether they are still attached, so detached stashes don’t muddle up isarev and delete entries that are still needed (which would be worse than leaking).

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.

It's not common, and I don't see an absolute need to calculate the
strict set of packages affected, and call mro_changed_in() for just them.

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

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​::.

@p5pRT
Copy link
Collaborator Author

@p5pRT p5pRT commented Aug 23, 2010

From @cpansprout

Inline Patch
diff -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';
+}
+
+
+
@p5pRT
Copy link
Collaborator Author

@p5pRT p5pRT commented Aug 23, 2010

From @cpansprout

Inline Patch
diff -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';
+}
@p5pRT
Copy link
Collaborator Author

@p5pRT p5pRT commented Aug 23, 2010

@p5pRT
Copy link
Collaborator Author

@p5pRT p5pRT commented Aug 23, 2010

From @cpansprout

On Aug 22, 2010, at 5​:46 PM, Father Chrysostomos wrote​:

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.

And I forgot to add the new test to MANIFEST. Here’s a patch for that.

@p5pRT
Copy link
Collaborator Author

@p5pRT p5pRT commented Aug 23, 2010

From @cpansprout

Inline Patch
diff -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
@p5pRT
Copy link
Collaborator Author

@p5pRT p5pRT commented Aug 23, 2010

From @iabyn

On Sun, Aug 22, 2010 at 12​:11​:27PM -0700, Father Chrysostomos wrote​:

On Aug 18, 2010, at 9​:47 AM, Dave Mitchell wrote​:

On Sun, Aug 08, 2010 at 12​:22​:13PM -0700, Father Chrysostomos 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.)

Note that hv_clear and hv_undef may remove the aux struct, so you may not
be able to rely on it always remaining.

What happens to the name currently stored in there when that happens?

See S_hfreeentries​: it special-cases adding name back at the end.

--
Wesley Crusher gets beaten up by his classmates for being a smarmy git,
and consequently has a go at making some friends of his own age for a
change.
  -- Things That Never Happen in "Star Trek" #18

@p5pRT
Copy link
Collaborator Author

@p5pRT p5pRT commented Aug 23, 2010

From @iabyn

On Mon, Aug 23, 2010 at 12​:50​:20PM +0100, Dave Mitchell wrote​:

See S_hfreeentries​: it special-cases adding name back at the end.

In fact I'm tempted to modify this code so that the aux structure
is always maintained (ecvne for hv_undef) when there's something that
nedds to be kept in it, so that back-references no longer have to be
shuffled betwween hv_aux and magic.

--
In economics, the exam questions are the same every year.
They just change the answers.

@p5pRT
Copy link
Collaborator Author

@p5pRT p5pRT commented Aug 29, 2010

From @cpansprout

On Aug 22, 2010, at 5​:46 PM, Father Chrysostomos wrote​:

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 ($stash = delete $​::{"it​::"}), they need to know whether they are still attached, so detached stashes don’t muddle up isarev and delete entries that are still needed (which would be worse than leaking).

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.

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.
2. Do it for XS access as well, by modifying hv_fetch_ent instead (or hv_common, or wherever the actual code is).

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).
Number 2 is probably more reliable. perl’s internals can pass a flag to avoid the PVLVs. XS code that assumes that stash elements are never magical will be broken (code that specifically calls the _nomg forms to avoid the magic checks). Most XS code will continue to work.

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.

@p5pRT
Copy link
Collaborator Author

@p5pRT p5pRT commented Aug 29, 2010

From @cpansprout

From​: 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
reset isa caches by calling mro_package_moved, if the glob’s name
ends with :​:.

Inline Patch
diff -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");
@p5pRT
Copy link
Collaborator Author

@p5pRT p5pRT commented Aug 29, 2010

From @demerphq

On 29 August 2010 23​:09, Father Chrysostomos <sprout@​cpan.org> wrote​:

On Aug 22, 2010, at 5​:46 PM, Father Chrysostomos wrote​:

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 ($stash = delete
$​::{"it​::"}), they need to know whether they are still attached, so detached
stashes don’t muddle up isarev and delete entries that are still needed
(which would be worse than leaking).

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.

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.
2. Do it for XS access as well, by modifying hv_fetch_ent instead (or
hv_common, or wherever the actual code is).
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).
Number 2 is probably more reliable. perl’s internals can pass a flag to
avoid the PVLVs. XS code that assumes that stash elements are never magical
will be broken (code that specifically calls the _nomg forms to avoid the
magic checks). Most XS code will continue to work.
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.

+ 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);
+ }

Did you miss a { } there? From the indenting it looks like the if ()
applies to both of the following ifs, but it is an if (EXPR) STMT; not
an IF (EXPR) BLOCK

yves

--
perl -Mre=debug -e "/just|another|perl|hacker/"

@p5pRT
Copy link
Collaborator Author

@p5pRT p5pRT commented Aug 30, 2010

From @cpansprout

On Aug 29, 2010, at 3​:20 PM, demerphq wrote​:

On 29 August 2010 23​:09, Father Chrysostomos <sprout@​cpan.org> wrote​:
+ 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);
+ }

Did you miss a { } there? From the indenting it looks like the if ()
applies to both of the following ifs, but it is an if (EXPR) STMT; not
an IF (EXPR) BLOCK

Thank you for catching that. Here is a fixed version.

@p5pRT
Copy link
Collaborator Author

@p5pRT p5pRT commented Aug 30, 2010

From @cpansprout

From​: 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
reset isa caches by calling mro_package_moved, if the glob’s name
ends with :​:.

Inline Patch
diff -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");
@p5pRT
Copy link
Collaborator Author

@p5pRT p5pRT commented Sep 5, 2010

From @cpansprout

On Aug 22, 2010, at 5​:46 PM, Father Chrysostomos wrote​:

Oops. I forgot the main part of the message and just sent the postscript. Here it is​:

Begin forwarded message​:

From​: Father Chrysostomos
Date​: August 22, 2010 5​:39​:15 PM PDT
Cc​: Nicholas Clark, p5p
Subject​: Re​: [perl #75176] Symbol​::delete_package does not free certain memory associated with package​::ISA

On Aug 8, 2010, at 12​:22 PM, Father Chrysostomos wrote​:

If PL_sub_generation does not invalidate isa caches, would it be appropriate to add a new PL_isa_generation variable?

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.

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

@p5pRT
Copy link
Collaborator Author

@p5pRT p5pRT commented Sep 5, 2010

From @cpansprout

From​: Father Chrysostomos <sprout@​cpan.org>

[perl #75176] Reset isa on stash manipulation

This only applies to glob-to-glob assignments and deletions of stash
elements. Other types of stash manipulation are dealt with by subse-
quent patches.

It adds mro_package_moved, a private function that iterates through
subpackages, calling mro_isa_changed_in on each.

Inline Patch
diff -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';
+}
@p5pRT
Copy link
Collaborator Author

@p5pRT p5pRT commented Sep 5, 2010

From @cpansprout

From​: 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
reset isa caches by calling mro_package_moved, if the glob’s name
ends with :​:.

Inline Patch
diff -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
@p5pRT
Copy link
Collaborator Author

@p5pRT p5pRT commented Sep 5, 2010

From @cpansprout

On Aug 29, 2010, at 2​:09 PM, Father Chrysostomos wrote​:

On Aug 22, 2010, at 5​:46 PM, Father Chrysostomos wrote​:

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 ($stash = delete $​::{"it​::"}), they need to know whether they are still attached, so detached stashes don’t muddle up isarev and delete entries that are still needed (which would be worse than leaking).

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.

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.
2. Do it for XS access as well, by modifying hv_fetch_ent instead (or hv_common, or wherever the actual code is).

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).
Number 2 is probably more reliable. perl’s internals can pass a flag to avoid the PVLVs. XS code that assumes that stash elements are never magical will be broken (code that specifically calls the _nomg forms to avoid the magic checks). Most XS code will continue to work.

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.

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

@p5pRT
Copy link
Collaborator Author

@p5pRT p5pRT commented Sep 5, 2010

From @cpansprout

From​: Father Chrysostomos <sprout@​cpan.org>

[perl #75176] Make assignment to undef stash elems reset caches

This makes assignment to undefined or nonexistent stash elements
invalidate isa and method caches on the packages affected.

It does this by creating PVLVs with defelem magic in pp_helem if the
current value of the stash element is not a real (!SvFAKE) glob.
This, of course, only applies to keys ending with :​:.

Because it is necessary to invalidate isa caches on the subclasses of
a nonexistent package when its corresponding stash element is assigned
to, mro_isa_changed_in is replaced with mro_isa_changed_in3. See the
docs for it in the diff for mro.c and its use in mg.c.

Inline Patch
diff -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";
+}
+
@p5pRT
Copy link
Collaborator Author

@p5pRT p5pRT commented Oct 10, 2010

From @cpansprout

On Sun Sep 05 13​:15​:28 2010, sprout wrote​:

On Aug 22, 2010, at 5​:46 PM, Father Chrysostomos wrote​:

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.

That patch can cause a bus error, so here is a new version.

Applied as c8bbf67.

@p5pRT
Copy link
Collaborator Author

@p5pRT p5pRT commented Oct 10, 2010

From [Unknown Contact. See original ticket]

On Sun Sep 05 13​:15​:28 2010, sprout wrote​:

On Aug 22, 2010, at 5​:46 PM, Father Chrysostomos wrote​:

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.

That patch can cause a bus error, so here is a new version.

Applied as c8bbf67.

@p5pRT
Copy link
Collaborator Author

@p5pRT p5pRT commented Oct 10, 2010

From @cpansprout

On Sun Aug 22 20​:21​:25 2010, sprout wrote​:

On Aug 22, 2010, at 5​:46 PM, Father Chrysostomos wrote​:

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.

And I forgot to add the new test to MANIFEST. Here’s a patch for that.

I’m now putting the tests in package_alias.t or whatever it’s called, so
that patch is no longer applicable.

@p5pRT
Copy link
Collaborator Author

@p5pRT p5pRT commented Oct 10, 2010

From [Unknown Contact. See original ticket]

On Sun Aug 22 20​:21​:25 2010, sprout wrote​:

On Aug 22, 2010, at 5​:46 PM, Father Chrysostomos wrote​:

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.

And I forgot to add the new test to MANIFEST. Here’s a patch for that.

I’m now putting the tests in package_alias.t or whatever it’s called, so
that patch is no longer applicable.

@p5pRT
Copy link
Collaborator Author

@p5pRT p5pRT commented Oct 10, 2010

From @cpansprout

On Sun Sep 05 13​:15​:28 2010, sprout 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).

3b has been applied as 1c93aaac75354eeef.

@p5pRT
Copy link
Collaborator Author

@p5pRT p5pRT commented Oct 10, 2010

From [Unknown Contact. See original ticket]

On Sun Sep 05 13​:15​:28 2010, sprout 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).

3b has been applied as 1c93aaac75354eeef.

@p5pRT
Copy link
Collaborator Author

@p5pRT p5pRT commented Oct 10, 2010

From @cpansprout

On Sat Oct 09 23​:06​:49 2010, sprout wrote​:

On Sun Sep 05 13​:15​:28 2010, sprout 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).

3b has been applied as 1c93aaac75354eeef.

Er, actually 3e79609.

@p5pRT
Copy link
Collaborator Author

@p5pRT p5pRT commented Oct 10, 2010

From [Unknown Contact. See original ticket]

On Sat Oct 09 23​:06​:49 2010, sprout wrote​:

On Sun Sep 05 13​:15​:28 2010, sprout 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).

3b has been applied as 1c93aaac75354eeef.

Er, actually 3e79609.

@p5pRT
Copy link
Collaborator Author

@p5pRT p5pRT commented Oct 10, 2010

From @cpansprout

On Sun Sep 05 13​:18​:02 2010, sprout wrote​:

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.
2. Do it for XS access as well, by modifying hv_fetch_ent instead
(or hv_common, or wherever the actual code is).

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).
Number 2 is probably more reliable. perl’s internals can pass a flag
to avoid the PVLVs. XS code that assumes that stash elements are
never magical will be broken (code that specifically calls the
_nomg forms to avoid the magic checks). Most XS code will continue
to work.

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.

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.

That fourth patch is no good. Not only does it have mistakes, but the
whole concept is flawed. Here are some of the problems​:

• It only works with top-level packages
• References to stash elements that are not globs no longer reference
the SVs themselves, but the named stash elements.
• Actually, those references would probably stringify with LVALUE, not
GLOB/SCALAR.
• Two references to the same element would not compare equal.
• References to stash elements containing glob copies--well, let​::s not
get into that.

And I now think that assignments to empty stash elements should not be
done by user code anyway. See #78074.

@p5pRT
Copy link
Collaborator Author

@p5pRT p5pRT commented Oct 10, 2010

From [Unknown Contact. See original ticket]

On Sun Sep 05 13​:18​:02 2010, sprout wrote​:

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.
2. Do it for XS access as well, by modifying hv_fetch_ent instead
(or hv_common, or wherever the actual code is).

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).
Number 2 is probably more reliable. perl’s internals can pass a flag
to avoid the PVLVs. XS code that assumes that stash elements are
never magical will be broken (code that specifically calls the
_nomg forms to avoid the magic checks). Most XS code will continue
to work.

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.

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.

That fourth patch is no good. Not only does it have mistakes, but the
whole concept is flawed. Here are some of the problems​:

• It only works with top-level packages
• References to stash elements that are not globs no longer reference
the SVs themselves, but the named stash elements.
• Actually, those references would probably stringify with LVALUE, not
GLOB/SCALAR.
• Two references to the same element would not compare equal.
• References to stash elements containing glob copies--well, let​::s not
get into that.

And I now think that assignments to empty stash elements should not be
done by user code anyway. See #78074.

@p5pRT
Copy link
Collaborator Author

@p5pRT p5pRT commented Nov 9, 2010

From @cpansprout

Now fixed by 80ebaca and a couple dozen patches leading up to it.

@p5pRT
Copy link
Collaborator Author

@p5pRT p5pRT commented Nov 9, 2010

@cpansprout - Status changed from 'open' to 'resolved'

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
Projects
None yet
Linked pull requests

Successfully merging a pull request may close this issue.

None yet
1 participant
You can’t perform that action at this time.