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