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