1 /* universal.c 2 * 3 * Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 4 * 2005, 2006, 2007, 2008 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 history 15 * 16 * [p.54 of _The Lord of the Rings_, I/ii: "The Shadow of the Past"] 17 */ 18 19 /* This file contains the code that implements the functions in Perl's 20 * UNIVERSAL package, such as UNIVERSAL->can(). 21 * 22 * It is also used to store XS functions that need to be present in 23 * miniperl for a lack of a better place to put them. It might be 24 * clever to move them to separate XS files which would then be pulled 25 * in by some to-be-written build process. 26 */ 27 28 #include "EXTERN.h" 29 #define PERL_IN_UNIVERSAL_C 30 #include "perl.h" 31 32 #ifdef USE_PERLIO 33 #include "perliol.h" /* For the PERLIO_F_XXX */ 34 #endif 35 36 /* 37 * Contributed by Graham Barr <Graham.Barr@tiuk.ti.com> 38 * The main guts of traverse_isa was actually copied from gv_fetchmeth 39 */ 40 41 STATIC bool 42 S_isa_lookup(pTHX_ HV *stash, const char * const name, STRLEN len, U32 flags) 43 { 44 dVAR; 45 const struct mro_meta *const meta = HvMROMETA(stash); 46 HV *isa = meta->isa; 47 const HV *our_stash; 48 49 PERL_ARGS_ASSERT_ISA_LOOKUP; 50 51 if (!isa) { 52 (void)mro_get_linear_isa(stash); 53 isa = meta->isa; 54 } 55 56 if (hv_common(isa, NULL, name, len, ( flags & SVf_UTF8 ? HVhek_UTF8 : 0), 57 HV_FETCH_ISEXISTS, NULL, 0)) { 58 /* Direct name lookup worked. */ 59 return TRUE; 60 } 61 62 /* A stash/class can go by many names (ie. User == main::User), so 63 we use the HvENAME in the stash itself, which is canonical, falling 64 back to HvNAME if necessary. */ 65 our_stash = gv_stashpvn(name, len, flags); 66 67 if (our_stash) { 68 HEK *canon_name = HvENAME_HEK(our_stash); 69 if (!canon_name) canon_name = HvNAME_HEK(our_stash); 70 71 if (hv_common(isa, NULL, HEK_KEY(canon_name), HEK_LEN(canon_name), 72 HEK_FLAGS(canon_name), 73 HV_FETCH_ISEXISTS, NULL, HEK_HASH(canon_name))) { 74 return TRUE; 75 } 76 } 77 78 return FALSE; 79 } 80 81 /* 82 =head1 SV Manipulation Functions 83 84 =for apidoc sv_derived_from_pvn 85 86 Returns a boolean indicating whether the SV is derived from the specified class 87 I<at the C level>. To check derivation at the Perl level, call C<isa()> as a 88 normal Perl method. 89 90 Currently, the only significant value for C<flags> is SVf_UTF8. 91 92 =cut 93 94 =for apidoc sv_derived_from_sv 95 96 Exactly like L</sv_derived_from_pvn>, but takes the name string in the form 97 of an SV instead of a string/length pair. 98 99 =cut 100 101 */ 102 103 bool 104 Perl_sv_derived_from_sv(pTHX_ SV *sv, SV *namesv, U32 flags) 105 { 106 char *namepv; 107 STRLEN namelen; 108 PERL_ARGS_ASSERT_SV_DERIVED_FROM_SV; 109 namepv = SvPV(namesv, namelen); 110 if (SvUTF8(namesv)) 111 flags |= SVf_UTF8; 112 return sv_derived_from_pvn(sv, namepv, namelen, flags); 113 } 114 115 /* 116 =for apidoc sv_derived_from 117 118 Exactly like L</sv_derived_from_pv>, but doesn't take a C<flags> parameter. 119 120 =cut 121 */ 122 123 bool 124 Perl_sv_derived_from(pTHX_ SV *sv, const char *const name) 125 { 126 PERL_ARGS_ASSERT_SV_DERIVED_FROM; 127 return sv_derived_from_pvn(sv, name, strlen(name), 0); 128 } 129 130 /* 131 =for apidoc sv_derived_from_pv 132 133 Exactly like L</sv_derived_from_pvn>, but takes a nul-terminated string 134 instead of a string/length pair. 135 136 =cut 137 */ 138 139 140 bool 141 Perl_sv_derived_from_pv(pTHX_ SV *sv, const char *const name, U32 flags) 142 { 143 PERL_ARGS_ASSERT_SV_DERIVED_FROM_PV; 144 return sv_derived_from_pvn(sv, name, strlen(name), flags); 145 } 146 147 bool 148 Perl_sv_derived_from_pvn(pTHX_ SV *sv, const char *const name, const STRLEN len, U32 flags) 149 { 150 dVAR; 151 HV *stash; 152 153 PERL_ARGS_ASSERT_SV_DERIVED_FROM_PVN; 154 155 SvGETMAGIC(sv); 156 157 if (SvROK(sv)) { 158 const char *type; 159 sv = SvRV(sv); 160 type = sv_reftype(sv,0); 161 if (type && strEQ(type,name)) 162 return TRUE; 163 stash = SvOBJECT(sv) ? SvSTASH(sv) : NULL; 164 } 165 else { 166 stash = gv_stashsv(sv, 0); 167 if (!stash) 168 stash = gv_stashpvs("UNIVERSAL", 0); 169 } 170 171 return stash ? isa_lookup(stash, name, len, flags) : FALSE; 172 } 173 174 /* 175 =for apidoc sv_does_sv 176 177 Returns a boolean indicating whether the SV performs a specific, named role. 178 The SV can be a Perl object or the name of a Perl class. 179 180 =cut 181 */ 182 183 #include "XSUB.h" 184 185 bool 186 Perl_sv_does_sv(pTHX_ SV *sv, SV *namesv, U32 flags) 187 { 188 SV *classname; 189 bool does_it; 190 SV *methodname; 191 dSP; 192 193 PERL_ARGS_ASSERT_SV_DOES_SV; 194 PERL_UNUSED_ARG(flags); 195 196 ENTER; 197 SAVETMPS; 198 199 SvGETMAGIC(sv); 200 201 if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv)))) { 202 LEAVE; 203 return FALSE; 204 } 205 206 if (sv_isobject(sv)) { 207 classname = sv_ref(NULL,SvRV(sv),TRUE); 208 } else { 209 classname = sv; 210 } 211 212 if (sv_eq(classname, namesv)) { 213 LEAVE; 214 return TRUE; 215 } 216 217 PUSHMARK(SP); 218 EXTEND(SP, 2); 219 PUSHs(sv); 220 PUSHs(namesv); 221 PUTBACK; 222 223 methodname = newSVpvs_flags("isa", SVs_TEMP); 224 /* ugly hack: use the SvSCREAM flag so S_method_common 225 * can figure out we're calling DOES() and not isa(), 226 * and report eventual errors correctly. --rgs */ 227 SvSCREAM_on(methodname); 228 call_sv(methodname, G_SCALAR | G_METHOD); 229 SPAGAIN; 230 231 does_it = SvTRUE( TOPs ); 232 FREETMPS; 233 LEAVE; 234 235 return does_it; 236 } 237 238 /* 239 =for apidoc sv_does 240 241 Like L</sv_does_pv>, but doesn't take a C<flags> parameter. 242 243 =cut 244 */ 245 246 bool 247 Perl_sv_does(pTHX_ SV *sv, const char *const name) 248 { 249 PERL_ARGS_ASSERT_SV_DOES; 250 return sv_does_sv(sv, newSVpvn_flags(name, strlen(name), SVs_TEMP), 0); 251 } 252 253 /* 254 =for apidoc sv_does_pv 255 256 Like L</sv_does_sv>, but takes a nul-terminated string instead of an SV. 257 258 =cut 259 */ 260 261 262 bool 263 Perl_sv_does_pv(pTHX_ SV *sv, const char *const name, U32 flags) 264 { 265 PERL_ARGS_ASSERT_SV_DOES_PV; 266 return sv_does_sv(sv, newSVpvn_flags(name, strlen(name), SVs_TEMP | flags), flags); 267 } 268 269 /* 270 =for apidoc sv_does_pvn 271 272 Like L</sv_does_sv>, but takes a string/length pair instead of an SV. 273 274 =cut 275 */ 276 277 bool 278 Perl_sv_does_pvn(pTHX_ SV *sv, const char *const name, const STRLEN len, U32 flags) 279 { 280 PERL_ARGS_ASSERT_SV_DOES_PVN; 281 282 return sv_does_sv(sv, newSVpvn_flags(name, len, flags | SVs_TEMP), flags); 283 } 284 285 /* 286 =for apidoc croak_xs_usage 287 288 A specialised variant of C<croak()> for emitting the usage message for xsubs 289 290 croak_xs_usage(cv, "eee_yow"); 291 292 works out the package name and subroutine name from C<cv>, and then calls 293 C<croak()>. Hence if C<cv> is C<&ouch::awk>, it would call C<croak> as: 294 295 Perl_croak(aTHX_ "Usage: %"SVf"::%"SVf"(%s)", "ouch" "awk", "eee_yow"); 296 297 =cut 298 */ 299 300 void 301 Perl_croak_xs_usage(const CV *const cv, const char *const params) 302 { 303 const GV *const gv = CvGV(cv); 304 305 PERL_ARGS_ASSERT_CROAK_XS_USAGE; 306 307 if (gv) { 308 const HV *const stash = GvSTASH(gv); 309 310 if (HvNAME_get(stash)) 311 Perl_croak_nocontext("Usage: %"HEKf"::%"HEKf"(%s)", 312 HEKfARG(HvNAME_HEK(stash)), 313 HEKfARG(GvNAME_HEK(gv)), 314 params); 315 else 316 Perl_croak_nocontext("Usage: %"HEKf"(%s)", 317 HEKfARG(GvNAME_HEK(gv)), params); 318 } else { 319 /* Pants. I don't think that it should be possible to get here. */ 320 Perl_croak_nocontext("Usage: CODE(0x%"UVxf")(%s)", PTR2UV(cv), params); 321 } 322 } 323 324 XS(XS_UNIVERSAL_isa) 325 { 326 dVAR; 327 dXSARGS; 328 329 if (items != 2) 330 croak_xs_usage(cv, "reference, kind"); 331 else { 332 SV * const sv = ST(0); 333 334 SvGETMAGIC(sv); 335 336 if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv)))) 337 XSRETURN_UNDEF; 338 339 ST(0) = boolSV(sv_derived_from_sv(sv, ST(1), 0)); 340 XSRETURN(1); 341 } 342 } 343 344 XS(XS_UNIVERSAL_can) 345 { 346 dVAR; 347 dXSARGS; 348 SV *sv; 349 SV *rv; 350 HV *pkg = NULL; 351 352 if (items != 2) 353 croak_xs_usage(cv, "object-ref, method"); 354 355 sv = ST(0); 356 357 SvGETMAGIC(sv); 358 359 if (!SvOK(sv) || !(SvROK(sv) || SvNIOK(sv) || (SvPOK(sv) && SvCUR(sv)) 360 )) 361 XSRETURN_UNDEF; 362 363 rv = &PL_sv_undef; 364 365 if (SvROK(sv)) { 366 sv = MUTABLE_SV(SvRV(sv)); 367 if (SvOBJECT(sv)) 368 pkg = SvSTASH(sv); 369 } 370 else { 371 pkg = gv_stashsv(sv, 0); 372 if (!pkg) 373 pkg = gv_stashpv("UNIVERSAL", 0); 374 } 375 376 if (pkg) { 377 GV * const gv = gv_fetchmethod_sv_flags(pkg, ST(1), 0); 378 if (gv && isGV(gv)) 379 rv = sv_2mortal(newRV(MUTABLE_SV(GvCV(gv)))); 380 } 381 382 ST(0) = rv; 383 XSRETURN(1); 384 } 385 386 XS(XS_UNIVERSAL_DOES) 387 { 388 dVAR; 389 dXSARGS; 390 PERL_UNUSED_ARG(cv); 391 392 if (items != 2) 393 Perl_croak(aTHX_ "Usage: invocant->DOES(kind)"); 394 else { 395 SV * const sv = ST(0); 396 if (sv_does_sv( sv, ST(1), 0 )) 397 XSRETURN_YES; 398 399 XSRETURN_NO; 400 } 401 } 402 403 XS(XS_UNIVERSAL_VERSION) 404 { 405 dVAR; 406 dXSARGS; 407 HV *pkg; 408 GV **gvp; 409 GV *gv; 410 SV *sv; 411 const char *undef; 412 PERL_UNUSED_ARG(cv); 413 414 if (SvROK(ST(0))) { 415 sv = MUTABLE_SV(SvRV(ST(0))); 416 if (!SvOBJECT(sv)) 417 Perl_croak(aTHX_ "Cannot find version of an unblessed reference"); 418 pkg = SvSTASH(sv); 419 } 420 else { 421 pkg = gv_stashsv(ST(0), 0); 422 } 423 424 gvp = pkg ? (GV**)hv_fetchs(pkg, "VERSION", FALSE) : NULL; 425 426 if (gvp && isGV(gv = *gvp) && (sv = GvSV(gv)) && SvOK(sv)) { 427 SV * const nsv = sv_newmortal(); 428 sv_setsv(nsv, sv); 429 sv = nsv; 430 if ( !sv_isobject(sv) || !sv_derived_from(sv, "version")) 431 upg_version(sv, FALSE); 432 433 undef = NULL; 434 } 435 else { 436 sv = &PL_sv_undef; 437 undef = "(undef)"; 438 } 439 440 if (items > 1) { 441 SV *req = ST(1); 442 443 if (undef) { 444 if (pkg) { 445 const HEK * const name = HvNAME_HEK(pkg); 446 Perl_croak(aTHX_ 447 "%"HEKf" does not define $%"HEKf 448 "::VERSION--version check failed", 449 HEKfARG(name), HEKfARG(name)); 450 } else { 451 Perl_croak(aTHX_ 452 "%"SVf" defines neither package nor VERSION--version check failed", 453 SVfARG(ST(0)) ); 454 } 455 } 456 457 if ( !sv_isobject(req) || !sv_derived_from(req, "version")) { 458 /* req may very well be R/O, so create a new object */ 459 req = sv_2mortal( new_version(req) ); 460 } 461 462 if ( vcmp( req, sv ) > 0 ) { 463 if ( hv_exists(MUTABLE_HV(SvRV(req)), "qv", 2 ) ) { 464 Perl_croak(aTHX_ "%"HEKf" version %"SVf" required--" 465 "this is only version %"SVf"", 466 HEKfARG(HvNAME_HEK(pkg)), 467 SVfARG(sv_2mortal(vnormal(req))), 468 SVfARG(sv_2mortal(vnormal(sv)))); 469 } else { 470 Perl_croak(aTHX_ "%"HEKf" version %"SVf" required--" 471 "this is only version %"SVf, 472 HEKfARG(HvNAME_HEK(pkg)), 473 SVfARG(sv_2mortal(vstringify(req))), 474 SVfARG(sv_2mortal(vstringify(sv)))); 475 } 476 } 477 478 } 479 480 if ( SvOK(sv) && sv_derived_from(sv, "version") ) { 481 ST(0) = sv_2mortal(vstringify(sv)); 482 } else { 483 ST(0) = sv; 484 } 485 486 XSRETURN(1); 487 } 488 489 XS(XS_version_new) 490 { 491 dVAR; 492 dXSARGS; 493 if (items > 3 || items < 1) 494 croak_xs_usage(cv, "class, version"); 495 SP -= items; 496 { 497 SV *vs = ST(1); 498 SV *rv; 499 STRLEN len; 500 const char *classname; 501 U32 flags; 502 if ( sv_isobject(ST(0)) ) { /* get the class if called as an object method */ 503 const HV * stash = SvSTASH(SvRV(ST(0))); 504 classname = HvNAME(stash); 505 len = HvNAMELEN(stash); 506 flags = HvNAMEUTF8(stash) ? SVf_UTF8 : 0; 507 } 508 else { 509 classname = SvPV(ST(0), len); 510 flags = SvUTF8(ST(0)); 511 } 512 513 if ( items == 1 || ! SvOK(vs) ) { /* no param or explicit undef */ 514 /* create empty object */ 515 vs = sv_newmortal(); 516 sv_setpvs(vs, "0"); 517 } 518 else if ( items == 3 ) { 519 vs = sv_newmortal(); 520 Perl_sv_setpvf(aTHX_ vs,"v%s",SvPV_nolen_const(ST(2))); 521 } 522 523 rv = new_version(vs); 524 if ( strnNE(classname,"version", len) ) /* inherited new() */ 525 sv_bless(rv, gv_stashpvn(classname, len, GV_ADD | flags)); 526 527 mPUSHs(rv); 528 PUTBACK; 529 return; 530 } 531 } 532 533 XS(XS_version_stringify) 534 { 535 dVAR; 536 dXSARGS; 537 if (items < 1) 538 croak_xs_usage(cv, "lobj, ..."); 539 SP -= items; 540 { 541 SV * lobj = ST(0); 542 543 if (sv_isobject(lobj) && sv_derived_from(lobj, "version")) { 544 lobj = SvRV(lobj); 545 } 546 else 547 Perl_croak(aTHX_ "lobj is not of type version"); 548 549 mPUSHs(vstringify(lobj)); 550 551 PUTBACK; 552 return; 553 } 554 } 555 556 XS(XS_version_numify) 557 { 558 dVAR; 559 dXSARGS; 560 if (items < 1) 561 croak_xs_usage(cv, "lobj, ..."); 562 SP -= items; 563 { 564 SV * lobj = ST(0); 565 566 if (sv_isobject(lobj) && sv_derived_from(lobj, "version")) { 567 lobj = SvRV(lobj); 568 } 569 else 570 Perl_croak(aTHX_ "lobj is not of type version"); 571 572 mPUSHs(vnumify(lobj)); 573 574 PUTBACK; 575 return; 576 } 577 } 578 579 XS(XS_version_normal) 580 { 581 dVAR; 582 dXSARGS; 583 if (items < 1) 584 croak_xs_usage(cv, "lobj, ..."); 585 SP -= items; 586 { 587 SV * lobj = ST(0); 588 589 if (sv_isobject(lobj) && sv_derived_from(lobj, "version")) { 590 lobj = SvRV(lobj); 591 } 592 else 593 Perl_croak(aTHX_ "lobj is not of type version"); 594 595 mPUSHs(vnormal(lobj)); 596 597 PUTBACK; 598 return; 599 } 600 } 601 602 XS(XS_version_vcmp) 603 { 604 dVAR; 605 dXSARGS; 606 if (items < 1) 607 croak_xs_usage(cv, "lobj, ..."); 608 SP -= items; 609 { 610 SV * lobj = ST(0); 611 612 if (sv_isobject(lobj) && sv_derived_from(lobj, "version")) { 613 lobj = SvRV(lobj); 614 } 615 else 616 Perl_croak(aTHX_ "lobj is not of type version"); 617 618 { 619 SV *rs; 620 SV *rvs; 621 SV * robj = ST(1); 622 const IV swap = (IV)SvIV(ST(2)); 623 624 if ( !sv_isobject(robj) || !sv_derived_from(robj, "version") ) 625 { 626 robj = new_version(SvOK(robj) ? robj : newSVpvs_flags("0", SVs_TEMP)); 627 sv_2mortal(robj); 628 } 629 rvs = SvRV(robj); 630 631 if ( swap ) 632 { 633 rs = newSViv(vcmp(rvs,lobj)); 634 } 635 else 636 { 637 rs = newSViv(vcmp(lobj,rvs)); 638 } 639 640 mPUSHs(rs); 641 } 642 643 PUTBACK; 644 return; 645 } 646 } 647 648 XS(XS_version_boolean) 649 { 650 dVAR; 651 dXSARGS; 652 if (items < 1) 653 croak_xs_usage(cv, "lobj, ..."); 654 SP -= items; 655 if (sv_isobject(ST(0)) && sv_derived_from(ST(0), "version")) { 656 SV * const lobj = SvRV(ST(0)); 657 SV * const rs = 658 newSViv( vcmp(lobj, 659 sv_2mortal(new_version( 660 sv_2mortal(newSVpvs("0")) 661 )) 662 ) 663 ); 664 mPUSHs(rs); 665 PUTBACK; 666 return; 667 } 668 else 669 Perl_croak(aTHX_ "lobj is not of type version"); 670 } 671 672 XS(XS_version_noop) 673 { 674 dVAR; 675 dXSARGS; 676 if (items < 1) 677 croak_xs_usage(cv, "lobj, ..."); 678 if (sv_isobject(ST(0)) && sv_derived_from(ST(0), "version")) 679 Perl_croak(aTHX_ "operation not supported with version object"); 680 else 681 Perl_croak(aTHX_ "lobj is not of type version"); 682 #ifndef HASATTRIBUTE_NORETURN 683 XSRETURN_EMPTY; 684 #endif 685 } 686 687 XS(XS_version_is_alpha) 688 { 689 dVAR; 690 dXSARGS; 691 if (items != 1) 692 croak_xs_usage(cv, "lobj"); 693 SP -= items; 694 if (sv_isobject(ST(0)) && sv_derived_from(ST(0), "version")) { 695 SV * const lobj = ST(0); 696 if ( hv_exists(MUTABLE_HV(SvRV(lobj)), "alpha", 5 ) ) 697 XSRETURN_YES; 698 else 699 XSRETURN_NO; 700 PUTBACK; 701 return; 702 } 703 else 704 Perl_croak(aTHX_ "lobj is not of type version"); 705 } 706 707 XS(XS_version_qv) 708 { 709 dVAR; 710 dXSARGS; 711 PERL_UNUSED_ARG(cv); 712 SP -= items; 713 { 714 SV * ver = ST(0); 715 SV * rv; 716 STRLEN len = 0; 717 const char * classname = ""; 718 U32 flags = 0; 719 if ( items == 2 && SvOK(ST(1)) ) { 720 ver = ST(1); 721 if ( sv_isobject(ST(0)) ) { /* class called as an object method */ 722 const HV * stash = SvSTASH(SvRV(ST(0))); 723 classname = HvNAME(stash); 724 len = HvNAMELEN(stash); 725 flags = HvNAMEUTF8(stash) ? SVf_UTF8 : 0; 726 } 727 else { 728 classname = SvPV(ST(0), len); 729 flags = SvUTF8(ST(0)); 730 } 731 } 732 if ( !SvVOK(ver) ) { /* not already a v-string */ 733 rv = sv_newmortal(); 734 sv_setsv(rv,ver); /* make a duplicate */ 735 upg_version(rv, TRUE); 736 } else { 737 rv = sv_2mortal(new_version(ver)); 738 } 739 if ( items == 2 740 && strnNE(classname,"version", len) ) { /* inherited new() */ 741 sv_bless(rv, gv_stashpvn(classname, len, GV_ADD | flags)); 742 } 743 PUSHs(rv); 744 } 745 PUTBACK; 746 return; 747 } 748 749 XS(XS_version_is_qv) 750 { 751 dVAR; 752 dXSARGS; 753 if (items != 1) 754 croak_xs_usage(cv, "lobj"); 755 SP -= items; 756 if (sv_isobject(ST(0)) && sv_derived_from(ST(0), "version")) { 757 SV * const lobj = ST(0); 758 if ( hv_exists(MUTABLE_HV(SvRV(lobj)), "qv", 2 ) ) 759 XSRETURN_YES; 760 else 761 XSRETURN_NO; 762 PUTBACK; 763 return; 764 } 765 else 766 Perl_croak(aTHX_ "lobj is not of type version"); 767 } 768 769 XS(XS_utf8_is_utf8) 770 { 771 dVAR; 772 dXSARGS; 773 if (items != 1) 774 croak_xs_usage(cv, "sv"); 775 else { 776 SV * const sv = ST(0); 777 SvGETMAGIC(sv); 778 if (SvUTF8(sv)) 779 XSRETURN_YES; 780 else 781 XSRETURN_NO; 782 } 783 XSRETURN_EMPTY; 784 } 785 786 XS(XS_utf8_valid) 787 { 788 dVAR; 789 dXSARGS; 790 if (items != 1) 791 croak_xs_usage(cv, "sv"); 792 else { 793 SV * const sv = ST(0); 794 STRLEN len; 795 const char * const s = SvPV_const(sv,len); 796 if (!SvUTF8(sv) || is_utf8_string((const U8*)s,len)) 797 XSRETURN_YES; 798 else 799 XSRETURN_NO; 800 } 801 XSRETURN_EMPTY; 802 } 803 804 XS(XS_utf8_encode) 805 { 806 dVAR; 807 dXSARGS; 808 if (items != 1) 809 croak_xs_usage(cv, "sv"); 810 sv_utf8_encode(ST(0)); 811 SvSETMAGIC(ST(0)); 812 XSRETURN_EMPTY; 813 } 814 815 XS(XS_utf8_decode) 816 { 817 dVAR; 818 dXSARGS; 819 if (items != 1) 820 croak_xs_usage(cv, "sv"); 821 else { 822 SV * const sv = ST(0); 823 bool RETVAL; 824 SvPV_force_nolen(sv); 825 RETVAL = sv_utf8_decode(sv); 826 SvSETMAGIC(sv); 827 ST(0) = boolSV(RETVAL); 828 } 829 XSRETURN(1); 830 } 831 832 XS(XS_utf8_upgrade) 833 { 834 dVAR; 835 dXSARGS; 836 if (items != 1) 837 croak_xs_usage(cv, "sv"); 838 else { 839 SV * const sv = ST(0); 840 STRLEN RETVAL; 841 dXSTARG; 842 843 RETVAL = sv_utf8_upgrade(sv); 844 XSprePUSH; PUSHi((IV)RETVAL); 845 } 846 XSRETURN(1); 847 } 848 849 XS(XS_utf8_downgrade) 850 { 851 dVAR; 852 dXSARGS; 853 if (items < 1 || items > 2) 854 croak_xs_usage(cv, "sv, failok=0"); 855 else { 856 SV * const sv = ST(0); 857 const bool failok = (items < 2) ? 0 : (int)SvIV(ST(1)); 858 const bool RETVAL = sv_utf8_downgrade(sv, failok); 859 860 ST(0) = boolSV(RETVAL); 861 } 862 XSRETURN(1); 863 } 864 865 XS(XS_utf8_native_to_unicode) 866 { 867 dVAR; 868 dXSARGS; 869 const UV uv = SvUV(ST(0)); 870 871 if (items > 1) 872 croak_xs_usage(cv, "sv"); 873 874 ST(0) = sv_2mortal(newSViv(NATIVE_TO_UNI(uv))); 875 XSRETURN(1); 876 } 877 878 XS(XS_utf8_unicode_to_native) 879 { 880 dVAR; 881 dXSARGS; 882 const UV uv = SvUV(ST(0)); 883 884 if (items > 1) 885 croak_xs_usage(cv, "sv"); 886 887 ST(0) = sv_2mortal(newSViv(UNI_TO_NATIVE(uv))); 888 XSRETURN(1); 889 } 890 891 XS(XS_Internals_SvREADONLY) /* This is dangerous stuff. */ 892 { 893 dVAR; 894 dXSARGS; 895 SV * const svz = ST(0); 896 SV * sv; 897 PERL_UNUSED_ARG(cv); 898 899 /* [perl #77776] - called as &foo() not foo() */ 900 if (!SvROK(svz)) 901 croak_xs_usage(cv, "SCALAR[, ON]"); 902 903 sv = SvRV(svz); 904 905 if (items == 1) { 906 if (SvREADONLY(sv) && !SvIsCOW(sv)) 907 XSRETURN_YES; 908 else 909 XSRETURN_NO; 910 } 911 else if (items == 2) { 912 if (SvTRUE(ST(1))) { 913 if (SvIsCOW(sv)) sv_force_normal(sv); 914 SvREADONLY_on(sv); 915 XSRETURN_YES; 916 } 917 else { 918 /* I hope you really know what you are doing. */ 919 if (!SvIsCOW(sv)) SvREADONLY_off(sv); 920 XSRETURN_NO; 921 } 922 } 923 XSRETURN_UNDEF; /* Can't happen. */ 924 } 925 XS(XS_Internals_SvREFCNT) /* This is dangerous stuff. */ 926 { 927 dVAR; 928 dXSARGS; 929 SV * const svz = ST(0); 930 SV * sv; 931 U32 refcnt; 932 PERL_UNUSED_ARG(cv); 933 934 /* [perl #77776] - called as &foo() not foo() */ 935 if ((items != 1 && items != 2) || !SvROK(svz)) 936 croak_xs_usage(cv, "SCALAR[, REFCOUNT]"); 937 938 sv = SvRV(svz); 939 940 /* I hope you really know what you are doing. */ 941 /* idea is for SvREFCNT(sv) to be accessed only once */ 942 refcnt = items == 2 ? 943 /* we free one ref on exit */ 944 (SvREFCNT(sv) = SvUV(ST(1)) + 1) 945 : SvREFCNT(sv); 946 XSRETURN_UV(refcnt - 1); /* Minus the ref created for us. */ 947 948 } 949 950 XS(XS_Internals_hv_clear_placehold) 951 { 952 dVAR; 953 dXSARGS; 954 955 if (items != 1 || !SvROK(ST(0))) 956 croak_xs_usage(cv, "hv"); 957 else { 958 HV * const hv = MUTABLE_HV(SvRV(ST(0))); 959 hv_clear_placeholders(hv); 960 XSRETURN(0); 961 } 962 } 963 964 XS(XS_PerlIO_get_layers) 965 { 966 dVAR; 967 dXSARGS; 968 if (items < 1 || items % 2 == 0) 969 croak_xs_usage(cv, "filehandle[,args]"); 970 #ifdef USE_PERLIO 971 { 972 SV * sv; 973 GV * gv; 974 IO * io; 975 bool input = TRUE; 976 bool details = FALSE; 977 978 if (items > 1) { 979 SV * const *svp; 980 for (svp = MARK + 2; svp <= SP; svp += 2) { 981 SV * const * const varp = svp; 982 SV * const * const valp = svp + 1; 983 STRLEN klen; 984 const char * const key = SvPV_const(*varp, klen); 985 986 switch (*key) { 987 case 'i': 988 if (klen == 5 && memEQ(key, "input", 5)) { 989 input = SvTRUE(*valp); 990 break; 991 } 992 goto fail; 993 case 'o': 994 if (klen == 6 && memEQ(key, "output", 6)) { 995 input = !SvTRUE(*valp); 996 break; 997 } 998 goto fail; 999 case 'd': 1000 if (klen == 7 && memEQ(key, "details", 7)) { 1001 details = SvTRUE(*valp); 1002 break; 1003 } 1004 goto fail; 1005 default: 1006 fail: 1007 Perl_croak(aTHX_ 1008 "get_layers: unknown argument '%s'", 1009 key); 1010 } 1011 } 1012 1013 SP -= (items - 1); 1014 } 1015 1016 sv = POPs; 1017 gv = MAYBE_DEREF_GV(sv); 1018 1019 if (!gv && !SvROK(sv)) 1020 gv = gv_fetchsv_nomg(sv, 0, SVt_PVIO); 1021 1022 if (gv && (io = GvIO(gv))) { 1023 AV* const av = PerlIO_get_layers(aTHX_ input ? 1024 IoIFP(io) : IoOFP(io)); 1025 I32 i; 1026 const I32 last = av_len(av); 1027 I32 nitem = 0; 1028 1029 for (i = last; i >= 0; i -= 3) { 1030 SV * const * const namsvp = av_fetch(av, i - 2, FALSE); 1031 SV * const * const argsvp = av_fetch(av, i - 1, FALSE); 1032 SV * const * const flgsvp = av_fetch(av, i, FALSE); 1033 1034 const bool namok = namsvp && *namsvp && SvPOK(*namsvp); 1035 const bool argok = argsvp && *argsvp && SvPOK(*argsvp); 1036 const bool flgok = flgsvp && *flgsvp && SvIOK(*flgsvp); 1037 1038 EXTEND(SP, 3); /* Three is the max in all branches: better check just once */ 1039 if (details) { 1040 /* Indents of 5? Yuck. */ 1041 /* We know that PerlIO_get_layers creates a new SV for 1042 the name and flags, so we can just take a reference 1043 and "steal" it when we free the AV below. */ 1044 PUSHs(namok 1045 ? sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp)) 1046 : &PL_sv_undef); 1047 PUSHs(argok 1048 ? newSVpvn_flags(SvPVX_const(*argsvp), 1049 SvCUR(*argsvp), 1050 (SvUTF8(*argsvp) ? SVf_UTF8 : 0) 1051 | SVs_TEMP) 1052 : &PL_sv_undef); 1053 PUSHs(flgok 1054 ? sv_2mortal(SvREFCNT_inc_simple_NN(*flgsvp)) 1055 : &PL_sv_undef); 1056 nitem += 3; 1057 } 1058 else { 1059 if (namok && argok) 1060 PUSHs(sv_2mortal(Perl_newSVpvf(aTHX_ "%"SVf"(%"SVf")", 1061 SVfARG(*namsvp), 1062 SVfARG(*argsvp)))); 1063 else if (namok) 1064 PUSHs(sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp))); 1065 else 1066 PUSHs(&PL_sv_undef); 1067 nitem++; 1068 if (flgok) { 1069 const IV flags = SvIVX(*flgsvp); 1070 1071 if (flags & PERLIO_F_UTF8) { 1072 PUSHs(newSVpvs_flags("utf8", SVs_TEMP)); 1073 nitem++; 1074 } 1075 } 1076 } 1077 } 1078 1079 SvREFCNT_dec(av); 1080 1081 XSRETURN(nitem); 1082 } 1083 } 1084 #endif 1085 1086 XSRETURN(0); 1087 } 1088 1089 1090 XS(XS_re_is_regexp) 1091 { 1092 dVAR; 1093 dXSARGS; 1094 PERL_UNUSED_VAR(cv); 1095 1096 if (items != 1) 1097 croak_xs_usage(cv, "sv"); 1098 1099 if (SvRXOK(ST(0))) { 1100 XSRETURN_YES; 1101 } else { 1102 XSRETURN_NO; 1103 } 1104 } 1105 1106 XS(XS_re_regnames_count) 1107 { 1108 REGEXP *rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL; 1109 SV * ret; 1110 dVAR; 1111 dXSARGS; 1112 1113 if (items != 0) 1114 croak_xs_usage(cv, ""); 1115 1116 SP -= items; 1117 PUTBACK; 1118 1119 if (!rx) 1120 XSRETURN_UNDEF; 1121 1122 ret = CALLREG_NAMED_BUFF_COUNT(rx); 1123 1124 SPAGAIN; 1125 PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef); 1126 XSRETURN(1); 1127 } 1128 1129 XS(XS_re_regname) 1130 { 1131 dVAR; 1132 dXSARGS; 1133 REGEXP * rx; 1134 U32 flags; 1135 SV * ret; 1136 1137 if (items < 1 || items > 2) 1138 croak_xs_usage(cv, "name[, all ]"); 1139 1140 SP -= items; 1141 PUTBACK; 1142 1143 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL; 1144 1145 if (!rx) 1146 XSRETURN_UNDEF; 1147 1148 if (items == 2 && SvTRUE(ST(1))) { 1149 flags = RXapif_ALL; 1150 } else { 1151 flags = RXapif_ONE; 1152 } 1153 ret = CALLREG_NAMED_BUFF_FETCH(rx, ST(0), (flags | RXapif_REGNAME)); 1154 1155 SPAGAIN; 1156 PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef); 1157 XSRETURN(1); 1158 } 1159 1160 1161 XS(XS_re_regnames) 1162 { 1163 dVAR; 1164 dXSARGS; 1165 REGEXP * rx; 1166 U32 flags; 1167 SV *ret; 1168 AV *av; 1169 I32 length; 1170 I32 i; 1171 SV **entry; 1172 1173 if (items > 1) 1174 croak_xs_usage(cv, "[all]"); 1175 1176 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL; 1177 1178 if (!rx) 1179 XSRETURN_UNDEF; 1180 1181 if (items == 1 && SvTRUE(ST(0))) { 1182 flags = RXapif_ALL; 1183 } else { 1184 flags = RXapif_ONE; 1185 } 1186 1187 SP -= items; 1188 PUTBACK; 1189 1190 ret = CALLREG_NAMED_BUFF_ALL(rx, (flags | RXapif_REGNAMES)); 1191 1192 SPAGAIN; 1193 1194 if (!ret) 1195 XSRETURN_UNDEF; 1196 1197 av = MUTABLE_AV(SvRV(ret)); 1198 length = av_len(av); 1199 1200 EXTEND(SP, length+1); /* better extend stack just once */ 1201 for (i = 0; i <= length; i++) { 1202 entry = av_fetch(av, i, FALSE); 1203 1204 if (!entry) 1205 Perl_croak(aTHX_ "NULL array element in re::regnames()"); 1206 1207 mPUSHs(SvREFCNT_inc_simple_NN(*entry)); 1208 } 1209 1210 SvREFCNT_dec(ret); 1211 1212 PUTBACK; 1213 return; 1214 } 1215 1216 XS(XS_re_regexp_pattern) 1217 { 1218 dVAR; 1219 dXSARGS; 1220 REGEXP *re; 1221 1222 EXTEND(SP, 2); 1223 SP -= items; 1224 if (items != 1) 1225 croak_xs_usage(cv, "sv"); 1226 1227 /* 1228 Checks if a reference is a regex or not. If the parameter is 1229 not a ref, or is not the result of a qr// then returns false 1230 in scalar context and an empty list in list context. 1231 Otherwise in list context it returns the pattern and the 1232 modifiers, in scalar context it returns the pattern just as it 1233 would if the qr// was stringified normally, regardless as 1234 to the class of the variable and any stringification overloads 1235 on the object. 1236 */ 1237 1238 if ((re = SvRX(ST(0)))) /* assign deliberate */ 1239 { 1240 /* Houston, we have a regex! */ 1241 SV *pattern; 1242 1243 if ( GIMME_V == G_ARRAY ) { 1244 STRLEN left = 0; 1245 char reflags[sizeof(INT_PAT_MODS) + MAX_CHARSET_NAME_LENGTH]; 1246 const char *fptr; 1247 char ch; 1248 U16 match_flags; 1249 1250 /* 1251 we are in list context so stringify 1252 the modifiers that apply. We ignore "negative 1253 modifiers" in this scenario, and the default character set 1254 */ 1255 1256 if (get_regex_charset(RX_EXTFLAGS(re)) != REGEX_DEPENDS_CHARSET) { 1257 STRLEN len; 1258 const char* const name = get_regex_charset_name(RX_EXTFLAGS(re), 1259 &len); 1260 Copy(name, reflags + left, len, char); 1261 left += len; 1262 } 1263 fptr = INT_PAT_MODS; 1264 match_flags = (U16)((RX_EXTFLAGS(re) & RXf_PMf_COMPILETIME) 1265 >> RXf_PMf_STD_PMMOD_SHIFT); 1266 1267 while((ch = *fptr++)) { 1268 if(match_flags & 1) { 1269 reflags[left++] = ch; 1270 } 1271 match_flags >>= 1; 1272 } 1273 1274 pattern = newSVpvn_flags(RX_PRECOMP(re),RX_PRELEN(re), 1275 (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP); 1276 1277 /* return the pattern and the modifiers */ 1278 PUSHs(pattern); 1279 PUSHs(newSVpvn_flags(reflags, left, SVs_TEMP)); 1280 XSRETURN(2); 1281 } else { 1282 /* Scalar, so use the string that Perl would return */ 1283 /* return the pattern in (?msix:..) format */ 1284 #if PERL_VERSION >= 11 1285 pattern = sv_2mortal(newSVsv(MUTABLE_SV(re))); 1286 #else 1287 pattern = newSVpvn_flags(RX_WRAPPED(re), RX_WRAPLEN(re), 1288 (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP); 1289 #endif 1290 PUSHs(pattern); 1291 XSRETURN(1); 1292 } 1293 } else { 1294 /* It ain't a regexp folks */ 1295 if ( GIMME_V == G_ARRAY ) { 1296 /* return the empty list */ 1297 XSRETURN_UNDEF; 1298 } else { 1299 /* Because of the (?:..) wrapping involved in a 1300 stringified pattern it is impossible to get a 1301 result for a real regexp that would evaluate to 1302 false. Therefore we can return PL_sv_no to signify 1303 that the object is not a regex, this means that one 1304 can say 1305 1306 if (regex($might_be_a_regex) eq '(?:foo)') { } 1307 1308 and not worry about undefined values. 1309 */ 1310 XSRETURN_NO; 1311 } 1312 } 1313 /* NOT-REACHED */ 1314 } 1315 1316 struct xsub_details { 1317 const char *name; 1318 XSUBADDR_t xsub; 1319 const char *proto; 1320 }; 1321 1322 const struct xsub_details details[] = { 1323 {"UNIVERSAL::isa", XS_UNIVERSAL_isa, NULL}, 1324 {"UNIVERSAL::can", XS_UNIVERSAL_can, NULL}, 1325 {"UNIVERSAL::DOES", XS_UNIVERSAL_DOES, NULL}, 1326 {"UNIVERSAL::VERSION", XS_UNIVERSAL_VERSION, NULL}, 1327 {"version::()", XS_version_noop, NULL}, 1328 {"version::new", XS_version_new, NULL}, 1329 {"version::parse", XS_version_new, NULL}, 1330 {"version::(\"\"", XS_version_stringify, NULL}, 1331 {"version::stringify", XS_version_stringify, NULL}, 1332 {"version::(0+", XS_version_numify, NULL}, 1333 {"version::numify", XS_version_numify, NULL}, 1334 {"version::normal", XS_version_normal, NULL}, 1335 {"version::(cmp", XS_version_vcmp, NULL}, 1336 {"version::(<=>", XS_version_vcmp, NULL}, 1337 {"version::vcmp", XS_version_vcmp, NULL}, 1338 {"version::(bool", XS_version_boolean, NULL}, 1339 {"version::boolean", XS_version_boolean, NULL}, 1340 {"version::(+", XS_version_noop, NULL}, 1341 {"version::(-", XS_version_noop, NULL}, 1342 {"version::(*", XS_version_noop, NULL}, 1343 {"version::(/", XS_version_noop, NULL}, 1344 {"version::(+=", XS_version_noop, NULL}, 1345 {"version::(-=", XS_version_noop, NULL}, 1346 {"version::(*=", XS_version_noop, NULL}, 1347 {"version::(/=", XS_version_noop, NULL}, 1348 {"version::(abs", XS_version_noop, NULL}, 1349 {"version::(nomethod", XS_version_noop, NULL}, 1350 {"version::noop", XS_version_noop, NULL}, 1351 {"version::is_alpha", XS_version_is_alpha, NULL}, 1352 {"version::qv", XS_version_qv, NULL}, 1353 {"version::declare", XS_version_qv, NULL}, 1354 {"version::is_qv", XS_version_is_qv, NULL}, 1355 {"utf8::is_utf8", XS_utf8_is_utf8, NULL}, 1356 {"utf8::valid", XS_utf8_valid, NULL}, 1357 {"utf8::encode", XS_utf8_encode, NULL}, 1358 {"utf8::decode", XS_utf8_decode, NULL}, 1359 {"utf8::upgrade", XS_utf8_upgrade, NULL}, 1360 {"utf8::downgrade", XS_utf8_downgrade, NULL}, 1361 {"utf8::native_to_unicode", XS_utf8_native_to_unicode, NULL}, 1362 {"utf8::unicode_to_native", XS_utf8_unicode_to_native, NULL}, 1363 {"Internals::SvREADONLY", XS_Internals_SvREADONLY, "\\[$%@];$"}, 1364 {"Internals::SvREFCNT", XS_Internals_SvREFCNT, "\\[$%@];$"}, 1365 {"Internals::hv_clear_placeholders", XS_Internals_hv_clear_placehold, "\\%"}, 1366 {"PerlIO::get_layers", XS_PerlIO_get_layers, "*;@"}, 1367 {"re::is_regexp", XS_re_is_regexp, "$"}, 1368 {"re::regname", XS_re_regname, ";$$"}, 1369 {"re::regnames", XS_re_regnames, ";$"}, 1370 {"re::regnames_count", XS_re_regnames_count, ""}, 1371 {"re::regexp_pattern", XS_re_regexp_pattern, "$"}, 1372 }; 1373 1374 void 1375 Perl_boot_core_UNIVERSAL(pTHX) 1376 { 1377 dVAR; 1378 static const char file[] = __FILE__; 1379 const struct xsub_details *xsub = details; 1380 const struct xsub_details *end 1381 = details + sizeof(details) / sizeof(details[0]); 1382 1383 do { 1384 newXS_flags(xsub->name, xsub->xsub, file, xsub->proto, 0); 1385 } while (++xsub < end); 1386 1387 /* Providing a Regexp::DESTROY fixes #21347. See test in t/op/ref.t */ 1388 { 1389 CV * const cv = 1390 newCONSTSUB(get_hv("Regexp::", GV_ADD), "DESTROY", NULL); 1391 Safefree(CvFILE(cv)); 1392 CvFILE(cv) = (char *)file; 1393 CvDYNFILE_off(cv); 1394 } 1395 } 1396 1397 /* 1398 * Local variables: 1399 * c-indentation-style: bsd 1400 * c-basic-offset: 4 1401 * indent-tabs-mode: nil 1402 * End: 1403 * 1404 * ex: set ts=8 sts=4 sw=4 et: 1405 */ 1406