gv.c

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