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