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