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