gv.c

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