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