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