universal.c

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