gv.c

   1 /*    gv.c
   2  *
   3  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
   4  *    2000, 2001, 2002, 2003, 2004, 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  *   'Mercy!' cried Gandalf.  'If the giving of information is to be the cure
  13  * of your inquisitiveness, I shall spend all the rest of my days answering
  14  * you.  What more do you want to know?'
  15  *   'The names of all the stars, and of all living things, and the whole
  16  * history of Middle-earth and Over-heaven and of the Sundering Seas,'
  17  * laughed Pippin.
  18  */
  19
  20 /*
  21 =head1 GV Functions
  22
  23 A GV is a structure which corresponds to to a Perl typeglob, ie *foo.
  24 It is a structure that holds a pointer to a scalar, an array, a hash etc,
  25 corresponding to $foo, @foo, %foo.
  26
  27 GVs are usually found as values in stashes (symbol table hashes) where
  28 Perl stores its global variables.
  29
  30 =cut
  31 */
  32
  33 #include "EXTERN.h"
  34 #define PERL_IN_GV_C
  35 #include "perl.h"
  36
  37 GV *
  38 Perl_gv_AVadd(pTHX_ register GV *gv)
  39 {
  40     if (!gv || SvTYPE((SV*)gv) != SVt_PVGV)
  41         Perl_croak(aTHX_ "Bad symbol for array");
  42     if (!GvAV(gv))
  43         GvAV(gv) = newAV();
  44     return gv;
  45 }
  46
  47 GV *
  48 Perl_gv_HVadd(pTHX_ register GV *gv)
  49 {
  50     if (!gv || SvTYPE((SV*)gv) != SVt_PVGV)
  51         Perl_croak(aTHX_ "Bad symbol for hash");
  52     if (!GvHV(gv))
  53         GvHV(gv) = newHV();
  54     return gv;
  55 }
  56
  57 GV *
  58 Perl_gv_IOadd(pTHX_ register GV *gv)
  59 {
  60     if (!gv || SvTYPE((SV*)gv) != SVt_PVGV)
  61         Perl_croak(aTHX_ "Bad symbol for filehandle");
  62     if (!GvIOp(gv)) {
  63 #ifdef GV_UNIQUE_CHECK
  64         if (GvUNIQUE(gv)) {
  65             Perl_croak(aTHX_ "Bad symbol for filehandle (GV is unique)");
  66         }
  67 #endif
  68         GvIOp(gv) = newIO();
  69     }
  70     return gv;
  71 }
  72
  73 GV *
  74 Perl_gv_fetchfile(pTHX_ const char *name)
  75 {
  76     char smallbuf[256];
  77     char *tmpbuf;
  78     STRLEN tmplen;
  79     GV *gv;
  80
  81     if (!PL_defstash)
  82         return Nullgv;
  83
  84     tmplen = strlen(name) + 2;
  85     if (tmplen < sizeof smallbuf)
  86         tmpbuf = smallbuf;
  87     else
  88         New(603, tmpbuf, tmplen + 1, char);
  89     /* This is where the debugger's %{"::_<$filename"} hash is created */
  90     tmpbuf[0] = '_';
  91     tmpbuf[1] = '<';
  92     strcpy(tmpbuf + 2, name);
  93     gv = *(GV**)hv_fetch(PL_defstash, tmpbuf, tmplen, TRUE);
  94     if (!isGV(gv)) {
  95         gv_init(gv, PL_defstash, tmpbuf, tmplen, FALSE);
  96         sv_setpv(GvSV(gv), name);
  97         if (PERLDB_LINE)
  98             hv_magic(GvHVn(gv_AVadd(gv)), Nullgv, PERL_MAGIC_dbfile);
  99     }
 100     if (tmpbuf != smallbuf)
 101         Safefree(tmpbuf);
 102     return gv;
 103 }
 104
 105 void
 106 Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi)
 107 {
 108     register GP *gp;
 109     bool doproto = SvTYPE(gv) > SVt_NULL;
 110     char *proto = (doproto && SvPOK(gv)) ? SvPVX(gv) : NULL;
 111
 112     sv_upgrade((SV*)gv, SVt_PVGV);
 113     if (SvLEN(gv)) {
 114         if (proto) {
 115             SvPVX(gv) = NULL;
 116             SvLEN(gv) = 0;
 117             SvPOK_off(gv);
 118         } else
 119             Safefree(SvPVX(gv));
 120     }
 121     Newz(602, gp, 1, GP);
 122     GvGP(gv) = gp_ref(gp);
 123     GvSV(gv) = NEWSV(72,0);
 124     GvLINE(gv) = CopLINE(PL_curcop);
 125     GvFILE(gv) = CopFILE(PL_curcop) ? CopFILE(PL_curcop) : "";
 126     GvCVGEN(gv) = 0;
 127     GvEGV(gv) = gv;
 128     sv_magic((SV*)gv, (SV*)gv, PERL_MAGIC_glob, Nullch, 0);
 129     GvSTASH(gv) = (HV*)SvREFCNT_inc(stash);
 130     GvNAME(gv) = savepvn(name, len);
 131     GvNAMELEN(gv) = len;
 132     if (multi || doproto)              /* doproto means it _was_ mentioned */
 133         GvMULTI_on(gv);
 134     if (doproto) {                      /* Replicate part of newSUB here. */
 135         SvIOK_off(gv);
 136         ENTER;
 137         /* XXX unsafe for threads if eval_owner isn't held */
 138         start_subparse(0,0);            /* Create CV in compcv. */
 139         GvCV(gv) = PL_compcv;
 140         LEAVE;
 141
 142         PL_sub_generation++;
 143         CvGV(GvCV(gv)) = gv;
 144         CvFILE_set_from_cop(GvCV(gv), PL_curcop);
 145         CvSTASH(GvCV(gv)) = PL_curstash;
 146         if (proto) {
 147             sv_setpv((SV*)GvCV(gv), proto);
 148             Safefree(proto);
 149         }
 150     }
 151 }
 152
 153 STATIC void
 154 S_gv_init_sv(pTHX_ GV *gv, I32 sv_type)
 155 {
 156     switch (sv_type) {
 157     case SVt_PVIO:
 158         (void)GvIOn(gv);
 159         break;
 160     case SVt_PVAV:
 161         (void)GvAVn(gv);
 162         break;
 163     case SVt_PVHV:
 164         (void)GvHVn(gv);
 165         break;
 166     }
 167 }
 168
 169 /*
 170 =for apidoc gv_fetchmeth
 171
 172 Returns the glob with the given C<name> and a defined subroutine or
 173 C<NULL>.  The glob lives in the given C<stash>, or in the stashes
 174 accessible via @ISA and UNIVERSAL::.
 175
 176 The argument C<level> should be either 0 or -1.  If C<level==0>, as a
 177 side-effect creates a glob with the given C<name> in the given C<stash>
 178 which in the case of success contains an alias for the subroutine, and sets
 179 up caching info for this glob.  Similarly for all the searched stashes.
 180
 181 This function grants C<"SUPER"> token as a postfix of the stash name. The
 182 GV returned from C<gv_fetchmeth> may be a method cache entry, which is not
 183 visible to Perl code.  So when calling C<call_sv>, you should not use
 184 the GV directly; instead, you should use the method's CV, which can be
 185 obtained from the GV with the C<GvCV> macro.
 186
 187 =cut
 188 */
 189
 190 GV *
 191 Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level)
 192 {
 193     AV* av;
 194     GV* topgv;
 195     GV* gv;
 196     GV** gvp;
 197     CV* cv;
 198
 199     /* UNIVERSAL methods should be callable without a stash */
 200     if (!stash) {
 201         level = -1;  /* probably appropriate */
 202         if(!(stash = gv_stashpvn("UNIVERSAL", 9, FALSE)))
 203             return 0;
 204     }
 205
 206     if (!HvNAME(stash))
 207       Perl_croak(aTHX_
 208                  "Can't use anonymous symbol table for method lookup");
 209
 210     if ((level > 100) || (level < -100))
 211         Perl_croak(aTHX_ "Recursive inheritance detected while looking for method '%s' in package '%s'",
 212               name, HvNAME(stash));
 213
 214     DEBUG_o( Perl_deb(aTHX_ "Looking for method %s in package %s\n",name,HvNAME(stash)) );
 215
 216     gvp = (GV**)hv_fetch(stash, name, len, (level >= 0));
 217     if (!gvp)
 218         topgv = Nullgv;
 219     else {
 220         topgv = *gvp;
 221         if (SvTYPE(topgv) != SVt_PVGV)
 222             gv_init(topgv, stash, name, len, TRUE);
 223         if ((cv = GvCV(topgv))) {
 224             /* If genuine method or valid cache entry, use it */
 225             if (!GvCVGEN(topgv) || GvCVGEN(topgv) == PL_sub_generation)
 226                 return topgv;
 227             /* Stale cached entry: junk it */
 228             SvREFCNT_dec(cv);
 229             GvCV(topgv) = cv = Nullcv;
 230             GvCVGEN(topgv) = 0;
 231         }
 232         else if (GvCVGEN(topgv) == PL_sub_generation)
 233             return 0;  /* cache indicates sub doesn't exist */
 234     }
 235
 236     gvp = (GV**)hv_fetch(stash, "ISA", 3, FALSE);
 237     av = (gvp && (gv = *gvp) && gv != (GV*)&PL_sv_undef) ? GvAV(gv) : Nullav;
 238
 239     /* create and re-create @.*::SUPER::ISA on demand */
 240     if (!av || !SvMAGIC(av)) {
 241         char* packname = HvNAME(stash);
 242         STRLEN packlen = strlen(packname);
 243
 244         if (packlen >= 7 && strEQ(packname + packlen - 7, "::SUPER")) {
 245             HV* basestash;
 246
 247             packlen -= 7;
 248             basestash = gv_stashpvn(packname, packlen, TRUE);
 249             gvp = (GV**)hv_fetch(basestash, "ISA", 3, FALSE);
 250             if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (av = GvAV(gv))) {
 251                 gvp = (GV**)hv_fetch(stash, "ISA", 3, TRUE);
 252                 if (!gvp || !(gv = *gvp))
 253                     Perl_croak(aTHX_ "Cannot create %s::ISA", HvNAME(stash));
 254                 if (SvTYPE(gv) != SVt_PVGV)
 255                     gv_init(gv, stash, "ISA", 3, TRUE);
 256                 SvREFCNT_dec(GvAV(gv));
 257                 GvAV(gv) = (AV*)SvREFCNT_inc(av);
 258             }
 259         }
 260     }
 261
 262     if (av) {
 263         SV** svp = AvARRAY(av);
 264         /* NOTE: No support for tied ISA */
 265         I32 items = AvFILLp(av) + 1;
 266         while (items--) {
 267             SV* sv = *svp++;
 268             HV* basestash = gv_stashsv(sv, FALSE);
 269             if (!basestash) {
 270                 if (ckWARN(WARN_MISC))
 271                     Perl_warner(aTHX_ packWARN(WARN_MISC), "Can't locate package %"SVf" for @%s::ISA",
 272                         sv, HvNAME(stash));
 273                 continue;
 274             }
 275             gv = gv_fetchmeth(basestash, name, len,
 276                               (level >= 0) ? level + 1 : level - 1);
 277             if (gv)
 278                 goto gotcha;
 279         }
 280     }
 281
 282     /* if at top level, try UNIVERSAL */
 283
 284     if (level == 0 || level == -1) {
 285         HV* lastchance;
 286
 287         if ((lastchance = gv_stashpvn("UNIVERSAL", 9, FALSE))) {
 288             if ((gv = gv_fetchmeth(lastchance, name, len,
 289                                   (level >= 0) ? level + 1 : level - 1)))
 290             {
 291           gotcha:
 292                 /*
 293                  * Cache method in topgv if:
 294                  *  1. topgv has no synonyms (else inheritance crosses wires)
 295                  *  2. method isn't a stub (else AUTOLOAD fails spectacularly)
 296                  */
 297                 if (topgv &&
 298                     GvREFCNT(topgv) == 1 &&
 299                     (cv = GvCV(gv)) &&
 300                     (CvROOT(cv) || CvXSUB(cv)))
 301                 {
 302                     if ((cv = GvCV(topgv)))
 303                         SvREFCNT_dec(cv);
 304                     GvCV(topgv) = (CV*)SvREFCNT_inc(GvCV(gv));
 305                     GvCVGEN(topgv) = PL_sub_generation;
 306                 }
 307                 return gv;
 308             }
 309             else if (topgv && GvREFCNT(topgv) == 1) {
 310                 /* cache the fact that the method is not defined */
 311                 GvCVGEN(topgv) = PL_sub_generation;
 312             }
 313         }
 314     }
 315
 316     return 0;
 317 }
 318
 319 /*
 320 =for apidoc gv_fetchmeth_autoload
 321
 322 Same as gv_fetchmeth(), but looks for autoloaded subroutines too.
 323 Returns a glob for the subroutine.
 324
 325 For an autoloaded subroutine without a GV, will create a GV even
 326 if C<level < 0>.  For an autoloaded subroutine without a stub, GvCV()
 327 of the result may be zero.
 328
 329 =cut
 330 */
 331
 332 GV *
 333 Perl_gv_fetchmeth_autoload(pTHX_ HV *stash, const char *name, STRLEN len, I32 level)
 334 {
 335     GV *gv = gv_fetchmeth(stash, name, len, level);
 336
 337     if (!gv) {
 338         char autoload[] = "AUTOLOAD";
 339         STRLEN autolen = sizeof(autoload)-1;
 340         CV *cv;
 341         GV **gvp;
 342
 343         if (!stash)
 344             return Nullgv;      /* UNIVERSAL::AUTOLOAD could cause trouble */
 345         if (len == autolen && strnEQ(name, autoload, autolen))
 346             return Nullgv;
 347         if (!(gv = gv_fetchmeth(stash, autoload, autolen, FALSE)))
 348             return Nullgv;
 349         cv = GvCV(gv);
 350         if (!(CvROOT(cv) || CvXSUB(cv)))
 351             return Nullgv;
 352         /* Have an autoload */
 353         if (level < 0)  /* Cannot do without a stub */
 354             gv_fetchmeth(stash, name, len, 0);
 355         gvp = (GV**)hv_fetch(stash, name, len, (level >= 0));
 356         if (!gvp)
 357             return Nullgv;
 358         return *gvp;
 359     }
 360     return gv;
 361 }
 362
 363 /*
 364 =for apidoc gv_fetchmethod
 365
 366 See L<gv_fetchmethod_autoload>.
 367
 368 =cut
 369 */
 370
 371 GV *
 372 Perl_gv_fetchmethod(pTHX_ HV *stash, const char *name)
 373 {
 374     return gv_fetchmethod_autoload(stash, name, TRUE);
 375 }
 376
 377 /*
 378 =for apidoc gv_fetchmethod_autoload
 379
 380 Returns the glob which contains the subroutine to call to invoke the method
 381 on the C<stash>.  In fact in the presence of autoloading this may be the
 382 glob for "AUTOLOAD".  In this case the corresponding variable $AUTOLOAD is
 383 already setup.
 384
 385 The third parameter of C<gv_fetchmethod_autoload> determines whether
 386 AUTOLOAD lookup is performed if the given method is not present: non-zero
 387 means yes, look for AUTOLOAD; zero means no, don't look for AUTOLOAD.
 388 Calling C<gv_fetchmethod> is equivalent to calling C<gv_fetchmethod_autoload>
 389 with a non-zero C<autoload> parameter.
 390
 391 These functions grant C<"SUPER"> token as a prefix of the method name. Note
 392 that if you want to keep the returned glob for a long time, you need to
 393 check for it being "AUTOLOAD", since at the later time the call may load a
 394 different subroutine due to $AUTOLOAD changing its value. Use the glob
 395 created via a side effect to do this.
 396
 397 These functions have the same side-effects and as C<gv_fetchmeth> with
 398 C<level==0>.  C<name> should be writable if contains C<':'> or C<'
 399 ''>. The warning against passing the GV returned by C<gv_fetchmeth> to
 400 C<call_sv> apply equally to these functions.
 401
 402 =cut
 403 */
 404
 405 GV *
 406 Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload)
 407 {
 408     register const char *nend;
 409     const char *nsplit = 0;
 410     GV* gv;
 411     HV* ostash = stash;
 412
 413     if (stash && SvTYPE(stash) < SVt_PVHV)
 414         stash = Nullhv;
 415
 416     for (nend = name; *nend; nend++) {
 417         if (*nend == '\'')
 418             nsplit = nend;
 419         else if (*nend == ':' && *(nend + 1) == ':')
 420             nsplit = ++nend;
 421     }
 422     if (nsplit) {
 423         const char *origname = name;
 424         name = nsplit + 1;
 425         if (*nsplit == ':')
 426             --nsplit;
 427         if ((nsplit - origname) == 5 && strnEQ(origname, "SUPER", 5)) {
 428             /* ->SUPER::method should really be looked up in original stash */
 429             SV *tmpstr = sv_2mortal(Perl_newSVpvf(aTHX_ "%s::SUPER",
 430                                                   CopSTASHPV(PL_curcop)));
 431             /* __PACKAGE__::SUPER stash should be autovivified */
 432             stash = gv_stashpvn(SvPVX(tmpstr), SvCUR(tmpstr), TRUE);
 433             DEBUG_o( Perl_deb(aTHX_ "Treating %s as %s::%s\n",
 434                          origname, HvNAME(stash), name) );
 435         }
 436         else {
 437             /* don't autovifify if ->NoSuchStash::method */
 438             stash = gv_stashpvn(origname, nsplit - origname, FALSE);
 439
 440             /* however, explicit calls to Pkg::SUPER::method may
 441                happen, and may require autovivification to work */
 442             if (!stash && (nsplit - origname) >= 7 &&
 443                 strnEQ(nsplit - 7, "::SUPER", 7) &&
 444                 gv_stashpvn(origname, nsplit - origname - 7, FALSE))
 445               stash = gv_stashpvn(origname, nsplit - origname, TRUE);
 446         }
 447         ostash = stash;
 448     }
 449
 450     gv = gv_fetchmeth(stash, name, nend - name, 0);
 451     if (!gv) {
 452         if (strEQ(name,"import") || strEQ(name,"unimport"))
 453             gv = (GV*)&PL_sv_yes;
 454         else if (autoload)
 455             gv = gv_autoload4(ostash, name, nend - name, TRUE);
 456     }
 457     else if (autoload) {
 458         CV* cv = GvCV(gv);
 459         if (!CvROOT(cv) && !CvXSUB(cv)) {
 460             GV* stubgv;
 461             GV* autogv;
 462
 463             if (CvANON(cv))
 464                 stubgv = gv;
 465             else {
 466                 stubgv = CvGV(cv);
 467                 if (GvCV(stubgv) != cv)         /* orphaned import */
 468                     stubgv = gv;
 469             }
 470             autogv = gv_autoload4(GvSTASH(stubgv),
 471                                   GvNAME(stubgv), GvNAMELEN(stubgv), TRUE);
 472             if (autogv)
 473                 gv = autogv;
 474         }
 475     }
 476
 477     return gv;
 478 }
 479
 480 GV*
 481 Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method)
 482 {
 483     char autoload[] = "AUTOLOAD";
 484     STRLEN autolen = sizeof(autoload)-1;
 485     GV* gv;
 486     CV* cv;
 487     HV* varstash;
 488     GV* vargv;
 489     SV* varsv;
 490     char *packname = "";
 491
 492     if (len == autolen && strnEQ(name, autoload, autolen))
 493         return Nullgv;
 494     if (stash) {
 495         if (SvTYPE(stash) < SVt_PVHV) {
 496             packname = SvPV_nolen((SV*)stash);
 497             stash = Nullhv;
 498         }
 499         else {
 500             packname = HvNAME(stash);
 501         }
 502     }
 503     if (!(gv = gv_fetchmeth(stash, autoload, autolen, FALSE)))
 504         return Nullgv;
 505     cv = GvCV(gv);
 506
 507     if (!(CvROOT(cv) || CvXSUB(cv)))
 508         return Nullgv;
 509
 510     /*
 511      * Inheriting AUTOLOAD for non-methods works ... for now.
 512      */
 513     if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX) && !method &&
 514         (GvCVGEN(gv) || GvSTASH(gv) != stash))
 515         Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
 516           "Use of inherited AUTOLOAD for non-method %s::%.*s() is deprecated",
 517              packname, (int)len, name);
 518
 519     if (CvXSUB(cv)) {
 520         /* rather than lookup/init $AUTOLOAD here
 521          * only to have the XSUB do another lookup for $AUTOLOAD
 522          * and split that value on the last '::',
 523          * pass along the same data via some unused fields in the CV
 524          */
 525         CvSTASH(cv) = stash;
 526         SvPVX(cv) = (char *)name; /* cast to lose constness warning */
 527         SvCUR(cv) = len;
 528         return gv;
 529     }
 530
 531     /*
 532      * Given &FOO::AUTOLOAD, set $FOO::AUTOLOAD to desired function name.
 533      * The subroutine's original name may not be "AUTOLOAD", so we don't
 534      * use that, but for lack of anything better we will use the sub's
 535      * original package to look up $AUTOLOAD.
 536      */
 537     varstash = GvSTASH(CvGV(cv));
 538     vargv = *(GV**)hv_fetch(varstash, autoload, autolen, TRUE);
 539     ENTER;
 540
 541     if (!isGV(vargv))
 542         gv_init(vargv, varstash, autoload, autolen, FALSE);
 543     LEAVE;
 544     varsv = GvSV(vargv);
 545     sv_setpv(varsv, packname);
 546     sv_catpvn(varsv, "::", 2);
 547     sv_catpvn(varsv, name, len);
 548     SvTAINTED_off(varsv);
 549     return gv;
 550 }
 551
 552 /* The "gv" parameter should be the glob known to Perl code as *!
 553  * The scalar must already have been magicalized.
 554  */
 555 STATIC void
 556 S_require_errno(pTHX_ GV *gv)
 557 {
 558     HV* stash = gv_stashpvn("Errno",5,FALSE);
 559
 560     if (!stash || !(gv_fetchmethod(stash, "TIEHASH"))) {
 561         dSP;
 562         PUTBACK;
 563         ENTER;
 564         save_scalar(gv); /* keep the value of $! */
 565         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
 566                          newSVpvn("Errno",5), Nullsv);
 567         LEAVE;
 568         SPAGAIN;
 569         stash = gv_stashpvn("Errno",5,FALSE);
 570         if (!stash || !(gv_fetchmethod(stash, "TIEHASH")))
 571             Perl_croak(aTHX_ "Can't use %%! because Errno.pm is not available");
 572     }
 573 }
 574
 575 /*
 576 =for apidoc gv_stashpv
 577
 578 Returns a pointer to the stash for a specified package.  C<name> should
 579 be a valid UTF-8 string.  If C<create> is set then the package will be
 580 created if it does not already exist.  If C<create> is not set and the
 581 package does not exist then NULL is returned.
 582
 583 =cut
 584 */
 585
 586 HV*
 587 Perl_gv_stashpv(pTHX_ const char *name, I32 create)
 588 {
 589     return gv_stashpvn(name, strlen(name), create);
 590 }
 591
 592 HV*
 593 Perl_gv_stashpvn(pTHX_ const char *name, U32 namelen, I32 create)
 594 {
 595     char smallbuf[256];
 596     char *tmpbuf;
 597     HV *stash;
 598     GV *tmpgv;
 599
 600     if (namelen + 3 < sizeof smallbuf)
 601         tmpbuf = smallbuf;
 602     else
 603         New(606, tmpbuf, namelen + 3, char);
 604     Copy(name,tmpbuf,namelen,char);
 605     tmpbuf[namelen++] = ':';
 606     tmpbuf[namelen++] = ':';
 607     tmpbuf[namelen] = '\0';
 608     tmpgv = gv_fetchpv(tmpbuf, create, SVt_PVHV);
 609     if (tmpbuf != smallbuf)
 610         Safefree(tmpbuf);
 611     if (!tmpgv)
 612         return 0;
 613     if (!GvHV(tmpgv))
 614         GvHV(tmpgv) = newHV();
 615     stash = GvHV(tmpgv);
 616     if (!HvNAME(stash))
 617         HvNAME(stash) = savepv(name);
 618     return stash;
 619 }
 620
 621 /*
 622 =for apidoc gv_stashsv
 623
 624 Returns a pointer to the stash for a specified package, which must be a
 625 valid UTF-8 string.  See C<gv_stashpv>.
 626
 627 =cut
 628 */
 629
 630 HV*
 631 Perl_gv_stashsv(pTHX_ SV *sv, I32 create)
 632 {
 633     register char *ptr;
 634     STRLEN len;
 635     ptr = SvPV(sv,len);
 636     return gv_stashpvn(ptr, len, create);
 637 }
 638
 639
 640 GV *
 641 Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type)
 642 {
 643     register const char *name = nambeg;
 644     register GV *gv = 0;
 645     GV**gvp;
 646     I32 len;
 647     register const char *namend;
 648     HV *stash = 0;
 649
 650     if (*name == '*' && isALPHA(name[1])) /* accidental stringify on a GV? */
 651         name++;
 652
 653     for (namend = name; *namend; namend++) {
 654         if ((*namend == ':' && namend[1] == ':')
 655             || (*namend == '\'' && namend[1]))
 656         {
 657             if (!stash)
 658                 stash = PL_defstash;
 659             if (!stash || !SvREFCNT(stash)) /* symbol table under destruction */
 660                 return Nullgv;
 661
 662             len = namend - name;
 663             if (len > 0) {
 664                 char smallbuf[256];
 665                 char *tmpbuf;
 666
 667                 if (len + 3 < sizeof (smallbuf))
 668                     tmpbuf = smallbuf;
 669                 else
 670                     New(601, tmpbuf, len+3, char);
 671                 Copy(name, tmpbuf, len, char);
 672                 tmpbuf[len++] = ':';
 673                 tmpbuf[len++] = ':';
 674                 tmpbuf[len] = '\0';
 675                 gvp = (GV**)hv_fetch(stash,tmpbuf,len,add);
 676                 gv = gvp ? *gvp : Nullgv;
 677                 if (gv && gv != (GV*)&PL_sv_undef) {
 678                     if (SvTYPE(gv) != SVt_PVGV)
 679                         gv_init(gv, stash, tmpbuf, len, (add & GV_ADDMULTI));
 680                     else
 681                         GvMULTI_on(gv);
 682                 }
 683                 if (tmpbuf != smallbuf)
 684                     Safefree(tmpbuf);
 685                 if (!gv || gv == (GV*)&PL_sv_undef)
 686                     return Nullgv;
 687
 688                 if (!(stash = GvHV(gv)))
 689                     stash = GvHV(gv) = newHV();
 690
 691                 if (!HvNAME(stash))
 692                     HvNAME(stash) = savepvn(nambeg, namend - nambeg);
 693             }
 694
 695             if (*namend == ':')
 696                 namend++;
 697             namend++;
 698             name = namend;
 699             if (!*name)
 700                 return gv ? gv : (GV*)*hv_fetch(PL_defstash, "main::", 6, TRUE);
 701         }
 702     }
 703     len = namend - name;
 704
 705     /* No stash in name, so see how we can default */
 706
 707     if (!stash) {
 708         if (isIDFIRST_lazy(name)) {
 709             bool global = FALSE;
 710
 711             if (isUPPER(*name)) {
 712                 if (*name == 'S' && (
 713                     strEQ(name, "SIG") ||
 714                     strEQ(name, "STDIN") ||
 715                     strEQ(name, "STDOUT") ||
 716                     strEQ(name, "STDERR")))
 717                     global = TRUE;
 718                 else if (*name == 'I' && strEQ(name, "INC"))
 719                     global = TRUE;
 720                 else if (*name == 'E' && strEQ(name, "ENV"))
 721                     global = TRUE;
 722                 else if (*name == 'A' && (
 723                   strEQ(name, "ARGV") ||
 724                   strEQ(name, "ARGVOUT")))
 725                     global = TRUE;
 726             }
 727             else if (*name == '_' && !name[1])
 728                 global = TRUE;
 729
 730             if (global)
 731                 stash = PL_defstash;
 732             else if (IN_PERL_COMPILETIME) {
 733                 stash = PL_curstash;
 734                 if (add && (PL_hints & HINT_STRICT_VARS) &&
 735                     sv_type != SVt_PVCV &&
 736                     sv_type != SVt_PVGV &&
 737                     sv_type != SVt_PVFM &&
 738                     sv_type != SVt_PVIO &&
 739                     !(len == 1 && sv_type == SVt_PV &&
 740                       (*name == 'a' || *name == 'b')) )
 741                 {
 742                     gvp = (GV**)hv_fetch(stash,name,len,0);
 743                     if (!gvp ||
 744                         *gvp == (GV*)&PL_sv_undef ||
 745                         SvTYPE(*gvp) != SVt_PVGV)
 746                     {
 747                         stash = 0;
 748                     }
 749                     else if ((sv_type == SVt_PV   && !GvIMPORTED_SV(*gvp)) ||
 750                              (sv_type == SVt_PVAV && !GvIMPORTED_AV(*gvp)) ||
 751                              (sv_type == SVt_PVHV && !GvIMPORTED_HV(*gvp)) )
 752                     {
 753                         Perl_warn(aTHX_ "Variable \"%c%s\" is not imported",
 754                             sv_type == SVt_PVAV ? '@' :
 755                             sv_type == SVt_PVHV ? '%' : '$',
 756                             name);
 757                         if (GvCVu(*gvp))
 758                             Perl_warn(aTHX_ "\t(Did you mean &%s instead?)\n", name);
 759                         stash = 0;
 760                     }
 761                 }
 762             }
 763             else
 764                 stash = CopSTASH(PL_curcop);
 765         }
 766         else
 767             stash = PL_defstash;
 768     }
 769
 770     /* By this point we should have a stash and a name */
 771
 772     if (!stash) {
 773         if (add) {
 774             register SV *err = Perl_mess(aTHX_
 775                  "Global symbol \"%s%s\" requires explicit package name",
 776                  (sv_type == SVt_PV ? "$"
 777                   : sv_type == SVt_PVAV ? "@"
 778                   : sv_type == SVt_PVHV ? "%"
 779                   : ""), name);
 780             if (USE_UTF8_IN_NAMES)
 781                 SvUTF8_on(err);
 782             qerror(err);
 783             stash = GvHV(gv_fetchpv("<none>::", GV_ADDMULTI, SVt_PVHV));
 784         }
 785         else
 786             return Nullgv;
 787     }
 788
 789     if (!SvREFCNT(stash))       /* symbol table under destruction */
 790         return Nullgv;
 791
 792     gvp = (GV**)hv_fetch(stash,name,len,add);
 793     if (!gvp || *gvp == (GV*)&PL_sv_undef)
 794         return Nullgv;
 795     gv = *gvp;
 796     if (SvTYPE(gv) == SVt_PVGV) {
 797         if (add) {
 798             GvMULTI_on(gv);
 799             gv_init_sv(gv, sv_type);
 800             if (*name=='!' && sv_type == SVt_PVHV && len==1)
 801                 require_errno(gv);
 802         }
 803         return gv;
 804     } else if (add & GV_NOINIT) {
 805         return gv;
 806     }
 807
 808     /* Adding a new symbol */
 809
 810     if (add & GV_ADDWARN && ckWARN_d(WARN_INTERNAL))
 811         Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "Had to create %s unexpectedly", nambeg);
 812     gv_init(gv, stash, name, len, add & GV_ADDMULTI);
 813     gv_init_sv(gv, sv_type);
 814
 815     if (isALPHA(name[0]) && ! (isLEXWARN_on ? ckWARN(WARN_ONCE)
 816                                             : (PL_dowarn & G_WARN_ON ) ) )
 817         GvMULTI_on(gv) ;
 818
 819     /* set up magic where warranted */
 820     switch (*name) {
 821     case 'A':
 822         if (strEQ(name, "ARGV")) {
 823             IoFLAGS(GvIOn(gv)) |= IOf_ARGV|IOf_START;
 824         }
 825         break;
 826     case 'E':
 827         if (strnEQ(name, "EXPORT", 6))
 828             GvMULTI_on(gv);
 829         break;
 830     case 'I':
 831         if (strEQ(name, "ISA")) {
 832             AV* av = GvAVn(gv);
 833             GvMULTI_on(gv);
 834             sv_magic((SV*)av, (SV*)gv, PERL_MAGIC_isa, Nullch, 0);
 835             /* NOTE: No support for tied ISA */
 836             if ((add & GV_ADDMULTI) && strEQ(nambeg,"AnyDBM_File::ISA")
 837                 && AvFILLp(av) == -1)
 838             {
 839                 char *pname;
 840                 av_push(av, newSVpvn(pname = "NDBM_File",9));
 841                 gv_stashpvn(pname, 9, TRUE);
 842                 av_push(av, newSVpvn(pname = "DB_File",7));
 843                 gv_stashpvn(pname, 7, TRUE);
 844                 av_push(av, newSVpvn(pname = "GDBM_File",9));
 845                 gv_stashpvn(pname, 9, TRUE);
 846                 av_push(av, newSVpvn(pname = "SDBM_File",9));
 847                 gv_stashpvn(pname, 9, TRUE);
 848                 av_push(av, newSVpvn(pname = "ODBM_File",9));
 849                 gv_stashpvn(pname, 9, TRUE);
 850             }
 851         }
 852         break;
 853     case 'O':
 854         if (strEQ(name, "OVERLOAD")) {
 855             HV* hv = GvHVn(gv);
 856             GvMULTI_on(gv);
 857             hv_magic(hv, Nullgv, PERL_MAGIC_overload);
 858         }
 859         break;
 860     case 'S':
 861         if (strEQ(name, "SIG")) {
 862             HV *hv;
 863             I32 i;
 864             if (!PL_psig_ptr) {
 865                 Newz(73, PL_psig_ptr,  SIG_SIZE, SV*);
 866                 Newz(73, PL_psig_name, SIG_SIZE, SV*);
 867                 Newz(73, PL_psig_pend, SIG_SIZE, int);
 868             }
 869             GvMULTI_on(gv);
 870             hv = GvHVn(gv);
 871             hv_magic(hv, Nullgv, PERL_MAGIC_sig);
 872             for (i = 1; i < SIG_SIZE; i++) {
 873                 SV ** init;
 874                 init = hv_fetch(hv, PL_sig_name[i], strlen(PL_sig_name[i]), 1);
 875                 if (init)
 876                     sv_setsv(*init, &PL_sv_undef);
 877                 PL_psig_ptr[i] = 0;
 878                 PL_psig_name[i] = 0;
 879                 PL_psig_pend[i] = 0;
 880             }
 881         }
 882         break;
 883     case 'V':
 884         if (strEQ(name, "VERSION"))
 885             GvMULTI_on(gv);
 886         break;
 887
 888     case '&':
 889     case '`':
 890     case '\'':
 891        if (
 892            len > 1 ||
 893            sv_type == SVt_PVAV ||
 894            sv_type == SVt_PVHV ||
 895            sv_type == SVt_PVCV ||
 896            sv_type == SVt_PVFM ||
 897            sv_type == SVt_PVIO
 898        ) { break; }
 899         PL_sawampersand = TRUE;
 900         goto ro_magicalize;
 901
 902     case ':':
 903         if (len > 1)
 904             break;
 905         sv_setpv(GvSV(gv),PL_chopset);
 906         goto magicalize;
 907
 908     case '?':
 909         if (len > 1)
 910             break;
 911 #ifdef COMPLEX_STATUS
 912         (void)SvUPGRADE(GvSV(gv), SVt_PVLV);
 913 #endif
 914         goto magicalize;
 915
 916     case '!':
 917         if (len > 1)
 918             break;
 919
 920         /* If %! has been used, automatically load Errno.pm.
 921            The require will itself set errno, so in order to
 922            preserve its value we have to set up the magic
 923            now (rather than going to magicalize)
 924         */
 925
 926         sv_magic(GvSV(gv), (SV*)gv, PERL_MAGIC_sv, name, len);
 927
 928         if (sv_type == SVt_PVHV)
 929             require_errno(gv);
 930
 931         break;
 932     case '-':
 933         if (len > 1)
 934             break;
 935         else {
 936             AV* av = GvAVn(gv);
 937             sv_magic((SV*)av, Nullsv, PERL_MAGIC_regdata, Nullch, 0);
 938             SvREADONLY_on(av);
 939         }
 940         goto magicalize;
 941     case '*':
 942         if (len == 1 && sv_type == SVt_PV && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
 943             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
 944                     "$* is no longer supported");
 945         break;
 946     case '#':
 947         if (len == 1 && sv_type == SVt_PV && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
 948             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
 949                     "Use of $# is deprecated");
 950         /* FALL THROUGH */
 951     case '[':
 952     case '^':
 953     case '~':
 954     case '=':
 955     case '%':
 956     case '.':
 957     case '(':
 958     case ')':
 959     case '<':
 960     case '>':
 961     case ',':
 962     case '\\':
 963     case '/':
 964     case '\001':        /* $^A */
 965     case '\003':        /* $^C */
 966     case '\004':        /* $^D */
 967     case '\006':        /* $^F */
 968     case '\010':        /* $^H */
 969     case '\011':        /* $^I, NOT \t in EBCDIC */
 970     case '\016':        /* $^N */
 971     case '\020':        /* $^P */
 972         if (len > 1)
 973             break;
 974         goto magicalize;
 975     case '|':
 976         if (len > 1)
 977             break;
 978         sv_setiv(GvSV(gv), (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0);
 979         goto magicalize;
 980     case '\005':        /* $^E && $^ENCODING */
 981         if (len > 1 && strNE(name, "\005NCODING"))
 982             break;
 983         goto magicalize;
 984
 985     case '\017':        /* $^O & $^OPEN */
 986         if (len > 1 && strNE(name, "\017PEN"))
 987             break;
 988         goto magicalize;
 989     case '\023':        /* $^S */
 990         if (len > 1)
 991             break;
 992         goto ro_magicalize;
 993     case '\024':        /* $^T, ${^TAINT} */
 994         if (len == 1)
 995             goto magicalize;
 996         else if (strEQ(name, "\024AINT"))
 997             goto ro_magicalize;
 998         else
 999             break;
1000     case '\025':
1001         if (len > 1 && strNE(name, "\025NICODE"))
1002             break;
1003         goto ro_magicalize;
1004
1005     case '\027':        /* $^W & $^WARNING_BITS */
1006         if (len > 1
1007             && strNE(name, "\027ARNING_BITS")
1008             )
1009             break;
1010         goto magicalize;
1011
1012     case '+':
1013         if (len > 1)
1014             break;
1015         else {
1016             AV* av = GvAVn(gv);
1017             sv_magic((SV*)av, (SV*)av, PERL_MAGIC_regdata, Nullch, 0);
1018             SvREADONLY_on(av);
1019         }
1020         /* FALL THROUGH */
1021     case '1':
1022     case '2':
1023     case '3':
1024     case '4':
1025     case '5':
1026     case '6':
1027     case '7':
1028     case '8':
1029     case '9':
1030         /* ensures variable is only digits */
1031         /* ${"1foo"} fails this test (and is thus writeable) */
1032         /* added by japhy, but borrowed from is_gv_magical */
1033
1034         if (len > 1) {
1035             const char *end = name + len;
1036             while (--end > name) {
1037                 if (!isDIGIT(*end)) return gv;
1038             }
1039         }
1040
1041       ro_magicalize:
1042         SvREADONLY_on(GvSV(gv));
1043       magicalize:
1044         sv_magic(GvSV(gv), (SV*)gv, PERL_MAGIC_sv, name, len);
1045         break;
1046
1047     case '\014':        /* $^L */
1048         if (len > 1)
1049             break;
1050         sv_setpv(GvSV(gv),"\f");
1051         PL_formfeed = GvSV(gv);
1052         break;
1053     case ';':
1054         if (len > 1)
1055             break;
1056         sv_setpv(GvSV(gv),"\034");
1057         break;
1058     case ']':
1059         if (len == 1) {
1060             SV *sv = GvSV(gv);
1061             if (!sv_derived_from(PL_patchlevel, "version"))
1062                 (void *)upg_version(PL_patchlevel);
1063             GvSV(gv) = vnumify(PL_patchlevel);
1064             SvREADONLY_on(GvSV(gv));
1065             SvREFCNT_dec(sv);
1066         }
1067         break;
1068     case '\026':        /* $^V */
1069         if (len == 1) {
1070             SV *sv = GvSV(gv);
1071             GvSV(gv) = new_version(PL_patchlevel);
1072             SvREADONLY_on(GvSV(gv));
1073             SvREFCNT_dec(sv);
1074         }
1075         break;
1076     }
1077     return gv;
1078 }
1079
1080 void
1081 Perl_gv_fullname4(pTHX_ SV *sv, GV *gv, const char *prefix, bool keepmain)
1082 {
1083     char *name;
1084     HV *hv = GvSTASH(gv);
1085     if (!hv) {
1086         SvOK_off(sv);
1087         return;
1088     }
1089     sv_setpv(sv, prefix ? prefix : "");
1090
1091     name = HvNAME(hv);
1092     if (!name)
1093         name = "__ANON__";
1094
1095     if (keepmain || strNE(name, "main")) {
1096         Perl_sv_catpvf(aTHX_ sv,"%s::", name);
1097     }
1098     sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv));
1099 }
1100
1101 void
1102 Perl_gv_fullname3(pTHX_ SV *sv, GV *gv, const char *prefix)
1103 {
1104     gv_fullname4(sv, gv, prefix, TRUE);
1105 }
1106
1107 void
1108 Perl_gv_efullname4(pTHX_ SV *sv, GV *gv, const char *prefix, bool keepmain)
1109 {
1110     GV *egv = GvEGV(gv);
1111     if (!egv)
1112         egv = gv;
1113     gv_fullname4(sv, egv, prefix, keepmain);
1114 }
1115
1116 void
1117 Perl_gv_efullname3(pTHX_ SV *sv, GV *gv, const char *prefix)
1118 {
1119     gv_efullname4(sv, gv, prefix, TRUE);
1120 }
1121
1122 /* XXX compatibility with versions <= 5.003. */
1123 void
1124 Perl_gv_fullname(pTHX_ SV *sv, GV *gv)
1125 {
1126     gv_fullname3(sv, gv, sv == (SV*)gv ? "*" : "");
1127 }
1128
1129 /* XXX compatibility with versions <= 5.003. */
1130 void
1131 Perl_gv_efullname(pTHX_ SV *sv, GV *gv)
1132 {
1133     gv_efullname3(sv, gv, sv == (SV*)gv ? "*" : "");
1134 }
1135
1136 IO *
1137 Perl_newIO(pTHX)
1138 {
1139     IO *io;
1140     GV *iogv;
1141
1142     io = (IO*)NEWSV(0,0);
1143     sv_upgrade((SV *)io,SVt_PVIO);
1144     SvREFCNT(io) = 1;
1145     SvOBJECT_on(io);
1146     /* Clear the stashcache because a new IO could overrule a
1147        package name */
1148     hv_clear(PL_stashcache);
1149     iogv = gv_fetchpv("FileHandle::", FALSE, SVt_PVHV);
1150     /* unless exists($main::{FileHandle}) and defined(%main::FileHandle::) */
1151     if (!(iogv && GvHV(iogv) && HvARRAY(GvHV(iogv))))
1152       iogv = gv_fetchpv("IO::Handle::", TRUE, SVt_PVHV);
1153     SvSTASH(io) = (HV*)SvREFCNT_inc(GvHV(iogv));
1154     return io;
1155 }
1156
1157 void
1158 Perl_gv_check(pTHX_ HV *stash)
1159 {
1160     register HE *entry;
1161     register I32 i;
1162     register GV *gv;
1163     HV *hv;
1164
1165     if (!HvARRAY(stash))
1166         return;
1167     for (i = 0; i <= (I32) HvMAX(stash); i++) {
1168         for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
1169             if (HeKEY(entry)[HeKLEN(entry)-1] == ':' &&
1170                 (gv = (GV*)HeVAL(entry)) && isGV(gv) && (hv = GvHV(gv)))
1171             {
1172                 if (hv != PL_defstash && hv != stash)
1173                      gv_check(hv);              /* nested package */
1174             }
1175             else if (isALPHA(*HeKEY(entry))) {
1176                 char *file;
1177                 gv = (GV*)HeVAL(entry);
1178                 if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv))
1179                     continue;
1180                 file = GvFILE(gv);
1181                 /* performance hack: if filename is absolute and it's a standard
1182                  * module, don't bother warning */
1183                 if (file
1184                     && PERL_FILE_IS_ABSOLUTE(file)
1185 #ifdef MACOS_TRADITIONAL
1186                     && (instr(file, ":lib:")
1187 #else
1188                     && (instr(file, "/lib/")
1189 #endif
1190                     || instr(file, ".pm")))
1191                 {
1192                     continue;
1193                 }
1194                 CopLINE_set(PL_curcop, GvLINE(gv));
1195 #ifdef USE_ITHREADS
1196                 CopFILE(PL_curcop) = file;      /* set for warning */
1197 #else
1198                 CopFILEGV(PL_curcop) = gv_fetchfile(file);
1199 #endif
1200                 Perl_warner(aTHX_ packWARN(WARN_ONCE),
1201                         "Name \"%s::%s\" used only once: possible typo",
1202                         HvNAME(stash), GvNAME(gv));
1203             }
1204         }
1205     }
1206 }
1207
1208 GV *
1209 Perl_newGVgen(pTHX_ char *pack)
1210 {
1211     return gv_fetchpv(Perl_form(aTHX_ "%s::_GEN_%ld", pack, (long)PL_gensym++),
1212                       TRUE, SVt_PVGV);
1213 }
1214
1215 /* hopefully this is only called on local symbol table entries */
1216
1217 GP*
1218 Perl_gp_ref(pTHX_ GP *gp)
1219 {
1220     if (!gp)
1221         return (GP*)NULL;
1222     gp->gp_refcnt++;
1223     if (gp->gp_cv) {
1224         if (gp->gp_cvgen) {
1225             /* multi-named GPs cannot be used for method cache */
1226             SvREFCNT_dec(gp->gp_cv);
1227             gp->gp_cv = Nullcv;
1228             gp->gp_cvgen = 0;
1229         }
1230         else {
1231             /* Adding a new name to a subroutine invalidates method cache */
1232             PL_sub_generation++;
1233         }
1234     }
1235     return gp;
1236 }
1237
1238 void
1239 Perl_gp_free(pTHX_ GV *gv)
1240 {
1241     GP* gp;
1242
1243     if (!gv || !(gp = GvGP(gv)))
1244         return;
1245     if (gp->gp_refcnt == 0) {
1246         if (ckWARN_d(WARN_INTERNAL))
1247             Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
1248                         "Attempt to free unreferenced glob pointers"
1249                         pTHX__FORMAT pTHX__VALUE);
1250         return;
1251     }
1252     if (gp->gp_cv) {
1253         /* Deleting the name of a subroutine invalidates method cache */
1254         PL_sub_generation++;
1255     }
1256     if (--gp->gp_refcnt > 0) {
1257         if (gp->gp_egv == gv)
1258             gp->gp_egv = 0;
1259         return;
1260     }
1261
1262     if (gp->gp_sv) SvREFCNT_dec(gp->gp_sv);
1263     if (gp->gp_av) SvREFCNT_dec(gp->gp_av);
1264     if (gp->gp_hv) {
1265          if (PL_stashcache && HvNAME(gp->gp_hv))
1266               hv_delete(PL_stashcache,
1267                         HvNAME(gp->gp_hv), strlen(HvNAME(gp->gp_hv)),
1268                         G_DISCARD);
1269          SvREFCNT_dec(gp->gp_hv);
1270     }
1271     if (gp->gp_io)   SvREFCNT_dec(gp->gp_io);
1272     if (gp->gp_cv)   SvREFCNT_dec(gp->gp_cv);
1273     if (gp->gp_form) SvREFCNT_dec(gp->gp_form);
1274
1275     Safefree(gp);
1276     GvGP(gv) = 0;
1277 }
1278
1279 int
1280 Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg)
1281 {
1282     AMT *amtp = (AMT*)mg->mg_ptr;
1283     if (amtp && AMT_AMAGIC(amtp)) {
1284         int i;
1285         for (i = 1; i < NofAMmeth; i++) {
1286             CV *cv = amtp->table[i];
1287             if (cv != Nullcv) {
1288                 SvREFCNT_dec((SV *) cv);
1289                 amtp->table[i] = Nullcv;
1290             }
1291         }
1292     }
1293  return 0;
1294 }
1295
1296 /* Updates and caches the CV's */
1297
1298 bool
1299 Perl_Gv_AMupdate(pTHX_ HV *stash)
1300 {
1301   GV* gv;
1302   CV* cv;
1303   MAGIC* mg=mg_find((SV*)stash, PERL_MAGIC_overload_table);
1304   AMT *amtp = (mg) ? (AMT*)mg->mg_ptr: (AMT *) NULL;
1305   AMT amt;
1306
1307   if (mg && amtp->was_ok_am == PL_amagic_generation
1308       && amtp->was_ok_sub == PL_sub_generation)
1309       return (bool)AMT_OVERLOADED(amtp);
1310   sv_unmagic((SV*)stash, PERL_MAGIC_overload_table);
1311
1312   DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME(stash)) );
1313
1314   Zero(&amt,1,AMT);
1315   amt.was_ok_am = PL_amagic_generation;
1316   amt.was_ok_sub = PL_sub_generation;
1317   amt.fallback = AMGfallNO;
1318   amt.flags = 0;
1319
1320   {
1321     int filled = 0, have_ovl = 0;
1322     int i, lim = 1;
1323     SV* sv = NULL;
1324
1325     /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
1326
1327     /* Try to find via inheritance. */
1328     gv = gv_fetchmeth(stash, PL_AMG_names[0], 2, -1);
1329     if (gv)
1330         sv = GvSV(gv);
1331
1332     if (!gv)
1333         lim = DESTROY_amg;              /* Skip overloading entries. */
1334     else if (SvTRUE(sv))
1335         amt.fallback=AMGfallYES;
1336     else if (SvOK(sv))
1337         amt.fallback=AMGfallNEVER;
1338
1339     for (i = 1; i < lim; i++)
1340         amt.table[i] = Nullcv;
1341     for (; i < NofAMmeth; i++) {
1342         char *cooky = (char*)PL_AMG_names[i];
1343         /* Human-readable form, for debugging: */
1344         char *cp = (i >= DESTROY_amg ? cooky : AMG_id2name(i));
1345         STRLEN l = strlen(cooky);
1346
1347         DEBUG_o( Perl_deb(aTHX_ "Checking overloading of `%s' in package `%.256s'\n",
1348                      cp, HvNAME(stash)) );
1349         /* don't fill the cache while looking up!
1350            Creation of inheritance stubs in intermediate packages may
1351            conflict with the logic of runtime method substitution.
1352            Indeed, for inheritance A -> B -> C, if C overloads "+0",
1353            then we could have created stubs for "(+0" in A and C too.
1354            But if B overloads "bool", we may want to use it for
1355            numifying instead of C's "+0". */
1356         if (i >= DESTROY_amg)
1357             gv = Perl_gv_fetchmeth_autoload(aTHX_ stash, cooky, l, 0);
1358         else                            /* Autoload taken care of below */
1359             gv = Perl_gv_fetchmeth(aTHX_ stash, cooky, l, -1);
1360         cv = 0;
1361         if (gv && (cv = GvCV(gv))) {
1362             if (GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")
1363                 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "overload")) {
1364                 /* This is a hack to support autoloading..., while
1365                    knowing *which* methods were declared as overloaded. */
1366                 /* GvSV contains the name of the method. */
1367                 GV *ngv = Nullgv;
1368
1369                 DEBUG_o( Perl_deb(aTHX_ "Resolving method `%"SVf256\
1370                         "' for overloaded `%s' in package `%.256s'\n",
1371                              GvSV(gv), cp, HvNAME(stash)) );
1372                 if (!SvPOK(GvSV(gv))
1373                     || !(ngv = gv_fetchmethod_autoload(stash, SvPVX(GvSV(gv)),
1374                                                        FALSE)))
1375                 {
1376                     /* Can be an import stub (created by `can'). */
1377                     SV *gvsv = GvSV(gv);
1378                     const char *name = SvPOK(gvsv) ?  SvPVX(gvsv) : "???";
1379                     Perl_croak(aTHX_ "%s method `%.256s' overloading `%s' "\
1380                                 "in package `%.256s'",
1381                                (GvCVGEN(gv) ? "Stub found while resolving"
1382                                 : "Can't resolve"),
1383                                name, cp, HvNAME(stash));
1384                 }
1385                 cv = GvCV(gv = ngv);
1386             }
1387             DEBUG_o( Perl_deb(aTHX_ "Overloading `%s' in package `%.256s' via `%.256s::%.256s' \n",
1388                          cp, HvNAME(stash), HvNAME(GvSTASH(CvGV(cv))),
1389                          GvNAME(CvGV(cv))) );
1390             filled = 1;
1391             if (i < DESTROY_amg)
1392                 have_ovl = 1;
1393         } else if (gv) {                /* Autoloaded... */
1394             cv = (CV*)gv;
1395             filled = 1;
1396         }
1397         amt.table[i]=(CV*)SvREFCNT_inc(cv);
1398     }
1399     if (filled) {
1400       AMT_AMAGIC_on(&amt);
1401       if (have_ovl)
1402           AMT_OVERLOADED_on(&amt);
1403       sv_magic((SV*)stash, 0, PERL_MAGIC_overload_table,
1404                                                 (char*)&amt, sizeof(AMT));
1405       return have_ovl;
1406     }
1407   }
1408   /* Here we have no table: */
1409   /* no_table: */
1410   AMT_AMAGIC_off(&amt);
1411   sv_magic((SV*)stash, 0, PERL_MAGIC_overload_table,
1412                                                 (char*)&amt, sizeof(AMTS));
1413   return FALSE;
1414 }
1415
1416
1417 CV*
1418 Perl_gv_handler(pTHX_ HV *stash, I32 id)
1419 {
1420     MAGIC *mg;
1421     AMT *amtp;
1422     CV *ret;
1423
1424     if (!stash || !HvNAME(stash))
1425         return Nullcv;
1426     mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
1427     if (!mg) {
1428       do_update:
1429         Gv_AMupdate(stash);
1430         mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
1431     }
1432     amtp = (AMT*)mg->mg_ptr;
1433     if ( amtp->was_ok_am != PL_amagic_generation
1434          || amtp->was_ok_sub != PL_sub_generation )
1435         goto do_update;
1436     if (AMT_AMAGIC(amtp)) {
1437         ret = amtp->table[id];
1438         if (ret && isGV(ret)) {         /* Autoloading stab */
1439             /* Passing it through may have resulted in a warning
1440                "Inherited AUTOLOAD for a non-method deprecated", since
1441                our caller is going through a function call, not a method call.
1442                So return the CV for AUTOLOAD, setting $AUTOLOAD. */
1443             GV *gv = gv_fetchmethod(stash, (char*)PL_AMG_names[id]);
1444
1445             if (gv && GvCV(gv))
1446                 return GvCV(gv);
1447         }
1448         return ret;
1449     }
1450
1451     return Nullcv;
1452 }
1453
1454
1455 SV*
1456 Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
1457 {
1458   MAGIC *mg;
1459   CV *cv=NULL;
1460   CV **cvp=NULL, **ocvp=NULL;
1461   AMT *amtp=NULL, *oamtp=NULL;
1462   int off=0, off1, lr=0, assign=AMGf_assign & flags, notfound=0;
1463   int postpr = 0, force_cpy = 0, assignshift = assign ? 1 : 0;
1464 #ifdef DEBUGGING
1465   int fl=0;
1466 #endif
1467   HV* stash=NULL;
1468   if (!(AMGf_noleft & flags) && SvAMAGIC(left)
1469       && (stash = SvSTASH(SvRV(left)))
1470       && (mg = mg_find((SV*)stash, PERL_MAGIC_overload_table))
1471       && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
1472                         ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
1473                         : (CV **) NULL))
1474       && ((cv = cvp[off=method+assignshift])
1475           || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
1476                                                           * usual method */
1477                   (
1478 #ifdef DEBUGGING
1479                    fl = 1,
1480 #endif
1481                    cv = cvp[off=method])))) {
1482     lr = -1;                    /* Call method for left argument */
1483   } else {
1484     if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) {
1485       int logic;
1486
1487       /* look for substituted methods */
1488       /* In all the covered cases we should be called with assign==0. */
1489          switch (method) {
1490          case inc_amg:
1491            force_cpy = 1;
1492            if ((cv = cvp[off=add_ass_amg])
1493                || ((cv = cvp[off = add_amg]) && (force_cpy = 0, postpr = 1))) {
1494              right = &PL_sv_yes; lr = -1; assign = 1;
1495            }
1496            break;
1497          case dec_amg:
1498            force_cpy = 1;
1499            if ((cv = cvp[off = subtr_ass_amg])
1500                || ((cv = cvp[off = subtr_amg]) && (force_cpy = 0, postpr=1))) {
1501              right = &PL_sv_yes; lr = -1; assign = 1;
1502            }
1503            break;
1504          case bool__amg:
1505            (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg]));
1506            break;
1507          case numer_amg:
1508            (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg]));
1509            break;
1510          case string_amg:
1511            (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg]));
1512            break;
1513  case not_amg:
1514    (void)((cv = cvp[off=bool__amg])
1515           || (cv = cvp[off=numer_amg])
1516           || (cv = cvp[off=string_amg]));
1517    postpr = 1;
1518    break;
1519          case copy_amg:
1520            {
1521              /*
1522                   * SV* ref causes confusion with the interpreter variable of
1523                   * the same name
1524                   */
1525              SV* tmpRef=SvRV(left);
1526              if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) {
1527                 /*
1528                  * Just to be extra cautious.  Maybe in some
1529                  * additional cases sv_setsv is safe, too.
1530                  */
1531                 SV* newref = newSVsv(tmpRef);
1532                 SvOBJECT_on(newref);
1533                 SvSTASH(newref) = (HV*)SvREFCNT_inc(SvSTASH(tmpRef));
1534                 return newref;
1535              }
1536            }
1537            break;
1538          case abs_amg:
1539            if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg])
1540                && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) {
1541              SV* nullsv=sv_2mortal(newSViv(0));
1542              if (off1==lt_amg) {
1543                SV* lessp = amagic_call(left,nullsv,
1544                                        lt_amg,AMGf_noright);
1545                logic = SvTRUE(lessp);
1546              } else {
1547                SV* lessp = amagic_call(left,nullsv,
1548                                        ncmp_amg,AMGf_noright);
1549                logic = (SvNV(lessp) < 0);
1550              }
1551              if (logic) {
1552                if (off==subtr_amg) {
1553                  right = left;
1554                  left = nullsv;
1555                  lr = 1;
1556                }
1557              } else {
1558                return left;
1559              }
1560            }
1561            break;
1562          case neg_amg:
1563            if ((cv = cvp[off=subtr_amg])) {
1564              right = left;
1565              left = sv_2mortal(newSViv(0));
1566              lr = 1;
1567            }
1568            break;
1569          case int_amg:
1570          case iter_amg:                 /* XXXX Eventually should do to_gv. */
1571              /* FAIL safe */
1572              return NULL;       /* Delegate operation to standard mechanisms. */
1573              break;
1574          case to_sv_amg:
1575          case to_av_amg:
1576          case to_hv_amg:
1577          case to_gv_amg:
1578          case to_cv_amg:
1579              /* FAIL safe */
1580              return left;       /* Delegate operation to standard mechanisms. */
1581              break;
1582          default:
1583            goto not_found;
1584          }
1585          if (!cv) goto not_found;
1586     } else if (!(AMGf_noright & flags) && SvAMAGIC(right)
1587                && (stash = SvSTASH(SvRV(right)))
1588                && (mg = mg_find((SV*)stash, PERL_MAGIC_overload_table))
1589                && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
1590                           ? (amtp = (AMT*)mg->mg_ptr)->table
1591                           : (CV **) NULL))
1592                && (cv = cvp[off=method])) { /* Method for right
1593                                              * argument found */
1594       lr=1;
1595     } else if (((ocvp && oamtp->fallback > AMGfallNEVER
1596                  && (cvp=ocvp) && (lr = -1))
1597                 || (cvp && amtp->fallback > AMGfallNEVER && (lr=1)))
1598                && !(flags & AMGf_unary)) {
1599                                 /* We look for substitution for
1600                                  * comparison operations and
1601                                  * concatenation */
1602       if (method==concat_amg || method==concat_ass_amg
1603           || method==repeat_amg || method==repeat_ass_amg) {
1604         return NULL;            /* Delegate operation to string conversion */
1605       }
1606       off = -1;
1607       switch (method) {
1608          case lt_amg:
1609          case le_amg:
1610          case gt_amg:
1611          case ge_amg:
1612          case eq_amg:
1613          case ne_amg:
1614            postpr = 1; off=ncmp_amg; break;
1615          case slt_amg:
1616          case sle_amg:
1617          case sgt_amg:
1618          case sge_amg:
1619          case seq_amg:
1620          case sne_amg:
1621            postpr = 1; off=scmp_amg; break;
1622          }
1623       if (off != -1) cv = cvp[off];
1624       if (!cv) {
1625         goto not_found;
1626       }
1627     } else {
1628     not_found:                  /* No method found, either report or croak */
1629       switch (method) {
1630          case to_sv_amg:
1631          case to_av_amg:
1632          case to_hv_amg:
1633          case to_gv_amg:
1634          case to_cv_amg:
1635              /* FAIL safe */
1636              return left;       /* Delegate operation to standard mechanisms. */
1637              break;
1638       }
1639       if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */
1640         notfound = 1; lr = -1;
1641       } else if (cvp && (cv=cvp[nomethod_amg])) {
1642         notfound = 1; lr = 1;
1643       } else {
1644         SV *msg;
1645         if (off==-1) off=method;
1646         msg = sv_2mortal(Perl_newSVpvf(aTHX_
1647                       "Operation `%s': no method found,%sargument %s%s%s%s",
1648                       AMG_id2name(method + assignshift),
1649                       (flags & AMGf_unary ? " " : "\n\tleft "),
1650                       SvAMAGIC(left)?
1651                         "in overloaded package ":
1652                         "has no overloaded magic",
1653                       SvAMAGIC(left)?
1654                         HvNAME(SvSTASH(SvRV(left))):
1655                         "",
1656                       SvAMAGIC(right)?
1657                         ",\n\tright argument in overloaded package ":
1658                         (flags & AMGf_unary
1659                          ? ""
1660                          : ",\n\tright argument has no overloaded magic"),
1661                       SvAMAGIC(right)?
1662                         HvNAME(SvSTASH(SvRV(right))):
1663                         ""));
1664         if (amtp && amtp->fallback >= AMGfallYES) {
1665           DEBUG_o( Perl_deb(aTHX_ "%s", SvPVX(msg)) );
1666         } else {
1667           Perl_croak(aTHX_ "%"SVf, msg);
1668         }
1669         return NULL;
1670       }
1671       force_cpy = force_cpy || assign;
1672     }
1673   }
1674 #ifdef DEBUGGING
1675   if (!notfound) {
1676     DEBUG_o(Perl_deb(aTHX_
1677                      "Overloaded operator `%s'%s%s%s:\n\tmethod%s found%s in package %s%s\n",
1678                      AMG_id2name(off),
1679                      method+assignshift==off? "" :
1680                      " (initially `",
1681                      method+assignshift==off? "" :
1682                      AMG_id2name(method+assignshift),
1683                      method+assignshift==off? "" : "')",
1684                      flags & AMGf_unary? "" :
1685                      lr==1 ? " for right argument": " for left argument",
1686                      flags & AMGf_unary? " for argument" : "",
1687                      stash ? HvNAME(stash) : "null",
1688                      fl? ",\n\tassignment variant used": "") );
1689   }
1690 #endif
1691     /* Since we use shallow copy during assignment, we need
1692      * to dublicate the contents, probably calling user-supplied
1693      * version of copy operator
1694      */
1695     /* We need to copy in following cases:
1696      * a) Assignment form was called.
1697      *          assignshift==1,  assign==T, method + 1 == off
1698      * b) Increment or decrement, called directly.
1699      *          assignshift==0,  assign==0, method + 0 == off
1700      * c) Increment or decrement, translated to assignment add/subtr.
1701      *          assignshift==0,  assign==T,
1702      *          force_cpy == T
1703      * d) Increment or decrement, translated to nomethod.
1704      *          assignshift==0,  assign==0,
1705      *          force_cpy == T
1706      * e) Assignment form translated to nomethod.
1707      *          assignshift==1,  assign==T, method + 1 != off
1708      *          force_cpy == T
1709      */
1710     /*  off is method, method+assignshift, or a result of opcode substitution.
1711      *  In the latter case assignshift==0, so only notfound case is important.
1712      */
1713   if (( (method + assignshift == off)
1714         && (assign || (method == inc_amg) || (method == dec_amg)))
1715       || force_cpy)
1716     RvDEEPCP(left);
1717   {
1718     dSP;
1719     BINOP myop;
1720     SV* res;
1721     bool oldcatch = CATCH_GET;
1722
1723     CATCH_SET(TRUE);
1724     Zero(&myop, 1, BINOP);
1725     myop.op_last = (OP *) &myop;
1726     myop.op_next = Nullop;
1727     myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
1728
1729     PUSHSTACKi(PERLSI_OVERLOAD);
1730     ENTER;
1731     SAVEOP();
1732     PL_op = (OP *) &myop;
1733     if (PERLDB_SUB && PL_curstash != PL_debstash)
1734         PL_op->op_private |= OPpENTERSUB_DB;
1735     PUTBACK;
1736     pp_pushmark();
1737
1738     EXTEND(SP, notfound + 5);
1739     PUSHs(lr>0? right: left);
1740     PUSHs(lr>0? left: right);
1741     PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no ));
1742     if (notfound) {
1743       PUSHs( sv_2mortal(newSVpv(AMG_id2name(method + assignshift),0)));
1744     }
1745     PUSHs((SV*)cv);
1746     PUTBACK;
1747
1748     if ((PL_op = Perl_pp_entersub(aTHX)))
1749       CALLRUNOPS(aTHX);
1750     LEAVE;
1751     SPAGAIN;
1752
1753     res=POPs;
1754     PUTBACK;
1755     POPSTACK;
1756     CATCH_SET(oldcatch);
1757
1758     if (postpr) {
1759       int ans=0;
1760       switch (method) {
1761       case le_amg:
1762       case sle_amg:
1763         ans=SvIV(res)<=0; break;
1764       case lt_amg:
1765       case slt_amg:
1766         ans=SvIV(res)<0; break;
1767       case ge_amg:
1768       case sge_amg:
1769         ans=SvIV(res)>=0; break;
1770       case gt_amg:
1771       case sgt_amg:
1772         ans=SvIV(res)>0; break;
1773       case eq_amg:
1774       case seq_amg:
1775         ans=SvIV(res)==0; break;
1776       case ne_amg:
1777       case sne_amg:
1778         ans=SvIV(res)!=0; break;
1779       case inc_amg:
1780       case dec_amg:
1781         SvSetSV(left,res); return left;
1782       case not_amg:
1783         ans=!SvTRUE(res); break;
1784       }
1785       return boolSV(ans);
1786     } else if (method==copy_amg) {
1787       if (!SvROK(res)) {
1788         Perl_croak(aTHX_ "Copy method did not return a reference");
1789       }
1790       return SvREFCNT_inc(SvRV(res));
1791     } else {
1792       return res;
1793     }
1794   }
1795 }
1796
1797 /*
1798 =for apidoc is_gv_magical
1799
1800 Returns C<TRUE> if given the name of a magical GV.
1801
1802 Currently only useful internally when determining if a GV should be
1803 created even in rvalue contexts.
1804
1805 C<flags> is not used at present but available for future extension to
1806 allow selecting particular classes of magical variable.
1807
1808 =cut
1809 */
1810 bool
1811 Perl_is_gv_magical(pTHX_ char *name, STRLEN len, U32 flags)
1812 {
1813     if (!len)
1814         return FALSE;
1815
1816     switch (*name) {
1817     case 'I':
1818         if (len == 3 && strEQ(name, "ISA"))
1819             goto yes;
1820         break;
1821     case 'O':
1822         if (len == 8 && strEQ(name, "OVERLOAD"))
1823             goto yes;
1824         break;
1825     case 'S':
1826         if (len == 3 && strEQ(name, "SIG"))
1827             goto yes;
1828         break;
1829     case '\017':   /* $^O & $^OPEN */
1830         if (len == 1
1831             || (len == 4 && strEQ(name, "\017PEN")))
1832         {
1833             goto yes;
1834         }
1835         break;
1836     case '\025':
1837         if (len > 1 && strEQ(name, "\025NICODE"))
1838             goto yes;
1839     case '\027':   /* $^W & $^WARNING_BITS */
1840         if (len == 1
1841             || (len == 12 && strEQ(name, "\027ARNING_BITS"))
1842             )
1843         {
1844             goto yes;
1845         }
1846         break;
1847
1848     case '&':
1849     case '`':
1850     case '\'':
1851     case ':':
1852     case '?':
1853     case '!':
1854     case '-':
1855     case '#':
1856     case '[':
1857     case '^':
1858     case '~':
1859     case '=':
1860     case '%':
1861     case '.':
1862     case '(':
1863     case ')':
1864     case '<':
1865     case '>':
1866     case ',':
1867     case '\\':
1868     case '/':
1869     case '|':
1870     case '+':
1871     case ';':
1872     case ']':
1873     case '\001':   /* $^A */
1874     case '\003':   /* $^C */
1875     case '\004':   /* $^D */
1876     case '\005':   /* $^E */
1877     case '\006':   /* $^F */
1878     case '\010':   /* $^H */
1879     case '\011':   /* $^I, NOT \t in EBCDIC */
1880     case '\014':   /* $^L */
1881     case '\016':   /* $^N */
1882     case '\020':   /* $^P */
1883     case '\023':   /* $^S */
1884     case '\026':   /* $^V */
1885         if (len == 1)
1886             goto yes;
1887         break;
1888     case '\024':   /* $^T, ${^TAINT} */
1889         if (len == 1 || strEQ(name, "\024AINT"))
1890             goto yes;
1891         break;
1892     case '1':
1893     case '2':
1894     case '3':
1895     case '4':
1896     case '5':
1897     case '6':
1898     case '7':
1899     case '8':
1900     case '9':
1901         if (len > 1) {
1902             char *end = name + len;
1903             while (--end > name) {
1904                 if (!isDIGIT(*end))
1905                     return FALSE;
1906             }
1907         }
1908     yes:
1909         return TRUE;
1910     default:
1911         break;
1912     }
1913     return FALSE;
1914 }