This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
fix totally broken caching in UNIVERSAL::isa() (from
[perl5.git] / universal.c
index fc0ec41..9adc42d 100644 (file)
@@ -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 {