universal.c

   1 /*    universal.c
   2  *
   3  *    Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
   4  *    2005, 2006, 2007, 2008 by Larry Wall and others
   5  *
   6  *    You may distribute under the terms of either the GNU General Public
   7  *    License or the Artistic License, as specified in the README file.
   8  *
   9  */
  10
  11 /*
  12  * '"The roots of those mountains must be roots indeed; there must be
  13  *   great secrets buried there which have not been discovered since the
  14  *   beginning."'                   --Gandalf, relating Gollum's history
  15  *
  16  *     [p.54 of _The Lord of the Rings_, I/ii: "The Shadow of the Past"]
  17  */
  18
  19 /* This file contains the code that implements the functions in Perl's
  20  * UNIVERSAL package, such as UNIVERSAL->can().
  21  *
  22  * It is also used to store XS functions that need to be present in
  23  * miniperl for a lack of a better place to put them. It might be
  24  * clever to move them to seperate XS files which would then be pulled
  25  * in by some to-be-written build process.
  26  */
  27
  28 #include "EXTERN.h"
  29 #define PERL_IN_UNIVERSAL_C
  30 #include "perl.h"
  31
  32 #ifdef USE_PERLIO
  33 #include "perliol.h" /* For the PERLIO_F_XXX */
  34 #endif
  35
  36 static HV *
  37 S_get_isa_hash(pTHX_ HV *const stash)
  38 {
  39     dVAR;
  40     struct mro_meta *const meta = HvMROMETA(stash);
  41
  42     PERL_ARGS_ASSERT_GET_ISA_HASH;
  43
  44     if (!meta->isa) {
  45         AV *const isa = mro_get_linear_isa(stash);
  46         if (!meta->isa) {
  47             HV *const isa_hash = newHV();
  48             /* Linearisation didn't build it for us, so do it here.  */
  49             SV *const *svp = AvARRAY(isa);
  50             SV *const *const svp_end = svp + AvFILLp(isa) + 1;
  51             const HEK *const canon_name = HvNAME_HEK(stash);
  52
  53             while (svp < svp_end) {
  54                 (void) hv_store_ent(isa_hash, *svp++, &PL_sv_undef, 0);
  55             }
  56
  57             (void) hv_common(isa_hash, NULL, HEK_KEY(canon_name),
  58                              HEK_LEN(canon_name), HEK_FLAGS(canon_name),
  59                              HV_FETCH_ISSTORE, &PL_sv_undef,
  60                              HEK_HASH(canon_name));
  61             (void) hv_store(isa_hash, "UNIVERSAL", 9, &PL_sv_undef, 0);
  62
  63             SvREADONLY_on(isa_hash);
  64
  65             meta->isa = isa_hash;
  66         }
  67     }
  68     return meta->isa;
  69 }
  70
  71 /*
  72  * Contributed by Graham Barr  <Graham.Barr@tiuk.ti.com>
  73  * The main guts of traverse_isa was actually copied from gv_fetchmeth
  74  */
  75
  76 STATIC bool
  77 S_isa_lookup(pTHX_ HV *stash, const char * const name)
  78 {
  79     dVAR;
  80     const struct mro_meta *const meta = HvMROMETA(stash);
  81     HV *const isa = meta->isa ? meta->isa : S_get_isa_hash(aTHX_ stash);
  82     STRLEN len = strlen(name);
  83     const HV *our_stash;
  84
  85     PERL_ARGS_ASSERT_ISA_LOOKUP;
  86
  87     if (hv_common(isa, NULL, name, len, 0 /* No "UTF-8" flag possible with only
  88                                              a char * argument*/,
  89                   HV_FETCH_ISEXISTS, NULL, 0)) {
  90         /* Direct name lookup worked.  */
  91         return TRUE;
  92     }
  93
  94     /* A stash/class can go by many names (ie. User == main::User), so
  95        we use the name in the stash itself, which is canonical.  */
  96     our_stash = gv_stashpvn(name, len, 0);
  97
  98     if (our_stash) {
  99         HEK *const canon_name = HvNAME_HEK(our_stash);
 100
 101         if (hv_common(isa, NULL, HEK_KEY(canon_name), HEK_LEN(canon_name),
 102                       HEK_FLAGS(canon_name),
 103                       HV_FETCH_ISEXISTS, NULL, HEK_HASH(canon_name))) {
 104             return TRUE;
 105         }
 106     }
 107
 108     return FALSE;
 109 }
 110
 111 /*
 112 =head1 SV Manipulation Functions
 113
 114 =for apidoc sv_derived_from
 115
 116 Returns a boolean indicating whether the SV is derived from the specified class
 117 I<at the C level>.  To check derivation at the Perl level, call C<isa()> as a
 118 normal Perl method.
 119
 120 =cut
 121 */
 122
 123 bool
 124 Perl_sv_derived_from(pTHX_ SV *sv, const char *const name)
 125 {
 126     dVAR;
 127     HV *stash;
 128
 129     PERL_ARGS_ASSERT_SV_DERIVED_FROM;
 130
 131     SvGETMAGIC(sv);
 132
 133     if (SvROK(sv)) {
 134         const char *type;
 135         sv = SvRV(sv);
 136         type = sv_reftype(sv,0);
 137         if (type && strEQ(type,name))
 138             return TRUE;
 139         stash = SvOBJECT(sv) ? SvSTASH(sv) : NULL;
 140     }
 141     else {
 142         stash = gv_stashsv(sv, 0);
 143     }
 144
 145     return stash ? isa_lookup(stash, name) : FALSE;
 146 }
 147
 148 /*
 149 =for apidoc sv_does
 150
 151 Returns a boolean indicating whether the SV performs a specific, named role.
 152 The SV can be a Perl object or the name of a Perl class.
 153
 154 =cut
 155 */
 156
 157 #include "XSUB.h"
 158
 159 bool
 160 Perl_sv_does(pTHX_ SV *sv, const char *const name)
 161 {
 162     const char *classname;
 163     bool does_it;
 164     SV *methodname;
 165     dSP;
 166
 167     PERL_ARGS_ASSERT_SV_DOES;
 168
 169     ENTER;
 170     SAVETMPS;
 171
 172     SvGETMAGIC(sv);
 173
 174     if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))
 175             || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv)))) {
 176         LEAVE;
 177         return FALSE;
 178     }
 179
 180     if (sv_isobject(sv)) {
 181         classname = sv_reftype(SvRV(sv),TRUE);
 182     } else {
 183         classname = SvPV_nolen(sv);
 184     }
 185
 186     if (strEQ(name,classname)) {
 187         LEAVE;
 188         return TRUE;
 189     }
 190
 191     PUSHMARK(SP);
 192     XPUSHs(sv);
 193     mXPUSHs(newSVpv(name, 0));
 194     PUTBACK;
 195
 196     methodname = newSVpvs_flags("isa", SVs_TEMP);
 197     /* ugly hack: use the SvSCREAM flag so S_method_common
 198      * can figure out we're calling DOES() and not isa(),
 199      * and report eventual errors correctly. --rgs */
 200     SvSCREAM_on(methodname);
 201     call_sv(methodname, G_SCALAR | G_METHOD);
 202     SPAGAIN;
 203
 204     does_it = SvTRUE( TOPs );
 205     FREETMPS;
 206     LEAVE;
 207
 208     return does_it;
 209 }
 210
 211 /*
 212 =for apidoc croak_xs_usage
 213
 214 A specialised variant of C<croak()> for emitting the usage message for xsubs
 215
 216     croak_xs_usage(cv, "eee_yow");
 217
 218 works out the package name and subroutine name from C<cv>, and then calls
 219 C<croak()>. Hence if C<cv> is C<&ouch::awk>, it would call C<croak> as:
 220
 221     Perl_croak(aTHX_ "Usage: %s::%s(%s)", "ouch" "awk", "eee_yow");
 222
 223 =cut
 224 */
 225
 226 void
 227 Perl_croak_xs_usage(pTHX_ const CV *const cv, const char *const params)
 228 {
 229     const GV *const gv = CvGV(cv);
 230
 231     PERL_ARGS_ASSERT_CROAK_XS_USAGE;
 232
 233     if (gv) {
 234         const char *const gvname = GvNAME(gv);
 235         const HV *const stash = GvSTASH(gv);
 236         const char *const hvname = stash ? HvNAME_get(stash) : NULL;
 237
 238         if (hvname)
 239             Perl_croak(aTHX_ "Usage: %s::%s(%s)", hvname, gvname, params);
 240         else
 241             Perl_croak(aTHX_ "Usage: %s(%s)", gvname, params);
 242     } else {
 243         /* Pants. I don't think that it should be possible to get here. */
 244         Perl_croak(aTHX_ "Usage: CODE(0x%"UVxf")(%s)", PTR2UV(cv), params);
 245     }
 246 }
 247
 248 XS(XS_UNIVERSAL_isa)
 249 {
 250     dVAR;
 251     dXSARGS;
 252
 253     if (items != 2)
 254         croak_xs_usage(cv, "reference, kind");
 255     else {
 256         SV * const sv = ST(0);
 257         const char *name;
 258
 259         SvGETMAGIC(sv);
 260
 261         if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))
 262                     || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv))))
 263             XSRETURN_UNDEF;
 264
 265         name = SvPV_nolen_const(ST(1));
 266
 267         ST(0) = boolSV(sv_derived_from(sv, name));
 268         XSRETURN(1);
 269     }
 270 }
 271
 272 XS(XS_UNIVERSAL_can)
 273 {
 274     dVAR;
 275     dXSARGS;
 276     SV   *sv;
 277     const char *name;
 278     SV   *rv;
 279     HV   *pkg = NULL;
 280
 281     if (items != 2)
 282         croak_xs_usage(cv, "object-ref, method");
 283
 284     sv = ST(0);
 285
 286     SvGETMAGIC(sv);
 287
 288     if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))
 289                 || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv))))
 290         XSRETURN_UNDEF;
 291
 292     name = SvPV_nolen_const(ST(1));
 293     rv = &PL_sv_undef;
 294
 295     if (SvROK(sv)) {
 296         sv = MUTABLE_SV(SvRV(sv));
 297         if (SvOBJECT(sv))
 298             pkg = SvSTASH(sv);
 299     }
 300     else {
 301         pkg = gv_stashsv(sv, 0);
 302     }
 303
 304     if (pkg) {
 305         GV * const gv = gv_fetchmethod_autoload(pkg, name, FALSE);
 306         if (gv && isGV(gv))
 307             rv = sv_2mortal(newRV(MUTABLE_SV(GvCV(gv))));
 308     }
 309
 310     ST(0) = rv;
 311     XSRETURN(1);
 312 }
 313
 314 XS(XS_UNIVERSAL_DOES)
 315 {
 316     dVAR;
 317     dXSARGS;
 318     PERL_UNUSED_ARG(cv);
 319
 320     if (items != 2)
 321         Perl_croak(aTHX_ "Usage: invocant->DOES(kind)");
 322     else {
 323         SV * const sv = ST(0);
 324         const char *name;
 325
 326         name = SvPV_nolen_const(ST(1));
 327         if (sv_does( sv, name ))
 328             XSRETURN_YES;
 329
 330         XSRETURN_NO;
 331     }
 332 }
 333
 334 XS(XS_UNIVERSAL_VERSION)
 335 {
 336     dVAR;
 337     dXSARGS;
 338     HV *pkg;
 339     GV **gvp;
 340     GV *gv;
 341     SV *sv;
 342     const char *undef;
 343     PERL_UNUSED_ARG(cv);
 344
 345     if (SvROK(ST(0))) {
 346         sv = MUTABLE_SV(SvRV(ST(0)));
 347         if (!SvOBJECT(sv))
 348             Perl_croak(aTHX_ "Cannot find version of an unblessed reference");
 349         pkg = SvSTASH(sv);
 350     }
 351     else {
 352         pkg = gv_stashsv(ST(0), 0);
 353     }
 354
 355     gvp = pkg ? (GV**)hv_fetchs(pkg, "VERSION", FALSE) : NULL;
 356
 357     if (gvp && isGV(gv = *gvp) && (sv = GvSV(gv)) && SvOK(sv)) {
 358         SV * const nsv = sv_newmortal();
 359         sv_setsv(nsv, sv);
 360         sv = nsv;
 361         if ( !sv_derived_from(sv, "version"))
 362             upg_version(sv, FALSE);
 363         undef = NULL;
 364     }
 365     else {
 366         sv = &PL_sv_undef;
 367         undef = "(undef)";
 368     }
 369
 370     if (items > 1) {
 371         SV *req = ST(1);
 372
 373         if (undef) {
 374             if (pkg) {
 375                 const char * const name = HvNAME_get(pkg);
 376                 Perl_croak(aTHX_
 377                            "%s does not define $%s::VERSION--version check failed",
 378                            name, name);
 379             } else {
 380                 Perl_croak(aTHX_
 381                              "%s defines neither package nor VERSION--version check failed",
 382                              SvPVx_nolen_const(ST(0)) );
 383              }
 384         }
 385
 386         if ( !sv_derived_from(req, "version")) {
 387             /* req may very well be R/O, so create a new object */
 388             req = sv_2mortal( new_version(req) );
 389         }
 390
 391         if ( vcmp( req, sv ) > 0 ) {
 392             if ( hv_exists(MUTABLE_HV(SvRV(req)), "qv", 2 ) ) {
 393                 Perl_croak(aTHX_ "%s version %"SVf" required--"
 394                        "this is only version %"SVf"", HvNAME_get(pkg),
 395                        SVfARG(vnormal(req)),
 396                        SVfARG(vnormal(sv)));
 397             } else {
 398                 Perl_croak(aTHX_ "%s version %"SVf" required--"
 399                        "this is only version %"SVf"", HvNAME_get(pkg),
 400                        SVfARG(vstringify(req)),
 401                        SVfARG(vstringify(sv)));
 402             }
 403         }
 404
 405     }
 406
 407     if ( SvOK(sv) && sv_derived_from(sv, "version") ) {
 408         ST(0) = vstringify(sv);
 409     } else {
 410         ST(0) = sv;
 411     }
 412
 413     XSRETURN(1);
 414 }
 415
 416 XS(XS_version_new)
 417 {
 418     dVAR;
 419     dXSARGS;
 420     if (items > 3)
 421         croak_xs_usage(cv, "class, version");
 422     SP -= items;
 423     {
 424         SV *vs = ST(1);
 425         SV *rv;
 426         const char * const classname =
 427             sv_isobject(ST(0)) /* get the class if called as an object method */
 428                 ? HvNAME(SvSTASH(SvRV(ST(0))))
 429                 : (char *)SvPV_nolen(ST(0));
 430
 431         if ( items == 1 || ! SvOK(vs) ) { /* no param or explicit undef */
 432             /* create empty object */
 433             vs = sv_newmortal();
 434             sv_setpvs(vs, "0");
 435         }
 436         else if ( items == 3 ) {
 437             vs = sv_newmortal();
 438             Perl_sv_setpvf(aTHX_ vs,"v%s",SvPV_nolen_const(ST(2)));
 439         }
 440
 441         rv = new_version(vs);
 442         if ( strcmp(classname,"version") != 0 ) /* inherited new() */
 443             sv_bless(rv, gv_stashpv(classname, GV_ADD));
 444
 445         mPUSHs(rv);
 446         PUTBACK;
 447         return;
 448     }
 449 }
 450
 451 XS(XS_version_stringify)
 452 {
 453      dVAR;
 454      dXSARGS;
 455      if (items < 1)
 456          croak_xs_usage(cv, "lobj, ...");
 457      SP -= items;
 458      {
 459           SV *  lobj;
 460
 461           if (sv_derived_from(ST(0), "version")) {
 462                lobj = SvRV(ST(0));
 463           }
 464           else
 465                Perl_croak(aTHX_ "lobj is not of type version");
 466
 467           mPUSHs(vstringify(lobj));
 468
 469           PUTBACK;
 470           return;
 471      }
 472 }
 473
 474 XS(XS_version_numify)
 475 {
 476      dVAR;
 477      dXSARGS;
 478      if (items < 1)
 479          croak_xs_usage(cv, "lobj, ...");
 480      SP -= items;
 481      {
 482           SV *  lobj;
 483
 484           if (sv_derived_from(ST(0), "version")) {
 485                lobj = SvRV(ST(0));
 486           }
 487           else
 488                Perl_croak(aTHX_ "lobj is not of type version");
 489
 490           mPUSHs(vnumify(lobj));
 491
 492           PUTBACK;
 493           return;
 494      }
 495 }
 496
 497 XS(XS_version_normal)
 498 {
 499      dVAR;
 500      dXSARGS;
 501      if (items < 1)
 502          croak_xs_usage(cv, "lobj, ...");
 503      SP -= items;
 504      {
 505           SV *  lobj;
 506
 507           if (sv_derived_from(ST(0), "version")) {
 508                lobj = SvRV(ST(0));
 509           }
 510           else
 511                Perl_croak(aTHX_ "lobj is not of type version");
 512
 513           mPUSHs(vnormal(lobj));
 514
 515           PUTBACK;
 516           return;
 517      }
 518 }
 519
 520 XS(XS_version_vcmp)
 521 {
 522      dVAR;
 523      dXSARGS;
 524      if (items < 1)
 525          croak_xs_usage(cv, "lobj, ...");
 526      SP -= items;
 527      {
 528           SV *  lobj;
 529
 530           if (sv_derived_from(ST(0), "version")) {
 531                lobj = SvRV(ST(0));
 532           }
 533           else
 534                Perl_croak(aTHX_ "lobj is not of type version");
 535
 536           {
 537                SV       *rs;
 538                SV       *rvs;
 539                SV * robj = ST(1);
 540                const IV  swap = (IV)SvIV(ST(2));
 541
 542                if ( ! sv_derived_from(robj, "version") )
 543                {
 544                     robj = new_version(SvOK(robj) ? robj : newSVpvs("0"));
 545                }
 546                rvs = SvRV(robj);
 547
 548                if ( swap )
 549                {
 550                     rs = newSViv(vcmp(rvs,lobj));
 551                }
 552                else
 553                {
 554                     rs = newSViv(vcmp(lobj,rvs));
 555                }
 556
 557                mPUSHs(rs);
 558           }
 559
 560           PUTBACK;
 561           return;
 562      }
 563 }
 564
 565 XS(XS_version_boolean)
 566 {
 567     dVAR;
 568     dXSARGS;
 569     if (items < 1)
 570         croak_xs_usage(cv, "lobj, ...");
 571     SP -= items;
 572     if (sv_derived_from(ST(0), "version")) {
 573         SV * const lobj = SvRV(ST(0));
 574         SV * const rs = newSViv( vcmp(lobj,new_version(newSVpvs("0"))) );
 575         mPUSHs(rs);
 576         PUTBACK;
 577         return;
 578     }
 579     else
 580         Perl_croak(aTHX_ "lobj is not of type version");
 581 }
 582
 583 XS(XS_version_noop)
 584 {
 585     dVAR;
 586     dXSARGS;
 587     if (items < 1)
 588         croak_xs_usage(cv, "lobj, ...");
 589     if (sv_derived_from(ST(0), "version"))
 590         Perl_croak(aTHX_ "operation not supported with version object");
 591     else
 592         Perl_croak(aTHX_ "lobj is not of type version");
 593 #ifndef HASATTRIBUTE_NORETURN
 594     XSRETURN_EMPTY;
 595 #endif
 596 }
 597
 598 XS(XS_version_is_alpha)
 599 {
 600     dVAR;
 601     dXSARGS;
 602     if (items != 1)
 603         croak_xs_usage(cv, "lobj");
 604     SP -= items;
 605     if (sv_derived_from(ST(0), "version")) {
 606         SV * const lobj = ST(0);
 607         if ( hv_exists(MUTABLE_HV(SvRV(lobj)), "alpha", 5 ) )
 608             XSRETURN_YES;
 609         else
 610             XSRETURN_NO;
 611         PUTBACK;
 612         return;
 613     }
 614     else
 615         Perl_croak(aTHX_ "lobj is not of type version");
 616 }
 617
 618 XS(XS_version_qv)
 619 {
 620     dVAR;
 621     dXSARGS;
 622     PERL_UNUSED_ARG(cv);
 623     SP -= items;
 624     {
 625         SV * ver = ST(0);
 626         SV * rv;
 627         const char * classname = "";
 628         if ( items == 2 && SvOK(ST(1)) ) {
 629             /* getting called as object or class method */
 630             ver = ST(1);
 631             classname =
 632                 sv_isobject(ST(0)) /* class called as an object method */
 633                     ? HvNAME_get(SvSTASH(SvRV(ST(0))))
 634                     : (char *)SvPV_nolen(ST(0));
 635         }
 636         if ( !SvVOK(ver) ) { /* not already a v-string */
 637             rv = sv_newmortal();
 638             sv_setsv(rv,ver); /* make a duplicate */
 639             upg_version(rv, TRUE);
 640         } else {
 641             rv = sv_2mortal(new_version(ver));
 642         }
 643         if ( items == 2 && strcmp(classname,"version") ) { /* inherited new() */
 644             sv_bless(rv, gv_stashpv(classname, GV_ADD));
 645         }
 646         PUSHs(rv);
 647     }
 648     PUTBACK;
 649     return;
 650 }
 651
 652 XS(XS_version_is_qv)
 653 {
 654     dVAR;
 655     dXSARGS;
 656     if (items != 1)
 657         croak_xs_usage(cv, "lobj");
 658     SP -= items;
 659     if (sv_derived_from(ST(0), "version")) {
 660         SV * const lobj = ST(0);
 661         if ( hv_exists(MUTABLE_HV(SvRV(lobj)), "qv", 2 ) )
 662             XSRETURN_YES;
 663         else
 664             XSRETURN_NO;
 665         PUTBACK;
 666         return;
 667     }
 668     else
 669         Perl_croak(aTHX_ "lobj is not of type version");
 670 }
 671
 672 XS(XS_utf8_is_utf8)
 673 {
 674      dVAR;
 675      dXSARGS;
 676      if (items != 1)
 677          croak_xs_usage(cv, "sv");
 678      else {
 679         SV * const sv = ST(0);
 680         SvGETMAGIC(sv);
 681             if (SvUTF8(sv))
 682                 XSRETURN_YES;
 683             else
 684                 XSRETURN_NO;
 685      }
 686      XSRETURN_EMPTY;
 687 }
 688
 689 XS(XS_utf8_valid)
 690 {
 691      dVAR;
 692      dXSARGS;
 693      if (items != 1)
 694          croak_xs_usage(cv, "sv");
 695     else {
 696         SV * const sv = ST(0);
 697         STRLEN len;
 698         const char * const s = SvPV_const(sv,len);
 699         if (!SvUTF8(sv) || is_utf8_string((const U8*)s,len))
 700             XSRETURN_YES;
 701         else
 702             XSRETURN_NO;
 703     }
 704      XSRETURN_EMPTY;
 705 }
 706
 707 XS(XS_utf8_encode)
 708 {
 709     dVAR;
 710     dXSARGS;
 711     if (items != 1)
 712         croak_xs_usage(cv, "sv");
 713     sv_utf8_encode(ST(0));
 714     XSRETURN_EMPTY;
 715 }
 716
 717 XS(XS_utf8_decode)
 718 {
 719     dVAR;
 720     dXSARGS;
 721     if (items != 1)
 722         croak_xs_usage(cv, "sv");
 723     else {
 724         SV * const sv = ST(0);
 725         const bool RETVAL = sv_utf8_decode(sv);
 726         ST(0) = boolSV(RETVAL);
 727         sv_2mortal(ST(0));
 728     }
 729     XSRETURN(1);
 730 }
 731
 732 XS(XS_utf8_upgrade)
 733 {
 734     dVAR;
 735     dXSARGS;
 736     if (items != 1)
 737         croak_xs_usage(cv, "sv");
 738     else {
 739         SV * const sv = ST(0);
 740         STRLEN  RETVAL;
 741         dXSTARG;
 742
 743         RETVAL = sv_utf8_upgrade(sv);
 744         XSprePUSH; PUSHi((IV)RETVAL);
 745     }
 746     XSRETURN(1);
 747 }
 748
 749 XS(XS_utf8_downgrade)
 750 {
 751     dVAR;
 752     dXSARGS;
 753     if (items < 1 || items > 2)
 754         croak_xs_usage(cv, "sv, failok=0");
 755     else {
 756         SV * const sv = ST(0);
 757         const bool failok = (items < 2) ? 0 : (int)SvIV(ST(1));
 758         const bool RETVAL = sv_utf8_downgrade(sv, failok);
 759
 760         ST(0) = boolSV(RETVAL);
 761         sv_2mortal(ST(0));
 762     }
 763     XSRETURN(1);
 764 }
 765
 766 XS(XS_utf8_native_to_unicode)
 767 {
 768  dVAR;
 769  dXSARGS;
 770  const UV uv = SvUV(ST(0));
 771
 772  if (items > 1)
 773      croak_xs_usage(cv, "sv");
 774
 775  ST(0) = sv_2mortal(newSViv(NATIVE_TO_UNI(uv)));
 776  XSRETURN(1);
 777 }
 778
 779 XS(XS_utf8_unicode_to_native)
 780 {
 781  dVAR;
 782  dXSARGS;
 783  const UV uv = SvUV(ST(0));
 784
 785  if (items > 1)
 786      croak_xs_usage(cv, "sv");
 787
 788  ST(0) = sv_2mortal(newSViv(UNI_TO_NATIVE(uv)));
 789  XSRETURN(1);
 790 }
 791
 792 XS(XS_Internals_SvREADONLY)     /* This is dangerous stuff. */
 793 {
 794     dVAR;
 795     dXSARGS;
 796     SV * const sv = SvRV(ST(0));
 797     PERL_UNUSED_ARG(cv);
 798
 799     if (items == 1) {
 800          if (SvREADONLY(sv))
 801              XSRETURN_YES;
 802          else
 803              XSRETURN_NO;
 804     }
 805     else if (items == 2) {
 806         if (SvTRUE(ST(1))) {
 807             SvREADONLY_on(sv);
 808             XSRETURN_YES;
 809         }
 810         else {
 811             /* I hope you really know what you are doing. */
 812             SvREADONLY_off(sv);
 813             XSRETURN_NO;
 814         }
 815     }
 816     XSRETURN_UNDEF; /* Can't happen. */
 817 }
 818
 819 XS(XS_Internals_SvREFCNT)       /* This is dangerous stuff. */
 820 {
 821     dVAR;
 822     dXSARGS;
 823     SV * const sv = SvRV(ST(0));
 824     PERL_UNUSED_ARG(cv);
 825
 826     if (items == 1)
 827          XSRETURN_IV(SvREFCNT(sv) - 1); /* Minus the ref created for us. */
 828     else if (items == 2) {
 829          /* I hope you really know what you are doing. */
 830          SvREFCNT(sv) = SvIV(ST(1));
 831          XSRETURN_IV(SvREFCNT(sv));
 832     }
 833     XSRETURN_UNDEF; /* Can't happen. */
 834 }
 835
 836 XS(XS_Internals_hv_clear_placehold)
 837 {
 838     dVAR;
 839     dXSARGS;
 840
 841     if (items != 1)
 842         croak_xs_usage(cv, "hv");
 843     else {
 844         HV * const hv = MUTABLE_HV(SvRV(ST(0)));
 845         hv_clear_placeholders(hv);
 846         XSRETURN(0);
 847     }
 848 }
 849
 850 XS(XS_PerlIO_get_layers)
 851 {
 852     dVAR;
 853     dXSARGS;
 854     if (items < 1 || items % 2 == 0)
 855         croak_xs_usage(cv, "filehandle[,args]");
 856 #ifdef USE_PERLIO
 857     {
 858         SV *    sv;
 859         GV *    gv;
 860         IO *    io;
 861         bool    input = TRUE;
 862         bool    details = FALSE;
 863
 864         if (items > 1) {
 865              SV * const *svp;
 866              for (svp = MARK + 2; svp <= SP; svp += 2) {
 867                   SV * const * const varp = svp;
 868                   SV * const * const valp = svp + 1;
 869                   STRLEN klen;
 870                   const char * const key = SvPV_const(*varp, klen);
 871
 872                   switch (*key) {
 873                   case 'i':
 874                        if (klen == 5 && memEQ(key, "input", 5)) {
 875                             input = SvTRUE(*valp);
 876                             break;
 877                        }
 878                        goto fail;
 879                   case 'o':
 880                        if (klen == 6 && memEQ(key, "output", 6)) {
 881                             input = !SvTRUE(*valp);
 882                             break;
 883                        }
 884                        goto fail;
 885                   case 'd':
 886                        if (klen == 7 && memEQ(key, "details", 7)) {
 887                             details = SvTRUE(*valp);
 888                             break;
 889                        }
 890                        goto fail;
 891                   default:
 892                   fail:
 893                        Perl_croak(aTHX_
 894                                   "get_layers: unknown argument '%s'",
 895                                   key);
 896                   }
 897              }
 898
 899              SP -= (items - 1);
 900         }
 901
 902         sv = POPs;
 903         gv = MUTABLE_GV(sv);
 904
 905         if (!isGV(sv)) {
 906              if (SvROK(sv) && isGV(SvRV(sv)))
 907                   gv = MUTABLE_GV(SvRV(sv));
 908              else if (SvPOKp(sv))
 909                   gv = gv_fetchsv(sv, 0, SVt_PVIO);
 910         }
 911
 912         if (gv && (io = GvIO(gv))) {
 913              AV* const av = PerlIO_get_layers(aTHX_ input ?
 914                                         IoIFP(io) : IoOFP(io));
 915              I32 i;
 916              const I32 last = av_len(av);
 917              I32 nitem = 0;
 918
 919              for (i = last; i >= 0; i -= 3) {
 920                   SV * const * const namsvp = av_fetch(av, i - 2, FALSE);
 921                   SV * const * const argsvp = av_fetch(av, i - 1, FALSE);
 922                   SV * const * const flgsvp = av_fetch(av, i,     FALSE);
 923
 924                   const bool namok = namsvp && *namsvp && SvPOK(*namsvp);
 925                   const bool argok = argsvp && *argsvp && SvPOK(*argsvp);
 926                   const bool flgok = flgsvp && *flgsvp && SvIOK(*flgsvp);
 927
 928                   if (details) {
 929                       /* Indents of 5? Yuck.  */
 930                       /* We know that PerlIO_get_layers creates a new SV for
 931                          the name and flags, so we can just take a reference
 932                          and "steal" it when we free the AV below.  */
 933                        XPUSHs(namok
 934                               ? sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp))
 935                               : &PL_sv_undef);
 936                        XPUSHs(argok
 937                               ? newSVpvn_flags(SvPVX_const(*argsvp),
 938                                                SvCUR(*argsvp),
 939                                                (SvUTF8(*argsvp) ? SVf_UTF8 : 0)
 940                                                | SVs_TEMP)
 941                               : &PL_sv_undef);
 942                        XPUSHs(flgok
 943                               ? sv_2mortal(SvREFCNT_inc_simple_NN(*flgsvp))
 944                               : &PL_sv_undef);
 945                        nitem += 3;
 946                   }
 947                   else {
 948                        if (namok && argok)
 949                             XPUSHs(sv_2mortal(Perl_newSVpvf(aTHX_ "%"SVf"(%"SVf")",
 950                                                  SVfARG(*namsvp),
 951                                                  SVfARG(*argsvp))));
 952                        else if (namok)
 953                            XPUSHs(sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp)));
 954                        else
 955                             XPUSHs(&PL_sv_undef);
 956                        nitem++;
 957                        if (flgok) {
 958                             const IV flags = SvIVX(*flgsvp);
 959
 960                             if (flags & PERLIO_F_UTF8) {
 961                                  XPUSHs(newSVpvs_flags("utf8", SVs_TEMP));
 962                                  nitem++;
 963                             }
 964                        }
 965                   }
 966              }
 967
 968              SvREFCNT_dec(av);
 969
 970              XSRETURN(nitem);
 971         }
 972     }
 973 #endif
 974
 975     XSRETURN(0);
 976 }
 977
 978 XS(XS_Internals_hash_seed)
 979 {
 980     dVAR;
 981     /* Using dXSARGS would also have dITEM and dSP,
 982      * which define 2 unused local variables.  */
 983     dAXMARK;
 984     PERL_UNUSED_ARG(cv);
 985     PERL_UNUSED_VAR(mark);
 986     XSRETURN_UV(PERL_HASH_SEED);
 987 }
 988
 989 XS(XS_Internals_rehash_seed)
 990 {
 991     dVAR;
 992     /* Using dXSARGS would also have dITEM and dSP,
 993      * which define 2 unused local variables.  */
 994     dAXMARK;
 995     PERL_UNUSED_ARG(cv);
 996     PERL_UNUSED_VAR(mark);
 997     XSRETURN_UV(PL_rehash_seed);
 998 }
 999
