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