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