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

Nick Ing-Simmons)

p4raw-id: //depot/perl@5912

diff --git a/t/op/universal.t b/t/op/universal.t
index a6bd03d..a0a74ec 100755 (executable)
--- 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 fc0ec41..9adc42d 100644 (file)
--- 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 {