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 sv = SvRV(ST(0));
 798     PERL_UNUSED_ARG(cv);
 799
 800     if (items == 1) {
 801          if (SvREADONLY(sv))
 802              XSRETURN_YES;
 803          else
 804              XSRETURN_NO;
 805     }
 806     else if (items == 2) {
 807         if (SvTRUE(ST(1))) {
 808             SvREADONLY_on(sv);
 809             XSRETURN_YES;
 810         }
 811         else {
 812             /* I hope you really know what you are doing. */
 813             SvREADONLY_off(sv);
 814             XSRETURN_NO;
 815         }
 816     }
 817     XSRETURN_UNDEF; /* Can't happen. */
 818 }
 819
 820 XS(XS_Internals_SvREFCNT)       /* This is dangerous stuff. */
 821 {
 822     dVAR;
 823     dXSARGS;
 824     SV * const sv = SvRV(ST(0));
 825     PERL_UNUSED_ARG(cv);
 826
 827     if (items == 1)
 828          XSRETURN_IV(SvREFCNT(sv) - 1); /* Minus the ref created for us. */
 829     else if (items == 2) {
 830          /* I hope you really know what you are doing. */
 831          SvREFCNT(sv) = SvIV(ST(1));
 832          XSRETURN_IV(SvREFCNT(sv));
 833     }
 834     XSRETURN_UNDEF; /* Can't happen. */
 835 }
 836
 837 XS(XS_Internals_hv_clear_placehold)
 838 {
 839     dVAR;
 840     dXSARGS;
 841
 842     if (items != 1)
 843         croak_xs_usage(cv, "hv");
 844     else {
 845         HV * const hv = MUTABLE_HV(SvRV(ST(0)));
 846         hv_clear_placeholders(hv);
 847         XSRETURN(0);
 848     }
 849 }
 850
 851 XS(XS_PerlIO_get_layers)
 852 {
 853     dVAR;
 854     dXSARGS;
 855     if (items < 1 || items % 2 == 0)
 856         croak_xs_usage(cv, "filehandle[,args]");
 857 #ifdef USE_PERLIO
 858     {
 859         SV *    sv;
 860         GV *    gv;
 861         IO *    io;
 862         bool    input = TRUE;
 863         bool    details = FALSE;
 864
 865         if (items > 1) {
 866              SV * const *svp;
 867              for (svp = MARK + 2; svp <= SP; svp += 2) {
 868                   SV * const * const varp = svp;
 869                   SV * const * const valp = svp + 1;
 870                   STRLEN klen;
 871                   const char * const key = SvPV_const(*varp, klen);
 872
 873                   switch (*key) {
 874                   case 'i':
 875                        if (klen == 5 && memEQ(key, "input", 5)) {
 876                             input = SvTRUE(*valp);
 877                             break;
 878                        }
 879                        goto fail;
 880                   case 'o':
 881                        if (klen == 6 && memEQ(key, "output", 6)) {
 882                             input = !SvTRUE(*valp);
 883                             break;
 884                        }
 885                        goto fail;
 886                   case 'd':
 887                        if (klen == 7 && memEQ(key, "details", 7)) {
 888                             details = SvTRUE(*valp);
 889                             break;
 890                        }
 891                        goto fail;
 892                   default:
 893                   fail:
 894                        Perl_croak(aTHX_
 895                                   "get_layers: unknown argument '%s'",
 896                                   key);
 897                   }
 898              }
 899
 900              SP -= (items - 1);
 901         }
 902
 903         sv = POPs;
 904         gv = MUTABLE_GV(sv);
 905
 906         if (!isGV(sv)) {
 907              if (SvROK(sv) && isGV(SvRV(sv)))
 908                   gv = MUTABLE_GV(SvRV(sv));
 909              else if (SvPOKp(sv))
 910                   gv = gv_fetchsv(sv, 0, SVt_PVIO);
 911         }
 912
 913         if (gv && (io = GvIO(gv))) {
 914              AV* const av = PerlIO_get_layers(aTHX_ input ?
 915                                         IoIFP(io) : IoOFP(io));
 916              I32 i;
 917              const I32 last = av_len(av);
 918              I32 nitem = 0;
 919
 920              for (i = last; i >= 0; i -= 3) {
 921                   SV * const * const namsvp = av_fetch(av, i - 2, FALSE);
 922                   SV * const * const argsvp = av_fetch(av, i - 1, FALSE);
 923                   SV * const * const flgsvp = av_fetch(av, i,     FALSE);
 924
 925                   const bool namok = namsvp && *namsvp && SvPOK(*namsvp);
 926                   const bool argok = argsvp && *argsvp && SvPOK(*argsvp);
 927                   const bool flgok = flgsvp && *flgsvp && SvIOK(*flgsvp);
 928
 929                   if (details) {
 930                       /* Indents of 5? Yuck.  */
 931                       /* We know that PerlIO_get_layers creates a new SV for
 932                          the name and flags, so we can just take a reference
 933                          and "steal" it when we free the AV below.  */
 934                        XPUSHs(namok
 935                               ? sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp))
 936                               : &PL_sv_undef);
 937                        XPUSHs(argok
 938                               ? newSVpvn_flags(SvPVX_const(*argsvp),
 939                                                SvCUR(*argsvp),
 940                                                (SvUTF8(*argsvp) ? SVf_UTF8 : 0)
 941                                                | SVs_TEMP)
 942                               : &PL_sv_undef);
 943                        XPUSHs(flgok
 944                               ? sv_2mortal(SvREFCNT_inc_simple_NN(*flgsvp))
 945                               : &PL_sv_undef);
 946                        nitem += 3;
 947                   }
 948                   else {
 949                        if (namok && argok)
 950                             XPUSHs(sv_2mortal(Perl_newSVpvf(aTHX_ "%"SVf"(%"SVf")",
 951                                                  SVfARG(*namsvp),
 952                                                  SVfARG(*argsvp))));
 953                        else if (namok)
 954                            XPUSHs(sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp)));
 955                        else
 956                             XPUSHs(&PL_sv_undef);
 957                        nitem++;
 958                        if (flgok) {
 959                             const IV flags = SvIVX(*flgsvp);
 960
 961                             if (flags & PERLIO_F_UTF8) {
 962                                  XPUSHs(newSVpvs_flags("utf8", SVs_TEMP));
 963                                  nitem++;
 964                             }
 965                        }
 966                   }
 967              }
 968
 969              SvREFCNT_dec(av);
 970
 971              XSRETURN(nitem);
 972         }
 973     }
 974 #endif
 975
 976     XSRETURN(0);
 977 }
 978
 979 XS(XS_Internals_hash_seed)
 980 {
 981     dVAR;
 982     /* Using dXSARGS would also have dITEM and dSP,
 983      * which define 2 unused local variables.  */
 984     dAXMARK;
 985     PERL_UNUSED_ARG(cv);
 986     PERL_UNUSED_VAR(mark);
 987     XSRETURN_UV(PERL_HASH_SEED);
 988 }
 989
 990 XS(XS_Internals_rehash_seed)
 991 {
 992     dVAR;
 993     /* Using dXSARGS would also have dITEM and dSP,
 994      * which define 2 unused local variables.  */
 995     dAXMARK;
 996     PERL_UNUSED_ARG(cv);
 997     PERL_UNUSED_VAR(mark);
 998     XSRETURN_UV(PL_rehash_seed);
 999 }
