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 Perl_croak(aTHX_ "Usage: %" SVf "::%" SVf "(%s)", "ouch" "awk", 401 "eee_yow"); 402 403 =cut 404 */ 405 406 void 407 Perl_croak_xs_usage(const CV *const cv, const char *const params) 408 { 409 /* Avoid CvGV as it requires aTHX. */ 410 const GV *gv = CvNAMED(cv) ? NULL : cv->sv_any->xcv_gv_u.xcv_gv; 411 412 PERL_ARGS_ASSERT_CROAK_XS_USAGE; 413 414 if (gv) got_gv: { 415 const HV *const stash = GvSTASH(gv); 416 417 if (HvNAME_get(stash)) 418 /* diag_listed_as: SKIPME */ 419 Perl_croak_nocontext("Usage: %" HEKf "::%" HEKf "(%s)", 420 HEKfARG(HvNAME_HEK(stash)), 421 HEKfARG(GvNAME_HEK(gv)), 422 params); 423 else 424 /* diag_listed_as: SKIPME */ 425 Perl_croak_nocontext("Usage: %" HEKf "(%s)", 426 HEKfARG(GvNAME_HEK(gv)), params); 427 } else { 428 dTHX; 429 if ((gv = CvGV(cv))) goto got_gv; 430 431 /* Pants. I don't think that it should be possible to get here. */ 432 /* diag_listed_as: SKIPME */ 433 Perl_croak(aTHX_ "Usage: CODE(0x%" UVxf ")(%s)", PTR2UV(cv), params); 434 } 435 } 436 437 XS(XS_UNIVERSAL_isa); /* prototype to pass -Wmissing-prototypes */ 438 XS(XS_UNIVERSAL_isa) 439 { 440 dXSARGS; 441 442 if (items != 2) 443 croak_xs_usage(cv, "reference, kind"); 444 else { 445 SV * const sv = ST(0); 446 447 SvGETMAGIC(sv); 448 449 if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv)))) 450 XSRETURN_UNDEF; 451 452 ST(0) = boolSV(sv_derived_from_sv(sv, ST(1), 0)); 453 XSRETURN(1); 454 } 455 } 456 457 XS(XS_UNIVERSAL_can); /* prototype to pass -Wmissing-prototypes */ 458 XS(XS_UNIVERSAL_can) 459 { 460 dXSARGS; 461 SV *sv; 462 SV *rv; 463 HV *pkg = NULL; 464 GV *iogv; 465 466 if (items != 2) 467 croak_xs_usage(cv, "object-ref, method"); 468 469 sv = ST(0); 470 471 SvGETMAGIC(sv); 472 473 /* Reject undef and empty string. Note that the string form takes 474 precedence here over the numeric form, as (!1)->foo treats the 475 invocant as the empty string, though it is a dualvar. */ 476 if (!SvOK(sv) || (SvPOK(sv) && !SvCUR(sv))) 477 XSRETURN_UNDEF; 478 479 rv = &PL_sv_undef; 480 481 if (SvROK(sv)) { 482 sv = MUTABLE_SV(SvRV(sv)); 483 if (SvOBJECT(sv)) 484 pkg = SvSTASH(sv); 485 else if (isGV_with_GP(sv) && GvIO(sv)) 486 pkg = SvSTASH(GvIO(sv)); 487 } 488 else if (isGV_with_GP(sv) && GvIO(sv)) 489 pkg = SvSTASH(GvIO(sv)); 490 else if ((iogv = gv_fetchsv_nomg(sv, 0, SVt_PVIO)) && GvIO(iogv)) 491 pkg = SvSTASH(GvIO(iogv)); 492 else { 493 pkg = gv_stashsv(sv, 0); 494 if (!pkg) 495 pkg = gv_stashpvs("UNIVERSAL", 0); 496 } 497 498 if (pkg) { 499 GV * const gv = gv_fetchmethod_sv_flags(pkg, ST(1), 0); 500 if (gv && isGV(gv)) 501 rv = sv_2mortal(newRV(MUTABLE_SV(GvCV(gv)))); 502 } 503 504 ST(0) = rv; 505 XSRETURN(1); 506 } 507 508 XS(XS_UNIVERSAL_DOES); /* prototype to pass -Wmissing-prototypes */ 509 XS(XS_UNIVERSAL_DOES) 510 { 511 dXSARGS; 512 PERL_UNUSED_ARG(cv); 513 514 if (items != 2) 515 Perl_croak(aTHX_ "Usage: invocant->DOES(kind)"); 516 else { 517 SV * const sv = ST(0); 518 if (sv_does_sv( sv, ST(1), 0 )) 519 XSRETURN_YES; 520 521 XSRETURN_NO; 522 } 523 } 524 525 XS(XS_utf8_is_utf8); /* prototype to pass -Wmissing-prototypes */ 526 XS(XS_utf8_is_utf8) 527 { 528 dXSARGS; 529 if (items != 1) 530 croak_xs_usage(cv, "sv"); 531 else { 532 SV * const sv = ST(0); 533 SvGETMAGIC(sv); 534 if (SvUTF8(sv)) 535 XSRETURN_YES; 536 else 537 XSRETURN_NO; 538 } 539 XSRETURN_EMPTY; 540 } 541 542 XS(XS_utf8_valid); /* prototype to pass -Wmissing-prototypes */ 543 XS(XS_utf8_valid) 544 { 545 dXSARGS; 546 if (items != 1) 547 croak_xs_usage(cv, "sv"); 548 else { 549 SV * const sv = ST(0); 550 STRLEN len; 551 const char * const s = SvPV_const(sv,len); 552 if (!SvUTF8(sv) || is_utf8_string((const U8*)s,len)) 553 XSRETURN_YES; 554 else 555 XSRETURN_NO; 556 } 557 XSRETURN_EMPTY; 558 } 559 560 XS(XS_utf8_encode); /* prototype to pass -Wmissing-prototypes */ 561 XS(XS_utf8_encode) 562 { 563 dXSARGS; 564 if (items != 1) 565 croak_xs_usage(cv, "sv"); 566 sv_utf8_encode(ST(0)); 567 SvSETMAGIC(ST(0)); 568 XSRETURN_EMPTY; 569 } 570 571 XS(XS_utf8_decode); /* prototype to pass -Wmissing-prototypes */ 572 XS(XS_utf8_decode) 573 { 574 dXSARGS; 575 if (items != 1) 576 croak_xs_usage(cv, "sv"); 577 else { 578 SV * const sv = ST(0); 579 bool RETVAL; 580 SvPV_force_nolen(sv); 581 RETVAL = sv_utf8_decode(sv); 582 SvSETMAGIC(sv); 583 ST(0) = boolSV(RETVAL); 584 } 585 XSRETURN(1); 586 } 587 588 XS(XS_utf8_upgrade); /* prototype to pass -Wmissing-prototypes */ 589 XS(XS_utf8_upgrade) 590 { 591 dXSARGS; 592 if (items != 1) 593 croak_xs_usage(cv, "sv"); 594 else { 595 SV * const sv = ST(0); 596 STRLEN RETVAL = 0; 597 dXSTARG; 598 599 XSprePUSH; 600 if (UNLIKELY(! sv)) { 601 XSRETURN_UNDEF; 602 } 603 604 SvGETMAGIC(sv); 605 if (UNLIKELY(! SvOK(sv))) { 606 XSRETURN_UNDEF; 607 } 608 609 RETVAL = sv_utf8_upgrade_nomg(sv); 610 PUSHi( (IV) RETVAL); 611 } 612 XSRETURN(1); 613 } 614 615 XS(XS_utf8_downgrade); /* prototype to pass -Wmissing-prototypes */ 616 XS(XS_utf8_downgrade) 617 { 618 dXSARGS; 619 if (items < 1 || items > 2) 620 croak_xs_usage(cv, "sv, failok=0"); 621 else { 622 SV * const sv0 = ST(0); 623 SV * const sv1 = ST(1); 624 const bool failok = (items < 2) ? 0 : SvTRUE_NN(sv1) ? 1 : 0; 625 const bool RETVAL = sv_utf8_downgrade(sv0, failok); 626 627 ST(0) = boolSV(RETVAL); 628 } 629 XSRETURN(1); 630 } 631 632 XS(XS_utf8_native_to_unicode); /* prototype to pass -Wmissing-prototypes */ 633 XS(XS_utf8_native_to_unicode) 634 { 635 dXSARGS; 636 const UV uv = SvUV(ST(0)); 637 638 if (items > 1) 639 croak_xs_usage(cv, "sv"); 640 641 ST(0) = sv_2mortal(newSVuv(NATIVE_TO_UNI(uv))); 642 XSRETURN(1); 643 } 644 645 XS(XS_utf8_unicode_to_native); /* prototype to pass -Wmissing-prototypes */ 646 XS(XS_utf8_unicode_to_native) 647 { 648 dXSARGS; 649 const UV uv = SvUV(ST(0)); 650 651 if (items > 1) 652 croak_xs_usage(cv, "sv"); 653 654 ST(0) = sv_2mortal(newSVuv(UNI_TO_NATIVE(uv))); 655 XSRETURN(1); 656 } 657 658 XS(XS_Internals_SvREADONLY); /* prototype to pass -Wmissing-prototypes */ 659 XS(XS_Internals_SvREADONLY) /* This is dangerous stuff. */ 660 { 661 dXSARGS; 662 SV * const svz = ST(0); 663 SV * sv; 664 665 /* [perl #77776] - called as &foo() not foo() */ 666 if (!SvROK(svz)) 667 croak_xs_usage(cv, "SCALAR[, ON]"); 668 669 sv = SvRV(svz); 670 671 if (items == 1) { 672 if (SvREADONLY(sv)) 673 XSRETURN_YES; 674 else 675 XSRETURN_NO; 676 } 677 else if (items == 2) { 678 SV *sv1 = ST(1); 679 if (SvTRUE_NN(sv1)) { 680 SvFLAGS(sv) |= SVf_READONLY; 681 XSRETURN_YES; 682 } 683 else { 684 /* I hope you really know what you are doing. */ 685 SvFLAGS(sv) &=~ SVf_READONLY; 686 XSRETURN_NO; 687 } 688 } 689 XSRETURN_UNDEF; /* Can't happen. */ 690 } 691 692 XS(XS_constant__make_const); /* prototype to pass -Wmissing-prototypes */ 693 XS(XS_constant__make_const) /* This is dangerous stuff. */ 694 { 695 dXSARGS; 696 SV * const svz = ST(0); 697 SV * sv; 698 699 /* [perl #77776] - called as &foo() not foo() */ 700 if (!SvROK(svz) || items != 1) 701 croak_xs_usage(cv, "SCALAR"); 702 703 sv = SvRV(svz); 704 705 SvREADONLY_on(sv); 706 if (SvTYPE(sv) == SVt_PVAV && AvFILLp(sv) != -1) { 707 /* for constant.pm; nobody else should be calling this 708 on arrays anyway. */ 709 SV **svp; 710 for (svp = AvARRAY(sv) + AvFILLp(sv) 711 ; svp >= AvARRAY(sv) 712 ; --svp) 713 if (*svp) SvPADTMP_on(*svp); 714 } 715 XSRETURN(0); 716 } 717 718 XS(XS_Internals_SvREFCNT); /* prototype to pass -Wmissing-prototypes */ 719 XS(XS_Internals_SvREFCNT) /* This is dangerous stuff. */ 720 { 721 dXSARGS; 722 SV * const svz = ST(0); 723 SV * sv; 724 U32 refcnt; 725 726 /* [perl #77776] - called as &foo() not foo() */ 727 if ((items != 1 && items != 2) || !SvROK(svz)) 728 croak_xs_usage(cv, "SCALAR[, REFCOUNT]"); 729 730 sv = SvRV(svz); 731 732 /* I hope you really know what you are doing. */ 733 /* idea is for SvREFCNT(sv) to be accessed only once */ 734 refcnt = items == 2 ? 735 /* we free one ref on exit */ 736 (SvREFCNT(sv) = SvUV(ST(1)) + 1) 737 : SvREFCNT(sv); 738 XSRETURN_UV(refcnt - 1); /* Minus the ref created for us. */ 739 740 } 741 742 XS(XS_Internals_hv_clear_placehold); /* prototype to pass -Wmissing-prototypes */ 743 XS(XS_Internals_hv_clear_placehold) 744 { 745 dXSARGS; 746 747 if (items != 1 || !SvROK(ST(0))) 748 croak_xs_usage(cv, "hv"); 749 else { 750 HV * const hv = MUTABLE_HV(SvRV(ST(0))); 751 hv_clear_placeholders(hv); 752 XSRETURN(0); 753 } 754 } 755 756 XS(XS_PerlIO_get_layers); /* prototype to pass -Wmissing-prototypes */ 757 XS(XS_PerlIO_get_layers) 758 { 759 dXSARGS; 760 if (items < 1 || items % 2 == 0) 761 croak_xs_usage(cv, "filehandle[,args]"); 762 #if defined(USE_PERLIO) 763 { 764 SV * sv; 765 GV * gv; 766 IO * io = NULL; 767 bool input = TRUE; 768 bool details = FALSE; 769 770 if (items > 1) { 771 SV * const *svp; 772 for (svp = MARK + 2; svp <= SP; svp += 2) { 773 SV * const * const varp = svp; 774 SV * const * const valp = svp + 1; 775 STRLEN klen; 776 const char * const key = SvPV_const(*varp, klen); 777 778 switch (*key) { 779 case 'i': 780 if (memEQs(key, klen, "input")) { 781 input = SvTRUE(*valp); 782 break; 783 } 784 goto fail; 785 case 'o': 786 if (memEQs(key, klen, "output")) { 787 input = !SvTRUE(*valp); 788 break; 789 } 790 goto fail; 791 case 'd': 792 if (memEQs(key, klen, "details")) { 793 details = SvTRUE(*valp); 794 break; 795 } 796 goto fail; 797 default: 798 fail: 799 Perl_croak(aTHX_ 800 "get_layers: unknown argument '%s'", 801 key); 802 } 803 } 804 805 SP -= (items - 1); 806 } 807 808 sv = POPs; 809 810 /* MAYBE_DEREF_GV will call get magic */ 811 if ((gv = MAYBE_DEREF_GV(sv))) 812 io = GvIO(gv); 813 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) 814 io = (IO*)SvRV(sv); 815 else if (!SvROK(sv) && (gv = gv_fetchsv_nomg(sv, 0, SVt_PVIO))) 816 io = GvIO(gv); 817 818 if (io) { 819 AV* const av = PerlIO_get_layers(aTHX_ input ? 820 IoIFP(io) : IoOFP(io)); 821 SSize_t i; 822 const SSize_t last = av_top_index(av); 823 SSize_t nitem = 0; 824 825 for (i = last; i >= 0; i -= 3) { 826 SV * const * const namsvp = av_fetch(av, i - 2, FALSE); 827 SV * const * const argsvp = av_fetch(av, i - 1, FALSE); 828 SV * const * const flgsvp = av_fetch(av, i, FALSE); 829 830 const bool namok = namsvp && *namsvp && SvPOK(*namsvp); 831 const bool argok = argsvp && *argsvp && SvPOK(*argsvp); 832 const bool flgok = flgsvp && *flgsvp && SvIOK(*flgsvp); 833 834 EXTEND(SP, 3); /* Three is the max in all branches: better check just once */ 835 if (details) { 836 /* Indents of 5? Yuck. */ 837 /* We know that PerlIO_get_layers creates a new SV for 838 the name and flags, so we can just take a reference 839 and "steal" it when we free the AV below. */ 840 PUSHs(namok 841 ? sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp)) 842 : &PL_sv_undef); 843 PUSHs(argok 844 ? newSVpvn_flags(SvPVX_const(*argsvp), 845 SvCUR(*argsvp), 846 (SvUTF8(*argsvp) ? SVf_UTF8 : 0) 847 | SVs_TEMP) 848 : &PL_sv_undef); 849 PUSHs(flgok 850 ? sv_2mortal(SvREFCNT_inc_simple_NN(*flgsvp)) 851 : &PL_sv_undef); 852 nitem += 3; 853 } 854 else { 855 if (namok && argok) 856 PUSHs(sv_2mortal(Perl_newSVpvf(aTHX_ "%" SVf "(%" SVf ")", 857 SVfARG(*namsvp), 858 SVfARG(*argsvp)))); 859 else if (namok) 860 PUSHs(sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp))); 861 else 862 PUSHs(&PL_sv_undef); 863 nitem++; 864 if (flgok) { 865 const IV flags = SvIVX(*flgsvp); 866 867 if (flags & PERLIO_F_UTF8) { 868 PUSHs(newSVpvs_flags("utf8", SVs_TEMP)); 869 nitem++; 870 } 871 } 872 } 873 } 874 875 SvREFCNT_dec(av); 876 877 XSRETURN(nitem); 878 } 879 } 880 #endif 881 882 XSRETURN(0); 883 } 884 885 XS(XS_re_is_regexp); /* prototype to pass -Wmissing-prototypes */ 886 XS(XS_re_is_regexp) 887 { 888 dXSARGS; 889 890 if (items != 1) 891 croak_xs_usage(cv, "sv"); 892 893 if (SvRXOK(ST(0))) { 894 XSRETURN_YES; 895 } else { 896 XSRETURN_NO; 897 } 898 } 899 900 XS(XS_re_regnames_count); /* prototype to pass -Wmissing-prototypes */ 901 XS(XS_re_regnames_count) 902 { 903 REGEXP *rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL; 904 SV * ret; 905 dXSARGS; 906 907 if (items != 0) 908 croak_xs_usage(cv, ""); 909 910 if (!rx) 911 XSRETURN_UNDEF; 912 913 ret = CALLREG_NAMED_BUFF_COUNT(rx); 914 915 SPAGAIN; 916 PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef); 917 XSRETURN(1); 918 } 919 920 XS(XS_re_regname); /* prototype to pass -Wmissing-prototypes */ 921 XS(XS_re_regname) 922 { 923 dXSARGS; 924 REGEXP * rx; 925 U32 flags; 926 SV * ret; 927 928 if (items < 1 || items > 2) 929 croak_xs_usage(cv, "name[, all ]"); 930 931 SP -= items; 932 PUTBACK; 933 934 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL; 935 936 if (!rx) 937 XSRETURN_UNDEF; 938 939 if (items == 2 && SvTRUE_NN(ST(1))) { 940 flags = RXapif_ALL; 941 } else { 942 flags = RXapif_ONE; 943 } 944 ret = CALLREG_NAMED_BUFF_FETCH(rx, ST(0), (flags | RXapif_REGNAME)); 945 946 SPAGAIN; 947 PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef); 948 XSRETURN(1); 949 } 950 951 952 XS(XS_re_regnames); /* prototype to pass -Wmissing-prototypes */ 953 XS(XS_re_regnames) 954 { 955 dXSARGS; 956 REGEXP * rx; 957 U32 flags; 958 SV *ret; 959 AV *av; 960 SSize_t length; 961 SSize_t i; 962 SV **entry; 963 964 if (items > 1) 965 croak_xs_usage(cv, "[all]"); 966 967 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL; 968 969 if (!rx) 970 XSRETURN_UNDEF; 971 972 if (items == 1 && SvTRUE_NN(ST(0))) { 973 flags = RXapif_ALL; 974 } else { 975 flags = RXapif_ONE; 976 } 977 978 SP -= items; 979 PUTBACK; 980 981 ret = CALLREG_NAMED_BUFF_ALL(rx, (flags | RXapif_REGNAMES)); 982 983 SPAGAIN; 984 985 if (!ret) 986 XSRETURN_UNDEF; 987 988 av = MUTABLE_AV(SvRV(ret)); 989 length = av_count(av); 990 991 EXTEND(SP, length); /* better extend stack just once */ 992 for (i = 0; i < length; i++) { 993 entry = av_fetch(av, i, FALSE); 994 995 if (!entry) 996 Perl_croak(aTHX_ "NULL array element in re::regnames()"); 997 998 mPUSHs(SvREFCNT_inc_simple_NN(*entry)); 999 } 1000 1001 SvREFCNT_dec(ret); 1002 1003 PUTBACK; 1004 return; 1005 } 1006 1007 XS(XS_re_regexp_pattern); /* prototype to pass -Wmissing-prototypes */ 1008 XS(XS_re_regexp_pattern) 1009 { 1010 dXSARGS; 1011 REGEXP *re; 1012 U8 const gimme = GIMME_V; 1013 1014 EXTEND(SP, 2); 1015 SP -= items; 1016 if (items != 1) 1017 croak_xs_usage(cv, "sv"); 1018 1019 /* 1020 Checks if a reference is a regex or not. If the parameter is 1021 not a ref, or is not the result of a qr// then returns false 1022 in scalar context and an empty list in list context. 1023 Otherwise in list context it returns the pattern and the 1024 modifiers, in scalar context it returns the pattern just as it 1025 would if the qr// was stringified normally, regardless as 1026 to the class of the variable and any stringification overloads 1027 on the object. 1028 */ 1029 1030 if ((re = SvRX(ST(0)))) /* assign deliberate */ 1031 { 1032 /* Houston, we have a regex! */ 1033 SV *pattern; 1034 1035 if ( gimme == G_LIST ) { 1036 STRLEN left = 0; 1037 char reflags[sizeof(INT_PAT_MODS) + MAX_CHARSET_NAME_LENGTH]; 1038 const char *fptr; 1039 char ch; 1040 U16 match_flags; 1041 1042 /* 1043 we are in list context so stringify 1044 the modifiers that apply. We ignore "negative 1045 modifiers" in this scenario, and the default character set 1046 */ 1047 1048 if (get_regex_charset(RX_EXTFLAGS(re)) != REGEX_DEPENDS_CHARSET) { 1049 STRLEN len; 1050 const char* const name = get_regex_charset_name(RX_EXTFLAGS(re), 1051 &len); 1052 Copy(name, reflags + left, len, char); 1053 left += len; 1054 } 1055 fptr = INT_PAT_MODS; 1056 match_flags = (U16)((RX_EXTFLAGS(re) & RXf_PMf_COMPILETIME) 1057 >> RXf_PMf_STD_PMMOD_SHIFT); 1058 1059 while((ch = *fptr++)) { 1060 if(match_flags & 1) { 1061 reflags[left++] = ch; 1062 } 1063 match_flags >>= 1; 1064 } 1065 1066 pattern = newSVpvn_flags(RX_PRECOMP(re),RX_PRELEN(re), 1067 (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP); 1068 1069 /* return the pattern and the modifiers */ 1070 PUSHs(pattern); 1071 PUSHs(newSVpvn_flags(reflags, left, SVs_TEMP)); 1072 XSRETURN(2); 1073 } else { 1074 /* Scalar, so use the string that Perl would return */ 1075 /* return the pattern in (?msixn:..) format */ 1076 pattern = sv_2mortal(newSVsv(MUTABLE_SV(re))); 1077 PUSHs(pattern); 1078 XSRETURN(1); 1079 } 1080 } else { 1081 /* It ain't a regexp folks */ 1082 if ( gimme == G_LIST ) { 1083 /* return the empty list */ 1084 XSRETURN_EMPTY; 1085 } else { 1086 /* Because of the (?:..) wrapping involved in a 1087 stringified pattern it is impossible to get a 1088 result for a real regexp that would evaluate to 1089 false. Therefore we can return PL_sv_no to signify 1090 that the object is not a regex, this means that one 1091 can say 1092 1093 if (regex($might_be_a_regex) eq '(?:foo)') { } 1094 1095 and not worry about undefined values. 1096 */ 1097 XSRETURN_NO; 1098 } 1099 } 1100 NOT_REACHED; /* NOTREACHED */ 1101 } 1102 1103 #if defined(HAS_GETCWD) && defined(PERL_IS_MINIPERL) 1104 1105 XS(XS_Internals_getcwd) 1106 { 1107 dXSARGS; 1108 SV *sv = sv_newmortal(); 1109 1110 if (items != 0) 1111 croak_xs_usage(cv, ""); 1112 1113 (void)getcwd_sv(sv); 1114 1115 SvTAINTED_on(sv); 1116 PUSHs(sv); 1117 XSRETURN(1); 1118 } 1119 1120 #endif 1121 1122 XS(XS_NamedCapture_tie_it) 1123 { 1124 dXSARGS; 1125 1126 if (items != 1) 1127 croak_xs_usage(cv, "sv"); 1128 { 1129 SV *sv = ST(0); 1130 GV * const gv = (GV *)sv; 1131 HV * const hv = GvHVn(gv); 1132 SV *rv = newSV_type(SVt_IV); 1133 const char *gv_name = GvNAME(gv); 1134 1135 sv_setrv_noinc(rv, newSVuv( 1136 strEQ(gv_name, "-") || strEQ(gv_name, "\003APTURE_ALL") 1137 ? RXapif_ALL : RXapif_ONE)); 1138 sv_bless(rv, GvSTASH(CvGV(cv))); 1139 1140 sv_unmagic((SV *)hv, PERL_MAGIC_tied); 1141 sv_magic((SV *)hv, rv, PERL_MAGIC_tied, NULL, 0); 1142 SvREFCNT_dec(rv); /* As sv_magic increased it by one. */ 1143 } 1144 XSRETURN_EMPTY; 1145 } 1146 1147 XS(XS_NamedCapture_TIEHASH) 1148 { 1149 dXSARGS; 1150 if (items < 1) 1151 croak_xs_usage(cv, "package, ..."); 1152 { 1153 const char * package = (const char *)SvPV_nolen(ST(0)); 1154 UV flag = RXapif_ONE; 1155 mark += 2; 1156 while(mark < sp) { 1157 STRLEN len; 1158 const char *p = SvPV_const(*mark, len); 1159 if(memEQs(p, len, "all")) 1160 flag = SvTRUE(mark[1]) ? RXapif_ALL : RXapif_ONE; 1161 mark += 2; 1162 } 1163 ST(0) = newSV_type_mortal(SVt_IV); 1164 sv_setuv(newSVrv(ST(0), package), flag); 1165 } 1166 XSRETURN(1); 1167 } 1168 1169 /* These are tightly coupled to the RXapif_* flags defined in regexp.h */ 1170 #define UNDEF_FATAL 0x80000 1171 #define DISCARD 0x40000 1172 #define EXPECT_SHIFT 24 1173 #define ACTION_MASK 0x000FF 1174 1175 #define FETCH_ALIAS (RXapif_FETCH | (2 << EXPECT_SHIFT)) 1176 #define STORE_ALIAS (RXapif_STORE | (3 << EXPECT_SHIFT) | UNDEF_FATAL | DISCARD) 1177 #define DELETE_ALIAS (RXapif_DELETE | (2 << EXPECT_SHIFT) | UNDEF_FATAL) 1178 #define CLEAR_ALIAS (RXapif_CLEAR | (1 << EXPECT_SHIFT) | UNDEF_FATAL | DISCARD) 1179 #define EXISTS_ALIAS (RXapif_EXISTS | (2 << EXPECT_SHIFT)) 1180 #define SCALAR_ALIAS (RXapif_SCALAR | (1 << EXPECT_SHIFT)) 1181 1182 XS(XS_NamedCapture_FETCH) 1183 { 1184 dXSARGS; 1185 dXSI32; 1186 PERL_UNUSED_VAR(cv); /* -W */ 1187 PERL_UNUSED_VAR(ax); /* -Wall */ 1188 SP -= items; 1189 { 1190 REGEXP *const rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL; 1191 U32 flags; 1192 SV *ret; 1193 const U32 action = ix & ACTION_MASK; 1194 const int expect = ix >> EXPECT_SHIFT; 1195 if (items != expect) 1196 croak_xs_usage(cv, expect == 2 ? "$key" 1197 : (expect == 3 ? "$key, $value" 1198 : "")); 1199 1200 if (!rx || !SvROK(ST(0))) { 1201 if (ix & UNDEF_FATAL) 1202 Perl_croak_no_modify(); 1203 else 1204 XSRETURN_UNDEF; 1205 } 1206 1207 flags = (U32)SvUV(SvRV(MUTABLE_SV(ST(0)))); 1208 1209 PUTBACK; 1210 ret = RX_ENGINE(rx)->named_buff(aTHX_ (rx), expect >= 2 ? ST(1) : NULL, 1211 expect >= 3 ? ST(2) : NULL, flags | action); 1212 SPAGAIN; 1213 1214 if (ix & DISCARD) { 1215 /* Called with G_DISCARD, so our return stack state is thrown away. 1216 Hence if we were returned anything, free it immediately. */ 1217 SvREFCNT_dec(ret); 1218 } else { 1219 PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef); 1220 } 1221 PUTBACK; 1222 return; 1223 } 1224 } 1225 1226 1227 XS(XS_NamedCapture_FIRSTKEY) 1228 { 1229 dXSARGS; 1230 dXSI32; 1231 PERL_UNUSED_VAR(cv); /* -W */ 1232 PERL_UNUSED_VAR(ax); /* -Wall */ 1233 SP -= items; 1234 { 1235 REGEXP *const rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL; 1236 U32 flags; 1237 SV *ret; 1238 const int expect = ix ? 2 : 1; 1239 const U32 action = ix ? RXapif_NEXTKEY : RXapif_FIRSTKEY; 1240 if (items != expect) 1241 croak_xs_usage(cv, expect == 2 ? "$lastkey" : ""); 1242 1243 if (!rx || !SvROK(ST(0))) 1244 XSRETURN_UNDEF; 1245 1246 flags = (U32)SvUV(SvRV(MUTABLE_SV(ST(0)))); 1247 1248 PUTBACK; 1249 ret = RX_ENGINE(rx)->named_buff_iter(aTHX_ (rx), 1250 expect >= 2 ? ST(1) : NULL, 1251 flags | action); 1252 SPAGAIN; 1253 1254 PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef); 1255 PUTBACK; 1256 return; 1257 } 1258 } 1259 1260 /* is this still needed? */ 1261 XS(XS_NamedCapture_flags) 1262 { 1263 dXSARGS; 1264 PERL_UNUSED_VAR(cv); /* -W */ 1265 PERL_UNUSED_VAR(ax); /* -Wall */ 1266 SP -= items; 1267 { 1268 EXTEND(SP, 2); 1269 mPUSHu(RXapif_ONE); 1270 mPUSHu(RXapif_ALL); 1271 PUTBACK; 1272 return; 1273 } 1274 } 1275 1276 #include "vutil.h" 1277 #include "vxs.inc" 1278 1279 struct xsub_details { 1280 const char *name; 1281 XSUBADDR_t xsub; 1282 const char *proto; 1283 int ix; 1284 }; 1285 1286 static const struct xsub_details these_details[] = { 1287 {"UNIVERSAL::isa", XS_UNIVERSAL_isa, NULL, 0 }, 1288 {"UNIVERSAL::can", XS_UNIVERSAL_can, NULL, 0 }, 1289 {"UNIVERSAL::DOES", XS_UNIVERSAL_DOES, NULL, 0 }, 1290 #define VXS_XSUB_DETAILS 1291 #include "vxs.inc" 1292 #undef VXS_XSUB_DETAILS 1293 {"utf8::is_utf8", XS_utf8_is_utf8, NULL, 0 }, 1294 {"utf8::valid", XS_utf8_valid, NULL, 0 }, 1295 {"utf8::encode", XS_utf8_encode, NULL, 0 }, 1296 {"utf8::decode", XS_utf8_decode, NULL, 0 }, 1297 {"utf8::upgrade", XS_utf8_upgrade, NULL, 0 }, 1298 {"utf8::downgrade", XS_utf8_downgrade, NULL, 0 }, 1299 {"utf8::native_to_unicode", XS_utf8_native_to_unicode, NULL, 0 }, 1300 {"utf8::unicode_to_native", XS_utf8_unicode_to_native, NULL, 0 }, 1301 {"Internals::SvREADONLY", XS_Internals_SvREADONLY, "\\[$%@];$", 0 }, 1302 {"Internals::SvREFCNT", XS_Internals_SvREFCNT, "\\[$%@];$", 0 }, 1303 {"Internals::hv_clear_placeholders", XS_Internals_hv_clear_placehold, "\\%", 0 }, 1304 {"constant::_make_const", XS_constant__make_const, "\\[$@]", 0 }, 1305 {"PerlIO::get_layers", XS_PerlIO_get_layers, "*;@", 0 }, 1306 {"re::is_regexp", XS_re_is_regexp, "$", 0 }, 1307 {"re::regname", XS_re_regname, ";$$", 0 }, 1308 {"re::regnames", XS_re_regnames, ";$", 0 }, 1309 {"re::regnames_count", XS_re_regnames_count, "", 0 }, 1310 {"re::regexp_pattern", XS_re_regexp_pattern, "$", 0 }, 1311 #if defined(HAS_GETCWD) && defined(PERL_IS_MINIPERL) 1312 {"Internals::getcwd", XS_Internals_getcwd, "", 0 }, 1313 #endif 1314 {"Tie::Hash::NamedCapture::_tie_it", XS_NamedCapture_tie_it, NULL, 0 }, 1315 {"Tie::Hash::NamedCapture::TIEHASH", XS_NamedCapture_TIEHASH, NULL, 0 }, 1316 {"Tie::Hash::NamedCapture::FETCH", XS_NamedCapture_FETCH, NULL, FETCH_ALIAS }, 1317 {"Tie::Hash::NamedCapture::STORE", XS_NamedCapture_FETCH, NULL, STORE_ALIAS }, 1318 {"Tie::Hash::NamedCapture::DELETE", XS_NamedCapture_FETCH, NULL, DELETE_ALIAS }, 1319 {"Tie::Hash::NamedCapture::CLEAR", XS_NamedCapture_FETCH, NULL, CLEAR_ALIAS }, 1320 {"Tie::Hash::NamedCapture::EXISTS", XS_NamedCapture_FETCH, NULL, EXISTS_ALIAS }, 1321 {"Tie::Hash::NamedCapture::SCALAR", XS_NamedCapture_FETCH, NULL, SCALAR_ALIAS }, 1322 {"Tie::Hash::NamedCapture::FIRSTKEY", XS_NamedCapture_FIRSTKEY, NULL, 0 }, 1323 {"Tie::Hash::NamedCapture::NEXTKEY", XS_NamedCapture_FIRSTKEY, NULL, 1 }, 1324 {"Tie::Hash::NamedCapture::flags", XS_NamedCapture_flags, NULL, 0 }, 1325 }; 1326 1327 STATIC OP* 1328 optimize_out_native_convert_function(pTHX_ OP* entersubop, 1329 GV* namegv, 1330 SV* protosv) 1331 { 1332 /* Optimizes out an identity function, i.e., one that just returns its 1333 * argument. The passed in function is assumed to be an identity function, 1334 * with no checking. This is designed to be called for utf8_to_native() 1335 * and native_to_utf8() on ASCII platforms, as they just return their 1336 * arguments, but it could work on any such function. 1337 * 1338 * The code is mostly just cargo-culted from Memoize::Lift */ 1339 1340 OP *pushop, *argop; 1341 OP *parent; 1342 SV* prototype = newSVpvs("$"); 1343 1344 PERL_UNUSED_ARG(protosv); 1345 1346 assert(entersubop->op_type == OP_ENTERSUB); 1347 1348 entersubop = ck_entersub_args_proto(entersubop, namegv, prototype); 1349 parent = entersubop; 1350 1351 SvREFCNT_dec(prototype); 1352 1353 pushop = cUNOPx(entersubop)->op_first; 1354 if (! OpHAS_SIBLING(pushop)) { 1355 parent = pushop; 1356 pushop = cUNOPx(pushop)->op_first; 1357 } 1358 argop = OpSIBLING(pushop); 1359 1360 /* Carry on without doing the optimization if it is not something we're 1361 * expecting, so continues to work */ 1362 if ( ! argop 1363 || ! OpHAS_SIBLING(argop) 1364 || OpHAS_SIBLING(OpSIBLING(argop)) 1365 ) { 1366 return entersubop; 1367 } 1368 1369 /* cut argop from the subtree */ 1370 (void)op_sibling_splice(parent, pushop, 1, NULL); 1371 1372 op_free(entersubop); 1373 return argop; 1374 } 1375 1376 void 1377 Perl_boot_core_UNIVERSAL(pTHX) 1378 { 1379 static const char file[] = __FILE__; 1380 const struct xsub_details *xsub = these_details; 1381 const struct xsub_details *end = C_ARRAY_END(these_details); 1382 1383 do { 1384 CV *cv = newXS_flags(xsub->name, xsub->xsub, file, xsub->proto, 0); 1385 XSANY.any_i32 = xsub->ix; 1386 } while (++xsub < end); 1387 1388 #ifndef EBCDIC 1389 { /* On ASCII platforms these functions just return their argument, so can 1390 be optimized away */ 1391 1392 CV* to_native_cv = get_cv("utf8::unicode_to_native", 0); 1393 CV* to_unicode_cv = get_cv("utf8::native_to_unicode", 0); 1394 1395 cv_set_call_checker_flags(to_native_cv, 1396 optimize_out_native_convert_function, 1397 (SV*) to_native_cv, 0); 1398 cv_set_call_checker_flags(to_unicode_cv, 1399 optimize_out_native_convert_function, 1400 (SV*) to_unicode_cv, 0); 1401 } 1402 #endif 1403 1404 /* Providing a Regexp::DESTROY fixes #21347. See test in t/op/ref.t */ 1405 { 1406 CV * const cv = 1407 newCONSTSUB(get_hv("Regexp::", GV_ADD), "DESTROY", NULL); 1408 char ** cvfile = &CvFILE(cv); 1409 char * oldfile = *cvfile; 1410 CvDYNFILE_off(cv); 1411 *cvfile = (char *)file; 1412 Safefree(oldfile); 1413 } 1414 } 1415 1416 /* 1417 * ex: set ts=8 sts=4 sw=4 et: 1418 */ 1419