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