1000
1001 XS(XS_Internals_HvREHASH)       /* Subject to change  */
1002 {
1003     dVAR;
1004     dXSARGS;
1005     PERL_UNUSED_ARG(cv);
1006     if (SvROK(ST(0))) {
1007         const HV * const hv = (const HV *) SvRV(ST(0));
1008         if (items == 1 && SvTYPE(hv) == SVt_PVHV) {
1009             if (HvREHASH(hv))
1010                 XSRETURN_YES;
1011             else
1012                 XSRETURN_NO;
1013         }
1014     }
1015     Perl_croak(aTHX_ "Internals::HvREHASH $hashref");
1016 }
1017
1018 XS(XS_mauve_reftype)
1019 {
1020     SV *sv;
1021     dVAR;
1022     dXSARGS;
1023     PERL_UNUSED_VAR(cv);
1024
1025     if (items != 1)
1026         croak_xs_usage(cv, "sv");
1027
1028     SP -= items;
1029     sv = (SV*)ST(0);
1030
1031     if (SvMAGICAL(sv))
1032         mg_get(sv);
1033     if (!SvROK(sv)) {
1034        XSRETURN_NO;
1035     } else {
1036         STRLEN len;
1037         char *type= (char *)sv_reftype_len(SvRV(sv),FALSE,&len);
1038         XPUSHs(sv_2mortal(newSVpv(type,len)));
1039     }
1040 }
1041
1042 XS(XS_mauve_refaddr)
1043 {
1044     SV *sv;
1045     dVAR;
1046     dXSARGS;
1047     PERL_UNUSED_VAR(cv);
1048
1049     if (items != 1)
1050         croak_xs_usage(cv, "sv");
1051
1052     SP -= items;
1053     sv = (SV*)ST(0);
1054
1055     if (SvMAGICAL(sv))
1056         mg_get(sv);
1057     if (!SvROK(sv)) {
1058        XSRETURN_NO;
1059     } else {
1060        XPUSHs(sv_2mortal(newSVuv(PTR2UV(SvRV(sv)))));
1061     }
1062 }
1063
1064 XS(XS_mauve_blessed)
1065 {
1066     SV *sv;
1067     dVAR;
1068     dXSARGS;
1069     PERL_UNUSED_VAR(cv);
1070
1071     if (items != 1)
1072         croak_xs_usage(cv, "sv");
1073
1074     SP -= items;
1075     sv = (SV*)ST(0);
1076
1077     if (SvMAGICAL(sv))
1078         mg_get(sv);
1079     if ( SvROK(sv) && SvOBJECT(SvRV(sv)) ) {
1080         STRLEN len;
1081         char *type= (char *)sv_reftype_len(SvRV(sv),TRUE,&len);
1082         XPUSHs(sv_2mortal(newSVpv(type,len)));
1083     } else {
1084         XPUSHs(sv_2mortal(newSVpv("",0)));
1085     }
1086 }
1087
1088 XS(XS_mauve_weaken)
1089 {
1090     SV *sv;
1091     dVAR;
1092     dXSARGS;
1093     PERL_UNUSED_VAR(cv);
1094
1095     if (items != 1)
1096         croak_xs_usage(cv, "sv");
1097
1098     SP -= items;
1099     sv = (SV*)ST(0);
1100
1101     if (SvMAGICAL(sv))
1102         mg_get(sv);
1103     sv_rvweaken(sv);
1104     XSRETURN_EMPTY;
1105 }
1106
1107 XS(XS_mauve_isweak)
1108 {
1109     dVAR;
1110     dXSARGS;
1111     if (items != 1)
1112        croak_xs_usage(cv,  "sv");
1113     {
1114         SV *    sv = ST(0);
1115         if (SvMAGICAL(sv))
1116             mg_get(sv);
1117         ST(0) = boolSV(SvROK(sv) && SvWEAKREF(sv));
1118         XSRETURN(1);
1119     }
1120     XSRETURN(1);
1121 }
1122
1123 XS(XS_re_is_regexp)
1124 {
1125     dVAR;
1126     dXSARGS;
1127     PERL_UNUSED_VAR(cv);
1128
1129     if (items != 1)
1130         croak_xs_usage(cv, "sv");
1131
1132     SP -= items;
1133
1134     if (SvRXOK(ST(0))) {
1135         XSRETURN_YES;
1136     } else {
1137         XSRETURN_NO;
1138     }
1139 }
1140
1141 XS(XS_re_regnames_count)
1142 {
1143     REGEXP *rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1144     SV * ret;
1145     dVAR;
1146     dXSARGS;
1147
1148     if (items != 0)
1149         croak_xs_usage(cv, "");
1150
1151     SP -= items;
1152
1153     if (!rx)
1154         XSRETURN_UNDEF;
1155
1156     ret = CALLREG_NAMED_BUFF_COUNT(rx);
1157
1158     SPAGAIN;
1159
1160     if (ret) {
1161         mXPUSHs(ret);
1162         PUTBACK;
1163         return;
1164     } else {
1165         XSRETURN_UNDEF;
1166     }
1167 }
1168
1169 XS(XS_re_regname)
1170 {
1171     dVAR;
1172     dXSARGS;
1173     REGEXP * rx;
1174     U32 flags;
1175     SV * ret;
1176
1177     if (items < 1 || items > 2)
1178         croak_xs_usage(cv, "name[, all ]");
1179
1180     SP -= items;
1181
1182     rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1183
1184     if (!rx)
1185         XSRETURN_UNDEF;
1186
1187     if (items == 2 && SvTRUE(ST(1))) {
1188         flags = RXapif_ALL;
1189     } else {
1190         flags = RXapif_ONE;
1191     }
1192     ret = CALLREG_NAMED_BUFF_FETCH(rx, ST(0), (flags | RXapif_REGNAME));
1193
1194     if (ret) {
1195         mXPUSHs(ret);
1196         XSRETURN(1);
1197     }
1198     XSRETURN_UNDEF;
1199 }
1200
1201
1202 XS(XS_re_regnames)
1203 {
1204     dVAR;
1205     dXSARGS;
1206     REGEXP * rx;
1207     U32 flags;
1208     SV *ret;
1209     AV *av;
1210     I32 length;
1211     I32 i;
1212     SV **entry;
1213
1214     if (items > 1)
1215         croak_xs_usage(cv, "[all]");
1216
1217     rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1218
1219     if (!rx)
1220         XSRETURN_UNDEF;
1221
1222     if (items == 1 && SvTRUE(ST(0))) {
1223         flags = RXapif_ALL;
1224     } else {
1225         flags = RXapif_ONE;
1226     }
1227
1228     SP -= items;
1229
1230     ret = CALLREG_NAMED_BUFF_ALL(rx, (flags | RXapif_REGNAMES));
1231
1232     SPAGAIN;
1233
1234     SP -= items;
1235
1236     if (!ret)
1237         XSRETURN_UNDEF;
1238
1239     av = MUTABLE_AV(SvRV(ret));
1240     length = av_len(av);
1241
1242     for (i = 0; i <= length; i++) {
1243         entry = av_fetch(av, i, FALSE);
1244
1245         if (!entry)
1246             Perl_croak(aTHX_ "NULL array element in re::regnames()");
1247
1248         mXPUSHs(SvREFCNT_inc_simple_NN(*entry));
1249     }
1250
1251     SvREFCNT_dec(ret);
1252
1253     PUTBACK;
1254     return;
1255 }
1256
1257 XS(XS_re_regexp_pattern)
1258 {
1259     dVAR;
1260     dXSARGS;
1261     REGEXP *re;
1262
1263     if (items != 1)
1264         croak_xs_usage(cv, "sv");
1265
1266     SP -= items;
1267
1268     /*
1269        Checks if a reference is a regex or not. If the parameter is
1270        not a ref, or is not the result of a qr// then returns false
1271        in scalar context and an empty list in list context.
1272        Otherwise in list context it returns the pattern and the
1273        modifiers, in scalar context it returns the pattern just as it
1274        would if the qr// was stringified normally, regardless as
1275        to the class of the variable and any strigification overloads
1276        on the object.
1277     */
1278
1279     if ((re = SvRX(ST(0)))) /* assign deliberate */
1280     {
1281         /* Houston, we have a regex! */
1282         SV *pattern;
1283         STRLEN left = 0;
1284         char reflags[sizeof(INT_PAT_MODS)];
1285
1286         if ( GIMME_V == G_ARRAY ) {
1287             /*
1288                we are in list context so stringify
1289                the modifiers that apply. We ignore "negative
1290                modifiers" in this scenario.
1291             */
1292
1293             const char *fptr = INT_PAT_MODS;
1294             char ch;
1295             U16 match_flags = (U16)((RX_EXTFLAGS(re) & PMf_COMPILETIME)
1296                                     >> RXf_PMf_STD_PMMOD_SHIFT);
1297
1298             while((ch = *fptr++)) {
1299                 if(match_flags & 1) {
1300                     reflags[left++] = ch;
1301                 }
1302                 match_flags >>= 1;
1303             }
1304
1305             pattern = newSVpvn_flags(RX_PRECOMP(re),RX_PRELEN(re),
1306                                      (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP);
1307
1308             /* return the pattern and the modifiers */
1309             XPUSHs(pattern);
1310             XPUSHs(newSVpvn_flags(reflags, left, SVs_TEMP));
1311             XSRETURN(2);
1312         } else {
1313             /* Scalar, so use the string that Perl would return */
1314             /* return the pattern in (?msix:..) format */
1315 #if PERL_VERSION >= 11
1316             pattern = sv_2mortal(newSVsv(MUTABLE_SV(re)));
1317 #else
1318             pattern = newSVpvn_flags(RX_WRAPPED(re), RX_WRAPLEN(re),
1319                                      (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP);
1320 #endif
1321             XPUSHs(pattern);
1322             XSRETURN(1);
1323         }
1324     } else {
1325         /* It ain't a regexp folks */
1326         if ( GIMME_V == G_ARRAY ) {
1327             /* return the empty list */
1328             XSRETURN_UNDEF;
1329         } else {
1330             /* Because of the (?:..) wrapping involved in a
1331                stringified pattern it is impossible to get a
1332                result for a real regexp that would evaluate to
1333                false. Therefore we can return PL_sv_no to signify
1334                that the object is not a regex, this means that one
1335                can say
1336
1337                  if (regex($might_be_a_regex) eq '(?:foo)') { }
1338
1339                and not worry about undefined values.
1340             */
1341             XSRETURN_NO;
1342         }
1343     }
1344     /* NOT-REACHED */
1345 }
1346
1347 XS(XS_Tie_Hash_NamedCapture_FETCH)
1348 {
1349     dVAR;
1350     dXSARGS;
1351     REGEXP * rx;
1352     U32 flags;
1353     SV * ret;
1354
1355     if (items != 2)
1356         croak_xs_usage(cv, "$key, $flags");
1357
1358     rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1359
1360     if (!rx || !SvROK(ST(0)))
1361         XSRETURN_UNDEF;
1362
1363     SP -= items;
1364
1365     flags = (U32)SvUV(SvRV(MUTABLE_SV(ST(0))));
1366     ret = CALLREG_NAMED_BUFF_FETCH(rx, ST(1), flags);
1367
1368     SPAGAIN;
1369
1370     if (ret) {
1371         mXPUSHs(ret);
1372         PUTBACK;
1373         return;
1374     }
1375     XSRETURN_UNDEF;
1376 }
1377
1378 XS(XS_Tie_Hash_NamedCapture_STORE)
1379 {
1380     dVAR;
1381     dXSARGS;
1382     REGEXP * rx;
1383     U32 flags;
1384
1385     if (items != 3)
1386         croak_xs_usage(cv, "$key, $value, $flags");
1387
1388     rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1389
1390     if (!rx || !SvROK(ST(0))) {
1391         if (!PL_localizing)
1392             Perl_croak_no_modify(aTHX);
1393         else
1394             XSRETURN_UNDEF;
1395     }
1396
1397     SP -= items;
1398
1399     flags = (U32)SvUV(SvRV(MUTABLE_SV(ST(0))));
1400     CALLREG_NAMED_BUFF_STORE(rx,ST(1), ST(2), flags);
1401 }
1402
1403 XS(XS_Tie_Hash_NamedCapture_DELETE)
1404 {
1405     dVAR;
1406     dXSARGS;
1407     REGEXP * rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1408     U32 flags;
1409
1410     if (items != 2)
1411         croak_xs_usage(cv, "$key, $flags");
1412
1413     if (!rx || !SvROK(ST(0)))
1414         Perl_croak_no_modify(aTHX);
1415
1416     SP -= items;
1417
1418     flags = (U32)SvUV(SvRV(MUTABLE_SV(ST(0))));
1419     CALLREG_NAMED_BUFF_DELETE(rx, ST(1), flags);
1420 }
1421
1422 XS(XS_Tie_Hash_NamedCapture_CLEAR)
1423 {
1424     dVAR;
1425     dXSARGS;
1426     REGEXP * rx;
1427     U32 flags;
1428
1429     if (items != 1)
1430         croak_xs_usage(cv, "$flags");
1431
1432     rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1433
1434     if (!rx || !SvROK(ST(0)))
1435         Perl_croak_no_modify(aTHX);
1436
1437     SP -= items;
1438
1439     flags = (U32)SvUV(SvRV(MUTABLE_SV(ST(0))));
1440     CALLREG_NAMED_BUFF_CLEAR(rx, flags);
1441 }
1442
1443 XS(XS_Tie_Hash_NamedCapture_EXISTS)
1444 {
1445     dVAR;
1446     dXSARGS;
1447     REGEXP * rx;
1448     U32 flags;
1449     SV * ret;
1450
1451     if (items != 2)
1452         croak_xs_usage(cv, "$key, $flags");
1453
1454     rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1455
1456     if (!rx || !SvROK(ST(0)))
1457         XSRETURN_UNDEF;
1458
1459     SP -= items;
1460
1461     flags = (U32)SvUV(SvRV(MUTABLE_SV(ST(0))));
1462     ret = CALLREG_NAMED_BUFF_EXISTS(rx, ST(1), flags);
1463
1464     SPAGAIN;
1465
1466         XPUSHs(ret);
1467         PUTBACK;
1468         return;
1469 }
1470
1471 XS(XS_Tie_Hash_NamedCapture_FIRSTK)
1472 {
1473     dVAR;
1474     dXSARGS;
1475     REGEXP * rx;
1476     U32 flags;
1477     SV * ret;
1478
1479     if (items != 1)
1480         croak_xs_usage(cv, "");
1481
1482     rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1483
1484     if (!rx || !SvROK(ST(0)))
1485         XSRETURN_UNDEF;
1486
1487     SP -= items;
1488
1489     flags = (U32)SvUV(SvRV(MUTABLE_SV(ST(0))));
1490     ret = CALLREG_NAMED_BUFF_FIRSTKEY(rx, flags);
1491
1492     SPAGAIN;
1493
1494     if (ret) {
1495         mXPUSHs(ret);
1496         PUTBACK;
1497     } else {
1498         XSRETURN_UNDEF;
1499     }
1500
1501 }
1502
1503 XS(XS_Tie_Hash_NamedCapture_NEXTK)
1504 {
1505     dVAR;
1506     dXSARGS;
1507     REGEXP * rx;
1508     U32 flags;
1509     SV * ret;
1510
1511     if (items != 2)
1512         croak_xs_usage(cv, "$lastkey");
1513
1514     rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1515
1516     if (!rx || !SvROK(ST(0)))
1517         XSRETURN_UNDEF;
1518
1519     SP -= items;
1520
1521     flags = (U32)SvUV(SvRV(MUTABLE_SV(ST(0))));
1522     ret = CALLREG_NAMED_BUFF_NEXTKEY(rx, ST(1), flags);
1523
1524     SPAGAIN;
1525
1526     if (ret) {
1527         mXPUSHs(ret);
1528     } else {
1529         XSRETURN_UNDEF;
1530     }
1531     PUTBACK;
1532 }
1533
1534 XS(XS_Tie_Hash_NamedCapture_SCALAR)
1535 {
1536     dVAR;
1537     dXSARGS;
1538     REGEXP * rx;
1539     U32 flags;
1540     SV * ret;
1541
1542     if (items != 1)
1543         croak_xs_usage(cv, "");
1544
1545     rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1546
1547     if (!rx || !SvROK(ST(0)))
1548         XSRETURN_UNDEF;
1549
1550     SP -= items;
1551
1552     flags = (U32)SvUV(SvRV(MUTABLE_SV(ST(0))));
1553     ret = CALLREG_NAMED_BUFF_SCALAR(rx, flags);
1554
1555     SPAGAIN;
1556
1557     if (ret) {
1558         mXPUSHs(ret);
1559         PUTBACK;
1560         return;
1561     } else {
1562         XSRETURN_UNDEF;
1563     }
1564 }
1565
1566 XS(XS_Tie_Hash_NamedCapture_flags)
1567 {
1568     dVAR;
1569     dXSARGS;
1570
1571     if (items != 0)
1572         croak_xs_usage(cv, "");
1573
1574         mXPUSHu(RXapif_ONE);
1575         mXPUSHu(RXapif_ALL);
1576         PUTBACK;
1577         return;
1578 }
1579
1580 struct xsub_details {
1581     const char *name;
1582     XSUBADDR_t xsub;
1583     const char *proto;
1584 };
1585
1586 struct xsub_details details[] = {
1587     {"UNIVERSAL::isa", XS_UNIVERSAL_isa, NULL},
1588     {"UNIVERSAL::can", XS_UNIVERSAL_can, NULL},
1589     {"UNIVERSAL::DOES", XS_UNIVERSAL_DOES, NULL},
1590     {"UNIVERSAL::VERSION", XS_UNIVERSAL_VERSION, NULL},
1591     {"version::()", XS_version_noop, NULL},
1592     {"version::new", XS_version_new, NULL},
1593     {"version::parse", XS_version_new, NULL},
1594     {"version::(\"\"", XS_version_stringify, NULL},
1595     {"version::stringify", XS_version_stringify, NULL},
1596     {"version::(0+", XS_version_numify, NULL},
1597     {"version::numify", XS_version_numify, NULL},
1598     {"version::normal", XS_version_normal, NULL},
1599     {"version::(cmp", XS_version_vcmp, NULL},
1600     {"version::(<=>", XS_version_vcmp, NULL},
1601     {"version::vcmp", XS_version_vcmp, NULL},
1602     {"version::(bool", XS_version_boolean, NULL},
1603     {"version::boolean", XS_version_boolean, NULL},
1604     {"version::(nomethod", XS_version_noop, NULL},
1605     {"version::noop", XS_version_noop, NULL},
1606     {"version::is_alpha", XS_version_is_alpha, NULL},
1607     {"version::qv", XS_version_qv, NULL},
1608     {"version::declare", XS_version_qv, NULL},
1609     {"version::is_qv", XS_version_is_qv, NULL},
1610     {"utf8::is_utf8", XS_utf8_is_utf8, NULL},
1611     {"utf8::valid", XS_utf8_valid, NULL},
1612     {"utf8::encode", XS_utf8_encode, NULL},
1613     {"utf8::decode", XS_utf8_decode, NULL},
1614     {"utf8::upgrade", XS_utf8_upgrade, NULL},
1615     {"utf8::downgrade", XS_utf8_downgrade, NULL},
1616     {"utf8::native_to_unicode", XS_utf8_native_to_unicode, NULL},
1617     {"utf8::unicode_to_native", XS_utf8_unicode_to_native, NULL},
1618     {"Internals::SvREADONLY", XS_Internals_SvREADONLY, "\\[$%@];$"},
1619     {"Internals::SvREFCNT", XS_Internals_SvREFCNT, "\\[$%@];$"},
1620     {"Internals::hv_clear_placeholders", XS_Internals_hv_clear_placehold, "\\%"},
1621     {"PerlIO::get_layers", XS_PerlIO_get_layers, "*;@"},
1622     {"Internals::hash_seed", XS_Internals_hash_seed, ""},
1623     {"Internals::rehash_seed", XS_Internals_rehash_seed, ""},
1624     {"Internals::HvREHASH", XS_Internals_HvREHASH, "\\%"},
1625     {"re::is_regexp", XS_re_is_regexp, "$"},
1626     {"re::regname", XS_re_regname, ";$$"},
1627     {"re::regnames", XS_re_regnames, ";$"},
1628     {"re::regnames_count", XS_re_regnames_count, ""},
1629     {"re::regexp_pattern", XS_re_regexp_pattern, "$"},
1630     {"Tie::Hash::NamedCapture::FETCH", XS_Tie_Hash_NamedCapture_FETCH, NULL},
1631     {"Tie::Hash::NamedCapture::STORE", XS_Tie_Hash_NamedCapture_STORE, NULL},
1632     {"Tie::Hash::NamedCapture::DELETE", XS_Tie_Hash_NamedCapture_DELETE, NULL},
1633     {"Tie::Hash::NamedCapture::CLEAR", XS_Tie_Hash_NamedCapture_CLEAR, NULL},
1634     {"Tie::Hash::NamedCapture::EXISTS", XS_Tie_Hash_NamedCapture_EXISTS, NULL},
1635     {"Tie::Hash::NamedCapture::FIRSTKEY", XS_Tie_Hash_NamedCapture_FIRSTK, NULL},
1636     {"Tie::Hash::NamedCapture::NEXTKEY", XS_Tie_Hash_NamedCapture_NEXTK, NULL},
1637     {"Tie::Hash::NamedCapture::SCALAR", XS_Tie_Hash_NamedCapture_SCALAR, NULL},
1638     {"Tie::Hash::NamedCapture::flags", XS_Tie_Hash_NamedCapture_flags, NULL}
1639     ,{"mauve::reftype", XS_mauve_reftype, "$"}
1640     ,{"mauve::refaddr", XS_mauve_refaddr, "$"}
1641     ,{"mauve::blessed", XS_mauve_blessed, "$"}
1642     ,{"mauve::weaken", XS_mauve_weaken, "$"}
1643     ,{"mauve::isweak", XS_mauve_isweak, "$"}
1644 };
1645
1646 void
1647 Perl_boot_core_UNIVERSAL(pTHX)
1648 {
1649     dVAR;
1650     static const char file[] = __FILE__;
1651     struct xsub_details *xsub = details;
1652     const struct xsub_details *end
1653         = details + sizeof(details) / sizeof(details[0]);
1654
1655     do {
1656         newXS_flags(xsub->name, xsub->xsub, file, xsub->proto, 0);
1657     } while (++xsub < end);
1658
1659     /* register the overloading (type 'A') magic */
1660     PL_amagic_generation++;
1661
1662     /* Providing a Regexp::DESTROY fixes #21347. See test in t/op/ref.t  */
1663     CvFILE(newCONSTSUB(get_hv("Regexp::", GV_ADD), "DESTROY", NULL))
1664         = (char *)file;
1665 }
1666
1667 /*
1668  * Local variables:
1669  * c-indentation-style: bsd
1670  * c-basic-offset: 4
1671  * indent-tabs-mode: t
1672  * End:
1673  *
1674  * ex: set ts=8 sts=4 sw=4 noet:
1675  */