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, 'L');
  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, '*', 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, 'I', 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, 'A');
 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, 'S');
 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, 0, 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, 'D', 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, 'D', 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, 0, 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,'c');
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, 'c');
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, 'c', (char*)&amt, sizeof(AMT));
1309       return have_ovl;
1310     }
1311   }
1312   /* Here we have no table: */
1313   /* no_table: */
1314   AMT_AMAGIC_off(&amt);
1315   sv_magic((SV*)stash, 0, 'c', (char*)&amt, sizeof(AMTS));
1316   return FALSE;
1317 }
1318
1319
1320 CV*
1321 Perl_gv_handler(pTHX_ HV *stash, I32 id)
1322 {
1323     MAGIC *mg;
1324     AMT *amtp;
1325
1326     if (!stash)
1327         return Nullcv;
1328     mg = mg_find((SV*)stash,'c');
1329     if (!mg) {
1330       do_update:
1331         Gv_AMupdate(stash);
1332         mg = mg_find((SV*)stash,'c');
1333     }
1334     amtp = (AMT*)mg->mg_ptr;
1335     if ( amtp->was_ok_am != PL_amagic_generation
1336          || amtp->was_ok_sub != PL_sub_generation )
1337         goto do_update;
1338     if (AMT_AMAGIC(amtp))
1339         return amtp->table[id];
1340     return Nullcv;
1341 }
1342
1343
1344 SV*
1345 Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
1346 {
1347   MAGIC *mg;
1348   CV *cv;
1349   CV **cvp=NULL, **ocvp=NULL;
1350   AMT *amtp, *oamtp;
1351   int fl=0, off, off1, lr=0, assign=AMGf_assign & flags, notfound=0;
1352   int postpr = 0, force_cpy = 0, assignshift = assign ? 1 : 0;
1353   HV* stash;
1354   if (!(AMGf_noleft & flags) && SvAMAGIC(left)
1355       && (mg = mg_find((SV*)(stash=SvSTASH(SvRV(left))),'c'))
1356       && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
1357                         ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
1358                         : (CV **) NULL))
1359       && ((cv = cvp[off=method+assignshift])
1360           || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
1361                                                           * usual method */
1362                   (fl = 1, cv = cvp[off=method])))) {
1363     lr = -1;                    /* Call method for left argument */
1364   } else {
1365     if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) {
1366       int logic;
1367
1368       /* look for substituted methods */
1369       /* In all the covered cases we should be called with assign==0. */
1370          switch (method) {
1371          case inc_amg:
1372            force_cpy = 1;
1373            if ((cv = cvp[off=add_ass_amg])
1374                || ((cv = cvp[off = add_amg]) && (force_cpy = 0, postpr = 1))) {
1375              right = &PL_sv_yes; lr = -1; assign = 1;
1376            }
1377            break;
1378          case dec_amg:
1379            force_cpy = 1;
1380            if ((cv = cvp[off = subtr_ass_amg])
1381                || ((cv = cvp[off = subtr_amg]) && (force_cpy = 0, postpr=1))) {
1382              right = &PL_sv_yes; lr = -1; assign = 1;
1383            }
1384            break;
1385          case bool__amg:
1386            (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg]));
1387            break;
1388          case numer_amg:
1389            (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg]));
1390            break;
1391          case string_amg:
1392            (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg]));
1393            break;
1394  case not_amg:
1395    (void)((cv = cvp[off=bool__amg])
1396           || (cv = cvp[off=numer_amg])
1397           || (cv = cvp[off=string_amg]));
1398    postpr = 1;
1399    break;
1400          case copy_amg:
1401            {
1402              /*
1403                   * SV* ref causes confusion with the interpreter variable of
1404                   * the same name
1405                   */
1406              SV* tmpRef=SvRV(left);
1407              if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) {
1408                 /*
1409                  * Just to be extra cautious.  Maybe in some
1410                  * additional cases sv_setsv is safe, too.
1411                  */
1412                 SV* newref = newSVsv(tmpRef);
1413                 SvOBJECT_on(newref);
1414                 SvSTASH(newref) = (HV*)SvREFCNT_inc(SvSTASH(tmpRef));
1415                 return newref;
1416              }
1417            }
1418            break;
1419          case abs_amg:
1420            if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg])
1421                && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) {
1422              SV* nullsv=sv_2mortal(newSViv(0));
1423              if (off1==lt_amg) {
1424                SV* lessp = amagic_call(left,nullsv,
1425                                        lt_amg,AMGf_noright);
1426                logic = SvTRUE(lessp);
1427              } else {
1428                SV* lessp = amagic_call(left,nullsv,
1429                                        ncmp_amg,AMGf_noright);
1430                logic = (SvNV(lessp) < 0);
1431              }
1432              if (logic) {
1433                if (off==subtr_amg) {
1434                  right = left;
1435                  left = nullsv;
1436                  lr = 1;
1437                }
1438              } else {
1439                return left;
1440              }
1441            }
1442            break;
1443          case neg_amg:
1444            if ((cv = cvp[off=subtr_amg])) {
1445              right = left;
1446              left = sv_2mortal(newSViv(0));
1447              lr = 1;
1448            }
1449            break;
1450          case int_amg:
1451          case iter_amg:                 /* XXXX Eventually should do to_gv. */
1452              /* FAIL safe */
1453              return NULL;       /* Delegate operation to standard mechanisms. */
1454              break;
1455          case to_sv_amg:
1456          case to_av_amg:
1457          case to_hv_amg:
1458          case to_gv_amg:
1459          case to_cv_amg:
1460              /* FAIL safe */
1461              return left;       /* Delegate operation to standard mechanisms. */
1462              break;
1463          default:
1464            goto not_found;
1465          }
1466          if (!cv) goto not_found;
1467     } else if (!(AMGf_noright & flags) && SvAMAGIC(right)
1468                && (mg = mg_find((SV*)(stash=SvSTASH(SvRV(right))),'c'))
1469                && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
1470                           ? (amtp = (AMT*)mg->mg_ptr)->table
1471                           : (CV **) NULL))
1472                && (cv = cvp[off=method])) { /* Method for right
1473                                              * argument found */
1474       lr=1;
1475     } else if (((ocvp && oamtp->fallback > AMGfallNEVER
1476                  && (cvp=ocvp) && (lr = -1))
1477                 || (cvp && amtp->fallback > AMGfallNEVER && (lr=1)))
1478                && !(flags & AMGf_unary)) {
1479                                 /* We look for substitution for
1480                                  * comparison operations and
1481                                  * concatenation */
1482       if (method==concat_amg || method==concat_ass_amg
1483           || method==repeat_amg || method==repeat_ass_amg) {
1484         return NULL;            /* Delegate operation to string conversion */
1485       }
1486       off = -1;
1487       switch (method) {
1488          case lt_amg:
1489          case le_amg:
1490          case gt_amg:
1491          case ge_amg:
1492          case eq_amg:
1493          case ne_amg:
1494            postpr = 1; off=ncmp_amg; break;
1495          case slt_amg:
1496          case sle_amg:
1497          case sgt_amg:
1498          case sge_amg:
1499          case seq_amg:
1500          case sne_amg:
1501            postpr = 1; off=scmp_amg; break;
1502          }
1503       if (off != -1) cv = cvp[off];
1504       if (!cv) {
1505         goto not_found;
1506       }
1507     } else {
1508     not_found:                  /* No method found, either report or croak */
1509       switch (method) {
1510          case to_sv_amg:
1511          case to_av_amg:
1512          case to_hv_amg:
1513          case to_gv_amg:
1514          case to_cv_amg:
1515              /* FAIL safe */
1516              return left;       /* Delegate operation to standard mechanisms. */
1517              break;
1518       }
1519       if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */
1520         notfound = 1; lr = -1;
1521       } else if (cvp && (cv=cvp[nomethod_amg])) {
1522         notfound = 1; lr = 1;
1523       } else {
1524         SV *msg;
1525         if (off==-1) off=method;
1526         msg = sv_2mortal(Perl_newSVpvf(aTHX_
1527                       "Operation `%s': no method found,%sargument %s%s%s%s",
1528                       AMG_id2name(method + assignshift),
1529                       (flags & AMGf_unary ? " " : "\n\tleft "),
1530                       SvAMAGIC(left)?
1531                         "in overloaded package ":
1532                         "has no overloaded magic",
1533                       SvAMAGIC(left)?
1534                         HvNAME(SvSTASH(SvRV(left))):
1535                         "",
1536                       SvAMAGIC(right)?
1537                         ",\n\tright argument in overloaded package ":
1538                         (flags & AMGf_unary
1539                          ? ""
1540                          : ",\n\tright argument has no overloaded magic"),
1541                       SvAMAGIC(right)?
1542                         HvNAME(SvSTASH(SvRV(right))):
1543                         ""));
1544         if (amtp && amtp->fallback >= AMGfallYES) {
1545           DEBUG_o( Perl_deb(aTHX_ "%s", SvPVX(msg)) );
1546         } else {
1547           Perl_croak(aTHX_ "%"SVf, msg);
1548         }
1549         return NULL;
1550       }
1551       force_cpy = force_cpy || assign;
1552     }
1553   }
1554   if (!notfound) {
1555     DEBUG_o( Perl_deb(aTHX_
1556   "Overloaded operator `%s'%s%s%s:\n\tmethod%s found%s in package %s%s\n",
1557                  AMG_id2name(off),
1558                  method+assignshift==off? "" :
1559                              " (initially `",
1560                  method+assignshift==off? "" :
1561                              AMG_id2name(method+assignshift),
1562                  method+assignshift==off? "" : "')",
1563                  flags & AMGf_unary? "" :
1564                    lr==1 ? " for right argument": " for left argument",
1565                  flags & AMGf_unary? " for argument" : "",
1566                  HvNAME(stash),
1567                  fl? ",\n\tassignment variant used": "") );
1568   }
1569     /* Since we use shallow copy during assignment, we need
1570      * to dublicate the contents, probably calling user-supplied
1571      * version of copy operator
1572      */
1573     /* We need to copy in following cases:
1574      * a) Assignment form was called.
1575      *          assignshift==1,  assign==T, method + 1 == off
1576      * b) Increment or decrement, called directly.
1577      *          assignshift==0,  assign==0, method + 0 == off
1578      * c) Increment or decrement, translated to assignment add/subtr.
1579      *          assignshift==0,  assign==T,
1580      *          force_cpy == T
1581      * d) Increment or decrement, translated to nomethod.
1582      *          assignshift==0,  assign==0,
1583      *          force_cpy == T
1584      * e) Assignment form translated to nomethod.
1585      *          assignshift==1,  assign==T, method + 1 != off
1586      *          force_cpy == T
1587      */
1588     /*  off is method, method+assignshift, or a result of opcode substitution.
1589      *  In the latter case assignshift==0, so only notfound case is important.
1590      */
1591   if (( (method + assignshift == off)
1592         && (assign || (method == inc_amg) || (method == dec_amg)))
1593       || force_cpy)
1594     RvDEEPCP(left);
1595   {
1596     dSP;
1597     BINOP myop;
1598     SV* res;
1599     bool oldcatch = CATCH_GET;
1600
1601     CATCH_SET(TRUE);
1602     Zero(&myop, 1, BINOP);
1603     myop.op_last = (OP *) &myop;
1604     myop.op_next = Nullop;
1605     myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
1606
1607     PUSHSTACKi(PERLSI_OVERLOAD);
1608     ENTER;
1609     SAVEOP();
1610     PL_op = (OP *) &myop;
1611     if (PERLDB_SUB && PL_curstash != PL_debstash)
1612         PL_op->op_private |= OPpENTERSUB_DB;
1613     PUTBACK;
1614     pp_pushmark();
1615
1616     EXTEND(SP, notfound + 5);
1617     PUSHs(lr>0? right: left);
1618     PUSHs(lr>0? left: right);
1619     PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no ));
1620     if (notfound) {
1621       PUSHs( sv_2mortal(newSVpv(AMG_id2name(method + assignshift),0)));
1622     }
1623     PUSHs((SV*)cv);
1624     PUTBACK;
1625
1626     if ((PL_op = Perl_pp_entersub(aTHX)))
1627       CALLRUNOPS(aTHX);
1628     LEAVE;
1629     SPAGAIN;
1630
1631     res=POPs;
1632     PUTBACK;
1633     POPSTACK;
1634     CATCH_SET(oldcatch);
1635
1636     if (postpr) {
1637       int ans;
1638       switch (method) {
1639       case le_amg:
1640       case sle_amg:
1641         ans=SvIV(res)<=0; break;
1642       case lt_amg:
1643       case slt_amg:
1644         ans=SvIV(res)<0; break;
1645       case ge_amg:
1646       case sge_amg:
1647         ans=SvIV(res)>=0; break;
1648       case gt_amg:
1649       case sgt_amg:
1650         ans=SvIV(res)>0; break;
1651       case eq_amg:
1652       case seq_amg:
1653         ans=SvIV(res)==0; break;
1654       case ne_amg:
1655       case sne_amg:
1656         ans=SvIV(res)!=0; break;
1657       case inc_amg:
1658       case dec_amg:
1659         SvSetSV(left,res); return left;
1660       case not_amg:
1661         ans=!SvTRUE(res); break;
1662       }
1663       return boolSV(ans);
1664     } else if (method==copy_amg) {
1665       if (!SvROK(res)) {
1666         Perl_croak(aTHX_ "Copy method did not return a reference");
1667       }
1668       return SvREFCNT_inc(SvRV(res));
1669     } else {
1670       return res;
1671     }
1672   }
1673 }
1674
1675 /*
1676 =for apidoc is_gv_magical
1677
1678 Returns C<TRUE> if given the name of a magical GV.
1679
1680 Currently only useful internally when determining if a GV should be
1681 created even in rvalue contexts.
1682
1683 C<flags> is not used at present but available for future extension to
1684 allow selecting particular classes of magical variable.
1685
1686 =cut
1687 */
1688 bool
1689 Perl_is_gv_magical(pTHX_ char *name, STRLEN len, U32 flags)
1690 {
1691     if (!len)
1692         return FALSE;
1693
1694     switch (*name) {
1695     case 'I':
1696         if (len == 3 && strEQ(name, "ISA"))
1697             goto yes;
1698         break;
1699     case 'O':
1700         if (len == 8 && strEQ(name, "OVERLOAD"))
1701             goto yes;
1702         break;
1703     case 'S':
1704         if (len == 3 && strEQ(name, "SIG"))
1705             goto yes;
1706         break;
1707     case '\017':   /* $^O & $^OPEN */
1708         if (len == 1
1709             || (len == 4 && strEQ(name, "\027PEN")))
1710         {
1711             goto yes;
1712         }
1713         break;
1714     case '\027':   /* $^W & $^WARNING_BITS */
1715         if (len == 1
1716             || (len == 12 && strEQ(name, "\027ARNING_BITS"))
1717             || (len == 17 && strEQ(name, "\027IDE_SYSTEM_CALLS")))
1718         {
1719             goto yes;
1720         }
1721         break;
1722
1723     case '&':
1724     case '`':
1725     case '\'':
1726     case ':':
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 '\001':   /* $^A */
1750     case '\003':   /* $^C */
1751     case '\004':   /* $^D */
1752     case '\005':   /* $^E */
1753     case '\006':   /* $^F */
1754     case '\010':   /* $^H */
1755     case '\011':   /* $^I, NOT \t in EBCDIC */
1756     case '\014':   /* $^L */
1757     case '\020':   /* $^P */
1758     case '\023':   /* $^S */
1759     case '\024':   /* $^T */
1760     case '\026':   /* $^V */
1761         if (len == 1)
1762             goto yes;
1763         break;
1764     case '1':
1765     case '2':
1766     case '3':
1767     case '4':
1768     case '5':
1769     case '6':
1770     case '7':
1771     case '8':
1772     case '9':
1773         if (len > 1) {
1774             char *end = name + len;
1775             while (--end > name) {
1776                 if (!isDIGIT(*end))
1777                     return FALSE;
1778             }
1779         }
1780     yes:
1781         return TRUE;
1782     default:
1783         break;
1784     }
1785     return FALSE;
1786 }