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