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 #ifdef 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             if (SvTYPE(sv) == SVt_PVAV && AvFILLp(sv) != -1) {
 944                 /* for constant.pm; nobody else should be calling this
 945                    on arrays anyway. */
 946                 SV **svp;
 947                 for (svp = AvARRAY(sv) + AvFILLp(sv)
 948                    ; svp >= AvARRAY(sv)
 949                    ; --svp)
 950                     if (*svp) SvPADTMP_on(*svp);
 951             }
 952             XSRETURN_YES;
 953         }
 954         else {
 955             /* I hope you really know what you are doing. */
 956             SvREADONLY_off(sv);
 957             XSRETURN_NO;
 958         }
 959     }
 960     XSRETURN_UNDEF; /* Can't happen. */
 961 }
 962 XS(XS_Internals_SvREFCNT)       /* This is dangerous stuff. */
 963 {
 964     dVAR;
 965     dXSARGS;
 966     SV * const svz = ST(0);
 967     SV * sv;
 968     U32 refcnt;
 969     PERL_UNUSED_ARG(cv);
 970
 971     /* [perl #77776] - called as &foo() not foo() */
 972     if ((items != 1 && items != 2) || !SvROK(svz))
 973         croak_xs_usage(cv, "SCALAR[, REFCOUNT]");
 974
 975     sv = SvRV(svz);
 976
 977          /* I hope you really know what you are doing. */
 978     /* idea is for SvREFCNT(sv) to be accessed only once */
 979     refcnt = items == 2 ?
 980                 /* we free one ref on exit */
 981                 (SvREFCNT(sv) = SvUV(ST(1)) + 1)
 982                 : SvREFCNT(sv);
 983     XSRETURN_UV(refcnt - 1); /* Minus the ref created for us. */
 984
 985 }
 986
 987 XS(XS_Internals_hv_clear_placehold)
 988 {
 989     dVAR;
 990     dXSARGS;
 991
 992     if (items != 1 || !SvROK(ST(0)))
 993         croak_xs_usage(cv, "hv");
 994     else {
 995         HV * const hv = MUTABLE_HV(SvRV(ST(0)));
 996         hv_clear_placeholders(hv);
 997         XSRETURN(0);
 998     }
 999 }
