gv.c

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