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 =
 656             newSViv( vcmp(lobj,
 657                           sv_2mortal(new_version(
 658                                         sv_2mortal(newSVpvs("0"))
 659                                     ))
 660                          )
 661                    );
 662         mPUSHs(rs);
 663         PUTBACK;
 664         return;
 665     }
 666     else
 667         Perl_croak(aTHX_ "lobj is not of type version");
 668 }
 669
 670 XS(XS_version_noop)
 671 {
 672     dVAR;
 673     dXSARGS;
 674     if (items < 1)
 675         croak_xs_usage(cv, "lobj, ...");
 676     if (sv_isobject(ST(0)) && sv_derived_from(ST(0), "version"))
 677         Perl_croak(aTHX_ "operation not supported with version object");
 678     else
 679         Perl_croak(aTHX_ "lobj is not of type version");
 680 #ifndef HASATTRIBUTE_NORETURN
 681     XSRETURN_EMPTY;
 682 #endif
 683 }
 684
 685 XS(XS_version_is_alpha)
 686 {
 687     dVAR;
 688     dXSARGS;
 689     if (items != 1)
 690         croak_xs_usage(cv, "lobj");
 691     SP -= items;
 692     if (sv_isobject(ST(0)) && sv_derived_from(ST(0), "version")) {
 693         SV * const lobj = ST(0);
 694         if ( hv_exists(MUTABLE_HV(SvRV(lobj)), "alpha", 5 ) )
 695             XSRETURN_YES;
 696         else
 697             XSRETURN_NO;
 698         PUTBACK;
 699         return;
 700     }
 701     else
 702         Perl_croak(aTHX_ "lobj is not of type version");
 703 }
 704
 705 XS(XS_version_qv)
 706 {
 707     dVAR;
 708     dXSARGS;
 709     PERL_UNUSED_ARG(cv);
 710     SP -= items;
 711     {
 712         SV * ver = ST(0);
 713         SV * rv;
 714         STRLEN len = 0;
 715         const char * classname = "";
 716         U32 flags = 0;
 717         if ( items == 2 && SvOK(ST(1)) ) {
 718             ver = ST(1);
 719             if ( sv_isobject(ST(0)) ) { /* class called as an object method */
 720                 const HV * stash = SvSTASH(SvRV(ST(0)));
 721                 classname = HvNAME(stash);
 722                 len       = HvNAMELEN(stash);
 723                 flags     = HvNAMEUTF8(stash) ? SVf_UTF8 : 0;
 724             }
 725             else {
 726                classname = SvPV(ST(0), len);
 727                 flags     = SvUTF8(ST(0));
 728             }
 729         }
 730         if ( !SvVOK(ver) ) { /* not already a v-string */
 731             rv = sv_newmortal();
 732             sv_setsv(rv,ver); /* make a duplicate */
 733             upg_version(rv, TRUE);
 734         } else {
 735             rv = sv_2mortal(new_version(ver));
 736         }
 737         if ( items == 2
 738                 && strnNE(classname,"version", len) ) { /* inherited new() */
 739             sv_bless(rv, gv_stashpvn(classname, len, GV_ADD | flags));
 740         }
 741         PUSHs(rv);
 742     }
 743     PUTBACK;
 744     return;
 745 }
 746
 747 XS(XS_version_is_qv)
 748 {
 749     dVAR;
 750     dXSARGS;
 751     if (items != 1)
 752         croak_xs_usage(cv, "lobj");
 753     SP -= items;
 754     if (sv_isobject(ST(0)) && sv_derived_from(ST(0), "version")) {
 755         SV * const lobj = ST(0);
 756         if ( hv_exists(MUTABLE_HV(SvRV(lobj)), "qv", 2 ) )
 757             XSRETURN_YES;
 758         else
 759             XSRETURN_NO;
 760         PUTBACK;
 761         return;
 762     }
 763     else
 764         Perl_croak(aTHX_ "lobj is not of type version");
 765 }
 766
 767 XS(XS_utf8_is_utf8)
 768 {
 769      dVAR;
 770      dXSARGS;
 771      if (items != 1)
 772          croak_xs_usage(cv, "sv");
 773      else {
 774         SV * const sv = ST(0);
 775         SvGETMAGIC(sv);
 776             if (SvUTF8(sv))
 777                 XSRETURN_YES;
 778             else
 779                 XSRETURN_NO;
 780      }
 781      XSRETURN_EMPTY;
 782 }
 783
 784 XS(XS_utf8_valid)
 785 {
 786      dVAR;
 787      dXSARGS;
 788      if (items != 1)
 789          croak_xs_usage(cv, "sv");
 790     else {
 791         SV * const sv = ST(0);
 792         STRLEN len;
 793         const char * const s = SvPV_const(sv,len);
 794         if (!SvUTF8(sv) || is_utf8_string((const U8*)s,len))
 795             XSRETURN_YES;
 796         else
 797             XSRETURN_NO;
 798     }
 799      XSRETURN_EMPTY;
 800 }
 801
 802 XS(XS_utf8_encode)
 803 {
 804     dVAR;
 805     dXSARGS;
 806     if (items != 1)
 807         croak_xs_usage(cv, "sv");
 808     sv_utf8_encode(ST(0));
 809     XSRETURN_EMPTY;
 810 }
 811
 812 XS(XS_utf8_decode)
 813 {
 814     dVAR;
 815     dXSARGS;
 816     if (items != 1)
 817         croak_xs_usage(cv, "sv");
 818     else {
 819         SV * const sv = ST(0);
 820         bool RETVAL;
 821         SvPV_force_nolen(sv);
 822         RETVAL = sv_utf8_decode(sv);
 823         ST(0) = boolSV(RETVAL);
 824     }
 825     XSRETURN(1);
 826 }
 827
 828 XS(XS_utf8_upgrade)
 829 {
 830     dVAR;
 831     dXSARGS;
 832     if (items != 1)
 833         croak_xs_usage(cv, "sv");
 834     else {
 835         SV * const sv = ST(0);
 836         STRLEN  RETVAL;
 837         dXSTARG;
 838
 839         RETVAL = sv_utf8_upgrade(sv);
 840         XSprePUSH; PUSHi((IV)RETVAL);
 841     }
 842     XSRETURN(1);
 843 }
 844
 845 XS(XS_utf8_downgrade)
 846 {
 847     dVAR;
 848     dXSARGS;
 849     if (items < 1 || items > 2)
 850         croak_xs_usage(cv, "sv, failok=0");
 851     else {
 852         SV * const sv = ST(0);
 853         const bool failok = (items < 2) ? 0 : (int)SvIV(ST(1));
 854         const bool RETVAL = sv_utf8_downgrade(sv, failok);
 855
 856         ST(0) = boolSV(RETVAL);
 857     }
 858     XSRETURN(1);
 859 }
 860
 861 XS(XS_utf8_native_to_unicode)
 862 {
 863  dVAR;
 864  dXSARGS;
 865  const UV uv = SvUV(ST(0));
 866
 867  if (items > 1)
 868      croak_xs_usage(cv, "sv");
 869
 870  ST(0) = sv_2mortal(newSViv(NATIVE_TO_UNI(uv)));
 871  XSRETURN(1);
 872 }
 873
 874 XS(XS_utf8_unicode_to_native)
 875 {
 876  dVAR;
 877  dXSARGS;
 878  const UV uv = SvUV(ST(0));
 879
 880  if (items > 1)
 881      croak_xs_usage(cv, "sv");
 882
 883  ST(0) = sv_2mortal(newSViv(UNI_TO_NATIVE(uv)));
 884  XSRETURN(1);
 885 }
 886
 887 XS(XS_Internals_SvREADONLY)     /* This is dangerous stuff. */
 888 {
 889     dVAR;
 890     dXSARGS;
 891     SV * const svz = ST(0);
 892     SV * sv;
 893     PERL_UNUSED_ARG(cv);
 894
 895     /* [perl #77776] - called as &foo() not foo() */
 896     if (!SvROK(svz))
 897         croak_xs_usage(cv, "SCALAR[, ON]");
 898
 899     sv = SvRV(svz);
 900
 901     if (items == 1) {
 902          if (SvREADONLY(sv) && !SvIsCOW(sv))
 903              XSRETURN_YES;
 904          else
 905              XSRETURN_NO;
 906     }
 907     else if (items == 2) {
 908         if (SvTRUE(ST(1))) {
 909             if (SvIsCOW(sv)) sv_force_normal(sv);
 910             SvREADONLY_on(sv);
 911             XSRETURN_YES;
 912         }
 913         else {
 914             /* I hope you really know what you are doing. */
 915             if (!SvIsCOW(sv)) SvREADONLY_off(sv);
 916             XSRETURN_NO;
 917         }
 918     }
 919     XSRETURN_UNDEF; /* Can't happen. */
 920 }
 921
 922 XS(XS_Internals_SvREFCNT)       /* This is dangerous stuff. */
 923 {
 924     dVAR;
 925     dXSARGS;
 926     SV * const svz = ST(0);
 927     SV * sv;
 928     PERL_UNUSED_ARG(cv);
 929
 930     /* [perl #77776] - called as &foo() not foo() */
 931     if (!SvROK(svz))
 932         croak_xs_usage(cv, "SCALAR[, REFCOUNT]");
 933
 934     sv = SvRV(svz);
 935
 936     if (items == 1)
 937          XSRETURN_UV(SvREFCNT(sv) - 1); /* Minus the ref created for us. */
 938     else if (items == 2) {
 939          /* I hope you really know what you are doing. */
 940          SvREFCNT(sv) = SvUV(ST(1)) + 1; /* we free one ref on exit */
 941          XSRETURN_UV(SvREFCNT(sv) - 1);
 942     }
 943     XSRETURN_UNDEF; /* Can't happen. */
 944 }
 945
 946 XS(XS_Internals_hv_clear_placehold)
 947 {
 948     dVAR;
 949     dXSARGS;
 950
 951     if (items != 1 || !SvROK(ST(0)))
 952         croak_xs_usage(cv, "hv");
 953     else {
 954         HV * const hv = MUTABLE_HV(SvRV(ST(0)));
 955         hv_clear_placeholders(hv);
 956         XSRETURN(0);
 957     }
 958 }
 959
 960 XS(XS_PerlIO_get_layers)
 961 {
 962     dVAR;
 963     dXSARGS;
 964     if (items < 1 || items % 2 == 0)
 965         croak_xs_usage(cv, "filehandle[,args]");
 966 #ifdef USE_PERLIO
 967     {
 968         SV *    sv;
 969         GV *    gv;
 970         IO *    io;
 971         bool    input = TRUE;
 972         bool    details = FALSE;
 973
 974         if (items > 1) {
 975              SV * const *svp;
 976              for (svp = MARK + 2; svp <= SP; svp += 2) {
 977                   SV * const * const varp = svp;
 978                   SV * const * const valp = svp + 1;
 979                   STRLEN klen;
 980                   const char * const key = SvPV_const(*varp, klen);
 981
 982                   switch (*key) {
 983                   case 'i':
 984                        if (klen == 5 && memEQ(key, "input", 5)) {
 985                             input = SvTRUE(*valp);
 986                             break;
 987                        }
 988                        goto fail;
 989                   case 'o':
 990                        if (klen == 6 && memEQ(key, "output", 6)) {
 991                             input = !SvTRUE(*valp);
 992                             break;
 993                        }
 994                        goto fail;
 995                   case 'd':
 996                        if (klen == 7 && memEQ(key, "details", 7)) {
 997                             details = SvTRUE(*valp);
 998                             break;
 999                        }
1000                        goto fail;
1001                   default:
1002                   fail:
1003                        Perl_croak(aTHX_
1004                                   "get_layers: unknown argument '%s'",
1005                                   key);
1006                   }
1007              }
1008
1009              SP -= (items - 1);
1010         }
1011
1012         sv = POPs;
1013         gv = MAYBE_DEREF_GV(sv);
1014
1015         if (!gv && !SvROK(sv))
1016             gv = gv_fetchsv_nomg(sv, 0, SVt_PVIO);
1017
1018         if (gv && (io = GvIO(gv))) {
1019              AV* const av = PerlIO_get_layers(aTHX_ input ?
1020                                         IoIFP(io) : IoOFP(io));
1021              I32 i;
1022              const I32 last = av_len(av);
1023              I32 nitem = 0;
1024
1025              for (i = last; i >= 0; i -= 3) {
1026                   SV * const * const namsvp = av_fetch(av, i - 2, FALSE);
1027                   SV * const * const argsvp = av_fetch(av, i - 1, FALSE);
1028                   SV * const * const flgsvp = av_fetch(av, i,     FALSE);
1029
1030                   const bool namok = namsvp && *namsvp && SvPOK(*namsvp);
1031                   const bool argok = argsvp && *argsvp && SvPOK(*argsvp);
1032                   const bool flgok = flgsvp && *flgsvp && SvIOK(*flgsvp);
1033
1034                   if (details) {
1035                       /* Indents of 5? Yuck.  */
1036                       /* We know that PerlIO_get_layers creates a new SV for
1037                          the name and flags, so we can just take a reference
1038                          and "steal" it when we free the AV below.  */
1039                        XPUSHs(namok
1040                               ? sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp))
1041                               : &PL_sv_undef);
1042                        XPUSHs(argok
1043                               ? newSVpvn_flags(SvPVX_const(*argsvp),
1044                                                SvCUR(*argsvp),
1045                                                (SvUTF8(*argsvp) ? SVf_UTF8 : 0)
1046                                                | SVs_TEMP)
1047                               : &PL_sv_undef);
1048                        XPUSHs(flgok
1049                               ? sv_2mortal(SvREFCNT_inc_simple_NN(*flgsvp))
1050                               : &PL_sv_undef);
1051                        nitem += 3;
1052                   }
1053                   else {
1054                        if (namok && argok)
1055                             XPUSHs(sv_2mortal(Perl_newSVpvf(aTHX_ "%"SVf"(%"SVf")",
1056                                                  SVfARG(*namsvp),
1057                                                  SVfARG(*argsvp))));
1058                        else if (namok)
1059                            XPUSHs(sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp)));
1060                        else
1061                             XPUSHs(&PL_sv_undef);
1062                        nitem++;
1063                        if (flgok) {
1064                             const IV flags = SvIVX(*flgsvp);
1065
1066                             if (flags & PERLIO_F_UTF8) {
1067                                  XPUSHs(newSVpvs_flags("utf8", SVs_TEMP));
1068                                  nitem++;
1069                             }
1070                        }
1071                   }
1072              }
1073
1074              SvREFCNT_dec(av);
1075
1076              XSRETURN(nitem);
1077         }
1078     }
1079 #endif
1080
1081     XSRETURN(0);
1082 }
1083
1084 XS(XS_Internals_hash_seed)
1085 {
1086     dVAR;
1087     /* Using dXSARGS would also have dITEM and dSP,
1088      * which define 2 unused local variables.  */
1089     dAXMARK;
1090     PERL_UNUSED_ARG(cv);
1091     PERL_UNUSED_VAR(mark);
1092     XSRETURN_UV(PERL_HASH_SEED);
1093 }
1094
1095 XS(XS_Internals_rehash_seed)
1096 {
1097     dVAR;
1098     /* Using dXSARGS would also have dITEM and dSP,
1099      * which define 2 unused local variables.  */
1100     dAXMARK;
1101     PERL_UNUSED_ARG(cv);
1102     PERL_UNUSED_VAR(mark);
1103     XSRETURN_UV(PL_rehash_seed);
1104 }
1105
1106 XS(XS_Internals_HvREHASH)       /* Subject to change  */
1107 {
1108     dVAR;
1109     dXSARGS;
1110     PERL_UNUSED_ARG(cv);
1111     if (SvROK(ST(0))) {
1112         const HV * const hv = (const HV *) SvRV(ST(0));
1113         if (items == 1 && SvTYPE(hv) == SVt_PVHV) {
1114             if (HvREHASH(hv))
1115                 XSRETURN_YES;
1116             else
1117                 XSRETURN_NO;
1118         }
1119     }
1120     Perl_croak(aTHX_ "Internals::HvREHASH $hashref");
1121 }
1122
1123 XS(XS_re_is_regexp)
1124 {
1125     dVAR;
1126     dXSARGS;
1127     PERL_UNUSED_VAR(cv);
1128
1129     if (items != 1)
1130         croak_xs_usage(cv, "sv");
1131
1132     if (SvRXOK(ST(0))) {
1133         XSRETURN_YES;
1134     } else {
1135         XSRETURN_NO;
1136     }
1137 }
1138
1139 XS(XS_re_regnames_count)
1140 {
1141     REGEXP *rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1142     SV * ret;
1143     dVAR;
1144     dXSARGS;
1145
1146     if (items != 0)
1147         croak_xs_usage(cv, "");
1148
1149     SP -= items;
1150     PUTBACK;
1151
1152     if (!rx)
1153         XSRETURN_UNDEF;
1154
1155     ret = CALLREG_NAMED_BUFF_COUNT(rx);
1156
1157     SPAGAIN;
1158     PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef);
1159     XSRETURN(1);
1160 }
1161
1162 XS(XS_re_regname)
1163 {
1164     dVAR;
1165     dXSARGS;
1166     REGEXP * rx;
1167     U32 flags;
1168     SV * ret;
1169
1170     if (items < 1 || items > 2)
1171         croak_xs_usage(cv, "name[, all ]");
1172
1173     SP -= items;
1174     PUTBACK;
1175
1176     rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1177
1178     if (!rx)
1179         XSRETURN_UNDEF;
1180
1181     if (items == 2 && SvTRUE(ST(1))) {
1182         flags = RXapif_ALL;
1183     } else {
1184         flags = RXapif_ONE;
1185     }
1186     ret = CALLREG_NAMED_BUFF_FETCH(rx, ST(0), (flags | RXapif_REGNAME));
1187
1188     SPAGAIN;
1189     PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef);
1190     XSRETURN(1);
1191 }
1192
1193
1194 XS(XS_re_regnames)
1195 {
1196     dVAR;
1197     dXSARGS;
1198     REGEXP * rx;
1199     U32 flags;
1200     SV *ret;
1201     AV *av;
1202     I32 length;
1203     I32 i;
1204     SV **entry;
1205
1206     if (items > 1)
1207         croak_xs_usage(cv, "[all]");
1208
1209     rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1210
1211     if (!rx)
1212         XSRETURN_UNDEF;
1213
1214     if (items == 1 && SvTRUE(ST(0))) {
1215         flags = RXapif_ALL;
1216     } else {
1217         flags = RXapif_ONE;
1218     }
1219
1220     SP -= items;
1221     PUTBACK;
1222
1223     ret = CALLREG_NAMED_BUFF_ALL(rx, (flags | RXapif_REGNAMES));
1224
1225     SPAGAIN;
1226
1227     if (!ret)
1228         XSRETURN_UNDEF;
1229
1230     av = MUTABLE_AV(SvRV(ret));
1231     length = av_len(av);
1232
1233     for (i = 0; i <= length; i++) {
1234         entry = av_fetch(av, i, FALSE);
1235
1236         if (!entry)
1237             Perl_croak(aTHX_ "NULL array element in re::regnames()");
1238
1239         mXPUSHs(SvREFCNT_inc_simple_NN(*entry));
1240     }
1241
1242     SvREFCNT_dec(ret);
1243
1244     PUTBACK;
1245     return;
1246 }
1247
1248 XS(XS_re_regexp_pattern)
1249 {
1250     dVAR;
1251     dXSARGS;
1252     REGEXP *re;
1253
1254     if (items != 1)
1255         croak_xs_usage(cv, "sv");
1256
1257     SP -= items;
1258
1259     /*
1260        Checks if a reference is a regex or not. If the parameter is
1261        not a ref, or is not the result of a qr// then returns false
1262        in scalar context and an empty list in list context.
1263        Otherwise in list context it returns the pattern and the
1264        modifiers, in scalar context it returns the pattern just as it
1265        would if the qr// was stringified normally, regardless as
1266        to the class of the variable and any stringification overloads
1267        on the object.
1268     */
1269
1270     if ((re = SvRX(ST(0)))) /* assign deliberate */
1271     {
1272         /* Houston, we have a regex! */
1273         SV *pattern;
1274
1275         if ( GIMME_V == G_ARRAY ) {
1276             STRLEN left = 0;
1277             char reflags[sizeof(INT_PAT_MODS) + MAX_CHARSET_NAME_LENGTH];
1278             const char *fptr;
1279             char ch;
1280             U16 match_flags;
1281
1282             /*
1283                we are in list context so stringify
1284                the modifiers that apply. We ignore "negative
1285                modifiers" in this scenario, and the default character set
1286             */
1287
1288             if (get_regex_charset(RX_EXTFLAGS(re)) != REGEX_DEPENDS_CHARSET) {
1289                 STRLEN len;
1290                 const char* const name = get_regex_charset_name(RX_EXTFLAGS(re),
1291                                                                 &len);
1292                 Copy(name, reflags + left, len, char);
1293                 left += len;
1294             }
1295             fptr = INT_PAT_MODS;
1296             match_flags = (U16)((RX_EXTFLAGS(re) & RXf_PMf_COMPILETIME)
1297                                     >> RXf_PMf_STD_PMMOD_SHIFT);
1298
1299             while((ch = *fptr++)) {
1300                 if(match_flags & 1) {
1301                     reflags[left++] = ch;
1302                 }
1303                 match_flags >>= 1;
1304             }
1305
1306             pattern = newSVpvn_flags(RX_PRECOMP(re),RX_PRELEN(re),
1307                                      (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP);
1308
1309             /* return the pattern and the modifiers */
1310             XPUSHs(pattern);
1311             XPUSHs(newSVpvn_flags(reflags, left, SVs_TEMP));
1312             XSRETURN(2);
1313         } else {
1314             /* Scalar, so use the string that Perl would return */
1315             /* return the pattern in (?msix:..) format */
1316 #if PERL_VERSION >= 11
1317             pattern = sv_2mortal(newSVsv(MUTABLE_SV(re)));
1318 #else
1319             pattern = newSVpvn_flags(RX_WRAPPED(re), RX_WRAPLEN(re),
1320                                      (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP);
1321 #endif
1322             XPUSHs(pattern);
1323             XSRETURN(1);
1324         }
1325     } else {
1326         /* It ain't a regexp folks */
1327         if ( GIMME_V == G_ARRAY ) {
1328             /* return the empty list */
1329             XSRETURN_UNDEF;
1330         } else {
1331             /* Because of the (?:..) wrapping involved in a
1332                stringified pattern it is impossible to get a
1333                result for a real regexp that would evaluate to
1334                false. Therefore we can return PL_sv_no to signify
1335                that the object is not a regex, this means that one
1336                can say
1337
1338                  if (regex($might_be_a_regex) eq '(?:foo)') { }
1339
1340                and not worry about undefined values.
1341             */
1342             XSRETURN_NO;
1343         }
1344     }
1345     /* NOT-REACHED */
1346 }
1347
1348 struct xsub_details {
1349     const char *name;
1350     XSUBADDR_t xsub;
1351     const char *proto;
1352 };
1353
1354 struct xsub_details details[] = {
1355     {"UNIVERSAL::isa", XS_UNIVERSAL_isa, NULL},
1356     {"UNIVERSAL::can", XS_UNIVERSAL_can, NULL},
1357     {"UNIVERSAL::DOES", XS_UNIVERSAL_DOES, NULL},
1358     {"UNIVERSAL::VERSION", XS_UNIVERSAL_VERSION, NULL},
1359     {"version::()", XS_version_noop, NULL},
1360     {"version::new", XS_version_new, NULL},
1361     {"version::parse", XS_version_new, NULL},
1362     {"version::(\"\"", XS_version_stringify, NULL},
1363     {"version::stringify", XS_version_stringify, NULL},
1364     {"version::(0+", XS_version_numify, NULL},
1365     {"version::numify", XS_version_numify, NULL},
1366     {"version::normal", XS_version_normal, NULL},
1367     {"version::(cmp", XS_version_vcmp, NULL},
1368     {"version::(<=>", XS_version_vcmp, NULL},
1369     {"version::vcmp", XS_version_vcmp, NULL},
1370     {"version::(bool", XS_version_boolean, NULL},
1371     {"version::boolean", XS_version_boolean, 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::(*=", XS_version_noop, NULL},
1379     {"version::(/=", XS_version_noop, NULL},
1380     {"version::(abs", XS_version_noop, NULL},
1381     {"version::(nomethod", XS_version_noop, NULL},
1382     {"version::noop", XS_version_noop, NULL},
1383     {"version::is_alpha", XS_version_is_alpha, NULL},
1384     {"version::qv", XS_version_qv, NULL},
1385     {"version::declare", XS_version_qv, NULL},
1386     {"version::is_qv", XS_version_is_qv, NULL},
1387     {"utf8::is_utf8", XS_utf8_is_utf8, NULL},
1388     {"utf8::valid", XS_utf8_valid, NULL},
1389     {"utf8::encode", XS_utf8_encode, NULL},
1390     {"utf8::decode", XS_utf8_decode, NULL},
1391     {"utf8::upgrade", XS_utf8_upgrade, NULL},
1392     {"utf8::downgrade", XS_utf8_downgrade, NULL},
1393     {"utf8::native_to_unicode", XS_utf8_native_to_unicode, NULL},
1394     {"utf8::unicode_to_native", XS_utf8_unicode_to_native, NULL},
1395     {"Internals::SvREADONLY", XS_Internals_SvREADONLY, "\\[$%@];$"},
1396     {"Internals::SvREFCNT", XS_Internals_SvREFCNT, "\\[$%@];$"},
1397     {"Internals::hv_clear_placeholders", XS_Internals_hv_clear_placehold, "\\%"},
1398     {"PerlIO::get_layers", XS_PerlIO_get_layers, "*;@"},
1399     {"Internals::hash_seed", XS_Internals_hash_seed, ""},
1400     {"Internals::rehash_seed", XS_Internals_rehash_seed, ""},
1401     {"Internals::HvREHASH", XS_Internals_HvREHASH, "\\%"},
1402     {"re::is_regexp", XS_re_is_regexp, "$"},
1403     {"re::regname", XS_re_regname, ";$$"},
1404     {"re::regnames", XS_re_regnames, ";$"},
1405     {"re::regnames_count", XS_re_regnames_count, ""},
1406     {"re::regexp_pattern", XS_re_regexp_pattern, "$"},
1407 };
1408
1409 void
1410 Perl_boot_core_UNIVERSAL(pTHX)
1411 {
1412     dVAR;
1413     static const char file[] = __FILE__;
1414     struct xsub_details *xsub = details;
1415     const struct xsub_details *end
1416         = details + sizeof(details) / sizeof(details[0]);
1417
1418     do {
1419         newXS_flags(xsub->name, xsub->xsub, file, xsub->proto, 0);
1420     } while (++xsub < end);
1421
1422     /* register the overloading (type 'A') magic */
1423     PL_amagic_generation++;
1424
1425     /* Providing a Regexp::DESTROY fixes #21347. See test in t/op/ref.t  */
1426     {
1427         CV * const cv =
1428             newCONSTSUB(get_hv("Regexp::", GV_ADD), "DESTROY", NULL);
1429         Safefree(CvFILE(cv));
1430         CvFILE(cv) = (char *)file;
1431         CvDYNFILE_off(cv);
1432     }
1433 }
1434
1435 /*
1436  * Local variables:
1437  * c-indentation-style: bsd
1438  * c-basic-offset: 4
1439  * indent-tabs-mode: t
1440  * End:
1441  *
1442  * ex: set ts=8 sts=4 sw=4 noet:
1443  */