fix totally broken caching in UNIVERSAL::isa() (from

Nick Ing-Simmons)

p4raw-id: //depot/perl@5912

2 files changed, 76 insertions, 20 deletions

diff --git a/t/op/universal.t b/t/op/universal.t
index a6bd03dbe9..a0a74ec4b2 100755
--- a/t/op/universal.t
+++ b/t/op/universal.t
@@ -6,9 +6,10 @@
 BEGIN {
     chdir 't' if -d 't';
     unshift @INC, '../lib' if -d '../lib';
+    $| = 1;
 }
 
-print "1..73\n";
+print "1..80\n";
 
 $a = {};
 bless $a, "Bob";
@@ -28,6 +29,19 @@ sub new { bless {} }
 
 $Alice::VERSION = 2.718;
 
+{
+    package Cedric;
+    our @ISA;
+    use base qw(Human);
+}
+
+{
+    package Programmer;
+    our $VERSION = 1.667;
+
+    sub write_perl { 1 }
+}
+
 package main;
 
 my $i = 2;
@@ -45,12 +59,34 @@ test $a->isa("Human");
 
 test ! $a->isa("Male");
 
+test ! $a->isa('Programmer');
+
 test $a->can("drink");
 
 test $a->can("eat");
 
 test ! $a->can("sleep");
 
+test (!Cedric->isa('Programmer'));
+
+test (Cedric->isa('Human'));
+
+push(@Cedric::ISA,'Programmer');
+
+test (Cedric->isa('Programmer'));
+
+{
+    package Alice;
+    base::->import('Programmer');
+}
+
+test $a->isa('Programmer');
+test $a->isa("Female");
+
+@Cedric::ISA = qw(Bob);
+
+test (!Cedric->isa('Programmer'));
+
 my $b = 'abc';
 my @refs = qw(SCALAR SCALAR     LVALUE      GLOB ARRAY HASH CODE);
 my @vals = (  \$b,   \3.14, \substr($b,1,1), \*b,  [],  {}, sub {} );
@@ -88,7 +124,7 @@ eval "use UNIVERSAL";
 
 test $a->isa("UNIVERSAL");
 
-my $sub2 = join ' ', sort grep { defined &{"UNIVERSAL::$_"} } keys %UNIVERSAL::; 
+my $sub2 = join ' ', sort grep { defined &{"UNIVERSAL::$_"} } keys %UNIVERSAL::;
 # XXX import being here is really a bug
 if ('a' lt 'A') {
     test $sub2 eq "can import isa VERSION";
diff --git a/universal.c b/universal.c
index fc0ec41fb7..9adc42de84 100644
--- a/universal.c
+++ b/universal.c
@@ -14,29 +14,44 @@ S_isa_lookup(pTHX_ HV *stash, const char *name, int len, int level)
     GV* gv;
     GV** gvp;
     HV* hv = Nullhv;
+    SV* subgen = Nullsv;
 
     if (!stash)
 	return &PL_sv_undef;
 
-    if(strEQ(HvNAME(stash), name))
+    if (strEQ(HvNAME(stash), name))
 	return &PL_sv_yes;
 
     if (level > 100)
-	Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'", HvNAME(stash));
+	Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
+		   HvNAME(stash));
 
     gvp = (GV**)hv_fetch(stash, "::ISA::CACHE::", 14, FALSE);
 
-    if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (hv = GvHV(gv))) {
-	SV* sv;
-	SV** svp = (SV**)hv_fetch(hv, name, len, FALSE);
-	if (svp && (sv = *svp) != (SV*)&PL_sv_undef)
-	    return sv;
+    if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (subgen = GvSV(gv))
+	&& (hv = GvHV(gv)))
+    {
+	if (SvIV(subgen) == PL_sub_generation) {
+	    SV* sv;
+	    SV** svp = (SV**)hv_fetch(hv, name, len, FALSE);
+	    if (svp && (sv = *svp) != (SV*)&PL_sv_undef) {
+	        DEBUG_o( Perl_deb(aTHX_ "Using cached ISA %s for package %s\n",
+				  name, HvNAME(stash)) );
+		return sv;
+	    }
+	}
+	else {
+	    DEBUG_o( Perl_deb(aTHX_ "ISA Cache in package %s is stale\n",
+			      HvNAME(stash)) );
+	    hv_clear(hv);
+	    sv_setiv(subgen, PL_sub_generation);
+	}
     }
 
     gvp = (GV**)hv_fetch(stash,"ISA",3,FALSE);
-    
+
     if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (av = GvAV(gv))) {
-	if(!hv) {
+	if (!hv || !subgen) {
 	    gvp = (GV**)hv_fetch(stash, "::ISA::CACHE::", 14, TRUE);
 
 	    gv = *gvp;
@@ -44,9 +59,14 @@ S_isa_lookup(pTHX_ HV *stash, const char *name, int len, int level)
 	    if (SvTYPE(gv) != SVt_PVGV)
 		gv_init(gv, stash, "::ISA::CACHE::", 14, TRUE);
 
-	    hv = GvHVn(gv);
+	    if (!hv)
+		hv = GvHVn(gv);
+	    if (!subgen) {
+		subgen = newSViv(PL_sub_generation);
+		GvSV(gv) = subgen;
+	    }
 	}
-	if(hv) {
+	if (hv) {
 	    SV** svp = AvARRAY(av);
 	    /* NOTE: No support for tied ISA */
 	    I32 items = AvFILLp(av) + 1;
@@ -61,7 +81,7 @@ S_isa_lookup(pTHX_ HV *stash, const char *name, int len, int level)
 			    SvPVX(sv), HvNAME(stash));
 		    continue;
 		}
-		if(&PL_sv_yes == isa_lookup(basestash, name, len, level + 1)) {
+		if (&PL_sv_yes == isa_lookup(basestash, name, len, level + 1)) {
 		    (void)hv_store(hv,name,len,&PL_sv_yes,0);
 		    return &PL_sv_yes;
 		}
@@ -88,23 +108,23 @@ Perl_sv_derived_from(pTHX_ SV *sv, const char *name)
 {
     char *type;
     HV *stash;
-  
+
     stash = Nullhv;
     type = Nullch;
- 
+
     if (SvGMAGICAL(sv))
         mg_get(sv) ;
 
     if (SvROK(sv)) {
         sv = SvRV(sv);
         type = sv_reftype(sv,0);
-        if(SvOBJECT(sv))
+        if (SvOBJECT(sv))
             stash = SvSTASH(sv);
     }
     else {
         stash = gv_stashsv(sv, FALSE);
     }
- 
+
     return (type && strEQ(type,name)) ||
             (stash && isa_lookup(stash, name, strlen(name), 0) == &PL_sv_yes)
         ? TRUE
@@ -174,9 +194,9 @@ XS(XS_UNIVERSAL_can)
     name = (char *)SvPV(ST(1),n_a);
     rv = &PL_sv_undef;
 
-    if(SvROK(sv)) {
+    if (SvROK(sv)) {
         sv = (SV*)SvRV(sv);
-        if(SvOBJECT(sv))
+        if (SvOBJECT(sv))
             pkg = SvSTASH(sv);
     }
     else {