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)), Nullgv, '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") || strEQ(name,"unimport"))
 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     if (!CvROOT(cv))
 422         return Nullgv;
 423
 424     /*
 425      * Inheriting AUTOLOAD for non-methods works ... for now.
 426      */
 427     if (ckWARN(WARN_DEPRECATED) && !method &&
 428         (GvCVGEN(gv) || GvSTASH(gv) != stash))
 429         Perl_warner(aTHX_ WARN_DEPRECATED,
 430           "Use of inherited AUTOLOAD for non-method %s::%.*s() is deprecated",
 431              HvNAME(stash), (int)len, name);
 432
 433     /*
 434      * Given &FOO::AUTOLOAD, set $FOO::AUTOLOAD to desired function name.
 435      * The subroutine's original name may not be "AUTOLOAD", so we don't
 436      * use that, but for lack of anything better we will use the sub's
 437      * original package to look up $AUTOLOAD.
 438      */
 439     varstash = GvSTASH(CvGV(cv));
 440     vargv = *(GV**)hv_fetch(varstash, autoload, autolen, TRUE);
 441     ENTER;
 442
 443 #ifdef USE_THREADS
 444     sv_lock((SV *)varstash);
 445 #endif
 446     if (!isGV(vargv))
 447         gv_init(vargv, varstash, autoload, autolen, FALSE);
 448     LEAVE;
 449     varsv = GvSV(vargv);
 450 #ifdef USE_THREADS
 451     sv_lock(varsv);
 452 #endif
 453     sv_setpv(varsv, HvNAME(stash));
 454     sv_catpvn(varsv, "::", 2);
 455     sv_catpvn(varsv, name, len);
 456     SvTAINTED_off(varsv);
 457     return gv;
 458 }
 459
 460 /*
 461 =for apidoc gv_stashpv
 462
 463 Returns a pointer to the stash for a specified package.  C<name> should
 464 be a valid UTF-8 string.  If C<create> is set then the package will be
 465 created if it does not already exist.  If C<create> is not set and the
 466 package does not exist then NULL is returned.
 467
 468 =cut
 469 */
 470
 471 HV*
 472 Perl_gv_stashpv(pTHX_ const char *name, I32 create)
 473 {
 474     return gv_stashpvn(name, strlen(name), create);
 475 }
 476
 477 HV*
 478 Perl_gv_stashpvn(pTHX_ const char *name, U32 namelen, I32 create)
 479 {
 480     char smallbuf[256];
 481     char *tmpbuf;
 482     HV *stash;
 483     GV *tmpgv;
 484
 485     if (namelen + 3 < sizeof smallbuf)
 486         tmpbuf = smallbuf;
 487     else
 488         New(606, tmpbuf, namelen + 3, char);
 489     Copy(name,tmpbuf,namelen,char);
 490     tmpbuf[namelen++] = ':';
 491     tmpbuf[namelen++] = ':';
 492     tmpbuf[namelen] = '\0';
 493     tmpgv = gv_fetchpv(tmpbuf, create, SVt_PVHV);
 494     if (tmpbuf != smallbuf)
 495         Safefree(tmpbuf);
 496     if (!tmpgv)
 497         return 0;
 498     if (!GvHV(tmpgv))
 499         GvHV(tmpgv) = newHV();
 500     stash = GvHV(tmpgv);
 501     if (!HvNAME(stash))
 502         HvNAME(stash) = savepv(name);
 503     return stash;
 504 }
 505
 506 /*
 507 =for apidoc gv_stashsv
 508
 509 Returns a pointer to the stash for a specified package, which must be a
 510 valid UTF-8 string.  See C<gv_stashpv>.
 511
 512 =cut
 513 */
 514
 515 HV*
 516 Perl_gv_stashsv(pTHX_ SV *sv, I32 create)
 517 {
 518     register char *ptr;
 519     STRLEN len;
 520     ptr = SvPV(sv,len);
 521     return gv_stashpvn(ptr, len, create);
 522 }
 523
 524
 525 GV *
 526 Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type)
 527 {
 528     dTHR;
 529     register const char *name = nambeg;
 530     register GV *gv = 0;
 531     GV**gvp;
 532     I32 len;
 533     register const char *namend;
 534     HV *stash = 0;
 535
 536     if (*name == '*' && isALPHA(name[1])) /* accidental stringify on a GV? */
 537         name++;
 538
 539     for (namend = name; *namend; namend++) {
 540         if ((*namend == ':' && namend[1] == ':')
 541             || (*namend == '\'' && namend[1]))
 542         {
 543             if (!stash)
 544                 stash = PL_defstash;
 545             if (!stash || !SvREFCNT(stash)) /* symbol table under destruction */
 546                 return Nullgv;
 547
 548             len = namend - name;
 549             if (len > 0) {
 550                 char smallbuf[256];
 551                 char *tmpbuf;
 552
 553                 if (len + 3 < sizeof smallbuf)
 554                     tmpbuf = smallbuf;
 555                 else
 556                     New(601, tmpbuf, len+3, char);
 557                 Copy(name, tmpbuf, len, char);
 558                 tmpbuf[len++] = ':';
 559                 tmpbuf[len++] = ':';
 560                 tmpbuf[len] = '\0';
 561                 gvp = (GV**)hv_fetch(stash,tmpbuf,len,add);
 562                 gv = gvp ? *gvp : Nullgv;
 563                 if (gv && gv != (GV*)&PL_sv_undef) {
 564                     if (SvTYPE(gv) != SVt_PVGV)
 565                         gv_init(gv, stash, tmpbuf, len, (add & GV_ADDMULTI));
 566                     else
 567                         GvMULTI_on(gv);
 568                 }
 569                 if (tmpbuf != smallbuf)
 570                     Safefree(tmpbuf);
 571                 if (!gv || gv == (GV*)&PL_sv_undef)
 572                     return Nullgv;
 573
 574                 if (!(stash = GvHV(gv)))
 575                     stash = GvHV(gv) = newHV();
 576
 577                 if (!HvNAME(stash))
 578                     HvNAME(stash) = savepvn(nambeg, namend - nambeg);
 579             }
 580
 581             if (*namend == ':')
 582                 namend++;
 583             namend++;
 584             name = namend;
 585             if (!*name)
 586                 return gv ? gv : (GV*)*hv_fetch(PL_defstash, "main::", 6, TRUE);
 587         }
 588     }
 589     len = namend - name;
 590     if (!len)
 591         len = 1;
 592
 593     /* No stash in name, so see how we can default */
 594
 595     if (!stash) {
 596         if (isIDFIRST_lazy(name)) {
 597             bool global = FALSE;
 598
 599             if (isUPPER(*name)) {
 600                 if (*name == 'S' && (
 601                     strEQ(name, "SIG") ||
 602                     strEQ(name, "STDIN") ||
 603                     strEQ(name, "STDOUT") ||
 604                     strEQ(name, "STDERR")))
 605                     global = TRUE;
 606                 else if (*name == 'I' && strEQ(name, "INC"))
 607                     global = TRUE;
 608                 else if (*name == 'E' && strEQ(name, "ENV"))
 609                     global = TRUE;
 610                 else if (*name == 'A' && (
 611                   strEQ(name, "ARGV") ||
 612                   strEQ(name, "ARGVOUT")))
 613                     global = TRUE;
 614             }
 615             else if (*name == '_' && !name[1])
 616                 global = TRUE;
 617
 618             if (global)
 619                 stash = PL_defstash;
 620             else if ((COP*)PL_curcop == &PL_compiling) {
 621                 stash = PL_curstash;
 622                 if (add && (PL_hints & HINT_STRICT_VARS) &&
 623                     sv_type != SVt_PVCV &&
 624                     sv_type != SVt_PVGV &&
 625                     sv_type != SVt_PVFM &&
 626                     sv_type != SVt_PVIO &&
 627                     !(len == 1 && sv_type == SVt_PV && strchr("ab",*name)) )
 628                 {
 629                     gvp = (GV**)hv_fetch(stash,name,len,0);
 630                     if (!gvp ||
 631                         *gvp == (GV*)&PL_sv_undef ||
 632                         SvTYPE(*gvp) != SVt_PVGV)
 633                     {
 634                         stash = 0;
 635                     }
 636                     else if ((sv_type == SVt_PV   && !GvIMPORTED_SV(*gvp)) ||
 637                              (sv_type == SVt_PVAV && !GvIMPORTED_AV(*gvp)) ||
 638                              (sv_type == SVt_PVHV && !GvIMPORTED_HV(*gvp)) )
 639                     {
 640                         Perl_warn(aTHX_ "Variable \"%c%s\" is not imported",
 641                             sv_type == SVt_PVAV ? '@' :
 642                             sv_type == SVt_PVHV ? '%' : '$',
 643                             name);
 644                         if (GvCVu(*gvp))
 645                             Perl_warn(aTHX_ "\t(Did you mean &%s instead?)\n", name);
 646                         stash = 0;
 647                     }
 648                 }
 649             }
 650             else
 651                 stash = CopSTASH(PL_curcop);
 652         }
 653         else
 654             stash = PL_defstash;
 655     }
 656
 657     /* By this point we should have a stash and a name */
 658
 659     if (!stash) {
 660         if (add) {
 661             qerror(Perl_mess(aTHX_
 662                  "Global symbol \"%s%s\" requires explicit package name",
 663                  (sv_type == SVt_PV ? "$"
 664                   : sv_type == SVt_PVAV ? "@"
 665                   : sv_type == SVt_PVHV ? "%"
 666                   : ""), name));
 667             stash = PL_nullstash;
 668         }
 669         else
 670             return Nullgv;
 671     }
 672
 673     if (!SvREFCNT(stash))       /* symbol table under destruction */
 674         return Nullgv;
 675
 676     gvp = (GV**)hv_fetch(stash,name,len,add);
 677     if (!gvp || *gvp == (GV*)&PL_sv_undef)
 678         return Nullgv;
 679     gv = *gvp;
 680     if (SvTYPE(gv) == SVt_PVGV) {
 681         if (add) {
 682             GvMULTI_on(gv);
 683             gv_init_sv(gv, sv_type);
 684         }
 685         return gv;
 686     } else if (add & GV_NOINIT) {
 687         return gv;
 688     }
 689
 690     /* Adding a new symbol */
 691
 692     if (add & GV_ADDWARN && ckWARN_d(WARN_INTERNAL))
 693         Perl_warner(aTHX_ WARN_INTERNAL, "Had to create %s unexpectedly", nambeg);
 694     gv_init(gv, stash, name, len, add & GV_ADDMULTI);
 695     gv_init_sv(gv, sv_type);
 696
 697     if (isLEXWARN_on && isALPHA(name[0]) && ! ckWARN(WARN_ONCE))
 698         GvMULTI_on(gv) ;
 699
 700     /* set up magic where warranted */
 701     switch (*name) {
 702     case 'A':
 703         if (strEQ(name, "ARGV")) {
 704             IoFLAGS(GvIOn(gv)) |= IOf_ARGV|IOf_START;
 705         }
 706         break;
 707     case 'E':
 708         if (strnEQ(name, "EXPORT", 6))
 709             GvMULTI_on(gv);
 710         break;
 711     case 'I':
 712         if (strEQ(name, "ISA")) {
 713             AV* av = GvAVn(gv);
 714             GvMULTI_on(gv);
 715             sv_magic((SV*)av, (SV*)gv, 'I', Nullch, 0);
 716             /* NOTE: No support for tied ISA */
 717             if ((add & GV_ADDMULTI) && strEQ(nambeg,"AnyDBM_File::ISA")
 718                 && AvFILLp(av) == -1)
 719             {
 720                 char *pname;
 721                 av_push(av, newSVpvn(pname = "NDBM_File",9));
 722                 gv_stashpvn(pname, 9, TRUE);
 723                 av_push(av, newSVpvn(pname = "DB_File",7));
 724                 gv_stashpvn(pname, 7, TRUE);
 725                 av_push(av, newSVpvn(pname = "GDBM_File",9));
 726                 gv_stashpvn(pname, 9, TRUE);
 727                 av_push(av, newSVpvn(pname = "SDBM_File",9));
 728                 gv_stashpvn(pname, 9, TRUE);
 729                 av_push(av, newSVpvn(pname = "ODBM_File",9));
 730                 gv_stashpvn(pname, 9, TRUE);
 731             }
 732         }
 733         break;
 734     case 'O':
 735         if (strEQ(name, "OVERLOAD")) {
 736             HV* hv = GvHVn(gv);
 737             GvMULTI_on(gv);
 738             hv_magic(hv, Nullgv, 'A');
 739         }
 740         break;
 741     case 'S':
 742         if (strEQ(name, "SIG")) {
 743             HV *hv;
 744             I32 i;
 745             if (!PL_psig_ptr) {
 746                 int sig_num[] = { SIG_NUM };
 747                 New(73, PL_psig_ptr, sizeof(sig_num)/sizeof(*sig_num), SV*);
 748                 New(73, PL_psig_name, sizeof(sig_num)/sizeof(*sig_num), SV*);
 749             }
 750             GvMULTI_on(gv);
 751             hv = GvHVn(gv);
 752             hv_magic(hv, Nullgv, 'S');
 753             for (i = 1; PL_sig_name[i]; i++) {
 754                 SV ** init;
 755                 init = hv_fetch(hv, PL_sig_name[i], strlen(PL_sig_name[i]), 1);
 756                 if (init)
 757                     sv_setsv(*init, &PL_sv_undef);
 758                 PL_psig_ptr[i] = 0;
 759                 PL_psig_name[i] = 0;
 760             }
 761         }
 762         break;
 763     case 'V':
 764         if (strEQ(name, "VERSION"))
 765             GvMULTI_on(gv);
 766         break;
 767
 768     case '&':
 769         if (len > 1)
 770             break;
 771         PL_sawampersand = TRUE;
 772         goto ro_magicalize;
 773
 774     case '`':
 775         if (len > 1)
 776             break;
 777         PL_sawampersand = TRUE;
 778         goto ro_magicalize;
 779
 780     case '\'':
 781         if (len > 1)
 782             break;
 783         PL_sawampersand = TRUE;
 784         goto ro_magicalize;
 785
 786     case ':':
 787         if (len > 1)
 788             break;
 789         sv_setpv(GvSV(gv),PL_chopset);
 790         goto magicalize;
 791
 792     case '?':
 793         if (len > 1)
 794             break;
 795 #ifdef COMPLEX_STATUS
 796         (void)SvUPGRADE(GvSV(gv), SVt_PVLV);
 797 #endif
 798         goto magicalize;
 799
 800     case '!':
 801         if (len > 1)
 802             break;
 803         if (sv_type > SVt_PV && PL_curcop != &PL_compiling) {
 804             HV* stash = gv_stashpvn("Errno",5,FALSE);
 805             if (!stash || !(gv_fetchmethod(stash, "TIEHASH"))) {
 806                 dSP;
 807                 PUTBACK;
 808                 require_pv("Errno.pm");
 809                 SPAGAIN;
 810                 stash = gv_stashpvn("Errno",5,FALSE);
 811                 if (!stash || !(gv_fetchmethod(stash, "TIEHASH")))
 812                     Perl_croak(aTHX_ "Can't use %%! because Errno.pm is not available");
 813             }
 814         }
 815         goto magicalize;
 816     case '-':
 817         if (len > 1)
 818             break;
 819         else {
 820             AV* av = GvAVn(gv);
 821             sv_magic((SV*)av, Nullsv, 'D', Nullch, 0);
 822             SvREADONLY_on(av);
 823         }
 824         goto magicalize;
 825     case '#':
 826     case '*':
 827         if (ckWARN(WARN_DEPRECATED) && len == 1 && sv_type == SVt_PV)
 828             Perl_warner(aTHX_ WARN_DEPRECATED, "Use of $%s is deprecated", name);
 829         /* FALL THROUGH */
 830     case '[':
 831     case '^':
 832     case '~':
 833     case '=':
 834     case '%':
 835     case '.':
 836     case '(':
 837     case ')':
 838     case '<':
 839     case '>':
 840     case ',':
 841     case '\\':
 842     case '/':
 843     case '\001':        /* $^A */
 844     case '\003':        /* $^C */
 845     case '\004':        /* $^D */
 846     case '\005':        /* $^E */
 847     case '\006':        /* $^F */
 848     case '\010':        /* $^H */
 849     case '\011':        /* $^I, NOT \t in EBCDIC */
 850     case '\020':        /* $^P */
 851     case '\024':        /* $^T */
 852         if (len > 1)
 853             break;
 854         goto magicalize;
 855     case '|':
 856         if (len > 1)
 857             break;
 858         sv_setiv(GvSV(gv), (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0);
 859         goto magicalize;
 860     case '\017':        /* $^O & $^OPEN */
 861         if (len > 1 && strNE(name, "\017PEN"))
 862             break;
 863         goto magicalize;
 864     case '\023':        /* $^S */
 865         if (len > 1)
 866             break;
 867         goto ro_magicalize;
 868     case '\027':        /* $^W & $^WARNING_BITS */
 869         if (len > 1 && strNE(name, "\027ARNING_BITS")
 870             && strNE(name, "\027IDE_SYSTEM_CALLS"))
 871             break;
 872         goto magicalize;
 873
 874     case '+':
 875         if (len > 1)
 876             break;
 877         else {
 878             AV* av = GvAVn(gv);
 879             sv_magic((SV*)av, (SV*)av, 'D', Nullch, 0);
 880             SvREADONLY_on(av);
 881         }
 882         /* FALL THROUGH */
 883     case '1':
 884     case '2':
 885     case '3':
 886     case '4':
 887     case '5':
 888     case '6':
 889     case '7':
 890     case '8':
 891     case '9':
 892       ro_magicalize:
 893         SvREADONLY_on(GvSV(gv));
 894       magicalize:
 895         sv_magic(GvSV(gv), (SV*)gv, 0, name, len);
 896         break;
 897
 898     case '\014':        /* $^L */
 899         if (len > 1)
 900             break;
 901         sv_setpv(GvSV(gv),"\f");
 902         PL_formfeed = GvSV(gv);
 903         break;
 904     case ';':
 905         if (len > 1)
 906             break;
 907         sv_setpv(GvSV(gv),"\034");
 908         break;
 909     case ']':
 910         if (len == 1) {
 911             SV *sv = GvSV(gv);
 912             (void)SvUPGRADE(sv, SVt_PVNV);
 913             Perl_sv_setpvf(aTHX_ sv,
 914 #if defined(PERL_SUBVERSION) && (PERL_SUBVERSION > 0)
 915                             "%8.6"
 916 #else
 917                             "%5.3"
 918 #endif
 919                             NVff,
 920                             SvNVX(PL_patchlevel));
 921             SvNVX(sv) = SvNVX(PL_patchlevel);
 922             SvNOK_on(sv);
 923             SvREADONLY_on(sv);
 924         }
 925         break;
 926     case '\026':        /* $^V */
 927         if (len == 1) {
 928             SV *sv = GvSV(gv);
 929             GvSV(gv) = SvREFCNT_inc(PL_patchlevel);
 930             SvREFCNT_dec(sv);
 931         }
 932         break;
 933     }
 934     return gv;
 935 }
 936
 937 void
 938 Perl_gv_fullname4(pTHX_ SV *sv, GV *gv, const char *prefix, bool keepmain)
 939 {
 940     HV *hv = GvSTASH(gv);
 941     if (!hv) {
 942         (void)SvOK_off(sv);
 943         return;
 944     }
 945     sv_setpv(sv, prefix ? prefix : "");
 946     if (keepmain || strNE(HvNAME(hv), "main")) {
 947         sv_catpv(sv,HvNAME(hv));
 948         sv_catpvn(sv,"::", 2);
 949     }
 950     sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv));
 951 }
 952
 953 void
 954 Perl_gv_fullname3(pTHX_ SV *sv, GV *gv, const char *prefix)
 955 {
 956     HV *hv = GvSTASH(gv);
 957     if (!hv) {
 958         (void)SvOK_off(sv);
 959         return;
 960     }
 961     sv_setpv(sv, prefix ? prefix : "");
 962     sv_catpv(sv,HvNAME(hv));
 963     sv_catpvn(sv,"::", 2);
 964     sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv));
 965 }
 966
 967 void
 968 Perl_gv_efullname4(pTHX_ SV *sv, GV *gv, const char *prefix, bool keepmain)
 969 {
 970     GV *egv = GvEGV(gv);
 971     if (!egv)
 972         egv = gv;
 973     gv_fullname4(sv, egv, prefix, keepmain);
 974 }
 975
 976 void
 977 Perl_gv_efullname3(pTHX_ SV *sv, GV *gv, const char *prefix)
 978 {
 979     GV *egv = GvEGV(gv);
 980     if (!egv)
 981         egv = gv;
 982     gv_fullname3(sv, egv, prefix);
 983 }
 984
 985 /* XXX compatibility with versions <= 5.003. */
 986 void
 987 Perl_gv_fullname(pTHX_ SV *sv, GV *gv)
 988 {
 989     gv_fullname3(sv, gv, sv == (SV*)gv ? "*" : "");
 990 }
 991
 992 /* XXX compatibility with versions <= 5.003. */
 993 void
 994 Perl_gv_efullname(pTHX_ SV *sv, GV *gv)
 995 {
 996     gv_efullname3(sv, gv, sv == (SV*)gv ? "*" : "");
 997 }
 998
 999 IO *
