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