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