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             Perl_croak_nocontext("Usage: %"HEKf"::%"HEKf"(%s)",
 316                                 HEKfARG(HvNAME_HEK(stash)),
 317                                 HEKfARG(GvNAME_HEK(gv)),
 318                                 params);
 319         else
 320             Perl_croak_nocontext("Usage: %"HEKf"(%s)",
 321                                 HEKfARG(GvNAME_HEK(gv)), params);
 322     } else {
 323         /* Pants. I don't think that it should be possible to get here. */
 324         Perl_croak_nocontext("Usage: CODE(0x%"UVxf")(%s)", PTR2UV(cv), params);
 325     }
 326 }
 327
 328 XS(XS_UNIVERSAL_isa)
 329 {
 330     dVAR;
 331     dXSARGS;
 332
 333     if (items != 2)
 334         croak_xs_usage(cv, "reference, kind");
 335     else {
 336         SV * const sv = ST(0);
 337
 338         SvGETMAGIC(sv);
 339
 340         if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))))
 341             XSRETURN_UNDEF;
 342
 343         ST(0) = boolSV(sv_derived_from_sv(sv, ST(1), 0));
 344         XSRETURN(1);
 345     }
 346 }
 347
 348 XS(XS_UNIVERSAL_can)
 349 {
 350     dVAR;
 351     dXSARGS;
 352     SV   *sv;
 353     SV   *rv;
 354     HV   *pkg = NULL;
 355     GV   *iogv;
 356
 357     if (items != 2)
 358         croak_xs_usage(cv, "object-ref, method");
 359
 360     sv = ST(0);
 361
 362     SvGETMAGIC(sv);
 363
 364     /* Reject undef and empty string.  Note that the string form takes
 365        precedence here over the numeric form, as (!1)->foo treats the
 366        invocant as the empty string, though it is a dualvar. */
 367     if (!SvOK(sv) || (SvPOK(sv) && !SvCUR(sv)))
 368         XSRETURN_UNDEF;
 369
 370     rv = &PL_sv_undef;
 371
 372     if (SvROK(sv)) {
 373         sv = MUTABLE_SV(SvRV(sv));
 374         if (SvOBJECT(sv))
 375             pkg = SvSTASH(sv);
 376         else if (isGV_with_GP(sv) && GvIO(sv))
 377             pkg = SvSTASH(GvIO(sv));
 378     }
 379     else if (isGV_with_GP(sv) && GvIO(sv))
 380         pkg = SvSTASH(GvIO(sv));
 381     else if ((iogv = gv_fetchsv_nomg(sv, 0, SVt_PVIO)) && GvIO(iogv))
 382         pkg = SvSTASH(GvIO(iogv));
 383     else {
 384         pkg = gv_stashsv(sv, 0);
 385         if (!pkg)
 386             pkg = gv_stashpv("UNIVERSAL", 0);
 387     }
 388
 389     if (pkg) {
 390         GV * const gv = gv_fetchmethod_sv_flags(pkg, ST(1), 0);
 391         if (gv && isGV(gv))
 392             rv = sv_2mortal(newRV(MUTABLE_SV(GvCV(gv))));
 393     }
 394
 395     ST(0) = rv;
 396     XSRETURN(1);
 397 }
 398
 399 XS(XS_UNIVERSAL_DOES)
 400 {
 401     dVAR;
 402     dXSARGS;
 403     PERL_UNUSED_ARG(cv);
 404
 405     if (items != 2)
 406         Perl_croak(aTHX_ "Usage: invocant->DOES(kind)");
 407     else {
 408         SV * const sv = ST(0);
 409         if (sv_does_sv( sv, ST(1), 0 ))
 410             XSRETURN_YES;
 411
 412         XSRETURN_NO;
 413     }
 414 }
 415
 416 XS(XS_UNIVERSAL_VERSION)
 417 {
 418     dVAR;
 419     dXSARGS;
 420     HV *pkg;
 421     GV **gvp;
 422     GV *gv;
 423     SV *sv;
 424     const char *undef;
 425     PERL_UNUSED_ARG(cv);
 426
 427     if (SvROK(ST(0))) {
 428         sv = MUTABLE_SV(SvRV(ST(0)));
 429         if (!SvOBJECT(sv))
 430             Perl_croak(aTHX_ "Cannot find version of an unblessed reference");
 431         pkg = SvSTASH(sv);
 432     }
 433     else {
 434         pkg = gv_stashsv(ST(0), 0);
 435     }
 436
 437     gvp = pkg ? (GV**)hv_fetchs(pkg, "VERSION", FALSE) : NULL;
 438
 439     if (gvp && isGV(gv = *gvp) && (sv = GvSV(gv)) && SvOK(sv)) {
 440         SV * const nsv = sv_newmortal();
 441         sv_setsv(nsv, sv);
 442         sv = nsv;
 443         if ( !sv_isobject(sv) || !sv_derived_from(sv, "version"))
 444             upg_version(sv, FALSE);
 445
 446         undef = NULL;
 447     }
 448     else {
 449         sv = &PL_sv_undef;
 450         undef = "(undef)";
 451     }
 452
 453     if (items > 1) {
 454         SV *req = ST(1);
 455
 456         if (undef) {
 457             if (pkg) {
 458                 const HEK * const name = HvNAME_HEK(pkg);
 459                 Perl_croak(aTHX_
 460                            "%"HEKf" does not define $%"HEKf
 461                            "::VERSION--version check failed",
 462                            HEKfARG(name), HEKfARG(name));
 463             } else {
 464                 Perl_croak(aTHX_
 465                              "%"SVf" defines neither package nor VERSION--version check failed",
 466                              SVfARG(ST(0)) );
 467              }
 468         }
 469
 470         if ( !sv_isobject(req) || !sv_derived_from(req, "version")) {
 471             /* req may very well be R/O, so create a new object */
 472             req = sv_2mortal( new_version(req) );
 473         }
 474
 475         if ( vcmp( req, sv ) > 0 ) {
 476             if ( hv_exists(MUTABLE_HV(SvRV(req)), "qv", 2 ) ) {
 477                 Perl_croak(aTHX_ "%"HEKf" version %"SVf" required--"
 478                        "this is only version %"SVf"",
 479                        HEKfARG(HvNAME_HEK(pkg)),
 480                        SVfARG(sv_2mortal(vnormal(req))),
 481                        SVfARG(sv_2mortal(vnormal(sv))));
 482             } else {
 483                 Perl_croak(aTHX_ "%"HEKf" version %"SVf" required--"
 484                        "this is only version %"SVf,
 485                        HEKfARG(HvNAME_HEK(pkg)),
 486                        SVfARG(sv_2mortal(vstringify(req))),
 487                        SVfARG(sv_2mortal(vstringify(sv))));
 488             }
 489         }
 490
 491     }
 492
 493     if ( SvOK(sv) && sv_derived_from(sv, "version") ) {
 494         ST(0) = sv_2mortal(vstringify(sv));
 495     } else {
 496         ST(0) = sv;
 497     }
 498
 499     XSRETURN(1);
 500 }
 501
 502 XS(XS_version_new)
 503 {
 504     dVAR;
 505     dXSARGS;
 506     if (items > 3 || items < 1)
 507         croak_xs_usage(cv, "class, version");
 508     SP -= items;
 509     {
 510         SV *vs = ST(1);
 511         SV *rv;
 512         STRLEN len;
 513         const char *classname;
 514         U32 flags;
 515
 516         /* Just in case this is something like a tied hash */
 517         SvGETMAGIC(vs);
 518
 519         if ( sv_isobject(ST(0)) ) { /* get the class if called as an object method */
 520             const HV * stash = SvSTASH(SvRV(ST(0)));
 521             classname = HvNAME(stash);
 522             len       = HvNAMELEN(stash);
 523             flags     = HvNAMEUTF8(stash) ? SVf_UTF8 : 0;
 524         }
 525         else {
 526             classname = SvPV(ST(0), len);
 527             flags     = SvUTF8(ST(0));
 528         }
 529
 530         if ( items == 1 || ! SvOK(vs) ) { /* no param or explicit undef */
 531             /* create empty object */
 532             vs = sv_newmortal();
 533             sv_setpvs(vs, "0");
 534         }
 535         else if ( items == 3 ) {
 536             vs = sv_newmortal();
 537             Perl_sv_setpvf(aTHX_ vs,"v%s",SvPV_nolen_const(ST(2)));
 538         }
 539
 540         rv = new_version(vs);
 541         if ( strnNE(classname,"version", len) ) /* inherited new() */
 542             sv_bless(rv, gv_stashpvn(classname, len, GV_ADD | flags));
 543
 544         mPUSHs(rv);
 545         PUTBACK;
 546         return;
 547     }
 548 }
 549
 550 XS(XS_version_stringify)
 551 {
 552      dVAR;
 553      dXSARGS;
 554      if (items < 1)
 555          croak_xs_usage(cv, "lobj, ...");
 556      SP -= items;
 557      {
 558           SV *  lobj = ST(0);
 559
 560           if (sv_isobject(lobj) && sv_derived_from(lobj, "version")) {
 561                lobj = SvRV(lobj);
 562           }
 563           else
 564                Perl_croak(aTHX_ "lobj is not of type version");
 565
 566           mPUSHs(vstringify(lobj));
 567
 568           PUTBACK;
 569           return;
 570      }
 571 }
 572
 573 XS(XS_version_numify)
 574 {
 575      dVAR;
 576      dXSARGS;
 577      if (items < 1)
 578          croak_xs_usage(cv, "lobj, ...");
 579      SP -= items;
 580      {
 581           SV *  lobj = ST(0);
 582
 583           if (sv_isobject(lobj) && sv_derived_from(lobj, "version")) {
 584                lobj = SvRV(lobj);
 585           }
 586           else
 587                Perl_croak(aTHX_ "lobj is not of type version");
 588
 589           mPUSHs(vnumify(lobj));
 590
 591           PUTBACK;
 592           return;
 593      }
 594 }
 595
 596 XS(XS_version_normal)
 597 {
 598      dVAR;
 599      dXSARGS;
 600      if (items < 1)
 601          croak_xs_usage(cv, "lobj, ...");
 602      SP -= items;
 603      {
 604           SV *  lobj = ST(0);
 605
 606           if (sv_isobject(lobj) && sv_derived_from(lobj, "version")) {
 607                lobj = SvRV(lobj);
 608           }
 609           else
 610                Perl_croak(aTHX_ "lobj is not of type version");
 611
 612           mPUSHs(vnormal(lobj));
 613
 614           PUTBACK;
 615           return;
 616      }
 617 }
 618
 619 XS(XS_version_vcmp)
 620 {
 621      dVAR;
 622      dXSARGS;
 623      if (items < 1)
 624          croak_xs_usage(cv, "lobj, ...");
 625      SP -= items;
 626      {
 627           SV *  lobj = ST(0);
 628
 629           if (sv_isobject(lobj) && sv_derived_from(lobj, "version")) {
 630                lobj = SvRV(lobj);
 631           }
 632           else
 633                Perl_croak(aTHX_ "lobj is not of type version");
 634
 635           {
 636                SV       *rs;
 637                SV       *rvs;
 638                SV * robj = ST(1);
 639                const IV  swap = (IV)SvIV(ST(2));
 640
 641                if ( !sv_isobject(robj) || !sv_derived_from(robj, "version") )
 642                {
 643                     robj = new_version(SvOK(robj) ? robj : newSVpvs_flags("0", SVs_TEMP));
 644                     sv_2mortal(robj);
 645                }
 646                rvs = SvRV(robj);
 647
 648                if ( swap )
 649                {
 650                     rs = newSViv(vcmp(rvs,lobj));
 651                }
 652                else
 653                {
 654                     rs = newSViv(vcmp(lobj,rvs));
 655                }
 656
 657                mPUSHs(rs);
 658           }
 659
 660           PUTBACK;
 661           return;
 662      }
 663 }
 664
 665 XS(XS_version_boolean)
 666 {
 667     dVAR;
 668     dXSARGS;
 669     if (items < 1)
 670         croak_xs_usage(cv, "lobj, ...");
 671     SP -= items;
 672     if (sv_isobject(ST(0)) && sv_derived_from(ST(0), "version")) {
 673         SV * const lobj = SvRV(ST(0));
 674         SV * const rs =
 675             newSViv( vcmp(lobj,
 676                           sv_2mortal(new_version(
 677                                         sv_2mortal(newSVpvs("0"))
 678                                     ))
 679                          )
 680                    );
 681         mPUSHs(rs);
 682         PUTBACK;
 683         return;
 684     }
 685     else
 686         Perl_croak(aTHX_ "lobj is not of type version");
 687 }
 688
 689 XS(XS_version_noop)
 690 {
 691     dVAR;
 692     dXSARGS;
 693     if (items < 1)
 694         croak_xs_usage(cv, "lobj, ...");
 695     if (sv_isobject(ST(0)) && sv_derived_from(ST(0), "version"))
 696         Perl_croak(aTHX_ "operation not supported with version object");
 697     else
 698         Perl_croak(aTHX_ "lobj is not of type version");
 699 #ifndef HASATTRIBUTE_NORETURN
 700     XSRETURN_EMPTY;
 701 #endif
 702 }
 703
 704 XS(XS_version_is_alpha)
 705 {
 706     dVAR;
 707     dXSARGS;
 708     if (items != 1)
 709         croak_xs_usage(cv, "lobj");
 710     SP -= items;
 711     if (sv_isobject(ST(0)) && sv_derived_from(ST(0), "version")) {
 712         SV * const lobj = ST(0);
 713         if ( hv_exists(MUTABLE_HV(SvRV(lobj)), "alpha", 5 ) )
 714             XSRETURN_YES;
 715         else
 716             XSRETURN_NO;
 717         PUTBACK;
 718         return;
 719     }
 720     else
 721         Perl_croak(aTHX_ "lobj is not of type version");
 722 }
 723
 724 XS(XS_version_qv)
 725 {
 726     dVAR;
 727     dXSARGS;
 728     PERL_UNUSED_ARG(cv);
 729     SP -= items;
 730     {
 731         SV * ver = ST(0);
 732         SV * rv;
 733         STRLEN len = 0;
 734         const char * classname = "";
 735         U32 flags = 0;
 736         if ( items == 2 ) {
 737             SvGETMAGIC(ST(1));
 738             if (SvOK(ST(1))) {
 739                 ver = ST(1);
 740             }
 741             else {
 742                 Perl_croak(aTHX_ "Invalid version format (version required)");
 743             }
 744             if ( sv_isobject(ST(0)) ) { /* class called as an object method */
 745                 const HV * stash = SvSTASH(SvRV(ST(0)));
 746                 classname = HvNAME(stash);
 747                 len       = HvNAMELEN(stash);
 748                 flags     = HvNAMEUTF8(stash) ? SVf_UTF8 : 0;
 749             }
 750             else {
 751                classname = SvPV(ST(0), len);
 752                 flags     = SvUTF8(ST(0));
 753             }
 754         }
 755         if ( !SvVOK(ver) ) { /* not already a v-string */
 756             rv = sv_newmortal();
 757             sv_setsv(rv,ver); /* make a duplicate */
 758             upg_version(rv, TRUE);
 759         } else {
 760             rv = sv_2mortal(new_version(ver));
 761         }
 762         if ( items == 2
 763                 && strnNE(classname,"version", len) ) { /* inherited new() */
 764             sv_bless(rv, gv_stashpvn(classname, len, GV_ADD | flags));
 765         }
 766         PUSHs(rv);
 767     }
 768     PUTBACK;
 769     return;
 770 }
 771
 772 XS(XS_version_is_qv)
 773 {
 774     dVAR;
 775     dXSARGS;
 776     if (items != 1)
 777         croak_xs_usage(cv, "lobj");
 778     SP -= items;
 779     if (sv_isobject(ST(0)) && sv_derived_from(ST(0), "version")) {
 780         SV * const lobj = ST(0);
 781         if ( hv_exists(MUTABLE_HV(SvRV(lobj)), "qv", 2 ) )
 782             XSRETURN_YES;
 783         else
 784             XSRETURN_NO;
 785         PUTBACK;
 786         return;
 787     }
 788     else
 789         Perl_croak(aTHX_ "lobj is not of type version");
 790 }
 791
 792 XS(XS_utf8_is_utf8)
 793 {
 794      dVAR;
 795      dXSARGS;
 796      if (items != 1)
 797          croak_xs_usage(cv, "sv");
 798      else {
 799         SV * const sv = ST(0);
 800         SvGETMAGIC(sv);
 801             if (SvUTF8(sv))
 802                 XSRETURN_YES;
 803             else
 804                 XSRETURN_NO;
 805      }
 806      XSRETURN_EMPTY;
 807 }
 808
 809 XS(XS_utf8_valid)
 810 {
 811      dVAR;
 812      dXSARGS;
 813      if (items != 1)
 814          croak_xs_usage(cv, "sv");
 815     else {
 816         SV * const sv = ST(0);
 817         STRLEN len;
 818         const char * const s = SvPV_const(sv,len);
 819         if (!SvUTF8(sv) || is_utf8_string((const U8*)s,len))
 820             XSRETURN_YES;
 821         else
 822             XSRETURN_NO;
 823     }
 824      XSRETURN_EMPTY;
 825 }
 826
 827 XS(XS_utf8_encode)
 828 {
 829     dVAR;
 830     dXSARGS;
 831     if (items != 1)
 832         croak_xs_usage(cv, "sv");
 833     sv_utf8_encode(ST(0));
 834     SvSETMAGIC(ST(0));
 835     XSRETURN_EMPTY;
 836 }
 837
 838 XS(XS_utf8_decode)
 839 {
 840     dVAR;
 841     dXSARGS;
 842     if (items != 1)
 843         croak_xs_usage(cv, "sv");
 844     else {
 845         SV * const sv = ST(0);
 846         bool RETVAL;
 847         SvPV_force_nolen(sv);
 848         RETVAL = sv_utf8_decode(sv);
 849         SvSETMAGIC(sv);
 850         ST(0) = boolSV(RETVAL);
 851     }
 852     XSRETURN(1);
 853 }
 854
 855 XS(XS_utf8_upgrade)
 856 {
 857     dVAR;
 858     dXSARGS;
 859     if (items != 1)
 860         croak_xs_usage(cv, "sv");
 861     else {
 862         SV * const sv = ST(0);
 863         STRLEN  RETVAL;
 864         dXSTARG;
 865
 866         RETVAL = sv_utf8_upgrade(sv);
 867         XSprePUSH; PUSHi((IV)RETVAL);
 868     }
 869     XSRETURN(1);
 870 }
 871
 872 XS(XS_utf8_downgrade)
 873 {
 874     dVAR;
 875     dXSARGS;
 876     if (items < 1 || items > 2)
 877         croak_xs_usage(cv, "sv, failok=0");
 878     else {
 879         SV * const sv = ST(0);
 880         const bool failok = (items < 2) ? 0 : (int)SvIV(ST(1));
 881         const bool RETVAL = sv_utf8_downgrade(sv, failok);
 882
 883         ST(0) = boolSV(RETVAL);
 884     }
 885     XSRETURN(1);
 886 }
 887
 888 XS(XS_utf8_native_to_unicode)
 889 {
 890  dVAR;
 891  dXSARGS;
 892  const UV uv = SvUV(ST(0));
 893
 894  if (items > 1)
 895      croak_xs_usage(cv, "sv");
 896
 897  ST(0) = sv_2mortal(newSViv(NATIVE_TO_UNI(uv)));
 898  XSRETURN(1);
 899 }
 900
 901 XS(XS_utf8_unicode_to_native)
 902 {
 903  dVAR;
 904  dXSARGS;
 905  const UV uv = SvUV(ST(0));
 906
 907  if (items > 1)
 908      croak_xs_usage(cv, "sv");
 909
 910  ST(0) = sv_2mortal(newSViv(UNI_TO_NATIVE(uv)));
 911  XSRETURN(1);
 912 }
 913
 914 XS(XS_Internals_SvREADONLY)     /* This is dangerous stuff. */
 915 {
 916     dVAR;
 917     dXSARGS;
 918     SV * const svz = ST(0);
 919     SV * sv;
 920     PERL_UNUSED_ARG(cv);
 921
 922     /* [perl #77776] - called as &foo() not foo() */
 923     if (!SvROK(svz))
 924         croak_xs_usage(cv, "SCALAR[, ON]");
 925
 926     sv = SvRV(svz);
 927
 928     if (items == 1) {
 929          if (SvREADONLY(sv))
 930              XSRETURN_YES;
 931          else
 932              XSRETURN_NO;
 933     }
 934     else if (items == 2) {
 935         if (SvTRUE(ST(1))) {
 936 #ifdef PERL_OLD_COPY_ON_WRITE
 937             if (SvIsCOW(sv)) sv_force_normal(sv);
 938 #endif
 939             SvREADONLY_on(sv);
 940             if (SvTYPE(sv) == SVt_PVAV && AvFILLp(sv) != -1) {
 941                 /* for constant.pm; nobody else should be calling this
 942                    on arrays anyway. */
 943                 SV **svp;
 944                 for (svp = AvARRAY(sv) + AvFILLp(sv)
 945                    ; svp >= AvARRAY(sv)
 946                    ; --svp)
 947                     if (*svp) SvPADTMP_on(*svp);
 948             }
 949             XSRETURN_YES;
 950         }
 951         else {
 952             /* I hope you really know what you are doing. */
 953             SvREADONLY_off(sv);
 954             XSRETURN_NO;
 955         }
 956     }
 957     XSRETURN_UNDEF; /* Can't happen. */
 958 }
 959 XS(XS_Internals_SvREFCNT)       /* This is dangerous stuff. */
 960 {
 961     dVAR;
 962     dXSARGS;
 963     SV * const svz = ST(0);
 964     SV * sv;
 965     U32 refcnt;
 966     PERL_UNUSED_ARG(cv);
 967
 968     /* [perl #77776] - called as &foo() not foo() */
 969     if ((items != 1 && items != 2) || !SvROK(svz))
 970         croak_xs_usage(cv, "SCALAR[, REFCOUNT]");
 971
 972     sv = SvRV(svz);
 973
 974          /* I hope you really know what you are doing. */
 975     /* idea is for SvREFCNT(sv) to be accessed only once */
 976     refcnt = items == 2 ?
 977                 /* we free one ref on exit */
 978                 (SvREFCNT(sv) = SvUV(ST(1)) + 1)
 979                 : SvREFCNT(sv);
 980     XSRETURN_UV(refcnt - 1); /* Minus the ref created for us. */
 981
 982 }
 983
 984 XS(XS_Internals_hv_clear_placehold)
 985 {
 986     dVAR;
 987     dXSARGS;
 988
 989     if (items != 1 || !SvROK(ST(0)))
 990         croak_xs_usage(cv, "hv");
 991     else {
 992         HV * const hv = MUTABLE_HV(SvRV(ST(0)));
 993         hv_clear_placeholders(hv);
 994         XSRETURN(0);
 995     }
 996 }
 997
 998 XS(XS_PerlIO_get_layers)
 999 {
1000     dVAR;
1001     dXSARGS;
1002     if (items < 1 || items % 2 == 0)
1003         croak_xs_usage(cv, "filehandle[,args]");
1004 #ifdef USE_PERLIO
1005     {
1006         SV *    sv;
1007         GV *    gv;
1008         IO *    io;
1009         bool    input = TRUE;
1010         bool    details = FALSE;
1011
1012         if (items > 1) {
1013              SV * const *svp;
1014              for (svp = MARK + 2; svp <= SP; svp += 2) {
1015                   SV * const * const varp = svp;
1016                   SV * const * const valp = svp + 1;
1017                   STRLEN klen;
1018                   const char * const key = SvPV_const(*varp, klen);
1019
1020                   switch (*key) {
1021                   case 'i':
1022                        if (klen == 5 && memEQ(key, "input", 5)) {
1023                             input = SvTRUE(*valp);
1024                             break;
1025                        }
1026                        goto fail;
1027                   case 'o':
1028                        if (klen == 6 && memEQ(key, "output", 6)) {
1029                             input = !SvTRUE(*valp);
1030                             break;
1031                        }
1032                        goto fail;
1033                   case 'd':
1034                        if (klen == 7 && memEQ(key, "details", 7)) {
1035                             details = SvTRUE(*valp);
1036                             break;
1037                        }
1038                        goto fail;
1039                   default:
1040                   fail:
1041                        Perl_croak(aTHX_
1042                                   "get_layers: unknown argument '%s'",
1043                                   key);
1044                   }
1045              }
1046
1047              SP -= (items - 1);
1048         }
1049
1050         sv = POPs;
1051         gv = MAYBE_DEREF_GV(sv);
1052
1053         if (!gv && !SvROK(sv))
1054             gv = gv_fetchsv_nomg(sv, 0, SVt_PVIO);
1055
1056         if (gv && (io = GvIO(gv))) {
1057              AV* const av = PerlIO_get_layers(aTHX_ input ?
1058                                         IoIFP(io) : IoOFP(io));
1059              SSize_t i;
1060              const SSize_t last = av_len(av);
1061              SSize_t nitem = 0;
1062
1063              for (i = last; i >= 0; i -= 3) {
1064                   SV * const * const namsvp = av_fetch(av, i - 2, FALSE);
1065                   SV * const * const argsvp = av_fetch(av, i - 1, FALSE);
1066                   SV * const * const flgsvp = av_fetch(av, i,     FALSE);
1067
1068                   const bool namok = namsvp && *namsvp && SvPOK(*namsvp);
1069                   const bool argok = argsvp && *argsvp && SvPOK(*argsvp);
1070                   const bool flgok = flgsvp && *flgsvp && SvIOK(*flgsvp);
1071
1072                   EXTEND(SP, 3); /* Three is the max in all branches: better check just once */
1073                   if (details) {
1074                       /* Indents of 5? Yuck.  */
1075                       /* We know that PerlIO_get_layers creates a new SV for
1076                          the name and flags, so we can just take a reference
1077                          and "steal" it when we free the AV below.  */
1078                        PUSHs(namok
1079                               ? sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp))
1080                               : &PL_sv_undef);
1081                        PUSHs(argok
1082                               ? newSVpvn_flags(SvPVX_const(*argsvp),
1083                                                SvCUR(*argsvp),
1084                                                (SvUTF8(*argsvp) ? SVf_UTF8 : 0)
1085                                                | SVs_TEMP)
1086                               : &PL_sv_undef);
1087                        PUSHs(flgok
1088                               ? sv_2mortal(SvREFCNT_inc_simple_NN(*flgsvp))
1089                               : &PL_sv_undef);
1090                        nitem += 3;
1091                   }
1092                   else {
1093                        if (namok && argok)
1094                             PUSHs(sv_2mortal(Perl_newSVpvf(aTHX_ "%"SVf"(%"SVf")",
1095                                                  SVfARG(*namsvp),
1096                                                  SVfARG(*argsvp))));
1097                        else if (namok)
1098                             PUSHs(sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp)));
1099                        else
1100                             PUSHs(&PL_sv_undef);
1101                        nitem++;
1102                        if (flgok) {
1103                             const IV flags = SvIVX(*flgsvp);
1104
1105                             if (flags & PERLIO_F_UTF8) {
1106                                  PUSHs(newSVpvs_flags("utf8", SVs_TEMP));
1107                                  nitem++;
1108                             }
1109                        }
1110                   }
1111              }
1112
1113              SvREFCNT_dec(av);
1114
1115              XSRETURN(nitem);
1116         }
1117     }
1118 #endif
1119
1120     XSRETURN(0);
1121 }
1122
1123
1124 XS(XS_re_is_regexp)
1125 {
1126     dVAR;
1127     dXSARGS;
1128     PERL_UNUSED_VAR(cv);
1129
1130     if (items != 1)
1131         croak_xs_usage(cv, "sv");
1132
1133     if (SvRXOK(ST(0))) {
1134         XSRETURN_YES;
1135     } else {
1136         XSRETURN_NO;
1137     }
1138 }
1139
1140 XS(XS_re_regnames_count)
1141 {
1142     REGEXP *rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1143     SV * ret;
1144     dVAR;
1145     dXSARGS;
1146
1147     if (items != 0)
1148         croak_xs_usage(cv, "");
1149
1150     SP -= items;
1151     PUTBACK;
1152
1153     if (!rx)
1154         XSRETURN_UNDEF;
1155
1156     ret = CALLREG_NAMED_BUFF_COUNT(rx);
1157
1158     SPAGAIN;
1159     PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef);
1160     XSRETURN(1);
1161 }
1162
1163 XS(XS_re_regname)
1164 {
1165     dVAR;
1166     dXSARGS;
1167     REGEXP * rx;
1168     U32 flags;
1169     SV * ret;
1170
1171     if (items < 1 || items > 2)
1172         croak_xs_usage(cv, "name[, all ]");
1173
1174     SP -= items;
1175     PUTBACK;
1176
1177     rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1178
1179     if (!rx)
1180         XSRETURN_UNDEF;
1181
1182     if (items == 2 && SvTRUE(ST(1))) {
1183         flags = RXapif_ALL;
1184     } else {
1185         flags = RXapif_ONE;
1186     }
1187     ret = CALLREG_NAMED_BUFF_FETCH(rx, ST(0), (flags | RXapif_REGNAME));
1188
1189     SPAGAIN;
1190     PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef);
1191     XSRETURN(1);
1192 }
1193
1194
1195 XS(XS_re_regnames)
1196 {
1197     dVAR;
1198     dXSARGS;
1199     REGEXP * rx;
1200     U32 flags;
1201     SV *ret;
1202     AV *av;
1203     SSize_t length;
1204     SSize_t i;
1205     SV **entry;
1206
1207     if (items > 1)
1208         croak_xs_usage(cv, "[all]");
1209
1210     rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1211
1212     if (!rx)
1213         XSRETURN_UNDEF;
1214
1215     if (items == 1 && SvTRUE(ST(0))) {
1216         flags = RXapif_ALL;
1217     } else {
1218         flags = RXapif_ONE;
1219     }
1220
1221     SP -= items;
1222     PUTBACK;
1223
1224     ret = CALLREG_NAMED_BUFF_ALL(rx, (flags | RXapif_REGNAMES));
1225
1226     SPAGAIN;
1227
1228     if (!ret)
1229         XSRETURN_UNDEF;
1230
1231     av = MUTABLE_AV(SvRV(ret));
1232     length = av_len(av);
1233
1234     EXTEND(SP, length+1); /* better extend stack just once */
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         mPUSHs(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     EXTEND(SP, 2);
1257     SP -= items;
1258     if (items != 1)
1259         croak_xs_usage(cv, "sv");
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             PUSHs(pattern);
1313             PUSHs(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             PUSHs(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 const 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     {"re::is_regexp", XS_re_is_regexp, "$"},
1402     {"re::regname", XS_re_regname, ";$$"},
1403     {"re::regnames", XS_re_regnames, ";$"},
1404     {"re::regnames_count", XS_re_regnames_count, ""},
1405     {"re::regexp_pattern", XS_re_regexp_pattern, "$"},
1406 };
1407
1408 void
1409 Perl_boot_core_UNIVERSAL(pTHX)
1410 {
1411     dVAR;
1412     static const char file[] = __FILE__;
1413     const struct xsub_details *xsub = details;
1414     const struct xsub_details *end
1415         = details + sizeof(details) / sizeof(details[0]);
1416
1417     do {
1418         newXS_flags(xsub->name, xsub->xsub, file, xsub->proto, 0);
1419     } while (++xsub < end);
1420
1421     /* Providing a Regexp::DESTROY fixes #21347. See test in t/op/ref.t  */
1422     {
1423         CV * const cv =
1424             newCONSTSUB(get_hv("Regexp::", GV_ADD), "DESTROY", NULL);
1425         Safefree(CvFILE(cv));
1426         CvFILE(cv) = (char *)file;
1427         CvDYNFILE_off(cv);
1428     }
1429 }
1430
1431 /*
1432  * Local variables:
1433  * c-indentation-style: bsd
1434  * c-basic-offset: 4
1435  * indent-tabs-mode: nil
1436  * End:
1437  *
1438  * ex: set ts=8 sts=4 sw=4 et:
1439  */