universal.c

   1 /*    universal.c
   2  *
   3  *    Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
   4  *    2005, 2006, 2007, 2008 by Larry Wall and others
   5  *
   6  *    You may distribute under the terms of either the GNU General Public
   7  *    License or the Artistic License, as specified in the README file.
   8  *
   9  */
  10
  11 /*
  12  * '"The roots of those mountains must be roots indeed; there must be
  13  *   great secrets buried there which have not been discovered since the
  14  *   beginning."'                   --Gandalf, relating Gollum's history
  15  *
  16  *     [p.54 of _The Lord of the Rings_, I/ii: "The Shadow of the Past"]
  17  */
  18
  19 /* This file contains the code that implements the functions in Perl's
  20  * UNIVERSAL package, such as UNIVERSAL->can().
  21  *
  22  * It is also used to store XS functions that need to be present in
  23  * miniperl for a lack of a better place to put them. It might be
  24  * clever to move them to separate XS files which would then be pulled
  25  * in by some to-be-written build process.
  26  */
  27
  28 #include "EXTERN.h"
  29 #define PERL_IN_UNIVERSAL_C
  30 #include "perl.h"
  31
  32 #if defined(USE_PERLIO)
  33 #include "perliol.h" /* For the PERLIO_F_XXX */
  34 #endif
  35
  36 /*
  37  * Contributed by Graham Barr  <Graham.Barr@tiuk.ti.com>
  38  * The main guts of traverse_isa was actually copied from gv_fetchmeth
  39  */
  40
  41 #define PERL_ARGS_ASSERT_ISA_LOOKUP \
  42     assert(stash); \
  43     assert(namesv || name)
  44
  45
  46 STATIC bool
  47 S_isa_lookup(pTHX_ HV *stash, SV *namesv, const char * name, STRLEN len, U32 flags)
  48 {
  49     const struct mro_meta *const meta = HvMROMETA(stash);
  50     HV *isa = meta->isa;
  51     const HV *our_stash;
  52
  53     PERL_ARGS_ASSERT_ISA_LOOKUP;
  54
  55     if (!isa) {
  56         (void)mro_get_linear_isa(stash);
  57         isa = meta->isa;
  58     }
  59
  60     if (hv_common(isa, namesv, name, len, ( flags & SVf_UTF8 ? HVhek_UTF8 : 0),
  61                   HV_FETCH_ISEXISTS, NULL, 0)) {
  62         /* Direct name lookup worked.  */
  63         return TRUE;
  64     }
  65
  66     /* A stash/class can go by many names (ie. User == main::User), so
  67        we use the HvENAME in the stash itself, which is canonical, falling
  68        back to HvNAME if necessary.  */
  69     our_stash = gv_stashsvpvn_cached(namesv, name, len, flags);
  70
  71     if (our_stash) {
  72         HEK *canon_name = HvENAME_HEK(our_stash);
  73         if (!canon_name) canon_name = HvNAME_HEK(our_stash);
  74         assert(canon_name);
  75         if (hv_common(isa, NULL, HEK_KEY(canon_name), HEK_LEN(canon_name),
  76                       HEK_FLAGS(canon_name),
  77                       HV_FETCH_ISEXISTS, NULL, HEK_HASH(canon_name))) {
  78             return TRUE;
  79         }
  80     }
  81
  82     return FALSE;
  83 }
  84
  85 #define PERL_ARGS_ASSERT_SV_DERIVED_FROM_SVPVN \
  86     assert(sv); \
  87     assert(namesv || name)
  88
  89 STATIC bool
  90 S_sv_derived_from_svpvn(pTHX_ SV *sv, SV *namesv, const char * name, const STRLEN len, U32 flags)
  91 {
  92     HV* stash;
  93
  94     PERL_ARGS_ASSERT_SV_DERIVED_FROM_SVPVN;
  95     SvGETMAGIC(sv);
  96
  97     if (SvROK(sv)) {
  98         const char *type;
  99         sv = SvRV(sv);
 100         type = sv_reftype(sv,0);
 101         if (type) {
 102             if (namesv)
 103                 name = SvPV_nolen(namesv);
 104             if (strEQ(name, type))
 105                 return TRUE;
 106         }
 107         if (!SvOBJECT(sv))
 108             return FALSE;
 109         stash = SvSTASH(sv);
 110     }
 111     else {
 112         stash = gv_stashsv(sv, 0);
 113     }
 114
 115     if (stash && isa_lookup(stash, namesv, name, len, flags))
 116         return TRUE;
 117
 118     stash = gv_stashpvs("UNIVERSAL", 0);
 119     return stash && isa_lookup(stash, namesv, name, len, flags);
 120 }
 121
 122 /*
 123 =for apidoc_section $SV
 124
 125 =for apidoc sv_derived_from_pvn
 126
 127 Returns a boolean indicating whether the SV is derived from the specified class
 128 I<at the C level>.  To check derivation at the Perl level, call C<isa()> as a
 129 normal Perl method.
 130
 131 Currently, the only significant value for C<flags> is SVf_UTF8.
 132
 133 =cut
 134
 135 =for apidoc sv_derived_from_sv
 136
 137 Exactly like L</sv_derived_from_pvn>, but takes the name string in the form
 138 of an SV instead of a string/length pair. This is the advised form.
 139
 140 =cut
 141
 142 */
 143
 144 bool
 145 Perl_sv_derived_from_sv(pTHX_ SV *sv, SV *namesv, U32 flags)
 146 {
 147     PERL_ARGS_ASSERT_SV_DERIVED_FROM_SV;
 148     return sv_derived_from_svpvn(sv, namesv, NULL, 0, flags);
 149 }
 150
 151 /*
 152 =for apidoc sv_derived_from
 153
 154 Exactly like L</sv_derived_from_pv>, but doesn't take a C<flags> parameter.
 155
 156 =cut
 157 */
 158
 159 bool
 160 Perl_sv_derived_from(pTHX_ SV *sv, const char *const name)
 161 {
 162     PERL_ARGS_ASSERT_SV_DERIVED_FROM;
 163     return sv_derived_from_svpvn(sv, NULL, name, strlen(name), 0);
 164 }
 165
 166 /*
 167 =for apidoc sv_derived_from_pv
 168
 169 Exactly like L</sv_derived_from_pvn>, but takes a nul-terminated string
 170 instead of a string/length pair.
 171
 172 =cut
 173 */
 174
 175
 176 bool
 177 Perl_sv_derived_from_pv(pTHX_ SV *sv, const char *const name, U32 flags)
 178 {
 179     PERL_ARGS_ASSERT_SV_DERIVED_FROM_PV;
 180     return sv_derived_from_svpvn(sv, NULL, name, strlen(name), flags);
 181 }
 182
 183 bool
 184 Perl_sv_derived_from_pvn(pTHX_ SV *sv, const char *const name, const STRLEN len, U32 flags)
 185 {
 186     PERL_ARGS_ASSERT_SV_DERIVED_FROM_PVN;
 187     return sv_derived_from_svpvn(sv, NULL, name, len, flags);
 188 }
 189
 190 /*
 191 =for apidoc sv_isa_sv
 192
 193 Returns a boolean indicating whether the SV is an object reference and is
 194 derived from the specified class, respecting any C<isa()> method overloading
 195 it may have. Returns false if C<sv> is not a reference to an object, or is
 196 not derived from the specified class.
 197
 198 This is the function used to implement the behaviour of the C<isa> operator.
 199
 200 Does not invoke magic on C<sv>.
 201
 202 Not to be confused with the older C<sv_isa> function, which does not use an
 203 overloaded C<isa()> method, nor will check subclassing.
 204
 205 =cut
 206
 207 */
 208
 209 bool
 210 Perl_sv_isa_sv(pTHX_ SV *sv, SV *namesv)
 211 {
 212     GV *isagv;
 213
 214     PERL_ARGS_ASSERT_SV_ISA_SV;
 215
 216     if(!SvROK(sv) || !SvOBJECT(SvRV(sv)))
 217         return FALSE;
 218
 219     isagv = gv_fetchmeth_pvn(SvSTASH(SvRV(sv)), "isa", 3, -1, GV_NOUNIVERSAL);
 220     if(isagv) {
 221         dSP;
 222         CV *isacv = isGV(isagv) ? GvCV(isagv) : (CV *)isagv;
 223         SV *retsv;
 224         bool ret;
 225
 226         PUTBACK;
 227
 228         ENTER;
 229         SAVETMPS;
 230
 231         EXTEND(SP, 2);
 232         PUSHMARK(SP);
 233         PUSHs(sv);
 234         PUSHs(namesv);
 235         PUTBACK;
 236
 237         call_sv((SV *)isacv, G_SCALAR);
 238
 239         SPAGAIN;
 240         retsv = POPs;
 241         ret = SvTRUE(retsv);
 242         PUTBACK;
 243
 244         FREETMPS;
 245         LEAVE;
 246
 247         return ret;
 248     }
 249
 250     /* TODO: Support namesv being an HV ref to the stash directly? */
 251
 252     return sv_derived_from_sv(sv, namesv, 0);
 253 }
 254
 255 /*
 256 =for apidoc sv_does_sv
 257
 258 Returns a boolean indicating whether the SV performs a specific, named role.
 259 The SV can be a Perl object or the name of a Perl class.
 260
 261 =cut
 262 */
 263
 264 #include "XSUB.h"
 265
 266 bool
 267 Perl_sv_does_sv(pTHX_ SV *sv, SV *namesv, U32 flags)
 268 {
 269     SV *classname;
 270     bool does_it;
 271     SV *methodname;
 272     dSP;
 273
 274     PERL_ARGS_ASSERT_SV_DOES_SV;
 275     PERL_UNUSED_ARG(flags);
 276
 277     ENTER;
 278     SAVETMPS;
 279
 280     SvGETMAGIC(sv);
 281
 282     if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv)))) {
 283         LEAVE;
 284         return FALSE;
 285     }
 286
 287     if (SvROK(sv) && SvOBJECT(SvRV(sv))) {
 288         classname = sv_ref(NULL,SvRV(sv),TRUE);
 289     } else {
 290         classname = sv;
 291     }
 292
 293     if (sv_eq(classname, namesv)) {
 294         LEAVE;
 295         return TRUE;
 296     }
 297
 298     PUSHMARK(SP);
 299     EXTEND(SP, 2);
 300     PUSHs(sv);
 301     PUSHs(namesv);
 302     PUTBACK;
 303
 304     /* create a PV with value "isa", but with a special address
 305      * so that perl knows we're really doing "DOES" instead */
 306     methodname = newSV_type(SVt_PV);
 307     SvLEN_set(methodname, 0);
 308     SvCUR_set(methodname, strlen(PL_isa_DOES));
 309     SvPVX(methodname) = (char *)PL_isa_DOES; /* discard 'const' qualifier */
 310     SvPOK_on(methodname);
 311     sv_2mortal(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_ARRAY ) {
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_ARRAY ) {
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 #ifdef HAS_GETCWD
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         SvRV_set(rv, newSVuv(
1101             strEQ(gv_name, "-") || strEQ(gv_name, "\003APTURE_ALL")
1102             ? RXapif_ALL : RXapif_ONE));
1103         SvROK_on(rv);
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 #ifdef HAS_GETCWD
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  */