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