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) && !SvIsCOW(sv))
 916              XSRETURN_YES;
 917          else
 918              XSRETURN_NO;
 919     }
 920     else if (items == 2) {
 921         if (SvTRUE(ST(1))) {
 922             if (SvIsCOW(sv)) sv_force_normal(sv);
 923             SvREADONLY_on(sv);
 924             if (SvTYPE(sv) == SVt_PVAV && AvFILLp(sv) != -1) {
 925                 /* for constant.pm; nobody else should be calling this
 926                    on arrays anyway. */
 927                 SV **svp;
 928                 for (svp = AvARRAY(sv) + AvFILLp(sv)
 929                    ; svp >= AvARRAY(sv)
 930                    ; --svp)
 931                     if (*svp) SvPADTMP_on(*svp);
 932             }
 933             XSRETURN_YES;
 934         }
 935         else {
 936             /* I hope you really know what you are doing. */
 937             if (!SvIsCOW(sv)) SvREADONLY_off(sv);
 938             XSRETURN_NO;
 939         }
 940     }
 941     XSRETURN_UNDEF; /* Can't happen. */
 942 }
 943 XS(XS_Internals_SvREFCNT)       /* This is dangerous stuff. */
 944 {
 945     dVAR;
 946     dXSARGS;
 947     SV * const svz = ST(0);
 948     SV * sv;
 949     U32 refcnt;
 950     PERL_UNUSED_ARG(cv);
 951
 952     /* [perl #77776] - called as &foo() not foo() */
 953     if ((items != 1 && items != 2) || !SvROK(svz))
 954         croak_xs_usage(cv, "SCALAR[, REFCOUNT]");
 955
 956     sv = SvRV(svz);
 957
 958          /* I hope you really know what you are doing. */
 959     /* idea is for SvREFCNT(sv) to be accessed only once */
 960     refcnt = items == 2 ?
 961                 /* we free one ref on exit */
 962                 (SvREFCNT(sv) = SvUV(ST(1)) + 1)
 963                 : SvREFCNT(sv);
 964     XSRETURN_UV(refcnt - 1); /* Minus the ref created for us. */
 965
 966 }
 967
 968 XS(XS_Internals_hv_clear_placehold)
 969 {
 970     dVAR;
 971     dXSARGS;
 972
 973     if (items != 1 || !SvROK(ST(0)))
 974         croak_xs_usage(cv, "hv");
 975     else {
 976         HV * const hv = MUTABLE_HV(SvRV(ST(0)));
 977         hv_clear_placeholders(hv);
 978         XSRETURN(0);
 979     }
 980 }
 981
 982 XS(XS_PerlIO_get_layers)
 983 {
 984     dVAR;
 985     dXSARGS;
 986     if (items < 1 || items % 2 == 0)
 987         croak_xs_usage(cv, "filehandle[,args]");
 988 #ifdef USE_PERLIO
 989     {
 990         SV *    sv;
 991         GV *    gv;
 992         IO *    io;
 993         bool    input = TRUE;
 994         bool    details = FALSE;
 995
 996         if (items > 1) {
 997              SV * const *svp;
 998              for (svp = MARK + 2; svp <= SP; svp += 2) {
 999                   SV * const * const varp = svp;
1000                   SV * const * const valp = svp + 1;
1001                   STRLEN klen;
1002                   const char * const key = SvPV_const(*varp, klen);
1003
1004                   switch (*key) {
1005                   case 'i':
1006                        if (klen == 5 && memEQ(key, "input", 5)) {
1007                             input = SvTRUE(*valp);
1008                             break;
1009                        }
1010                        goto fail;
1011                   case 'o':
1012                        if (klen == 6 && memEQ(key, "output", 6)) {
1013                             input = !SvTRUE(*valp);
1014                             break;
1015                        }
1016                        goto fail;
1017                   case 'd':
1018                        if (klen == 7 && memEQ(key, "details", 7)) {
1019                             details = SvTRUE(*valp);
1020                             break;
1021                        }
1022                        goto fail;
1023                   default:
1024                   fail:
1025                        Perl_croak(aTHX_
1026                                   "get_layers: unknown argument '%s'",
1027                                   key);
1028                   }
1029              }
1030
1031              SP -= (items - 1);
1032         }
1033
1034         sv = POPs;
1035         gv = MAYBE_DEREF_GV(sv);
1036
1037         if (!gv && !SvROK(sv))
1038             gv = gv_fetchsv_nomg(sv, 0, SVt_PVIO);
1039
1040         if (gv && (io = GvIO(gv))) {
1041              AV* const av = PerlIO_get_layers(aTHX_ input ?
1042                                         IoIFP(io) : IoOFP(io));
1043              I32 i;
1044              const I32 last = av_len(av);
1045              I32 nitem = 0;
1046
1047              for (i = last; i >= 0; i -= 3) {
1048                   SV * const * const namsvp = av_fetch(av, i - 2, FALSE);
1049                   SV * const * const argsvp = av_fetch(av, i - 1, FALSE);
1050                   SV * const * const flgsvp = av_fetch(av, i,     FALSE);
1051
1052                   const bool namok = namsvp && *namsvp && SvPOK(*namsvp);
1053                   const bool argok = argsvp && *argsvp && SvPOK(*argsvp);
1054                   const bool flgok = flgsvp && *flgsvp && SvIOK(*flgsvp);
1055
1056                   EXTEND(SP, 3); /* Three is the max in all branches: better check just once */
1057                   if (details) {
1058                       /* Indents of 5? Yuck.  */
1059                       /* We know that PerlIO_get_layers creates a new SV for
1060                          the name and flags, so we can just take a reference
1061                          and "steal" it when we free the AV below.  */
1062                        PUSHs(namok
1063                               ? sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp))
1064                               : &PL_sv_undef);
1065                        PUSHs(argok
1066                               ? newSVpvn_flags(SvPVX_const(*argsvp),
1067                                                SvCUR(*argsvp),
1068                                                (SvUTF8(*argsvp) ? SVf_UTF8 : 0)
1069                                                | SVs_TEMP)
1070                               : &PL_sv_undef);
1071                        PUSHs(flgok
1072                               ? sv_2mortal(SvREFCNT_inc_simple_NN(*flgsvp))
1073                               : &PL_sv_undef);
1074                        nitem += 3;
1075                   }
1076                   else {
1077                        if (namok && argok)
1078                             PUSHs(sv_2mortal(Perl_newSVpvf(aTHX_ "%"SVf"(%"SVf")",
1079                                                  SVfARG(*namsvp),
1080                                                  SVfARG(*argsvp))));
1081                        else if (namok)
1082                             PUSHs(sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp)));
1083                        else
1084                             PUSHs(&PL_sv_undef);
1085                        nitem++;
1086                        if (flgok) {
1087                             const IV flags = SvIVX(*flgsvp);
1088
1089                             if (flags & PERLIO_F_UTF8) {
1090                                  PUSHs(newSVpvs_flags("utf8", SVs_TEMP));
1091                                  nitem++;
1092                             }
1093                        }
1094                   }
1095              }
1096
1097              SvREFCNT_dec(av);
1098
1099              XSRETURN(nitem);
1100         }
1101     }
1102 #endif
1103
1104     XSRETURN(0);
1105 }
1106
1107
1108 XS(XS_re_is_regexp)
1109 {
1110     dVAR;
1111     dXSARGS;
1112     PERL_UNUSED_VAR(cv);
1113
1114     if (items != 1)
1115         croak_xs_usage(cv, "sv");
1116
1117     if (SvRXOK(ST(0))) {
1118         XSRETURN_YES;
1119     } else {
1120         XSRETURN_NO;
1121     }
1122 }
1123
1124 XS(XS_re_regnames_count)
1125 {
1126     REGEXP *rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1127     SV * ret;
1128     dVAR;
1129     dXSARGS;
1130
1131     if (items != 0)
1132         croak_xs_usage(cv, "");
1133
1134     SP -= items;
1135     PUTBACK;
1136
1137     if (!rx)
1138         XSRETURN_UNDEF;
1139
1140     ret = CALLREG_NAMED_BUFF_COUNT(rx);
1141
1142     SPAGAIN;
1143     PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef);
1144     XSRETURN(1);
1145 }
1146
1147 XS(XS_re_regname)
1148 {
1149     dVAR;
1150     dXSARGS;
1151     REGEXP * rx;
1152     U32 flags;
1153     SV * ret;
1154
1155     if (items < 1 || items > 2)
1156         croak_xs_usage(cv, "name[, all ]");
1157
1158     SP -= items;
1159     PUTBACK;
1160
1161     rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1162
1163     if (!rx)
1164         XSRETURN_UNDEF;
1165
1166     if (items == 2 && SvTRUE(ST(1))) {
1167         flags = RXapif_ALL;
1168     } else {
1169         flags = RXapif_ONE;
1170     }
1171     ret = CALLREG_NAMED_BUFF_FETCH(rx, ST(0), (flags | RXapif_REGNAME));
1172
1173     SPAGAIN;
1174     PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef);
1175     XSRETURN(1);
1176 }
1177
1178
1179 XS(XS_re_regnames)
1180 {
1181     dVAR;
1182     dXSARGS;
1183     REGEXP * rx;
1184     U32 flags;
1185     SV *ret;
1186     AV *av;
1187     I32 length;
1188     I32 i;
1189     SV **entry;
1190
1191     if (items > 1)
1192         croak_xs_usage(cv, "[all]");
1193
1194     rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1195
1196     if (!rx)
1197         XSRETURN_UNDEF;
1198
1199     if (items == 1 && SvTRUE(ST(0))) {
1200         flags = RXapif_ALL;
1201     } else {
1202         flags = RXapif_ONE;
1203     }
1204
1205     SP -= items;
1206     PUTBACK;
1207
1208     ret = CALLREG_NAMED_BUFF_ALL(rx, (flags | RXapif_REGNAMES));
1209
1210     SPAGAIN;
1211
1212     if (!ret)
1213         XSRETURN_UNDEF;
1214
1215     av = MUTABLE_AV(SvRV(ret));
1216     length = av_len(av);
1217
1218     EXTEND(SP, length+1); /* better extend stack just once */
1219     for (i = 0; i <= length; i++) {
1220         entry = av_fetch(av, i, FALSE);
1221
1222         if (!entry)
1223             Perl_croak(aTHX_ "NULL array element in re::regnames()");
1224
1225         mPUSHs(SvREFCNT_inc_simple_NN(*entry));
1226     }
1227
1228     SvREFCNT_dec(ret);
1229
1230     PUTBACK;
1231     return;
1232 }
1233
1234 XS(XS_re_regexp_pattern)
1235 {
1236     dVAR;
1237     dXSARGS;
1238     REGEXP *re;
1239
1240     EXTEND(SP, 2);
1241     SP -= items;
1242     if (items != 1)
1243         croak_xs_usage(cv, "sv");
1244
1245     /*
1246        Checks if a reference is a regex or not. If the parameter is
1247        not a ref, or is not the result of a qr// then returns false
1248        in scalar context and an empty list in list context.
1249        Otherwise in list context it returns the pattern and the
1250        modifiers, in scalar context it returns the pattern just as it
1251        would if the qr// was stringified normally, regardless as
1252        to the class of the variable and any stringification overloads
1253        on the object.
1254     */
1255
1256     if ((re = SvRX(ST(0)))) /* assign deliberate */
1257     {
1258         /* Houston, we have a regex! */
1259         SV *pattern;
1260
1261         if ( GIMME_V == G_ARRAY ) {
1262             STRLEN left = 0;
1263             char reflags[sizeof(INT_PAT_MODS) + MAX_CHARSET_NAME_LENGTH];
1264             const char *fptr;
1265             char ch;
1266             U16 match_flags;
1267
1268             /*
1269                we are in list context so stringify
1270                the modifiers that apply. We ignore "negative
1271                modifiers" in this scenario, and the default character set
1272             */
1273
1274             if (get_regex_charset(RX_EXTFLAGS(re)) != REGEX_DEPENDS_CHARSET) {
1275                 STRLEN len;
1276                 const char* const name = get_regex_charset_name(RX_EXTFLAGS(re),
1277                                                                 &len);
1278                 Copy(name, reflags + left, len, char);
1279                 left += len;
1280             }
1281             fptr = INT_PAT_MODS;
1282             match_flags = (U16)((RX_EXTFLAGS(re) & RXf_PMf_COMPILETIME)
1283                                     >> RXf_PMf_STD_PMMOD_SHIFT);
1284
1285             while((ch = *fptr++)) {
1286                 if(match_flags & 1) {
1287                     reflags[left++] = ch;
1288                 }
1289                 match_flags >>= 1;
1290             }
1291
1292             pattern = newSVpvn_flags(RX_PRECOMP(re),RX_PRELEN(re),
1293                                      (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP);
1294
1295             /* return the pattern and the modifiers */
1296             PUSHs(pattern);
1297             PUSHs(newSVpvn_flags(reflags, left, SVs_TEMP));
1298             XSRETURN(2);
1299         } else {
1300             /* Scalar, so use the string that Perl would return */
1301             /* return the pattern in (?msix:..) format */
1302 #if PERL_VERSION >= 11
1303             pattern = sv_2mortal(newSVsv(MUTABLE_SV(re)));
1304 #else
1305             pattern = newSVpvn_flags(RX_WRAPPED(re), RX_WRAPLEN(re),
1306                                      (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP);
1307 #endif
1308             PUSHs(pattern);
1309             XSRETURN(1);
1310         }
1311     } else {
1312         /* It ain't a regexp folks */
1313         if ( GIMME_V == G_ARRAY ) {
1314             /* return the empty list */
1315             XSRETURN_UNDEF;
1316         } else {
1317             /* Because of the (?:..) wrapping involved in a
1318                stringified pattern it is impossible to get a
1319                result for a real regexp that would evaluate to
1320                false. Therefore we can return PL_sv_no to signify
1321                that the object is not a regex, this means that one
1322                can say
1323
1324                  if (regex($might_be_a_regex) eq '(?:foo)') { }
1325
1326                and not worry about undefined values.
1327             */
1328             XSRETURN_NO;
1329         }
1330     }
1331     /* NOT-REACHED */
1332 }
1333
1334 struct xsub_details {
1335     const char *name;
1336     XSUBADDR_t xsub;
1337     const char *proto;
1338 };
1339
1340 const struct xsub_details details[] = {
1341     {"UNIVERSAL::isa", XS_UNIVERSAL_isa, NULL},
1342     {"UNIVERSAL::can", XS_UNIVERSAL_can, NULL},
1343     {"UNIVERSAL::DOES", XS_UNIVERSAL_DOES, NULL},
1344     {"UNIVERSAL::VERSION", XS_UNIVERSAL_VERSION, NULL},
1345     {"version::()", XS_version_noop, NULL},
1346     {"version::new", XS_version_new, NULL},
1347     {"version::parse", XS_version_new, NULL},
1348     {"version::(\"\"", XS_version_stringify, NULL},
1349     {"version::stringify", XS_version_stringify, NULL},
1350     {"version::(0+", XS_version_numify, NULL},
1351     {"version::numify", XS_version_numify, NULL},
1352     {"version::normal", XS_version_normal, NULL},
1353     {"version::(cmp", XS_version_vcmp, NULL},
1354     {"version::(<=>", XS_version_vcmp, NULL},
1355     {"version::vcmp", XS_version_vcmp, NULL},
1356     {"version::(bool", XS_version_boolean, NULL},
1357     {"version::boolean", XS_version_boolean, NULL},
1358     {"version::(+", XS_version_noop, NULL},
1359     {"version::(-", XS_version_noop, 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::(abs", XS_version_noop, NULL},
1367     {"version::(nomethod", XS_version_noop, NULL},
1368     {"version::noop", XS_version_noop, NULL},
1369     {"version::is_alpha", XS_version_is_alpha, NULL},
1370     {"version::qv", XS_version_qv, NULL},
1371     {"version::declare", XS_version_qv, NULL},
1372     {"version::is_qv", XS_version_is_qv, NULL},
1373     {"utf8::is_utf8", XS_utf8_is_utf8, NULL},
1374     {"utf8::valid", XS_utf8_valid, NULL},
1375     {"utf8::encode", XS_utf8_encode, NULL},
1376     {"utf8::decode", XS_utf8_decode, NULL},
1377     {"utf8::upgrade", XS_utf8_upgrade, NULL},
1378     {"utf8::downgrade", XS_utf8_downgrade, NULL},
1379     {"utf8::native_to_unicode", XS_utf8_native_to_unicode, NULL},
1380     {"utf8::unicode_to_native", XS_utf8_unicode_to_native, NULL},
1381     {"Internals::SvREADONLY", XS_Internals_SvREADONLY, "\\[$%@];$"},
1382     {"Internals::SvREFCNT", XS_Internals_SvREFCNT, "\\[$%@];$"},
1383     {"Internals::hv_clear_placeholders", XS_Internals_hv_clear_placehold, "\\%"},
1384     {"PerlIO::get_layers", XS_PerlIO_get_layers, "*;@"},
1385     {"re::is_regexp", XS_re_is_regexp, "$"},
1386     {"re::regname", XS_re_regname, ";$$"},
1387     {"re::regnames", XS_re_regnames, ";$"},
1388     {"re::regnames_count", XS_re_regnames_count, ""},
1389     {"re::regexp_pattern", XS_re_regexp_pattern, "$"},
1390 };
1391
1392 void
1393 Perl_boot_core_UNIVERSAL(pTHX)
1394 {
1395     dVAR;
1396     static const char file[] = __FILE__;
1397     const struct xsub_details *xsub = details;
1398     const struct xsub_details *end
1399         = details + sizeof(details) / sizeof(details[0]);
1400
1401     do {
1402         newXS_flags(xsub->name, xsub->xsub, file, xsub->proto, 0);
1403     } while (++xsub < end);
1404
1405     /* Providing a Regexp::DESTROY fixes #21347. See test in t/op/ref.t  */
1406     {
1407         CV * const cv =
1408             newCONSTSUB(get_hv("Regexp::", GV_ADD), "DESTROY", NULL);
1409         Safefree(CvFILE(cv));
1410         CvFILE(cv) = (char *)file;
1411         CvDYNFILE_off(cv);
1412     }
1413 }
1414
1415 /*
1416  * Local variables:
1417  * c-indentation-style: bsd
1418  * c-basic-offset: 4
1419  * indent-tabs-mode: nil
1420  * End:
1421  *
1422  * ex: set ts=8 sts=4 sw=4 et:
1423  */