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