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