gv.c

   1 /*    gv.c
   2  *
   3  *    Copyright (c) 1991-1999, 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(*name)
 585             || (IN_UTF8 && ((*name & 0xc0) == 0xc0) && isIDFIRST_utf8((U8*)name)))
 586         {
 587             bool global = FALSE;
 588
 589             if (isUPPER(*name)) {
 590                 if (*name == 'S' && (
 591                     strEQ(name, "SIG") ||
 592                     strEQ(name, "STDIN") ||
 593                     strEQ(name, "STDOUT") ||
 594                     strEQ(name, "STDERR")))
 595                     global = TRUE;
 596                 else if (*name == 'I' && strEQ(name, "INC"))
 597                     global = TRUE;
 598                 else if (*name == 'E' && strEQ(name, "ENV"))
 599                     global = TRUE;
 600                 else if (*name == 'A' && (
 601                   strEQ(name, "ARGV") ||
 602                   strEQ(name, "ARGVOUT")))
 603                     global = TRUE;
 604             }
 605             else if (*name == '_' && !name[1])
 606                 global = TRUE;
 607
 608             if (global)
 609                 stash = PL_defstash;
 610             else if ((COP*)PL_curcop == &PL_compiling) {
 611                 stash = PL_curstash;
 612                 if (add && (PL_hints & HINT_STRICT_VARS) &&
 613                     sv_type != SVt_PVCV &&
 614                     sv_type != SVt_PVGV &&
 615                     sv_type != SVt_PVFM &&
 616                     sv_type != SVt_PVIO &&
 617                     !(len == 1 && sv_type == SVt_PV && strchr("ab",*name)) )
 618                 {
 619                     gvp = (GV**)hv_fetch(stash,name,len,0);
 620                     if (!gvp ||
 621                         *gvp == (GV*)&PL_sv_undef ||
 622                         SvTYPE(*gvp) != SVt_PVGV)
 623                     {
 624                         stash = 0;
 625                     }
 626                     else if (sv_type == SVt_PV   && !GvIMPORTED_SV(*gvp) ||
 627                              sv_type == SVt_PVAV && !GvIMPORTED_AV(*gvp) ||
 628                              sv_type == SVt_PVHV && !GvIMPORTED_HV(*gvp) )
 629                     {
 630                         Perl_warn(aTHX_ "Variable \"%c%s\" is not imported",
 631                             sv_type == SVt_PVAV ? '@' :
 632                             sv_type == SVt_PVHV ? '%' : '$',
 633                             name);
 634                         if (GvCVu(*gvp))
 635                             Perl_warn(aTHX_ "(Did you mean &%s instead?)\n", name);
 636                         stash = 0;
 637                     }
 638                 }
 639             }
 640             else
 641                 stash = CopSTASH(PL_curcop);
 642         }
 643         else
 644             stash = PL_defstash;
 645     }
 646
 647     /* By this point we should have a stash and a name */
 648
 649     if (!stash) {
 650         if (add) {
 651             qerror(Perl_mess(aTHX_
 652                  "Global symbol \"%s%s\" requires explicit package name",
 653                  (sv_type == SVt_PV ? "$"
 654                   : sv_type == SVt_PVAV ? "@"
 655                   : sv_type == SVt_PVHV ? "%"
 656                   : ""), name));
 657         }
 658         return Nullgv;
 659     }
 660
 661     if (!SvREFCNT(stash))       /* symbol table under destruction */
 662         return Nullgv;
 663
 664     gvp = (GV**)hv_fetch(stash,name,len,add);
 665     if (!gvp || *gvp == (GV*)&PL_sv_undef)
 666         return Nullgv;
 667     gv = *gvp;
 668     if (SvTYPE(gv) == SVt_PVGV) {
 669         if (add) {
 670             GvMULTI_on(gv);
 671             gv_init_sv(gv, sv_type);
 672         }
 673         return gv;
 674     } else if (add & GV_NOINIT) {
 675         return gv;
 676     }
 677
 678     /* Adding a new symbol */
 679
 680     if (add & GV_ADDWARN && ckWARN_d(WARN_INTERNAL))
 681         Perl_warner(aTHX_ WARN_INTERNAL, "Had to create %s unexpectedly", nambeg);
 682     gv_init(gv, stash, name, len, add & GV_ADDMULTI);
 683     gv_init_sv(gv, sv_type);
 684     GvFLAGS(gv) |= add_gvflags;
 685
 686     if (isLEXWARN_on && isALPHA(name[0]) && ! ckWARN(WARN_ONCE))
 687         GvMULTI_on(gv) ;
 688
 689     /* set up magic where warranted */
 690     switch (*name) {
 691     case 'A':
 692         if (strEQ(name, "ARGV")) {
 693             IoFLAGS(GvIOn(gv)) |= IOf_ARGV|IOf_START;
 694         }
 695         break;
 696     case 'E':
 697         if (strnEQ(name, "EXPORT", 6))
 698             GvMULTI_on(gv);
 699         break;
 700     case 'I':
 701         if (strEQ(name, "ISA")) {
 702             AV* av = GvAVn(gv);
 703             GvMULTI_on(gv);
 704             sv_magic((SV*)av, (SV*)gv, 'I', Nullch, 0);
 705             /* NOTE: No support for tied ISA */
 706             if ((add & GV_ADDMULTI) && strEQ(nambeg,"AnyDBM_File::ISA")
 707                 && AvFILLp(av) == -1)
 708             {
 709                 char *pname;
 710                 av_push(av, newSVpvn(pname = "NDBM_File",9));
 711                 gv_stashpvn(pname, 9, TRUE);
 712                 av_push(av, newSVpvn(pname = "DB_File",7));
 713                 gv_stashpvn(pname, 7, TRUE);
 714                 av_push(av, newSVpvn(pname = "GDBM_File",9));
 715                 gv_stashpvn(pname, 9, TRUE);
 716                 av_push(av, newSVpvn(pname = "SDBM_File",9));
 717                 gv_stashpvn(pname, 9, TRUE);
 718                 av_push(av, newSVpvn(pname = "ODBM_File",9));
 719                 gv_stashpvn(pname, 9, TRUE);
 720             }
 721         }
 722         break;
 723     case 'O':
 724         if (strEQ(name, "OVERLOAD")) {
 725             HV* hv = GvHVn(gv);
 726             GvMULTI_on(gv);
 727             hv_magic(hv, gv, 'A');
 728         }
 729         break;
 730     case 'S':
 731         if (strEQ(name, "SIG")) {
 732             HV *hv;
 733             I32 i;
 734             if (!PL_psig_ptr) {
 735                 int sig_num[] = { SIG_NUM };
 736                 New(73, PL_psig_ptr, sizeof(sig_num)/sizeof(*sig_num), SV*);
 737                 New(73, PL_psig_name, sizeof(sig_num)/sizeof(*sig_num), SV*);
 738             }
 739             GvMULTI_on(gv);
 740             hv = GvHVn(gv);
 741             hv_magic(hv, gv, 'S');
 742             for (i = 1; PL_sig_name[i]; i++) {
 743                 SV ** init;
 744                 init = hv_fetch(hv, PL_sig_name[i], strlen(PL_sig_name[i]), 1);
 745                 if (init)
 746                     sv_setsv(*init, &PL_sv_undef);
 747                 PL_psig_ptr[i] = 0;
 748                 PL_psig_name[i] = 0;
 749             }
 750         }
 751         break;
 752     case 'V':
 753         if (strEQ(name, "VERSION"))
 754             GvMULTI_on(gv);
 755         break;
 756
 757     case '&':
 758         if (len > 1)
 759             break;
 760         PL_sawampersand = TRUE;
 761         goto ro_magicalize;
 762
 763     case '`':
 764         if (len > 1)
 765             break;
 766         PL_sawampersand = TRUE;
 767         goto ro_magicalize;
 768
 769     case '\'':
 770         if (len > 1)
 771             break;
 772         PL_sawampersand = TRUE;
 773         goto ro_magicalize;
 774
 775     case ':':
 776         if (len > 1)
 777             break;
 778         sv_setpv(GvSV(gv),PL_chopset);
 779         goto magicalize;
 780
 781     case '?':
 782         if (len > 1)
 783             break;
 784 #ifdef COMPLEX_STATUS
 785         (void)SvUPGRADE(GvSV(gv), SVt_PVLV);
 786 #endif
 787         goto magicalize;
 788
 789     case '!':
 790         if (len > 1)
 791             break;
 792         if (sv_type > SVt_PV && PL_curcop != &PL_compiling) {
 793             HV* stash = gv_stashpvn("Errno",5,FALSE);
 794             if (!stash || !(gv_fetchmethod(stash, "TIEHASH"))) {
 795                 dSP;
 796                 PUTBACK;
 797                 require_pv("Errno.pm");
 798                 SPAGAIN;
 799                 stash = gv_stashpvn("Errno",5,FALSE);
 800                 if (!stash || !(gv_fetchmethod(stash, "TIEHASH")))
 801                     Perl_croak(aTHX_ "Can't use %%! because Errno.pm is not available");
 802             }
 803         }
 804         goto magicalize;
 805     case '-':
 806         if (len > 1)
 807             break;
 808         else {
 809             AV* av = GvAVn(gv);
 810             sv_magic((SV*)av, Nullsv, 'D', Nullch, 0);
 811         }
 812         goto magicalize;
 813     case '#':
 814     case '*':
 815         if (ckWARN(WARN_DEPRECATED) && len == 1 && sv_type == SVt_PV)
 816             Perl_warner(aTHX_ WARN_DEPRECATED, "Use of $%s is deprecated", name);
 817         /* FALL THROUGH */
 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 '/':
 831     case '|':
 832     case '\001':
 833     case '\003':
 834     case '\004':
 835     case '\005':
 836     case '\006':
 837     case '\010':
 838     case '\011':        /* NOT \t in EBCDIC */
 839     case '\017':
 840     case '\020':
 841     case '\024':
 842         if (len > 1)
 843             break;
 844         goto magicalize;
 845     case '\023':
 846         if (len > 1)
 847             break;
 848         goto ro_magicalize;
 849     case '\027':        /* $^W & $^Warnings */
 850         if (len > 1 && strNE(name, "\027arnings"))
 851             break;
 852         goto magicalize;
 853
 854     case '+':
 855         if (len > 1)
 856             break;
 857         else {
 858             AV* av = GvAVn(gv);
 859             sv_magic((SV*)av, (SV*)av, 'D', Nullch, 0);
 860         }
 861         /* FALL THROUGH */
 862     case '1':
 863     case '2':
 864     case '3':
 865     case '4':
 866     case '5':
 867     case '6':
 868     case '7':
 869     case '8':
 870     case '9':
 871       ro_magicalize:
 872         SvREADONLY_on(GvSV(gv));
 873       magicalize:
 874         sv_magic(GvSV(gv), (SV*)gv, 0, name, len);
 875         break;
 876
 877     case '\014':
 878         if (len > 1)
 879             break;
 880         sv_setpv(GvSV(gv),"\f");
 881         PL_formfeed = GvSV(gv);
 882         break;
 883     case ';':
 884         if (len > 1)
 885             break;
 886         sv_setpv(GvSV(gv),"\034");
 887         break;
 888     case ']':
 889         if (len == 1) {
 890             SV *sv = GvSV(gv);
 891             (void)SvUPGRADE(sv, SVt_PVNV);
 892             SvNVX(sv) = SvNVX(PL_patchlevel);
 893             SvNOK_on(sv);
 894             (void)SvPV_nolen(sv);
 895             SvREADONLY_on(sv);
 896         }
 897         break;
 898     }
 899     return gv;
 900 }
 901
 902 void
 903 Perl_gv_fullname3(pTHX_ SV *sv, GV *gv, const char *prefix)
 904 {
 905     HV *hv = GvSTASH(gv);
 906     if (!hv) {
 907         SvOK_off(sv);
 908         return;
 909     }
 910     sv_setpv(sv, prefix ? prefix : "");
 911     sv_catpv(sv,HvNAME(hv));
 912     sv_catpvn(sv,"::", 2);
 913     sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv));
 914 }
 915
 916 void
 917 Perl_gv_efullname3(pTHX_ SV *sv, GV *gv, const char *prefix)
 918 {
 919     GV *egv = GvEGV(gv);
 920     if (!egv)
 921         egv = gv;
 922     gv_fullname3(sv, egv, prefix);
 923 }
 924
 925 /* XXX compatibility with versions <= 5.003. */
 926 void
 927 Perl_gv_fullname(pTHX_ SV *sv, GV *gv)
 928 {
 929     gv_fullname3(sv, gv, sv == (SV*)gv ? "*" : "");
 930 }
 931
 932 /* XXX compatibility with versions <= 5.003. */
 933 void
 934 Perl_gv_efullname(pTHX_ SV *sv, GV *gv)
 935 {
 936     gv_efullname3(sv, gv, sv == (SV*)gv ? "*" : "");
 937 }
 938
 939 IO *
 940 Perl_newIO(pTHX)
 941 {
 942     dTHR;
 943     IO *io;
 944     GV *iogv;
 945
 946     io = (IO*)NEWSV(0,0);
 947     sv_upgrade((SV *)io,SVt_PVIO);
 948     SvREFCNT(io) = 1;
 949     SvOBJECT_on(io);
 950     iogv = gv_fetchpv("FileHandle::", FALSE, SVt_PVHV);
 951     /* unless exists($main::{FileHandle}) and defined(%main::FileHandle::) */
 952     if (!(iogv && GvHV(iogv) && HvARRAY(GvHV(iogv))))
 953       iogv = gv_fetchpv("IO::Handle::", TRUE, SVt_PVHV);
 954     SvSTASH(io) = (HV*)SvREFCNT_inc(GvHV(iogv));
 955     return io;
 956 }
 957
 958 void
 959 Perl_gv_check(pTHX_ HV *stash)
 960 {
 961     dTHR;
 962     register HE *entry;
 963     register I32 i;
 964     register GV *gv;
 965     HV *hv;
 966
 967     if (!HvARRAY(stash))
 968         return;
 969     for (i = 0; i <= (I32) HvMAX(stash); i++) {
 970         for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
 971             if (HeKEY(entry)[HeKLEN(entry)-1] == ':' &&
 972                 (gv = (GV*)HeVAL(entry)) && (hv = GvHV(gv)) && HvNAME(hv))
 973             {
 974                 if (hv != PL_defstash && hv != stash)
 975                      gv_check(hv);              /* nested package */
 976             }
 977             else if (isALPHA(*HeKEY(entry))) {
 978                 char *file;
 979                 gv = (GV*)HeVAL(entry);
 980                 if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv))
 981                     continue;
 982                 file = GvFILE(gv);
 983                 /* performance hack: if filename is absolute and it's a standard
 984                  * module, don't bother warning */
 985                 if (file
 986                     && PERL_FILE_IS_ABSOLUTE(file)
 987                     && (instr(file, "/lib/") || instr(file, ".pm")))
 988                 {
 989                     continue;
 990                 }
 991                 CopLINE_set(PL_curcop, GvLINE(gv));
 992 #ifdef USE_ITHREADS
 993                 CopFILE(PL_curcop) = file;      /* set for warning */
 994 #else
 995                 CopFILEGV(PL_curcop) = gv_fetchfile(file);
 996 #endif
 997                 Perl_warner(aTHX_ WARN_ONCE,
 998                         "Name \"%s::%s\" used only once: possible typo",
 999                         HvNAME(stash), GvNAME(gv));
1000             }
1001         }
1002     }
1003 }
1004
1005 GV *
1006 Perl_newGVgen(pTHX_ char *pack)
1007 {
1008     return gv_fetchpv(Perl_form(aTHX_ "%s::_GEN_%ld", pack, (long)PL_gensym++),
1009                       TRUE, SVt_PVGV);
1010 }
1011
1012 /* hopefully this is only called on local symbol table entries */
1013
1014 GP*
1015 Perl_gp_ref(pTHX_ GP *gp)
1016 {
1017     if (!gp)
1018         return (GP*)NULL;
1019     gp->gp_refcnt++;
1020     if (gp->gp_cv) {
1021         if (gp->gp_cvgen) {
1022             /* multi-named GPs cannot be used for method cache */
1023             SvREFCNT_dec(gp->gp_cv);
1024             gp->gp_cv = Nullcv;
1025             gp->gp_cvgen = 0;
1026         }
1027         else {
1028             /* Adding a new name to a subroutine invalidates method cache */
1029             PL_sub_generation++;
1030         }
1031     }
1032     return gp;
1033 }
1034
1035 void
1036 Perl_gp_free(pTHX_ GV *gv)
1037 {
1038     dTHR;
1039     GP* gp;
1040     CV* cv;
1041
1042     if (!gv || !(gp = GvGP(gv)))
1043         return;
1044     if (gp->gp_refcnt == 0) {
1045         if (ckWARN_d(WARN_INTERNAL))
1046             Perl_warner(aTHX_ WARN_INTERNAL,
1047                         "Attempt to free unreferenced glob pointers");
1048         return;
1049     }
1050     if (gp->gp_cv) {
1051         /* Deleting the name of a subroutine invalidates method cache */
1052         PL_sub_generation++;
1053     }
1054     if (--gp->gp_refcnt > 0) {
1055         if (gp->gp_egv == gv)
1056             gp->gp_egv = 0;
1057         return;
1058     }
1059
1060     SvREFCNT_dec(gp->gp_sv);
1061     SvREFCNT_dec(gp->gp_av);
1062     SvREFCNT_dec(gp->gp_hv);
1063     SvREFCNT_dec(gp->gp_io);
1064     SvREFCNT_dec(gp->gp_cv);
1065     SvREFCNT_dec(gp->gp_form);
1066
1067     Safefree(gp);
1068     GvGP(gv) = 0;
1069 }
1070
1071 #if defined(CRIPPLED_CC) && (defined(iAPX286) || defined(M_I286) || defined(I80286))
1072 #define MICROPORT
1073 #endif
1074
1075 #ifdef  MICROPORT       /* Microport 2.4 hack */
1076 AV *GvAVn(gv)
1077 register GV *gv;
1078 {
1079     if (GvGP(gv)->gp_av)
1080         return GvGP(gv)->gp_av;
1081     else
1082         return GvGP(gv_AVadd(gv))->gp_av;
1083 }
1084
1085 HV *GvHVn(gv)
1086 register GV *gv;
1087 {
1088     if (GvGP(gv)->gp_hv)
1089         return GvGP(gv)->gp_hv;
1090     else
1091         return GvGP(gv_HVadd(gv))->gp_hv;
1092 }
1093 #endif                  /* Microport 2.4 hack */
1094
1095 /* Updates and caches the CV's */
1096
1097 bool
1098 Perl_Gv_AMupdate(pTHX_ HV *stash)
1099 {
1100   dTHR;
1101   GV** gvp;
1102   HV* hv;
1103   GV* gv;
1104   CV* cv;
1105   MAGIC* mg=mg_find((SV*)stash,'c');
1106   AMT *amtp = (mg) ? (AMT*)mg->mg_ptr: (AMT *) NULL;
1107   AMT amt;
1108   STRLEN n_a;
1109
1110   if (mg && amtp->was_ok_am == PL_amagic_generation
1111       && amtp->was_ok_sub == PL_sub_generation)
1112       return AMT_AMAGIC(amtp);
1113   if (amtp && AMT_AMAGIC(amtp)) {       /* Have table. */
1114     int i;
1115     for (i=1; i<NofAMmeth; i++) {
1116       if (amtp->table[i]) {
1117         SvREFCNT_dec(amtp->table[i]);
1118       }
1119     }
1120   }
1121   sv_unmagic((SV*)stash, 'c');
1122
1123   DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME(stash)) );
1124
1125   amt.was_ok_am = PL_amagic_generation;
1126   amt.was_ok_sub = PL_sub_generation;
1127   amt.fallback = AMGfallNO;
1128   amt.flags = 0;
1129
1130 #ifdef OVERLOAD_VIA_HASH
1131   gvp=(GV**)hv_fetch(stash,"OVERLOAD",8,FALSE); /* A shortcut */
1132   if (gvp && ((gv = *gvp) != (GV*)&PL_sv_undef && (hv = GvHV(gv)))) {
1133     int filled=0;
1134     int i;
1135     char *cp;
1136     SV* sv;
1137     SV** svp;
1138
1139     /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
1140
1141     if (( cp = (char *)PL_AMG_names[0] ) &&
1142         (svp = (SV**)hv_fetch(hv,cp,strlen(cp),FALSE)) && (sv = *svp)) {
1143       if (SvTRUE(sv)) amt.fallback=AMGfallYES;
1144       else if (SvOK(sv)) amt.fallback=AMGfallNEVER;
1145     }
1146     for (i = 1; i < NofAMmeth; i++) {
1147       cv = 0;
1148       cp = (char *)PL_AMG_names[i];
1149
1150         svp = (SV**)hv_fetch(hv, cp, strlen(cp), FALSE);
1151         if (svp && ((sv = *svp) != &PL_sv_undef)) {
1152           switch (SvTYPE(sv)) {
1153             default:
1154               if (!SvROK(sv)) {
1155                 if (!SvOK(sv)) break;
1156                 gv = gv_fetchmethod(stash, SvPV(sv, n_a));
1157                 if (gv) cv = GvCV(gv);
1158                 break;
1159               }
1160               cv = (CV*)SvRV(sv);
1161               if (SvTYPE(cv) == SVt_PVCV)
1162                   break;
1163                 /* FALL THROUGH */
1164             case SVt_PVHV:
1165             case SVt_PVAV:
1166               Perl_croak(aTHX_ "Not a subroutine reference in overload table");
1167               return FALSE;
1168             case SVt_PVCV:
1169               cv = (CV*)sv;
1170               break;
1171             case SVt_PVGV:
1172               if (!(cv = GvCVu((GV*)sv)))
1173                 cv = sv_2cv(sv, &stash, &gv, FALSE);
1174               break;
1175           }
1176           if (cv) filled=1;
1177           else {
1178             Perl_croak(aTHX_ "Method for operation %s not found in package %.256s during blessing\n",
1179                 cp,HvNAME(stash));
1180             return FALSE;
1181           }
1182         }
1183 #else
1184   {
1185     int filled = 0;
1186     int i;
1187     const char *cp;
1188     SV* sv = NULL;
1189     SV** svp;
1190
1191     /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
1192
1193     if ( cp = PL_AMG_names[0] ) {
1194         /* Try to find via inheritance. */
1195         gv = gv_fetchmeth(stash, "()", 2, -1); /* A cookie: "()". */
1196         if (gv) sv = GvSV(gv);
1197
1198         if (!gv) goto no_table;
1199         else if (SvTRUE(sv)) amt.fallback=AMGfallYES;
1200         else if (SvOK(sv)) amt.fallback=AMGfallNEVER;
1201     }
1202
1203     for (i = 1; i < NofAMmeth; i++) {
1204         SV *cookie = sv_2mortal(Perl_newSVpvf(aTHX_ "(%s", cp = PL_AMG_names[i]));
1205         DEBUG_o( Perl_deb(aTHX_ "Checking overloading of `%s' in package `%.256s'\n",
1206                      cp, HvNAME(stash)) );
1207         /* don't fill the cache while looking up! */
1208         gv = gv_fetchmeth(stash, SvPVX(cookie), SvCUR(cookie), -1);
1209         cv = 0;
1210         if(gv && (cv = GvCV(gv))) {
1211             if (GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")
1212                 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "overload")) {
1213                 /* GvSV contains the name of the method. */
1214                 GV *ngv;
1215
1216                 DEBUG_o( Perl_deb(aTHX_ "Resolving method `%.256s' for overloaded `%s' in package `%.256s'\n",
1217                              SvPV(GvSV(gv), n_a), cp, HvNAME(stash)) );
1218                 if (!SvPOK(GvSV(gv))
1219                     || !(ngv = gv_fetchmethod_autoload(stash, SvPVX(GvSV(gv)),
1220                                                        FALSE)))
1221                 {
1222                     /* Can be an import stub (created by `can'). */
1223                     if (GvCVGEN(gv)) {
1224                         Perl_croak(aTHX_ "Stub found while resolving method `%.256s' overloading `%s' in package `%.256s'",
1225                               (SvPOK(GvSV(gv)) ?  SvPVX(GvSV(gv)) : "???" ),
1226                               cp, HvNAME(stash));
1227                     } else
1228                         Perl_croak(aTHX_ "Can't resolve method `%.256s' overloading `%s' in package `%.256s'",
1229                               (SvPOK(GvSV(gv)) ?  SvPVX(GvSV(gv)) : "???" ),
1230                               cp, HvNAME(stash));
1231                 }
1232                 cv = GvCV(gv = ngv);
1233             }
1234             DEBUG_o( Perl_deb(aTHX_ "Overloading `%s' in package `%.256s' via `%.256s::%.256s' \n",
1235                          cp, HvNAME(stash), HvNAME(GvSTASH(CvGV(cv))),
1236                          GvNAME(CvGV(cv))) );
1237             filled = 1;
1238         }
1239 #endif
1240         amt.table[i]=(CV*)SvREFCNT_inc(cv);
1241     }
1242     if (filled) {
1243       AMT_AMAGIC_on(&amt);
1244       sv_magic((SV*)stash, 0, 'c', (char*)&amt, sizeof(AMT));
1245       return TRUE;
1246     }
1247   }
1248   /* Here we have no table: */
1249  no_table:
1250   AMT_AMAGIC_off(&amt);
1251   sv_magic((SV*)stash, 0, 'c', (char*)&amt, sizeof(AMTS));
1252   return FALSE;
1253 }
1254
1255 SV*
1256 Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
1257 {
1258   dTHR;
1259   MAGIC *mg;
1260   CV *cv;
1261   CV **cvp=NULL, **ocvp=NULL;
1262   AMT *amtp, *oamtp;
1263   int fl=0, off, off1, lr=0, assign=AMGf_assign & flags, notfound=0;
1264   int postpr = 0, force_cpy = 0, assignshift = assign ? 1 : 0;
1265   HV* stash;
1266   if (!(AMGf_noleft & flags) && SvAMAGIC(left)
1267       && (mg = mg_find((SV*)(stash=SvSTASH(SvRV(left))),'c'))
1268       && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
1269                         ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
1270                         : (CV **) NULL))
1271       && ((cv = cvp[off=method+assignshift])
1272           || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
1273                                                           * usual method */
1274                   (fl = 1, cv = cvp[off=method])))) {
1275     lr = -1;                    /* Call method for left argument */
1276   } else {
1277     if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) {
1278       int logic;
1279
1280       /* look for substituted methods */
1281       /* In all the covered cases we should be called with assign==0. */
1282          switch (method) {
1283          case inc_amg:
1284            force_cpy = 1;
1285            if ((cv = cvp[off=add_ass_amg])
1286                || ((cv = cvp[off = add_amg]) && (force_cpy = 0, postpr = 1))) {
1287              right = &PL_sv_yes; lr = -1; assign = 1;
1288            }
1289            break;
1290          case dec_amg:
1291            force_cpy = 1;
1292            if ((cv = cvp[off = subtr_ass_amg])
1293                || ((cv = cvp[off = subtr_amg]) && (force_cpy = 0, postpr=1))) {
1294              right = &PL_sv_yes; lr = -1; assign = 1;
1295            }
1296            break;
1297          case bool__amg:
1298            (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg]));
1299            break;
1300          case numer_amg:
1301            (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg]));
1302            break;
1303          case string_amg:
1304            (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg]));
1305            break;
1306  case not_amg:
1307    (void)((cv = cvp[off=bool__amg])
1308           || (cv = cvp[off=numer_amg])
1309           || (cv = cvp[off=string_amg]));
1310    postpr = 1;
1311    break;
1312          case copy_amg:
1313            {
1314              /*
1315                   * SV* ref causes confusion with the interpreter variable of
1316                   * the same name
1317                   */
1318              SV* tmpRef=SvRV(left);
1319              if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) {
1320                 /*
1321                  * Just to be extra cautious.  Maybe in some
1322                  * additional cases sv_setsv is safe, too.
1323                  */
1324                 SV* newref = newSVsv(tmpRef);
1325                 SvOBJECT_on(newref);
1326                 SvSTASH(newref) = (HV*)SvREFCNT_inc(SvSTASH(tmpRef));
1327                 return newref;
1328              }
1329            }
1330            break;
1331          case abs_amg:
1332            if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg])
1333                && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) {
1334              SV* nullsv=sv_2mortal(newSViv(0));
1335              if (off1==lt_amg) {
1336                SV* lessp = amagic_call(left,nullsv,
1337                                        lt_amg,AMGf_noright);
1338                logic = SvTRUE(lessp);
1339              } else {
1340                SV* lessp = amagic_call(left,nullsv,
1341                                        ncmp_amg,AMGf_noright);
1342                logic = (SvNV(lessp) < 0);
1343              }
1344              if (logic) {
1345                if (off==subtr_amg) {
1346                  right = left;
1347                  left = nullsv;
1348                  lr = 1;
1349                }
1350              } else {
1351                return left;
1352              }
1353            }
1354            break;
1355          case neg_amg:
1356            if (cv = cvp[off=subtr_amg]) {
1357              right = left;
1358              left = sv_2mortal(newSViv(0));
1359              lr = 1;
1360            }
1361            break;
1362          case iter_amg:                 /* XXXX Eventually should do to_gv. */
1363          case to_sv_amg:
1364          case to_av_amg:
1365          case to_hv_amg:
1366          case to_gv_amg:
1367          case to_cv_amg:
1368              /* FAIL safe */
1369              return NULL;       /* Delegate operation to standard mechanisms. */
1370              break;
1371          default:
1372            goto not_found;
1373          }
1374          if (!cv) goto not_found;
1375     } else if (!(AMGf_noright & flags) && SvAMAGIC(right)
1376                && (mg = mg_find((SV*)(stash=SvSTASH(SvRV(right))),'c'))
1377                && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
1378                           ? (amtp = (AMT*)mg->mg_ptr)->table
1379                           : (CV **) NULL))
1380                && (cv = cvp[off=method])) { /* Method for right
1381                                              * argument found */
1382       lr=1;
1383     } else if (((ocvp && oamtp->fallback > AMGfallNEVER
1384                  && (cvp=ocvp) && (lr = -1))
1385                 || (cvp && amtp->fallback > AMGfallNEVER && (lr=1)))
1386                && !(flags & AMGf_unary)) {
1387                                 /* We look for substitution for
1388                                  * comparison operations and
1389                                  * concatenation */
1390       if (method==concat_amg || method==concat_ass_amg
1391           || method==repeat_amg || method==repeat_ass_amg) {
1392         return NULL;            /* Delegate operation to string conversion */
1393       }
1394       off = -1;
1395       switch (method) {
1396          case lt_amg:
1397          case le_amg:
1398          case gt_amg:
1399          case ge_amg:
1400          case eq_amg:
1401          case ne_amg:
1402            postpr = 1; off=ncmp_amg; break;
1403          case slt_amg:
1404          case sle_amg:
1405          case sgt_amg:
1406          case sge_amg:
1407          case seq_amg:
1408          case sne_amg:
1409            postpr = 1; off=scmp_amg; break;
1410          }
1411       if (off != -1) cv = cvp[off];
1412       if (!cv) {
1413         goto not_found;
1414       }
1415     } else {
1416     not_found:                  /* No method found, either report or croak */
1417       if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */
1418         notfound = 1; lr = -1;
1419       } else if (cvp && (cv=cvp[nomethod_amg])) {
1420         notfound = 1; lr = 1;
1421       } else {
1422         SV *msg;
1423         if (off==-1) off=method;
1424         msg = sv_2mortal(Perl_newSVpvf(aTHX_
1425                       "Operation `%s': no method found,%sargument %s%s%s%s",
1426                       PL_AMG_names[method + assignshift],
1427                       (flags & AMGf_unary ? " " : "\n\tleft "),
1428                       SvAMAGIC(left)?
1429                         "in overloaded package ":
1430                         "has no overloaded magic",
1431                       SvAMAGIC(left)?
1432                         HvNAME(SvSTASH(SvRV(left))):
1433                         "",
1434                       SvAMAGIC(right)?
1435                         ",\n\tright argument in overloaded package ":
1436                         (flags & AMGf_unary
1437                          ? ""
1438                          : ",\n\tright argument has no overloaded magic"),
1439                       SvAMAGIC(right)?
1440                         HvNAME(SvSTASH(SvRV(right))):
1441                         ""));
1442         if (amtp && amtp->fallback >= AMGfallYES) {
1443           DEBUG_o( Perl_deb(aTHX_ "%s", SvPVX(msg)) );
1444         } else {
1445           Perl_croak(aTHX_ "%"SVf, msg);
1446         }
1447         return NULL;
1448       }
1449       force_cpy = force_cpy || assign;
1450     }
1451   }
1452   if (!notfound) {
1453     DEBUG_o( Perl_deb(aTHX_
1454   "Overloaded operator `%s'%s%s%s:\n\tmethod%s found%s in package %s%s\n",
1455                  PL_AMG_names[off],
1456                  method+assignshift==off? "" :
1457                              " (initially `",
1458                  method+assignshift==off? "" :
1459                              PL_AMG_names[method+assignshift],
1460                  method+assignshift==off? "" : "')",
1461                  flags & AMGf_unary? "" :
1462                    lr==1 ? " for right argument": " for left argument",
1463                  flags & AMGf_unary? " for argument" : "",
1464                  HvNAME(stash),
1465                  fl? ",\n\tassignment variant used": "") );
1466   }
1467     /* Since we use shallow copy during assignment, we need
1468      * to dublicate the contents, probably calling user-supplied
1469      * version of copy operator
1470      */
1471     /* We need to copy in following cases:
1472      * a) Assignment form was called.
1473      *          assignshift==1,  assign==T, method + 1 == off
1474      * b) Increment or decrement, called directly.
1475      *          assignshift==0,  assign==0, method + 0 == off
1476      * c) Increment or decrement, translated to assignment add/subtr.
1477      *          assignshift==0,  assign==T,
1478      *          force_cpy == T
1479      * d) Increment or decrement, translated to nomethod.
1480      *          assignshift==0,  assign==0,
1481      *          force_cpy == T
1482      * e) Assignment form translated to nomethod.
1483      *          assignshift==1,  assign==T, method + 1 != off
1484      *          force_cpy == T
1485      */
1486     /*  off is method, method+assignshift, or a result of opcode substitution.
1487      *  In the latter case assignshift==0, so only notfound case is important.
1488      */
1489   if (( (method + assignshift == off)
1490         && (assign || (method == inc_amg) || (method == dec_amg)))
1491       || force_cpy)
1492     RvDEEPCP(left);
1493   {
1494     dSP;
1495     BINOP myop;
1496     SV* res;
1497     bool oldcatch = CATCH_GET;
1498
1499     CATCH_SET(TRUE);
1500     Zero(&myop, 1, BINOP);
1501     myop.op_last = (OP *) &myop;
1502     myop.op_next = Nullop;
1503     myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
1504
1505     PUSHSTACKi(PERLSI_OVERLOAD);
1506     ENTER;
1507     SAVEOP();
1508     PL_op = (OP *) &myop;
1509     if (PERLDB_SUB && PL_curstash != PL_debstash)
1510         PL_op->op_private |= OPpENTERSUB_DB;
1511     PUTBACK;
1512     pp_pushmark();
1513
1514     EXTEND(SP, notfound + 5);
1515     PUSHs(lr>0? right: left);
1516     PUSHs(lr>0? left: right);
1517     PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no ));
1518     if (notfound) {
1519       PUSHs( sv_2mortal(newSVpv((char *)PL_AMG_names[method + assignshift],0)));
1520     }
1521     PUSHs((SV*)cv);
1522     PUTBACK;
1523
1524     if (PL_op = Perl_pp_entersub(aTHX))
1525       CALLRUNOPS(aTHX);
1526     LEAVE;
1527     SPAGAIN;
1528
1529     res=POPs;
1530     PUTBACK;
1531     POPSTACK;
1532     CATCH_SET(oldcatch);
1533
1534     if (postpr) {
1535       int ans;
1536       switch (method) {
1537       case le_amg:
1538       case sle_amg:
1539         ans=SvIV(res)<=0; break;
1540       case lt_amg:
1541       case slt_amg:
1542         ans=SvIV(res)<0; break;
1543       case ge_amg:
1544       case sge_amg:
1545         ans=SvIV(res)>=0; break;
1546       case gt_amg:
1547       case sgt_amg:
1548         ans=SvIV(res)>0; break;
1549       case eq_amg:
1550       case seq_amg:
1551         ans=SvIV(res)==0; break;
1552       case ne_amg:
1553       case sne_amg:
1554         ans=SvIV(res)!=0; break;
1555       case inc_amg:
1556       case dec_amg:
1557         SvSetSV(left,res); return left;
1558       case not_amg:
1559         ans=!SvTRUE(res); break;
1560       }
1561       return boolSV(ans);
1562     } else if (method==copy_amg) {
1563       if (!SvROK(res)) {
1564         Perl_croak(aTHX_ "Copy method did not return a reference");
1565       }
1566       return SvREFCNT_inc(SvRV(res));
1567     } else {
1568       return res;
1569     }
1570   }
1571 }