1000 Perl_newIO(pTHX)
1001 {
1002     dTHR;
1003     IO *io;
1004     GV *iogv;
1005
1006     io = (IO*)NEWSV(0,0);
1007     sv_upgrade((SV *)io,SVt_PVIO);
1008     SvREFCNT(io) = 1;
1009     SvOBJECT_on(io);
1010     iogv = gv_fetchpv("FileHandle::", FALSE, SVt_PVHV);
1011     /* unless exists($main::{FileHandle}) and defined(%main::FileHandle::) */
1012     if (!(iogv && GvHV(iogv) && HvARRAY(GvHV(iogv))))
1013       iogv = gv_fetchpv("IO::Handle::", TRUE, SVt_PVHV);
1014     SvSTASH(io) = (HV*)SvREFCNT_inc(GvHV(iogv));
1015     return io;
1016 }
1017
1018 void
1019 Perl_gv_check(pTHX_ HV *stash)
1020 {
1021     dTHR;
1022     register HE *entry;
1023     register I32 i;
1024     register GV *gv;
1025     HV *hv;
1026
1027     if (!HvARRAY(stash))
1028         return;
1029     for (i = 0; i <= (I32) HvMAX(stash); i++) {
1030         for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
1031             if (HeKEY(entry)[HeKLEN(entry)-1] == ':' &&
1032                 (gv = (GV*)HeVAL(entry)) && (hv = GvHV(gv)) && HvNAME(hv))
1033             {
1034                 if (hv != PL_defstash && hv != stash)
1035                      gv_check(hv);              /* nested package */
1036             }
1037             else if (isALPHA(*HeKEY(entry))) {
1038                 char *file;
1039                 gv = (GV*)HeVAL(entry);
1040                 if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv))
1041                     continue;
1042                 file = GvFILE(gv);
1043                 /* performance hack: if filename is absolute and it's a standard
1044                  * module, don't bother warning */
1045                 if (file
1046                     && PERL_FILE_IS_ABSOLUTE(file)
1047                     && (instr(file, "/lib/") || instr(file, ".pm")))
1048                 {
1049                     continue;
1050                 }
1051                 CopLINE_set(PL_curcop, GvLINE(gv));
1052 #ifdef USE_ITHREADS
1053                 CopFILE(PL_curcop) = file;      /* set for warning */
1054 #else
1055                 CopFILEGV(PL_curcop) = gv_fetchfile(file);
1056 #endif
1057                 Perl_warner(aTHX_ WARN_ONCE,
1058                         "Name \"%s::%s\" used only once: possible typo",
1059                         HvNAME(stash), GvNAME(gv));
1060             }
1061         }
1062     }
1063 }
1064
1065 GV *
1066 Perl_newGVgen(pTHX_ char *pack)
1067 {
1068     return gv_fetchpv(Perl_form(aTHX_ "%s::_GEN_%ld", pack, (long)PL_gensym++),
1069                       TRUE, SVt_PVGV);
1070 }
1071
1072 /* hopefully this is only called on local symbol table entries */
1073
1074 GP*
1075 Perl_gp_ref(pTHX_ GP *gp)
1076 {
1077     if (!gp)
1078         return (GP*)NULL;
1079     gp->gp_refcnt++;
1080     if (gp->gp_cv) {
1081         if (gp->gp_cvgen) {
1082             /* multi-named GPs cannot be used for method cache */
1083             SvREFCNT_dec(gp->gp_cv);
1084             gp->gp_cv = Nullcv;
1085             gp->gp_cvgen = 0;
1086         }
1087         else {
1088             /* Adding a new name to a subroutine invalidates method cache */
1089             PL_sub_generation++;
1090         }
1091     }
1092     return gp;
1093 }
1094
1095 void
1096 Perl_gp_free(pTHX_ GV *gv)
1097 {
1098     dTHR;
1099     GP* gp;
1100
1101     if (!gv || !(gp = GvGP(gv)))
1102         return;
1103     if (gp->gp_refcnt == 0) {
1104         if (ckWARN_d(WARN_INTERNAL))
1105             Perl_warner(aTHX_ WARN_INTERNAL,
1106                         "Attempt to free unreferenced glob pointers");
1107         return;
1108     }
1109     if (gp->gp_cv) {
1110         /* Deleting the name of a subroutine invalidates method cache */
1111         PL_sub_generation++;
1112     }
1113     if (--gp->gp_refcnt > 0) {
1114         if (gp->gp_egv == gv)
1115             gp->gp_egv = 0;
1116         return;
1117     }
1118
1119     SvREFCNT_dec(gp->gp_sv);
1120     SvREFCNT_dec(gp->gp_av);
1121     SvREFCNT_dec(gp->gp_hv);
1122     SvREFCNT_dec(gp->gp_io);
1123     SvREFCNT_dec(gp->gp_cv);
1124     SvREFCNT_dec(gp->gp_form);
1125
1126     Safefree(gp);
1127     GvGP(gv) = 0;
1128 }
1129
1130 #if defined(CRIPPLED_CC) && (defined(iAPX286) || defined(M_I286) || defined(I80286))
1131 #define MICROPORT
1132 #endif
1133
1134 #ifdef  MICROPORT       /* Microport 2.4 hack */
1135 AV *GvAVn(gv)
1136 register GV *gv;
1137 {
1138     if (GvGP(gv)->gp_av)
1139         return GvGP(gv)->gp_av;
1140     else
1141         return GvGP(gv_AVadd(gv))->gp_av;
1142 }
1143
1144 HV *GvHVn(gv)
1145 register GV *gv;
1146 {
1147     if (GvGP(gv)->gp_hv)
1148         return GvGP(gv)->gp_hv;
1149     else
1150         return GvGP(gv_HVadd(gv))->gp_hv;
1151 }
1152 #endif                  /* Microport 2.4 hack */
1153
1154 /* Updates and caches the CV's */
1155
1156 bool
1157 Perl_Gv_AMupdate(pTHX_ HV *stash)
1158 {
1159   dTHR;
1160   GV* gv;
1161   CV* cv;
1162   MAGIC* mg=mg_find((SV*)stash,'c');
1163   AMT *amtp = (mg) ? (AMT*)mg->mg_ptr: (AMT *) NULL;
1164   AMT amt;
1165   STRLEN n_a;
1166 #ifdef OVERLOAD_VIA_HASH
1167   GV** gvp;
1168   HV* hv;
1169 #endif
1170
1171   if (mg && amtp->was_ok_am == PL_amagic_generation
1172       && amtp->was_ok_sub == PL_sub_generation)
1173       return AMT_AMAGIC(amtp);
1174   if (amtp && AMT_AMAGIC(amtp)) {       /* Have table. */
1175     int i;
1176     for (i=1; i<NofAMmeth; i++) {
1177       if (amtp->table[i]) {
1178         SvREFCNT_dec(amtp->table[i]);
1179       }
1180     }
1181   }
1182   sv_unmagic((SV*)stash, 'c');
1183
1184   DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME(stash)) );
1185
1186   amt.was_ok_am = PL_amagic_generation;
1187   amt.was_ok_sub = PL_sub_generation;
1188   amt.fallback = AMGfallNO;
1189   amt.flags = 0;
1190
1191 #ifdef OVERLOAD_VIA_HASH
1192   gvp=(GV**)hv_fetch(stash,"OVERLOAD",8,FALSE); /* A shortcut */
1193   if (gvp && ((gv = *gvp) != (GV*)&PL_sv_undef && (hv = GvHV(gv)))) {
1194     int filled=0;
1195     int i;
1196     char *cp;
1197     SV* sv;
1198     SV** svp;
1199
1200     /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
1201
1202     if (( cp = (char *)PL_AMG_names[0] ) &&
1203         (svp = (SV**)hv_fetch(hv,cp,strlen(cp),FALSE)) && (sv = *svp)) {
1204       if (SvTRUE(sv)) amt.fallback=AMGfallYES;
1205       else if (SvOK(sv)) amt.fallback=AMGfallNEVER;
1206     }
1207     for (i = 1; i < NofAMmeth; i++) {
1208       cv = 0;
1209       cp = (char *)PL_AMG_names[i];
1210
1211         svp = (SV**)hv_fetch(hv, cp, strlen(cp), FALSE);
1212         if (svp && ((sv = *svp) != &PL_sv_undef)) {
1213           switch (SvTYPE(sv)) {
1214             default:
1215               if (!SvROK(sv)) {
1216                 if (!SvOK(sv)) break;
1217                 gv = gv_fetchmethod(stash, SvPV(sv, n_a));
1218                 if (gv) cv = GvCV(gv);
1219                 break;
1220               }
1221               cv = (CV*)SvRV(sv);
1222               if (SvTYPE(cv) == SVt_PVCV)
1223                   break;
1224                 /* FALL THROUGH */
1225             case SVt_PVHV:
1226             case SVt_PVAV:
1227               Perl_croak(aTHX_ "Not a subroutine reference in overload table");
1228               return FALSE;
1229             case SVt_PVCV:
1230               cv = (CV*)sv;
1231               break;
1232             case SVt_PVGV:
1233               if (!(cv = GvCVu((GV*)sv)))
1234                 cv = sv_2cv(sv, &stash, &gv, FALSE);
1235               break;
1236           }
1237           if (cv) filled=1;
1238           else {
1239             Perl_croak(aTHX_ "Method for operation %s not found in package %.256s during blessing\n",
1240                 cp,HvNAME(stash));
1241             return FALSE;
1242           }
1243         }
1244 #else
1245   {
1246     int filled = 0;
1247     int i;
1248     const char *cp;
1249     SV* sv = NULL;
1250
1251     /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
1252
1253     if ((cp = PL_AMG_names[0])) {
1254         /* Try to find via inheritance. */
1255         gv = gv_fetchmeth(stash, "()", 2, -1); /* A cookie: "()". */
1256         if (gv)
1257             sv = GvSV(gv);
1258
1259         if (!gv)
1260             goto no_table;
1261         else if (SvTRUE(sv))
1262             amt.fallback=AMGfallYES;
1263         else if (SvOK(sv))
1264             amt.fallback=AMGfallNEVER;
1265     }
1266
1267     for (i = 1; i < NofAMmeth; i++) {
1268         SV *cookie = sv_2mortal(Perl_newSVpvf(aTHX_ "(%s", cp = PL_AMG_names[i]));
1269         DEBUG_o( Perl_deb(aTHX_ "Checking overloading of `%s' in package `%.256s'\n",
1270                      cp, HvNAME(stash)) );
1271         /* don't fill the cache while looking up! */
1272         gv = gv_fetchmeth(stash, SvPVX(cookie), SvCUR(cookie), -1);
1273         cv = 0;
1274         if(gv && (cv = GvCV(gv))) {
1275             if (GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")
1276                 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "overload")) {
1277                 /* GvSV contains the name of the method. */
1278                 GV *ngv;
1279
1280                 DEBUG_o( Perl_deb(aTHX_ "Resolving method `%.256s' for overloaded `%s' in package `%.256s'\n",
1281                              SvPV(GvSV(gv), n_a), cp, HvNAME(stash)) );
1282                 if (!SvPOK(GvSV(gv))
1283                     || !(ngv = gv_fetchmethod_autoload(stash, SvPVX(GvSV(gv)),
1284                                                        FALSE)))
1285                 {
1286                     /* Can be an import stub (created by `can'). */
1287                     if (GvCVGEN(gv)) {
1288                         Perl_croak(aTHX_ "Stub found while resolving method `%.256s' overloading `%s' in package `%.256s'",
1289                               (SvPOK(GvSV(gv)) ?  SvPVX(GvSV(gv)) : "???" ),
1290                               cp, HvNAME(stash));
1291                     } else
1292                         Perl_croak(aTHX_ "Can't resolve method `%.256s' overloading `%s' in package `%.256s'",
1293                               (SvPOK(GvSV(gv)) ?  SvPVX(GvSV(gv)) : "???" ),
1294                               cp, HvNAME(stash));
1295                 }
1296                 cv = GvCV(gv = ngv);
1297             }
1298             DEBUG_o( Perl_deb(aTHX_ "Overloading `%s' in package `%.256s' via `%.256s::%.256s' \n",
1299                          cp, HvNAME(stash), HvNAME(GvSTASH(CvGV(cv))),
1300                          GvNAME(CvGV(cv))) );
1301             filled = 1;
1302         }
1303 #endif
1304         amt.table[i]=(CV*)SvREFCNT_inc(cv);
1305     }
1306     if (filled) {
1307       AMT_AMAGIC_on(&amt);
1308       sv_magic((SV*)stash, 0, 'c', (char*)&amt, sizeof(AMT));
1309       return TRUE;
1310     }
1311   }
1312   /* Here we have no table: */
1313  no_table:
1314   AMT_AMAGIC_off(&amt);
1315   sv_magic((SV*)stash, 0, 'c', (char*)&amt, sizeof(AMTS));
1316   return FALSE;
1317 }
1318
1319 SV*
1320 Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
1321 {
1322   dTHR;
1323   MAGIC *mg;
1324   CV *cv;
1325   CV **cvp=NULL, **ocvp=NULL;
1326   AMT *amtp, *oamtp;
1327   int fl=0, off, off1, lr=0, assign=AMGf_assign & flags, notfound=0;
1328   int postpr = 0, force_cpy = 0, assignshift = assign ? 1 : 0;
1329   HV* stash;
1330   if (!(AMGf_noleft & flags) && SvAMAGIC(left)
1331       && (mg = mg_find((SV*)(stash=SvSTASH(SvRV(left))),'c'))
1332       && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
1333                         ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
1334                         : (CV **) NULL))
1335       && ((cv = cvp[off=method+assignshift])
1336           || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
1337                                                           * usual method */
1338                   (fl = 1, cv = cvp[off=method])))) {
1339     lr = -1;                    /* Call method for left argument */
1340   } else {
1341     if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) {
1342       int logic;
1343
1344       /* look for substituted methods */
1345       /* In all the covered cases we should be called with assign==0. */
1346          switch (method) {
1347          case inc_amg:
1348            force_cpy = 1;
1349            if ((cv = cvp[off=add_ass_amg])
1350                || ((cv = cvp[off = add_amg]) && (force_cpy = 0, postpr = 1))) {
1351              right = &PL_sv_yes; lr = -1; assign = 1;
1352            }
1353            break;
1354          case dec_amg:
1355            force_cpy = 1;
1356            if ((cv = cvp[off = subtr_ass_amg])
1357                || ((cv = cvp[off = subtr_amg]) && (force_cpy = 0, postpr=1))) {
1358              right = &PL_sv_yes; lr = -1; assign = 1;
1359            }
1360            break;
1361          case bool__amg:
1362            (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg]));
1363            break;
1364          case numer_amg:
1365            (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg]));
1366            break;
1367          case string_amg:
1368            (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg]));
1369            break;
1370  case not_amg:
1371    (void)((cv = cvp[off=bool__amg])
1372           || (cv = cvp[off=numer_amg])
1373           || (cv = cvp[off=string_amg]));
1374    postpr = 1;
1375    break;
1376          case copy_amg:
1377            {
1378              /*
1379                   * SV* ref causes confusion with the interpreter variable of
1380                   * the same name
1381                   */
1382              SV* tmpRef=SvRV(left);
1383              if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) {
1384                 /*
1385                  * Just to be extra cautious.  Maybe in some
1386                  * additional cases sv_setsv is safe, too.
1387                  */
1388                 SV* newref = newSVsv(tmpRef);
1389                 SvOBJECT_on(newref);
1390                 SvSTASH(newref) = (HV*)SvREFCNT_inc(SvSTASH(tmpRef));
1391                 return newref;
1392              }
1393            }
1394            break;
1395          case abs_amg:
1396            if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg])
1397                && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) {
1398              SV* nullsv=sv_2mortal(newSViv(0));
1399              if (off1==lt_amg) {
1400                SV* lessp = amagic_call(left,nullsv,
1401                                        lt_amg,AMGf_noright);
1402                logic = SvTRUE(lessp);
1403              } else {
1404                SV* lessp = amagic_call(left,nullsv,
1405                                        ncmp_amg,AMGf_noright);
1406                logic = (SvNV(lessp) < 0);
1407              }
1408              if (logic) {
1409                if (off==subtr_amg) {
1410                  right = left;
1411                  left = nullsv;
1412                  lr = 1;
1413                }
1414              } else {
1415                return left;
1416              }
1417            }
1418            break;
1419          case neg_amg:
1420            if ((cv = cvp[off=subtr_amg])) {
1421              right = left;
1422              left = sv_2mortal(newSViv(0));
1423              lr = 1;
1424            }
1425            break;
1426          case iter_amg:                 /* XXXX Eventually should do to_gv. */
1427              /* FAIL safe */
1428              return NULL;       /* Delegate operation to standard mechanisms. */
1429              break;
1430          case to_sv_amg:
1431          case to_av_amg:
1432          case to_hv_amg:
1433          case to_gv_amg:
1434          case to_cv_amg:
1435              /* FAIL safe */
1436              return left;       /* Delegate operation to standard mechanisms. */
1437              break;
1438          default:
1439            goto not_found;
1440          }
1441          if (!cv) goto not_found;
1442     } else if (!(AMGf_noright & flags) && SvAMAGIC(right)
1443                && (mg = mg_find((SV*)(stash=SvSTASH(SvRV(right))),'c'))
1444                && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
1445                           ? (amtp = (AMT*)mg->mg_ptr)->table
1446                           : (CV **) NULL))
1447                && (cv = cvp[off=method])) { /* Method for right
1448                                              * argument found */
1449       lr=1;
1450     } else if (((ocvp && oamtp->fallback > AMGfallNEVER
1451                  && (cvp=ocvp) && (lr = -1))
1452                 || (cvp && amtp->fallback > AMGfallNEVER && (lr=1)))
1453                && !(flags & AMGf_unary)) {
1454                                 /* We look for substitution for
1455                                  * comparison operations and
1456                                  * concatenation */
1457       if (method==concat_amg || method==concat_ass_amg
1458           || method==repeat_amg || method==repeat_ass_amg) {
1459         return NULL;            /* Delegate operation to string conversion */
1460       }
1461       off = -1;
1462       switch (method) {
1463          case lt_amg:
1464          case le_amg:
1465          case gt_amg:
1466          case ge_amg:
1467          case eq_amg:
1468          case ne_amg:
1469            postpr = 1; off=ncmp_amg; break;
1470          case slt_amg:
1471          case sle_amg:
1472          case sgt_amg:
1473          case sge_amg:
1474          case seq_amg:
1475          case sne_amg:
1476            postpr = 1; off=scmp_amg; break;
1477          }
1478       if (off != -1) cv = cvp[off];
1479       if (!cv) {
1480         goto not_found;
1481       }
1482     } else {
1483     not_found:                  /* No method found, either report or croak */
1484       switch (method) {
1485          case to_sv_amg:
1486          case to_av_amg:
1487          case to_hv_amg:
1488          case to_gv_amg:
1489          case to_cv_amg:
1490              /* FAIL safe */
1491              return left;       /* Delegate operation to standard mechanisms. */
1492              break;
1493       }
1494       if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */
1495         notfound = 1; lr = -1;
1496       } else if (cvp && (cv=cvp[nomethod_amg])) {
1497         notfound = 1; lr = 1;
1498       } else {
1499         SV *msg;
1500         if (off==-1) off=method;
1501         msg = sv_2mortal(Perl_newSVpvf(aTHX_
1502                       "Operation `%s': no method found,%sargument %s%s%s%s",
1503                       PL_AMG_names[method + assignshift],
1504                       (flags & AMGf_unary ? " " : "\n\tleft "),
1505                       SvAMAGIC(left)?
1506                         "in overloaded package ":
1507                         "has no overloaded magic",
1508                       SvAMAGIC(left)?
1509                         HvNAME(SvSTASH(SvRV(left))):
1510                         "",
1511                       SvAMAGIC(right)?
1512                         ",\n\tright argument in overloaded package ":
1513                         (flags & AMGf_unary
1514                          ? ""
1515                          : ",\n\tright argument has no overloaded magic"),
1516                       SvAMAGIC(right)?
1517                         HvNAME(SvSTASH(SvRV(right))):
1518                         ""));
1519         if (amtp && amtp->fallback >= AMGfallYES) {
1520           DEBUG_o( Perl_deb(aTHX_ "%s", SvPVX(msg)) );
1521         } else {
1522           Perl_croak(aTHX_ "%"SVf, msg);
1523         }
1524         return NULL;
1525       }
1526       force_cpy = force_cpy || assign;
1527     }
1528   }
1529   if (!notfound) {
1530     DEBUG_o( Perl_deb(aTHX_
1531   "Overloaded operator `%s'%s%s%s:\n\tmethod%s found%s in package %s%s\n",
1532                  PL_AMG_names[off],
1533                  method+assignshift==off? "" :
1534                              " (initially `",
1535                  method+assignshift==off? "" :
1536                              PL_AMG_names[method+assignshift],
1537                  method+assignshift==off? "" : "')",
1538                  flags & AMGf_unary? "" :
1539                    lr==1 ? " for right argument": " for left argument",
1540                  flags & AMGf_unary? " for argument" : "",
1541                  HvNAME(stash),
1542                  fl? ",\n\tassignment variant used": "") );
1543   }
1544     /* Since we use shallow copy during assignment, we need
1545      * to dublicate the contents, probably calling user-supplied
1546      * version of copy operator
1547      */
1548     /* We need to copy in following cases:
1549      * a) Assignment form was called.
1550      *          assignshift==1,  assign==T, method + 1 == off
1551      * b) Increment or decrement, called directly.
1552      *          assignshift==0,  assign==0, method + 0 == off
1553      * c) Increment or decrement, translated to assignment add/subtr.
1554      *          assignshift==0,  assign==T,
1555      *          force_cpy == T
1556      * d) Increment or decrement, translated to nomethod.
1557      *          assignshift==0,  assign==0,
1558      *          force_cpy == T
1559      * e) Assignment form translated to nomethod.
1560      *          assignshift==1,  assign==T, method + 1 != off
1561      *          force_cpy == T
1562      */
1563     /*  off is method, method+assignshift, or a result of opcode substitution.
1564      *  In the latter case assignshift==0, so only notfound case is important.
1565      */
1566   if (( (method + assignshift == off)
1567         && (assign || (method == inc_amg) || (method == dec_amg)))
1568       || force_cpy)
1569     RvDEEPCP(left);
1570   {
1571     dSP;
1572     BINOP myop;
1573     SV* res;
1574     bool oldcatch = CATCH_GET;
1575
1576     CATCH_SET(TRUE);
1577     Zero(&myop, 1, BINOP);
1578     myop.op_last = (OP *) &myop;
1579     myop.op_next = Nullop;
1580     myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
1581
1582     PUSHSTACKi(PERLSI_OVERLOAD);
1583     ENTER;
1584     SAVEOP();
1585     PL_op = (OP *) &myop;
1586     if (PERLDB_SUB && PL_curstash != PL_debstash)
1587         PL_op->op_private |= OPpENTERSUB_DB;
1588     PUTBACK;
1589     pp_pushmark();
1590
1591     EXTEND(SP, notfound + 5);
1592     PUSHs(lr>0? right: left);
1593     PUSHs(lr>0? left: right);
1594     PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no ));
1595     if (notfound) {
1596       PUSHs( sv_2mortal(newSVpv((char *)PL_AMG_names[method + assignshift],0)));
1597     }
1598     PUSHs((SV*)cv);
1599     PUTBACK;
1600
1601     if ((PL_op = Perl_pp_entersub(aTHX)))
1602       CALLRUNOPS(aTHX);
1603     LEAVE;
1604     SPAGAIN;
1605
1606     res=POPs;
1607     PUTBACK;
1608     POPSTACK;
1609     CATCH_SET(oldcatch);
1610
1611     if (postpr) {
1612       int ans;
1613       switch (method) {
1614       case le_amg:
1615       case sle_amg:
1616         ans=SvIV(res)<=0; break;
1617       case lt_amg:
1618       case slt_amg:
1619         ans=SvIV(res)<0; break;
1620       case ge_amg:
1621       case sge_amg:
1622         ans=SvIV(res)>=0; break;
1623       case gt_amg:
1624       case sgt_amg:
1625         ans=SvIV(res)>0; break;
1626       case eq_amg:
1627       case seq_amg:
1628         ans=SvIV(res)==0; break;
1629       case ne_amg:
1630       case sne_amg:
1631         ans=SvIV(res)!=0; break;
1632       case inc_amg:
1633       case dec_amg:
1634         SvSetSV(left,res); return left;
1635       case not_amg:
1636         ans=!SvTRUE(res); break;
1637       }
1638       return boolSV(ans);
1639     } else if (method==copy_amg) {
1640       if (!SvROK(res)) {
1641         Perl_croak(aTHX_ "Copy method did not return a reference");
1642       }
1643       return SvREFCNT_inc(SvRV(res));
1644     } else {
1645       return res;
1646     }
1647   }
1648 }
1649
1650 /*
1651 =for apidoc is_gv_magical
1652
1653 Returns C<TRUE> if given the name of a magical GV.
1654
1655 Currently only useful internally when determining if a GV should be
1656 created even in rvalue contexts.
1657
1658 C<flags> is not used at present but available for future extension to
1659 allow selecting particular classes of magical variable.
1660
1661 =cut
1662 */
1663 bool
1664 Perl_is_gv_magical(pTHX_ char *name, STRLEN len, U32 flags)
1665 {
1666     if (!len)
1667         return FALSE;
1668
1669     switch (*name) {
1670     case 'I':
1671         if (len == 3 && strEQ(name, "ISA"))
1672             goto yes;
1673         break;
1674     case 'O':
1675         if (len == 8 && strEQ(name, "OVERLOAD"))
1676             goto yes;
1677         break;
1678     case 'S':
1679         if (len == 3 && strEQ(name, "SIG"))
1680             goto yes;
1681         break;
1682     case '\017':   /* $^O & $^OPEN */
1683         if (len == 1
1684             || (len == 4 && strEQ(name, "\027PEN")))
1685         {
1686             goto yes;
1687         }
1688         break;
1689     case '\027':   /* $^W & $^WARNING_BITS */
1690         if (len == 1
1691             || (len == 12 && strEQ(name, "\027ARNING_BITS"))
1692             || (len == 17 && strEQ(name, "\027IDE_SYSTEM_CALLS")))
1693         {
1694             goto yes;
1695         }
1696         break;
1697
1698     case '&':
1699     case '`':
1700     case '\'':
1701     case ':':
1702     case '?':
1703     case '!':
1704     case '-':
1705     case '#':
1706     case '*':
1707     case '[':
1708     case '^':
1709     case '~':
1710     case '=':
1711     case '%':
1712     case '.':
1713     case '(':
1714     case ')':
1715     case '<':
1716     case '>':
1717     case ',':
1718     case '\\':
1719     case '/':
1720     case '|':
1721     case '+':
1722     case ';':
1723     case ']':
1724     case '\001':   /* $^A */
1725     case '\003':   /* $^C */
1726     case '\004':   /* $^D */
1727     case '\005':   /* $^E */
1728     case '\006':   /* $^F */
1729     case '\010':   /* $^H */
1730     case '\011':   /* $^I, NOT \t in EBCDIC */
1731     case '\014':   /* $^L */
1732     case '\020':   /* $^P */
1733     case '\023':   /* $^S */
1734     case '\024':   /* $^T */
1735     case '\026':   /* $^V */
1736         if (len == 1)
1737             goto yes;
1738         break;
1739     case '1':
1740     case '2':
1741     case '3':
1742     case '4':
1743     case '5':
1744     case '6':
1745     case '7':
1746     case '8':
1747     case '9':
1748         if (len > 1) {
1749             char *end = name + len;
1750             while (--end > name) {
1751                 if (!isDIGIT(*end))
1752                     return FALSE;
1753             }
1754         }
1755     yes:
1756         return TRUE;
1757     default:
1758         break;
1759     }
1760     return FALSE;
1761 }