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':        /* $^A */
 833     case '\003':        /* $^C */
 834     case '\004':        /* $^D */
 835     case '\005':        /* $^E */
 836     case '\006':        /* $^F */
 837     case '\010':        /* $^H */
 838     case '\011':        /* $^I, NOT \t in EBCDIC */
 839     case '\017':        /* $^O */
 840     case '\020':        /* $^P */
 841     case '\024':        /* $^T */
 842         if (len > 1)
 843             break;
 844         goto magicalize;
 845     case '\023':        /* $^S */
 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':        /* $^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         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     CV* cv;
1048
1049     if (!gv || !(gp = GvGP(gv)))
1050         return;
1051     if (gp->gp_refcnt == 0) {
1052         if (ckWARN_d(WARN_INTERNAL))
1053             Perl_warner(aTHX_ WARN_INTERNAL,
1054                         "Attempt to free unreferenced glob pointers");
1055         return;
1056     }
1057     if (gp->gp_cv) {
1058         /* Deleting the name of a subroutine invalidates method cache */
1059         PL_sub_generation++;
1060     }
1061     if (--gp->gp_refcnt > 0) {
1062         if (gp->gp_egv == gv)
1063             gp->gp_egv = 0;
1064         return;
1065     }
1066
1067     SvREFCNT_dec(gp->gp_sv);
1068     SvREFCNT_dec(gp->gp_av);
1069     SvREFCNT_dec(gp->gp_hv);
1070     SvREFCNT_dec(gp->gp_io);
1071     SvREFCNT_dec(gp->gp_cv);
1072     SvREFCNT_dec(gp->gp_form);
1073
1074     Safefree(gp);
1075     GvGP(gv) = 0;
1076 }
1077
1078 #if defined(CRIPPLED_CC) && (defined(iAPX286) || defined(M_I286) || defined(I80286))
1079 #define MICROPORT
1080 #endif
1081
1082 #ifdef  MICROPORT       /* Microport 2.4 hack */
1083 AV *GvAVn(gv)
1084 register GV *gv;
1085 {
1086     if (GvGP(gv)->gp_av)
1087         return GvGP(gv)->gp_av;
1088     else
1089         return GvGP(gv_AVadd(gv))->gp_av;
1090 }
1091
1092 HV *GvHVn(gv)
1093 register GV *gv;
1094 {
1095     if (GvGP(gv)->gp_hv)
1096         return GvGP(gv)->gp_hv;
1097     else
1098         return GvGP(gv_HVadd(gv))->gp_hv;
1099 }
1100 #endif                  /* Microport 2.4 hack */
1101
1102 /* Updates and caches the CV's */
1103
1104 bool
1105 Perl_Gv_AMupdate(pTHX_ HV *stash)
1106 {
1107   dTHR;
1108   GV** gvp;
1109   HV* hv;
1110   GV* gv;
1111   CV* cv;
1112   MAGIC* mg=mg_find((SV*)stash,'c');
1113   AMT *amtp = (mg) ? (AMT*)mg->mg_ptr: (AMT *) NULL;
1114   AMT amt;
1115   STRLEN n_a;
1116
1117   if (mg && amtp->was_ok_am == PL_amagic_generation
1118       && amtp->was_ok_sub == PL_sub_generation)
1119       return AMT_AMAGIC(amtp);
1120   if (amtp && AMT_AMAGIC(amtp)) {       /* Have table. */
1121     int i;
1122     for (i=1; i<NofAMmeth; i++) {
1123       if (amtp->table[i]) {
1124         SvREFCNT_dec(amtp->table[i]);
1125       }
1126     }
1127   }
1128   sv_unmagic((SV*)stash, 'c');
1129
1130   DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME(stash)) );
1131
1132   amt.was_ok_am = PL_amagic_generation;
1133   amt.was_ok_sub = PL_sub_generation;
1134   amt.fallback = AMGfallNO;
1135   amt.flags = 0;
1136
1137 #ifdef OVERLOAD_VIA_HASH
1138   gvp=(GV**)hv_fetch(stash,"OVERLOAD",8,FALSE); /* A shortcut */
1139   if (gvp && ((gv = *gvp) != (GV*)&PL_sv_undef && (hv = GvHV(gv)))) {
1140     int filled=0;
1141     int i;
1142     char *cp;
1143     SV* sv;
1144     SV** svp;
1145
1146     /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
1147
1148     if (( cp = (char *)PL_AMG_names[0] ) &&
1149         (svp = (SV**)hv_fetch(hv,cp,strlen(cp),FALSE)) && (sv = *svp)) {
1150       if (SvTRUE(sv)) amt.fallback=AMGfallYES;
1151       else if (SvOK(sv)) amt.fallback=AMGfallNEVER;
1152     }
1153     for (i = 1; i < NofAMmeth; i++) {
1154       cv = 0;
1155       cp = (char *)PL_AMG_names[i];
1156
1157         svp = (SV**)hv_fetch(hv, cp, strlen(cp), FALSE);
1158         if (svp && ((sv = *svp) != &PL_sv_undef)) {
1159           switch (SvTYPE(sv)) {
1160             default:
1161               if (!SvROK(sv)) {
1162                 if (!SvOK(sv)) break;
1163                 gv = gv_fetchmethod(stash, SvPV(sv, n_a));
1164                 if (gv) cv = GvCV(gv);
1165                 break;
1166               }
1167               cv = (CV*)SvRV(sv);
1168               if (SvTYPE(cv) == SVt_PVCV)
1169                   break;
1170                 /* FALL THROUGH */
1171             case SVt_PVHV:
1172             case SVt_PVAV:
1173               Perl_croak(aTHX_ "Not a subroutine reference in overload table");
1174               return FALSE;
1175             case SVt_PVCV:
1176               cv = (CV*)sv;
1177               break;
1178             case SVt_PVGV:
1179               if (!(cv = GvCVu((GV*)sv)))
1180                 cv = sv_2cv(sv, &stash, &gv, FALSE);
1181               break;
1182           }
1183           if (cv) filled=1;
1184           else {
1185             Perl_croak(aTHX_ "Method for operation %s not found in package %.256s during blessing\n",
1186                 cp,HvNAME(stash));
1187             return FALSE;
1188           }
1189         }
1190 #else
1191   {
1192     int filled = 0;
1193     int i;
1194     const char *cp;
1195     SV* sv = NULL;
1196     SV** svp;
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) sv = GvSV(gv);
1204
1205         if (!gv) goto no_table;
1206         else if (SvTRUE(sv)) amt.fallback=AMGfallYES;
1207         else if (SvOK(sv)) amt.fallback=AMGfallNEVER;
1208     }
1209
1210     for (i = 1; i < NofAMmeth; i++) {
1211         SV *cookie = sv_2mortal(Perl_newSVpvf(aTHX_ "(%s", cp = PL_AMG_names[i]));
1212         DEBUG_o( Perl_deb(aTHX_ "Checking overloading of `%s' in package `%.256s'\n",
1213                      cp, HvNAME(stash)) );
1214         /* don't fill the cache while looking up! */
1215         gv = gv_fetchmeth(stash, SvPVX(cookie), SvCUR(cookie), -1);
1216         cv = 0;
1217         if(gv && (cv = GvCV(gv))) {
1218             if (GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")
1219                 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "overload")) {
1220                 /* GvSV contains the name of the method. */
1221                 GV *ngv;
1222
1223                 DEBUG_o( Perl_deb(aTHX_ "Resolving method `%.256s' for overloaded `%s' in package `%.256s'\n",
1224                              SvPV(GvSV(gv), n_a), cp, HvNAME(stash)) );
1225                 if (!SvPOK(GvSV(gv))
1226                     || !(ngv = gv_fetchmethod_autoload(stash, SvPVX(GvSV(gv)),
1227                                                        FALSE)))
1228                 {
1229                     /* Can be an import stub (created by `can'). */
1230                     if (GvCVGEN(gv)) {
1231                         Perl_croak(aTHX_ "Stub found while resolving method `%.256s' overloading `%s' in package `%.256s'",
1232                               (SvPOK(GvSV(gv)) ?  SvPVX(GvSV(gv)) : "???" ),
1233                               cp, HvNAME(stash));
1234                     } else
1235                         Perl_croak(aTHX_ "Can't resolve method `%.256s' overloading `%s' in package `%.256s'",
1236                               (SvPOK(GvSV(gv)) ?  SvPVX(GvSV(gv)) : "???" ),
1237                               cp, HvNAME(stash));
1238                 }
1239                 cv = GvCV(gv = ngv);
1240             }
1241             DEBUG_o( Perl_deb(aTHX_ "Overloading `%s' in package `%.256s' via `%.256s::%.256s' \n",
1242                          cp, HvNAME(stash), HvNAME(GvSTASH(CvGV(cv))),
1243                          GvNAME(CvGV(cv))) );
1244             filled = 1;
1245         }
1246 #endif
1247         amt.table[i]=(CV*)SvREFCNT_inc(cv);
1248     }
1249     if (filled) {
1250       AMT_AMAGIC_on(&amt);
1251       sv_magic((SV*)stash, 0, 'c', (char*)&amt, sizeof(AMT));
1252       return TRUE;
1253     }
1254   }
1255   /* Here we have no table: */
1256  no_table:
1257   AMT_AMAGIC_off(&amt);
1258   sv_magic((SV*)stash, 0, 'c', (char*)&amt, sizeof(AMTS));
1259   return FALSE;
1260 }
1261
1262 SV*
1263 Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
1264 {
1265   dTHR;
1266   MAGIC *mg;
1267   CV *cv;
1268   CV **cvp=NULL, **ocvp=NULL;
1269   AMT *amtp, *oamtp;
1270   int fl=0, off, off1, lr=0, assign=AMGf_assign & flags, notfound=0;
1271   int postpr = 0, force_cpy = 0, assignshift = assign ? 1 : 0;
1272   HV* stash;
1273   if (!(AMGf_noleft & flags) && SvAMAGIC(left)
1274       && (mg = mg_find((SV*)(stash=SvSTASH(SvRV(left))),'c'))
1275       && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
1276                         ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
1277                         : (CV **) NULL))
1278       && ((cv = cvp[off=method+assignshift])
1279           || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
1280                                                           * usual method */
1281                   (fl = 1, cv = cvp[off=method])))) {
1282     lr = -1;                    /* Call method for left argument */
1283   } else {
1284     if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) {
1285       int logic;
1286
1287       /* look for substituted methods */
1288       /* In all the covered cases we should be called with assign==0. */
1289          switch (method) {
1290          case inc_amg:
1291            force_cpy = 1;
1292            if ((cv = cvp[off=add_ass_amg])
1293                || ((cv = cvp[off = add_amg]) && (force_cpy = 0, postpr = 1))) {
1294              right = &PL_sv_yes; lr = -1; assign = 1;
1295            }
1296            break;
1297          case dec_amg:
1298            force_cpy = 1;
1299            if ((cv = cvp[off = subtr_ass_amg])
1300                || ((cv = cvp[off = subtr_amg]) && (force_cpy = 0, postpr=1))) {
1301              right = &PL_sv_yes; lr = -1; assign = 1;
1302            }
1303            break;
1304          case bool__amg:
1305            (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg]));
1306            break;
1307          case numer_amg:
1308            (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg]));
1309            break;
1310          case string_amg:
1311            (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg]));
1312            break;
1313  case not_amg:
1314    (void)((cv = cvp[off=bool__amg])
1315           || (cv = cvp[off=numer_amg])
1316           || (cv = cvp[off=string_amg]));
1317    postpr = 1;
1318    break;
1319          case copy_amg:
1320            {
1321              /*
1322                   * SV* ref causes confusion with the interpreter variable of
1323                   * the same name
1324                   */
1325              SV* tmpRef=SvRV(left);
1326              if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) {
1327                 /*
1328                  * Just to be extra cautious.  Maybe in some
1329                  * additional cases sv_setsv is safe, too.
1330                  */
1331                 SV* newref = newSVsv(tmpRef);
1332                 SvOBJECT_on(newref);
1333                 SvSTASH(newref) = (HV*)SvREFCNT_inc(SvSTASH(tmpRef));
1334                 return newref;
1335              }
1336            }
1337            break;
1338          case abs_amg:
1339            if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg])
1340                && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) {
1341              SV* nullsv=sv_2mortal(newSViv(0));
1342              if (off1==lt_amg) {
1343                SV* lessp = amagic_call(left,nullsv,
1344                                        lt_amg,AMGf_noright);
1345                logic = SvTRUE(lessp);
1346              } else {
1347                SV* lessp = amagic_call(left,nullsv,
1348                                        ncmp_amg,AMGf_noright);
1349                logic = (SvNV(lessp) < 0);
1350              }
1351              if (logic) {
1352                if (off==subtr_amg) {
1353                  right = left;
1354                  left = nullsv;
1355                  lr = 1;
1356                }
1357              } else {
1358                return left;
1359              }
1360            }
1361            break;
1362          case neg_amg:
1363            if (cv = cvp[off=subtr_amg]) {
1364              right = left;
1365              left = sv_2mortal(newSViv(0));
1366              lr = 1;
1367            }
1368            break;
1369          case iter_amg:                 /* XXXX Eventually should do to_gv. */
1370          case to_sv_amg:
1371          case to_av_amg:
1372          case to_hv_amg:
1373          case to_gv_amg:
1374          case to_cv_amg:
1375              /* FAIL safe */
1376              return NULL;       /* Delegate operation to standard mechanisms. */
1377              break;
1378          default:
1379            goto not_found;
1380          }
1381          if (!cv) goto not_found;
1382     } else if (!(AMGf_noright & flags) && SvAMAGIC(right)
1383                && (mg = mg_find((SV*)(stash=SvSTASH(SvRV(right))),'c'))
1384                && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
1385                           ? (amtp = (AMT*)mg->mg_ptr)->table
1386                           : (CV **) NULL))
1387                && (cv = cvp[off=method])) { /* Method for right
1388                                              * argument found */
1389       lr=1;
1390     } else if (((ocvp && oamtp->fallback > AMGfallNEVER
1391                  && (cvp=ocvp) && (lr = -1))
1392                 || (cvp && amtp->fallback > AMGfallNEVER && (lr=1)))
1393                && !(flags & AMGf_unary)) {
1394                                 /* We look for substitution for
1395                                  * comparison operations and
1396                                  * concatenation */
1397       if (method==concat_amg || method==concat_ass_amg
1398           || method==repeat_amg || method==repeat_ass_amg) {
1399         return NULL;            /* Delegate operation to string conversion */
1400       }
1401       off = -1;
1402       switch (method) {
1403          case lt_amg:
1404          case le_amg:
1405          case gt_amg:
1406          case ge_amg:
1407          case eq_amg:
1408          case ne_amg:
1409            postpr = 1; off=ncmp_amg; break;
1410          case slt_amg:
1411          case sle_amg:
1412          case sgt_amg:
1413          case sge_amg:
1414          case seq_amg:
1415          case sne_amg:
1416            postpr = 1; off=scmp_amg; break;
1417          }
1418       if (off != -1) cv = cvp[off];
1419       if (!cv) {
1420         goto not_found;
1421       }
1422     } else {
1423     not_found:                  /* No method found, either report or croak */
1424       if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */
1425         notfound = 1; lr = -1;
1426       } else if (cvp && (cv=cvp[nomethod_amg])) {
1427         notfound = 1; lr = 1;
1428       } else {
1429         SV *msg;
1430         if (off==-1) off=method;
1431         msg = sv_2mortal(Perl_newSVpvf(aTHX_
1432                       "Operation `%s': no method found,%sargument %s%s%s%s",
1433                       PL_AMG_names[method + assignshift],
1434                       (flags & AMGf_unary ? " " : "\n\tleft "),
1435                       SvAMAGIC(left)?
1436                         "in overloaded package ":
1437                         "has no overloaded magic",
1438                       SvAMAGIC(left)?
1439                         HvNAME(SvSTASH(SvRV(left))):
1440                         "",
1441                       SvAMAGIC(right)?
1442                         ",\n\tright argument in overloaded package ":
1443                         (flags & AMGf_unary
1444                          ? ""
1445                          : ",\n\tright argument has no overloaded magic"),
1446                       SvAMAGIC(right)?
1447                         HvNAME(SvSTASH(SvRV(right))):
1448                         ""));
1449         if (amtp && amtp->fallback >= AMGfallYES) {
1450           DEBUG_o( Perl_deb(aTHX_ "%s", SvPVX(msg)) );
1451         } else {
1452           Perl_croak(aTHX_ "%"SVf, msg);
1453         }
1454         return NULL;
1455       }
1456       force_cpy = force_cpy || assign;
1457     }
1458   }
1459   if (!notfound) {
1460     DEBUG_o( Perl_deb(aTHX_
1461   "Overloaded operator `%s'%s%s%s:\n\tmethod%s found%s in package %s%s\n",
1462                  PL_AMG_names[off],
1463                  method+assignshift==off? "" :
1464                              " (initially `",
1465                  method+assignshift==off? "" :
1466                              PL_AMG_names[method+assignshift],
1467                  method+assignshift==off? "" : "')",
1468                  flags & AMGf_unary? "" :
1469                    lr==1 ? " for right argument": " for left argument",
1470                  flags & AMGf_unary? " for argument" : "",
1471                  HvNAME(stash),
1472                  fl? ",\n\tassignment variant used": "") );
1473   }
1474     /* Since we use shallow copy during assignment, we need
1475      * to dublicate the contents, probably calling user-supplied
1476      * version of copy operator
1477      */
1478     /* We need to copy in following cases:
1479      * a) Assignment form was called.
1480      *          assignshift==1,  assign==T, method + 1 == off
1481      * b) Increment or decrement, called directly.
1482      *          assignshift==0,  assign==0, method + 0 == off
1483      * c) Increment or decrement, translated to assignment add/subtr.
1484      *          assignshift==0,  assign==T,
1485      *          force_cpy == T
1486      * d) Increment or decrement, translated to nomethod.
1487      *          assignshift==0,  assign==0,
1488      *          force_cpy == T
1489      * e) Assignment form translated to nomethod.
1490      *          assignshift==1,  assign==T, method + 1 != off
1491      *          force_cpy == T
1492      */
1493     /*  off is method, method+assignshift, or a result of opcode substitution.
1494      *  In the latter case assignshift==0, so only notfound case is important.
1495      */
1496   if (( (method + assignshift == off)
1497         && (assign || (method == inc_amg) || (method == dec_amg)))
1498       || force_cpy)
1499     RvDEEPCP(left);
1500   {
1501     dSP;
1502     BINOP myop;
1503     SV* res;
1504     bool oldcatch = CATCH_GET;
1505
1506     CATCH_SET(TRUE);
1507     Zero(&myop, 1, BINOP);
1508     myop.op_last = (OP *) &myop;
1509     myop.op_next = Nullop;
1510     myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
1511
1512     PUSHSTACKi(PERLSI_OVERLOAD);
1513     ENTER;
1514     SAVEOP();
1515     PL_op = (OP *) &myop;
1516     if (PERLDB_SUB && PL_curstash != PL_debstash)
1517         PL_op->op_private |= OPpENTERSUB_DB;
1518     PUTBACK;
1519     pp_pushmark();
1520
1521     EXTEND(SP, notfound + 5);
1522     PUSHs(lr>0? right: left);
1523     PUSHs(lr>0? left: right);
1524     PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no ));
1525     if (notfound) {
1526       PUSHs( sv_2mortal(newSVpv((char *)PL_AMG_names[method + assignshift],0)));
1527     }
1528     PUSHs((SV*)cv);
1529     PUTBACK;
1530
1531     if (PL_op = Perl_pp_entersub(aTHX))
1532       CALLRUNOPS(aTHX);
1533     LEAVE;
1534     SPAGAIN;
1535
1536     res=POPs;
1537     PUTBACK;
1538     POPSTACK;
1539     CATCH_SET(oldcatch);
1540
1541     if (postpr) {
1542       int ans;
1543       switch (method) {
1544       case le_amg:
1545       case sle_amg:
1546         ans=SvIV(res)<=0; break;
1547       case lt_amg:
1548       case slt_amg:
1549         ans=SvIV(res)<0; break;
1550       case ge_amg:
1551       case sge_amg:
1552         ans=SvIV(res)>=0; break;
1553       case gt_amg:
1554       case sgt_amg:
1555         ans=SvIV(res)>0; break;
1556       case eq_amg:
1557       case seq_amg:
1558         ans=SvIV(res)==0; break;
1559       case ne_amg:
1560       case sne_amg:
1561         ans=SvIV(res)!=0; break;
1562       case inc_amg:
1563       case dec_amg:
1564         SvSetSV(left,res); return left;
1565       case not_amg:
1566         ans=!SvTRUE(res); break;
1567       }
1568       return boolSV(ans);
1569     } else if (method==copy_amg) {
1570       if (!SvROK(res)) {
1571         Perl_croak(aTHX_ "Copy method did not return a reference");
1572       }
1573       return SvREFCNT_inc(SvRV(res));
1574     } else {
1575       return res;
1576     }
1577   }
1578 }