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 (isLEXWARN_on && isALPHA(name[0]) && ! ckWARN(WARN_ONCE))
 735         GvMULTI_on(gv) ;
 736
 737     /* set up magic where warranted */
 738     switch (*name) {
 739     case 'A':
 740         if (strEQ(name, "ARGV")) {
 741             IoFLAGS(GvIOn(gv)) |= IOf_ARGV|IOf_START;
 742         }
 743         break;
 744     case 'E':
 745         if (strnEQ(name, "EXPORT", 6))
 746             GvMULTI_on(gv);
 747         break;
 748     case 'I':
 749         if (strEQ(name, "ISA")) {
 750             AV* av = GvAVn(gv);
 751             GvMULTI_on(gv);
 752             sv_magic((SV*)av, (SV*)gv, 'I', Nullch, 0);
 753             /* NOTE: No support for tied ISA */
 754             if ((add & GV_ADDMULTI) && strEQ(nambeg,"AnyDBM_File::ISA")
 755                 && AvFILLp(av) == -1)
 756             {
 757                 char *pname;
 758                 av_push(av, newSVpvn(pname = "NDBM_File",9));
 759                 gv_stashpvn(pname, 9, TRUE);
 760                 av_push(av, newSVpvn(pname = "DB_File",7));
 761                 gv_stashpvn(pname, 7, TRUE);
 762                 av_push(av, newSVpvn(pname = "GDBM_File",9));
 763                 gv_stashpvn(pname, 9, TRUE);
 764                 av_push(av, newSVpvn(pname = "SDBM_File",9));
 765                 gv_stashpvn(pname, 9, TRUE);
 766                 av_push(av, newSVpvn(pname = "ODBM_File",9));
 767                 gv_stashpvn(pname, 9, TRUE);
 768             }
 769         }
 770         break;
 771     case 'O':
 772         if (strEQ(name, "OVERLOAD")) {
 773             HV* hv = GvHVn(gv);
 774             GvMULTI_on(gv);
 775             hv_magic(hv, Nullgv, 'A');
 776         }
 777         break;
 778     case 'S':
 779         if (strEQ(name, "SIG")) {
 780             HV *hv;
 781             I32 i;
 782             if (!PL_psig_ptr) {
 783                 Newz(73, PL_psig_ptr,  SIG_SIZE, SV*);
 784                 Newz(73, PL_psig_name, SIG_SIZE, SV*);
 785                 Newz(73, PL_psig_pend, SIG_SIZE, int);
 786             }
 787             GvMULTI_on(gv);
 788             hv = GvHVn(gv);
 789             hv_magic(hv, Nullgv, 'S');
 790             for (i = 1; i < SIG_SIZE; i++) {
 791                 SV ** init;
 792                 init = hv_fetch(hv, PL_sig_name[i], strlen(PL_sig_name[i]), 1);
 793                 if (init)
 794                     sv_setsv(*init, &PL_sv_undef);
 795                 PL_psig_ptr[i] = 0;
 796                 PL_psig_name[i] = 0;
 797                 PL_psig_pend[i] = 0;
 798             }
 799         }
 800         break;
 801     case 'V':
 802         if (strEQ(name, "VERSION"))
 803             GvMULTI_on(gv);
 804         break;
 805
 806     case '&':
 807         if (len > 1)
 808             break;
 809         PL_sawampersand = TRUE;
 810         goto ro_magicalize;
 811
 812     case '`':
 813         if (len > 1)
 814             break;
 815         PL_sawampersand = TRUE;
 816         goto ro_magicalize;
 817
 818     case '\'':
 819         if (len > 1)
 820             break;
 821         PL_sawampersand = TRUE;
 822         goto ro_magicalize;
 823
 824     case ':':
 825         if (len > 1)
 826             break;
 827         sv_setpv(GvSV(gv),PL_chopset);
 828         goto magicalize;
 829
 830     case '?':
 831         if (len > 1)
 832             break;
 833 #ifdef COMPLEX_STATUS
 834         (void)SvUPGRADE(GvSV(gv), SVt_PVLV);
 835 #endif
 836         goto magicalize;
 837
 838     case '!':
 839         if (len > 1)
 840             break;
 841
 842         /* If %! has been used, automatically load Errno.pm.
 843            The require will itself set errno, so in order to
 844            preserve its value we have to set up the magic
 845            now (rather than going to magicalize)
 846         */
 847
 848         sv_magic(GvSV(gv), (SV*)gv, 0, name, len);
 849
 850         if (sv_type == SVt_PVHV)
 851             require_errno(gv);
 852
 853         break;
 854     case '-':
 855         if (len > 1)
 856             break;
 857         else {
 858             AV* av = GvAVn(gv);
 859             sv_magic((SV*)av, Nullsv, 'D', Nullch, 0);
 860             SvREADONLY_on(av);
 861         }
 862         goto magicalize;
 863     case '#':
 864     case '*':
 865         if (ckWARN(WARN_DEPRECATED) && len == 1 && sv_type == SVt_PV)
 866             Perl_warner(aTHX_ WARN_DEPRECATED, "Use of $%s is deprecated", name);
 867         /* FALL THROUGH */
 868     case '[':
 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 '\001':        /* $^A */
 882     case '\003':        /* $^C */
 883     case '\004':        /* $^D */
 884     case '\005':        /* $^E */
 885     case '\006':        /* $^F */
 886     case '\010':        /* $^H */
 887     case '\011':        /* $^I, NOT \t in EBCDIC */
 888     case '\020':        /* $^P */
 889     case '\024':        /* $^T */
 890         if (len > 1)
 891             break;
 892         goto magicalize;
 893     case '|':
 894         if (len > 1)
 895             break;
 896         sv_setiv(GvSV(gv), (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0);
 897         goto magicalize;
 898     case '\017':        /* $^O & $^OPEN */
 899         if (len > 1 && strNE(name, "\017PEN"))
 900             break;
 901         goto magicalize;
 902     case '\023':        /* $^S */
 903         if (len > 1)
 904             break;
 905         goto ro_magicalize;
 906     case '\027':        /* $^W & $^WARNING_BITS */
 907         if (len > 1 && strNE(name, "\027ARNING_BITS")
 908             && strNE(name, "\027IDE_SYSTEM_CALLS"))
 909             break;
 910         goto magicalize;
 911
 912     case '+':
 913         if (len > 1)
 914             break;
 915         else {
 916             AV* av = GvAVn(gv);
 917             sv_magic((SV*)av, (SV*)av, 'D', Nullch, 0);
 918             SvREADONLY_on(av);
 919         }
 920         /* FALL THROUGH */
 921     case '1':
 922     case '2':
 923     case '3':
 924     case '4':
 925     case '5':
 926     case '6':
 927     case '7':
 928     case '8':
 929     case '9':
 930       ro_magicalize:
 931         SvREADONLY_on(GvSV(gv));
 932       magicalize:
 933         sv_magic(GvSV(gv), (SV*)gv, 0, name, len);
 934         break;
 935
 936     case '\014':        /* $^L */
 937         if (len > 1)
 938             break;
 939         sv_setpv(GvSV(gv),"\f");
 940         PL_formfeed = GvSV(gv);
 941         break;
 942     case ';':
 943         if (len > 1)
 944             break;
 945         sv_setpv(GvSV(gv),"\034");
 946         break;
 947     case ']':
 948         if (len == 1) {
 949             SV *sv = GvSV(gv);
 950             (void)SvUPGRADE(sv, SVt_PVNV);
 951             Perl_sv_setpvf(aTHX_ sv,
 952 #if defined(PERL_SUBVERSION) && (PERL_SUBVERSION > 0)
 953                             "%8.6"
 954 #else
 955                             "%5.3"
 956 #endif
 957                             NVff,
 958                             SvNVX(PL_patchlevel));
 959             SvNVX(sv) = SvNVX(PL_patchlevel);
 960             SvNOK_on(sv);
 961             SvREADONLY_on(sv);
 962         }
 963         break;
 964     case '\026':        /* $^V */
 965         if (len == 1) {
 966             SV *sv = GvSV(gv);
 967             GvSV(gv) = SvREFCNT_inc(PL_patchlevel);
 968             SvREFCNT_dec(sv);
 969         }
 970         break;
 971     }
 972     return gv;
 973 }
 974
 975 void
 976 Perl_gv_fullname4(pTHX_ SV *sv, GV *gv, const char *prefix, bool keepmain)
 977 {
 978     HV *hv = GvSTASH(gv);
 979     if (!hv) {
 980         (void)SvOK_off(sv);
 981         return;
 982     }
 983     sv_setpv(sv, prefix ? prefix : "");
 984     if (keepmain || strNE(HvNAME(hv), "main")) {
 985         sv_catpv(sv,HvNAME(hv));
 986         sv_catpvn(sv,"::", 2);
 987     }
 988     sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv));
 989 }
 990
 991 void
 992 Perl_gv_fullname3(pTHX_ SV *sv, GV *gv, const char *prefix)
 993 {
 994     HV *hv = GvSTASH(gv);
 995     if (!hv) {
 996         (void)SvOK_off(sv);
 997         return;
 998     }
 999     sv_setpv(sv, prefix ? prefix : "");
1000     sv_catpv(sv,HvNAME(hv));
1001     sv_catpvn(sv,"::", 2);
1002     sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv));
1003 }
1004
1005 void
1006 Perl_gv_efullname4(pTHX_ SV *sv, GV *gv, const char *prefix, bool keepmain)
1007 {
1008     GV *egv = GvEGV(gv);
1009     if (!egv)
1010         egv = gv;
1011     gv_fullname4(sv, egv, prefix, keepmain);
1012 }
1013
1014 void
1015 Perl_gv_efullname3(pTHX_ SV *sv, GV *gv, const char *prefix)
1016 {
1017     GV *egv = GvEGV(gv);
1018     if (!egv)
1019         egv = gv;
1020     gv_fullname3(sv, egv, prefix);
1021 }
1022
1023 /* XXX compatibility with versions <= 5.003. */
1024 void
1025 Perl_gv_fullname(pTHX_ SV *sv, GV *gv)
1026 {
1027     gv_fullname3(sv, gv, sv == (SV*)gv ? "*" : "");
1028 }
1029
1030 /* XXX compatibility with versions <= 5.003. */
1031 void
1032 Perl_gv_efullname(pTHX_ SV *sv, GV *gv)
1033 {
1034     gv_efullname3(sv, gv, sv == (SV*)gv ? "*" : "");
1035 }
1036
1037 IO *
1038 Perl_newIO(pTHX)
1039 {
1040     IO *io;
1041     GV *iogv;
1042
1043     io = (IO*)NEWSV(0,0);
1044     sv_upgrade((SV *)io,SVt_PVIO);
1045     SvREFCNT(io) = 1;
1046     SvOBJECT_on(io);
1047     iogv = gv_fetchpv("FileHandle::", FALSE, SVt_PVHV);
1048     /* unless exists($main::{FileHandle}) and defined(%main::FileHandle::) */
1049     if (!(iogv && GvHV(iogv) && HvARRAY(GvHV(iogv))))
1050       iogv = gv_fetchpv("IO::Handle::", TRUE, SVt_PVHV);
1051     SvSTASH(io) = (HV*)SvREFCNT_inc(GvHV(iogv));
1052     return io;
1053 }
1054
1055 void
1056 Perl_gv_check(pTHX_ HV *stash)
1057 {
1058     register HE *entry;
1059     register I32 i;
1060     register GV *gv;
1061     HV *hv;
1062
1063     if (!HvARRAY(stash))
1064         return;
1065     for (i = 0; i <= (I32) HvMAX(stash); i++) {
1066         for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
1067             if (HeKEY(entry)[HeKLEN(entry)-1] == ':' &&
1068                 (gv = (GV*)HeVAL(entry)) && (hv = GvHV(gv)) && HvNAME(hv))
1069             {
1070                 if (hv != PL_defstash && hv != stash)
1071                      gv_check(hv);              /* nested package */
1072             }
1073             else if (isALPHA(*HeKEY(entry))) {
1074                 char *file;
1075                 gv = (GV*)HeVAL(entry);
1076                 if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv))
1077                     continue;
1078                 file = GvFILE(gv);
1079                 /* performance hack: if filename is absolute and it's a standard
1080                  * module, don't bother warning */
1081                 if (file
1082                     && PERL_FILE_IS_ABSOLUTE(file)
1083                     && (instr(file, "/lib/") || instr(file, ".pm")))
1084                 {
1085                     continue;
1086                 }
1087                 CopLINE_set(PL_curcop, GvLINE(gv));
1088 #ifdef USE_ITHREADS
1089                 CopFILE(PL_curcop) = file;      /* set for warning */
1090 #else
1091                 CopFILEGV(PL_curcop) = gv_fetchfile(file);
1092 #endif
1093                 Perl_warner(aTHX_ WARN_ONCE,
1094                         "Name \"%s::%s\" used only once: possible typo",
1095                         HvNAME(stash), GvNAME(gv));
1096             }
1097         }
1098     }
1099 }
1100
1101 GV *
1102 Perl_newGVgen(pTHX_ char *pack)
1103 {
1104     return gv_fetchpv(Perl_form(aTHX_ "%s::_GEN_%ld", pack, (long)PL_gensym++),
1105                       TRUE, SVt_PVGV);
1106 }
1107
1108 /* hopefully this is only called on local symbol table entries */
1109
1110 GP*
1111 Perl_gp_ref(pTHX_ GP *gp)
1112 {
1113     if (!gp)
1114         return (GP*)NULL;
1115     gp->gp_refcnt++;
1116     if (gp->gp_cv) {
1117         if (gp->gp_cvgen) {
1118             /* multi-named GPs cannot be used for method cache */
1119             SvREFCNT_dec(gp->gp_cv);
1120             gp->gp_cv = Nullcv;
1121             gp->gp_cvgen = 0;
1122         }
1123         else {
1124             /* Adding a new name to a subroutine invalidates method cache */
1125             PL_sub_generation++;
1126         }
1127     }
1128     return gp;
1129 }
1130
1131 void
1132 Perl_gp_free(pTHX_ GV *gv)
1133 {
1134     GP* gp;
1135
1136     if (!gv || !(gp = GvGP(gv)))
1137         return;
1138     if (gp->gp_refcnt == 0) {
1139         if (ckWARN_d(WARN_INTERNAL))
1140             Perl_warner(aTHX_ WARN_INTERNAL,
1141                         "Attempt to free unreferenced glob pointers");
1142         return;
1143     }
1144     if (gp->gp_cv) {
1145         /* Deleting the name of a subroutine invalidates method cache */
1146         PL_sub_generation++;
1147     }
1148     if (--gp->gp_refcnt > 0) {
1149         if (gp->gp_egv == gv)
1150             gp->gp_egv = 0;
1151         return;
1152     }
1153
1154     SvREFCNT_dec(gp->gp_sv);
1155     SvREFCNT_dec(gp->gp_av);
1156     SvREFCNT_dec(gp->gp_hv);
1157     SvREFCNT_dec(gp->gp_io);
1158     SvREFCNT_dec(gp->gp_cv);
1159     SvREFCNT_dec(gp->gp_form);
1160
1161     Safefree(gp);
1162     GvGP(gv) = 0;
1163 }
1164
1165 #if defined(CRIPPLED_CC) && (defined(iAPX286) || defined(M_I286) || defined(I80286))
1166 #define MICROPORT
1167 #endif
1168
1169 #ifdef  MICROPORT       /* Microport 2.4 hack */
1170 AV *GvAVn(gv)
1171 register GV *gv;
1172 {
1173     if (GvGP(gv)->gp_av)
1174         return GvGP(gv)->gp_av;
1175     else
1176         return GvGP(gv_AVadd(gv))->gp_av;
1177 }
1178
1179 HV *GvHVn(gv)
1180 register GV *gv;
1181 {
1182     if (GvGP(gv)->gp_hv)
1183         return GvGP(gv)->gp_hv;
1184     else
1185         return GvGP(gv_HVadd(gv))->gp_hv;
1186 }
1187 #endif                  /* Microport 2.4 hack */
1188
1189 int
1190 Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg)
1191 {
1192     AMT *amtp = (AMT*)mg->mg_ptr;
1193     if (amtp && AMT_AMAGIC(amtp)) {
1194         int i;
1195         for (i = 1; i < NofAMmeth; i++) {
1196             CV *cv = amtp->table[i];
1197             if (cv != Nullcv) {
1198                 SvREFCNT_dec((SV *) cv);
1199                 amtp->table[i] = Nullcv;
1200             }
1201         }
1202     }
1203  return 0;
1204 }
1205
1206 /* Updates and caches the CV's */
1207
1208 bool
1209 Perl_Gv_AMupdate(pTHX_ HV *stash)
1210 {
1211   GV* gv;
1212   CV* cv;
1213   MAGIC* mg=mg_find((SV*)stash,'c');
1214   AMT *amtp = (mg) ? (AMT*)mg->mg_ptr: (AMT *) NULL;
1215   AMT amt;
1216   STRLEN n_a;
1217
1218   if (mg && amtp->was_ok_am == PL_amagic_generation
1219       && amtp->was_ok_sub == PL_sub_generation)
1220       return AMT_OVERLOADED(amtp);
1221   sv_unmagic((SV*)stash, 'c');
1222
1223   DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME(stash)) );
1224
1225   Zero(&amt,1,AMT);
1226   amt.was_ok_am = PL_amagic_generation;
1227   amt.was_ok_sub = PL_sub_generation;
1228   amt.fallback = AMGfallNO;
1229   amt.flags = 0;
1230
1231   {
1232     int filled = 0, have_ovl = 0;
1233     int i, lim = 1;
1234     SV* sv = NULL;
1235
1236     /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
1237
1238     /* Try to find via inheritance. */
1239     gv = gv_fetchmeth(stash, PL_AMG_names[0], 2, -1);
1240     if (gv)
1241         sv = GvSV(gv);
1242
1243     if (!gv)
1244         lim = DESTROY_amg;              /* Skip overloading entries. */
1245     else if (SvTRUE(sv))
1246         amt.fallback=AMGfallYES;
1247     else if (SvOK(sv))
1248         amt.fallback=AMGfallNEVER;
1249
1250     for (i = 1; i < lim; i++)
1251         amt.table[i] = Nullcv;
1252     for (; i < NofAMmeth; i++) {
1253         char *cooky = (char*)PL_AMG_names[i];
1254         /* Human-readable form, for debugging: */
1255         char *cp = (i >= DESTROY_amg ? cooky : AMG_id2name(i));
1256         STRLEN l = strlen(cooky);
1257
1258         DEBUG_o( Perl_deb(aTHX_ "Checking overloading of `%s' in package `%.256s'\n",
1259                      cp, HvNAME(stash)) );
1260         /* don't fill the cache while looking up! */
1261         gv = gv_fetchmeth(stash, cooky, l, -1);
1262         cv = 0;
1263         if (gv && (cv = GvCV(gv))) {
1264             if (GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")
1265                 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "overload")) {
1266                 /* GvSV contains the name of the method. */
1267                 GV *ngv;
1268
1269                 DEBUG_o( Perl_deb(aTHX_ "Resolving method `%.256s' for overloaded `%s' in package `%.256s'\n",
1270                              SvPV(GvSV(gv), n_a), cp, HvNAME(stash)) );
1271                 if (!SvPOK(GvSV(gv))
1272                     || !(ngv = gv_fetchmethod_autoload(stash, SvPVX(GvSV(gv)),
1273                                                        FALSE)))
1274                 {
1275                     /* Can be an import stub (created by `can'). */
1276                     if (GvCVGEN(gv)) {
1277                         Perl_croak(aTHX_ "Stub found while resolving method `%.256s' overloading `%s' in package `%.256s'",
1278                               (SvPOK(GvSV(gv)) ?  SvPVX(GvSV(gv)) : "???" ),
1279                               cp, HvNAME(stash));
1280                     } else
1281                         Perl_croak(aTHX_ "Can't resolve method `%.256s' overloading `%s' in package `%.256s'",
1282                               (SvPOK(GvSV(gv)) ?  SvPVX(GvSV(gv)) : "???" ),
1283                               cp, HvNAME(stash));
1284                 }
1285                 cv = GvCV(gv = ngv);
1286             }
1287             DEBUG_o( Perl_deb(aTHX_ "Overloading `%s' in package `%.256s' via `%.256s::%.256s' \n",
1288                          cp, HvNAME(stash), HvNAME(GvSTASH(CvGV(cv))),
1289                          GvNAME(CvGV(cv))) );
1290             filled = 1;
1291             if (i < DESTROY_amg)
1292                 have_ovl = 1;
1293         }
1294         amt.table[i]=(CV*)SvREFCNT_inc(cv);
1295     }
1296     if (filled) {
1297       AMT_AMAGIC_on(&amt);
1298       if (have_ovl)
1299           AMT_OVERLOADED_on(&amt);
1300       sv_magic((SV*)stash, 0, 'c', (char*)&amt, sizeof(AMT));
1301       return have_ovl;
1302     }
1303   }
1304   /* Here we have no table: */
1305   /* no_table: */
1306   AMT_AMAGIC_off(&amt);
1307   sv_magic((SV*)stash, 0, 'c', (char*)&amt, sizeof(AMTS));
1308   return FALSE;
1309 }
1310
1311
1312 CV*
1313 Perl_gv_handler(pTHX_ HV *stash, I32 id)
1314 {
1315     dTHR;
1316     MAGIC *mg;
1317     AMT *amtp;
1318
1319     if (!stash)
1320         return Nullcv;
1321     mg = mg_find((SV*)stash,'c');
1322     if (!mg) {
1323       do_update:
1324         Gv_AMupdate(stash);
1325         mg = mg_find((SV*)stash,'c');
1326     }
1327     amtp = (AMT*)mg->mg_ptr;
1328     if ( amtp->was_ok_am != PL_amagic_generation
1329          || amtp->was_ok_sub != PL_sub_generation )
1330         goto do_update;
1331     if (AMT_AMAGIC(amtp))
1332         return amtp->table[id];
1333     return Nullcv;
1334 }
1335
1336
1337 SV*
1338 Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
1339 {
1340   MAGIC *mg;
1341   CV *cv;
1342   CV **cvp=NULL, **ocvp=NULL;
1343   AMT *amtp, *oamtp;
1344   int fl=0, off, off1, lr=0, assign=AMGf_assign & flags, notfound=0;
1345   int postpr = 0, force_cpy = 0, assignshift = assign ? 1 : 0;
1346   HV* stash;
1347   if (!(AMGf_noleft & flags) && SvAMAGIC(left)
1348       && (mg = mg_find((SV*)(stash=SvSTASH(SvRV(left))),'c'))
1349       && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
1350                         ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
1351                         : (CV **) NULL))
1352       && ((cv = cvp[off=method+assignshift])
1353           || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
1354                                                           * usual method */
1355                   (fl = 1, cv = cvp[off=method])))) {
1356     lr = -1;                    /* Call method for left argument */
1357   } else {
1358     if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) {
1359       int logic;
1360
1361       /* look for substituted methods */
1362       /* In all the covered cases we should be called with assign==0. */
1363          switch (method) {
1364          case inc_amg:
1365            force_cpy = 1;
1366            if ((cv = cvp[off=add_ass_amg])
1367                || ((cv = cvp[off = add_amg]) && (force_cpy = 0, postpr = 1))) {
1368              right = &PL_sv_yes; lr = -1; assign = 1;
1369            }
1370            break;
1371          case dec_amg:
1372            force_cpy = 1;
1373            if ((cv = cvp[off = subtr_ass_amg])
1374                || ((cv = cvp[off = subtr_amg]) && (force_cpy = 0, postpr=1))) {
1375              right = &PL_sv_yes; lr = -1; assign = 1;
1376            }
1377            break;
1378          case bool__amg:
1379            (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg]));
1380            break;
1381          case numer_amg:
1382            (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg]));
1383            break;
1384          case string_amg:
1385            (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg]));
1386            break;
1387  case not_amg:
1388    (void)((cv = cvp[off=bool__amg])
1389           || (cv = cvp[off=numer_amg])
1390           || (cv = cvp[off=string_amg]));
1391    postpr = 1;
1392    break;
1393          case copy_amg:
1394            {
1395              /*
1396                   * SV* ref causes confusion with the interpreter variable of
1397                   * the same name
1398                   */
1399              SV* tmpRef=SvRV(left);
1400              if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) {
1401                 /*
1402                  * Just to be extra cautious.  Maybe in some
1403                  * additional cases sv_setsv is safe, too.
1404                  */
1405                 SV* newref = newSVsv(tmpRef);
1406                 SvOBJECT_on(newref);
1407                 SvSTASH(newref) = (HV*)SvREFCNT_inc(SvSTASH(tmpRef));
1408                 return newref;
1409              }
1410            }
1411            break;
1412          case abs_amg:
1413            if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg])
1414                && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) {
1415              SV* nullsv=sv_2mortal(newSViv(0));
1416              if (off1==lt_amg) {
1417                SV* lessp = amagic_call(left,nullsv,
1418                                        lt_amg,AMGf_noright);
1419                logic = SvTRUE(lessp);
1420              } else {
1421                SV* lessp = amagic_call(left,nullsv,
1422                                        ncmp_amg,AMGf_noright);
1423                logic = (SvNV(lessp) < 0);
1424              }
1425              if (logic) {
1426                if (off==subtr_amg) {
1427                  right = left;
1428                  left = nullsv;
1429                  lr = 1;
1430                }
1431              } else {
1432                return left;
1433              }
1434            }
1435            break;
1436          case neg_amg:
1437            if ((cv = cvp[off=subtr_amg])) {
1438              right = left;
1439              left = sv_2mortal(newSViv(0));
1440              lr = 1;
1441            }
1442            break;
1443          case int_amg:
1444          case iter_amg:                 /* XXXX Eventually should do to_gv. */
1445              /* FAIL safe */
1446              return NULL;       /* Delegate operation to standard mechanisms. */
1447              break;
1448          case to_sv_amg:
1449          case to_av_amg:
1450          case to_hv_amg:
1451          case to_gv_amg:
1452          case to_cv_amg:
1453              /* FAIL safe */
1454              return left;       /* Delegate operation to standard mechanisms. */
1455              break;
1456          default:
1457            goto not_found;
1458          }
1459          if (!cv) goto not_found;
1460     } else if (!(AMGf_noright & flags) && SvAMAGIC(right)
1461                && (mg = mg_find((SV*)(stash=SvSTASH(SvRV(right))),'c'))
1462                && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
1463                           ? (amtp = (AMT*)mg->mg_ptr)->table
1464                           : (CV **) NULL))
1465                && (cv = cvp[off=method])) { /* Method for right
1466                                              * argument found */
1467       lr=1;
1468     } else if (((ocvp && oamtp->fallback > AMGfallNEVER
1469                  && (cvp=ocvp) && (lr = -1))
1470                 || (cvp && amtp->fallback > AMGfallNEVER && (lr=1)))
1471                && !(flags & AMGf_unary)) {
1472                                 /* We look for substitution for
1473                                  * comparison operations and
1474                                  * concatenation */
1475       if (method==concat_amg || method==concat_ass_amg
1476           || method==repeat_amg || method==repeat_ass_amg) {
1477         return NULL;            /* Delegate operation to string conversion */
1478       }
1479       off = -1;
1480       switch (method) {
1481          case lt_amg:
1482          case le_amg:
1483          case gt_amg:
1484          case ge_amg:
1485          case eq_amg:
1486          case ne_amg:
1487            postpr = 1; off=ncmp_amg; break;
1488          case slt_amg:
1489          case sle_amg:
1490          case sgt_amg:
1491          case sge_amg:
1492          case seq_amg:
1493          case sne_amg:
1494            postpr = 1; off=scmp_amg; break;
1495          }
1496       if (off != -1) cv = cvp[off];
1497       if (!cv) {
1498         goto not_found;
1499       }
1500     } else {
1501     not_found:                  /* No method found, either report or croak */
1502       switch (method) {
1503          case to_sv_amg:
1504          case to_av_amg:
1505          case to_hv_amg:
1506          case to_gv_amg:
1507          case to_cv_amg:
1508              /* FAIL safe */
1509              return left;       /* Delegate operation to standard mechanisms. */
1510              break;
1511       }
1512       if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */
1513         notfound = 1; lr = -1;
1514       } else if (cvp && (cv=cvp[nomethod_amg])) {
1515         notfound = 1; lr = 1;
1516       } else {
1517         SV *msg;
1518         if (off==-1) off=method;
1519         msg = sv_2mortal(Perl_newSVpvf(aTHX_
1520                       "Operation `%s': no method found,%sargument %s%s%s%s",
1521                       AMG_id2name(method + assignshift),
1522                       (flags & AMGf_unary ? " " : "\n\tleft "),
1523                       SvAMAGIC(left)?
1524                         "in overloaded package ":
1525                         "has no overloaded magic",
1526                       SvAMAGIC(left)?
1527                         HvNAME(SvSTASH(SvRV(left))):
1528                         "",
1529                       SvAMAGIC(right)?
1530                         ",\n\tright argument in overloaded package ":
1531                         (flags & AMGf_unary
1532                          ? ""
1533                          : ",\n\tright argument has no overloaded magic"),
1534                       SvAMAGIC(right)?
1535                         HvNAME(SvSTASH(SvRV(right))):
1536                         ""));
1537         if (amtp && amtp->fallback >= AMGfallYES) {
1538           DEBUG_o( Perl_deb(aTHX_ "%s", SvPVX(msg)) );
1539         } else {
1540           Perl_croak(aTHX_ "%"SVf, msg);
1541         }
1542         return NULL;
1543       }
1544       force_cpy = force_cpy || assign;
1545     }
1546   }
1547   if (!notfound) {
1548     DEBUG_o( Perl_deb(aTHX_
1549   "Overloaded operator `%s'%s%s%s:\n\tmethod%s found%s in package %s%s\n",
1550                  AMG_id2name(off),
1551                  method+assignshift==off? "" :
1552                              " (initially `",
1553                  method+assignshift==off? "" :
1554                              AMG_id2name(method+assignshift),
1555                  method+assignshift==off? "" : "')",
1556                  flags & AMGf_unary? "" :
1557                    lr==1 ? " for right argument": " for left argument",
1558                  flags & AMGf_unary? " for argument" : "",
1559                  HvNAME(stash),
1560                  fl? ",\n\tassignment variant used": "") );
1561   }
1562     /* Since we use shallow copy during assignment, we need
1563      * to dublicate the contents, probably calling user-supplied
1564      * version of copy operator
1565      */
1566     /* We need to copy in following cases:
1567      * a) Assignment form was called.
1568      *          assignshift==1,  assign==T, method + 1 == off
1569      * b) Increment or decrement, called directly.
1570      *          assignshift==0,  assign==0, method + 0 == off
1571      * c) Increment or decrement, translated to assignment add/subtr.
1572      *          assignshift==0,  assign==T,
1573      *          force_cpy == T
1574      * d) Increment or decrement, translated to nomethod.
1575      *          assignshift==0,  assign==0,
1576      *          force_cpy == T
1577      * e) Assignment form translated to nomethod.
1578      *          assignshift==1,  assign==T, method + 1 != off
1579      *          force_cpy == T
1580      */
1581     /*  off is method, method+assignshift, or a result of opcode substitution.
1582      *  In the latter case assignshift==0, so only notfound case is important.
1583      */
1584   if (( (method + assignshift == off)
1585         && (assign || (method == inc_amg) || (method == dec_amg)))
1586       || force_cpy)
1587     RvDEEPCP(left);
1588   {
1589     dSP;
1590     BINOP myop;
1591     SV* res;
1592     bool oldcatch = CATCH_GET;
1593
1594     CATCH_SET(TRUE);
1595     Zero(&myop, 1, BINOP);
1596     myop.op_last = (OP *) &myop;
1597     myop.op_next = Nullop;
1598     myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
1599
1600     PUSHSTACKi(PERLSI_OVERLOAD);
1601     ENTER;
1602     SAVEOP();
1603     PL_op = (OP *) &myop;
1604     if (PERLDB_SUB && PL_curstash != PL_debstash)
1605         PL_op->op_private |= OPpENTERSUB_DB;
1606     PUTBACK;
1607     pp_pushmark();
1608
1609     EXTEND(SP, notfound + 5);
1610     PUSHs(lr>0? right: left);
1611     PUSHs(lr>0? left: right);
1612     PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no ));
1613     if (notfound) {
1614       PUSHs( sv_2mortal(newSVpv(AMG_id2name(method + assignshift),0)));
1615     }
1616     PUSHs((SV*)cv);
1617     PUTBACK;
1618
1619     if ((PL_op = Perl_pp_entersub(aTHX)))
1620       CALLRUNOPS(aTHX);
1621     LEAVE;
1622     SPAGAIN;
1623
1624     res=POPs;
1625     PUTBACK;
1626     POPSTACK;
1627     CATCH_SET(oldcatch);
1628
1629     if (postpr) {
1630       int ans;
1631       switch (method) {
1632       case le_amg:
1633       case sle_amg:
1634         ans=SvIV(res)<=0; break;
1635       case lt_amg:
1636       case slt_amg:
1637         ans=SvIV(res)<0; break;
1638       case ge_amg:
1639       case sge_amg:
1640         ans=SvIV(res)>=0; break;
1641       case gt_amg:
1642       case sgt_amg:
1643         ans=SvIV(res)>0; break;
1644       case eq_amg:
1645       case seq_amg:
1646         ans=SvIV(res)==0; break;
1647       case ne_amg:
1648       case sne_amg:
1649         ans=SvIV(res)!=0; break;
1650       case inc_amg:
1651       case dec_amg:
1652         SvSetSV(left,res); return left;
1653       case not_amg:
1654         ans=!SvTRUE(res); break;
1655       }
1656       return boolSV(ans);
1657     } else if (method==copy_amg) {
1658       if (!SvROK(res)) {
1659         Perl_croak(aTHX_ "Copy method did not return a reference");
1660       }
1661       return SvREFCNT_inc(SvRV(res));
1662     } else {
1663       return res;
1664     }
1665   }
1666 }
1667
1668 /*
1669 =for apidoc is_gv_magical
1670
1671 Returns C<TRUE> if given the name of a magical GV.
1672
1673 Currently only useful internally when determining if a GV should be
1674 created even in rvalue contexts.
1675
1676 C<flags> is not used at present but available for future extension to
1677 allow selecting particular classes of magical variable.
1678
1679 =cut
1680 */
1681 bool
1682 Perl_is_gv_magical(pTHX_ char *name, STRLEN len, U32 flags)
1683 {
1684     if (!len)
1685         return FALSE;
1686
1687     switch (*name) {
1688     case 'I':
1689         if (len == 3 && strEQ(name, "ISA"))
1690             goto yes;
1691         break;
1692     case 'O':
1693         if (len == 8 && strEQ(name, "OVERLOAD"))
1694             goto yes;
1695         break;
1696     case 'S':
1697         if (len == 3 && strEQ(name, "SIG"))
1698             goto yes;
1699         break;
1700     case '\017':   /* $^O & $^OPEN */
1701         if (len == 1
1702             || (len == 4 && strEQ(name, "\027PEN")))
1703         {
1704             goto yes;
1705         }
1706         break;
1707     case '\027':   /* $^W & $^WARNING_BITS */
1708         if (len == 1
1709             || (len == 12 && strEQ(name, "\027ARNING_BITS"))
1710             || (len == 17 && strEQ(name, "\027IDE_SYSTEM_CALLS")))
1711         {
1712             goto yes;
1713         }
1714         break;
1715
1716     case '&':
1717     case '`':
1718     case '\'':
1719     case ':':
1720     case '?':
1721     case '!':
1722     case '-':
1723     case '#':
1724     case '*':
1725     case '[':
1726     case '^':
1727     case '~':
1728     case '=':
1729     case '%':
1730     case '.':
1731     case '(':
1732     case ')':
1733     case '<':
1734     case '>':
1735     case ',':
1736     case '\\':
1737     case '/':
1738     case '|':
1739     case '+':
1740     case ';':
1741     case ']':
1742     case '\001':   /* $^A */
1743     case '\003':   /* $^C */
1744     case '\004':   /* $^D */
1745     case '\005':   /* $^E */
1746     case '\006':   /* $^F */
1747     case '\010':   /* $^H */
1748     case '\011':   /* $^I, NOT \t in EBCDIC */
1749     case '\014':   /* $^L */
1750     case '\020':   /* $^P */
1751     case '\023':   /* $^S */
1752     case '\024':   /* $^T */
1753     case '\026':   /* $^V */
1754         if (len == 1)
1755             goto yes;
1756         break;
1757     case '1':
1758     case '2':
1759     case '3':
1760     case '4':
1761     case '5':
1762     case '6':
1763     case '7':
1764     case '8':
1765     case '9':
1766         if (len > 1) {
1767             char *end = name + len;
1768             while (--end > name) {
1769                 if (!isDIGIT(*end))
1770                     return FALSE;
1771             }
1772         }
1773     yes:
1774         return TRUE;
1775     default:
1776         break;
1777     }
1778     return FALSE;
1779 }