universal.c

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