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