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 #ifdef MACOS_TRADITIONAL
1085                     && (instr(file, ":lib:")
1086 #else
1087                     && (instr(file, "/lib/")
1088 #endif
1089                     || instr(file, ".pm")))
1090                 {
1091                     continue;
1092                 }
1093                 CopLINE_set(PL_curcop, GvLINE(gv));
1094 #ifdef USE_ITHREADS
1095                 CopFILE(PL_curcop) = file;      /* set for warning */
1096 #else
1097                 CopFILEGV(PL_curcop) = gv_fetchfile(file);
1098 #endif
1099                 Perl_warner(aTHX_ WARN_ONCE,
1100                         "Name \"%s::%s\" used only once: possible typo",
1101                         HvNAME(stash), GvNAME(gv));
1102             }
1103         }
1104     }
1105 }
1106
1107 GV *
1108 Perl_newGVgen(pTHX_ char *pack)
1109 {
1110     return gv_fetchpv(Perl_form(aTHX_ "%s::_GEN_%ld", pack, (long)PL_gensym++),
1111                       TRUE, SVt_PVGV);
1112 }
1113
1114 /* hopefully this is only called on local symbol table entries */
1115
1116 GP*
1117 Perl_gp_ref(pTHX_ GP *gp)
1118 {
1119     if (!gp)
1120         return (GP*)NULL;
1121     gp->gp_refcnt++;
1122     if (gp->gp_cv) {
1123         if (gp->gp_cvgen) {
1124             /* multi-named GPs cannot be used for method cache */
1125             SvREFCNT_dec(gp->gp_cv);
1126             gp->gp_cv = Nullcv;
1127             gp->gp_cvgen = 0;
1128         }
1129         else {
1130             /* Adding a new name to a subroutine invalidates method cache */
1131             PL_sub_generation++;
1132         }
1133     }
1134     return gp;
1135 }
1136
1137 void
1138 Perl_gp_free(pTHX_ GV *gv)
1139 {
1140     GP* gp;
1141
1142     if (!gv || !(gp = GvGP(gv)))
1143         return;
1144     if (gp->gp_refcnt == 0) {
1145         if (ckWARN_d(WARN_INTERNAL))
1146             Perl_warner(aTHX_ WARN_INTERNAL,
1147                         "Attempt to free unreferenced glob pointers");
1148         return;
1149     }
1150     if (gp->gp_cv) {
1151         /* Deleting the name of a subroutine invalidates method cache */
1152         PL_sub_generation++;
1153     }
1154     if (--gp->gp_refcnt > 0) {
1155         if (gp->gp_egv == gv)
1156             gp->gp_egv = 0;
1157         return;
1158     }
1159
1160     SvREFCNT_dec(gp->gp_sv);
1161     SvREFCNT_dec(gp->gp_av);
1162     SvREFCNT_dec(gp->gp_hv);
1163     SvREFCNT_dec(gp->gp_io);
1164     SvREFCNT_dec(gp->gp_cv);
1165     SvREFCNT_dec(gp->gp_form);
1166
1167     Safefree(gp);
1168     GvGP(gv) = 0;
1169 }
1170
1171 #if defined(CRIPPLED_CC) && (defined(iAPX286) || defined(M_I286) || defined(I80286))
1172 #define MICROPORT
1173 #endif
1174
1175 #ifdef  MICROPORT       /* Microport 2.4 hack */
1176 AV *GvAVn(gv)
1177 register GV *gv;
1178 {
1179     if (GvGP(gv)->gp_av)
1180         return GvGP(gv)->gp_av;
1181     else
1182         return GvGP(gv_AVadd(gv))->gp_av;
1183 }
1184
1185 HV *GvHVn(gv)
1186 register GV *gv;
1187 {
1188     if (GvGP(gv)->gp_hv)
1189         return GvGP(gv)->gp_hv;
1190     else
1191         return GvGP(gv_HVadd(gv))->gp_hv;
1192 }
1193 #endif                  /* Microport 2.4 hack */
1194
1195 int
1196 Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg)
1197 {
1198     AMT *amtp = (AMT*)mg->mg_ptr;
1199     if (amtp && AMT_AMAGIC(amtp)) {
1200         int i;
1201         for (i = 1; i < NofAMmeth; i++) {
1202             CV *cv = amtp->table[i];
1203             if (cv != Nullcv) {
1204                 SvREFCNT_dec((SV *) cv);
1205                 amtp->table[i] = Nullcv;
1206             }
1207         }
1208     }
1209  return 0;
1210 }
1211
1212 /* Updates and caches the CV's */
1213
1214 bool
1215 Perl_Gv_AMupdate(pTHX_ HV *stash)
1216 {
1217   GV* gv;
1218   CV* cv;
1219   MAGIC* mg=mg_find((SV*)stash,'c');
1220   AMT *amtp = (mg) ? (AMT*)mg->mg_ptr: (AMT *) NULL;
1221   AMT amt;
1222   STRLEN n_a;
1223
1224   if (mg && amtp->was_ok_am == PL_amagic_generation
1225       && amtp->was_ok_sub == PL_sub_generation)
1226       return AMT_OVERLOADED(amtp);
1227   sv_unmagic((SV*)stash, 'c');
1228
1229   DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME(stash)) );
1230
1231   Zero(&amt,1,AMT);
1232   amt.was_ok_am = PL_amagic_generation;
1233   amt.was_ok_sub = PL_sub_generation;
1234   amt.fallback = AMGfallNO;
1235   amt.flags = 0;
1236
1237   {
1238     int filled = 0, have_ovl = 0;
1239     int i, lim = 1;
1240     SV* sv = NULL;
1241
1242     /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
1243
1244     /* Try to find via inheritance. */
1245     gv = gv_fetchmeth(stash, PL_AMG_names[0], 2, -1);
1246     if (gv)
1247         sv = GvSV(gv);
1248
1249     if (!gv)
1250         lim = DESTROY_amg;              /* Skip overloading entries. */
1251     else if (SvTRUE(sv))
1252         amt.fallback=AMGfallYES;
1253     else if (SvOK(sv))
1254         amt.fallback=AMGfallNEVER;
1255
1256     for (i = 1; i < lim; i++)
1257         amt.table[i] = Nullcv;
1258     for (; i < NofAMmeth; i++) {
1259         char *cooky = (char*)PL_AMG_names[i];
1260         /* Human-readable form, for debugging: */
1261         char *cp = (i >= DESTROY_amg ? cooky : AMG_id2name(i));
1262         STRLEN l = strlen(cooky);
1263
1264         DEBUG_o( Perl_deb(aTHX_ "Checking overloading of `%s' in package `%.256s'\n",
1265                      cp, HvNAME(stash)) );
1266         /* don't fill the cache while looking up! */
1267         gv = gv_fetchmeth(stash, cooky, l, -1);
1268         cv = 0;
1269         if (gv && (cv = GvCV(gv))) {
1270             if (GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")
1271                 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "overload")) {
1272                 /* GvSV contains the name of the method. */
1273                 GV *ngv;
1274
1275                 DEBUG_o( Perl_deb(aTHX_ "Resolving method `%.256s' for overloaded `%s' in package `%.256s'\n",
1276                              SvPV(GvSV(gv), n_a), cp, HvNAME(stash)) );
1277                 if (!SvPOK(GvSV(gv))
1278                     || !(ngv = gv_fetchmethod_autoload(stash, SvPVX(GvSV(gv)),
1279                                                        FALSE)))
1280                 {
1281                     /* Can be an import stub (created by `can'). */
1282                     if (GvCVGEN(gv)) {
1283                         Perl_croak(aTHX_ "Stub found while resolving method `%.256s' overloading `%s' in package `%.256s'",
1284                               (SvPOK(GvSV(gv)) ?  SvPVX(GvSV(gv)) : "???" ),
1285                               cp, HvNAME(stash));
1286                     } else
1287                         Perl_croak(aTHX_ "Can't resolve method `%.256s' overloading `%s' in package `%.256s'",
1288                               (SvPOK(GvSV(gv)) ?  SvPVX(GvSV(gv)) : "???" ),
1289                               cp, HvNAME(stash));
1290                 }
1291                 cv = GvCV(gv = ngv);
1292             }
1293             DEBUG_o( Perl_deb(aTHX_ "Overloading `%s' in package `%.256s' via `%.256s::%.256s' \n",
1294                          cp, HvNAME(stash), HvNAME(GvSTASH(CvGV(cv))),
1295                          GvNAME(CvGV(cv))) );
1296             filled = 1;
1297             if (i < DESTROY_amg)
1298                 have_ovl = 1;
1299         }
1300         amt.table[i]=(CV*)SvREFCNT_inc(cv);
1301     }
1302     if (filled) {
1303       AMT_AMAGIC_on(&amt);
1304       if (have_ovl)
1305           AMT_OVERLOADED_on(&amt);
1306       sv_magic((SV*)stash, 0, 'c', (char*)&amt, sizeof(AMT));
1307       return have_ovl;
1308     }
1309   }
1310   /* Here we have no table: */
1311   /* no_table: */
1312   AMT_AMAGIC_off(&amt);
1313   sv_magic((SV*)stash, 0, 'c', (char*)&amt, sizeof(AMTS));
1314   return FALSE;
1315 }
1316
1317
1318 CV*
1319 Perl_gv_handler(pTHX_ HV *stash, I32 id)
1320 {
1321     MAGIC *mg;
1322     AMT *amtp;
1323
1324     if (!stash)
1325         return Nullcv;
1326     mg = mg_find((SV*)stash,'c');
1327     if (!mg) {
1328       do_update:
1329         Gv_AMupdate(stash);
1330         mg = mg_find((SV*)stash,'c');
1331     }
1332     amtp = (AMT*)mg->mg_ptr;
1333     if ( amtp->was_ok_am != PL_amagic_generation
1334          || amtp->was_ok_sub != PL_sub_generation )
1335         goto do_update;
1336     if (AMT_AMAGIC(amtp))
1337         return amtp->table[id];
1338     return Nullcv;
1339 }
1340
1341
1342 SV*
1343 Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
1344 {
1345   MAGIC *mg;
1346   CV *cv;
1347   CV **cvp=NULL, **ocvp=NULL;
1348   AMT *amtp, *oamtp;
1349   int fl=0, off, off1, lr=0, assign=AMGf_assign & flags, notfound=0;
1350   int postpr = 0, force_cpy = 0, assignshift = assign ? 1 : 0;
1351   HV* stash;
1352   if (!(AMGf_noleft & flags) && SvAMAGIC(left)
1353       && (mg = mg_find((SV*)(stash=SvSTASH(SvRV(left))),'c'))
1354       && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
1355                         ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
1356                         : (CV **) NULL))
1357       && ((cv = cvp[off=method+assignshift])
1358           || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
1359                                                           * usual method */
1360                   (fl = 1, cv = cvp[off=method])))) {
1361     lr = -1;                    /* Call method for left argument */
1362   } else {
1363     if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) {
1364       int logic;
1365
1366       /* look for substituted methods */
1367       /* In all the covered cases we should be called with assign==0. */
1368          switch (method) {
1369          case inc_amg:
1370            force_cpy = 1;
1371            if ((cv = cvp[off=add_ass_amg])
1372                || ((cv = cvp[off = add_amg]) && (force_cpy = 0, postpr = 1))) {
1373              right = &PL_sv_yes; lr = -1; assign = 1;
1374            }
1375            break;
1376          case dec_amg:
1377            force_cpy = 1;
1378            if ((cv = cvp[off = subtr_ass_amg])
1379                || ((cv = cvp[off = subtr_amg]) && (force_cpy = 0, postpr=1))) {
1380              right = &PL_sv_yes; lr = -1; assign = 1;
1381            }
1382            break;
1383          case bool__amg:
1384            (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg]));
1385            break;
1386          case numer_amg:
1387            (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg]));
1388            break;
1389          case string_amg:
1390            (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg]));
1391            break;
1392  case not_amg:
1393    (void)((cv = cvp[off=bool__amg])
1394           || (cv = cvp[off=numer_amg])
1395           || (cv = cvp[off=string_amg]));
1396    postpr = 1;
1397    break;
1398          case copy_amg:
1399            {
1400              /*
1401                   * SV* ref causes confusion with the interpreter variable of
1402                   * the same name
1403                   */
1404              SV* tmpRef=SvRV(left);
1405              if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) {
1406                 /*
1407                  * Just to be extra cautious.  Maybe in some
1408                  * additional cases sv_setsv is safe, too.
1409                  */
1410                 SV* newref = newSVsv(tmpRef);
1411                 SvOBJECT_on(newref);
1412                 SvSTASH(newref) = (HV*)SvREFCNT_inc(SvSTASH(tmpRef));
1413                 return newref;
1414              }
1415            }
1416            break;
1417          case abs_amg:
1418            if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg])
1419                && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) {
1420              SV* nullsv=sv_2mortal(newSViv(0));
1421              if (off1==lt_amg) {
1422                SV* lessp = amagic_call(left,nullsv,
1423                                        lt_amg,AMGf_noright);
1424                logic = SvTRUE(lessp);
1425              } else {
1426                SV* lessp = amagic_call(left,nullsv,
1427                                        ncmp_amg,AMGf_noright);
1428                logic = (SvNV(lessp) < 0);
1429              }
1430              if (logic) {
1431                if (off==subtr_amg) {
1432                  right = left;
1433                  left = nullsv;
1434                  lr = 1;
1435                }
1436              } else {
1437                return left;
1438              }
1439            }
1440            break;
1441          case neg_amg:
1442            if ((cv = cvp[off=subtr_amg])) {
1443              right = left;
1444              left = sv_2mortal(newSViv(0));
1445              lr = 1;
1446            }
1447            break;
1448          case int_amg:
1449          case iter_amg:                 /* XXXX Eventually should do to_gv. */
1450              /* FAIL safe */
1451              return NULL;       /* Delegate operation to standard mechanisms. */
1452              break;
1453          case to_sv_amg:
1454          case to_av_amg:
1455          case to_hv_amg:
1456          case to_gv_amg:
1457          case to_cv_amg:
1458              /* FAIL safe */
1459              return left;       /* Delegate operation to standard mechanisms. */
1460              break;
1461          default:
1462            goto not_found;
1463          }
1464          if (!cv) goto not_found;
1465     } else if (!(AMGf_noright & flags) && SvAMAGIC(right)
1466                && (mg = mg_find((SV*)(stash=SvSTASH(SvRV(right))),'c'))
1467                && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
1468                           ? (amtp = (AMT*)mg->mg_ptr)->table
1469                           : (CV **) NULL))
1470                && (cv = cvp[off=method])) { /* Method for right
1471                                              * argument found */
1472       lr=1;
1473     } else if (((ocvp && oamtp->fallback > AMGfallNEVER
1474                  && (cvp=ocvp) && (lr = -1))
1475                 || (cvp && amtp->fallback > AMGfallNEVER && (lr=1)))
1476                && !(flags & AMGf_unary)) {
1477                                 /* We look for substitution for
1478                                  * comparison operations and
1479                                  * concatenation */
1480       if (method==concat_amg || method==concat_ass_amg
1481           || method==repeat_amg || method==repeat_ass_amg) {
1482         return NULL;            /* Delegate operation to string conversion */
1483       }
1484       off = -1;
1485       switch (method) {
1486          case lt_amg:
1487          case le_amg:
1488          case gt_amg:
1489          case ge_amg:
1490          case eq_amg:
1491          case ne_amg:
1492            postpr = 1; off=ncmp_amg; break;
1493          case slt_amg:
1494          case sle_amg:
1495          case sgt_amg:
1496          case sge_amg:
1497          case seq_amg:
1498          case sne_amg:
1499            postpr = 1; off=scmp_amg; break;
1500          }
1501       if (off != -1) cv = cvp[off];
1502       if (!cv) {
1503         goto not_found;
1504       }
1505     } else {
1506     not_found:                  /* No method found, either report or croak */
1507       switch (method) {
1508          case to_sv_amg:
1509          case to_av_amg:
1510          case to_hv_amg:
1511          case to_gv_amg:
1512          case to_cv_amg:
1513              /* FAIL safe */
1514              return left;       /* Delegate operation to standard mechanisms. */
1515              break;
1516       }
1517       if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */
1518         notfound = 1; lr = -1;
1519       } else if (cvp && (cv=cvp[nomethod_amg])) {
1520         notfound = 1; lr = 1;
1521       } else {
1522         SV *msg;
1523         if (off==-1) off=method;
1524         msg = sv_2mortal(Perl_newSVpvf(aTHX_
1525                       "Operation `%s': no method found,%sargument %s%s%s%s",
1526                       AMG_id2name(method + assignshift),
1527                       (flags & AMGf_unary ? " " : "\n\tleft "),
1528                       SvAMAGIC(left)?
1529                         "in overloaded package ":
1530                         "has no overloaded magic",
1531                       SvAMAGIC(left)?
1532                         HvNAME(SvSTASH(SvRV(left))):
1533                         "",
1534                       SvAMAGIC(right)?
1535                         ",\n\tright argument in overloaded package ":
1536                         (flags & AMGf_unary
1537                          ? ""
1538                          : ",\n\tright argument has no overloaded magic"),
1539                       SvAMAGIC(right)?
1540                         HvNAME(SvSTASH(SvRV(right))):
1541                         ""));
1542         if (amtp && amtp->fallback >= AMGfallYES) {
1543           DEBUG_o( Perl_deb(aTHX_ "%s", SvPVX(msg)) );
1544         } else {
1545           Perl_croak(aTHX_ "%"SVf, msg);
1546         }
1547         return NULL;
1548       }
1549       force_cpy = force_cpy || assign;
1550     }
1551   }
1552   if (!notfound) {
1553     DEBUG_o( Perl_deb(aTHX_
1554   "Overloaded operator `%s'%s%s%s:\n\tmethod%s found%s in package %s%s\n",
1555                  AMG_id2name(off),
1556                  method+assignshift==off? "" :
1557                              " (initially `",
1558                  method+assignshift==off? "" :
1559                              AMG_id2name(method+assignshift),
1560                  method+assignshift==off? "" : "')",
1561                  flags & AMGf_unary? "" :
1562                    lr==1 ? " for right argument": " for left argument",
1563                  flags & AMGf_unary? " for argument" : "",
1564                  HvNAME(stash),
1565                  fl? ",\n\tassignment variant used": "") );
1566   }
1567     /* Since we use shallow copy during assignment, we need
1568      * to dublicate the contents, probably calling user-supplied
1569      * version of copy operator
1570      */
1571     /* We need to copy in following cases:
1572      * a) Assignment form was called.
1573      *          assignshift==1,  assign==T, method + 1 == off
1574      * b) Increment or decrement, called directly.
1575      *          assignshift==0,  assign==0, method + 0 == off
1576      * c) Increment or decrement, translated to assignment add/subtr.
1577      *          assignshift==0,  assign==T,
1578      *          force_cpy == T
1579      * d) Increment or decrement, translated to nomethod.
1580      *          assignshift==0,  assign==0,
1581      *          force_cpy == T
1582      * e) Assignment form translated to nomethod.
1583      *          assignshift==1,  assign==T, method + 1 != off
1584      *          force_cpy == T
1585      */
1586     /*  off is method, method+assignshift, or a result of opcode substitution.
1587      *  In the latter case assignshift==0, so only notfound case is important.
1588      */
1589   if (( (method + assignshift == off)
1590         && (assign || (method == inc_amg) || (method == dec_amg)))
1591       || force_cpy)
1592     RvDEEPCP(left);
1593   {
1594     dSP;
1595     BINOP myop;
1596     SV* res;
1597     bool oldcatch = CATCH_GET;
1598
1599     CATCH_SET(TRUE);
1600     Zero(&myop, 1, BINOP);
1601     myop.op_last = (OP *) &myop;
1602     myop.op_next = Nullop;
1603     myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
1604
1605     PUSHSTACKi(PERLSI_OVERLOAD);
1606     ENTER;
1607     SAVEOP();
1608     PL_op = (OP *) &myop;
1609     if (PERLDB_SUB && PL_curstash != PL_debstash)
1610         PL_op->op_private |= OPpENTERSUB_DB;
1611     PUTBACK;
1612     pp_pushmark();
1613
1614     EXTEND(SP, notfound + 5);
1615     PUSHs(lr>0? right: left);
1616     PUSHs(lr>0? left: right);
1617     PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no ));
1618     if (notfound) {
1619       PUSHs( sv_2mortal(newSVpv(AMG_id2name(method + assignshift),0)));
1620     }
1621     PUSHs((SV*)cv);
1622     PUTBACK;
1623
1624     if ((PL_op = Perl_pp_entersub(aTHX)))
1625       CALLRUNOPS(aTHX);
1626     LEAVE;
1627     SPAGAIN;
1628
1629     res=POPs;
1630     PUTBACK;
1631     POPSTACK;
1632     CATCH_SET(oldcatch);
1633
1634     if (postpr) {
1635       int ans;
1636       switch (method) {
1637       case le_amg:
1638       case sle_amg:
1639         ans=SvIV(res)<=0; break;
1640       case lt_amg:
1641       case slt_amg:
1642         ans=SvIV(res)<0; break;
1643       case ge_amg:
1644       case sge_amg:
1645         ans=SvIV(res)>=0; break;
1646       case gt_amg:
1647       case sgt_amg:
1648         ans=SvIV(res)>0; break;
1649       case eq_amg:
1650       case seq_amg:
1651         ans=SvIV(res)==0; break;
1652       case ne_amg:
1653       case sne_amg:
1654         ans=SvIV(res)!=0; break;
1655       case inc_amg:
1656       case dec_amg:
1657         SvSetSV(left,res); return left;
1658       case not_amg:
1659         ans=!SvTRUE(res); break;
1660       }
1661       return boolSV(ans);
1662     } else if (method==copy_amg) {
1663       if (!SvROK(res)) {
1664         Perl_croak(aTHX_ "Copy method did not return a reference");
1665       }
1666       return SvREFCNT_inc(SvRV(res));
1667     } else {
1668       return res;
1669     }
1670   }
1671 }
1672
1673 /*
1674 =for apidoc is_gv_magical
1675
1676 Returns C<TRUE> if given the name of a magical GV.
1677
1678 Currently only useful internally when determining if a GV should be
1679 created even in rvalue contexts.
1680
1681 C<flags> is not used at present but available for future extension to
1682 allow selecting particular classes of magical variable.
1683
1684 =cut
1685 */
1686 bool
1687 Perl_is_gv_magical(pTHX_ char *name, STRLEN len, U32 flags)
1688 {
1689     if (!len)
1690         return FALSE;
1691
1692     switch (*name) {
1693     case 'I':
1694         if (len == 3 && strEQ(name, "ISA"))
1695             goto yes;
1696         break;
1697     case 'O':
1698         if (len == 8 && strEQ(name, "OVERLOAD"))
1699             goto yes;
1700         break;
1701     case 'S':
1702         if (len == 3 && strEQ(name, "SIG"))
1703             goto yes;
1704         break;
1705     case '\017':   /* $^O & $^OPEN */
1706         if (len == 1
1707             || (len == 4 && strEQ(name, "\027PEN")))
1708         {
1709             goto yes;
1710         }
1711         break;
1712     case '\027':   /* $^W & $^WARNING_BITS */
1713         if (len == 1
1714             || (len == 12 && strEQ(name, "\027ARNING_BITS"))
1715             || (len == 17 && strEQ(name, "\027IDE_SYSTEM_CALLS")))
1716         {
1717             goto yes;
1718         }
1719         break;
1720
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 '|':
1744     case '+':
1745     case ';':
1746     case ']':
1747     case '\001':   /* $^A */
1748     case '\003':   /* $^C */
1749     case '\004':   /* $^D */
1750     case '\005':   /* $^E */
1751     case '\006':   /* $^F */
1752     case '\010':   /* $^H */
1753     case '\011':   /* $^I, NOT \t in EBCDIC */
1754     case '\014':   /* $^L */
1755     case '\020':   /* $^P */
1756     case '\023':   /* $^S */
1757     case '\024':   /* $^T */
1758     case '\026':   /* $^V */
1759         if (len == 1)
1760             goto yes;
1761         break;
1762     case '1':
1763     case '2':
1764     case '3':
1765     case '4':
1766     case '5':
1767     case '6':
1768     case '7':
1769     case '8':
1770     case '9':
1771         if (len > 1) {
1772             char *end = name + len;
1773             while (--end > name) {
1774                 if (!isDIGIT(*end))
1775                     return FALSE;
1776             }
1777         }
1778     yes:
1779         return TRUE;
1780     default:
1781         break;
1782     }
1783     return FALSE;
1784 }