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     dTHR;
1317     MAGIC *mg;
1318     AMT *amtp;
1319
1320     if (!stash)
1321         return Nullcv;
1322     mg = mg_find((SV*)stash,'c');
1323     if (!mg) {
1324       do_update:
1325         Gv_AMupdate(stash);
1326         mg = mg_find((SV*)stash,'c');
1327     }
1328     amtp = (AMT*)mg->mg_ptr;
1329     if ( amtp->was_ok_am != PL_amagic_generation
1330          || amtp->was_ok_sub != PL_sub_generation )
1331         goto do_update;
1332     if (AMT_AMAGIC(amtp))
1333         return amtp->table[id];
1334     return Nullcv;
1335 }
1336
1337
1338 SV*
1339 Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
1340 {
1341   MAGIC *mg;
1342   CV *cv;
1343   CV **cvp=NULL, **ocvp=NULL;
1344   AMT *amtp, *oamtp;
1345   int fl=0, off, off1, lr=0, assign=AMGf_assign & flags, notfound=0;
1346   int postpr = 0, force_cpy = 0, assignshift = assign ? 1 : 0;
1347   HV* stash;
1348   if (!(AMGf_noleft & flags) && SvAMAGIC(left)
1349       && (mg = mg_find((SV*)(stash=SvSTASH(SvRV(left))),'c'))
1350       && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
1351                         ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
1352                         : (CV **) NULL))
1353       && ((cv = cvp[off=method+assignshift])
1354           || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
1355                                                           * usual method */
1356                   (fl = 1, cv = cvp[off=method])))) {
1357     lr = -1;                    /* Call method for left argument */
1358   } else {
1359     if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) {
1360       int logic;
1361
1362       /* look for substituted methods */
1363       /* In all the covered cases we should be called with assign==0. */
1364          switch (method) {
1365          case inc_amg:
1366            force_cpy = 1;
1367            if ((cv = cvp[off=add_ass_amg])
1368                || ((cv = cvp[off = add_amg]) && (force_cpy = 0, postpr = 1))) {
1369              right = &PL_sv_yes; lr = -1; assign = 1;
1370            }
1371            break;
1372          case dec_amg:
1373            force_cpy = 1;
1374            if ((cv = cvp[off = subtr_ass_amg])
1375                || ((cv = cvp[off = subtr_amg]) && (force_cpy = 0, postpr=1))) {
1376              right = &PL_sv_yes; lr = -1; assign = 1;
1377            }
1378            break;
1379          case bool__amg:
1380            (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg]));
1381            break;
1382          case numer_amg:
1383            (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg]));
1384            break;
1385          case string_amg:
1386            (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg]));
1387            break;
1388  case not_amg:
1389    (void)((cv = cvp[off=bool__amg])
1390           || (cv = cvp[off=numer_amg])
1391           || (cv = cvp[off=string_amg]));
1392    postpr = 1;
1393    break;
1394          case copy_amg:
1395            {
1396              /*
1397                   * SV* ref causes confusion with the interpreter variable of
1398                   * the same name
1399                   */
1400              SV* tmpRef=SvRV(left);
1401              if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) {
1402                 /*
1403                  * Just to be extra cautious.  Maybe in some
1404                  * additional cases sv_setsv is safe, too.
1405                  */
1406                 SV* newref = newSVsv(tmpRef);
1407                 SvOBJECT_on(newref);
1408                 SvSTASH(newref) = (HV*)SvREFCNT_inc(SvSTASH(tmpRef));
1409                 return newref;
1410              }
1411            }
1412            break;
1413          case abs_amg:
1414            if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg])
1415                && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) {
1416              SV* nullsv=sv_2mortal(newSViv(0));
1417              if (off1==lt_amg) {
1418                SV* lessp = amagic_call(left,nullsv,
1419                                        lt_amg,AMGf_noright);
1420                logic = SvTRUE(lessp);
1421              } else {
1422                SV* lessp = amagic_call(left,nullsv,
1423                                        ncmp_amg,AMGf_noright);
1424                logic = (SvNV(lessp) < 0);
1425              }
1426              if (logic) {
1427                if (off==subtr_amg) {
1428                  right = left;
1429                  left = nullsv;
1430                  lr = 1;
1431                }
1432              } else {
1433                return left;
1434              }
1435            }
1436            break;
1437          case neg_amg:
1438            if ((cv = cvp[off=subtr_amg])) {
1439              right = left;
1440              left = sv_2mortal(newSViv(0));
1441              lr = 1;
1442            }
1443            break;
1444          case int_amg:
1445          case iter_amg:                 /* XXXX Eventually should do to_gv. */
1446              /* FAIL safe */
1447              return NULL;       /* Delegate operation to standard mechanisms. */
1448              break;
1449          case to_sv_amg:
1450          case to_av_amg:
1451          case to_hv_amg:
1452          case to_gv_amg:
1453          case to_cv_amg:
1454              /* FAIL safe */
1455              return left;       /* Delegate operation to standard mechanisms. */
1456              break;
1457          default:
1458            goto not_found;
1459          }
1460          if (!cv) goto not_found;
1461     } else if (!(AMGf_noright & flags) && SvAMAGIC(right)
1462                && (mg = mg_find((SV*)(stash=SvSTASH(SvRV(right))),'c'))
1463                && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
1464                           ? (amtp = (AMT*)mg->mg_ptr)->table
1465                           : (CV **) NULL))
1466                && (cv = cvp[off=method])) { /* Method for right
1467                                              * argument found */
1468       lr=1;
1469     } else if (((ocvp && oamtp->fallback > AMGfallNEVER
1470                  && (cvp=ocvp) && (lr = -1))
1471                 || (cvp && amtp->fallback > AMGfallNEVER && (lr=1)))
1472                && !(flags & AMGf_unary)) {
1473                                 /* We look for substitution for
1474                                  * comparison operations and
1475                                  * concatenation */
1476       if (method==concat_amg || method==concat_ass_amg
1477           || method==repeat_amg || method==repeat_ass_amg) {
1478         return NULL;            /* Delegate operation to string conversion */
1479       }
1480       off = -1;
1481       switch (method) {
1482          case lt_amg:
1483          case le_amg:
1484          case gt_amg:
1485          case ge_amg:
1486          case eq_amg:
1487          case ne_amg:
1488            postpr = 1; off=ncmp_amg; break;
1489          case slt_amg:
1490          case sle_amg:
1491          case sgt_amg:
1492          case sge_amg:
1493          case seq_amg:
1494          case sne_amg:
1495            postpr = 1; off=scmp_amg; break;
1496          }
1497       if (off != -1) cv = cvp[off];
1498       if (!cv) {
1499         goto not_found;
1500       }
1501     } else {
1502     not_found:                  /* No method found, either report or croak */
1503       switch (method) {
1504          case to_sv_amg:
1505          case to_av_amg:
1506          case to_hv_amg:
1507          case to_gv_amg:
1508          case to_cv_amg:
1509              /* FAIL safe */
1510              return left;       /* Delegate operation to standard mechanisms. */
1511              break;
1512       }
1513       if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */
1514         notfound = 1; lr = -1;
1515       } else if (cvp && (cv=cvp[nomethod_amg])) {
1516         notfound = 1; lr = 1;
1517       } else {
1518         SV *msg;
1519         if (off==-1) off=method;
1520         msg = sv_2mortal(Perl_newSVpvf(aTHX_
1521                       "Operation `%s': no method found,%sargument %s%s%s%s",
1522                       AMG_id2name(method + assignshift),
1523                       (flags & AMGf_unary ? " " : "\n\tleft "),
1524                       SvAMAGIC(left)?
1525                         "in overloaded package ":
1526                         "has no overloaded magic",
1527                       SvAMAGIC(left)?
1528                         HvNAME(SvSTASH(SvRV(left))):
1529                         "",
1530                       SvAMAGIC(right)?
1531                         ",\n\tright argument in overloaded package ":
1532                         (flags & AMGf_unary
1533                          ? ""
1534                          : ",\n\tright argument has no overloaded magic"),
1535                       SvAMAGIC(right)?
1536                         HvNAME(SvSTASH(SvRV(right))):
1537                         ""));
1538         if (amtp && amtp->fallback >= AMGfallYES) {
1539           DEBUG_o( Perl_deb(aTHX_ "%s", SvPVX(msg)) );
1540         } else {
1541           Perl_croak(aTHX_ "%"SVf, msg);
1542         }
1543         return NULL;
1544       }
1545       force_cpy = force_cpy || assign;
1546     }
1547   }
1548   if (!notfound) {
1549     DEBUG_o( Perl_deb(aTHX_
1550   "Overloaded operator `%s'%s%s%s:\n\tmethod%s found%s in package %s%s\n",
1551                  AMG_id2name(off),
1552                  method+assignshift==off? "" :
1553                              " (initially `",
1554                  method+assignshift==off? "" :
1555                              AMG_id2name(method+assignshift),
1556                  method+assignshift==off? "" : "')",
1557                  flags & AMGf_unary? "" :
1558                    lr==1 ? " for right argument": " for left argument",
1559                  flags & AMGf_unary? " for argument" : "",
1560                  HvNAME(stash),
1561                  fl? ",\n\tassignment variant used": "") );
1562   }
1563     /* Since we use shallow copy during assignment, we need
1564      * to dublicate the contents, probably calling user-supplied
1565      * version of copy operator
1566      */
1567     /* We need to copy in following cases:
1568      * a) Assignment form was called.
1569      *          assignshift==1,  assign==T, method + 1 == off
1570      * b) Increment or decrement, called directly.
1571      *          assignshift==0,  assign==0, method + 0 == off
1572      * c) Increment or decrement, translated to assignment add/subtr.
1573      *          assignshift==0,  assign==T,
1574      *          force_cpy == T
1575      * d) Increment or decrement, translated to nomethod.
1576      *          assignshift==0,  assign==0,
1577      *          force_cpy == T
1578      * e) Assignment form translated to nomethod.
1579      *          assignshift==1,  assign==T, method + 1 != off
1580      *          force_cpy == T
1581      */
1582     /*  off is method, method+assignshift, or a result of opcode substitution.
1583      *  In the latter case assignshift==0, so only notfound case is important.
1584      */
1585   if (( (method + assignshift == off)
1586         && (assign || (method == inc_amg) || (method == dec_amg)))
1587       || force_cpy)
1588     RvDEEPCP(left);
1589   {
1590     dSP;
1591     BINOP myop;
1592     SV* res;
1593     bool oldcatch = CATCH_GET;
1594
1595     CATCH_SET(TRUE);
1596     Zero(&myop, 1, BINOP);
1597     myop.op_last = (OP *) &myop;
1598     myop.op_next = Nullop;
1599     myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
1600
1601     PUSHSTACKi(PERLSI_OVERLOAD);
1602     ENTER;
1603     SAVEOP();
1604     PL_op = (OP *) &myop;
1605     if (PERLDB_SUB && PL_curstash != PL_debstash)
1606         PL_op->op_private |= OPpENTERSUB_DB;
1607     PUTBACK;
1608     pp_pushmark();
1609
1610     EXTEND(SP, notfound + 5);
1611     PUSHs(lr>0? right: left);
1612     PUSHs(lr>0? left: right);
1613     PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no ));
1614     if (notfound) {
1615       PUSHs( sv_2mortal(newSVpv(AMG_id2name(method + assignshift),0)));
1616     }
1617     PUSHs((SV*)cv);
1618     PUTBACK;
1619
1620     if ((PL_op = Perl_pp_entersub(aTHX)))
1621       CALLRUNOPS(aTHX);
1622     LEAVE;
1623     SPAGAIN;
1624
1625     res=POPs;
1626     PUTBACK;
1627     POPSTACK;
1628     CATCH_SET(oldcatch);
1629
1630     if (postpr) {
1631       int ans;
1632       switch (method) {
1633       case le_amg:
1634       case sle_amg:
1635         ans=SvIV(res)<=0; break;
1636       case lt_amg:
1637       case slt_amg:
1638         ans=SvIV(res)<0; break;
1639       case ge_amg:
1640       case sge_amg:
1641         ans=SvIV(res)>=0; break;
1642       case gt_amg:
1643       case sgt_amg:
1644         ans=SvIV(res)>0; break;
1645       case eq_amg:
1646       case seq_amg:
1647         ans=SvIV(res)==0; break;
1648       case ne_amg:
1649       case sne_amg:
1650         ans=SvIV(res)!=0; break;
1651       case inc_amg:
1652       case dec_amg:
1653         SvSetSV(left,res); return left;
1654       case not_amg:
1655         ans=!SvTRUE(res); break;
1656       }
1657       return boolSV(ans);
1658     } else if (method==copy_amg) {
1659       if (!SvROK(res)) {
1660         Perl_croak(aTHX_ "Copy method did not return a reference");
1661       }
1662       return SvREFCNT_inc(SvRV(res));
1663     } else {
1664       return res;
1665     }
1666   }
1667 }
1668
1669 /*
1670 =for apidoc is_gv_magical
1671
1672 Returns C<TRUE> if given the name of a magical GV.
1673
1674 Currently only useful internally when determining if a GV should be
1675 created even in rvalue contexts.
1676
1677 C<flags> is not used at present but available for future extension to
1678 allow selecting particular classes of magical variable.
1679
1680 =cut
1681 */
1682 bool
1683 Perl_is_gv_magical(pTHX_ char *name, STRLEN len, U32 flags)
1684 {
1685     if (!len)
1686         return FALSE;
1687
1688     switch (*name) {
1689     case 'I':
1690         if (len == 3 && strEQ(name, "ISA"))
1691             goto yes;
1692         break;
1693     case 'O':
1694         if (len == 8 && strEQ(name, "OVERLOAD"))
1695             goto yes;
1696         break;
1697     case 'S':
1698         if (len == 3 && strEQ(name, "SIG"))
1699             goto yes;
1700         break;
1701     case '\017':   /* $^O & $^OPEN */
1702         if (len == 1
1703             || (len == 4 && strEQ(name, "\027PEN")))
1704         {
1705             goto yes;
1706         }
1707         break;
1708     case '\027':   /* $^W & $^WARNING_BITS */
1709         if (len == 1
1710             || (len == 12 && strEQ(name, "\027ARNING_BITS"))
1711             || (len == 17 && strEQ(name, "\027IDE_SYSTEM_CALLS")))
1712         {
1713             goto yes;
1714         }
1715         break;
1716
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 ']':
1743     case '\001':   /* $^A */
1744     case '\003':   /* $^C */
1745     case '\004':   /* $^D */
1746     case '\005':   /* $^E */
1747     case '\006':   /* $^F */
1748     case '\010':   /* $^H */
1749     case '\011':   /* $^I, NOT \t in EBCDIC */
1750     case '\014':   /* $^L */
1751     case '\020':   /* $^P */
1752     case '\023':   /* $^S */
1753     case '\024':   /* $^T */
1754     case '\026':   /* $^V */
1755         if (len == 1)
1756             goto yes;
1757         break;
1758     case '1':
1759     case '2':
1760     case '3':
1761     case '4':
1762     case '5':
1763     case '6':
1764     case '7':
1765     case '8':
1766     case '9':
1767         if (len > 1) {
1768             char *end = name + len;
1769             while (--end > name) {
1770                 if (!isDIGIT(*end))
1771                     return FALSE;
1772             }
1773         }
1774     yes:
1775         return TRUE;
1776     default:
1777         break;
1778     }
1779     return FALSE;
1780 }