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