gv.c

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