gv.c

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