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