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 = NULL;
 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
 779         /* MAYBE_DEREF_GV will call get magic */
 780         if ((gv = MAYBE_DEREF_GV(sv)))
 781             io = GvIO(gv);
 782         else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO)
 783             io = (IO*)SvRV(sv);
 784         else if (!SvROK(sv) && (gv = gv_fetchsv_nomg(sv, 0, SVt_PVIO)))
 785             io = GvIO(gv);
 786
 787         if (io) {
 788              AV* const av = PerlIO_get_layers(aTHX_ input ?
 789                                         IoIFP(io) : IoOFP(io));
 790              SSize_t i;
 791              const SSize_t last = av_top_index(av);
 792              SSize_t nitem = 0;
 793
 794              for (i = last; i >= 0; i -= 3) {
 795                   SV * const * const namsvp = av_fetch(av, i - 2, FALSE);
 796                   SV * const * const argsvp = av_fetch(av, i - 1, FALSE);
 797                   SV * const * const flgsvp = av_fetch(av, i,     FALSE);
 798
 799                   const bool namok = namsvp && *namsvp && SvPOK(*namsvp);
 800                   const bool argok = argsvp && *argsvp && SvPOK(*argsvp);
 801                   const bool flgok = flgsvp && *flgsvp && SvIOK(*flgsvp);
 802
 803                   EXTEND(SP, 3); /* Three is the max in all branches: better check just once */
 804                   if (details) {
 805                       /* Indents of 5? Yuck.  */
 806                       /* We know that PerlIO_get_layers creates a new SV for
 807                          the name and flags, so we can just take a reference
 808                          and "steal" it when we free the AV below.  */
 809                        PUSHs(namok
 810                               ? sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp))
 811                               : &PL_sv_undef);
 812                        PUSHs(argok
 813                               ? newSVpvn_flags(SvPVX_const(*argsvp),
 814                                                SvCUR(*argsvp),
 815                                                (SvUTF8(*argsvp) ? SVf_UTF8 : 0)
 816                                                | SVs_TEMP)
 817                               : &PL_sv_undef);
 818                        PUSHs(flgok
 819                               ? sv_2mortal(SvREFCNT_inc_simple_NN(*flgsvp))
 820                               : &PL_sv_undef);
 821                        nitem += 3;
 822                   }
 823                   else {
 824                        if (namok && argok)
 825                             PUSHs(sv_2mortal(Perl_newSVpvf(aTHX_ "%" SVf "(%" SVf ")",
 826                                                  SVfARG(*namsvp),
 827                                                  SVfARG(*argsvp))));
 828                        else if (namok)
 829                             PUSHs(sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp)));
 830                        else
 831                             PUSHs(&PL_sv_undef);
 832                        nitem++;
 833                        if (flgok) {
 834                             const IV flags = SvIVX(*flgsvp);
 835
 836                             if (flags & PERLIO_F_UTF8) {
 837                                  PUSHs(newSVpvs_flags("utf8", SVs_TEMP));
 838                                  nitem++;
 839                             }
 840                        }
 841                   }
 842              }
 843
 844              SvREFCNT_dec(av);
 845
 846              XSRETURN(nitem);
 847         }
 848     }
 849 #endif
 850
 851     XSRETURN(0);
 852 }
 853
 854 XS(XS_re_is_regexp); /* prototype to pass -Wmissing-prototypes */
 855 XS(XS_re_is_regexp)
 856 {
 857     dXSARGS;
 858
 859     if (items != 1)
 860         croak_xs_usage(cv, "sv");
 861
 862     if (SvRXOK(ST(0))) {
 863         XSRETURN_YES;
 864     } else {
 865         XSRETURN_NO;
 866     }
 867 }
 868
 869 XS(XS_re_regnames_count); /* prototype to pass -Wmissing-prototypes */
 870 XS(XS_re_regnames_count)
 871 {
 872     REGEXP *rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
 873     SV * ret;
 874     dXSARGS;
 875
 876     if (items != 0)
 877         croak_xs_usage(cv, "");
 878
 879     if (!rx)
 880         XSRETURN_UNDEF;
 881
 882     ret = CALLREG_NAMED_BUFF_COUNT(rx);
 883
 884     SPAGAIN;
 885     PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef);
 886     XSRETURN(1);
 887 }
 888
 889 XS(XS_re_regname); /* prototype to pass -Wmissing-prototypes */
 890 XS(XS_re_regname)
 891 {
 892     dXSARGS;
 893     REGEXP * rx;
 894     U32 flags;
 895     SV * ret;
 896
 897     if (items < 1 || items > 2)
 898         croak_xs_usage(cv, "name[, all ]");
 899
 900     SP -= items;
 901     PUTBACK;
 902
 903     rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
 904
 905     if (!rx)
 906         XSRETURN_UNDEF;
 907
 908     if (items == 2 && SvTRUE_NN(ST(1))) {
 909         flags = RXapif_ALL;
 910     } else {
 911         flags = RXapif_ONE;
 912     }
 913     ret = CALLREG_NAMED_BUFF_FETCH(rx, ST(0), (flags | RXapif_REGNAME));
 914
 915     SPAGAIN;
 916     PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef);
 917     XSRETURN(1);
 918 }
 919
 920
 921 XS(XS_re_regnames); /* prototype to pass -Wmissing-prototypes */
 922 XS(XS_re_regnames)
 923 {
 924     dXSARGS;
 925     REGEXP * rx;
 926     U32 flags;
 927     SV *ret;
 928     AV *av;
 929     SSize_t length;
 930     SSize_t i;
 931     SV **entry;
 932
 933     if (items > 1)
 934         croak_xs_usage(cv, "[all]");
 935
 936     rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
 937
 938     if (!rx)
 939         XSRETURN_UNDEF;
 940
 941     if (items == 1 && SvTRUE_NN(ST(0))) {
 942         flags = RXapif_ALL;
 943     } else {
 944         flags = RXapif_ONE;
 945     }
 946
 947     SP -= items;
 948     PUTBACK;
 949
 950     ret = CALLREG_NAMED_BUFF_ALL(rx, (flags | RXapif_REGNAMES));
 951
 952     SPAGAIN;
 953
 954     if (!ret)
 955         XSRETURN_UNDEF;
 956
 957     av = MUTABLE_AV(SvRV(ret));
 958     length = av_count(av);
 959
 960     EXTEND(SP, length); /* better extend stack just once */
 961     for (i = 0; i < length; i++) {
 962         entry = av_fetch(av, i, FALSE);
 963
 964         if (!entry)
 965             Perl_croak(aTHX_ "NULL array element in re::regnames()");
 966
 967         mPUSHs(SvREFCNT_inc_simple_NN(*entry));
 968     }
 969
 970     SvREFCNT_dec(ret);
 971
 972     PUTBACK;
 973     return;
 974 }
 975
 976 XS(XS_re_regexp_pattern); /* prototype to pass -Wmissing-prototypes */
 977 XS(XS_re_regexp_pattern)
 978 {
 979     dXSARGS;
 980     REGEXP *re;
 981     U8 const gimme = GIMME_V;
 982
 983     EXTEND(SP, 2);
 984     SP -= items;
 985     if (items != 1)
 986         croak_xs_usage(cv, "sv");
 987
 988     /*
 989        Checks if a reference is a regex or not. If the parameter is
 990        not a ref, or is not the result of a qr// then returns false
 991        in scalar context and an empty list in list context.
 992        Otherwise in list context it returns the pattern and the
 993        modifiers, in scalar context it returns the pattern just as it
 994        would if the qr// was stringified normally, regardless as
 995        to the class of the variable and any stringification overloads
 996        on the object.
 997     */
 998
 999     if ((re = SvRX(ST(0)))) /* assign deliberate */
1000     {
1001         /* Houston, we have a regex! */
1002         SV *pattern;
1003
1004         if ( gimme == G_LIST ) {
1005             STRLEN left = 0;
1006             char reflags[sizeof(INT_PAT_MODS) + MAX_CHARSET_NAME_LENGTH];
1007             const char *fptr;
1008             char ch;
1009             U16 match_flags;
1010
1011             /*
1012                we are in list context so stringify
1013                the modifiers that apply. We ignore "negative
1014                modifiers" in this scenario, and the default character set
1015             */
1016
1017             if (get_regex_charset(RX_EXTFLAGS(re)) != REGEX_DEPENDS_CHARSET) {
1018                 STRLEN len;
1019                 const char* const name = get_regex_charset_name(RX_EXTFLAGS(re),
1020                                                                 &len);
1021                 Copy(name, reflags + left, len, char);
1022                 left += len;
1023             }
1024             fptr = INT_PAT_MODS;
1025             match_flags = (U16)((RX_EXTFLAGS(re) & RXf_PMf_COMPILETIME)
1026                                     >> RXf_PMf_STD_PMMOD_SHIFT);
1027
1028             while((ch = *fptr++)) {
1029                 if(match_flags & 1) {
1030                     reflags[left++] = ch;
1031                 }
1032                 match_flags >>= 1;
1033             }
1034
1035             pattern = newSVpvn_flags(RX_PRECOMP(re),RX_PRELEN(re),
1036                                      (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP);
1037
1038             /* return the pattern and the modifiers */
1039             PUSHs(pattern);
1040             PUSHs(newSVpvn_flags(reflags, left, SVs_TEMP));
1041             XSRETURN(2);
1042         } else {
1043             /* Scalar, so use the string that Perl would return */
1044             /* return the pattern in (?msixn:..) format */
1045             pattern = sv_2mortal(newSVsv(MUTABLE_SV(re)));
1046             PUSHs(pattern);
1047             XSRETURN(1);
1048         }
1049     } else {
1050         /* It ain't a regexp folks */
1051         if ( gimme == G_LIST ) {
1052             /* return the empty list */
1053             XSRETURN_EMPTY;
1054         } else {
1055             /* Because of the (?:..) wrapping involved in a
1056                stringified pattern it is impossible to get a
1057                result for a real regexp that would evaluate to
1058                false. Therefore we can return PL_sv_no to signify
1059                that the object is not a regex, this means that one
1060                can say
1061
1062                  if (regex($might_be_a_regex) eq '(?:foo)') { }
1063
1064                and not worry about undefined values.
1065             */
1066             XSRETURN_NO;
1067         }
1068     }
1069     NOT_REACHED; /* NOTREACHED */
1070 }
1071
1072 #if defined(HAS_GETCWD) && defined(PERL_IS_MINIPERL)
1073
1074 XS(XS_Internals_getcwd)
1075 {
1076     dXSARGS;
1077     SV *sv = sv_newmortal();
1078
1079     if (items != 0)
1080         croak_xs_usage(cv, "");
1081
1082     (void)getcwd_sv(sv);
1083
1084     SvTAINTED_on(sv);
1085     PUSHs(sv);
1086     XSRETURN(1);
1087 }
1088
1089 #endif
1090
1091 XS(XS_NamedCapture_tie_it)
1092 {
1093     dXSARGS;
1094
1095     if (items != 1)
1096         croak_xs_usage(cv,  "sv");
1097     {
1098         SV *sv = ST(0);
1099         GV * const gv = (GV *)sv;
1100         HV * const hv = GvHVn(gv);
1101         SV *rv = newSV_type(SVt_IV);
1102         const char *gv_name = GvNAME(gv);
1103
1104         sv_setrv_noinc(rv, newSVuv(
1105             strEQ(gv_name, "-") || strEQ(gv_name, "\003APTURE_ALL")
1106             ? RXapif_ALL : RXapif_ONE));
1107         sv_bless(rv, GvSTASH(CvGV(cv)));
1108
1109         sv_unmagic((SV *)hv, PERL_MAGIC_tied);
1110         sv_magic((SV *)hv, rv, PERL_MAGIC_tied, NULL, 0);
1111         SvREFCNT_dec(rv); /* As sv_magic increased it by one.  */
1112     }
1113     XSRETURN_EMPTY;
1114 }
1115
1116 XS(XS_NamedCapture_TIEHASH)
1117 {
1118     dXSARGS;
1119     if (items < 1)
1120        croak_xs_usage(cv,  "package, ...");
1121     {
1122         const char *    package = (const char *)SvPV_nolen(ST(0));
1123         UV flag = RXapif_ONE;
1124         mark += 2;
1125         while(mark < sp) {
1126             STRLEN len;
1127             const char *p = SvPV_const(*mark, len);
1128             if(memEQs(p, len, "all"))
1129                 flag = SvTRUE(mark[1]) ? RXapif_ALL : RXapif_ONE;
1130             mark += 2;
1131         }
1132         ST(0) = newSV_type_mortal(SVt_IV);
1133         sv_setuv(newSVrv(ST(0), package), flag);
1134     }
1135     XSRETURN(1);
1136 }
1137
1138 /* These are tightly coupled to the RXapif_* flags defined in regexp.h  */
1139 #define UNDEF_FATAL  0x80000
1140 #define DISCARD      0x40000
1141 #define EXPECT_SHIFT 24
1142 #define ACTION_MASK  0x000FF
1143
1144 #define FETCH_ALIAS  (RXapif_FETCH  | (2 << EXPECT_SHIFT))
1145 #define STORE_ALIAS  (RXapif_STORE  | (3 << EXPECT_SHIFT) | UNDEF_FATAL | DISCARD)
1146 #define DELETE_ALIAS (RXapif_DELETE | (2 << EXPECT_SHIFT) | UNDEF_FATAL)
1147 #define CLEAR_ALIAS  (RXapif_CLEAR  | (1 << EXPECT_SHIFT) | UNDEF_FATAL | DISCARD)
1148 #define EXISTS_ALIAS (RXapif_EXISTS | (2 << EXPECT_SHIFT))
1149 #define SCALAR_ALIAS (RXapif_SCALAR | (1 << EXPECT_SHIFT))
1150
1151 XS(XS_NamedCapture_FETCH)
1152 {
1153     dXSARGS;
1154     dXSI32;
1155     PERL_UNUSED_VAR(cv); /* -W */
1156     PERL_UNUSED_VAR(ax); /* -Wall */
1157     SP -= items;
1158     {
1159         REGEXP *const rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1160         U32 flags;
1161         SV *ret;
1162         const U32 action = ix & ACTION_MASK;
1163         const int expect = ix >> EXPECT_SHIFT;
1164         if (items != expect)
1165             croak_xs_usage(cv, expect == 2 ? "$key"
1166                                            : (expect == 3 ? "$key, $value"
1167                                                           : ""));
1168
1169         if (!rx || !SvROK(ST(0))) {
1170             if (ix & UNDEF_FATAL)
1171                 Perl_croak_no_modify();
1172             else
1173                 XSRETURN_UNDEF;
1174         }
1175
1176         flags = (U32)SvUV(SvRV(MUTABLE_SV(ST(0))));
1177
1178         PUTBACK;
1179         ret = RX_ENGINE(rx)->named_buff(aTHX_ (rx), expect >= 2 ? ST(1) : NULL,
1180                                     expect >= 3 ? ST(2) : NULL, flags | action);
1181         SPAGAIN;
1182
1183         if (ix & DISCARD) {
1184             /* Called with G_DISCARD, so our return stack state is thrown away.
1185                Hence if we were returned anything, free it immediately.  */
1186             SvREFCNT_dec(ret);
1187         } else {
1188             PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef);
1189         }
1190         PUTBACK;
1191         return;
1192     }
1193 }
1194
1195
1196 XS(XS_NamedCapture_FIRSTKEY)
1197 {
1198     dXSARGS;
1199     dXSI32;
1200     PERL_UNUSED_VAR(cv); /* -W */
1201     PERL_UNUSED_VAR(ax); /* -Wall */
1202     SP -= items;
1203     {
1204         REGEXP *const rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1205         U32 flags;
1206         SV *ret;
1207         const int expect = ix ? 2 : 1;
1208         const U32 action = ix ? RXapif_NEXTKEY : RXapif_FIRSTKEY;
1209         if (items != expect)
1210             croak_xs_usage(cv, expect == 2 ? "$lastkey" : "");
1211
1212         if (!rx || !SvROK(ST(0)))
1213             XSRETURN_UNDEF;
1214
1215         flags = (U32)SvUV(SvRV(MUTABLE_SV(ST(0))));
1216
1217         PUTBACK;
1218         ret = RX_ENGINE(rx)->named_buff_iter(aTHX_ (rx),
1219                                              expect >= 2 ? ST(1) : NULL,
1220                                              flags | action);
1221         SPAGAIN;
1222
1223         PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef);
1224         PUTBACK;
1225         return;
1226     }
1227 }
1228
1229 /* is this still needed? */
1230 XS(XS_NamedCapture_flags)
1231 {
1232     dXSARGS;
1233     PERL_UNUSED_VAR(cv); /* -W */
1234     PERL_UNUSED_VAR(ax); /* -Wall */
1235     SP -= items;
1236     {
1237         EXTEND(SP, 2);
1238         mPUSHu(RXapif_ONE);
1239         mPUSHu(RXapif_ALL);
1240         PUTBACK;
1241         return;
1242     }
1243 }
1244
1245 #include "vutil.h"
1246 #include "vxs.inc"
1247
1248 struct xsub_details {
1249     const char *name;
1250     XSUBADDR_t xsub;
1251     const char *proto;
1252     int ix;
1253 };
1254
1255 static const struct xsub_details these_details[] = {
1256     {"UNIVERSAL::isa", XS_UNIVERSAL_isa, NULL, 0 },
1257     {"UNIVERSAL::can", XS_UNIVERSAL_can, NULL, 0 },
1258     {"UNIVERSAL::DOES", XS_UNIVERSAL_DOES, NULL, 0 },
1259 #define VXS_XSUB_DETAILS
1260 #include "vxs.inc"
1261 #undef VXS_XSUB_DETAILS
1262     {"utf8::is_utf8", XS_utf8_is_utf8, NULL, 0 },
1263     {"utf8::valid", XS_utf8_valid, NULL, 0 },
1264     {"utf8::encode", XS_utf8_encode, NULL, 0 },
1265     {"utf8::decode", XS_utf8_decode, NULL, 0 },
1266     {"utf8::upgrade", XS_utf8_upgrade, NULL, 0 },
1267     {"utf8::downgrade", XS_utf8_downgrade, NULL, 0 },
1268     {"utf8::native_to_unicode", XS_utf8_native_to_unicode, NULL, 0 },
1269     {"utf8::unicode_to_native", XS_utf8_unicode_to_native, NULL, 0 },
1270     {"Internals::SvREADONLY", XS_Internals_SvREADONLY, "\\[$%@];$", 0 },
1271     {"Internals::SvREFCNT", XS_Internals_SvREFCNT, "\\[$%@];$", 0 },
1272     {"Internals::hv_clear_placeholders", XS_Internals_hv_clear_placehold, "\\%", 0 },
1273     {"constant::_make_const", XS_constant__make_const, "\\[$@]", 0 },
1274     {"PerlIO::get_layers", XS_PerlIO_get_layers, "*;@", 0 },
1275     {"re::is_regexp", XS_re_is_regexp, "$", 0 },
1276     {"re::regname", XS_re_regname, ";$$", 0 },
1277     {"re::regnames", XS_re_regnames, ";$", 0 },
1278     {"re::regnames_count", XS_re_regnames_count, "", 0 },
1279     {"re::regexp_pattern", XS_re_regexp_pattern, "$", 0 },
1280 #if defined(HAS_GETCWD) && defined(PERL_IS_MINIPERL)
1281     {"Internals::getcwd", XS_Internals_getcwd, "", 0 },
1282 #endif
1283     {"Tie::Hash::NamedCapture::_tie_it", XS_NamedCapture_tie_it, NULL, 0 },
1284     {"Tie::Hash::NamedCapture::TIEHASH", XS_NamedCapture_TIEHASH, NULL, 0 },
1285     {"Tie::Hash::NamedCapture::FETCH", XS_NamedCapture_FETCH, NULL, FETCH_ALIAS },
1286     {"Tie::Hash::NamedCapture::STORE", XS_NamedCapture_FETCH, NULL, STORE_ALIAS },
1287     {"Tie::Hash::NamedCapture::DELETE", XS_NamedCapture_FETCH, NULL, DELETE_ALIAS },
1288     {"Tie::Hash::NamedCapture::CLEAR", XS_NamedCapture_FETCH, NULL, CLEAR_ALIAS },
1289     {"Tie::Hash::NamedCapture::EXISTS", XS_NamedCapture_FETCH, NULL, EXISTS_ALIAS },
1290     {"Tie::Hash::NamedCapture::SCALAR", XS_NamedCapture_FETCH, NULL, SCALAR_ALIAS },
1291     {"Tie::Hash::NamedCapture::FIRSTKEY", XS_NamedCapture_FIRSTKEY, NULL, 0 },
1292     {"Tie::Hash::NamedCapture::NEXTKEY", XS_NamedCapture_FIRSTKEY, NULL, 1 },
1293     {"Tie::Hash::NamedCapture::flags", XS_NamedCapture_flags, NULL, 0 },
1294 };
1295
1296 STATIC OP*
1297 optimize_out_native_convert_function(pTHX_ OP* entersubop,
1298                                            GV* namegv,
1299                                            SV* protosv)
1300 {
1301     /* Optimizes out an identity function, i.e., one that just returns its
1302      * argument.  The passed in function is assumed to be an identity function,
1303      * with no checking.  This is designed to be called for utf8_to_native()
1304      * and native_to_utf8() on ASCII platforms, as they just return their
1305      * arguments, but it could work on any such function.
1306      *
1307      * The code is mostly just cargo-culted from Memoize::Lift */
1308
1309     OP *pushop, *argop;
1310     OP *parent;
1311     SV* prototype = newSVpvs("$");
1312
1313     PERL_UNUSED_ARG(protosv);
1314
1315     assert(entersubop->op_type == OP_ENTERSUB);
1316
1317     entersubop = ck_entersub_args_proto(entersubop, namegv, prototype);
1318     parent = entersubop;
1319
1320     SvREFCNT_dec(prototype);
1321
1322     pushop = cUNOPx(entersubop)->op_first;
1323     if (! OpHAS_SIBLING(pushop)) {
1324         parent = pushop;
1325         pushop = cUNOPx(pushop)->op_first;
1326     }
1327     argop = OpSIBLING(pushop);
1328
1329     /* Carry on without doing the optimization if it is not something we're
1330      * expecting, so continues to work */
1331     if (   ! argop
1332         || ! OpHAS_SIBLING(argop)
1333         ||   OpHAS_SIBLING(OpSIBLING(argop))
1334     ) {
1335         return entersubop;
1336     }
1337
1338     /* cut argop from the subtree */
1339     (void)op_sibling_splice(parent, pushop, 1, NULL);
1340
1341     op_free(entersubop);
1342     return argop;
1343 }
1344
1345 void
1346 Perl_boot_core_UNIVERSAL(pTHX)
1347 {
1348     static const char file[] = __FILE__;
1349     const struct xsub_details *xsub = these_details;
1350     const struct xsub_details *end = C_ARRAY_END(these_details);
1351
1352     do {
1353         CV *cv = newXS_flags(xsub->name, xsub->xsub, file, xsub->proto, 0);
1354         XSANY.any_i32 = xsub->ix;
1355     } while (++xsub < end);
1356
1357 #ifndef EBCDIC
1358     { /* On ASCII platforms these functions just return their argument, so can
1359          be optimized away */
1360
1361         CV* to_native_cv = get_cv("utf8::unicode_to_native", 0);
1362         CV* to_unicode_cv = get_cv("utf8::native_to_unicode", 0);
1363
1364         cv_set_call_checker_flags(to_native_cv,
1365                             optimize_out_native_convert_function,
1366                             (SV*) to_native_cv, 0);
1367         cv_set_call_checker_flags(to_unicode_cv,
1368                             optimize_out_native_convert_function,
1369                             (SV*) to_unicode_cv, 0);
1370     }
1371 #endif
1372
1373     /* Providing a Regexp::DESTROY fixes #21347. See test in t/op/ref.t  */
1374     {
1375         CV * const cv =
1376             newCONSTSUB(get_hv("Regexp::", GV_ADD), "DESTROY", NULL);
1377         char ** cvfile = &CvFILE(cv);
1378         char * oldfile = *cvfile;
1379         CvDYNFILE_off(cv);
1380         *cvfile = (char *)file;
1381         Safefree(oldfile);
1382     }
1383 }
1384
1385 /*
1386  * ex: set ts=8 sts=4 sw=4 et:
1387  */