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                 Newz(73, PL_psig_ptr,  SIG_SIZE, SV*);
 754                 Newz(73, PL_psig_name, SIG_SIZE, SV*);
 755                 Newz(73, PL_psig_pend, SIG_SIZE, int);
 756             }
 757             GvMULTI_on(gv);
 758             hv = GvHVn(gv);
 759             hv_magic(hv, Nullgv, 'S');
 760             for (i = 1; i < SIG_SIZE; 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                 PL_psig_pend[i] = 0;
 768             }
 769         }
 770         break;
 771     case 'V':
 772         if (strEQ(name, "VERSION"))
 773             GvMULTI_on(gv);
 774         break;
 775
 776     case '&':
 777         if (len > 1)
 778             break;
 779         PL_sawampersand = TRUE;
 780         goto ro_magicalize;
 781
 782     case '`':
 783         if (len > 1)
 784             break;
 785         PL_sawampersand = TRUE;
 786         goto ro_magicalize;
 787
 788     case '\'':
 789         if (len > 1)
 790             break;
 791         PL_sawampersand = TRUE;
 792         goto ro_magicalize;
 793
 794     case ':':
 795         if (len > 1)
 796             break;
 797         sv_setpv(GvSV(gv),PL_chopset);
 798         goto magicalize;
 799
 800     case '?':
 801         if (len > 1)
 802             break;
 803 #ifdef COMPLEX_STATUS
 804         (void)SvUPGRADE(GvSV(gv), SVt_PVLV);
 805 #endif
 806         goto magicalize;
 807
 808     case '!':
 809         if (len > 1)
 810             break;
 811         if (sv_type > SVt_PV && PL_curcop != &PL_compiling) {
 812             HV* stash = gv_stashpvn("Errno",5,FALSE);
 813             if (!stash || !(gv_fetchmethod(stash, "TIEHASH"))) {
 814                 dSP;
 815                 PUTBACK;
 816                 require_pv("Errno.pm");
 817                 SPAGAIN;
 818                 stash = gv_stashpvn("Errno",5,FALSE);
 819                 if (!stash || !(gv_fetchmethod(stash, "TIEHASH")))
 820                     Perl_croak(aTHX_ "Can't use %%! because Errno.pm is not available");
 821             }
 822         }
 823         goto magicalize;
 824     case '-':
 825         if (len > 1)
 826             break;
 827         else {
 828             AV* av = GvAVn(gv);
 829             sv_magic((SV*)av, Nullsv, 'D', Nullch, 0);
 830             SvREADONLY_on(av);
 831         }
 832         goto magicalize;
 833     case '#':
 834     case '*':
 835         if (ckWARN(WARN_DEPRECATED) && len == 1 && sv_type == SVt_PV)
 836             Perl_warner(aTHX_ WARN_DEPRECATED, "Use of $%s is deprecated", name);
 837         /* FALL THROUGH */
 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 '/':
 851     case '\001':        /* $^A */
 852     case '\003':        /* $^C */
 853     case '\004':        /* $^D */
 854     case '\005':        /* $^E */
 855     case '\006':        /* $^F */
 856     case '\010':        /* $^H */
 857     case '\011':        /* $^I, NOT \t in EBCDIC */
 858     case '\020':        /* $^P */
 859     case '\024':        /* $^T */
 860         if (len > 1)
 861             break;
 862         goto magicalize;
 863     case '|':
 864         if (len > 1)
 865             break;
 866         sv_setiv(GvSV(gv), (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0);
 867         goto magicalize;
 868     case '\017':        /* $^O & $^OPEN */
 869         if (len > 1 && strNE(name, "\017PEN"))
 870             break;
 871         goto magicalize;
 872     case '\023':        /* $^S */
 873         if (len > 1)
 874             break;
 875         goto ro_magicalize;
 876     case '\027':        /* $^W & $^WARNING_BITS */
 877         if (len > 1 && strNE(name, "\027ARNING_BITS")
 878             && strNE(name, "\027IDE_SYSTEM_CALLS"))
 879             break;
 880         goto magicalize;
 881
 882     case '+':
 883         if (len > 1)
 884             break;
 885         else {
 886             AV* av = GvAVn(gv);
 887             sv_magic((SV*)av, (SV*)av, 'D', Nullch, 0);
 888             SvREADONLY_on(av);
 889         }
 890         /* FALL THROUGH */
 891     case '1':
 892     case '2':
 893     case '3':
 894     case '4':
 895     case '5':
 896     case '6':
 897     case '7':
 898     case '8':
 899     case '9':
 900       ro_magicalize:
 901         SvREADONLY_on(GvSV(gv));
 902       magicalize:
 903         sv_magic(GvSV(gv), (SV*)gv, 0, name, len);
 904         break;
 905
 906     case '\014':        /* $^L */
 907         if (len > 1)
 908             break;
 909         sv_setpv(GvSV(gv),"\f");
 910         PL_formfeed = GvSV(gv);
 911         break;
 912     case ';':
 913         if (len > 1)
 914             break;
 915         sv_setpv(GvSV(gv),"\034");
 916         break;
 917     case ']':
 918         if (len == 1) {
 919             SV *sv = GvSV(gv);
 920             (void)SvUPGRADE(sv, SVt_PVNV);
 921             Perl_sv_setpvf(aTHX_ sv,
 922 #if defined(PERL_SUBVERSION) && (PERL_SUBVERSION > 0)
 923                             "%8.6"
 924 #else
 925                             "%5.3"
 926 #endif
 927                             NVff,
 928                             SvNVX(PL_patchlevel));
 929             SvNVX(sv) = SvNVX(PL_patchlevel);
 930             SvNOK_on(sv);
 931             SvREADONLY_on(sv);
 932         }
 933         break;
 934     case '\026':        /* $^V */
 935         if (len == 1) {
 936             SV *sv = GvSV(gv);
 937             GvSV(gv) = SvREFCNT_inc(PL_patchlevel);
 938             SvREFCNT_dec(sv);
 939         }
 940         break;
 941     }
 942     return gv;
 943 }
 944
 945 void
 946 Perl_gv_fullname4(pTHX_ SV *sv, GV *gv, const char *prefix, bool keepmain)
 947 {
 948     HV *hv = GvSTASH(gv);
 949     if (!hv) {
 950         (void)SvOK_off(sv);
 951         return;
 952     }
 953     sv_setpv(sv, prefix ? prefix : "");
 954     if (keepmain || strNE(HvNAME(hv), "main")) {
 955         sv_catpv(sv,HvNAME(hv));
 956         sv_catpvn(sv,"::", 2);
 957     }
 958     sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv));
 959 }
 960
 961 void
 962 Perl_gv_fullname3(pTHX_ SV *sv, GV *gv, const char *prefix)
 963 {
 964     HV *hv = GvSTASH(gv);
 965     if (!hv) {
 966         (void)SvOK_off(sv);
 967         return;
 968     }
 969     sv_setpv(sv, prefix ? prefix : "");
 970     sv_catpv(sv,HvNAME(hv));
 971     sv_catpvn(sv,"::", 2);
 972     sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv));
 973 }
 974
 975 void
 976 Perl_gv_efullname4(pTHX_ SV *sv, GV *gv, const char *prefix, bool keepmain)
 977 {
 978     GV *egv = GvEGV(gv);
 979     if (!egv)
 980         egv = gv;
 981     gv_fullname4(sv, egv, prefix, keepmain);
 982 }
 983
 984 void
 985 Perl_gv_efullname3(pTHX_ SV *sv, GV *gv, const char *prefix)
 986 {
 987     GV *egv = GvEGV(gv);
 988     if (!egv)
 989         egv = gv;
 990     gv_fullname3(sv, egv, prefix);
 991 }
 992
 993 /* XXX compatibility with versions <= 5.003. */
 994 void
 995 Perl_gv_fullname(pTHX_ SV *sv, GV *gv)
 996 {
 997     gv_fullname3(sv, gv, sv == (SV*)gv ? "*" : "");
 998 }
 999
