gv.c

   1 /*    gv.c
   2  *
   3  *    Copyright (c) 1991-2002, 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 /*
  20 =head1 GV Functions
  21 */
  22
  23 #include "EXTERN.h"
  24 #define PERL_IN_GV_C
  25 #include "perl.h"
  26
  27 GV *
  28 Perl_gv_AVadd(pTHX_ register GV *gv)
  29 {
  30     if (!gv || SvTYPE((SV*)gv) != SVt_PVGV)
  31         Perl_croak(aTHX_ "Bad symbol for array");
  32     if (!GvAV(gv))
  33         GvAV(gv) = newAV();
  34     return gv;
  35 }
  36
  37 GV *
  38 Perl_gv_HVadd(pTHX_ register GV *gv)
  39 {
  40     if (!gv || SvTYPE((SV*)gv) != SVt_PVGV)
  41         Perl_croak(aTHX_ "Bad symbol for hash");
  42     if (!GvHV(gv))
  43         GvHV(gv) = newHV();
  44     return gv;
  45 }
  46
  47 GV *
  48 Perl_gv_IOadd(pTHX_ register GV *gv)
  49 {
  50     if (!gv || SvTYPE((SV*)gv) != SVt_PVGV)
  51         Perl_croak(aTHX_ "Bad symbol for filehandle");
  52     if (!GvIOp(gv)) {
  53 #ifdef GV_UNIQUE_CHECK
  54         if (GvUNIQUE(gv)) {
  55             Perl_croak(aTHX_ "Bad symbol for filehandle (GV is unique)");
  56         }
  57 #endif
  58         GvIOp(gv) = newIO();
  59     }
  60     return gv;
  61 }
  62
  63 GV *
  64 Perl_gv_fetchfile(pTHX_ const char *name)
  65 {
  66     char smallbuf[256];
  67     char *tmpbuf;
  68     STRLEN tmplen;
  69     GV *gv;
  70
  71     if (!PL_defstash)
  72         return Nullgv;
  73
  74     tmplen = strlen(name) + 2;
  75     if (tmplen < sizeof smallbuf)
  76         tmpbuf = smallbuf;
  77     else
  78         New(603, tmpbuf, tmplen + 1, char);
  79     /* This is where the debugger's %{"::_<$filename"} hash is created */
  80     tmpbuf[0] = '_';
  81     tmpbuf[1] = '<';
  82     strcpy(tmpbuf + 2, name);
  83     gv = *(GV**)hv_fetch(PL_defstash, tmpbuf, tmplen, TRUE);
  84     if (!isGV(gv)) {
  85         gv_init(gv, PL_defstash, tmpbuf, tmplen, FALSE);
  86         sv_setpv(GvSV(gv), name);
  87         if (PERLDB_LINE)
  88             hv_magic(GvHVn(gv_AVadd(gv)), Nullgv, PERL_MAGIC_dbfile);
  89     }
  90     if (tmpbuf != smallbuf)
  91         Safefree(tmpbuf);
  92     return gv;
  93 }
  94
  95 void
  96 Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi)
  97 {
  98     register GP *gp;
  99     bool doproto = SvTYPE(gv) > SVt_NULL;
 100     char *proto = (doproto && SvPOK(gv)) ? SvPVX(gv) : NULL;
 101
 102     sv_upgrade((SV*)gv, SVt_PVGV);
 103     if (SvLEN(gv)) {
 104         if (proto) {
 105             SvPVX(gv) = NULL;
 106             SvLEN(gv) = 0;
 107             SvPOK_off(gv);
 108         } else
 109             Safefree(SvPVX(gv));
 110     }
 111     Newz(602, gp, 1, GP);
 112     GvGP(gv) = gp_ref(gp);
 113     GvSV(gv) = NEWSV(72,0);
 114     GvLINE(gv) = CopLINE(PL_curcop);
 115     GvFILE(gv) = CopFILE(PL_curcop) ? CopFILE(PL_curcop) : "";
 116     GvCVGEN(gv) = 0;
 117     GvEGV(gv) = gv;
 118     sv_magic((SV*)gv, (SV*)gv, PERL_MAGIC_glob, Nullch, 0);
 119     GvSTASH(gv) = (HV*)SvREFCNT_inc(stash);
 120     GvNAME(gv) = savepvn(name, len);
 121     GvNAMELEN(gv) = len;
 122     if (multi || doproto)              /* doproto means it _was_ mentioned */
 123         GvMULTI_on(gv);
 124     if (doproto) {                      /* Replicate part of newSUB here. */
 125         SvIOK_off(gv);
 126         ENTER;
 127         /* XXX unsafe for threads if eval_owner isn't held */
 128         start_subparse(0,0);            /* Create CV in compcv. */
 129         GvCV(gv) = PL_compcv;
 130         LEAVE;
 131
 132         PL_sub_generation++;
 133         CvGV(GvCV(gv)) = gv;
 134         CvFILE_set_from_cop(GvCV(gv), PL_curcop);
 135         CvSTASH(GvCV(gv)) = PL_curstash;
 136         if (proto) {
 137             sv_setpv((SV*)GvCV(gv), proto);
 138             Safefree(proto);
 139         }
 140     }
 141 }
 142
 143 STATIC void
 144 S_gv_init_sv(pTHX_ GV *gv, I32 sv_type)
 145 {
 146     switch (sv_type) {
 147     case SVt_PVIO:
 148         (void)GvIOn(gv);
 149         break;
 150     case SVt_PVAV:
 151         (void)GvAVn(gv);
 152         break;
 153     case SVt_PVHV:
 154         (void)GvHVn(gv);
 155         break;
 156     }
 157 }
 158
 159 /*
 160 =for apidoc gv_fetchmeth
 161
 162 Returns the glob with the given C<name> and a defined subroutine or
 163 C<NULL>.  The glob lives in the given C<stash>, or in the stashes
 164 accessible via @ISA and UNIVERSAL::.
 165
 166 The argument C<level> should be either 0 or -1.  If C<level==0>, as a
 167 side-effect creates a glob with the given C<name> in the given C<stash>
 168 which in the case of success contains an alias for the subroutine, and sets
 169 up caching info for this glob.  Similarly for all the searched stashes.
 170
 171 This function grants C<"SUPER"> token as a postfix of the stash name. The
 172 GV returned from C<gv_fetchmeth> may be a method cache entry, which is not
 173 visible to Perl code.  So when calling C<call_sv>, you should not use
 174 the GV directly; instead, you should use the method's CV, which can be
 175 obtained from the GV with the C<GvCV> macro.
 176
 177 =cut
 178 */
 179
 180 GV *
 181 Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level)
 182 {
 183     AV* av;
 184     GV* topgv;
 185     GV* gv;
 186     GV** gvp;
 187     CV* cv;
 188
 189     /* UNIVERSAL methods should be callable without a stash */
 190     if (!stash) {
 191         level = -1;  /* probably appropriate */
 192         if(!(stash = gv_stashpvn("UNIVERSAL", 9, FALSE)))
 193             return 0;
 194     }
 195
 196     if ((level > 100) || (level < -100))
 197         Perl_croak(aTHX_ "Recursive inheritance detected while looking for method '%s' in package '%s'",
 198               name, HvNAME(stash));
 199
 200     DEBUG_o( Perl_deb(aTHX_ "Looking for method %s in package %s\n",name,HvNAME(stash)) );
 201
 202     gvp = (GV**)hv_fetch(stash, name, len, (level >= 0));
 203     if (!gvp)
 204         topgv = Nullgv;
 205     else {
 206         topgv = *gvp;
 207         if (SvTYPE(topgv) != SVt_PVGV)
 208             gv_init(topgv, stash, name, len, TRUE);
 209         if ((cv = GvCV(topgv))) {
 210             /* If genuine method or valid cache entry, use it */
 211             if (!GvCVGEN(topgv) || GvCVGEN(topgv) == PL_sub_generation)
 212                 return topgv;
 213             /* Stale cached entry: junk it */
 214             SvREFCNT_dec(cv);
 215             GvCV(topgv) = cv = Nullcv;
 216             GvCVGEN(topgv) = 0;
 217         }
 218         else if (GvCVGEN(topgv) == PL_sub_generation)
 219             return 0;  /* cache indicates sub doesn't exist */
 220     }
 221
 222     gvp = (GV**)hv_fetch(stash, "ISA", 3, FALSE);
 223     av = (gvp && (gv = *gvp) && gv != (GV*)&PL_sv_undef) ? GvAV(gv) : Nullav;
 224
 225     /* create and re-create @.*::SUPER::ISA on demand */
 226     if (!av || !SvMAGIC(av)) {
 227         char* packname = HvNAME(stash);
 228         STRLEN packlen = strlen(packname);
 229
 230         if (packlen >= 7 && strEQ(packname + packlen - 7, "::SUPER")) {
 231             HV* basestash;
 232
 233             packlen -= 7;
 234             basestash = gv_stashpvn(packname, packlen, TRUE);
 235             gvp = (GV**)hv_fetch(basestash, "ISA", 3, FALSE);
 236             if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (av = GvAV(gv))) {
 237                 gvp = (GV**)hv_fetch(stash, "ISA", 3, TRUE);
 238                 if (!gvp || !(gv = *gvp))
 239                     Perl_croak(aTHX_ "Cannot create %s::ISA", HvNAME(stash));
 240                 if (SvTYPE(gv) != SVt_PVGV)
 241                     gv_init(gv, stash, "ISA", 3, TRUE);
 242                 SvREFCNT_dec(GvAV(gv));
 243                 GvAV(gv) = (AV*)SvREFCNT_inc(av);
 244             }
 245         }
 246     }
 247
 248     if (av) {
 249         SV** svp = AvARRAY(av);
 250         /* NOTE: No support for tied ISA */
 251         I32 items = AvFILLp(av) + 1;
 252         while (items--) {
 253             SV* sv = *svp++;
 254             HV* basestash = gv_stashsv(sv, FALSE);
 255             if (!basestash) {
 256                 if (ckWARN(WARN_MISC))
 257                     Perl_warner(aTHX_ packWARN(WARN_MISC), "Can't locate package %s for @%s::ISA",
 258                         SvPVX(sv), HvNAME(stash));
 259                 continue;
 260             }
 261             gv = gv_fetchmeth(basestash, name, len,
 262                               (level >= 0) ? level + 1 : level - 1);
 263             if (gv)
 264                 goto gotcha;
 265         }
 266     }
 267
 268     /* if at top level, try UNIVERSAL */
 269
 270     if (level == 0 || level == -1) {
 271         HV* lastchance;
 272
 273         if ((lastchance = gv_stashpvn("UNIVERSAL", 9, FALSE))) {
 274             if ((gv = gv_fetchmeth(lastchance, name, len,
 275                                   (level >= 0) ? level + 1 : level - 1)))
 276             {
 277           gotcha:
 278                 /*
 279                  * Cache method in topgv if:
 280                  *  1. topgv has no synonyms (else inheritance crosses wires)
 281                  *  2. method isn't a stub (else AUTOLOAD fails spectacularly)
 282                  */
 283                 if (topgv &&
 284                     GvREFCNT(topgv) == 1 &&
 285                     (cv = GvCV(gv)) &&
 286                     (CvROOT(cv) || CvXSUB(cv)))
 287                 {
 288                     if ((cv = GvCV(topgv)))
 289                         SvREFCNT_dec(cv);
 290                     GvCV(topgv) = (CV*)SvREFCNT_inc(GvCV(gv));
 291                     GvCVGEN(topgv) = PL_sub_generation;
 292                 }
 293                 return gv;
 294             }
 295             else if (topgv && GvREFCNT(topgv) == 1) {
 296                 /* cache the fact that the method is not defined */
 297                 GvCVGEN(topgv) = PL_sub_generation;
 298             }
 299         }
 300     }
 301
 302     return 0;
 303 }
 304
 305 /*
 306 =for apidoc gv_fetchmeth_autoload
 307
 308 Same as gv_fetchmeth(), but looks for autoloaded subroutines too.
 309 Returns a glob for the subroutine.
 310
 311 For an autoloaded subroutine without a GV, will create a GV even
 312 if C<level < 0>.  For an autoloaded subroutine without a stub, GvCV()
 313 of the result may be zero.
 314
 315 =cut
 316 */
 317
 318 GV *
 319 Perl_gv_fetchmeth_autoload(pTHX_ HV *stash, const char *name, STRLEN len, I32 level)
 320 {
 321     GV *gv = gv_fetchmeth(stash, name, len, level);
 322
 323     if (!gv) {
 324         char autoload[] = "AUTOLOAD";
 325         STRLEN autolen = sizeof(autoload)-1;
 326         CV *cv;
 327         GV **gvp;
 328
 329         if (!stash)
 330             return Nullgv;      /* UNIVERSAL::AUTOLOAD could cause trouble */
 331         if (len == autolen && strnEQ(name, autoload, autolen))
 332             return Nullgv;
 333         if (!(gv = gv_fetchmeth(stash, autoload, autolen, FALSE)))
 334             return Nullgv;
 335         cv = GvCV(gv);
 336         if (!(CvROOT(cv) || CvXSUB(cv)))
 337             return Nullgv;
 338         /* Have an autoload */
 339         if (level < 0)  /* Cannot do without a stub */
 340             gv_fetchmeth(stash, name, len, 0);
 341         gvp = (GV**)hv_fetch(stash, name, len, (level >= 0));
 342         if (!gvp)
 343             return Nullgv;
 344         return *gvp;
 345     }
 346     return gv;
 347 }
 348
 349 /*
 350 =for apidoc gv_fetchmethod
 351
 352 See L<gv_fetchmethod_autoload>.
 353
 354 =cut
 355 */
 356
 357 GV *
 358 Perl_gv_fetchmethod(pTHX_ HV *stash, const char *name)
 359 {
 360     return gv_fetchmethod_autoload(stash, name, TRUE);
 361 }
 362
 363 /*
 364 =for apidoc gv_fetchmethod_autoload
 365
 366 Returns the glob which contains the subroutine to call to invoke the method
 367 on the C<stash>.  In fact in the presence of autoloading this may be the
 368 glob for "AUTOLOAD".  In this case the corresponding variable $AUTOLOAD is
 369 already setup.
 370
 371 The third parameter of C<gv_fetchmethod_autoload> determines whether
 372 AUTOLOAD lookup is performed if the given method is not present: non-zero
 373 means yes, look for AUTOLOAD; zero means no, don't look for AUTOLOAD.
 374 Calling C<gv_fetchmethod> is equivalent to calling C<gv_fetchmethod_autoload>
 375 with a non-zero C<autoload> parameter.
 376
 377 These functions grant C<"SUPER"> token as a prefix of the method name. Note
 378 that if you want to keep the returned glob for a long time, you need to
 379 check for it being "AUTOLOAD", since at the later time the call may load a
 380 different subroutine due to $AUTOLOAD changing its value. Use the glob
 381 created via a side effect to do this.
 382
 383 These functions have the same side-effects and as C<gv_fetchmeth> with
 384 C<level==0>.  C<name> should be writable if contains C<':'> or C<'
 385 ''>. The warning against passing the GV returned by C<gv_fetchmeth> to
 386 C<call_sv> apply equally to these functions.
 387
 388 =cut
 389 */
 390
 391 GV *
 392 Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload)
 393 {
 394     register const char *nend;
 395     const char *nsplit = 0;
 396     GV* gv;
 397
 398     for (nend = name; *nend; nend++) {
 399         if (*nend == '\'')
 400             nsplit = nend;
 401         else if (*nend == ':' && *(nend + 1) == ':')
 402             nsplit = ++nend;
 403     }
 404     if (nsplit) {
 405         const char *origname = name;
 406         name = nsplit + 1;
 407         if (*nsplit == ':')
 408             --nsplit;
 409         if ((nsplit - origname) == 5 && strnEQ(origname, "SUPER", 5)) {
 410             /* ->SUPER::method should really be looked up in original stash */
 411             SV *tmpstr = sv_2mortal(Perl_newSVpvf(aTHX_ "%s::SUPER",
 412                                                   CopSTASHPV(PL_curcop)));
 413             /* __PACKAGE__::SUPER stash should be autovivified */
 414             stash = gv_stashpvn(SvPVX(tmpstr), SvCUR(tmpstr), TRUE);
 415             DEBUG_o( Perl_deb(aTHX_ "Treating %s as %s::%s\n",
 416                          origname, HvNAME(stash), name) );
 417         }
 418         else {
 419             /* don't autovifify if ->NoSuchStash::method */
 420             stash = gv_stashpvn(origname, nsplit - origname, FALSE);
 421
 422             /* however, explicit calls to Pkg::SUPER::method may
 423                happen, and may require autovivification to work */
 424             if (!stash && (nsplit - origname) >= 7 &&
 425                 strnEQ(nsplit - 7, "::SUPER", 7) &&
 426                 gv_stashpvn(origname, nsplit - origname - 7, FALSE))
 427               stash = gv_stashpvn(origname, nsplit - origname, TRUE);
 428         }
 429     }
 430
 431     gv = gv_fetchmeth(stash, name, nend - name, 0);
 432     if (!gv) {
 433         if (strEQ(name,"import") || strEQ(name,"unimport"))
 434             gv = (GV*)&PL_sv_yes;
 435         else if (autoload)
 436             gv = gv_autoload4(stash, name, nend - name, TRUE);
 437     }
 438     else if (autoload) {
 439         CV* cv = GvCV(gv);
 440         if (!CvROOT(cv) && !CvXSUB(cv)) {
 441             GV* stubgv;
 442             GV* autogv;
 443
 444             if (CvANON(cv))
 445                 stubgv = gv;
 446             else {
 447                 stubgv = CvGV(cv);
 448                 if (GvCV(stubgv) != cv)         /* orphaned import */
 449                     stubgv = gv;
 450             }
 451             autogv = gv_autoload4(GvSTASH(stubgv),
 452                                   GvNAME(stubgv), GvNAMELEN(stubgv), TRUE);
 453             if (autogv)
 454                 gv = autogv;
 455         }
 456     }
 457
 458     return gv;
 459 }
 460
 461 GV*
 462 Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method)
 463 {
 464     char autoload[] = "AUTOLOAD";
 465     STRLEN autolen = sizeof(autoload)-1;
 466     GV* gv;
 467     CV* cv;
 468     HV* varstash;
 469     GV* vargv;
 470     SV* varsv;
 471
 472     if (!stash)
 473         return Nullgv;  /* UNIVERSAL::AUTOLOAD could cause trouble */
 474     if (len == autolen && strnEQ(name, autoload, autolen))
 475         return Nullgv;
 476     if (!(gv = gv_fetchmeth(stash, autoload, autolen, FALSE)))
 477         return Nullgv;
 478     cv = GvCV(gv);
 479
 480     if (!(CvROOT(cv) || CvXSUB(cv)))
 481         return Nullgv;
 482
 483     /*
 484      * Inheriting AUTOLOAD for non-methods works ... for now.
 485      */
 486     if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX) && !method &&
 487         (GvCVGEN(gv) || GvSTASH(gv) != stash))
 488         Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
 489           "Use of inherited AUTOLOAD for non-method %s::%.*s() is deprecated",
 490              HvNAME(stash), (int)len, name);
 491
 492     if (CvXSUB(cv)) {
 493         /* rather than lookup/init $AUTOLOAD here
 494          * only to have the XSUB do another lookup for $AUTOLOAD
 495          * and split that value on the last '::',
 496          * pass along the same data via some unused fields in the CV
 497          */
 498         CvSTASH(cv) = stash;
 499         SvPVX(cv) = (char *)name; /* cast to lose constness warning */
 500         SvCUR(cv) = len;
 501         return gv;
 502     }
 503
 504     /*
 505      * Given &FOO::AUTOLOAD, set $FOO::AUTOLOAD to desired function name.
 506      * The subroutine's original name may not be "AUTOLOAD", so we don't
 507      * use that, but for lack of anything better we will use the sub's
 508      * original package to look up $AUTOLOAD.
 509      */
 510     varstash = GvSTASH(CvGV(cv));
 511     vargv = *(GV**)hv_fetch(varstash, autoload, autolen, TRUE);
 512     ENTER;
 513
 514     if (!isGV(vargv))
 515         gv_init(vargv, varstash, autoload, autolen, FALSE);
 516     LEAVE;
 517     varsv = GvSV(vargv);
 518     sv_setpv(varsv, HvNAME(stash));
 519     sv_catpvn(varsv, "::", 2);
 520     sv_catpvn(varsv, name, len);
 521     SvTAINTED_off(varsv);
 522     return gv;
 523 }
 524
 525 /* The "gv" parameter should be the glob known to Perl code as *!
 526  * The scalar must already have been magicalized.
 527  */
 528 STATIC void
 529 S_require_errno(pTHX_ GV *gv)
 530 {
 531     HV* stash = gv_stashpvn("Errno",5,FALSE);
 532
 533     if (!stash || !(gv_fetchmethod(stash, "TIEHASH"))) {
 534         dSP;
 535         PUTBACK;
 536         ENTER;
 537         save_scalar(gv); /* keep the value of $! */
 538         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
 539                          newSVpvn("Errno",5), Nullsv);
 540         LEAVE;
 541         SPAGAIN;
 542         stash = gv_stashpvn("Errno",5,FALSE);
 543         if (!stash || !(gv_fetchmethod(stash, "TIEHASH")))
 544             Perl_croak(aTHX_ "Can't use %%! because Errno.pm is not available");
 545     }
 546 }
 547
 548 /*
 549 =for apidoc gv_stashpv
 550
 551 Returns a pointer to the stash for a specified package.  C<name> should
 552 be a valid UTF-8 string.  If C<create> is set then the package will be
 553 created if it does not already exist.  If C<create> is not set and the
 554 package does not exist then NULL is returned.
 555
 556 =cut
 557 */
 558
 559 HV*
 560 Perl_gv_stashpv(pTHX_ const char *name, I32 create)
 561 {
 562     return gv_stashpvn(name, strlen(name), create);
 563 }
 564
 565 HV*
 566 Perl_gv_stashpvn(pTHX_ const char *name, U32 namelen, I32 create)
 567 {
 568     char smallbuf[256];
 569     char *tmpbuf;
 570     HV *stash;
 571     GV *tmpgv;
 572
 573     if (namelen + 3 < sizeof smallbuf)
 574         tmpbuf = smallbuf;
 575     else
 576         New(606, tmpbuf, namelen + 3, char);
 577     Copy(name,tmpbuf,namelen,char);
 578     tmpbuf[namelen++] = ':';
 579     tmpbuf[namelen++] = ':';
 580     tmpbuf[namelen] = '\0';
 581     tmpgv = gv_fetchpv(tmpbuf, create, SVt_PVHV);
 582     if (tmpbuf != smallbuf)
 583         Safefree(tmpbuf);
 584     if (!tmpgv)
 585         return 0;
 586     if (!GvHV(tmpgv))
 587         GvHV(tmpgv) = newHV();
 588     stash = GvHV(tmpgv);
 589     if (!HvNAME(stash))
 590         HvNAME(stash) = savepv(name);
 591     return stash;
 592 }
 593
 594 /*
 595 =for apidoc gv_stashsv
 596
 597 Returns a pointer to the stash for a specified package, which must be a
 598 valid UTF-8 string.  See C<gv_stashpv>.
 599
 600 =cut
 601 */
 602
 603 HV*
 604 Perl_gv_stashsv(pTHX_ SV *sv, I32 create)
 605 {
 606     register char *ptr;
 607     STRLEN len;
 608     ptr = SvPV(sv,len);
 609     return gv_stashpvn(ptr, len, create);
 610 }
 611
 612
 613 GV *
 614 Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type)
 615 {
 616     register const char *name = nambeg;
 617     register GV *gv = 0;
 618     GV**gvp;
 619     I32 len;
 620     register const char *namend;
 621     HV *stash = 0;
 622
 623     if (*name == '*' && isALPHA(name[1])) /* accidental stringify on a GV? */
 624         name++;
 625
 626     for (namend = name; *namend; namend++) {
 627         if ((*namend == ':' && namend[1] == ':')
 628             || (*namend == '\'' && namend[1]))
 629         {
 630             if (!stash)
 631                 stash = PL_defstash;
 632             if (!stash || !SvREFCNT(stash)) /* symbol table under destruction */
 633                 return Nullgv;
 634
 635             len = namend - name;
 636             if (len > 0) {
 637                 char smallbuf[256];
 638                 char *tmpbuf;
 639
 640                 if (len + 3 < sizeof (smallbuf))
 641                     tmpbuf = smallbuf;
 642                 else
 643                     New(601, tmpbuf, len+3, char);
 644                 Copy(name, tmpbuf, len, char);
 645                 tmpbuf[len++] = ':';
 646                 tmpbuf[len++] = ':';
 647                 tmpbuf[len] = '\0';
 648                 gvp = (GV**)hv_fetch(stash,tmpbuf,len,add);
 649                 gv = gvp ? *gvp : Nullgv;
 650                 if (gv && gv != (GV*)&PL_sv_undef) {
 651                     if (SvTYPE(gv) != SVt_PVGV)
 652                         gv_init(gv, stash, tmpbuf, len, (add & GV_ADDMULTI));
 653                     else
 654                         GvMULTI_on(gv);
 655                 }
 656                 if (tmpbuf != smallbuf)
 657                     Safefree(tmpbuf);
 658                 if (!gv || gv == (GV*)&PL_sv_undef)
 659                     return Nullgv;
 660
 661                 if (!(stash = GvHV(gv)))
 662                     stash = GvHV(gv) = newHV();
 663
 664                 if (!HvNAME(stash))
 665                     HvNAME(stash) = savepvn(nambeg, namend - nambeg);
 666             }
 667
 668             if (*namend == ':')
 669                 namend++;
 670             namend++;
 671             name = namend;
 672             if (!*name)
 673                 return gv ? gv : (GV*)*hv_fetch(PL_defstash, "main::", 6, TRUE);
 674         }
 675     }
 676     len = namend - name;
 677     if (!len)
 678         len = 1;
 679
 680     /* No stash in name, so see how we can default */
 681
 682     if (!stash) {
 683         if (isIDFIRST_lazy(name)) {
 684             bool global = FALSE;
 685
 686             if (isUPPER(*name)) {
 687                 if (*name == 'S' && (
 688                     strEQ(name, "SIG") ||
 689                     strEQ(name, "STDIN") ||
 690                     strEQ(name, "STDOUT") ||
 691                     strEQ(name, "STDERR")))
 692                     global = TRUE;
 693                 else if (*name == 'I' && strEQ(name, "INC"))
 694                     global = TRUE;
 695                 else if (*name == 'E' && strEQ(name, "ENV"))
 696                     global = TRUE;
 697                 else if (*name == 'A' && (
 698                   strEQ(name, "ARGV") ||
 699                   strEQ(name, "ARGVOUT")))
 700                     global = TRUE;
 701             }
 702             else if (*name == '_' && !name[1])
 703                 global = TRUE;
 704
 705             if (global)
 706                 stash = PL_defstash;
 707             else if ((COP*)PL_curcop == &PL_compiling) {
 708                 stash = PL_curstash;
 709                 if (add && (PL_hints & HINT_STRICT_VARS) &&
 710                     sv_type != SVt_PVCV &&
 711                     sv_type != SVt_PVGV &&
 712                     sv_type != SVt_PVFM &&
 713                     sv_type != SVt_PVIO &&
 714                     !(len == 1 && sv_type == SVt_PV && strchr("ab",*name)) )
 715                 {
 716                     gvp = (GV**)hv_fetch(stash,name,len,0);
 717                     if (!gvp ||
 718                         *gvp == (GV*)&PL_sv_undef ||
 719                         SvTYPE(*gvp) != SVt_PVGV)
 720                     {
 721                         stash = 0;
 722                     }
 723                     else if ((sv_type == SVt_PV   && !GvIMPORTED_SV(*gvp)) ||
 724                              (sv_type == SVt_PVAV && !GvIMPORTED_AV(*gvp)) ||
 725                              (sv_type == SVt_PVHV && !GvIMPORTED_HV(*gvp)) )
 726                     {
 727                         Perl_warn(aTHX_ "Variable \"%c%s\" is not imported",
 728                             sv_type == SVt_PVAV ? '@' :
 729                             sv_type == SVt_PVHV ? '%' : '$',
 730                             name);
 731                         if (GvCVu(*gvp))
 732                             Perl_warn(aTHX_ "\t(Did you mean &%s instead?)\n", name);
 733                         stash = 0;
 734                     }
 735                 }
 736             }
 737             else
 738                 stash = CopSTASH(PL_curcop);
 739         }
 740         else
 741             stash = PL_defstash;
 742     }
 743
 744     /* By this point we should have a stash and a name */
 745
 746     if (!stash) {
 747         if (add) {
 748             qerror(Perl_mess(aTHX_
 749                  "Global symbol \"%s%s\" requires explicit package name",
 750                  (sv_type == SVt_PV ? "$"
 751                   : sv_type == SVt_PVAV ? "@"
 752                   : sv_type == SVt_PVHV ? "%"
 753                   : ""), name));
 754         }
 755         return Nullgv;
 756     }
 757
 758     if (!SvREFCNT(stash))       /* symbol table under destruction */
 759         return Nullgv;
 760
 761     gvp = (GV**)hv_fetch(stash,name,len,add);
 762     if (!gvp || *gvp == (GV*)&PL_sv_undef)
 763         return Nullgv;
 764     gv = *gvp;
 765     if (SvTYPE(gv) == SVt_PVGV) {
 766         if (add) {
 767             GvMULTI_on(gv);
 768             gv_init_sv(gv, sv_type);
 769             if (*name=='!' && sv_type == SVt_PVHV && len==1)
 770                 require_errno(gv);
 771         }
 772         return gv;
 773     } else if (add & GV_NOINIT) {
 774         return gv;
 775     }
 776
 777     /* Adding a new symbol */
 778
 779     if (add & GV_ADDWARN && ckWARN_d(WARN_INTERNAL))
 780         Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "Had to create %s unexpectedly", nambeg);
 781     gv_init(gv, stash, name, len, add & GV_ADDMULTI);
 782     gv_init_sv(gv, sv_type);
 783
 784     if (isALPHA(name[0]) && ! (isLEXWARN_on ? ckWARN(WARN_ONCE)
 785                                             : (PL_dowarn & G_WARN_ON ) ) )
 786         GvMULTI_on(gv) ;
 787
 788     /* set up magic where warranted */
 789     switch (*name) {
 790     case 'A':
 791         if (strEQ(name, "ARGV")) {
 792             IoFLAGS(GvIOn(gv)) |= IOf_ARGV|IOf_START;
 793         }
 794         break;
 795     case 'E':
 796         if (strnEQ(name, "EXPORT", 6))
 797             GvMULTI_on(gv);
 798         break;
 799     case 'I':
 800         if (strEQ(name, "ISA")) {
 801             AV* av = GvAVn(gv);
 802             GvMULTI_on(gv);
 803             sv_magic((SV*)av, (SV*)gv, PERL_MAGIC_isa, Nullch, 0);
 804             /* NOTE: No support for tied ISA */
 805             if ((add & GV_ADDMULTI) && strEQ(nambeg,"AnyDBM_File::ISA")
 806                 && AvFILLp(av) == -1)
 807             {
 808                 char *pname;
 809                 av_push(av, newSVpvn(pname = "NDBM_File",9));
 810                 gv_stashpvn(pname, 9, TRUE);
 811                 av_push(av, newSVpvn(pname = "DB_File",7));
 812                 gv_stashpvn(pname, 7, TRUE);
 813                 av_push(av, newSVpvn(pname = "GDBM_File",9));
 814                 gv_stashpvn(pname, 9, TRUE);
 815                 av_push(av, newSVpvn(pname = "SDBM_File",9));
 816                 gv_stashpvn(pname, 9, TRUE);
 817                 av_push(av, newSVpvn(pname = "ODBM_File",9));
 818                 gv_stashpvn(pname, 9, TRUE);
 819             }
 820         }
 821         break;
 822     case 'O':
 823         if (strEQ(name, "OVERLOAD")) {
 824             HV* hv = GvHVn(gv);
 825             GvMULTI_on(gv);
 826             hv_magic(hv, Nullgv, PERL_MAGIC_overload);
 827         }
 828         break;
 829     case 'S':
 830         if (strEQ(name, "SIG")) {
 831             HV *hv;
 832             I32 i;
 833             if (!PL_psig_ptr) {
 834                 Newz(73, PL_psig_ptr,  SIG_SIZE, SV*);
 835                 Newz(73, PL_psig_name, SIG_SIZE, SV*);
 836                 Newz(73, PL_psig_pend, SIG_SIZE, int);
 837             }
 838             GvMULTI_on(gv);
 839             hv = GvHVn(gv);
 840             hv_magic(hv, Nullgv, PERL_MAGIC_sig);
 841             for (i = 1; i < SIG_SIZE; i++) {
 842                 SV ** init;
 843                 init = hv_fetch(hv, PL_sig_name[i], strlen(PL_sig_name[i]), 1);
 844                 if (init)
 845                     sv_setsv(*init, &PL_sv_undef);
 846                 PL_psig_ptr[i] = 0;
 847                 PL_psig_name[i] = 0;
 848                 PL_psig_pend[i] = 0;
 849             }
 850         }
 851         break;
 852     case 'V':
 853         if (strEQ(name, "VERSION"))
 854             GvMULTI_on(gv);
 855         break;
 856
 857     case '&':
 858     case '`':
 859     case '\'':
 860        if (
 861            len > 1 ||
 862            sv_type == SVt_PVAV ||
 863            sv_type == SVt_PVHV ||
 864            sv_type == SVt_PVCV ||
 865            sv_type == SVt_PVFM ||
 866            sv_type == SVt_PVIO
 867        ) { break; }
 868         PL_sawampersand = TRUE;
 869         goto ro_magicalize;
 870
 871     case ':':
 872         if (len > 1)
 873             break;
 874         sv_setpv(GvSV(gv),PL_chopset);
 875         goto magicalize;
 876
 877     case '?':
 878         if (len > 1)
 879             break;
 880 #ifdef COMPLEX_STATUS
 881         (void)SvUPGRADE(GvSV(gv), SVt_PVLV);
 882 #endif
 883         goto magicalize;
 884
 885     case '!':
 886         if (len > 1)
 887             break;
 888
 889         /* If %! has been used, automatically load Errno.pm.
 890            The require will itself set errno, so in order to
 891            preserve its value we have to set up the magic
 892            now (rather than going to magicalize)
 893         */
 894
 895         sv_magic(GvSV(gv), (SV*)gv, PERL_MAGIC_sv, name, len);
 896
 897         if (sv_type == SVt_PVHV)
 898             require_errno(gv);
 899
 900         break;
 901     case '-':
 902         if (len > 1)
 903             break;
 904         else {
 905             AV* av = GvAVn(gv);
 906             sv_magic((SV*)av, Nullsv, PERL_MAGIC_regdata, Nullch, 0);
 907             SvREADONLY_on(av);
 908         }
 909         goto magicalize;
 910     case '#':
 911     case '*':
 912         if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX) && len == 1 && sv_type == SVt_PV)
 913             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX), "Use of $%s is deprecated", name);
 914         /* FALL THROUGH */
 915     case '[':
 916     case '^':
 917     case '~':
 918     case '=':
 919     case '%':
 920     case '.':
 921     case '(':
 922     case ')':
 923     case '<':
 924     case '>':
 925     case ',':
 926     case '\\':
 927     case '/':
 928     case '\001':        /* $^A */
 929     case '\003':        /* $^C */
 930     case '\004':        /* $^D */
 931     case '\006':        /* $^F */
 932     case '\010':        /* $^H */
 933     case '\011':        /* $^I, NOT \t in EBCDIC */
 934     case '\016':        /* $^N */
 935     case '\020':        /* $^P */
 936         if (len > 1)
 937             break;
 938         goto magicalize;
 939     case '|':
 940         if (len > 1)
 941             break;
 942         sv_setiv(GvSV(gv), (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0);
 943         goto magicalize;
 944     case '\005':        /* $^E && $^ENCODING */
 945         if (len > 1 && strNE(name, "\005NCODING"))
 946             break;
 947         goto magicalize;
 948
 949     case '\017':        /* $^O & $^OPEN */
 950         if (len > 1 && strNE(name, "\017PEN"))
 951             break;
 952         goto magicalize;
 953     case '\023':        /* $^S */
 954         if (len > 1)
 955             break;
 956         goto ro_magicalize;
 957     case '\024':        /* $^T, ${^TAINT} */
 958         if (len == 1)
 959             goto magicalize;
 960         else if (strEQ(name, "\024AINT"))
 961             goto ro_magicalize;
 962         else
 963             break;
 964     case '\027':        /* $^W & $^WARNING_BITS */
 965         if (len > 1 && strNE(name, "\027ARNING_BITS")
 966             && strNE(name, "\027IDE_SYSTEM_CALLS"))
 967             break;
 968         goto magicalize;
 969
 970     case '+':
 971         if (len > 1)
 972             break;
 973         else {
 974             AV* av = GvAVn(gv);
 975             sv_magic((SV*)av, (SV*)av, PERL_MAGIC_regdata, Nullch, 0);
 976             SvREADONLY_on(av);
 977         }
 978         /* FALL THROUGH */
 979     case '1':
 980     case '2':
 981     case '3':
 982     case '4':
 983     case '5':
 984     case '6':
 985     case '7':
 986     case '8':
 987     case '9':
 988         /* ensures variable is only digits */
 989         /* ${"1foo"} fails this test (and is thus writeable) */
 990         /* added by japhy, but borrowed from is_gv_magical */
 991
 992         if (len > 1) {
 993             const char *end = name + len;
 994             while (--end > name) {
 995                 if (!isDIGIT(*end)) return gv;
 996             }
 997         }
 998
 999       ro_magicalize:
1000         SvREADONLY_on(GvSV(gv));
1001       magicalize:
1002         sv_magic(GvSV(gv), (SV*)gv, PERL_MAGIC_sv, name, len);
1003         break;
1004
1005     case '\014':        /* $^L */
1006         if (len > 1)
1007             break;
1008         sv_setpv(GvSV(gv),"\f");
1009         PL_formfeed = GvSV(gv);
1010         break;
1011     case ';':
1012         if (len > 1)
1013             break;
1014         sv_setpv(GvSV(gv),"\034");
1015         break;
1016     case ']':
1017         if (len == 1) {
1018             SV *sv = GvSV(gv);
1019             (void)SvUPGRADE(sv, SVt_PVNV);
1020             Perl_sv_setpvf(aTHX_ sv,
1021 #if defined(PERL_SUBVERSION) && (PERL_SUBVERSION > 0)
1022                             "%8.6"
1023 #else
1024                             "%5.3"
1025 #endif
1026                             NVff,
1027                             SvNVX(PL_patchlevel));
1028             SvNVX(sv) = SvNVX(PL_patchlevel);
1029             SvNOK_on(sv);
1030             SvREADONLY_on(sv);
1031         }
1032         break;
1033     case '\026':        /* $^V */
1034         if (len == 1) {
1035             SV *sv = GvSV(gv);
1036             GvSV(gv) = SvREFCNT_inc(PL_patchlevel);
1037             SvREFCNT_dec(sv);
1038         }
1039         break;
1040     }
1041     return gv;
1042 }
1043
1044 void
1045 Perl_gv_fullname4(pTHX_ SV *sv, GV *gv, const char *prefix, bool keepmain)
1046 {
1047     HV *hv = GvSTASH(gv);
1048     if (!hv) {
1049         (void)SvOK_off(sv);
1050         return;
1051     }
1052     sv_setpv(sv, prefix ? prefix : "");
1053     if (keepmain || strNE(HvNAME(hv), "main")) {
1054         sv_catpv(sv,HvNAME(hv));
1055         sv_catpvn(sv,"::", 2);
1056     }
1057     sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv));
1058 }
1059
1060 void
1061 Perl_gv_fullname3(pTHX_ SV *sv, GV *gv, const char *prefix)
1062 {
1063     gv_fullname4(sv, gv, prefix, TRUE);
1064 }
1065
1066 void
1067 Perl_gv_efullname4(pTHX_ SV *sv, GV *gv, const char *prefix, bool keepmain)
1068 {
1069     GV *egv = GvEGV(gv);
1070     if (!egv)
1071         egv = gv;
1072     gv_fullname4(sv, egv, prefix, keepmain);
1073 }
1074
1075 void
1076 Perl_gv_efullname3(pTHX_ SV *sv, GV *gv, const char *prefix)
1077 {
1078     gv_efullname4(sv, gv, prefix, TRUE);
1079 }
1080
1081 /* XXX compatibility with versions <= 5.003. */
1082 void
1083 Perl_gv_fullname(pTHX_ SV *sv, GV *gv)
1084 {
1085     gv_fullname3(sv, gv, sv == (SV*)gv ? "*" : "");
1086 }
1087
1088 /* XXX compatibility with versions <= 5.003. */
1089 void
1090 Perl_gv_efullname(pTHX_ SV *sv, GV *gv)
1091 {
1092     gv_efullname3(sv, gv, sv == (SV*)gv ? "*" : "");
1093 }
1094
1095 IO *
1096 Perl_newIO(pTHX)
1097 {
1098     IO *io;
1099     GV *iogv;
1100
1101     io = (IO*)NEWSV(0,0);
1102     sv_upgrade((SV *)io,SVt_PVIO);
1103     SvREFCNT(io) = 1;
1104     SvOBJECT_on(io);
1105     iogv = gv_fetchpv("FileHandle::", FALSE, SVt_PVHV);
1106     /* unless exists($main::{FileHandle}) and defined(%main::FileHandle::) */
1107     if (!(iogv && GvHV(iogv) && HvARRAY(GvHV(iogv))))
1108       iogv = gv_fetchpv("IO::Handle::", TRUE, SVt_PVHV);
1109     SvSTASH(io) = (HV*)SvREFCNT_inc(GvHV(iogv));
1110     return io;
1111 }
1112
1113 void
1114 Perl_gv_check(pTHX_ HV *stash)
1115 {
1116     register HE *entry;
1117     register I32 i;
1118     register GV *gv;
1119     HV *hv;
1120
1121     if (!HvARRAY(stash))
1122         return;
1123     for (i = 0; i <= (I32) HvMAX(stash); i++) {
1124         for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
1125             if (HeKEY(entry)[HeKLEN(entry)-1] == ':' &&
1126                 (gv = (GV*)HeVAL(entry)) && (hv = GvHV(gv)))
1127             {
1128                 if (hv != PL_defstash && hv != stash)
1129                      gv_check(hv);              /* nested package */
1130             }
1131             else if (isALPHA(*HeKEY(entry))) {
1132                 char *file;
1133                 gv = (GV*)HeVAL(entry);
1134                 if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv))
1135                     continue;
1136                 file = GvFILE(gv);
1137                 /* performance hack: if filename is absolute and it's a standard
1138                  * module, don't bother warning */
1139                 if (file
1140                     && PERL_FILE_IS_ABSOLUTE(file)
1141 #ifdef MACOS_TRADITIONAL
1142                     && (instr(file, ":lib:")
1143 #else
1144                     && (instr(file, "/lib/")
1145 #endif
1146                     || instr(file, ".pm")))
1147                 {
1148                     continue;
1149                 }
1150                 CopLINE_set(PL_curcop, GvLINE(gv));
1151 #ifdef USE_ITHREADS
1152                 CopFILE(PL_curcop) = file;      /* set for warning */
1153 #else
1154                 CopFILEGV(PL_curcop) = gv_fetchfile(file);
1155 #endif
1156                 Perl_warner(aTHX_ packWARN(WARN_ONCE),
1157                         "Name \"%s::%s\" used only once: possible typo",
1158                         HvNAME(stash), GvNAME(gv));
1159             }
1160         }
1161     }
1162 }
1163
1164 GV *
1165 Perl_newGVgen(pTHX_ char *pack)
1166 {
1167     return gv_fetchpv(Perl_form(aTHX_ "%s::_GEN_%ld", pack, (long)PL_gensym++),
1168                       TRUE, SVt_PVGV);
1169 }
1170
1171 /* hopefully this is only called on local symbol table entries */
1172
1173 GP*
1174 Perl_gp_ref(pTHX_ GP *gp)
1175 {
1176     if (!gp)
1177         return (GP*)NULL;
1178     gp->gp_refcnt++;
1179     if (gp->gp_cv) {
1180         if (gp->gp_cvgen) {
1181             /* multi-named GPs cannot be used for method cache */
1182             SvREFCNT_dec(gp->gp_cv);
1183             gp->gp_cv = Nullcv;
1184             gp->gp_cvgen = 0;
1185         }
1186         else {
1187             /* Adding a new name to a subroutine invalidates method cache */
1188             PL_sub_generation++;
1189         }
1190     }
1191     return gp;
1192 }
1193
1194 void
1195 Perl_gp_free(pTHX_ GV *gv)
1196 {
1197     GP* gp;
1198
1199     if (!gv || !(gp = GvGP(gv)))
1200         return;
1201     if (gp->gp_refcnt == 0) {
1202         if (ckWARN_d(WARN_INTERNAL))
1203             Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
1204                         "Attempt to free unreferenced glob pointers");
1205         return;
1206     }
1207     if (gp->gp_cv) {
1208         /* Deleting the name of a subroutine invalidates method cache */
1209         PL_sub_generation++;
1210     }
1211     if (--gp->gp_refcnt > 0) {
1212         if (gp->gp_egv == gv)
1213             gp->gp_egv = 0;
1214         return;
1215     }
1216
1217     SvREFCNT_dec(gp->gp_sv);
1218     SvREFCNT_dec(gp->gp_av);
1219     SvREFCNT_dec(gp->gp_hv);
1220     SvREFCNT_dec(gp->gp_io);
1221     SvREFCNT_dec(gp->gp_cv);
1222     SvREFCNT_dec(gp->gp_form);
1223
1224     Safefree(gp);
1225     GvGP(gv) = 0;
1226 }
1227
1228 int
1229 Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg)
1230 {
1231     AMT *amtp = (AMT*)mg->mg_ptr;
1232     if (amtp && AMT_AMAGIC(amtp)) {
1233         int i;
1234         for (i = 1; i < NofAMmeth; i++) {
1235             CV *cv = amtp->table[i];
1236             if (cv != Nullcv) {
1237                 SvREFCNT_dec((SV *) cv);
1238                 amtp->table[i] = Nullcv;
1239             }
1240         }
1241     }
1242  return 0;
1243 }
1244
1245 /* Updates and caches the CV's */
1246
1247 bool
1248 Perl_Gv_AMupdate(pTHX_ HV *stash)
1249 {
1250   GV* gv;
1251   CV* cv;
1252   MAGIC* mg=mg_find((SV*)stash, PERL_MAGIC_overload_table);
1253   AMT *amtp = (mg) ? (AMT*)mg->mg_ptr: (AMT *) NULL;
1254   AMT amt;
1255
1256   if (mg && amtp->was_ok_am == PL_amagic_generation
1257       && amtp->was_ok_sub == PL_sub_generation)
1258       return (bool)AMT_OVERLOADED(amtp);
1259   sv_unmagic((SV*)stash, PERL_MAGIC_overload_table);
1260
1261   DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME(stash)) );
1262
1263   Zero(&amt,1,AMT);
1264   amt.was_ok_am = PL_amagic_generation;
1265   amt.was_ok_sub = PL_sub_generation;
1266   amt.fallback = AMGfallNO;
1267   amt.flags = 0;
1268
1269   {
1270     int filled = 0, have_ovl = 0;
1271     int i, lim = 1;
1272     SV* sv = NULL;
1273
1274     /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
1275
1276     /* Try to find via inheritance. */
1277     gv = gv_fetchmeth(stash, PL_AMG_names[0], 2, -1);
1278     if (gv)
1279         sv = GvSV(gv);
1280
1281     if (!gv)
1282         lim = DESTROY_amg;              /* Skip overloading entries. */
1283     else if (SvTRUE(sv))
1284         amt.fallback=AMGfallYES;
1285     else if (SvOK(sv))
1286         amt.fallback=AMGfallNEVER;
1287
1288     for (i = 1; i < lim; i++)
1289         amt.table[i] = Nullcv;
1290     for (; i < NofAMmeth; i++) {
1291         char *cooky = (char*)PL_AMG_names[i];
1292         /* Human-readable form, for debugging: */
1293         char *cp = (i >= DESTROY_amg ? cooky : AMG_id2name(i));
1294         STRLEN l = strlen(cooky);
1295
1296         DEBUG_o( Perl_deb(aTHX_ "Checking overloading of `%s' in package `%.256s'\n",
1297                      cp, HvNAME(stash)) );
1298         /* don't fill the cache while looking up!
1299            Creation of inheritance stubs in intermediate packages may
1300            conflict with the logic of runtime method substitution.
1301            Indeed, for inheritance A -> B -> C, if C overloads "+0",
1302            then we could have created stubs for "(+0" in A and C too.
1303            But if B overloads "bool", we may want to use it for
1304            numifying instead of C's "+0". */
1305         if (i >= DESTROY_amg)
1306             gv = Perl_gv_fetchmeth_autoload(aTHX_ stash, cooky, l, 0);
1307         else                            /* Autoload taken care of below */
1308             gv = Perl_gv_fetchmeth(aTHX_ stash, cooky, l, -1);
1309         cv = 0;
1310         if (gv && (cv = GvCV(gv))) {
1311             if (GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")
1312                 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "overload")) {
1313                 /* This is a hack to support autoloading..., while
1314                    knowing *which* methods were declared as overloaded. */
1315                 /* GvSV contains the name of the method. */
1316                 GV *ngv = Nullgv;
1317
1318                 DEBUG_o( Perl_deb(aTHX_ "Resolving method `%.256s' for overloaded `%s' in package `%.256s'\n",
1319                              SvPV_nolen(GvSV(gv)), cp, HvNAME(stash)) );
1320                 if (!SvPOK(GvSV(gv))
1321                     || !(ngv = gv_fetchmethod_autoload(stash, SvPVX(GvSV(gv)),
1322                                                        FALSE)))
1323                 {
1324                     /* Can be an import stub (created by `can'). */
1325                     if (GvCVGEN(gv)) {
1326                         Perl_croak(aTHX_ "Stub found while resolving method `%.256s' overloading `%s' in package `%.256s'",
1327                               (SvPOK(GvSV(gv)) ?  SvPVX(GvSV(gv)) : "???" ),
1328                               cp, HvNAME(stash));
1329                     } else
1330                         Perl_croak(aTHX_ "Can't resolve method `%.256s' overloading `%s' in package `%.256s'",
1331                               (SvPOK(GvSV(gv)) ?  SvPVX(GvSV(gv)) : "???" ),
1332                               cp, HvNAME(stash));
1333                 }
1334                 cv = GvCV(gv = ngv);
1335             }
1336             DEBUG_o( Perl_deb(aTHX_ "Overloading `%s' in package `%.256s' via `%.256s::%.256s' \n",
1337                          cp, HvNAME(stash), HvNAME(GvSTASH(CvGV(cv))),
1338                          GvNAME(CvGV(cv))) );
1339             filled = 1;
1340             if (i < DESTROY_amg)
1341                 have_ovl = 1;
1342         } else if (gv) {                /* Autoloaded... */
1343             cv = (CV*)gv;
1344             filled = 1;
1345         }
1346         amt.table[i]=(CV*)SvREFCNT_inc(cv);
1347     }
1348     if (filled) {
1349       AMT_AMAGIC_on(&amt);
1350       if (have_ovl)
1351           AMT_OVERLOADED_on(&amt);
1352       sv_magic((SV*)stash, 0, PERL_MAGIC_overload_table,
1353                                                 (char*)&amt, sizeof(AMT));
1354       return have_ovl;
1355     }
1356   }
1357   /* Here we have no table: */
1358   /* no_table: */
1359   AMT_AMAGIC_off(&amt);
1360   sv_magic((SV*)stash, 0, PERL_MAGIC_overload_table,
1361                                                 (char*)&amt, sizeof(AMTS));
1362   return FALSE;
1363 }
1364
1365
1366 CV*
1367 Perl_gv_handler(pTHX_ HV *stash, I32 id)
1368 {
1369     MAGIC *mg;
1370     AMT *amtp;
1371     CV *ret;
1372
1373     if (!stash)
1374         return Nullcv;
1375     mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
1376     if (!mg) {
1377       do_update:
1378         Gv_AMupdate(stash);
1379         mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
1380     }
1381     amtp = (AMT*)mg->mg_ptr;
1382     if ( amtp->was_ok_am != PL_amagic_generation
1383          || amtp->was_ok_sub != PL_sub_generation )
1384         goto do_update;
1385     if (AMT_AMAGIC(amtp)) {
1386         ret = amtp->table[id];
1387         if (ret && isGV(ret)) {         /* Autoloading stab */
1388             /* Passing it through may have resulted in a warning
1389                "Inherited AUTOLOAD for a non-method deprecated", since
1390                our caller is going through a function call, not a method call.
1391                So return the CV for AUTOLOAD, setting $AUTOLOAD. */
1392             GV *gv = gv_fetchmethod(stash, (char*)PL_AMG_names[id]);
1393
1394             if (gv && GvCV(gv))
1395                 return GvCV(gv);
1396         }
1397         return ret;
1398     }
1399
1400     return Nullcv;
1401 }
1402
1403
1404 SV*
1405 Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
1406 {
1407   MAGIC *mg;
1408   CV *cv=NULL;
1409   CV **cvp=NULL, **ocvp=NULL;
1410   AMT *amtp=NULL, *oamtp=NULL;
1411   int off=0, off1, lr=0, assign=AMGf_assign & flags, notfound=0;
1412   int postpr = 0, force_cpy = 0, assignshift = assign ? 1 : 0;
1413 #ifdef DEBUGGING
1414   int fl=0;
1415 #endif
1416   HV* stash=NULL;
1417   if (!(AMGf_noleft & flags) && SvAMAGIC(left)
1418       && (stash = SvSTASH(SvRV(left)))
1419       && (mg = mg_find((SV*)stash, PERL_MAGIC_overload_table))
1420       && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
1421                         ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
1422                         : (CV **) NULL))
1423       && ((cv = cvp[off=method+assignshift])
1424           || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
1425                                                           * usual method */
1426                   (
1427 #ifdef DEBUGGING
1428                    fl = 1,
1429 #endif
1430                    cv = cvp[off=method])))) {
1431     lr = -1;                    /* Call method for left argument */
1432   } else {
1433     if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) {
1434       int logic;
1435
1436       /* look for substituted methods */
1437       /* In all the covered cases we should be called with assign==0. */
1438          switch (method) {
1439          case inc_amg:
1440            force_cpy = 1;
1441            if ((cv = cvp[off=add_ass_amg])
1442                || ((cv = cvp[off = add_amg]) && (force_cpy = 0, postpr = 1))) {
1443              right = &PL_sv_yes; lr = -1; assign = 1;
1444            }
1445            break;
1446          case dec_amg:
1447            force_cpy = 1;
1448            if ((cv = cvp[off = subtr_ass_amg])
1449                || ((cv = cvp[off = subtr_amg]) && (force_cpy = 0, postpr=1))) {
1450              right = &PL_sv_yes; lr = -1; assign = 1;
1451            }
1452            break;
1453          case bool__amg:
1454            (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg]));
1455            break;
1456          case numer_amg:
1457            (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg]));
1458            break;
1459          case string_amg:
1460            (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg]));
1461            break;
1462  case not_amg:
1463    (void)((cv = cvp[off=bool__amg])
1464           || (cv = cvp[off=numer_amg])
1465           || (cv = cvp[off=string_amg]));
1466    postpr = 1;
1467    break;
1468          case copy_amg:
1469            {
1470              /*
1471                   * SV* ref causes confusion with the interpreter variable of
1472                   * the same name
1473                   */
1474              SV* tmpRef=SvRV(left);
1475              if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) {
1476                 /*
1477                  * Just to be extra cautious.  Maybe in some
1478                  * additional cases sv_setsv is safe, too.
1479                  */
1480                 SV* newref = newSVsv(tmpRef);
1481                 SvOBJECT_on(newref);
1482                 SvSTASH(newref) = (HV*)SvREFCNT_inc(SvSTASH(tmpRef));
1483                 return newref;
1484              }
1485            }
1486            break;
1487          case abs_amg:
1488            if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg])
1489                && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) {
1490              SV* nullsv=sv_2mortal(newSViv(0));
1491              if (off1==lt_amg) {
1492                SV* lessp = amagic_call(left,nullsv,
1493                                        lt_amg,AMGf_noright);
1494                logic = SvTRUE(lessp);
1495              } else {
1496                SV* lessp = amagic_call(left,nullsv,
1497                                        ncmp_amg,AMGf_noright);
1498                logic = (SvNV(lessp) < 0);
1499              }
1500              if (logic) {
1501                if (off==subtr_amg) {
1502                  right = left;
1503                  left = nullsv;
1504                  lr = 1;
1505                }
1506              } else {
1507                return left;
1508              }
1509            }
1510            break;
1511          case neg_amg:
1512            if ((cv = cvp[off=subtr_amg])) {
1513              right = left;
1514              left = sv_2mortal(newSViv(0));
1515              lr = 1;
1516            }
1517            break;
1518          case int_amg:
1519          case iter_amg:                 /* XXXX Eventually should do to_gv. */
1520              /* FAIL safe */
1521              return NULL;       /* Delegate operation to standard mechanisms. */
1522              break;
1523          case to_sv_amg:
1524          case to_av_amg:
1525          case to_hv_amg:
1526          case to_gv_amg:
1527          case to_cv_amg:
1528              /* FAIL safe */
1529              return left;       /* Delegate operation to standard mechanisms. */
1530              break;
1531          default:
1532            goto not_found;
1533          }
1534          if (!cv) goto not_found;
1535     } else if (!(AMGf_noright & flags) && SvAMAGIC(right)
1536                && (stash = SvSTASH(SvRV(right)))
1537                && (mg = mg_find((SV*)stash, PERL_MAGIC_overload_table))
1538                && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
1539                           ? (amtp = (AMT*)mg->mg_ptr)->table
1540                           : (CV **) NULL))
1541                && (cv = cvp[off=method])) { /* Method for right
1542                                              * argument found */
1543       lr=1;
1544     } else if (((ocvp && oamtp->fallback > AMGfallNEVER
1545                  && (cvp=ocvp) && (lr = -1))
1546                 || (cvp && amtp->fallback > AMGfallNEVER && (lr=1)))
1547                && !(flags & AMGf_unary)) {
1548                                 /* We look for substitution for
1549                                  * comparison operations and
1550                                  * concatenation */
1551       if (method==concat_amg || method==concat_ass_amg
1552           || method==repeat_amg || method==repeat_ass_amg) {
1553         return NULL;            /* Delegate operation to string conversion */
1554       }
1555       off = -1;
1556       switch (method) {
1557          case lt_amg:
1558          case le_amg:
1559          case gt_amg:
1560          case ge_amg:
1561          case eq_amg:
1562          case ne_amg:
1563            postpr = 1; off=ncmp_amg; break;
1564          case slt_amg:
1565          case sle_amg:
1566          case sgt_amg:
1567          case sge_amg:
1568          case seq_amg:
1569          case sne_amg:
1570            postpr = 1; off=scmp_amg; break;
1571          }
1572       if (off != -1) cv = cvp[off];
1573       if (!cv) {
1574         goto not_found;
1575       }
1576     } else {
1577     not_found:                  /* No method found, either report or croak */
1578       switch (method) {
1579          case to_sv_amg:
1580          case to_av_amg:
1581          case to_hv_amg:
1582          case to_gv_amg:
1583          case to_cv_amg:
1584              /* FAIL safe */
1585              return left;       /* Delegate operation to standard mechanisms. */
1586              break;
1587       }
1588       if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */
1589         notfound = 1; lr = -1;
1590       } else if (cvp && (cv=cvp[nomethod_amg])) {
1591         notfound = 1; lr = 1;
1592       } else {
1593         SV *msg;
1594         if (off==-1) off=method;
1595         msg = sv_2mortal(Perl_newSVpvf(aTHX_
1596                       "Operation `%s': no method found,%sargument %s%s%s%s",
1597                       AMG_id2name(method + assignshift),
1598                       (flags & AMGf_unary ? " " : "\n\tleft "),
1599                       SvAMAGIC(left)?
1600                         "in overloaded package ":
1601                         "has no overloaded magic",
1602                       SvAMAGIC(left)?
1603                         HvNAME(SvSTASH(SvRV(left))):
1604                         "",
1605                       SvAMAGIC(right)?
1606                         ",\n\tright argument in overloaded package ":
1607                         (flags & AMGf_unary
1608                          ? ""
1609                          : ",\n\tright argument has no overloaded magic"),
1610                       SvAMAGIC(right)?
1611                         HvNAME(SvSTASH(SvRV(right))):
1612                         ""));
1613         if (amtp && amtp->fallback >= AMGfallYES) {
1614           DEBUG_o( Perl_deb(aTHX_ "%s", SvPVX(msg)) );
1615         } else {
1616           Perl_croak(aTHX_ "%"SVf, msg);
1617         }
1618         return NULL;
1619       }
1620       force_cpy = force_cpy || assign;
1621     }
1622   }
1623 #ifdef DEBUGGING
1624   if (!notfound) {
1625     DEBUG_o(Perl_deb(aTHX_
1626                      "Overloaded operator `%s'%s%s%s:\n\tmethod%s found%s in package %s%s\n",
1627                      AMG_id2name(off),
1628                      method+assignshift==off? "" :
1629                      " (initially `",
1630                      method+assignshift==off? "" :
1631                      AMG_id2name(method+assignshift),
1632                      method+assignshift==off? "" : "')",
1633                      flags & AMGf_unary? "" :
1634                      lr==1 ? " for right argument": " for left argument",
1635                      flags & AMGf_unary? " for argument" : "",
1636                      stash ? HvNAME(stash) : "null",
1637                      fl? ",\n\tassignment variant used": "") );
1638   }
1639 #endif
1640     /* Since we use shallow copy during assignment, we need
1641      * to dublicate the contents, probably calling user-supplied
1642      * version of copy operator
1643      */
1644     /* We need to copy in following cases:
1645      * a) Assignment form was called.
1646      *          assignshift==1,  assign==T, method + 1 == off
1647      * b) Increment or decrement, called directly.
1648      *          assignshift==0,  assign==0, method + 0 == off
1649      * c) Increment or decrement, translated to assignment add/subtr.
1650      *          assignshift==0,  assign==T,
1651      *          force_cpy == T
1652      * d) Increment or decrement, translated to nomethod.
1653      *          assignshift==0,  assign==0,
1654      *          force_cpy == T
1655      * e) Assignment form translated to nomethod.
1656      *          assignshift==1,  assign==T, method + 1 != off
1657      *          force_cpy == T
1658      */
1659     /*  off is method, method+assignshift, or a result of opcode substitution.
1660      *  In the latter case assignshift==0, so only notfound case is important.
1661      */
1662   if (( (method + assignshift == off)
1663         && (assign || (method == inc_amg) || (method == dec_amg)))
1664       || force_cpy)
1665     RvDEEPCP(left);
1666   {
1667     dSP;
1668     BINOP myop;
1669     SV* res;
1670     bool oldcatch = CATCH_GET;
1671
1672     CATCH_SET(TRUE);
1673     Zero(&myop, 1, BINOP);
1674     myop.op_last = (OP *) &myop;
1675     myop.op_next = Nullop;
1676     myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
1677
1678     PUSHSTACKi(PERLSI_OVERLOAD);
1679     ENTER;
1680     SAVEOP();
1681     PL_op = (OP *) &myop;
1682     if (PERLDB_SUB && PL_curstash != PL_debstash)
1683         PL_op->op_private |= OPpENTERSUB_DB;
1684     PUTBACK;
1685     pp_pushmark();
1686
1687     EXTEND(SP, notfound + 5);
1688     PUSHs(lr>0? right: left);
1689     PUSHs(lr>0? left: right);
1690     PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no ));
1691     if (notfound) {
1692       PUSHs( sv_2mortal(newSVpv(AMG_id2name(method + assignshift),0)));
1693     }
1694     PUSHs((SV*)cv);
1695     PUTBACK;
1696
1697     if ((PL_op = Perl_pp_entersub(aTHX)))
1698       CALLRUNOPS(aTHX);
1699     LEAVE;
1700     SPAGAIN;
1701
1702     res=POPs;
1703     PUTBACK;
1704     POPSTACK;
1705     CATCH_SET(oldcatch);
1706
1707     if (postpr) {
1708       int ans=0;
1709       switch (method) {
1710       case le_amg:
1711       case sle_amg:
1712         ans=SvIV(res)<=0; break;
1713       case lt_amg:
1714       case slt_amg:
1715         ans=SvIV(res)<0; break;
1716       case ge_amg:
1717       case sge_amg:
1718         ans=SvIV(res)>=0; break;
1719       case gt_amg:
1720       case sgt_amg:
1721         ans=SvIV(res)>0; break;
1722       case eq_amg:
1723       case seq_amg:
1724         ans=SvIV(res)==0; break;
1725       case ne_amg:
1726       case sne_amg:
1727         ans=SvIV(res)!=0; break;
1728       case inc_amg:
1729       case dec_amg:
1730         SvSetSV(left,res); return left;
1731       case not_amg:
1732         ans=!SvTRUE(res); break;
1733       }
1734       return boolSV(ans);
1735     } else if (method==copy_amg) {
1736       if (!SvROK(res)) {
1737         Perl_croak(aTHX_ "Copy method did not return a reference");
1738       }
1739       return SvREFCNT_inc(SvRV(res));
1740     } else {
1741       return res;
1742     }
1743   }
1744 }
1745
1746 /*
1747 =for apidoc is_gv_magical
1748
1749 Returns C<TRUE> if given the name of a magical GV.
1750
1751 Currently only useful internally when determining if a GV should be
1752 created even in rvalue contexts.
1753
1754 C<flags> is not used at present but available for future extension to
1755 allow selecting particular classes of magical variable.
1756
1757 =cut
1758 */
1759 bool
1760 Perl_is_gv_magical(pTHX_ char *name, STRLEN len, U32 flags)
1761 {
1762     if (!len)
1763         return FALSE;
1764
1765     switch (*name) {
1766     case 'I':
1767         if (len == 3 && strEQ(name, "ISA"))
1768             goto yes;
1769         break;
1770     case 'O':
1771         if (len == 8 && strEQ(name, "OVERLOAD"))
1772             goto yes;
1773         break;
1774     case 'S':
1775         if (len == 3 && strEQ(name, "SIG"))
1776             goto yes;
1777         break;
1778     case '\017':   /* $^O & $^OPEN */
1779         if (len == 1
1780             || (len == 4 && strEQ(name, "\017PEN")))
1781         {
1782             goto yes;
1783         }
1784         break;
1785     case '\027':   /* $^W & $^WARNING_BITS */
1786         if (len == 1
1787             || (len == 12 && strEQ(name, "\027ARNING_BITS"))
1788             || (len == 17 && strEQ(name, "\027IDE_SYSTEM_CALLS")))
1789         {
1790             goto yes;
1791         }
1792         break;
1793
1794     case '&':
1795     case '`':
1796     case '\'':
1797     case ':':
1798     case '?':
1799     case '!':
1800     case '-':
1801     case '#':
1802     case '*':
1803     case '[':
1804     case '^':
1805     case '~':
1806     case '=':
1807     case '%':
1808     case '.':
1809     case '(':
1810     case ')':
1811     case '<':
1812     case '>':
1813     case ',':
1814     case '\\':
1815     case '/':
1816     case '|':
1817     case '+':
1818     case ';':
1819     case ']':
1820     case '\001':   /* $^A */
1821     case '\003':   /* $^C */
1822     case '\004':   /* $^D */
1823     case '\005':   /* $^E */
1824     case '\006':   /* $^F */
1825     case '\010':   /* $^H */
1826     case '\011':   /* $^I, NOT \t in EBCDIC */
1827     case '\014':   /* $^L */
1828     case '\016':   /* $^N */
1829     case '\020':   /* $^P */
1830     case '\023':   /* $^S */
1831     case '\026':   /* $^V */
1832         if (len == 1)
1833             goto yes;
1834         break;
1835     case '\024':   /* $^T, ${^TAINT} */
1836         if (len == 1 || strEQ(name, "\024AINT"))
1837             goto yes;
1838         break;
1839     case '1':
1840     case '2':
1841     case '3':
1842     case '4':
1843     case '5':
1844     case '6':
1845     case '7':
1846     case '8':
1847     case '9':
1848         if (len > 1) {
1849             char *end = name + len;
1850             while (--end > name) {
1851                 if (!isDIGIT(*end))
1852                     return FALSE;
1853             }
1854         }
1855     yes:
1856         return TRUE;
1857     default:
1858         break;
1859     }
1860     return FALSE;
1861 }