1 /* universal.c 2 * 3 * Copyright (c) 1997-2002, Larry Wall 4 * 5 * You may distribute under the terms of either the GNU General Public 6 * License or the Artistic License, as specified in the README file. 7 * 8 */ 9 10 /* 11 * "The roots of those mountains must be roots indeed; there must be 12 * great secrets buried there which have not been discovered since the 13 * beginning." --Gandalf, relating Gollum's story 14 */ 15 16 #include "EXTERN.h" 17 #define PERL_IN_UNIVERSAL_C 18 #include "perl.h" 19 20 /* 21 * Contributed by Graham Barr <Graham.Barr@tiuk.ti.com> 22 * The main guts of traverse_isa was actually copied from gv_fetchmeth 23 */ 24 25 STATIC SV * 26 S_isa_lookup(pTHX_ HV *stash, const char *name, HV* name_stash, 27 int len, int level) 28 { 29 AV* av; 30 GV* gv; 31 GV** gvp; 32 HV* hv = Nullhv; 33 SV* subgen = Nullsv; 34 35 /* A stash/class can go by many names (ie. User == main::User), so 36 we compare the stash itself just in case */ 37 if (name_stash && (stash == name_stash)) 38 return &PL_sv_yes; 39 40 if (strEQ(HvNAME(stash), name)) 41 return &PL_sv_yes; 42 43 if (level > 100) 44 Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'", 45 HvNAME(stash)); 46 47 gvp = (GV**)hv_fetch(stash, "::ISA::CACHE::", 14, FALSE); 48 49 if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (subgen = GvSV(gv)) 50 && (hv = GvHV(gv))) 51 { 52 if (SvIV(subgen) == (IV)PL_sub_generation) { 53 SV* sv; 54 SV** svp = (SV**)hv_fetch(hv, name, len, FALSE); 55 if (svp && (sv = *svp) != (SV*)&PL_sv_undef) { 56 DEBUG_o( Perl_deb(aTHX_ "Using cached ISA %s for package %s\n", 57 name, HvNAME(stash)) ); 58 return sv; 59 } 60 } 61 else { 62 DEBUG_o( Perl_deb(aTHX_ "ISA Cache in package %s is stale\n", 63 HvNAME(stash)) ); 64 hv_clear(hv); 65 sv_setiv(subgen, PL_sub_generation); 66 } 67 } 68 69 gvp = (GV**)hv_fetch(stash,"ISA",3,FALSE); 70 71 if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (av = GvAV(gv))) { 72 if (!hv || !subgen) { 73 gvp = (GV**)hv_fetch(stash, "::ISA::CACHE::", 14, TRUE); 74 75 gv = *gvp; 76 77 if (SvTYPE(gv) != SVt_PVGV) 78 gv_init(gv, stash, "::ISA::CACHE::", 14, TRUE); 79 80 if (!hv) 81 hv = GvHVn(gv); 82 if (!subgen) { 83 subgen = newSViv(PL_sub_generation); 84 GvSV(gv) = subgen; 85 } 86 } 87 if (hv) { 88 SV** svp = AvARRAY(av); 89 /* NOTE: No support for tied ISA */ 90 I32 items = AvFILLp(av) + 1; 91 while (items--) { 92 SV* sv = *svp++; 93 HV* basestash = gv_stashsv(sv, FALSE); 94 if (!basestash) { 95 if (ckWARN(WARN_MISC)) 96 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), 97 "Can't locate package %s for @%s::ISA", 98 SvPVX(sv), HvNAME(stash)); 99 continue; 100 } 101 if (&PL_sv_yes == isa_lookup(basestash, name, name_stash, 102 len, level + 1)) { 103 (void)hv_store(hv,name,len,&PL_sv_yes,0); 104 return &PL_sv_yes; 105 } 106 } 107 (void)hv_store(hv,name,len,&PL_sv_no,0); 108 } 109 } 110 111 return boolSV(strEQ(name, "UNIVERSAL")); 112 } 113 114 /* 115 =head1 SV Manipulation Functions 116 117 =for apidoc sv_derived_from 118 119 Returns a boolean indicating whether the SV is derived from the specified 120 class. This is the function that implements C<UNIVERSAL::isa>. It works 121 for class names as well as for objects. 122 123 =cut 124 */ 125 126 bool 127 Perl_sv_derived_from(pTHX_ SV *sv, const char *name) 128 { 129 char *type; 130 HV *stash; 131 HV *name_stash; 132 133 stash = Nullhv; 134 type = Nullch; 135 136 if (SvGMAGICAL(sv)) 137 mg_get(sv) ; 138 139 if (SvROK(sv)) { 140 sv = SvRV(sv); 141 type = sv_reftype(sv,0); 142 if (SvOBJECT(sv)) 143 stash = SvSTASH(sv); 144 } 145 else { 146 stash = gv_stashsv(sv, FALSE); 147 } 148 149 name_stash = gv_stashpv(name, FALSE); 150 151 return (type && strEQ(type,name)) || 152 (stash && isa_lookup(stash, name, name_stash, strlen(name), 0) 153 == &PL_sv_yes) 154 ? TRUE 155 : FALSE ; 156 } 157 158 #include "XSUB.h" 159 160 void XS_UNIVERSAL_isa(pTHX_ CV *cv); 161 void XS_UNIVERSAL_can(pTHX_ CV *cv); 162 void XS_UNIVERSAL_VERSION(pTHX_ CV *cv); 163 XS(XS_utf8_valid); 164 XS(XS_utf8_encode); 165 XS(XS_utf8_decode); 166 XS(XS_utf8_upgrade); 167 XS(XS_utf8_downgrade); 168 XS(XS_utf8_unicode_to_native); 169 XS(XS_utf8_native_to_unicode); 170 XS(XS_Internals_SvREADONLY); 171 XS(XS_Internals_SvREFCNT); 172 XS(XS_Internals_hv_clear_placehold); 173 174 void 175 Perl_boot_core_UNIVERSAL(pTHX) 176 { 177 char *file = __FILE__; 178 179 newXS("UNIVERSAL::isa", XS_UNIVERSAL_isa, file); 180 newXS("UNIVERSAL::can", XS_UNIVERSAL_can, file); 181 newXS("UNIVERSAL::VERSION", XS_UNIVERSAL_VERSION, file); 182 newXS("utf8::valid", XS_utf8_valid, file); 183 newXS("utf8::encode", XS_utf8_encode, file); 184 newXS("utf8::decode", XS_utf8_decode, file); 185 newXS("utf8::upgrade", XS_utf8_upgrade, file); 186 newXS("utf8::downgrade", XS_utf8_downgrade, file); 187 newXS("utf8::native_to_unicode", XS_utf8_native_to_unicode, file); 188 newXS("utf8::unicode_to_native", XS_utf8_unicode_to_native, file); 189 newXSproto("Internals::SvREADONLY",XS_Internals_SvREADONLY, file, "\\[$%@];$"); 190 newXSproto("Internals::SvREFCNT",XS_Internals_SvREFCNT, file, "\\[$%@];$"); 191 newXSproto("Internals::hv_clear_placeholders", 192 XS_Internals_hv_clear_placehold, file, "\\%"); 193 } 194 195 196 XS(XS_UNIVERSAL_isa) 197 { 198 dXSARGS; 199 SV *sv; 200 char *name; 201 STRLEN n_a; 202 203 if (items != 2) 204 Perl_croak(aTHX_ "Usage: UNIVERSAL::isa(reference, kind)"); 205 206 sv = ST(0); 207 208 if (SvGMAGICAL(sv)) 209 mg_get(sv); 210 211 if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv)))) 212 XSRETURN_UNDEF; 213 214 name = (char *)SvPV(ST(1),n_a); 215 216 ST(0) = boolSV(sv_derived_from(sv, name)); 217 XSRETURN(1); 218 } 219 220 XS(XS_UNIVERSAL_can) 221 { 222 dXSARGS; 223 SV *sv; 224 char *name; 225 SV *rv; 226 HV *pkg = NULL; 227 STRLEN n_a; 228 229 if (items != 2) 230 Perl_croak(aTHX_ "Usage: UNIVERSAL::can(object-ref, method)"); 231 232 sv = ST(0); 233 234 if (SvGMAGICAL(sv)) 235 mg_get(sv); 236 237 if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv)))) 238 XSRETURN_UNDEF; 239 240 name = (char *)SvPV(ST(1),n_a); 241 rv = &PL_sv_undef; 242 243 if (SvROK(sv)) { 244 sv = (SV*)SvRV(sv); 245 if (SvOBJECT(sv)) 246 pkg = SvSTASH(sv); 247 } 248 else { 249 pkg = gv_stashsv(sv, FALSE); 250 } 251 252 if (pkg) { 253 GV *gv = gv_fetchmethod_autoload(pkg, name, FALSE); 254 if (gv && isGV(gv)) 255 rv = sv_2mortal(newRV((SV*)GvCV(gv))); 256 } 257 258 ST(0) = rv; 259 XSRETURN(1); 260 } 261 262 XS(XS_UNIVERSAL_VERSION) 263 { 264 dXSARGS; 265 HV *pkg; 266 GV **gvp; 267 GV *gv; 268 SV *sv; 269 char *undef; 270 271 if (SvROK(ST(0))) { 272 sv = (SV*)SvRV(ST(0)); 273 if (!SvOBJECT(sv)) 274 Perl_croak(aTHX_ "Cannot find version of an unblessed reference"); 275 pkg = SvSTASH(sv); 276 } 277 else { 278 pkg = gv_stashsv(ST(0), FALSE); 279 } 280 281 gvp = pkg ? (GV**)hv_fetch(pkg,"VERSION",7,FALSE) : Null(GV**); 282 283 if (gvp && isGV(gv = *gvp) && SvOK(sv = GvSV(gv))) { 284 SV *nsv = sv_newmortal(); 285 sv_setsv(nsv, sv); 286 sv = nsv; 287 undef = Nullch; 288 } 289 else { 290 sv = (SV*)&PL_sv_undef; 291 undef = "(undef)"; 292 } 293 294 if (items > 1) { 295 STRLEN len; 296 SV *req = ST(1); 297 298 if (undef) { 299 if (pkg) 300 Perl_croak(aTHX_ 301 "%s does not define $%s::VERSION--version check failed", 302 HvNAME(pkg), HvNAME(pkg)); 303 else { 304 char *str = SvPVx(ST(0), len); 305 306 Perl_croak(aTHX_ 307 "%s defines neither package nor VERSION--version check failed", str); 308 } 309 } 310 if (!SvNIOK(sv) && SvPOK(sv)) { 311 char *str = SvPVx(sv,len); 312 while (len) { 313 --len; 314 /* XXX could DWIM "1.2.3" here */ 315 if (!isDIGIT(str[len]) && str[len] != '.' && str[len] != '_') 316 break; 317 } 318 if (len) { 319 if (SvNOK(req) && SvPOK(req)) { 320 /* they said C<use Foo v1.2.3> and $Foo::VERSION 321 * doesn't look like a float: do string compare */ 322 if (sv_cmp(req,sv) == 1) { 323 Perl_croak(aTHX_ "%s v%"VDf" required--" 324 "this is only v%"VDf, 325 HvNAME(pkg), req, sv); 326 } 327 goto finish; 328 } 329 /* they said C<use Foo 1.002_003> and $Foo::VERSION 330 * doesn't look like a float: force numeric compare */ 331 (void)SvUPGRADE(sv, SVt_PVNV); 332 SvNVX(sv) = str_to_version(sv); 333 SvPOK_off(sv); 334 SvNOK_on(sv); 335 } 336 } 337 /* if we get here, we're looking for a numeric comparison, 338 * so force the required version into a float, even if they 339 * said C<use Foo v1.2.3> */ 340 if (SvNOK(req) && SvPOK(req)) { 341 NV n = SvNV(req); 342 req = sv_newmortal(); 343 sv_setnv(req, n); 344 } 345 346 if (SvNV(req) > SvNV(sv)) 347 Perl_croak(aTHX_ "%s version %s required--this is only version %s", 348 HvNAME(pkg), SvPV_nolen(req), SvPV_nolen(sv)); 349 } 350 351 finish: 352 ST(0) = sv; 353 354 XSRETURN(1); 355 } 356 357 XS(XS_utf8_valid) 358 { 359 dXSARGS; 360 if (items != 1) 361 Perl_croak(aTHX_ "Usage: utf8::valid(sv)"); 362 { 363 SV * sv = ST(0); 364 { 365 STRLEN len; 366 char *s = SvPV(sv,len); 367 if (!SvUTF8(sv) || is_utf8_string((U8*)s,len)) 368 XSRETURN_YES; 369 else 370 XSRETURN_NO; 371 } 372 } 373 XSRETURN_EMPTY; 374 } 375 376 XS(XS_utf8_encode) 377 { 378 dXSARGS; 379 if (items != 1) 380 Perl_croak(aTHX_ "Usage: utf8::encode(sv)"); 381 { 382 SV * sv = ST(0); 383 384 sv_utf8_encode(sv); 385 } 386 XSRETURN_EMPTY; 387 } 388 389 XS(XS_utf8_decode) 390 { 391 dXSARGS; 392 if (items != 1) 393 Perl_croak(aTHX_ "Usage: utf8::decode(sv)"); 394 { 395 SV * sv = ST(0); 396 bool RETVAL; 397 398 RETVAL = sv_utf8_decode(sv); 399 ST(0) = boolSV(RETVAL); 400 sv_2mortal(ST(0)); 401 } 402 XSRETURN(1); 403 } 404 405 XS(XS_utf8_upgrade) 406 { 407 dXSARGS; 408 if (items != 1) 409 Perl_croak(aTHX_ "Usage: utf8::upgrade(sv)"); 410 { 411 SV * sv = ST(0); 412 STRLEN RETVAL; 413 dXSTARG; 414 415 RETVAL = sv_utf8_upgrade(sv); 416 XSprePUSH; PUSHi((IV)RETVAL); 417 } 418 XSRETURN(1); 419 } 420 421 XS(XS_utf8_downgrade) 422 { 423 dXSARGS; 424 if (items < 1 || items > 2) 425 Perl_croak(aTHX_ "Usage: utf8::downgrade(sv, failok=0)"); 426 { 427 SV * sv = ST(0); 428 bool failok; 429 bool RETVAL; 430 431 if (items < 2) 432 failok = 0; 433 else { 434 failok = (int)SvIV(ST(1)); 435 } 436 437 RETVAL = sv_utf8_downgrade(sv, failok); 438 ST(0) = boolSV(RETVAL); 439 sv_2mortal(ST(0)); 440 } 441 XSRETURN(1); 442 } 443 444 XS(XS_utf8_native_to_unicode) 445 { 446 dXSARGS; 447 UV uv = SvUV(ST(0)); 448 449 if (items > 1) 450 Perl_croak(aTHX_ "Usage: utf8::native_to_unicode(sv)"); 451 452 ST(0) = sv_2mortal(newSViv(NATIVE_TO_UNI(uv))); 453 XSRETURN(1); 454 } 455 456 XS(XS_utf8_unicode_to_native) 457 { 458 dXSARGS; 459 UV uv = SvUV(ST(0)); 460 461 if (items > 1) 462 Perl_croak(aTHX_ "Usage: utf8::unicode_to_native(sv)"); 463 464 ST(0) = sv_2mortal(newSViv(UNI_TO_NATIVE(uv))); 465 XSRETURN(1); 466 } 467 468 XS(XS_Internals_SvREADONLY) /* This is dangerous stuff. */ 469 { 470 dXSARGS; 471 SV *sv = SvRV(ST(0)); 472 if (items == 1) { 473 if (SvREADONLY(sv)) 474 XSRETURN_YES; 475 else 476 XSRETURN_NO; 477 } 478 else if (items == 2) { 479 if (SvTRUE(ST(1))) { 480 SvREADONLY_on(sv); 481 XSRETURN_YES; 482 } 483 else { 484 /* I hope you really know what you are doing. */ 485 SvREADONLY_off(sv); 486 XSRETURN_NO; 487 } 488 } 489 XSRETURN_UNDEF; /* Can't happen. */ 490 } 491 492 XS(XS_Internals_SvREFCNT) /* This is dangerous stuff. */ 493 { 494 dXSARGS; 495 SV *sv = SvRV(ST(0)); 496 if (items == 1) 497 XSRETURN_IV(SvREFCNT(sv) - 1); /* Minus the ref created for us. */ 498 else if (items == 2) { 499 /* I hope you really know what you are doing. */ 500 SvREFCNT(sv) = SvIV(ST(1)); 501 XSRETURN_IV(SvREFCNT(sv)); 502 } 503 XSRETURN_UNDEF; /* Can't happen. */ 504 } 505 506 /* Maybe this should return the number of placeholders found in scalar context, 507 and a list of them in list context. */ 508 XS(XS_Internals_hv_clear_placehold) 509 { 510 dXSARGS; 511 HV *hv = (HV *) SvRV(ST(0)); 512 513 /* I don't care how many parameters were passed in, but I want to avoid 514 the unused variable warning. */ 515 516 items = (I32)HvPLACEHOLDERS(hv); 517 518 if (items) { 519 HE *entry; 520 I32 riter = HvRITER(hv); 521 HE *eiter = HvEITER(hv); 522 hv_iterinit(hv); 523 /* This may look suboptimal with the items *after* the iternext, but 524 it's quite deliberate. We only get here with items==0 if we've 525 just deleted the last placeholder in the hash. If we've just done 526 that then it means that the hash is in lazy delete mode, and the 527 HE is now only referenced in our iterator. If we just quit the loop 528 and discarded our iterator then the HE leaks. So we do the && the 529 other way to ensure iternext is called just one more time, which 530 has the side effect of triggering the lazy delete. */ 531 while ((entry = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS)) 532 && items) { 533 SV *val = hv_iterval(hv, entry); 534 535 if (val == &PL_sv_undef) { 536 537 /* It seems that I have to go back in the front of the hash 538 API to delete a hash, even though I have a HE structure 539 pointing to the very entry I want to delete, and could hold 540 onto the previous HE that points to it. And it's easier to 541 go in with SVs as I can then specify the precomputed hash, 542 and don't have fun and games with utf8 keys. */ 543 SV *key = hv_iterkeysv(entry); 544 545 hv_delete_ent (hv, key, G_DISCARD, HeHASH(entry)); 546 items--; 547 } 548 } 549 HvRITER(hv) = riter; 550 HvEITER(hv) = eiter; 551 } 552 553 XSRETURN(0); 554 } 555