1000 /* XXX compatibility with versions <= 5.003. */
1001 void
1002 Perl_gv_efullname(pTHX_ SV *sv, GV *gv)
1003 {
1004     gv_efullname3(sv, gv, sv == (SV*)gv ? "*" : "");
1005 }
1006
1007 IO *
1008 Perl_newIO(pTHX)
1009 {
1010     IO *io;
1011     GV *iogv;
1012
1013     io = (IO*)NEWSV(0,0);
1014     sv_upgrade((SV *)io,SVt_PVIO);
1015     SvREFCNT(io) = 1;
1016     SvOBJECT_on(io);
1017     iogv = gv_fetchpv("FileHandle::", FALSE, SVt_PVHV);
1018     /* unless exists($main::{FileHandle}) and defined(%main::FileHandle::) */
1019     if (!(iogv && GvHV(iogv) && HvARRAY(GvHV(iogv))))
1020       iogv = gv_fetchpv("IO::Handle::", TRUE, SVt_PVHV);
1021     SvSTASH(io) = (HV*)SvREFCNT_inc(GvHV(iogv));
1022     return io;
1023 }
1024
1025 void
1026 Perl_gv_check(pTHX_ HV *stash)
1027 {
1028     register HE *entry;
1029     register I32 i;
1030     register GV *gv;
1031     HV *hv;
1032
1033     if (!HvARRAY(stash))
1034         return;
1035     for (i = 0; i <= (I32) HvMAX(stash); i++) {
1036         for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
1037             if (HeKEY(entry)[HeKLEN(entry)-1] == ':' &&
1038                 (gv = (GV*)HeVAL(entry)) && (hv = GvHV(gv)) && HvNAME(hv))
1039             {
1040                 if (hv != PL_defstash && hv != stash)
1041                      gv_check(hv);              /* nested package */
1042             }
1043             else if (isALPHA(*HeKEY(entry))) {
1044                 char *file;
1045                 gv = (GV*)HeVAL(entry);
1046                 if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv))
1047                     continue;
1048                 file = GvFILE(gv);
1049                 /* performance hack: if filename is absolute and it's a standard
1050                  * module, don't bother warning */
1051                 if (file
1052                     && PERL_FILE_IS_ABSOLUTE(file)
1053                     && (instr(file, "/lib/") || instr(file, ".pm")))
1054                 {
1055                     continue;
1056                 }
1057                 CopLINE_set(PL_curcop, GvLINE(gv));
1058 #ifdef USE_ITHREADS
1059                 CopFILE(PL_curcop) = file;      /* set for warning */
1060 #else
1061                 CopFILEGV(PL_curcop) = gv_fetchfile(file);
1062 #endif
1063                 Perl_warner(aTHX_ WARN_ONCE,
1064                         "Name \"%s::%s\" used only once: possible typo",
1065                         HvNAME(stash), GvNAME(gv));
1066             }
1067         }
1068     }
1069 }
1070
1071 GV *
1072 Perl_newGVgen(pTHX_ char *pack)
1073 {
1074     return gv_fetchpv(Perl_form(aTHX_ "%s::_GEN_%ld", pack, (long)PL_gensym++),
1075                       TRUE, SVt_PVGV);
1076 }
1077
1078 /* hopefully this is only called on local symbol table entries */
1079
1080 GP*
1081 Perl_gp_ref(pTHX_ GP *gp)
1082 {
1083     if (!gp)
1084         return (GP*)NULL;
1085     gp->gp_refcnt++;
1086     if (gp->gp_cv) {
1087         if (gp->gp_cvgen) {
1088             /* multi-named GPs cannot be used for method cache */
1089             SvREFCNT_dec(gp->gp_cv);
1090             gp->gp_cv = Nullcv;
1091             gp->gp_cvgen = 0;
1092         }
1093         else {
1094             /* Adding a new name to a subroutine invalidates method cache */
1095             PL_sub_generation++;
1096         }
1097     }
1098     return gp;
1099 }
1100
1101 void
1102 Perl_gp_free(pTHX_ GV *gv)
1103 {
1104     GP* gp;
1105
1106     if (!gv || !(gp = GvGP(gv)))
1107         return;
1108     if (gp->gp_refcnt == 0) {
1109         if (ckWARN_d(WARN_INTERNAL))
1110             Perl_warner(aTHX_ WARN_INTERNAL,
1111                         "Attempt to free unreferenced glob pointers");
1112         return;
1113     }
1114     if (gp->gp_cv) {
1115         /* Deleting the name of a subroutine invalidates method cache */
1116         PL_sub_generation++;
1117     }
1118     if (--gp->gp_refcnt > 0) {
1119         if (gp->gp_egv == gv)
1120             gp->gp_egv = 0;
1121         return;
1122     }
1123
1124     SvREFCNT_dec(gp->gp_sv);
1125     SvREFCNT_dec(gp->gp_av);
1126     SvREFCNT_dec(gp->gp_hv);
1127     SvREFCNT_dec(gp->gp_io);
1128     SvREFCNT_dec(gp->gp_cv);
1129     SvREFCNT_dec(gp->gp_form);
1130
1131     Safefree(gp);
1132     GvGP(gv) = 0;
1133 }
1134
1135 #if defined(CRIPPLED_CC) && (defined(iAPX286) || defined(M_I286) || defined(I80286))
1136 #define MICROPORT
1137 #endif
1138
1139 #ifdef  MICROPORT       /* Microport 2.4 hack */
1140 AV *GvAVn(gv)
1141 register GV *gv;
1142 {
1143     if (GvGP(gv)->gp_av)
1144         return GvGP(gv)->gp_av;
1145     else
1146         return GvGP(gv_AVadd(gv))->gp_av;
1147 }
1148
1149 HV *GvHVn(gv)
1150 register GV *gv;
1151 {
1152     if (GvGP(gv)->gp_hv)
1153         return GvGP(gv)->gp_hv;
1154     else
1155         return GvGP(gv_HVadd(gv))->gp_hv;
1156 }
1157 #endif                  /* Microport 2.4 hack */
1158
1159 int
1160 Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg)
1161 {
1162     AMT *amtp = (AMT*)mg->mg_ptr;
1163     if (amtp && AMT_AMAGIC(amtp)) {
1164         int i;
1165         for (i = 1; i < NofAMmeth; i++) {
1166             CV *cv = amtp->table[i];
1167             if (cv != Nullcv) {
1168                 SvREFCNT_dec((SV *) cv);
1169                 amtp->table[i] = Nullcv;
1170             }
1171         }
1172     }
1173  return 0;
1174 }
1175
1176 /* Updates and caches the CV's */
1177
1178 bool
1179 Perl_Gv_AMupdate(pTHX_ HV *stash)
1180 {
1181   GV* gv;
1182   CV* cv;
1183   MAGIC* mg=mg_find((SV*)stash,'c');
1184   AMT *amtp = (mg) ? (AMT*)mg->mg_ptr: (AMT *) NULL;
1185   AMT amt;
1186   STRLEN n_a;
1187
1188   if (mg && amtp->was_ok_am == PL_amagic_generation
1189       && amtp->was_ok_sub == PL_sub_generation)
1190       return AMT_OVERLOADED(amtp);
1191   sv_unmagic((SV*)stash, 'c');
1192
1193   DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME(stash)) );
1194
1195   Zero(&amt,1,AMT);
1196   amt.was_ok_am = PL_amagic_generation;
1197   amt.was_ok_sub = PL_sub_generation;
1198   amt.fallback = AMGfallNO;
1199   amt.flags = 0;
1200
1201   {
1202     int filled = 0, have_ovl = 0;
1203     int i, lim = 1;
1204     const char *cp;
1205     SV* sv = NULL;
1206
1207     /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
1208
1209     /* Try to find via inheritance. */
1210     gv = gv_fetchmeth(stash, PL_AMG_names[0], 2, -1);
1211     if (gv)
1212         sv = GvSV(gv);
1213
1214     if (!gv)
1215         lim = DESTROY_amg;              /* Skip overloading entries. */
1216     else if (SvTRUE(sv))
1217         amt.fallback=AMGfallYES;
1218     else if (SvOK(sv))
1219         amt.fallback=AMGfallNEVER;
1220
1221     for (i = 1; i < lim; i++)
1222         amt.table[i] = Nullcv;
1223     for (; i < NofAMmeth; i++) {
1224         char *cooky = (char*)PL_AMG_names[i];
1225         /* Human-readable form, for debugging: */
1226         char *cp = (i >= DESTROY_amg ? cooky : AMG_id2name(i));
1227         STRLEN l = strlen(cooky);
1228
1229         DEBUG_o( Perl_deb(aTHX_ "Checking overloading of `%s' in package `%.256s'\n",
1230                      cp, HvNAME(stash)) );
1231         /* don't fill the cache while looking up! */
1232         gv = gv_fetchmeth(stash, cooky, l, -1);
1233         cv = 0;
1234         if (gv && (cv = GvCV(gv))) {
1235             if (GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")
1236                 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "overload")) {
1237                 /* GvSV contains the name of the method. */
1238                 GV *ngv;
1239
1240                 DEBUG_o( Perl_deb(aTHX_ "Resolving method `%.256s' for overloaded `%s' in package `%.256s'\n",
1241                              SvPV(GvSV(gv), n_a), cp, HvNAME(stash)) );
1242                 if (!SvPOK(GvSV(gv))
1243                     || !(ngv = gv_fetchmethod_autoload(stash, SvPVX(GvSV(gv)),
1244                                                        FALSE)))
1245                 {
1246                     /* Can be an import stub (created by `can'). */
1247                     if (GvCVGEN(gv)) {
1248                         Perl_croak(aTHX_ "Stub found while resolving method `%.256s' overloading `%s' in package `%.256s'",
1249                               (SvPOK(GvSV(gv)) ?  SvPVX(GvSV(gv)) : "???" ),
1250                               cp, HvNAME(stash));
1251                     } else
1252                         Perl_croak(aTHX_ "Can't resolve method `%.256s' overloading `%s' in package `%.256s'",
1253                               (SvPOK(GvSV(gv)) ?  SvPVX(GvSV(gv)) : "???" ),
1254                               cp, HvNAME(stash));
1255                 }
1256                 cv = GvCV(gv = ngv);
1257             }
1258             DEBUG_o( Perl_deb(aTHX_ "Overloading `%s' in package `%.256s' via `%.256s::%.256s' \n",
1259                          cp, HvNAME(stash), HvNAME(GvSTASH(CvGV(cv))),
1260                          GvNAME(CvGV(cv))) );
1261             filled = 1;
1262             if (i < DESTROY_amg)
1263                 have_ovl = 1;
1264         }
1265         amt.table[i]=(CV*)SvREFCNT_inc(cv);
1266     }
1267     if (filled) {
1268       AMT_AMAGIC_on(&amt);
1269       if (have_ovl)
1270           AMT_OVERLOADED_on(&amt);
1271       sv_magic((SV*)stash, 0, 'c', (char*)&amt, sizeof(AMT));
1272       return have_ovl;
1273     }
1274   }
1275   /* Here we have no table: */
1276  no_table:
1277   AMT_AMAGIC_off(&amt);
1278   sv_magic((SV*)stash, 0, 'c', (char*)&amt, sizeof(AMTS));
1279   return FALSE;
1280 }
1281
1282
1283 CV*
1284 Perl_gv_handler(pTHX_ HV *stash, I32 id)
1285 {
1286     dTHR;
1287     MAGIC *mg;
1288     AMT *amtp;
1289
1290     if (!stash)
1291         return Nullcv;
1292     mg = mg_find((SV*)stash,'c');
1293     if (!mg) {
1294       do_update:
1295         Gv_AMupdate(stash);
1296         mg = mg_find((SV*)stash,'c');
1297     }
1298     amtp = (AMT*)mg->mg_ptr;
1299     if ( amtp->was_ok_am != PL_amagic_generation
1300          || amtp->was_ok_sub != PL_sub_generation )
1301         goto do_update;
1302     if (AMT_AMAGIC(amtp))
1303         return amtp->table[id];
1304     return Nullcv;
1305 }
1306
1307
1308 SV*
1309 Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
1310 {
1311   MAGIC *mg;
1312   CV *cv;
1313   CV **cvp=NULL, **ocvp=NULL;
1314   AMT *amtp, *oamtp;
1315   int fl=0, off, off1, lr=0, assign=AMGf_assign & flags, notfound=0;
1316   int postpr = 0, force_cpy = 0, assignshift = assign ? 1 : 0;
1317   HV* stash;
1318   if (!(AMGf_noleft & flags) && SvAMAGIC(left)
1319       && (mg = mg_find((SV*)(stash=SvSTASH(SvRV(left))),'c'))
1320       && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
1321                         ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
1322                         : (CV **) NULL))
1323       && ((cv = cvp[off=method+assignshift])
1324           || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
1325                                                           * usual method */
1326                   (fl = 1, cv = cvp[off=method])))) {
1327     lr = -1;                    /* Call method for left argument */
1328   } else {
1329     if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) {
1330       int logic;
1331
1332       /* look for substituted methods */
1333       /* In all the covered cases we should be called with assign==0. */
1334          switch (method) {
1335          case inc_amg:
1336            force_cpy = 1;
1337            if ((cv = cvp[off=add_ass_amg])
1338                || ((cv = cvp[off = add_amg]) && (force_cpy = 0, postpr = 1))) {
1339              right = &PL_sv_yes; lr = -1; assign = 1;
1340            }
1341            break;
1342          case dec_amg:
1343            force_cpy = 1;
1344            if ((cv = cvp[off = subtr_ass_amg])
1345                || ((cv = cvp[off = subtr_amg]) && (force_cpy = 0, postpr=1))) {
1346              right = &PL_sv_yes; lr = -1; assign = 1;
1347            }
1348            break;
1349          case bool__amg:
1350            (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg]));
1351            break;
1352          case numer_amg:
1353            (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg]));
1354            break;
1355          case string_amg:
1356            (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg]));
1357            break;
1358  case not_amg:
1359    (void)((cv = cvp[off=bool__amg])
1360           || (cv = cvp[off=numer_amg])
1361           || (cv = cvp[off=string_amg]));
1362    postpr = 1;
1363    break;
1364          case copy_amg:
1365            {
1366              /*
1367                   * SV* ref causes confusion with the interpreter variable of
1368                   * the same name
1369                   */
1370              SV* tmpRef=SvRV(left);
1371              if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) {
1372                 /*
1373                  * Just to be extra cautious.  Maybe in some
1374                  * additional cases sv_setsv is safe, too.
1375                  */
1376                 SV* newref = newSVsv(tmpRef);
1377                 SvOBJECT_on(newref);
1378                 SvSTASH(newref) = (HV*)SvREFCNT_inc(SvSTASH(tmpRef));
1379                 return newref;
1380              }
1381            }
1382            break;
1383          case abs_amg:
1384            if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg])
1385                && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) {
1386              SV* nullsv=sv_2mortal(newSViv(0));
1387              if (off1==lt_amg) {
1388                SV* lessp = amagic_call(left,nullsv,
1389                                        lt_amg,AMGf_noright);
1390                logic = SvTRUE(lessp);
1391              } else {
1392                SV* lessp = amagic_call(left,nullsv,
1393                                        ncmp_amg,AMGf_noright);
1394                logic = (SvNV(lessp) < 0);
1395              }
1396              if (logic) {
1397                if (off==subtr_amg) {
1398                  right = left;
1399                  left = nullsv;
1400                  lr = 1;
1401                }
1402              } else {
1403                return left;
1404              }
1405            }
1406            break;
1407          case neg_amg:
1408            if ((cv = cvp[off=subtr_amg])) {
1409              right = left;
1410              left = sv_2mortal(newSViv(0));
1411              lr = 1;
1412            }
1413            break;
1414          case iter_amg:                 /* XXXX Eventually should do to_gv. */
1415              /* FAIL safe */
1416              return NULL;       /* Delegate operation to standard mechanisms. */
1417              break;
1418          case to_sv_amg:
1419          case to_av_amg:
1420          case to_hv_amg:
1421          case to_gv_amg:
1422          case to_cv_amg:
1423              /* FAIL safe */
1424              return left;       /* Delegate operation to standard mechanisms. */
1425              break;
1426          default:
1427            goto not_found;
1428          }
1429          if (!cv) goto not_found;
1430     } else if (!(AMGf_noright & flags) && SvAMAGIC(right)
1431                && (mg = mg_find((SV*)(stash=SvSTASH(SvRV(right))),'c'))
1432                && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
1433                           ? (amtp = (AMT*)mg->mg_ptr)->table
1434                           : (CV **) NULL))
1435                && (cv = cvp[off=method])) { /* Method for right
1436                                              * argument found */
1437       lr=1;
1438     } else if (((ocvp && oamtp->fallback > AMGfallNEVER
1439                  && (cvp=ocvp) && (lr = -1))
1440                 || (cvp && amtp->fallback > AMGfallNEVER && (lr=1)))
1441                && !(flags & AMGf_unary)) {
1442                                 /* We look for substitution for
1443                                  * comparison operations and
1444                                  * concatenation */
1445       if (method==concat_amg || method==concat_ass_amg
1446           || method==repeat_amg || method==repeat_ass_amg) {
1447         return NULL;            /* Delegate operation to string conversion */
1448       }
1449       off = -1;
1450       switch (method) {
1451          case lt_amg:
1452          case le_amg:
1453          case gt_amg:
1454          case ge_amg:
1455          case eq_amg:
1456          case ne_amg:
1457            postpr = 1; off=ncmp_amg; break;
1458          case slt_amg:
1459          case sle_amg:
1460          case sgt_amg:
1461          case sge_amg:
1462          case seq_amg:
1463          case sne_amg:
1464            postpr = 1; off=scmp_amg; break;
1465          }
1466       if (off != -1) cv = cvp[off];
1467       if (!cv) {
1468         goto not_found;
1469       }
1470     } else {
1471     not_found:                  /* No method found, either report or croak */
1472       switch (method) {
1473          case to_sv_amg:
1474          case to_av_amg:
1475          case to_hv_amg:
1476          case to_gv_amg:
1477          case to_cv_amg:
1478              /* FAIL safe */
1479              return left;       /* Delegate operation to standard mechanisms. */
1480              break;
1481       }
1482       if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */
1483         notfound = 1; lr = -1;
1484       } else if (cvp && (cv=cvp[nomethod_amg])) {
1485         notfound = 1; lr = 1;
1486       } else {
1487         SV *msg;
1488         if (off==-1) off=method;
1489         msg = sv_2mortal(Perl_newSVpvf(aTHX_
1490                       "Operation `%s': no method found,%sargument %s%s%s%s",
1491                       AMG_id2name(method + assignshift),
1492                       (flags & AMGf_unary ? " " : "\n\tleft "),
1493                       SvAMAGIC(left)?
1494                         "in overloaded package ":
1495                         "has no overloaded magic",
1496                       SvAMAGIC(left)?
1497                         HvNAME(SvSTASH(SvRV(left))):
1498                         "",
1499                       SvAMAGIC(right)?
1500                         ",\n\tright argument in overloaded package ":
1501                         (flags & AMGf_unary
1502                          ? ""
1503                          : ",\n\tright argument has no overloaded magic"),
1504                       SvAMAGIC(right)?
1505                         HvNAME(SvSTASH(SvRV(right))):
1506                         ""));
1507         if (amtp && amtp->fallback >= AMGfallYES) {
1508           DEBUG_o( Perl_deb(aTHX_ "%s", SvPVX(msg)) );
1509         } else {
1510           Perl_croak(aTHX_ "%"SVf, msg);
1511         }
1512         return NULL;
1513       }
1514       force_cpy = force_cpy || assign;
1515     }
1516   }
1517   if (!notfound) {
1518     DEBUG_o( Perl_deb(aTHX_
1519   "Overloaded operator `%s'%s%s%s:\n\tmethod%s found%s in package %s%s\n",
1520                  AMG_id2name(off),
1521                  method+assignshift==off? "" :
1522                              " (initially `",
1523                  method+assignshift==off? "" :
1524                              AMG_id2name(method+assignshift),
1525                  method+assignshift==off? "" : "')",
1526                  flags & AMGf_unary? "" :
1527                    lr==1 ? " for right argument": " for left argument",
1528                  flags & AMGf_unary? " for argument" : "",
1529                  HvNAME(stash),
1530                  fl? ",\n\tassignment variant used": "") );
1531   }
1532     /* Since we use shallow copy during assignment, we need
1533      * to dublicate the contents, probably calling user-supplied
1534      * version of copy operator
1535      */
1536     /* We need to copy in following cases:
1537      * a) Assignment form was called.
1538      *          assignshift==1,  assign==T, method + 1 == off
1539      * b) Increment or decrement, called directly.
1540      *          assignshift==0,  assign==0, method + 0 == off
1541      * c) Increment or decrement, translated to assignment add/subtr.
1542      *          assignshift==0,  assign==T,
1543      *          force_cpy == T
1544      * d) Increment or decrement, translated to nomethod.
1545      *          assignshift==0,  assign==0,
1546      *          force_cpy == T
1547      * e) Assignment form translated to nomethod.
1548      *          assignshift==1,  assign==T, method + 1 != off
1549      *          force_cpy == T
1550      */
1551     /*  off is method, method+assignshift, or a result of opcode substitution.
1552      *  In the latter case assignshift==0, so only notfound case is important.
1553      */
1554   if (( (method + assignshift == off)
1555         && (assign || (method == inc_amg) || (method == dec_amg)))
1556       || force_cpy)
1557     RvDEEPCP(left);
1558   {
1559     dSP;
1560     BINOP myop;
1561     SV* res;
1562     bool oldcatch = CATCH_GET;
1563
1564     CATCH_SET(TRUE);
1565     Zero(&myop, 1, BINOP);
1566     myop.op_last = (OP *) &myop;
1567     myop.op_next = Nullop;
1568     myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
1569
1570     PUSHSTACKi(PERLSI_OVERLOAD);
1571     ENTER;
1572     SAVEOP();
1573     PL_op = (OP *) &myop;
1574     if (PERLDB_SUB && PL_curstash != PL_debstash)
1575         PL_op->op_private |= OPpENTERSUB_DB;
1576     PUTBACK;
1577     pp_pushmark();
1578
1579     EXTEND(SP, notfound + 5);
1580     PUSHs(lr>0? right: left);
1581     PUSHs(lr>0? left: right);
1582     PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no ));
1583     if (notfound) {
1584       PUSHs( sv_2mortal(newSVpv(AMG_id2name(method + assignshift),0)));
1585     }
1586     PUSHs((SV*)cv);
1587     PUTBACK;
1588
1589     if ((PL_op = Perl_pp_entersub(aTHX)))
1590       CALLRUNOPS(aTHX);
1591     LEAVE;
1592     SPAGAIN;
1593
1594     res=POPs;
1595     PUTBACK;
1596     POPSTACK;
1597     CATCH_SET(oldcatch);
1598
1599     if (postpr) {
1600       int ans;
1601       switch (method) {
1602       case le_amg:
1603       case sle_amg:
1604         ans=SvIV(res)<=0; break;
1605       case lt_amg:
1606       case slt_amg:
1607         ans=SvIV(res)<0; break;
1608       case ge_amg:
1609       case sge_amg:
1610         ans=SvIV(res)>=0; break;
1611       case gt_amg:
1612       case sgt_amg:
1613         ans=SvIV(res)>0; break;
1614       case eq_amg:
1615       case seq_amg:
1616         ans=SvIV(res)==0; break;
1617       case ne_amg:
1618       case sne_amg:
1619         ans=SvIV(res)!=0; break;
1620       case inc_amg:
1621       case dec_amg:
1622         SvSetSV(left,res); return left;
1623       case not_amg:
1624         ans=!SvTRUE(res); break;
1625       }
1626       return boolSV(ans);
1627     } else if (method==copy_amg) {
1628       if (!SvROK(res)) {
1629         Perl_croak(aTHX_ "Copy method did not return a reference");
1630       }
1631       return SvREFCNT_inc(SvRV(res));
1632     } else {
1633       return res;
1634     }
1635   }
1636 }
1637
1638 /*
1639 =for apidoc is_gv_magical
1640
1641 Returns C<TRUE> if given the name of a magical GV.
1642
1643 Currently only useful internally when determining if a GV should be
1644 created even in rvalue contexts.
1645
1646 C<flags> is not used at present but available for future extension to
1647 allow selecting particular classes of magical variable.
1648
1649 =cut
1650 */
1651 bool
1652 Perl_is_gv_magical(pTHX_ char *name, STRLEN len, U32 flags)
1653 {
1654     if (!len)
1655         return FALSE;
1656
1657     switch (*name) {
1658     case 'I':
1659         if (len == 3 && strEQ(name, "ISA"))
1660             goto yes;
1661         break;
1662     case 'O':
1663         if (len == 8 && strEQ(name, "OVERLOAD"))
1664             goto yes;
1665         break;
1666     case 'S':
1667         if (len == 3 && strEQ(name, "SIG"))
1668             goto yes;
1669         break;
1670     case '\017':   /* $^O & $^OPEN */
1671         if (len == 1
1672             || (len == 4 && strEQ(name, "\027PEN")))
1673         {
1674             goto yes;
1675         }
1676         break;
1677     case '\027':   /* $^W & $^WARNING_BITS */
1678         if (len == 1
1679             || (len == 12 && strEQ(name, "\027ARNING_BITS"))
1680             || (len == 17 && strEQ(name, "\027IDE_SYSTEM_CALLS")))
1681         {
1682             goto yes;
1683         }
1684         break;
1685
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 ']':
1712     case '\001':   /* $^A */
1713     case '\003':   /* $^C */
1714     case '\004':   /* $^D */
1715     case '\005':   /* $^E */
1716     case '\006':   /* $^F */
1717     case '\010':   /* $^H */
1718     case '\011':   /* $^I, NOT \t in EBCDIC */
1719     case '\014':   /* $^L */
1720     case '\020':   /* $^P */
1721     case '\023':   /* $^S */
1722     case '\024':   /* $^T */
1723     case '\026':   /* $^V */
1724         if (len == 1)
1725             goto yes;
1726         break;
1727     case '1':
1728     case '2':
1729     case '3':
1730     case '4':
1731     case '5':
1732     case '6':
1733     case '7':
1734     case '8':
1735     case '9':
1736         if (len > 1) {
1737             char *end = name + len;
1738             while (--end > name) {
1739                 if (!isDIGIT(*end))
1740                     return FALSE;
1741             }
1742         }
1743     yes:
1744         return TRUE;
1745     default:
1746         break;
1747     }
1748     return FALSE;
1749 }