1 /* universal.c 2 * 3 * Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 4 * by Larry Wall and others 5 * 6 * You may distribute under the terms of either the GNU General Public 7 * License or the Artistic License, as specified in the README file. 8 * 9 */ 10 11 /* 12 * "The roots of those mountains must be roots indeed; there must be 13 * great secrets buried there which have not been discovered since the 14 * beginning." --Gandalf, relating Gollum's story 15 */ 16 17 #include "EXTERN.h" 18 #define PERL_IN_UNIVERSAL_C 19 #include "perl.h" 20 21 #ifdef USE_PERLIO 22 #include "perliol.h" /* For the PERLIO_F_XXX */ 23 #endif 24 25 /* 26 * Contributed by Graham Barr <Graham.Barr@tiuk.ti.com> 27 * The main guts of traverse_isa was actually copied from gv_fetchmeth 28 */ 29 30 STATIC SV * 31 S_isa_lookup(pTHX_ HV *stash, const char *name, HV* name_stash, 32 int len, int level) 33 { 34 AV* av; 35 GV* gv; 36 GV** gvp; 37 HV* hv = Nullhv; 38 SV* subgen = Nullsv; 39 40 /* A stash/class can go by many names (ie. User == main::User), so 41 we compare the stash itself just in case */ 42 if (name_stash && (stash == name_stash)) 43 return &PL_sv_yes; 44 45 if (strEQ(HvNAME(stash), name)) 46 return &PL_sv_yes; 47 48 if (strEQ(name, "UNIVERSAL")) 49 return &PL_sv_yes; 50 51 if (level > 100) 52 Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'", 53 HvNAME(stash)); 54 55 gvp = (GV**)hv_fetch(stash, "::ISA::CACHE::", 14, FALSE); 56 57 if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (subgen = GvSV(gv)) 58 && (hv = GvHV(gv))) 59 { 60 if (SvIV(subgen) == (IV)PL_sub_generation) { 61 SV* sv; 62 SV** svp = (SV**)hv_fetch(hv, name, len, FALSE); 63 if (svp && (sv = *svp) != (SV*)&PL_sv_undef) { 64 DEBUG_o( Perl_deb(aTHX_ "Using cached ISA %s for package %s\n", 65 name, HvNAME(stash)) ); 66 return sv; 67 } 68 } 69 else { 70 DEBUG_o( Perl_deb(aTHX_ "ISA Cache in package %s is stale\n", 71 HvNAME(stash)) ); 72 hv_clear(hv); 73 sv_setiv(subgen, PL_sub_generation); 74 } 75 } 76 77 gvp = (GV**)hv_fetch(stash,"ISA",3,FALSE); 78 79 if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (av = GvAV(gv))) { 80 if (!hv || !subgen) { 81 gvp = (GV**)hv_fetch(stash, "::ISA::CACHE::", 14, TRUE); 82 83 gv = *gvp; 84 85 if (SvTYPE(gv) != SVt_PVGV) 86 gv_init(gv, stash, "::ISA::CACHE::", 14, TRUE); 87 88 if (!hv) 89 hv = GvHVn(gv); 90 if (!subgen) { 91 subgen = newSViv(PL_sub_generation); 92 GvSV(gv) = subgen; 93 } 94 } 95 if (hv) { 96 SV** svp = AvARRAY(av); 97 /* NOTE: No support for tied ISA */ 98 I32 items = AvFILLp(av) + 1; 99 while (items--) { 100 SV* sv = *svp++; 101 HV* basestash = gv_stashsv(sv, FALSE); 102 if (!basestash) { 103 if (ckWARN(WARN_MISC)) 104 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), 105 "Can't locate package %"SVf" for @%s::ISA", 106 sv, HvNAME(stash)); 107 continue; 108 } 109 if (&PL_sv_yes == isa_lookup(basestash, name, name_stash, 110 len, level + 1)) { 111 (void)hv_store(hv,name,len,&PL_sv_yes,0); 112 return &PL_sv_yes; 113 } 114 } 115 (void)hv_store(hv,name,len,&PL_sv_no,0); 116 } 117 } 118 return &PL_sv_no; 119 } 120 121 /* 122 =head1 SV Manipulation Functions 123 124 =for apidoc sv_derived_from 125 126 Returns a boolean indicating whether the SV is derived from the specified 127 class. This is the function that implements C<UNIVERSAL::isa>. It works 128 for class names as well as for objects. 129 130 =cut 131 */ 132 133 bool 134 Perl_sv_derived_from(pTHX_ SV *sv, const char *name) 135 { 136 char *type; 137 HV *stash; 138 HV *name_stash; 139 140 stash = Nullhv; 141 type = Nullch; 142 143 if (SvGMAGICAL(sv)) 144 mg_get(sv) ; 145 146 if (SvROK(sv)) { 147 sv = SvRV(sv); 148 type = sv_reftype(sv,0); 149 if (SvOBJECT(sv)) 150 stash = SvSTASH(sv); 151 } 152 else { 153 stash = gv_stashsv(sv, FALSE); 154 } 155 156 name_stash = gv_stashpv(name, FALSE); 157 158 return (type && strEQ(type,name)) || 159 (stash && isa_lookup(stash, name, name_stash, strlen(name), 0) 160 == &PL_sv_yes) 161 ? TRUE 162 : FALSE ; 163 } 164 165 #include "XSUB.h" 166 167 void XS_UNIVERSAL_isa(pTHX_ CV *cv); 168 void XS_UNIVERSAL_can(pTHX_ CV *cv); 169 void XS_UNIVERSAL_VERSION(pTHX_ CV *cv); 170 XS(XS_utf8_is_utf8); 171 XS(XS_utf8_valid); 172 XS(XS_utf8_encode); 173 XS(XS_utf8_decode); 174 XS(XS_utf8_upgrade); 175 XS(XS_utf8_downgrade); 176 XS(XS_utf8_unicode_to_native); 177 XS(XS_utf8_native_to_unicode); 178 XS(XS_Internals_SvREADONLY); 179 XS(XS_Internals_SvREFCNT); 180 XS(XS_Internals_hv_clear_placehold); 181 XS(XS_PerlIO_get_layers); 182 XS(XS_Regexp_DESTROY); 183 XS(XS_Internals_hash_seed); 184 XS(XS_Internals_rehash_seed); 185 XS(XS_Internals_HvREHASH); 186 187 void 188 Perl_boot_core_UNIVERSAL(pTHX) 189 { 190 char *file = __FILE__; 191 192 newXS("UNIVERSAL::isa", XS_UNIVERSAL_isa, file); 193 newXS("UNIVERSAL::can", XS_UNIVERSAL_can, file); 194 newXS("UNIVERSAL::VERSION", XS_UNIVERSAL_VERSION, file); 195 newXS("utf8::is_utf8", XS_utf8_is_utf8, file); 196 newXS("utf8::valid", XS_utf8_valid, file); 197 newXS("utf8::encode", XS_utf8_encode, file); 198 newXS("utf8::decode", XS_utf8_decode, file); 199 newXS("utf8::upgrade", XS_utf8_upgrade, file); 200 newXS("utf8::downgrade", XS_utf8_downgrade, file); 201 newXS("utf8::native_to_unicode", XS_utf8_native_to_unicode, file); 202 newXS("utf8::unicode_to_native", XS_utf8_unicode_to_native, file); 203 newXSproto("Internals::SvREADONLY",XS_Internals_SvREADONLY, file, "\\[$%@];$"); 204 newXSproto("Internals::SvREFCNT",XS_Internals_SvREFCNT, file, "\\[$%@];$"); 205 newXSproto("Internals::hv_clear_placeholders", 206 XS_Internals_hv_clear_placehold, file, "\\%"); 207 newXSproto("PerlIO::get_layers", 208 XS_PerlIO_get_layers, file, "*;@"); 209 newXS("Regexp::DESTROY", XS_Regexp_DESTROY, file); 210 newXSproto("Internals::hash_seed",XS_Internals_hash_seed, file, ""); 211 newXSproto("Internals::rehash_seed",XS_Internals_rehash_seed, file, ""); 212 newXSproto("Internals::HvREHASH", XS_Internals_HvREHASH, file, "\\%"); 213 } 214 215 216 XS(XS_UNIVERSAL_isa) 217 { 218 dXSARGS; 219 SV *sv; 220 char *name; 221 STRLEN n_a; 222 223 if (items != 2) 224 Perl_croak(aTHX_ "Usage: UNIVERSAL::isa(reference, kind)"); 225 226 sv = ST(0); 227 228 if (SvGMAGICAL(sv)) 229 mg_get(sv); 230 231 if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv)) 232 || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv)))) 233 XSRETURN_UNDEF; 234 235 name = (char *)SvPV(ST(1),n_a); 236 237 ST(0) = boolSV(sv_derived_from(sv, name)); 238 XSRETURN(1); 239 } 240 241 XS(XS_UNIVERSAL_can) 242 { 243 dXSARGS; 244 SV *sv; 245 char *name; 246 SV *rv; 247 HV *pkg = NULL; 248 STRLEN n_a; 249 250 if (items != 2) 251 Perl_croak(aTHX_ "Usage: UNIVERSAL::can(object-ref, method)"); 252 253 sv = ST(0); 254 255 if (SvGMAGICAL(sv)) 256 mg_get(sv); 257 258 if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv)) 259 || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv)))) 260 XSRETURN_UNDEF; 261 262 name = (char *)SvPV(ST(1),n_a); 263 rv = &PL_sv_undef; 264 265 if (SvROK(sv)) { 266 sv = (SV*)SvRV(sv); 267 if (SvOBJECT(sv)) 268 pkg = SvSTASH(sv); 269 } 270 else { 271 pkg = gv_stashsv(sv, FALSE); 272 } 273 274 if (pkg) { 275 GV *gv = gv_fetchmethod_autoload(pkg, name, FALSE); 276 if (gv && isGV(gv)) 277 rv = sv_2mortal(newRV((SV*)GvCV(gv))); 278 } 279 280 ST(0) = rv; 281 XSRETURN(1); 282 } 283 284 XS(XS_UNIVERSAL_VERSION) 285 { 286 dXSARGS; 287 HV *pkg; 288 GV **gvp; 289 GV *gv; 290 SV *sv; 291 char *undef; 292 293 if (SvROK(ST(0))) { 294 sv = (SV*)SvRV(ST(0)); 295 if (!SvOBJECT(sv)) 296 Perl_croak(aTHX_ "Cannot find version of an unblessed reference"); 297 pkg = SvSTASH(sv); 298 } 299 else { 300 pkg = gv_stashsv(ST(0), FALSE); 301 } 302 303 gvp = pkg ? (GV**)hv_fetch(pkg,"VERSION",7,FALSE) : Null(GV**); 304 305 if (gvp && isGV(gv = *gvp) && SvOK(sv = GvSV(gv))) { 306 SV *nsv = sv_newmortal(); 307 sv_setsv(nsv, sv); 308 sv = nsv; 309 undef = Nullch; 310 } 311 else { 312 sv = (SV*)&PL_sv_undef; 313 undef = "(undef)"; 314 } 315 316 if (items > 1) { 317 STRLEN len; 318 SV *req = ST(1); 319 320 if (undef) { 321 if (pkg) 322 Perl_croak(aTHX_ 323 "%s does not define $%s::VERSION--version check failed", 324 HvNAME(pkg), HvNAME(pkg)); 325 else { 326 char *str = SvPVx(ST(0), len); 327 328 Perl_croak(aTHX_ 329 "%s defines neither package nor VERSION--version check failed", str); 330 } 331 } 332 if (!SvNIOK(sv) && SvPOK(sv)) { 333 char *str = SvPVx(sv,len); 334 while (len) { 335 --len; 336 /* XXX could DWIM "1.2.3" here */ 337 if (!isDIGIT(str[len]) && str[len] != '.' && str[len] != '_') 338 break; 339 } 340 if (len) { 341 if (SvNOK(req) && SvPOK(req)) { 342 /* they said C<use Foo v1.2.3> and $Foo::VERSION 343 * doesn't look like a float: do string compare */ 344 if (sv_cmp(req,sv) == 1) { 345 Perl_croak(aTHX_ "%s v%"VDf" required--" 346 "this is only v%"VDf, 347 HvNAME(pkg), req, sv); 348 } 349 goto finish; 350 } 351 /* they said C<use Foo 1.002_003> and $Foo::VERSION 352 * doesn't look like a float: force numeric compare */ 353 (void)SvUPGRADE(sv, SVt_PVNV); 354 SvNVX(sv) = str_to_version(sv); 355 SvPOK_off(sv); 356 SvNOK_on(sv); 357 } 358 } 359 /* if we get here, we're looking for a numeric comparison, 360 * so force the required version into a float, even if they 361 * said C<use Foo v1.2.3> */ 362 if (SvNOK(req) && SvPOK(req)) { 363 NV n = SvNV(req); 364 req = sv_newmortal(); 365 sv_setnv(req, n); 366 } 367 368 if (SvNV(req) > SvNV(sv)) 369 Perl_croak(aTHX_ "%s version %s required--this is only version %s", 370 HvNAME(pkg), SvPV_nolen(req), SvPV_nolen(sv)); 371 } 372 373 finish: 374 ST(0) = sv; 375 376 XSRETURN(1); 377 } 378 379 XS(XS_utf8_is_utf8) 380 { 381 dXSARGS; 382 if (items != 1) 383 Perl_croak(aTHX_ "Usage: utf8::is_utf8(sv)"); 384 { 385 SV * sv = ST(0); 386 { 387 if (SvUTF8(sv)) 388 XSRETURN_YES; 389 else 390 XSRETURN_NO; 391 } 392 } 393 XSRETURN_EMPTY; 394 } 395 396 XS(XS_utf8_valid) 397 { 398 dXSARGS; 399 if (items != 1) 400 Perl_croak(aTHX_ "Usage: utf8::valid(sv)"); 401 { 402 SV * sv = ST(0); 403 { 404 STRLEN len; 405 char *s = SvPV(sv,len); 406 if (!SvUTF8(sv) || is_utf8_string((U8*)s,len)) 407 XSRETURN_YES; 408 else 409 XSRETURN_NO; 410 } 411 } 412 XSRETURN_EMPTY; 413 } 414 415 XS(XS_utf8_encode) 416 { 417 dXSARGS; 418 if (items != 1) 419 Perl_croak(aTHX_ "Usage: utf8::encode(sv)"); 420 { 421 SV * sv = ST(0); 422 423 sv_utf8_encode(sv); 424 } 425 XSRETURN_EMPTY; 426 } 427 428 XS(XS_utf8_decode) 429 { 430 dXSARGS; 431 if (items != 1) 432 Perl_croak(aTHX_ "Usage: utf8::decode(sv)"); 433 { 434 SV * sv = ST(0); 435 bool RETVAL; 436 437 RETVAL = sv_utf8_decode(sv); 438 ST(0) = boolSV(RETVAL); 439 sv_2mortal(ST(0)); 440 } 441 XSRETURN(1); 442 } 443 444 XS(XS_utf8_upgrade) 445 { 446 dXSARGS; 447 if (items != 1) 448 Perl_croak(aTHX_ "Usage: utf8::upgrade(sv)"); 449 { 450 SV * sv = ST(0); 451 STRLEN RETVAL; 452 dXSTARG; 453 454 RETVAL = sv_utf8_upgrade(sv); 455 XSprePUSH; PUSHi((IV)RETVAL); 456 } 457 XSRETURN(1); 458 } 459 460 XS(XS_utf8_downgrade) 461 { 462 dXSARGS; 463 if (items < 1 || items > 2) 464 Perl_croak(aTHX_ "Usage: utf8::downgrade(sv, failok=0)"); 465 { 466 SV * sv = ST(0); 467 bool failok; 468 bool RETVAL; 469 470 if (items < 2) 471 failok = 0; 472 else { 473 failok = (int)SvIV(ST(1)); 474 } 475 476 RETVAL = sv_utf8_downgrade(sv, failok); 477 ST(0) = boolSV(RETVAL); 478 sv_2mortal(ST(0)); 479 } 480 XSRETURN(1); 481 } 482 483 XS(XS_utf8_native_to_unicode) 484 { 485 dXSARGS; 486 UV uv = SvUV(ST(0)); 487 488 if (items > 1) 489 Perl_croak(aTHX_ "Usage: utf8::native_to_unicode(sv)"); 490 491 ST(0) = sv_2mortal(newSViv(NATIVE_TO_UNI(uv))); 492 XSRETURN(1); 493 } 494 495 XS(XS_utf8_unicode_to_native) 496 { 497 dXSARGS; 498 UV uv = SvUV(ST(0)); 499 500 if (items > 1) 501 Perl_croak(aTHX_ "Usage: utf8::unicode_to_native(sv)"); 502 503 ST(0) = sv_2mortal(newSViv(UNI_TO_NATIVE(uv))); 504 XSRETURN(1); 505 } 506 507 XS(XS_Internals_SvREADONLY) /* This is dangerous stuff. */ 508 { 509 dXSARGS; 510 SV *sv = SvRV(ST(0)); 511 if (items == 1) { 512 if (SvREADONLY(sv)) 513 XSRETURN_YES; 514 else 515 XSRETURN_NO; 516 } 517 else if (items == 2) { 518 if (SvTRUE(ST(1))) { 519 SvREADONLY_on(sv); 520 XSRETURN_YES; 521 } 522 else { 523 /* I hope you really know what you are doing. */ 524 SvREADONLY_off(sv); 525 XSRETURN_NO; 526 } 527 } 528 XSRETURN_UNDEF; /* Can't happen. */ 529 } 530 531 XS(XS_Internals_SvREFCNT) /* This is dangerous stuff. */ 532 { 533 dXSARGS; 534 SV *sv = SvRV(ST(0)); 535 if (items == 1) 536 XSRETURN_IV(SvREFCNT(sv) - 1); /* Minus the ref created for us. */ 537 else if (items == 2) { 538 /* I hope you really know what you are doing. */ 539 SvREFCNT(sv) = SvIV(ST(1)); 540 XSRETURN_IV(SvREFCNT(sv)); 541 } 542 XSRETURN_UNDEF; /* Can't happen. */ 543 } 544 545 XS(XS_Internals_hv_clear_placehold) 546 { 547 dXSARGS; 548 HV *hv = (HV *) SvRV(ST(0)); 549 if (items != 1) 550 Perl_croak(aTHX_ "Usage: UNIVERSAL::hv_clear_placeholders(hv)"); 551 hv_clear_placeholders(hv); 552 XSRETURN(0); 553 } 554 555 XS(XS_Regexp_DESTROY) 556 { 557 558 } 559 560 XS(XS_PerlIO_get_layers) 561 { 562 dXSARGS; 563 if (items < 1 || items % 2 == 0) 564 Perl_croak(aTHX_ "Usage: PerlIO_get_layers(filehandle[,args])"); 565 #ifdef USE_PERLIO 566 { 567 SV * sv; 568 GV * gv; 569 IO * io; 570 bool input = TRUE; 571 bool details = FALSE; 572 573 if (items > 1) { 574 SV **svp; 575 576 for (svp = MARK + 2; svp <= SP; svp += 2) { 577 SV **varp = svp; 578 SV **valp = svp + 1; 579 STRLEN klen; 580 char *key = SvPV(*varp, klen); 581 582 switch (*key) { 583 case 'i': 584 if (klen == 5 && memEQ(key, "input", 5)) { 585 input = SvTRUE(*valp); 586 break; 587 } 588 goto fail; 589 case 'o': 590 if (klen == 6 && memEQ(key, "output", 6)) { 591 input = !SvTRUE(*valp); 592 break; 593 } 594 goto fail; 595 case 'd': 596 if (klen == 7 && memEQ(key, "details", 7)) { 597 details = SvTRUE(*valp); 598 break; 599 } 600 goto fail; 601 default: 602 fail: 603 Perl_croak(aTHX_ 604 "get_layers: unknown argument '%s'", 605 key); 606 } 607 } 608 609 SP -= (items - 1); 610 } 611 612 sv = POPs; 613 gv = (GV*)sv; 614 615 if (!isGV(sv)) { 616 if (SvROK(sv) && isGV(SvRV(sv))) 617 gv = (GV*)SvRV(sv); 618 else 619 gv = gv_fetchpv(SvPVX(sv), FALSE, SVt_PVIO); 620 } 621 622 if (gv && (io = GvIO(gv))) { 623 dTARGET; 624 AV* av = PerlIO_get_layers(aTHX_ input ? 625 IoIFP(io) : IoOFP(io)); 626 I32 i; 627 I32 last = av_len(av); 628 I32 nitem = 0; 629 630 for (i = last; i >= 0; i -= 3) { 631 SV **namsvp; 632 SV **argsvp; 633 SV **flgsvp; 634 bool namok, argok, flgok; 635 636 namsvp = av_fetch(av, i - 2, FALSE); 637 argsvp = av_fetch(av, i - 1, FALSE); 638 flgsvp = av_fetch(av, i, FALSE); 639 640 namok = namsvp && *namsvp && SvPOK(*namsvp); 641 argok = argsvp && *argsvp && SvPOK(*argsvp); 642 flgok = flgsvp && *flgsvp && SvIOK(*flgsvp); 643 644 if (details) { 645 XPUSHs(namok ? 646 newSVpv(SvPVX(*namsvp), 0) : &PL_sv_undef); 647 XPUSHs(argok ? 648 newSVpv(SvPVX(*argsvp), 0) : &PL_sv_undef); 649 if (flgok) 650 XPUSHi(SvIVX(*flgsvp)); 651 else 652 XPUSHs(&PL_sv_undef); 653 nitem += 3; 654 } 655 else { 656 if (namok && argok) 657 XPUSHs(Perl_newSVpvf(aTHX_ "%"SVf"(%"SVf")", 658 *namsvp, *argsvp)); 659 else if (namok) 660 XPUSHs(Perl_newSVpvf(aTHX_ "%"SVf, *namsvp)); 661 else 662 XPUSHs(&PL_sv_undef); 663 nitem++; 664 if (flgok) { 665 IV flags = SvIVX(*flgsvp); 666 667 if (flags & PERLIO_F_UTF8) { 668 XPUSHs(newSVpvn("utf8", 4)); 669 nitem++; 670 } 671 } 672 } 673 } 674 675 SvREFCNT_dec(av); 676 677 XSRETURN(nitem); 678 } 679 } 680 #endif 681 682 XSRETURN(0); 683 } 684 685 XS(XS_Internals_hash_seed) 686 { 687 /* Using dXSARGS would also have dITEM and dSP, 688 * which define 2 unused local variables. */ 689 dMARK; dAX; 690 XSRETURN_UV(PERL_HASH_SEED); 691 } 692 693 XS(XS_Internals_rehash_seed) 694 { 695 /* Using dXSARGS would also have dITEM and dSP, 696 * which define 2 unused local variables. */ 697 dMARK; dAX; 698 XSRETURN_UV(PL_rehash_seed); 699 } 700 701 XS(XS_Internals_HvREHASH) /* Subject to change */ 702 { 703 dXSARGS; 704 if (SvROK(ST(0))) { 705 HV *hv = (HV *) SvRV(ST(0)); 706 if (items == 1 && SvTYPE(hv) == SVt_PVHV) { 707 if (HvREHASH(hv)) 708 XSRETURN_YES; 709 else 710 XSRETURN_NO; 711 } 712 } 713 Perl_croak(aTHX_ "Internals::HvREHASH $hashref"); 714 } 715