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