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