1000 XS(XS_Internals_HvREHASH)       /* Subject to change  */
1001 {
1002     dVAR;
1003     dXSARGS;
1004     PERL_UNUSED_ARG(cv);
1005     if (SvROK(ST(0))) {
1006         const HV * const hv = (const HV *) SvRV(ST(0));
1007         if (items == 1 && SvTYPE(hv) == SVt_PVHV) {
1008             if (HvREHASH(hv))
1009                 XSRETURN_YES;
1010             else
1011                 XSRETURN_NO;
1012         }
1013     }
1014     Perl_croak(aTHX_ "Internals::HvREHASH $hashref");
1015 }
1016
1017 XS(XS_re_is_regexp)
1018 {
1019     dVAR;
1020     dXSARGS;
1021     PERL_UNUSED_VAR(cv);
1022
1023     if (items != 1)
1024         croak_xs_usage(cv, "sv");
1025
1026     SP -= items;
1027
1028     if (SvRXOK(ST(0))) {
1029         XSRETURN_YES;
1030     } else {
1031         XSRETURN_NO;
1032     }
1033 }
1034
1035 XS(XS_re_regnames_count)
1036 {
1037     REGEXP *rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1038     SV * ret;
1039     dVAR;
1040     dXSARGS;
1041
1042     if (items != 0)
1043         croak_xs_usage(cv, "");
1044
1045     SP -= items;
1046
1047     if (!rx)
1048         XSRETURN_UNDEF;
1049
1050     ret = CALLREG_NAMED_BUFF_COUNT(rx);
1051
1052     SPAGAIN;
1053
1054     if (ret) {
1055         mXPUSHs(ret);
1056         PUTBACK;
1057         return;
1058     } else {
1059         XSRETURN_UNDEF;
1060     }
1061 }
1062
1063 XS(XS_re_regname)
1064 {
1065     dVAR;
1066     dXSARGS;
1067     REGEXP * rx;
1068     U32 flags;
1069     SV * ret;
1070
1071     if (items < 1 || items > 2)
1072         croak_xs_usage(cv, "name[, all ]");
1073
1074     SP -= items;
1075
1076     rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1077
1078     if (!rx)
1079         XSRETURN_UNDEF;
1080
1081     if (items == 2 && SvTRUE(ST(1))) {
1082         flags = RXapif_ALL;
1083     } else {
1084         flags = RXapif_ONE;
1085     }
1086     ret = CALLREG_NAMED_BUFF_FETCH(rx, ST(0), (flags | RXapif_REGNAME));
1087
1088     if (ret) {
1089         mXPUSHs(ret);
1090         XSRETURN(1);
1091     }
1092     XSRETURN_UNDEF;
1093 }
1094
1095
1096 XS(XS_re_regnames)
1097 {
1098     dVAR;
1099     dXSARGS;
1100     REGEXP * rx;
1101     U32 flags;
1102     SV *ret;
1103     AV *av;
1104     I32 length;
1105     I32 i;
1106     SV **entry;
1107
1108     if (items > 1)
1109         croak_xs_usage(cv, "[all]");
1110
1111     rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1112
1113     if (!rx)
1114         XSRETURN_UNDEF;
1115
1116     if (items == 1 && SvTRUE(ST(0))) {
1117         flags = RXapif_ALL;
1118     } else {
1119         flags = RXapif_ONE;
1120     }
1121
1122     SP -= items;
1123
1124     ret = CALLREG_NAMED_BUFF_ALL(rx, (flags | RXapif_REGNAMES));
1125
1126     SPAGAIN;
1127
1128     SP -= items;
1129
1130     if (!ret)
1131         XSRETURN_UNDEF;
1132
1133     av = MUTABLE_AV(SvRV(ret));
1134     length = av_len(av);
1135
1136     for (i = 0; i <= length; i++) {
1137         entry = av_fetch(av, i, FALSE);
1138
1139         if (!entry)
1140             Perl_croak(aTHX_ "NULL array element in re::regnames()");
1141
1142         mXPUSHs(SvREFCNT_inc_simple_NN(*entry));
1143     }
1144
1145     SvREFCNT_dec(ret);
1146
1147     PUTBACK;
1148     return;
1149 }
1150
1151 XS(XS_re_regexp_pattern)
1152 {
1153     dVAR;
1154     dXSARGS;
1155     REGEXP *re;
1156
1157     if (items != 1)
1158         croak_xs_usage(cv, "sv");
1159
1160     SP -= items;
1161
1162     /*
1163        Checks if a reference is a regex or not. If the parameter is
1164        not a ref, or is not the result of a qr// then returns false
1165        in scalar context and an empty list in list context.
1166        Otherwise in list context it returns the pattern and the
1167        modifiers, in scalar context it returns the pattern just as it
1168        would if the qr// was stringified normally, regardless as
1169        to the class of the variable and any strigification overloads
1170        on the object.
1171     */
1172
1173     if ((re = SvRX(ST(0)))) /* assign deliberate */
1174     {
1175         /* Houston, we have a regex! */
1176         SV *pattern;
1177         STRLEN left = 0;
1178         char reflags[sizeof(INT_PAT_MODS)];
1179
1180         if ( GIMME_V == G_ARRAY ) {
1181             /*
1182                we are in list context so stringify
1183                the modifiers that apply. We ignore "negative
1184                modifiers" in this scenario.
1185             */
1186
1187             const char *fptr = INT_PAT_MODS;
1188             char ch;
1189             U16 match_flags = (U16)((RX_EXTFLAGS(re) & PMf_COMPILETIME)
1190                                     >> RXf_PMf_STD_PMMOD_SHIFT);
1191
1192             while((ch = *fptr++)) {
1193                 if(match_flags & 1) {
1194                     reflags[left++] = ch;
1195                 }
1196                 match_flags >>= 1;
1197             }
1198
1199             pattern = newSVpvn_flags(RX_PRECOMP(re),RX_PRELEN(re),
1200                                      (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP);
1201
1202             /* return the pattern and the modifiers */
1203             XPUSHs(pattern);
1204             XPUSHs(newSVpvn_flags(reflags, left, SVs_TEMP));
1205             XSRETURN(2);
1206         } else {
1207             /* Scalar, so use the string that Perl would return */
1208             /* return the pattern in (?msix:..) format */
1209 #if PERL_VERSION >= 11
1210             pattern = sv_2mortal(newSVsv(MUTABLE_SV(re)));
1211 #else
1212             pattern = newSVpvn_flags(RX_WRAPPED(re), RX_WRAPLEN(re),
1213                                      (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP);
1214 #endif
1215             XPUSHs(pattern);
1216             XSRETURN(1);
1217         }
1218     } else {
1219         /* It ain't a regexp folks */
1220         if ( GIMME_V == G_ARRAY ) {
1221             /* return the empty list */
1222             XSRETURN_UNDEF;
1223         } else {
1224             /* Because of the (?:..) wrapping involved in a
1225                stringified pattern it is impossible to get a
1226                result for a real regexp that would evaluate to
1227                false. Therefore we can return PL_sv_no to signify
1228                that the object is not a regex, this means that one
1229                can say
1230
1231                  if (regex($might_be_a_regex) eq '(?:foo)') { }
1232
1233                and not worry about undefined values.
1234             */
1235             XSRETURN_NO;
1236         }
1237     }
1238     /* NOT-REACHED */
1239 }
1240
1241 XS(XS_Tie_Hash_NamedCapture_FETCH)
1242 {
1243     dVAR;
1244     dXSARGS;
1245     REGEXP * rx;
1246     U32 flags;
1247     SV * ret;
1248
1249     if (items != 2)
1250         croak_xs_usage(cv, "$key, $flags");
1251
1252     rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1253
1254     if (!rx || !SvROK(ST(0)))
1255         XSRETURN_UNDEF;
1256
1257     SP -= items;
1258
1259     flags = (U32)INT2PTR(IV,SvIV(SvRV(MUTABLE_SV(ST(0)))));
1260     ret = CALLREG_NAMED_BUFF_FETCH(rx, ST(1), flags);
1261
1262     SPAGAIN;
1263
1264     if (ret) {
1265         mXPUSHs(ret);
1266         PUTBACK;
1267         return;
1268     }
1269     XSRETURN_UNDEF;
1270 }
1271
1272 XS(XS_Tie_Hash_NamedCapture_STORE)
1273 {
1274     dVAR;
1275     dXSARGS;
1276     REGEXP * rx;
1277     U32 flags;
1278
1279     if (items != 3)
1280         croak_xs_usage(cv, "$key, $value, $flags");
1281
1282     rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1283
1284     if (!rx || !SvROK(ST(0))) {
1285         if (!PL_localizing)
1286             Perl_croak(aTHX_ "%s", PL_no_modify);
1287         else
1288             XSRETURN_UNDEF;
1289     }
1290
1291     SP -= items;
1292
1293     flags = (U32)INT2PTR(IV,SvIV(SvRV(MUTABLE_SV(ST(0)))));
1294     CALLREG_NAMED_BUFF_STORE(rx,ST(1), ST(2), flags);
1295 }
1296
1297 XS(XS_Tie_Hash_NamedCapture_DELETE)
1298 {
1299     dVAR;
1300     dXSARGS;
1301     REGEXP * rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1302     U32 flags;
1303
1304     if (items != 2)
1305         croak_xs_usage(cv, "$key, $flags");
1306
1307     if (!rx || !SvROK(ST(0)))
1308         Perl_croak(aTHX_ "%s", PL_no_modify);
1309
1310     SP -= items;
1311
1312     flags = (U32)INT2PTR(IV,SvIV(SvRV(MUTABLE_SV(ST(0)))));
1313     CALLREG_NAMED_BUFF_DELETE(rx, ST(1), flags);
1314 }
1315
1316 XS(XS_Tie_Hash_NamedCapture_CLEAR)
1317 {
1318     dVAR;
1319     dXSARGS;
1320     REGEXP * rx;
1321     U32 flags;
1322
1323     if (items != 1)
1324         croak_xs_usage(cv, "$flags");
1325
1326     rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1327
1328     if (!rx || !SvROK(ST(0)))
1329         Perl_croak(aTHX_ "%s", PL_no_modify);
1330
1331     SP -= items;
1332
1333     flags = (U32)INT2PTR(IV,SvIV(SvRV(MUTABLE_SV(ST(0)))));
1334     CALLREG_NAMED_BUFF_CLEAR(rx, flags);
1335 }
1336
1337 XS(XS_Tie_Hash_NamedCapture_EXISTS)
1338 {
1339     dVAR;
1340     dXSARGS;
1341     REGEXP * rx;
1342     U32 flags;
1343     SV * ret;
1344
1345     if (items != 2)
1346         croak_xs_usage(cv, "$key, $flags");
1347
1348     rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1349
1350     if (!rx || !SvROK(ST(0)))
1351         XSRETURN_UNDEF;
1352
1353     SP -= items;
1354
1355     flags = (U32)INT2PTR(IV,SvIV(SvRV(MUTABLE_SV(ST(0)))));
1356     ret = CALLREG_NAMED_BUFF_EXISTS(rx, ST(1), flags);
1357
1358     SPAGAIN;
1359
1360         XPUSHs(ret);
1361         PUTBACK;
1362         return;
1363 }
1364
1365 XS(XS_Tie_Hash_NamedCapture_FIRSTK)
1366 {
1367     dVAR;
1368     dXSARGS;
1369     REGEXP * rx;
1370     U32 flags;
1371     SV * ret;
1372
1373     if (items != 1)
1374         croak_xs_usage(cv, "");
1375
1376     rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1377
1378     if (!rx || !SvROK(ST(0)))
1379         XSRETURN_UNDEF;
1380
1381     SP -= items;
1382
1383     flags = (U32)INT2PTR(IV,SvIV(SvRV(MUTABLE_SV(ST(0)))));
1384     ret = CALLREG_NAMED_BUFF_FIRSTKEY(rx, flags);
1385
1386     SPAGAIN;
1387
1388     if (ret) {
1389         mXPUSHs(ret);
1390         PUTBACK;
1391     } else {
1392         XSRETURN_UNDEF;
1393     }
1394
1395 }
1396
1397 XS(XS_Tie_Hash_NamedCapture_NEXTK)
1398 {
1399     dVAR;
1400     dXSARGS;
1401     REGEXP * rx;
1402     U32 flags;
1403     SV * ret;
1404
1405     if (items != 2)
1406         croak_xs_usage(cv, "$lastkey");
1407
1408     rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1409
1410     if (!rx || !SvROK(ST(0)))
1411         XSRETURN_UNDEF;
1412
1413     SP -= items;
1414
1415     flags = (U32)INT2PTR(IV,SvIV(SvRV(MUTABLE_SV(ST(0)))));
1416     ret = CALLREG_NAMED_BUFF_NEXTKEY(rx, ST(1), flags);
1417
1418     SPAGAIN;
1419
1420     if (ret) {
1421         mXPUSHs(ret);
1422     } else {
1423         XSRETURN_UNDEF;
1424     }
1425     PUTBACK;
1426 }
1427
1428 XS(XS_Tie_Hash_NamedCapture_SCALAR)
1429 {
1430     dVAR;
1431     dXSARGS;
1432     REGEXP * rx;
1433     U32 flags;
1434     SV * ret;
1435
1436     if (items != 1)
1437         croak_xs_usage(cv, "");
1438
1439     rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1440
1441     if (!rx || !SvROK(ST(0)))
1442         XSRETURN_UNDEF;
1443
1444     SP -= items;
1445
1446     flags = (U32)INT2PTR(IV,SvIV(SvRV(MUTABLE_SV(ST(0)))));
1447     ret = CALLREG_NAMED_BUFF_SCALAR(rx, flags);
1448
1449     SPAGAIN;
1450
1451     if (ret) {
1452         mXPUSHs(ret);
1453         PUTBACK;
1454         return;
1455     } else {
1456         XSRETURN_UNDEF;
1457     }
1458 }
1459
1460 XS(XS_Tie_Hash_NamedCapture_flags)
1461 {
1462     dVAR;
1463     dXSARGS;
1464
1465     if (items != 0)
1466         croak_xs_usage(cv, "");
1467
1468         mXPUSHu(RXapif_ONE);
1469         mXPUSHu(RXapif_ALL);
1470         PUTBACK;
1471         return;
1472 }
1473
1474 struct xsub_details {
1475     const char *name;
1476     XSUBADDR_t xsub;
1477     const char *proto;
1478 };
1479
1480 struct xsub_details details[] = {
1481     {"UNIVERSAL::isa", XS_UNIVERSAL_isa, NULL},
1482     {"UNIVERSAL::can", XS_UNIVERSAL_can, NULL},
1483     {"UNIVERSAL::DOES", XS_UNIVERSAL_DOES, NULL},
1484     {"UNIVERSAL::VERSION", XS_UNIVERSAL_VERSION, NULL},
1485     {"version::()", XS_version_noop, NULL},
1486     {"version::new", XS_version_new, NULL},
1487     {"version::parse", XS_version_new, NULL},
1488     {"version::(\"\"", XS_version_stringify, NULL},
1489     {"version::stringify", XS_version_stringify, NULL},
1490     {"version::(0+", XS_version_numify, NULL},
1491     {"version::numify", XS_version_numify, NULL},
1492     {"version::normal", XS_version_normal, NULL},
1493     {"version::(cmp", XS_version_vcmp, NULL},
1494     {"version::(<=>", XS_version_vcmp, NULL},
1495     {"version::vcmp", XS_version_vcmp, NULL},
1496     {"version::(bool", XS_version_boolean, NULL},
1497     {"version::boolean", XS_version_boolean, NULL},
1498     {"version::(nomethod", XS_version_noop, NULL},
1499     {"version::noop", XS_version_noop, NULL},
1500     {"version::is_alpha", XS_version_is_alpha, NULL},
1501     {"version::qv", XS_version_qv, NULL},
1502     {"version::declare", XS_version_qv, NULL},
1503     {"version::is_qv", XS_version_is_qv, NULL},
1504     {"utf8::is_utf8", XS_utf8_is_utf8, NULL},
1505     {"utf8::valid", XS_utf8_valid, NULL},
1506     {"utf8::encode", XS_utf8_encode, NULL},
1507     {"utf8::decode", XS_utf8_decode, NULL},
1508     {"utf8::upgrade", XS_utf8_upgrade, NULL},
1509     {"utf8::downgrade", XS_utf8_downgrade, NULL},
1510     {"utf8::native_to_unicode", XS_utf8_native_to_unicode, NULL},
1511     {"utf8::unicode_to_native", XS_utf8_unicode_to_native, NULL},
1512     {"Internals::SvREADONLY", XS_Internals_SvREADONLY, "\\[$%@];$"},
1513     {"Internals::SvREFCNT", XS_Internals_SvREFCNT, "\\[$%@];$"},
1514     {"Internals::hv_clear_placeholders", XS_Internals_hv_clear_placehold, "\\%"},
1515     {"PerlIO::get_layers", XS_PerlIO_get_layers, "*;@"},
1516     {"Internals::hash_seed", XS_Internals_hash_seed, ""},
1517     {"Internals::rehash_seed", XS_Internals_rehash_seed, ""},
1518     {"Internals::HvREHASH", XS_Internals_HvREHASH, "\\%"},
1519     {"re::is_regexp", XS_re_is_regexp, "$"},
1520     {"re::regname", XS_re_regname, ";$$"},
1521     {"re::regnames", XS_re_regnames, ";$"},
1522     {"re::regnames_count", XS_re_regnames_count, ""},
1523     {"re::regexp_pattern", XS_re_regexp_pattern, "$"},
1524     {"Tie::Hash::NamedCapture::FETCH", XS_Tie_Hash_NamedCapture_FETCH, NULL},
1525     {"Tie::Hash::NamedCapture::STORE", XS_Tie_Hash_NamedCapture_STORE, NULL},
1526     {"Tie::Hash::NamedCapture::DELETE", XS_Tie_Hash_NamedCapture_DELETE, NULL},
1527     {"Tie::Hash::NamedCapture::CLEAR", XS_Tie_Hash_NamedCapture_CLEAR, NULL},
1528     {"Tie::Hash::NamedCapture::EXISTS", XS_Tie_Hash_NamedCapture_EXISTS, NULL},
1529     {"Tie::Hash::NamedCapture::FIRSTKEY", XS_Tie_Hash_NamedCapture_FIRSTK, NULL},
1530     {"Tie::Hash::NamedCapture::NEXTKEY", XS_Tie_Hash_NamedCapture_NEXTK, NULL},
1531     {"Tie::Hash::NamedCapture::SCALAR", XS_Tie_Hash_NamedCapture_SCALAR, NULL},
1532     {"Tie::Hash::NamedCapture::flags", XS_Tie_Hash_NamedCapture_flags, NULL}
1533 };
1534
1535 void
1536 Perl_boot_core_UNIVERSAL(pTHX)
1537 {
1538     dVAR;
1539     static const char file[] = __FILE__;
1540     struct xsub_details *xsub = details;
1541     const struct xsub_details *end
1542         = details + sizeof(details) / sizeof(details[0]);
1543
1544     do {
1545         newXS_flags(xsub->name, xsub->xsub, file, xsub->proto, 0);
1546     } while (++xsub < end);
1547
1548     /* register the overloading (type 'A') magic */
1549     PL_amagic_generation++;
1550
1551     /* Providing a Regexp::DESTROY fixes #21347. See test in t/op/ref.t  */
1552     CvFILE(newCONSTSUB(get_hv("Regexp::", GV_ADD), "DESTROY", NULL))
1553         = (char *)file;
1554 }
1555
1556 /*
1557  * Local variables:
1558  * c-indentation-style: bsd
1559  * c-basic-offset: 4
1560  * indent-tabs-mode: t
1561  * End:
1562  *
1563  * ex: set ts=8 sts=4 sw=4 noet:
1564  */