1 /* Extracted from perl-5.004/universal.c, contributed by Graham Barr */ 2 3 static SV * 4 isa_lookup(stash, name, len, level) 5 HV *stash; 6 char *name; 7 int len; 8 int level; 9 { 10 AV* av; 11 GV* gv; 12 GV** gvp; 13 HV* hv = Nullhv; 14 15 if (!stash) 16 return &sv_undef; 17 18 if(strEQ(HvNAME(stash), name)) 19 return &sv_yes; 20 21 if (level > 100) 22 croak("Recursive inheritance detected"); 23 24 gvp = (GV**)hv_fetch(stash, "::ISA::CACHE::", 14, FALSE); 25 26 if (gvp && (gv = *gvp) != (GV*)&sv_undef && (hv = GvHV(gv))) { 27 SV* sv; 28 SV** svp = (SV**)hv_fetch(hv, name, len, FALSE); 29 if (svp && (sv = *svp) != (SV*)&sv_undef) 30 return sv; 31 } 32 33 gvp = (GV**)hv_fetch(stash,"ISA",3,FALSE); 34 35 if (gvp && (gv = *gvp) != (GV*)&sv_undef && (av = GvAV(gv))) { 36 if(!hv) { 37 gvp = (GV**)hv_fetch(stash, "::ISA::CACHE::", 14, TRUE); 38 39 gv = *gvp; 40 41 if (SvTYPE(gv) != SVt_PVGV) 42 gv_init(gv, stash, "::ISA::CACHE::", 14, TRUE); 43 44 hv = GvHVn(gv); 45 } 46 if(hv) { 47 SV** svp = AvARRAY(av); 48 I32 items = AvFILL(av) + 1; 49 while (items--) { 50 SV* sv = *svp++; 51 HV* basestash = gv_stashsv(sv, FALSE); 52 if (!basestash) { 53 if (dowarn) 54 warn("Can't locate package %s for @%s::ISA", 55 SvPVX(sv), HvNAME(stash)); 56 continue; 57 } 58 if(&sv_yes == isa_lookup(basestash, name, len, level + 1)) { 59 (void)hv_store(hv,name,len,&sv_yes,0); 60 return &sv_yes; 61 } 62 } 63 (void)hv_store(hv,name,len,&sv_no,0); 64 } 65 } 66 67 return &sv_no; 68 } 69 70 static bool 71 sv_derived_from(sv, name) 72 SV * sv ; 73 char * name ; 74 { 75 SV *rv; 76 char *type; 77 HV *stash; 78 79 stash = Nullhv; 80 type = Nullch; 81 82 if (SvGMAGICAL(sv)) 83 mg_get(sv) ; 84 85 if (SvROK(sv)) { 86 sv = SvRV(sv); 87 type = sv_reftype(sv,0); 88 if(SvOBJECT(sv)) 89 stash = SvSTASH(sv); 90 } 91 else { 92 stash = gv_stashsv(sv, FALSE); 93 } 94 95 return (type && strEQ(type,name)) || 96 (stash && isa_lookup(stash, name, strlen(name), 0) == &sv_yes) 97 ? TRUE 98 : FALSE ; 99 100 } 101