1 /* Extracted from perl-5.004/universal.c, contributed by Graham Barr */
2
3 static SV *
isa_lookup(stash,name,len,level)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
sv_derived_from(sv,name)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