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(sv_2mortal(vnormal(req))),
 396                        SVfARG(sv_2mortal(vnormal(sv))));
 397             } else {
 398                 Perl_croak(aTHX_ "%s version %"SVf" required--"
 399                        "this is only version %"SVf"", HvNAME_get(pkg),
 400                        SVfARG(sv_2mortal(vstringify(req))),
 401                        SVfARG(sv_2mortal(vstringify(sv))));
 402             }
 403         }
 404
 405     }
 406
 407     if ( SvOK(sv) && sv_derived_from(sv, "version") ) {
 408         ST(0) = sv_2mortal(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 = ST(0);
 460
 461           if (sv_derived_from(lobj, "version") && SvROK(lobj)) {
 462                lobj = SvRV(lobj);
 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 = ST(0);
 483
 484           if (sv_derived_from(lobj, "version") && SvROK(lobj)) {
 485                lobj = SvRV(lobj);
 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 = ST(0);
 506
 507           if (sv_derived_from(lobj, "version") && SvROK(lobj)) {
 508                lobj = SvRV(lobj);
 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 = ST(0);
 529
 530           if (sv_derived_from(lobj, "version") && SvROK(lobj)) {
 531                lobj = SvRV(lobj);
 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_flags("0", SVs_TEMP));
 545                     sv_2mortal(robj);
 546                }
 547                rvs = SvRV(robj);
 548
 549                if ( swap )
 550                {
 551                     rs = newSViv(vcmp(rvs,lobj));
 552                }
 553                else
 554                {
 555                     rs = newSViv(vcmp(lobj,rvs));
 556                }
 557
 558                mPUSHs(rs);
 559           }
 560
 561           PUTBACK;
 562           return;
 563      }
 564 }
 565
 566 XS(XS_version_boolean)
 567 {
 568     dVAR;
 569     dXSARGS;
 570     if (items < 1)
 571         croak_xs_usage(cv, "lobj, ...");
 572     SP -= items;
 573     if (sv_derived_from(ST(0), "version") && SvROK(ST(0))) {
 574         SV * const lobj = SvRV(ST(0));
 575         SV * const rs = newSViv( vcmp(lobj,new_version(newSVpvs("0"))) );
 576         mPUSHs(rs);
 577         PUTBACK;
 578         return;
 579     }
 580     else
 581         Perl_croak(aTHX_ "lobj is not of type version");
 582 }
 583
 584 XS(XS_version_noop)
 585 {
 586     dVAR;
 587     dXSARGS;
 588     if (items < 1)
 589         croak_xs_usage(cv, "lobj, ...");
 590     if (sv_derived_from(ST(0), "version") && SvROK(ST(0)))
 591         Perl_croak(aTHX_ "operation not supported with version object");
 592     else
 593         Perl_croak(aTHX_ "lobj is not of type version");
 594 #ifndef HASATTRIBUTE_NORETURN
 595     XSRETURN_EMPTY;
 596 #endif
 597 }
 598
 599 XS(XS_version_is_alpha)
 600 {
 601     dVAR;
 602     dXSARGS;
 603     if (items != 1)
 604         croak_xs_usage(cv, "lobj");
 605     SP -= items;
 606     if (sv_derived_from(ST(0), "version") && SvROK(ST(0))) {
 607         SV * const lobj = ST(0);
 608         if ( hv_exists(MUTABLE_HV(SvRV(lobj)), "alpha", 5 ) )
 609             XSRETURN_YES;
 610         else
 611             XSRETURN_NO;
 612         PUTBACK;
 613         return;
 614     }
 615     else
 616         Perl_croak(aTHX_ "lobj is not of type version");
 617 }
 618
 619 XS(XS_version_qv)
 620 {
 621     dVAR;
 622     dXSARGS;
 623     PERL_UNUSED_ARG(cv);
 624     SP -= items;
 625     {
 626         SV * ver = ST(0);
 627         SV * rv;
 628         const char * classname = "";
 629         if ( items == 2 && SvOK(ST(1)) ) {
 630             /* getting called as object or class method */
 631             ver = ST(1);
 632             classname =
 633                 sv_isobject(ST(0)) /* class called as an object method */
 634                     ? HvNAME_get(SvSTASH(SvRV(ST(0))))
 635                     : (char *)SvPV_nolen(ST(0));
 636         }
 637         if ( !SvVOK(ver) ) { /* not already a v-string */
 638             rv = sv_newmortal();
 639             sv_setsv(rv,ver); /* make a duplicate */
 640             upg_version(rv, TRUE);
 641         } else {
 642             rv = sv_2mortal(new_version(ver));
 643         }
 644         if ( items == 2 && strcmp(classname,"version") ) { /* inherited new() */
 645             sv_bless(rv, gv_stashpv(classname, GV_ADD));
 646         }
 647         PUSHs(rv);
 648     }
 649     PUTBACK;
 650     return;
 651 }
 652
 653 XS(XS_version_is_qv)
 654 {
 655     dVAR;
 656     dXSARGS;
 657     if (items != 1)
 658         croak_xs_usage(cv, "lobj");
 659     SP -= items;
 660     if (sv_derived_from(ST(0), "version") && SvROK(ST(0))) {
 661         SV * const lobj = ST(0);
 662         if ( hv_exists(MUTABLE_HV(SvRV(lobj)), "qv", 2 ) )
 663             XSRETURN_YES;
 664         else
 665             XSRETURN_NO;
 666         PUTBACK;
 667         return;
 668     }
 669     else
 670         Perl_croak(aTHX_ "lobj is not of type version");
 671 }
 672
 673 XS(XS_utf8_is_utf8)
 674 {
 675      dVAR;
 676      dXSARGS;
 677      if (items != 1)
 678          croak_xs_usage(cv, "sv");
 679      else {
 680         SV * const sv = ST(0);
 681         SvGETMAGIC(sv);
 682             if (SvUTF8(sv))
 683                 XSRETURN_YES;
 684             else
 685                 XSRETURN_NO;
 686      }
 687      XSRETURN_EMPTY;
 688 }
 689
 690 XS(XS_utf8_valid)
 691 {
 692      dVAR;
 693      dXSARGS;
 694      if (items != 1)
 695          croak_xs_usage(cv, "sv");
 696     else {
 697         SV * const sv = ST(0);
 698         STRLEN len;
 699         const char * const s = SvPV_const(sv,len);
 700         if (!SvUTF8(sv) || is_utf8_string((const U8*)s,len))
 701             XSRETURN_YES;
 702         else
 703             XSRETURN_NO;
 704     }
 705      XSRETURN_EMPTY;
 706 }
 707
 708 XS(XS_utf8_encode)
 709 {
 710     dVAR;
 711     dXSARGS;
 712     if (items != 1)
 713         croak_xs_usage(cv, "sv");
 714     sv_utf8_encode(ST(0));
 715     XSRETURN_EMPTY;
 716 }
 717
 718 XS(XS_utf8_decode)
 719 {
 720     dVAR;
 721     dXSARGS;
 722     if (items != 1)
 723         croak_xs_usage(cv, "sv");
 724     else {
 725         SV * const sv = ST(0);
 726         const bool RETVAL = sv_utf8_decode(sv);
 727         ST(0) = boolSV(RETVAL);
 728         sv_2mortal(ST(0));
 729     }
 730     XSRETURN(1);
 731 }
 732
 733 XS(XS_utf8_upgrade)
 734 {
 735     dVAR;
 736     dXSARGS;
 737     if (items != 1)
 738         croak_xs_usage(cv, "sv");
 739     else {
 740         SV * const sv = ST(0);
 741         STRLEN  RETVAL;
 742         dXSTARG;
 743
 744         RETVAL = sv_utf8_upgrade(sv);
 745         XSprePUSH; PUSHi((IV)RETVAL);
 746     }
 747     XSRETURN(1);
 748 }
 749
 750 XS(XS_utf8_downgrade)
 751 {
 752     dVAR;
 753     dXSARGS;
 754     if (items < 1 || items > 2)
 755         croak_xs_usage(cv, "sv, failok=0");
 756     else {
 757         SV * const sv = ST(0);
 758         const bool failok = (items < 2) ? 0 : (int)SvIV(ST(1));
 759         const bool RETVAL = sv_utf8_downgrade(sv, failok);
 760
 761         ST(0) = boolSV(RETVAL);
 762         sv_2mortal(ST(0));
 763     }
 764     XSRETURN(1);
 765 }
 766
 767 XS(XS_utf8_native_to_unicode)
 768 {
 769  dVAR;
 770  dXSARGS;
 771  const UV uv = SvUV(ST(0));
 772
 773  if (items > 1)
 774      croak_xs_usage(cv, "sv");
 775
 776  ST(0) = sv_2mortal(newSViv(NATIVE_TO_UNI(uv)));
 777  XSRETURN(1);
 778 }
 779
 780 XS(XS_utf8_unicode_to_native)
 781 {
 782  dVAR;
 783  dXSARGS;
 784  const UV uv = SvUV(ST(0));
 785
 786  if (items > 1)
 787      croak_xs_usage(cv, "sv");
 788
 789  ST(0) = sv_2mortal(newSViv(UNI_TO_NATIVE(uv)));
 790  XSRETURN(1);
 791 }
 792
 793 XS(XS_Internals_SvREADONLY)     /* This is dangerous stuff. */
 794 {
 795     dVAR;
 796     dXSARGS;
 797     SV * const svz = ST(0);
 798     SV * sv;
 799     PERL_UNUSED_ARG(cv);
 800
 801     /* [perl #77776] - called as &foo() not foo() */
 802     if (!SvROK(svz))
 803         croak_xs_usage(cv, "SCALAR[, ON]");
 804
 805     sv = SvRV(svz);
 806
 807     if (items == 1) {
 808          if (SvREADONLY(sv))
 809              XSRETURN_YES;
 810          else
 811              XSRETURN_NO;
 812     }
 813     else if (items == 2) {
 814         if (SvTRUE(ST(1))) {
 815             SvREADONLY_on(sv);
 816             XSRETURN_YES;
 817         }
 818         else {
 819             /* I hope you really know what you are doing. */
 820             SvREADONLY_off(sv);
 821             XSRETURN_NO;
 822         }
 823     }
 824     XSRETURN_UNDEF; /* Can't happen. */
 825 }
 826
 827 XS(XS_Internals_SvREFCNT)       /* This is dangerous stuff. */
 828 {
 829     dVAR;
 830     dXSARGS;
 831     SV * const svz = ST(0);
 832     SV * sv;
 833     PERL_UNUSED_ARG(cv);
 834
 835     /* [perl #77776] - called as &foo() not foo() */
 836     if (!SvROK(svz))
 837         croak_xs_usage(cv, "SCALAR[, REFCOUNT]");
 838
 839     sv = SvRV(svz);
 840
 841     if (items == 1)
 842          XSRETURN_IV(SvREFCNT(sv) - 1); /* Minus the ref created for us. */
 843     else if (items == 2) {
 844          /* I hope you really know what you are doing. */
 845          SvREFCNT(sv) = SvIV(ST(1));
 846          XSRETURN_IV(SvREFCNT(sv));
 847     }
 848     XSRETURN_UNDEF; /* Can't happen. */
 849 }
 850
 851 XS(XS_Internals_hv_clear_placehold)
 852 {
 853     dVAR;
 854     dXSARGS;
 855
 856     if (items != 1 || !SvROK(ST(0)))
 857         croak_xs_usage(cv, "hv");
 858     else {
 859         HV * const hv = MUTABLE_HV(SvRV(ST(0)));
 860         hv_clear_placeholders(hv);
 861         XSRETURN(0);
 862     }
 863 }
 864
 865 XS(XS_PerlIO_get_layers)
 866 {
 867     dVAR;
 868     dXSARGS;
 869     if (items < 1 || items % 2 == 0)
 870         croak_xs_usage(cv, "filehandle[,args]");
 871 #ifdef USE_PERLIO
 872     {
 873         SV *    sv;
 874         GV *    gv;
 875         IO *    io;
 876         bool    input = TRUE;
 877         bool    details = FALSE;
 878
 879         if (items > 1) {
 880              SV * const *svp;
 881              for (svp = MARK + 2; svp <= SP; svp += 2) {
 882                   SV * const * const varp = svp;
 883                   SV * const * const valp = svp + 1;
 884                   STRLEN klen;
 885                   const char * const key = SvPV_const(*varp, klen);
 886
 887                   switch (*key) {
 888                   case 'i':
 889                        if (klen == 5 && memEQ(key, "input", 5)) {
 890                             input = SvTRUE(*valp);
 891                             break;
 892                        }
 893                        goto fail;
 894                   case 'o':
 895                        if (klen == 6 && memEQ(key, "output", 6)) {
 896                             input = !SvTRUE(*valp);
 897                             break;
 898                        }
 899                        goto fail;
 900                   case 'd':
 901                        if (klen == 7 && memEQ(key, "details", 7)) {
 902                             details = SvTRUE(*valp);
 903                             break;
 904                        }
 905                        goto fail;
 906                   default:
 907                   fail:
 908                        Perl_croak(aTHX_
 909                                   "get_layers: unknown argument '%s'",
 910                                   key);
 911                   }
 912              }
 913
 914              SP -= (items - 1);
 915         }
 916
 917         sv = POPs;
 918         gv = MUTABLE_GV(sv);
 919
 920         if (!isGV(sv)) {
 921              if (SvROK(sv) && isGV(SvRV(sv)))
 922                   gv = MUTABLE_GV(SvRV(sv));
 923              else if (SvPOKp(sv))
 924                   gv = gv_fetchsv(sv, 0, SVt_PVIO);
 925         }
 926
 927         if (gv && (io = GvIO(gv))) {
 928              AV* const av = PerlIO_get_layers(aTHX_ input ?
 929                                         IoIFP(io) : IoOFP(io));
 930              I32 i;
 931              const I32 last = av_len(av);
 932              I32 nitem = 0;
 933
 934              for (i = last; i >= 0; i -= 3) {
 935                   SV * const * const namsvp = av_fetch(av, i - 2, FALSE);
 936                   SV * const * const argsvp = av_fetch(av, i - 1, FALSE);
 937                   SV * const * const flgsvp = av_fetch(av, i,     FALSE);
 938
 939                   const bool namok = namsvp && *namsvp && SvPOK(*namsvp);
 940                   const bool argok = argsvp && *argsvp && SvPOK(*argsvp);
 941                   const bool flgok = flgsvp && *flgsvp && SvIOK(*flgsvp);
 942
 943                   if (details) {
 944                       /* Indents of 5? Yuck.  */
 945                       /* We know that PerlIO_get_layers creates a new SV for
 946                          the name and flags, so we can just take a reference
 947                          and "steal" it when we free the AV below.  */
 948                        XPUSHs(namok
 949                               ? sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp))
 950                               : &PL_sv_undef);
 951                        XPUSHs(argok
 952                               ? newSVpvn_flags(SvPVX_const(*argsvp),
 953                                                SvCUR(*argsvp),
 954                                                (SvUTF8(*argsvp) ? SVf_UTF8 : 0)
 955                                                | SVs_TEMP)
 956                               : &PL_sv_undef);
 957                        XPUSHs(flgok
 958                               ? sv_2mortal(SvREFCNT_inc_simple_NN(*flgsvp))
 959                               : &PL_sv_undef);
 960                        nitem += 3;
 961                   }
 962                   else {
 963                        if (namok && argok)
 964                             XPUSHs(sv_2mortal(Perl_newSVpvf(aTHX_ "%"SVf"(%"SVf")",
 965                                                  SVfARG(*namsvp),
 966                                                  SVfARG(*argsvp))));
 967                        else if (namok)
 968                            XPUSHs(sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp)));
 969                        else
 970                             XPUSHs(&PL_sv_undef);
 971                        nitem++;
 972                        if (flgok) {
 973                             const IV flags = SvIVX(*flgsvp);
 974
 975                             if (flags & PERLIO_F_UTF8) {
 976                                  XPUSHs(newSVpvs_flags("utf8", SVs_TEMP));
 977                                  nitem++;
 978                             }
 979                        }
 980                   }
 981              }
 982
 983              SvREFCNT_dec(av);
 984
 985              XSRETURN(nitem);
 986         }
 987     }
 988 #endif
 989
 990     XSRETURN(0);
 991 }
 992
 993 XS(XS_Internals_hash_seed)
 994 {
 995     dVAR;
 996     /* Using dXSARGS would also have dITEM and dSP,
 997      * which define 2 unused local variables.  */
 998     dAXMARK;
 999     PERL_UNUSED_ARG(cv);
1000     PERL_UNUSED_VAR(mark);
1001     XSRETURN_UV(PERL_HASH_SEED);
1002 }
1003
1004 XS(XS_Internals_rehash_seed)
1005 {
1006     dVAR;
1007     /* Using dXSARGS would also have dITEM and dSP,
1008      * which define 2 unused local variables.  */
1009     dAXMARK;
1010     PERL_UNUSED_ARG(cv);
1011     PERL_UNUSED_VAR(mark);
1012     XSRETURN_UV(PL_rehash_seed);
1013 }
1014
1015 XS(XS_Internals_HvREHASH)       /* Subject to change  */
1016 {
1017     dVAR;
1018     dXSARGS;
1019     PERL_UNUSED_ARG(cv);
1020     if (SvROK(ST(0))) {
1021         const HV * const hv = (const HV *) SvRV(ST(0));
1022         if (items == 1 && SvTYPE(hv) == SVt_PVHV) {
1023             if (HvREHASH(hv))
1024                 XSRETURN_YES;
1025             else
1026                 XSRETURN_NO;
1027         }
1028     }
1029     Perl_croak(aTHX_ "Internals::HvREHASH $hashref");
1030 }
1031
1032 XS(XS_re_is_regexp)
1033 {
1034     dVAR;
1035     dXSARGS;
1036     PERL_UNUSED_VAR(cv);
1037
1038     if (items != 1)
1039         croak_xs_usage(cv, "sv");
1040
1041     SP -= items;
1042
1043     if (SvRXOK(ST(0))) {
1044         XSRETURN_YES;
1045     } else {
1046         XSRETURN_NO;
1047     }
1048 }
1049
1050 XS(XS_re_regnames_count)
1051 {
1052     REGEXP *rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1053     SV * ret;
1054     dVAR;
1055     dXSARGS;
1056
1057     if (items != 0)
1058         croak_xs_usage(cv, "");
1059
1060     SP -= items;
1061
1062     if (!rx)
1063         XSRETURN_UNDEF;
1064
1065     ret = CALLREG_NAMED_BUFF_COUNT(rx);
1066
1067     SPAGAIN;
1068
1069     if (ret) {
1070         mXPUSHs(ret);
1071         PUTBACK;
1072         return;
1073     } else {
1074         XSRETURN_UNDEF;
1075     }
1076 }
1077
1078 XS(XS_re_regname)
1079 {
1080     dVAR;
1081     dXSARGS;
1082     REGEXP * rx;
1083     U32 flags;
1084     SV * ret;
1085
1086     if (items < 1 || items > 2)
1087         croak_xs_usage(cv, "name[, all ]");
1088
1089     SP -= items;
1090
1091     rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1092
1093     if (!rx)
1094         XSRETURN_UNDEF;
1095
1096     if (items == 2 && SvTRUE(ST(1))) {
1097         flags = RXapif_ALL;
1098     } else {
1099         flags = RXapif_ONE;
1100     }
1101     ret = CALLREG_NAMED_BUFF_FETCH(rx, ST(0), (flags | RXapif_REGNAME));
1102
1103     if (ret) {
1104         mXPUSHs(ret);
1105         XSRETURN(1);
1106     }
1107     XSRETURN_UNDEF;
1108 }
1109
1110
1111 XS(XS_re_regnames)
1112 {
1113     dVAR;
1114     dXSARGS;
1115     REGEXP * rx;
1116     U32 flags;
1117     SV *ret;
1118     AV *av;
1119     I32 length;
1120     I32 i;
1121     SV **entry;
1122
1123     if (items > 1)
1124         croak_xs_usage(cv, "[all]");
1125
1126     rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1127
1128     if (!rx)
1129         XSRETURN_UNDEF;
1130
1131     if (items == 1 && SvTRUE(ST(0))) {
1132         flags = RXapif_ALL;
1133     } else {
1134         flags = RXapif_ONE;
1135     }
1136
1137     SP -= items;
1138
1139     ret = CALLREG_NAMED_BUFF_ALL(rx, (flags | RXapif_REGNAMES));
1140
1141     SPAGAIN;
1142
1143     SP -= items;
1144
1145     if (!ret)
1146         XSRETURN_UNDEF;
1147
1148     av = MUTABLE_AV(SvRV(ret));
1149     length = av_len(av);
1150
1151     for (i = 0; i <= length; i++) {
1152         entry = av_fetch(av, i, FALSE);
1153
1154         if (!entry)
1155             Perl_croak(aTHX_ "NULL array element in re::regnames()");
1156
1157         mXPUSHs(SvREFCNT_inc_simple_NN(*entry));
1158     }
1159
1160     SvREFCNT_dec(ret);
1161
1162     PUTBACK;
1163     return;
1164 }
1165
1166 XS(XS_re_regexp_pattern)
1167 {
1168     dVAR;
1169     dXSARGS;
1170     REGEXP *re;
1171
1172     if (items != 1)
1173         croak_xs_usage(cv, "sv");
1174
1175     SP -= items;
1176
1177     /*
1178        Checks if a reference is a regex or not. If the parameter is
1179        not a ref, or is not the result of a qr// then returns false
1180        in scalar context and an empty list in list context.
1181        Otherwise in list context it returns the pattern and the
1182        modifiers, in scalar context it returns the pattern just as it
1183        would if the qr// was stringified normally, regardless as
1184        to the class of the variable and any strigification overloads
1185        on the object.
1186     */
1187
1188     if ((re = SvRX(ST(0)))) /* assign deliberate */
1189     {
1190         /* Houston, we have a regex! */
1191         SV *pattern;
1192
1193         if ( GIMME_V == G_ARRAY ) {
1194             STRLEN left = 0;
1195             char reflags[sizeof(INT_PAT_MODS) + 1]; /* The +1 is for the charset
1196                                                         modifier */
1197             const char *fptr;
1198             char ch;
1199             U16 match_flags;
1200
1201             /*
1202                we are in list context so stringify
1203                the modifiers that apply. We ignore "negative
1204                modifiers" in this scenario.
1205             */
1206
1207             if (RX_EXTFLAGS(re) & RXf_PMf_LOCALE) {
1208                 reflags[left++] = LOCALE_PAT_MOD;
1209             }
1210             else if (RX_EXTFLAGS(re) & RXf_PMf_UNICODE) {
1211                 reflags[left++] = UNICODE_PAT_MOD;
1212             }
1213             fptr = INT_PAT_MODS;
1214             match_flags = (U16)((RX_EXTFLAGS(re) & PMf_COMPILETIME)
1215                                     >> RXf_PMf_STD_PMMOD_SHIFT);
1216
1217             while((ch = *fptr++)) {
1218                 if(match_flags & 1) {
1219                     reflags[left++] = ch;
1220                 }
1221                 match_flags >>= 1;
1222             }
1223
1224             pattern = newSVpvn_flags(RX_PRECOMP(re),RX_PRELEN(re),
1225                                      (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP);
1226
1227             /* return the pattern and the modifiers */
1228             XPUSHs(pattern);
1229             XPUSHs(newSVpvn_flags(reflags, left, SVs_TEMP));
1230             XSRETURN(2);
1231         } else {
1232             /* Scalar, so use the string that Perl would return */
1233             /* return the pattern in (?msix:..) format */
1234 #if PERL_VERSION >= 11
1235             pattern = sv_2mortal(newSVsv(MUTABLE_SV(re)));
1236 #else
1237             pattern = newSVpvn_flags(RX_WRAPPED(re), RX_WRAPLEN(re),
1238                                      (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP);
1239 #endif
1240             XPUSHs(pattern);
1241             XSRETURN(1);
1242         }
1243     } else {
1244         /* It ain't a regexp folks */
1245         if ( GIMME_V == G_ARRAY ) {
1246             /* return the empty list */
1247             XSRETURN_UNDEF;
1248         } else {
1249             /* Because of the (?:..) wrapping involved in a
1250                stringified pattern it is impossible to get a
1251                result for a real regexp that would evaluate to
1252                false. Therefore we can return PL_sv_no to signify
1253                that the object is not a regex, this means that one
1254                can say
1255
1256                  if (regex($might_be_a_regex) eq '(?:foo)') { }
1257
1258                and not worry about undefined values.
1259             */
1260             XSRETURN_NO;
1261         }
1262     }
1263     /* NOT-REACHED */
1264 }
1265
1266 XS(XS_Tie_Hash_NamedCapture_FETCH)
1267 {
1268     dVAR;
1269     dXSARGS;
1270     REGEXP * rx;
1271     U32 flags;
1272     SV * ret;
1273
1274     if (items != 2)
1275         croak_xs_usage(cv, "$key, $flags");
1276
1277     rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1278
1279     if (!rx || !SvROK(ST(0)))
1280         XSRETURN_UNDEF;
1281
1282     SP -= items;
1283
1284     flags = (U32)SvUV(SvRV(MUTABLE_SV(ST(0))));
1285     ret = CALLREG_NAMED_BUFF_FETCH(rx, ST(1), flags);
1286
1287     SPAGAIN;
1288
1289     if (ret) {
1290         mXPUSHs(ret);
1291         PUTBACK;
1292         return;
1293     }
1294     XSRETURN_UNDEF;
1295 }
1296
1297 XS(XS_Tie_Hash_NamedCapture_STORE)
1298 {
1299     dVAR;
1300     dXSARGS;
1301     REGEXP * rx;
1302     U32 flags;
1303
1304     if (items != 3)
1305         croak_xs_usage(cv, "$key, $value, $flags");
1306
1307     rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1308
1309     if (!rx || !SvROK(ST(0))) {
1310         Perl_croak_no_modify(aTHX);
1311     }
1312
1313     SP -= items;
1314
1315     flags = (U32)SvUV(SvRV(MUTABLE_SV(ST(0))));
1316     CALLREG_NAMED_BUFF_STORE(rx,ST(1), ST(2), flags);
1317 }
1318
1319 XS(XS_Tie_Hash_NamedCapture_DELETE)
1320 {
1321     dVAR;
1322     dXSARGS;
1323     REGEXP * rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1324     U32 flags;
1325
1326     if (items != 2)
1327         croak_xs_usage(cv, "$key, $flags");
1328
1329     if (!rx || !SvROK(ST(0)))
1330         Perl_croak_no_modify(aTHX);
1331
1332     SP -= items;
1333
1334     flags = (U32)SvUV(SvRV(MUTABLE_SV(ST(0))));
1335     CALLREG_NAMED_BUFF_DELETE(rx, ST(1), flags);
1336 }
1337
1338 XS(XS_Tie_Hash_NamedCapture_CLEAR)
1339 {
1340     dVAR;
1341     dXSARGS;
1342     REGEXP * rx;
1343     U32 flags;
1344
1345     if (items != 1)
1346         croak_xs_usage(cv, "$flags");
1347
1348     rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1349
1350     if (!rx || !SvROK(ST(0)))
1351         Perl_croak_no_modify(aTHX);
1352
1353     SP -= items;
1354
1355     flags = (U32)SvUV(SvRV(MUTABLE_SV(ST(0))));
1356     CALLREG_NAMED_BUFF_CLEAR(rx, flags);
1357 }
1358
1359 XS(XS_Tie_Hash_NamedCapture_EXISTS)
1360 {
1361     dVAR;
1362     dXSARGS;
1363     REGEXP * rx;
1364     U32 flags;
1365     SV * ret;
1366
1367     if (items != 2)
1368         croak_xs_usage(cv, "$key, $flags");
1369
1370     rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1371
1372     if (!rx || !SvROK(ST(0)))
1373         XSRETURN_UNDEF;
1374
1375     SP -= items;
1376
1377     flags = (U32)SvUV(SvRV(MUTABLE_SV(ST(0))));
1378     ret = CALLREG_NAMED_BUFF_EXISTS(rx, ST(1), flags);
1379
1380     SPAGAIN;
1381
1382         XPUSHs(ret);
1383         PUTBACK;
1384         return;
1385 }
1386
1387 XS(XS_Tie_Hash_NamedCapture_FIRSTK)
1388 {
1389     dVAR;
1390     dXSARGS;
1391     REGEXP * rx;
1392     U32 flags;
1393     SV * ret;
1394
1395     if (items != 1)
1396         croak_xs_usage(cv, "");
1397
1398     rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1399
1400     if (!rx || !SvROK(ST(0)))
1401         XSRETURN_UNDEF;
1402
1403     SP -= items;
1404
1405     flags = (U32)SvUV(SvRV(MUTABLE_SV(ST(0))));
1406     ret = CALLREG_NAMED_BUFF_FIRSTKEY(rx, flags);
1407
1408     SPAGAIN;
1409
1410     if (ret) {
1411         mXPUSHs(ret);
1412         PUTBACK;
1413     } else {
1414         XSRETURN_UNDEF;
1415     }
1416
1417 }
1418
1419 XS(XS_Tie_Hash_NamedCapture_NEXTK)
1420 {
1421     dVAR;
1422     dXSARGS;
1423     REGEXP * rx;
1424     U32 flags;
1425     SV * ret;
1426
1427     if (items != 2)
1428         croak_xs_usage(cv, "$lastkey");
1429
1430     rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1431
1432     if (!rx || !SvROK(ST(0)))
1433         XSRETURN_UNDEF;
1434
1435     SP -= items;
1436
1437     flags = (U32)SvUV(SvRV(MUTABLE_SV(ST(0))));
1438     ret = CALLREG_NAMED_BUFF_NEXTKEY(rx, ST(1), flags);
1439
1440     SPAGAIN;
1441
1442     if (ret) {
1443         mXPUSHs(ret);
1444     } else {
1445         XSRETURN_UNDEF;
1446     }
1447     PUTBACK;
1448 }
1449
1450 XS(XS_Tie_Hash_NamedCapture_SCALAR)
1451 {
1452     dVAR;
1453     dXSARGS;
1454     REGEXP * rx;
1455     U32 flags;
1456     SV * ret;
1457
1458     if (items != 1)
1459         croak_xs_usage(cv, "");
1460
1461     rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1462
1463     if (!rx || !SvROK(ST(0)))
1464         XSRETURN_UNDEF;
1465
1466     SP -= items;
1467
1468     flags = (U32)SvUV(SvRV(MUTABLE_SV(ST(0))));
1469     ret = CALLREG_NAMED_BUFF_SCALAR(rx, flags);
1470
1471     SPAGAIN;
1472
1473     if (ret) {
1474         mXPUSHs(ret);
1475         PUTBACK;
1476         return;
1477     } else {
1478         XSRETURN_UNDEF;
1479     }
1480 }
1481
1482 XS(XS_Tie_Hash_NamedCapture_flags)
1483 {
1484     dVAR;
1485     dXSARGS;
1486
1487     if (items != 0)
1488         croak_xs_usage(cv, "");
1489
1490         mXPUSHu(RXapif_ONE);
1491         mXPUSHu(RXapif_ALL);
1492         PUTBACK;
1493         return;
1494 }
1495
1496 struct xsub_details {
1497     const char *name;
1498     XSUBADDR_t xsub;
1499     const char *proto;
1500 };
1501
1502 struct xsub_details details[] = {
1503     {"UNIVERSAL::isa", XS_UNIVERSAL_isa, NULL},
1504     {"UNIVERSAL::can", XS_UNIVERSAL_can, NULL},
1505     {"UNIVERSAL::DOES", XS_UNIVERSAL_DOES, NULL},
1506     {"UNIVERSAL::VERSION", XS_UNIVERSAL_VERSION, NULL},
1507     {"version::()", XS_version_noop, NULL},
1508     {"version::new", XS_version_new, NULL},
1509     {"version::parse", XS_version_new, NULL},
1510     {"version::(\"\"", XS_version_stringify, NULL},
1511     {"version::stringify", XS_version_stringify, NULL},
1512     {"version::(0+", XS_version_numify, NULL},
1513     {"version::numify", XS_version_numify, NULL},
1514     {"version::normal", XS_version_normal, NULL},
1515     {"version::(cmp", XS_version_vcmp, NULL},
1516     {"version::(<=>", XS_version_vcmp, NULL},
1517     {"version::vcmp", XS_version_vcmp, NULL},
1518     {"version::(bool", XS_version_boolean, NULL},
1519     {"version::boolean", XS_version_boolean, NULL},
1520     {"version::(nomethod", XS_version_noop, NULL},
1521     {"version::noop", XS_version_noop, NULL},
1522     {"version::is_alpha", XS_version_is_alpha, NULL},
1523     {"version::qv", XS_version_qv, NULL},
1524     {"version::declare", XS_version_qv, NULL},
1525     {"version::is_qv", XS_version_is_qv, NULL},
1526     {"utf8::is_utf8", XS_utf8_is_utf8, NULL},
1527     {"utf8::valid", XS_utf8_valid, NULL},
1528     {"utf8::encode", XS_utf8_encode, NULL},
1529     {"utf8::decode", XS_utf8_decode, NULL},
1530     {"utf8::upgrade", XS_utf8_upgrade, NULL},
1531     {"utf8::downgrade", XS_utf8_downgrade, NULL},
1532     {"utf8::native_to_unicode", XS_utf8_native_to_unicode, NULL},
1533     {"utf8::unicode_to_native", XS_utf8_unicode_to_native, NULL},
1534     {"Internals::SvREADONLY", XS_Internals_SvREADONLY, "\\[$%@];$"},
1535     {"Internals::SvREFCNT", XS_Internals_SvREFCNT, "\\[$%@];$"},
1536     {"Internals::hv_clear_placeholders", XS_Internals_hv_clear_placehold, "\\%"},
1537     {"PerlIO::get_layers", XS_PerlIO_get_layers, "*;@"},
1538     {"Internals::hash_seed", XS_Internals_hash_seed, ""},
1539     {"Internals::rehash_seed", XS_Internals_rehash_seed, ""},
1540     {"Internals::HvREHASH", XS_Internals_HvREHASH, "\\%"},
1541     {"re::is_regexp", XS_re_is_regexp, "$"},
1542     {"re::regname", XS_re_regname, ";$$"},
1543     {"re::regnames", XS_re_regnames, ";$"},
1544     {"re::regnames_count", XS_re_regnames_count, ""},
1545     {"re::regexp_pattern", XS_re_regexp_pattern, "$"},
1546     {"Tie::Hash::NamedCapture::FETCH", XS_Tie_Hash_NamedCapture_FETCH, NULL},
1547     {"Tie::Hash::NamedCapture::STORE", XS_Tie_Hash_NamedCapture_STORE, NULL},
1548     {"Tie::Hash::NamedCapture::DELETE", XS_Tie_Hash_NamedCapture_DELETE, NULL},
1549     {"Tie::Hash::NamedCapture::CLEAR", XS_Tie_Hash_NamedCapture_CLEAR, NULL},
1550     {"Tie::Hash::NamedCapture::EXISTS", XS_Tie_Hash_NamedCapture_EXISTS, NULL},
1551     {"Tie::Hash::NamedCapture::FIRSTKEY", XS_Tie_Hash_NamedCapture_FIRSTK, NULL},
1552     {"Tie::Hash::NamedCapture::NEXTKEY", XS_Tie_Hash_NamedCapture_NEXTK, NULL},
1553     {"Tie::Hash::NamedCapture::SCALAR", XS_Tie_Hash_NamedCapture_SCALAR, NULL},
1554     {"Tie::Hash::NamedCapture::flags", XS_Tie_Hash_NamedCapture_flags, NULL}
1555 };
1556
1557 void
1558 Perl_boot_core_UNIVERSAL(pTHX)
1559 {
1560     dVAR;
1561     static const char file[] = __FILE__;
1562     struct xsub_details *xsub = details;
1563     const struct xsub_details *end
1564         = details + sizeof(details) / sizeof(details[0]);
1565
1566     do {
1567         newXS_flags(xsub->name, xsub->xsub, file, xsub->proto, 0);
1568     } while (++xsub < end);
1569
1570     /* register the overloading (type 'A') magic */
1571     PL_amagic_generation++;
1572
1573     /* Providing a Regexp::DESTROY fixes #21347. See test in t/op/ref.t  */
1574     CvFILE(newCONSTSUB(get_hv("Regexp::", GV_ADD), "DESTROY", NULL))
1575         = (char *)file;
1576 }
1577
1578 /*
1579  * Local variables:
1580  * c-indentation-style: bsd
1581  * c-basic-offset: 4
1582  * indent-tabs-mode: t
1583  * End:
1584  *
1585  * ex: set ts=8 sts=4 sw=4 noet:
1586  */