1000
1001 XS(XS_PerlIO_get_layers)
1002 {
1003     dVAR;
1004     dXSARGS;
1005     if (items < 1 || items % 2 == 0)
1006         croak_xs_usage(cv, "filehandle[,args]");
1007 #ifdef USE_PERLIO
1008     {
1009         SV *    sv;
1010         GV *    gv;
1011         IO *    io;
1012         bool    input = TRUE;
1013         bool    details = FALSE;
1014
1015         if (items > 1) {
1016              SV * const *svp;
1017              for (svp = MARK + 2; svp <= SP; svp += 2) {
1018                   SV * const * const varp = svp;
1019                   SV * const * const valp = svp + 1;
1020                   STRLEN klen;
1021                   const char * const key = SvPV_const(*varp, klen);
1022
1023                   switch (*key) {
1024                   case 'i':
1025                        if (klen == 5 && memEQ(key, "input", 5)) {
1026                             input = SvTRUE(*valp);
1027                             break;
1028                        }
1029                        goto fail;
1030                   case 'o':
1031                        if (klen == 6 && memEQ(key, "output", 6)) {
1032                             input = !SvTRUE(*valp);
1033                             break;
1034                        }
1035                        goto fail;
1036                   case 'd':
1037                        if (klen == 7 && memEQ(key, "details", 7)) {
1038                             details = SvTRUE(*valp);
1039                             break;
1040                        }
1041                        goto fail;
1042                   default:
1043                   fail:
1044                        Perl_croak(aTHX_
1045                                   "get_layers: unknown argument '%s'",
1046                                   key);
1047                   }
1048              }
1049
1050              SP -= (items - 1);
1051         }
1052
1053         sv = POPs;
1054         gv = MAYBE_DEREF_GV(sv);
1055
1056         if (!gv && !SvROK(sv))
1057             gv = gv_fetchsv_nomg(sv, 0, SVt_PVIO);
1058
1059         if (gv && (io = GvIO(gv))) {
1060              AV* const av = PerlIO_get_layers(aTHX_ input ?
1061                                         IoIFP(io) : IoOFP(io));
1062              SSize_t i;
1063              const SSize_t last = av_len(av);
1064              SSize_t nitem = 0;
1065
1066              for (i = last; i >= 0; i -= 3) {
1067                   SV * const * const namsvp = av_fetch(av, i - 2, FALSE);
1068                   SV * const * const argsvp = av_fetch(av, i - 1, FALSE);
1069                   SV * const * const flgsvp = av_fetch(av, i,     FALSE);
1070
1071                   const bool namok = namsvp && *namsvp && SvPOK(*namsvp);
1072                   const bool argok = argsvp && *argsvp && SvPOK(*argsvp);
1073                   const bool flgok = flgsvp && *flgsvp && SvIOK(*flgsvp);
1074
1075                   EXTEND(SP, 3); /* Three is the max in all branches: better check just once */
1076                   if (details) {
1077                       /* Indents of 5? Yuck.  */
1078                       /* We know that PerlIO_get_layers creates a new SV for
1079                          the name and flags, so we can just take a reference
1080                          and "steal" it when we free the AV below.  */
1081                        PUSHs(namok
1082                               ? sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp))
1083                               : &PL_sv_undef);
1084                        PUSHs(argok
1085                               ? newSVpvn_flags(SvPVX_const(*argsvp),
1086                                                SvCUR(*argsvp),
1087                                                (SvUTF8(*argsvp) ? SVf_UTF8 : 0)
1088                                                | SVs_TEMP)
1089                               : &PL_sv_undef);
1090                        PUSHs(flgok
1091                               ? sv_2mortal(SvREFCNT_inc_simple_NN(*flgsvp))
1092                               : &PL_sv_undef);
1093                        nitem += 3;
1094                   }
1095                   else {
1096                        if (namok && argok)
1097                             PUSHs(sv_2mortal(Perl_newSVpvf(aTHX_ "%"SVf"(%"SVf")",
1098                                                  SVfARG(*namsvp),
1099                                                  SVfARG(*argsvp))));
1100                        else if (namok)
1101                             PUSHs(sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp)));
1102                        else
1103                             PUSHs(&PL_sv_undef);
1104                        nitem++;
1105                        if (flgok) {
1106                             const IV flags = SvIVX(*flgsvp);
1107
1108                             if (flags & PERLIO_F_UTF8) {
1109                                  PUSHs(newSVpvs_flags("utf8", SVs_TEMP));
1110                                  nitem++;
1111                             }
1112                        }
1113                   }
1114              }
1115
1116              SvREFCNT_dec(av);
1117
1118              XSRETURN(nitem);
1119         }
1120     }
1121 #endif
1122
1123     XSRETURN(0);
1124 }
1125
1126
1127 XS(XS_re_is_regexp)
1128 {
1129     dVAR;
1130     dXSARGS;
1131     PERL_UNUSED_VAR(cv);
1132
1133     if (items != 1)
1134         croak_xs_usage(cv, "sv");
1135
1136     if (SvRXOK(ST(0))) {
1137         XSRETURN_YES;
1138     } else {
1139         XSRETURN_NO;
1140     }
1141 }
1142
1143 XS(XS_re_regnames_count)
1144 {
1145     REGEXP *rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1146     SV * ret;
1147     dVAR;
1148     dXSARGS;
1149
1150     if (items != 0)
1151         croak_xs_usage(cv, "");
1152
1153     SP -= items;
1154     PUTBACK;
1155
1156     if (!rx)
1157         XSRETURN_UNDEF;
1158
1159     ret = CALLREG_NAMED_BUFF_COUNT(rx);
1160
1161     SPAGAIN;
1162     PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef);
1163     XSRETURN(1);
1164 }
1165
1166 XS(XS_re_regname)
1167 {
1168     dVAR;
1169     dXSARGS;
1170     REGEXP * rx;
1171     U32 flags;
1172     SV * ret;
1173
1174     if (items < 1 || items > 2)
1175         croak_xs_usage(cv, "name[, all ]");
1176
1177     SP -= items;
1178     PUTBACK;
1179
1180     rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1181
1182     if (!rx)
1183         XSRETURN_UNDEF;
1184
1185     if (items == 2 && SvTRUE(ST(1))) {
1186         flags = RXapif_ALL;
1187     } else {
1188         flags = RXapif_ONE;
1189     }
1190     ret = CALLREG_NAMED_BUFF_FETCH(rx, ST(0), (flags | RXapif_REGNAME));
1191
1192     SPAGAIN;
1193     PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef);
1194     XSRETURN(1);
1195 }
1196
1197
1198 XS(XS_re_regnames)
1199 {
1200     dVAR;
1201     dXSARGS;
1202     REGEXP * rx;
1203     U32 flags;
1204     SV *ret;
1205     AV *av;
1206     SSize_t length;
1207     SSize_t i;
1208     SV **entry;
1209
1210     if (items > 1)
1211         croak_xs_usage(cv, "[all]");
1212
1213     rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1214
1215     if (!rx)
1216         XSRETURN_UNDEF;
1217
1218     if (items == 1 && SvTRUE(ST(0))) {
1219         flags = RXapif_ALL;
1220     } else {
1221         flags = RXapif_ONE;
1222     }
1223
1224     SP -= items;
1225     PUTBACK;
1226
1227     ret = CALLREG_NAMED_BUFF_ALL(rx, (flags | RXapif_REGNAMES));
1228
1229     SPAGAIN;
1230
1231     if (!ret)
1232         XSRETURN_UNDEF;
1233
1234     av = MUTABLE_AV(SvRV(ret));
1235     length = av_len(av);
1236
1237     EXTEND(SP, length+1); /* better extend stack just once */
1238     for (i = 0; i <= length; i++) {
1239         entry = av_fetch(av, i, FALSE);
1240
1241         if (!entry)
1242             Perl_croak(aTHX_ "NULL array element in re::regnames()");
1243
1244         mPUSHs(SvREFCNT_inc_simple_NN(*entry));
1245     }
1246
1247     SvREFCNT_dec(ret);
1248
1249     PUTBACK;
1250     return;
1251 }
1252
1253 XS(XS_re_regexp_pattern)
1254 {
1255     dVAR;
1256     dXSARGS;
1257     REGEXP *re;
1258
1259     EXTEND(SP, 2);
1260     SP -= items;
1261     if (items != 1)
1262         croak_xs_usage(cv, "sv");
1263
1264     /*
1265        Checks if a reference is a regex or not. If the parameter is
1266        not a ref, or is not the result of a qr// then returns false
1267        in scalar context and an empty list in list context.
1268        Otherwise in list context it returns the pattern and the
1269        modifiers, in scalar context it returns the pattern just as it
1270        would if the qr// was stringified normally, regardless as
1271        to the class of the variable and any stringification overloads
1272        on the object.
1273     */
1274
1275     if ((re = SvRX(ST(0)))) /* assign deliberate */
1276     {
1277         /* Houston, we have a regex! */
1278         SV *pattern;
1279
1280         if ( GIMME_V == G_ARRAY ) {
1281             STRLEN left = 0;
1282             char reflags[sizeof(INT_PAT_MODS) + MAX_CHARSET_NAME_LENGTH];
1283             const char *fptr;
1284             char ch;
1285             U16 match_flags;
1286
1287             /*
1288                we are in list context so stringify
1289                the modifiers that apply. We ignore "negative
1290                modifiers" in this scenario, and the default character set
1291             */
1292
1293             if (get_regex_charset(RX_EXTFLAGS(re)) != REGEX_DEPENDS_CHARSET) {
1294                 STRLEN len;
1295                 const char* const name = get_regex_charset_name(RX_EXTFLAGS(re),
1296                                                                 &len);
1297                 Copy(name, reflags + left, len, char);
1298                 left += len;
1299             }
1300             fptr = INT_PAT_MODS;
1301             match_flags = (U16)((RX_EXTFLAGS(re) & RXf_PMf_COMPILETIME)
1302                                     >> RXf_PMf_STD_PMMOD_SHIFT);
1303
1304             while((ch = *fptr++)) {
1305                 if(match_flags & 1) {
1306                     reflags[left++] = ch;
1307                 }
1308                 match_flags >>= 1;
1309             }
1310
1311             pattern = newSVpvn_flags(RX_PRECOMP(re),RX_PRELEN(re),
1312                                      (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP);
1313
1314             /* return the pattern and the modifiers */
1315             PUSHs(pattern);
1316             PUSHs(newSVpvn_flags(reflags, left, SVs_TEMP));
1317             XSRETURN(2);
1318         } else {
1319             /* Scalar, so use the string that Perl would return */
1320             /* return the pattern in (?msix:..) format */
1321 #if PERL_VERSION >= 11
1322             pattern = sv_2mortal(newSVsv(MUTABLE_SV(re)));
1323 #else
1324             pattern = newSVpvn_flags(RX_WRAPPED(re), RX_WRAPLEN(re),
1325                                      (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP);
1326 #endif
1327             PUSHs(pattern);
1328             XSRETURN(1);
1329         }
1330     } else {
1331         /* It ain't a regexp folks */
1332         if ( GIMME_V == G_ARRAY ) {
1333             /* return the empty list */
1334             XSRETURN_UNDEF;
1335         } else {
1336             /* Because of the (?:..) wrapping involved in a
1337                stringified pattern it is impossible to get a
1338                result for a real regexp that would evaluate to
1339                false. Therefore we can return PL_sv_no to signify
1340                that the object is not a regex, this means that one
1341                can say
1342
1343                  if (regex($might_be_a_regex) eq '(?:foo)') { }
1344
1345                and not worry about undefined values.
1346             */
1347             XSRETURN_NO;
1348         }
1349     }
1350     /* NOT-REACHED */
1351 }
1352
1353 struct xsub_details {
1354     const char *name;
1355     XSUBADDR_t xsub;
1356     const char *proto;
1357 };
1358
1359 static const struct xsub_details details[] = {
1360     {"UNIVERSAL::isa", XS_UNIVERSAL_isa, NULL},
1361     {"UNIVERSAL::can", XS_UNIVERSAL_can, NULL},
1362     {"UNIVERSAL::DOES", XS_UNIVERSAL_DOES, NULL},
1363     {"UNIVERSAL::VERSION", XS_UNIVERSAL_VERSION, NULL},
1364     {"version::()", XS_version_noop, NULL},
1365     {"version::new", XS_version_new, NULL},
1366     {"version::parse", XS_version_new, NULL},
1367     {"version::(\"\"", XS_version_stringify, NULL},
1368     {"version::stringify", XS_version_stringify, NULL},
1369     {"version::(0+", XS_version_numify, NULL},
1370     {"version::numify", XS_version_numify, NULL},
1371     {"version::normal", XS_version_normal, NULL},
1372     {"version::(cmp", XS_version_vcmp, NULL},
1373     {"version::(<=>", XS_version_vcmp, NULL},
1374     {"version::vcmp", XS_version_vcmp, NULL},
1375     {"version::(bool", XS_version_boolean, NULL},
1376     {"version::boolean", XS_version_boolean, NULL},
1377     {"version::(+", XS_version_noop, NULL},
1378     {"version::(-", XS_version_noop, NULL},
1379     {"version::(*", XS_version_noop, NULL},
1380     {"version::(/", XS_version_noop, NULL},
1381     {"version::(+=", XS_version_noop, NULL},
1382     {"version::(-=", XS_version_noop, NULL},
1383     {"version::(*=", XS_version_noop, NULL},
1384     {"version::(/=", XS_version_noop, NULL},
1385     {"version::(abs", XS_version_noop, NULL},
1386     {"version::(nomethod", XS_version_noop, NULL},
1387     {"version::noop", XS_version_noop, NULL},
1388     {"version::is_alpha", XS_version_is_alpha, NULL},
1389     {"version::qv", XS_version_qv, NULL},
1390     {"version::declare", XS_version_qv, NULL},
1391     {"version::is_qv", XS_version_is_qv, NULL},
1392     {"utf8::is_utf8", XS_utf8_is_utf8, NULL},
1393     {"utf8::valid", XS_utf8_valid, NULL},
1394     {"utf8::encode", XS_utf8_encode, NULL},
1395     {"utf8::decode", XS_utf8_decode, NULL},
1396     {"utf8::upgrade", XS_utf8_upgrade, NULL},
1397     {"utf8::downgrade", XS_utf8_downgrade, NULL},
1398     {"utf8::native_to_unicode", XS_utf8_native_to_unicode, NULL},
1399     {"utf8::unicode_to_native", XS_utf8_unicode_to_native, NULL},
1400     {"Internals::SvREADONLY", XS_Internals_SvREADONLY, "\\[$%@];$"},
1401     {"Internals::SvREFCNT", XS_Internals_SvREFCNT, "\\[$%@];$"},
1402     {"Internals::hv_clear_placeholders", XS_Internals_hv_clear_placehold, "\\%"},
1403     {"PerlIO::get_layers", XS_PerlIO_get_layers, "*;@"},
1404     {"re::is_regexp", XS_re_is_regexp, "$"},
1405     {"re::regname", XS_re_regname, ";$$"},
1406     {"re::regnames", XS_re_regnames, ";$"},
1407     {"re::regnames_count", XS_re_regnames_count, ""},
1408     {"re::regexp_pattern", XS_re_regexp_pattern, "$"},
1409 };
1410
1411 void
1412 Perl_boot_core_UNIVERSAL(pTHX)
1413 {
1414     dVAR;
1415     static const char file[] = __FILE__;
1416     const struct xsub_details *xsub = details;
1417     const struct xsub_details *end
1418         = details + sizeof(details) / sizeof(details[0]);
1419
1420     do {
1421         newXS_flags(xsub->name, xsub->xsub, file, xsub->proto, 0);
1422     } while (++xsub < end);
1423
1424     /* Providing a Regexp::DESTROY fixes #21347. See test in t/op/ref.t  */
1425     {
1426         CV * const cv =
1427             newCONSTSUB(get_hv("Regexp::", GV_ADD), "DESTROY", NULL);
1428         Safefree(CvFILE(cv));
1429         CvFILE(cv) = (char *)file;
1430         CvDYNFILE_off(cv);
1431     }
1432 }
1433
1434 /*
1435  * Local variables:
1436  * c-indentation-style: bsd
1437  * c-basic-offset: 4
1438  * indent-tabs-mode: nil
1439  * End:
1440  *
1441  * ex: set ts=8 sts=4 sw=4 et:
1442  */