1 #include "EXTERN.h" 2 #include "perl.h" 3 #include "XSUB.h" 4 5 /* 6 * Contributed by Graham Barr <Graham.Barr@tiuk.ti.com> 7 * The main guts of traverse_isa was actually copied from gv_fetchmeth 8 */ 9 10 static SV * 11 isa_lookup(stash, name, len, level) 12 HV *stash; 13 char *name; 14 int len; 15 int level; 16 { 17 AV* av; 18 GV* gv; 19 GV** gvp; 20 HV* hv = Nullhv; 21 22 if (!stash) 23 return &sv_undef; 24 25 if(strEQ(HvNAME(stash), name)) 26 return &sv_yes; 27 28 if (level > 100) 29 croak("Recursive inheritance detected"); 30 31 gvp = (GV**)hv_fetch(stash, "::ISA::CACHE::", 14, FALSE); 32 33 if (gvp && (gv = *gvp) != (GV*)&sv_undef && (hv = GvHV(gv))) { 34 SV* sv; 35 SV** svp = (SV**)hv_fetch(hv, name, len, FALSE); 36 if (svp && (sv = *svp) != (SV*)&sv_undef) 37 return sv; 38 } 39 40 gvp = (GV**)hv_fetch(stash,"ISA",3,FALSE); 41 42 if (gvp && (gv = *gvp) != (GV*)&sv_undef && (av = GvAV(gv))) { 43 if(!hv) { 44 gvp = (GV**)hv_fetch(stash, "::ISA::CACHE::", 14, TRUE); 45 46 gv = *gvp; 47 48 if (SvTYPE(gv) != SVt_PVGV) 49 gv_init(gv, stash, "::ISA::CACHE::", 14, TRUE); 50 51 hv = GvHVn(gv); 52 } 53 if(hv) { 54 SV** svp = AvARRAY(av); 55 I32 items = AvFILL(av) + 1; 56 while (items--) { 57 SV* sv = *svp++; 58 HV* basestash = gv_stashsv(sv, FALSE); 59 if (!basestash) { 60 if (dowarn) 61 warn("Can't locate package %s for @%s::ISA", 62 SvPVX(sv), HvNAME(stash)); 63 continue; 64 } 65 if(&sv_yes == isa_lookup(basestash, name, len, level + 1)) { 66 (void)hv_store(hv,name,len,&sv_yes,0); 67 return &sv_yes; 68 } 69 } 70 (void)hv_store(hv,name,len,&sv_no,0); 71 } 72 } 73 74 return boolSV(strEQ(name, "UNIVERSAL")); 75 } 76 77 bool 78 sv_derived_from(sv, name) 79 SV * sv ; 80 char * name ; 81 { 82 SV *rv; 83 char *type; 84 HV *stash; 85 86 stash = Nullhv; 87 type = Nullch; 88 89 if (SvGMAGICAL(sv)) 90 mg_get(sv) ; 91 92 if (SvROK(sv)) { 93 sv = SvRV(sv); 94 type = sv_reftype(sv,0); 95 if(SvOBJECT(sv)) 96 stash = SvSTASH(sv); 97 } 98 else { 99 stash = gv_stashsv(sv, FALSE); 100 } 101 102 return (type && strEQ(type,name)) || 103 (stash && isa_lookup(stash, name, strlen(name), 0) == &sv_yes) 104 ? TRUE 105 : FALSE ; 106 107 } 108 109 110 static 111 XS(XS_UNIVERSAL_isa) 112 { 113 dXSARGS; 114 SV *sv; 115 char *name; 116 117 if (items != 2) 118 croak("Usage: UNIVERSAL::isa(reference, kind)"); 119 120 sv = ST(0); 121 name = (char *)SvPV(ST(1),na); 122 123 ST(0) = boolSV(sv_derived_from(sv, name)); 124 XSRETURN(1); 125 } 126 127 static 128 XS(XS_UNIVERSAL_can) 129 { 130 dXSARGS; 131 SV *sv; 132 char *name; 133 SV *rv; 134 HV *pkg = NULL; 135 136 if (items != 2) 137 croak("Usage: UNIVERSAL::can(object-ref, method)"); 138 139 sv = ST(0); 140 name = (char *)SvPV(ST(1),na); 141 rv = &sv_undef; 142 143 if(SvROK(sv)) { 144 sv = (SV*)SvRV(sv); 145 if(SvOBJECT(sv)) 146 pkg = SvSTASH(sv); 147 } 148 else { 149 pkg = gv_stashsv(sv, FALSE); 150 } 151 152 if (pkg) { 153 GV *gv = gv_fetchmethod_autoload(pkg, name, FALSE); 154 if (gv && isGV(gv)) 155 rv = sv_2mortal(newRV((SV*)GvCV(gv))); 156 } 157 158 ST(0) = rv; 159 XSRETURN(1); 160 } 161 162 static 163 XS(XS_UNIVERSAL_VERSION) 164 { 165 dXSARGS; 166 HV *pkg; 167 GV **gvp; 168 GV *gv; 169 SV *sv; 170 char *undef; 171 double req; 172 173 if(SvROK(ST(0))) { 174 sv = (SV*)SvRV(ST(0)); 175 if(!SvOBJECT(sv)) 176 croak("Cannot find version of an unblessed reference"); 177 pkg = SvSTASH(sv); 178 } 179 else { 180 pkg = gv_stashsv(ST(0), FALSE); 181 } 182 183 gvp = pkg ? (GV**)hv_fetch(pkg,"VERSION",7,FALSE) : Null(GV**); 184 185 if (gvp && (gv = *gvp) != (GV*)&sv_undef && (sv = GvSV(gv))) { 186 SV *nsv = sv_newmortal(); 187 sv_setsv(nsv, sv); 188 sv = nsv; 189 undef = Nullch; 190 } 191 else { 192 sv = (SV*)&sv_undef; 193 undef = "(undef)"; 194 } 195 196 if (items > 1 && (undef || (req = SvNV(ST(1)), req > SvNV(sv)))) 197 croak("%s version %s required--this is only version %s", 198 HvNAME(pkg), SvPV(ST(1),na), undef ? undef : SvPV(sv,na)); 199 200 ST(0) = sv; 201 202 XSRETURN(1); 203 } 204 205 void 206 boot_core_UNIVERSAL() 207 { 208 char *file = __FILE__; 209 210 newXS("UNIVERSAL::isa", XS_UNIVERSAL_isa, file); 211 newXS("UNIVERSAL::can", XS_UNIVERSAL_can, file); 212 newXS("UNIVERSAL::VERSION", XS_UNIVERSAL_VERSION, file); 213 } 214