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