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     SV* sv = NULL;
1211
1212     /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
1213
1214     /* Try to find via inheritance. */
1215     gv = gv_fetchmeth(stash, PL_AMG_names[0], 2, -1);
1216     if (gv)
1217         sv = GvSV(gv);
1218
1219     if (!gv)
1220         lim = DESTROY_amg;              /* Skip overloading entries. */
1221     else if (SvTRUE(sv))
1222         amt.fallback=AMGfallYES;
1223     else if (SvOK(sv))
1224         amt.fallback=AMGfallNEVER;
1225
1226     for (i = 1; i < lim; i++)
1227         amt.table[i] = Nullcv;
1228     for (; i < NofAMmeth; i++) {
1229         char *cooky = (char*)PL_AMG_names[i];
1230         /* Human-readable form, for debugging: */
1231         char *cp = (i >= DESTROY_amg ? cooky : AMG_id2name(i));
1232         STRLEN l = strlen(cooky);
1233
1234         DEBUG_o( Perl_deb(aTHX_ "Checking overloading of `%s' in package `%.256s'\n",
1235                      cp, HvNAME(stash)) );
1236         /* don't fill the cache while looking up! */
1237         gv = gv_fetchmeth(stash, cooky, l, -1);
1238         cv = 0;
1239         if (gv && (cv = GvCV(gv))) {
1240             if (GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")
1241                 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "overload")) {
1242                 /* GvSV contains the name of the method. */
1243                 GV *ngv;
1244
1245                 DEBUG_o( Perl_deb(aTHX_ "Resolving method `%.256s' for overloaded `%s' in package `%.256s'\n",
1246                              SvPV(GvSV(gv), n_a), cp, HvNAME(stash)) );
1247                 if (!SvPOK(GvSV(gv))
1248                     || !(ngv = gv_fetchmethod_autoload(stash, SvPVX(GvSV(gv)),
1249                                                        FALSE)))
1250                 {
1251                     /* Can be an import stub (created by `can'). */
1252                     if (GvCVGEN(gv)) {
1253                         Perl_croak(aTHX_ "Stub found while resolving method `%.256s' overloading `%s' in package `%.256s'",
1254                               (SvPOK(GvSV(gv)) ?  SvPVX(GvSV(gv)) : "???" ),
1255                               cp, HvNAME(stash));
1256                     } else
1257                         Perl_croak(aTHX_ "Can't resolve method `%.256s' overloading `%s' in package `%.256s'",
1258                               (SvPOK(GvSV(gv)) ?  SvPVX(GvSV(gv)) : "???" ),
1259                               cp, HvNAME(stash));
1260                 }
1261                 cv = GvCV(gv = ngv);
1262             }
1263             DEBUG_o( Perl_deb(aTHX_ "Overloading `%s' in package `%.256s' via `%.256s::%.256s' \n",
1264                          cp, HvNAME(stash), HvNAME(GvSTASH(CvGV(cv))),
1265                          GvNAME(CvGV(cv))) );
1266             filled = 1;
1267             if (i < DESTROY_amg)
1268                 have_ovl = 1;
1269         }
1270         amt.table[i]=(CV*)SvREFCNT_inc(cv);
1271     }
1272     if (filled) {
1273       AMT_AMAGIC_on(&amt);
1274       if (have_ovl)
1275           AMT_OVERLOADED_on(&amt);
1276       sv_magic((SV*)stash, 0, 'c', (char*)&amt, sizeof(AMT));
1277       return have_ovl;
1278     }
1279   }
1280   /* Here we have no table: */
1281   /* no_table: */
1282   AMT_AMAGIC_off(&amt);
1283   sv_magic((SV*)stash, 0, 'c', (char*)&amt, sizeof(AMTS));
1284   return FALSE;
1285 }
1286
1287
1288 CV*
1289 Perl_gv_handler(pTHX_ HV *stash, I32 id)
1290 {
1291     dTHR;
1292     MAGIC *mg;
1293     AMT *amtp;
1294
1295     if (!stash)
1296         return Nullcv;
1297     mg = mg_find((SV*)stash,'c');
1298     if (!mg) {
1299       do_update:
1300         Gv_AMupdate(stash);
1301         mg = mg_find((SV*)stash,'c');
1302     }
1303     amtp = (AMT*)mg->mg_ptr;
1304     if ( amtp->was_ok_am != PL_amagic_generation
1305          || amtp->was_ok_sub != PL_sub_generation )
1306         goto do_update;
1307     if (AMT_AMAGIC(amtp))
1308         return amtp->table[id];
1309     return Nullcv;
1310 }
1311
1312
1313 SV*
1314 Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
1315 {
1316   MAGIC *mg;
1317   CV *cv;
1318   CV **cvp=NULL, **ocvp=NULL;
1319   AMT *amtp, *oamtp;
1320   int fl=0, off, off1, lr=0, assign=AMGf_assign & flags, notfound=0;
1321   int postpr = 0, force_cpy = 0, assignshift = assign ? 1 : 0;
1322   HV* stash;
1323   if (!(AMGf_noleft & flags) && SvAMAGIC(left)
1324       && (mg = mg_find((SV*)(stash=SvSTASH(SvRV(left))),'c'))
1325       && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
1326                         ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
1327                         : (CV **) NULL))
1328       && ((cv = cvp[off=method+assignshift])
1329           || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
1330                                                           * usual method */
1331                   (fl = 1, cv = cvp[off=method])))) {
1332     lr = -1;                    /* Call method for left argument */
1333   } else {
1334     if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) {
1335       int logic;
1336
1337       /* look for substituted methods */
1338       /* In all the covered cases we should be called with assign==0. */
1339          switch (method) {
1340          case inc_amg:
1341            force_cpy = 1;
1342            if ((cv = cvp[off=add_ass_amg])
1343                || ((cv = cvp[off = add_amg]) && (force_cpy = 0, postpr = 1))) {
1344              right = &PL_sv_yes; lr = -1; assign = 1;
1345            }
1346            break;
1347          case dec_amg:
1348            force_cpy = 1;
1349            if ((cv = cvp[off = subtr_ass_amg])
1350                || ((cv = cvp[off = subtr_amg]) && (force_cpy = 0, postpr=1))) {
1351              right = &PL_sv_yes; lr = -1; assign = 1;
1352            }
1353            break;
1354          case bool__amg:
1355            (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg]));
1356            break;
1357          case numer_amg:
1358            (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg]));
1359            break;
1360          case string_amg:
1361            (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg]));
1362            break;
1363  case not_amg:
1364    (void)((cv = cvp[off=bool__amg])
1365           || (cv = cvp[off=numer_amg])
1366           || (cv = cvp[off=string_amg]));
1367    postpr = 1;
1368    break;
1369          case copy_amg:
1370            {
1371              /*
1372                   * SV* ref causes confusion with the interpreter variable of
1373                   * the same name
1374                   */
1375              SV* tmpRef=SvRV(left);
1376              if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) {
1377                 /*
1378                  * Just to be extra cautious.  Maybe in some
1379                  * additional cases sv_setsv is safe, too.
1380                  */
1381                 SV* newref = newSVsv(tmpRef);
1382                 SvOBJECT_on(newref);
1383                 SvSTASH(newref) = (HV*)SvREFCNT_inc(SvSTASH(tmpRef));
1384                 return newref;
1385              }
1386            }
1387            break;
1388          case abs_amg:
1389            if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg])
1390                && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) {
1391              SV* nullsv=sv_2mortal(newSViv(0));
1392              if (off1==lt_amg) {
1393                SV* lessp = amagic_call(left,nullsv,
1394                                        lt_amg,AMGf_noright);
1395                logic = SvTRUE(lessp);
1396              } else {
1397                SV* lessp = amagic_call(left,nullsv,
1398                                        ncmp_amg,AMGf_noright);
1399                logic = (SvNV(lessp) < 0);
1400              }
1401              if (logic) {
1402                if (off==subtr_amg) {
1403                  right = left;
1404                  left = nullsv;
1405                  lr = 1;
1406                }
1407              } else {
1408                return left;
1409              }
1410            }
1411            break;
1412          case neg_amg:
1413            if ((cv = cvp[off=subtr_amg])) {
1414              right = left;
1415              left = sv_2mortal(newSViv(0));
1416              lr = 1;
1417            }
1418            break;
1419          case int_amg:
1420          case iter_amg:                 /* XXXX Eventually should do to_gv. */
1421              /* FAIL safe */
1422              return NULL;       /* Delegate operation to standard mechanisms. */
1423              break;
1424          case to_sv_amg:
1425          case to_av_amg:
1426          case to_hv_amg:
1427          case to_gv_amg:
1428          case to_cv_amg:
1429              /* FAIL safe */
1430              return left;       /* Delegate operation to standard mechanisms. */
1431              break;
1432          default:
1433            goto not_found;
1434          }
1435          if (!cv) goto not_found;
1436     } else if (!(AMGf_noright & flags) && SvAMAGIC(right)
1437                && (mg = mg_find((SV*)(stash=SvSTASH(SvRV(right))),'c'))
1438                && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
1439                           ? (amtp = (AMT*)mg->mg_ptr)->table
1440                           : (CV **) NULL))
1441                && (cv = cvp[off=method])) { /* Method for right
1442                                              * argument found */
1443       lr=1;
1444     } else if (((ocvp && oamtp->fallback > AMGfallNEVER
1445                  && (cvp=ocvp) && (lr = -1))
1446                 || (cvp && amtp->fallback > AMGfallNEVER && (lr=1)))
1447                && !(flags & AMGf_unary)) {
1448                                 /* We look for substitution for
1449                                  * comparison operations and
1450                                  * concatenation */
1451       if (method==concat_amg || method==concat_ass_amg
1452           || method==repeat_amg || method==repeat_ass_amg) {
1453         return NULL;            /* Delegate operation to string conversion */
1454       }
1455       off = -1;
1456       switch (method) {
1457          case lt_amg:
1458          case le_amg:
1459          case gt_amg:
1460          case ge_amg:
1461          case eq_amg:
1462          case ne_amg:
1463            postpr = 1; off=ncmp_amg; break;
1464          case slt_amg:
1465          case sle_amg:
1466          case sgt_amg:
1467          case sge_amg:
1468          case seq_amg:
1469          case sne_amg:
1470            postpr = 1; off=scmp_amg; break;
1471          }
1472       if (off != -1) cv = cvp[off];
1473       if (!cv) {
1474         goto not_found;
1475       }
1476     } else {
1477     not_found:                  /* No method found, either report or croak */
1478       switch (method) {
1479          case to_sv_amg:
1480          case to_av_amg:
1481          case to_hv_amg:
1482          case to_gv_amg:
1483          case to_cv_amg:
1484              /* FAIL safe */
1485              return left;       /* Delegate operation to standard mechanisms. */
1486              break;
1487       }
1488       if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */
1489         notfound = 1; lr = -1;
1490       } else if (cvp && (cv=cvp[nomethod_amg])) {
1491         notfound = 1; lr = 1;
1492       } else {
1493         SV *msg;
1494         if (off==-1) off=method;
1495         msg = sv_2mortal(Perl_newSVpvf(aTHX_
1496                       "Operation `%s': no method found,%sargument %s%s%s%s",
1497                       AMG_id2name(method + assignshift),
1498                       (flags & AMGf_unary ? " " : "\n\tleft "),
1499                       SvAMAGIC(left)?
1500                         "in overloaded package ":
1501                         "has no overloaded magic",
1502                       SvAMAGIC(left)?
1503                         HvNAME(SvSTASH(SvRV(left))):
1504                         "",
1505                       SvAMAGIC(right)?
1506                         ",\n\tright argument in overloaded package ":
1507                         (flags & AMGf_unary
1508                          ? ""
1509                          : ",\n\tright argument has no overloaded magic"),
1510                       SvAMAGIC(right)?
1511                         HvNAME(SvSTASH(SvRV(right))):
1512                         ""));
1513         if (amtp && amtp->fallback >= AMGfallYES) {
1514           DEBUG_o( Perl_deb(aTHX_ "%s", SvPVX(msg)) );
1515         } else {
1516           Perl_croak(aTHX_ "%"SVf, msg);
1517         }
1518         return NULL;
1519       }
1520       force_cpy = force_cpy || assign;
1521     }
1522   }
1523   if (!notfound) {
1524     DEBUG_o( Perl_deb(aTHX_
1525   "Overloaded operator `%s'%s%s%s:\n\tmethod%s found%s in package %s%s\n",
1526                  AMG_id2name(off),
1527                  method+assignshift==off? "" :
1528                              " (initially `",
1529                  method+assignshift==off? "" :
1530                              AMG_id2name(method+assignshift),
1531                  method+assignshift==off? "" : "')",
1532                  flags & AMGf_unary? "" :
1533                    lr==1 ? " for right argument": " for left argument",
1534                  flags & AMGf_unary? " for argument" : "",
1535                  HvNAME(stash),
1536                  fl? ",\n\tassignment variant used": "") );
1537   }
1538     /* Since we use shallow copy during assignment, we need
1539      * to dublicate the contents, probably calling user-supplied
1540      * version of copy operator
1541      */
1542     /* We need to copy in following cases:
1543      * a) Assignment form was called.
1544      *          assignshift==1,  assign==T, method + 1 == off
1545      * b) Increment or decrement, called directly.
1546      *          assignshift==0,  assign==0, method + 0 == off
1547      * c) Increment or decrement, translated to assignment add/subtr.
1548      *          assignshift==0,  assign==T,
1549      *          force_cpy == T
1550      * d) Increment or decrement, translated to nomethod.
1551      *          assignshift==0,  assign==0,
1552      *          force_cpy == T
1553      * e) Assignment form translated to nomethod.
1554      *          assignshift==1,  assign==T, method + 1 != off
1555      *          force_cpy == T
1556      */
1557     /*  off is method, method+assignshift, or a result of opcode substitution.
1558      *  In the latter case assignshift==0, so only notfound case is important.
1559      */
1560   if (( (method + assignshift == off)
1561         && (assign || (method == inc_amg) || (method == dec_amg)))
1562       || force_cpy)
1563     RvDEEPCP(left);
1564   {
1565     dSP;
1566     BINOP myop;
1567     SV* res;
1568     bool oldcatch = CATCH_GET;
1569
1570     CATCH_SET(TRUE);
1571     Zero(&myop, 1, BINOP);
1572     myop.op_last = (OP *) &myop;
1573     myop.op_next = Nullop;
1574     myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
1575
1576     PUSHSTACKi(PERLSI_OVERLOAD);
1577     ENTER;
1578     SAVEOP();
1579     PL_op = (OP *) &myop;
1580     if (PERLDB_SUB && PL_curstash != PL_debstash)
1581         PL_op->op_private |= OPpENTERSUB_DB;
1582     PUTBACK;
1583     pp_pushmark();
1584
1585     EXTEND(SP, notfound + 5);
1586     PUSHs(lr>0? right: left);
1587     PUSHs(lr>0? left: right);
1588     PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no ));
1589     if (notfound) {
1590       PUSHs( sv_2mortal(newSVpv(AMG_id2name(method + assignshift),0)));
1591     }
1592     PUSHs((SV*)cv);
1593     PUTBACK;
1594
1595     if ((PL_op = Perl_pp_entersub(aTHX)))
1596       CALLRUNOPS(aTHX);
1597     LEAVE;
1598     SPAGAIN;
1599
1600     res=POPs;
1601     PUTBACK;
1602     POPSTACK;
1603     CATCH_SET(oldcatch);
1604
1605     if (postpr) {
1606       int ans;
1607       switch (method) {
1608       case le_amg:
1609       case sle_amg:
1610         ans=SvIV(res)<=0; break;
1611       case lt_amg:
1612       case slt_amg:
1613         ans=SvIV(res)<0; break;
1614       case ge_amg:
1615       case sge_amg:
1616         ans=SvIV(res)>=0; break;
1617       case gt_amg:
1618       case sgt_amg:
1619         ans=SvIV(res)>0; break;
1620       case eq_amg:
1621       case seq_amg:
1622         ans=SvIV(res)==0; break;
1623       case ne_amg:
1624       case sne_amg:
1625         ans=SvIV(res)!=0; break;
1626       case inc_amg:
1627       case dec_amg:
1628         SvSetSV(left,res); return left;
1629       case not_amg:
1630         ans=!SvTRUE(res); break;
1631       }
1632       return boolSV(ans);
1633     } else if (method==copy_amg) {
1634       if (!SvROK(res)) {
1635         Perl_croak(aTHX_ "Copy method did not return a reference");
1636       }
1637       return SvREFCNT_inc(SvRV(res));
1638     } else {
1639       return res;
1640     }
1641   }
1642 }
1643
1644 /*
1645 =for apidoc is_gv_magical
1646
1647 Returns C<TRUE> if given the name of a magical GV.
1648
1649 Currently only useful internally when determining if a GV should be
1650 created even in rvalue contexts.
1651
1652 C<flags> is not used at present but available for future extension to
1653 allow selecting particular classes of magical variable.
1654
1655 =cut
1656 */
1657 bool
1658 Perl_is_gv_magical(pTHX_ char *name, STRLEN len, U32 flags)
1659 {
1660     if (!len)
1661         return FALSE;
1662
1663     switch (*name) {
1664     case 'I':
1665         if (len == 3 && strEQ(name, "ISA"))
1666             goto yes;
1667         break;
1668     case 'O':
1669         if (len == 8 && strEQ(name, "OVERLOAD"))
1670             goto yes;
1671         break;
1672     case 'S':
1673         if (len == 3 && strEQ(name, "SIG"))
1674             goto yes;
1675         break;
1676     case '\017':   /* $^O & $^OPEN */
1677         if (len == 1
1678             || (len == 4 && strEQ(name, "\027PEN")))
1679         {
1680             goto yes;
1681         }
1682         break;
1683     case '\027':   /* $^W & $^WARNING_BITS */
1684         if (len == 1
1685             || (len == 12 && strEQ(name, "\027ARNING_BITS"))
1686             || (len == 17 && strEQ(name, "\027IDE_SYSTEM_CALLS")))
1687         {
1688             goto yes;
1689         }
1690         break;
1691
1692     case '&':
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 '\001':   /* $^A */
1719     case '\003':   /* $^C */
1720     case '\004':   /* $^D */
1721     case '\005':   /* $^E */
1722     case '\006':   /* $^F */
1723     case '\010':   /* $^H */
1724     case '\011':   /* $^I, NOT \t in EBCDIC */
1725     case '\014':   /* $^L */
1726     case '\020':   /* $^P */
1727     case '\023':   /* $^S */
1728     case '\024':   /* $^T */
1729     case '\026':   /* $^V */
1730         if (len == 1)
1731             goto yes;
1732         break;
1733     case '1':
1734     case '2':
1735     case '3':
1736     case '4':
1737     case '5':
1738     case '6':
1739     case '7':
1740     case '8':
1741     case '9':
1742         if (len > 1) {
1743             char *end = name + len;
1744             while (--end > name) {
1745                 if (!isDIGIT(*end))
1746                     return FALSE;
1747             }
1748         }
1749     yes:
1750         return TRUE;
1751     default:
1752         break;
1753     }
1754     return FALSE;
1755 }