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