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