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