gv.c

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