1 #include "EXTERN.h" 2 #define PERL_IN_UNIVERSAL_C 3 #include "perl.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 S_isa_lookup(pTHX_ HV *stash, const char *name, int len, int level) 12 { 13 AV* av; 14 GV* gv; 15 GV** gvp; 16 HV* hv = Nullhv; 17 18 if (!stash) 19 return &PL_sv_undef; 20 21 if(strEQ(HvNAME(stash), name)) 22 return &PL_sv_yes; 23 24 if (level > 100) 25 Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'", HvNAME(stash)); 26 27 gvp = (GV**)hv_fetch(stash, "::ISA::CACHE::", 14, FALSE); 28 29 if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (hv = GvHV(gv))) { 30 SV* sv; 31 SV** svp = (SV**)hv_fetch(hv, name, len, FALSE); 32 if (svp && (sv = *svp) != (SV*)&PL_sv_undef) 33 return sv; 34 } 35 36 gvp = (GV**)hv_fetch(stash,"ISA",3,FALSE); 37 38 if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (av = GvAV(gv))) { 39 if(!hv) { 40 gvp = (GV**)hv_fetch(stash, "::ISA::CACHE::", 14, TRUE); 41 42 gv = *gvp; 43 44 if (SvTYPE(gv) != SVt_PVGV) 45 gv_init(gv, stash, "::ISA::CACHE::", 14, TRUE); 46 47 hv = GvHVn(gv); 48 } 49 if(hv) { 50 SV** svp = AvARRAY(av); 51 /* NOTE: No support for tied ISA */ 52 I32 items = AvFILLp(av) + 1; 53 while (items--) { 54 SV* sv = *svp++; 55 HV* basestash = gv_stashsv(sv, FALSE); 56 if (!basestash) { 57 dTHR; 58 if (ckWARN(WARN_MISC)) 59 Perl_warner(aTHX_ WARN_SYNTAX, 60 "Can't locate package %s for @%s::ISA", 61 SvPVX(sv), HvNAME(stash)); 62 continue; 63 } 64 if(&PL_sv_yes == isa_lookup(basestash, name, len, level + 1)) { 65 (void)hv_store(hv,name,len,&PL_sv_yes,0); 66 return &PL_sv_yes; 67 } 68 } 69 (void)hv_store(hv,name,len,&PL_sv_no,0); 70 } 71 } 72 73 return boolSV(strEQ(name, "UNIVERSAL")); 74 } 75 76 /* 77 =for apidoc sv_derived_from 78 79 Returns a boolean indicating whether the SV is derived from the specified 80 class. This is the function that implements C<UNIVERSAL::isa>. It works 81 for class names as well as for objects. 82 83 =cut 84 */ 85 86 bool 87 Perl_sv_derived_from(pTHX_ SV *sv, const char *name) 88 { 89 char *type; 90 HV *stash; 91 92 stash = Nullhv; 93 type = Nullch; 94 95 if (SvGMAGICAL(sv)) 96 mg_get(sv) ; 97 98 if (SvROK(sv)) { 99 sv = SvRV(sv); 100 type = sv_reftype(sv,0); 101 if(SvOBJECT(sv)) 102 stash = SvSTASH(sv); 103 } 104 else { 105 stash = gv_stashsv(sv, FALSE); 106 } 107 108 return (type && strEQ(type,name)) || 109 (stash && isa_lookup(stash, name, strlen(name), 0) == &PL_sv_yes) 110 ? TRUE 111 : FALSE ; 112 } 113 114 void XS_UNIVERSAL_isa(pTHXo_ CV *cv); 115 void XS_UNIVERSAL_can(pTHXo_ CV *cv); 116 void XS_UNIVERSAL_VERSION(pTHXo_ CV *cv); 117 118 void 119 Perl_boot_core_UNIVERSAL(pTHX) 120 { 121 char *file = __FILE__; 122 123 newXS("UNIVERSAL::isa", XS_UNIVERSAL_isa, file); 124 newXS("UNIVERSAL::can", XS_UNIVERSAL_can, file); 125 newXS("UNIVERSAL::VERSION", XS_UNIVERSAL_VERSION, file); 126 } 127 128 #include "XSUB.h" 129 130 XS(XS_UNIVERSAL_isa) 131 { 132 dXSARGS; 133 SV *sv; 134 char *name; 135 STRLEN n_a; 136 137 if (items != 2) 138 Perl_croak(aTHX_ "Usage: UNIVERSAL::isa(reference, kind)"); 139 140 sv = ST(0); 141 142 if (SvGMAGICAL(sv)) 143 mg_get(sv); 144 145 if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv)))) 146 XSRETURN_UNDEF; 147 148 name = (char *)SvPV(ST(1),n_a); 149 150 ST(0) = boolSV(sv_derived_from(sv, name)); 151 XSRETURN(1); 152 } 153 154 XS(XS_UNIVERSAL_can) 155 { 156 dXSARGS; 157 SV *sv; 158 char *name; 159 SV *rv; 160 HV *pkg = NULL; 161 STRLEN n_a; 162 163 if (items != 2) 164 Perl_croak(aTHX_ "Usage: UNIVERSAL::can(object-ref, method)"); 165 166 sv = ST(0); 167 168 if (SvGMAGICAL(sv)) 169 mg_get(sv); 170 171 if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv)))) 172 XSRETURN_UNDEF; 173 174 name = (char *)SvPV(ST(1),n_a); 175 rv = &PL_sv_undef; 176 177 if(SvROK(sv)) { 178 sv = (SV*)SvRV(sv); 179 if(SvOBJECT(sv)) 180 pkg = SvSTASH(sv); 181 } 182 else { 183 pkg = gv_stashsv(sv, FALSE); 184 } 185 186 if (pkg) { 187 GV *gv = gv_fetchmethod_autoload(pkg, name, FALSE); 188 if (gv && isGV(gv)) 189 rv = sv_2mortal(newRV((SV*)GvCV(gv))); 190 } 191 192 ST(0) = rv; 193 XSRETURN(1); 194 } 195 196 XS(XS_UNIVERSAL_VERSION) 197 { 198 dXSARGS; 199 HV *pkg; 200 GV **gvp; 201 GV *gv; 202 SV *sv; 203 char *undef; 204 205 if (SvROK(ST(0))) { 206 sv = (SV*)SvRV(ST(0)); 207 if (!SvOBJECT(sv)) 208 Perl_croak(aTHX_ "Cannot find version of an unblessed reference"); 209 pkg = SvSTASH(sv); 210 } 211 else { 212 pkg = gv_stashsv(ST(0), FALSE); 213 } 214 215 gvp = pkg ? (GV**)hv_fetch(pkg,"VERSION",7,FALSE) : Null(GV**); 216 217 if (gvp && isGV(gv = *gvp) && SvOK(sv = GvSV(gv))) { 218 SV *nsv = sv_newmortal(); 219 sv_setsv(nsv, sv); 220 sv = nsv; 221 undef = Nullch; 222 } 223 else { 224 sv = (SV*)&PL_sv_undef; 225 undef = "(undef)"; 226 } 227 228 if (items > 1) { 229 STRLEN len; 230 SV *req = ST(1); 231 232 if (undef) 233 Perl_croak(aTHX_ "%s does not define $%s::VERSION--version check failed", 234 HvNAME(pkg), HvNAME(pkg)); 235 236 if (!SvNIOK(sv) && SvPOK(sv)) { 237 char *str = SvPVx(sv,len); 238 while (len) { 239 --len; 240 /* XXX could DWIM "1.2.3" here */ 241 if (!isDIGIT(str[len]) && str[len] != '.' && str[len] != '_') 242 break; 243 } 244 if (len) { 245 if (SvNIOKp(req) && SvPOK(req)) { 246 /* they said C<use Foo v1.2.3> and $Foo::VERSION 247 * doesn't look like a float: do string compare */ 248 if (sv_cmp(req,sv) == 1) { 249 Perl_croak(aTHX_ "%s v%vd required--" 250 "this is only v%vd", 251 HvNAME(pkg), req, sv); 252 } 253 goto finish; 254 } 255 /* they said C<use Foo 1.002_003> and $Foo::VERSION 256 * doesn't look like a float: force numeric compare */ 257 (void)SvUPGRADE(sv, SVt_PVNV); 258 SvNVX(sv) = str_to_version(sv); 259 SvPOK_off(sv); 260 SvNOK_on(sv); 261 } 262 } 263 /* if we get here, we're looking for a numeric comparison, 264 * so force the required version into a float, even if they 265 * said C<use Foo v1.2.3> */ 266 if (SvNIOKp(req) && SvPOK(req)) { 267 NV n = SvNV(req); 268 req = sv_newmortal(); 269 sv_setnv(req, n); 270 } 271 272 if (SvNV(req) > SvNV(sv)) 273 Perl_croak(aTHX_ "%s version %s required--this is only version %s", 274 HvNAME(pkg), SvPV(req,len), SvPV(sv,len)); 275 } 276 277 finish: 278 ST(0) = sv; 279 280 XSRETURN(1); 281 } 282 283