gv.c

   1 /*    gv.c
   2  *
   3  *    Copyright (c) 1991-2002, Larry Wall
   4  *
   5  *    You may distribute under the terms of either the GNU General Public
   6  *    License or the Artistic License, as specified in the README file.
   7  *
   8  */
   9
  10 /*
  11  *   'Mercy!' cried Gandalf.  'If the giving of information is to be the cure
  12  * of your inquisitiveness, I shall spend all the rest of my days answering
  13  * you.  What more do you want to know?'
  14  *   'The names of all the stars, and of all living things, and the whole
  15  * history of Middle-earth and Over-heaven and of the Sundering Seas,'
  16  * laughed Pippin.
  17  */
  18
  19 /*
  20 =head1 GV Functions
  21 */
  22
  23 #include "EXTERN.h"
  24 #define PERL_IN_GV_C
  25 #include "perl.h"
  26
  27 GV *
  28 Perl_gv_AVadd(pTHX_ register GV *gv)
  29 {
  30     if (!gv || SvTYPE((SV*)gv) != SVt_PVGV)
  31         Perl_croak(aTHX_ "Bad symbol for array");
  32     if (!GvAV(gv))
  33         GvAV(gv) = newAV();
  34     return gv;
  35 }
  36
  37 GV *
  38 Perl_gv_HVadd(pTHX_ register GV *gv)
  39 {
  40     if (!gv || SvTYPE((SV*)gv) != SVt_PVGV)
  41         Perl_croak(aTHX_ "Bad symbol for hash");
  42     if (!GvHV(gv))
  43         GvHV(gv) = newHV();
  44     return gv;
  45 }
  46
  47 GV *
  48 Perl_gv_IOadd(pTHX_ register GV *gv)
  49 {
  50     if (!gv || SvTYPE((SV*)gv) != SVt_PVGV)
  51         Perl_croak(aTHX_ "Bad symbol for filehandle");
  52     if (!GvIOp(gv)) {
  53 #ifdef GV_UNIQUE_CHECK
  54         if (GvUNIQUE(gv)) {
  55             Perl_croak(aTHX_ "Bad symbol for filehandle (GV is unique)");
  56         }
  57 #endif
  58         GvIOp(gv) = newIO();
  59     }
  60     return gv;
  61 }
  62
  63 GV *
  64 Perl_gv_fetchfile(pTHX_ const char *name)
  65 {
  66     char smallbuf[256];
  67     char *tmpbuf;
  68     STRLEN tmplen;
  69     GV *gv;
  70
  71     if (!PL_defstash)
  72         return Nullgv;
  73
  74     tmplen = strlen(name) + 2;
  75     if (tmplen < sizeof smallbuf)
  76         tmpbuf = smallbuf;
  77     else
  78         New(603, tmpbuf, tmplen + 1, char);
  79     /* This is where the debugger's %{"::_<$filename"} hash is created */
  80     tmpbuf[0] = '_';
  81     tmpbuf[1] = '<';
  82     strcpy(tmpbuf + 2, name);
  83     gv = *(GV**)hv_fetch(PL_defstash, tmpbuf, tmplen, TRUE);
  84     if (!isGV(gv)) {
  85         gv_init(gv, PL_defstash, tmpbuf, tmplen, FALSE);
  86         sv_setpv(GvSV(gv), name);
  87         if (PERLDB_LINE)
  88             hv_magic(GvHVn(gv_AVadd(gv)), Nullgv, PERL_MAGIC_dbfile);
  89     }
  90     if (tmpbuf != smallbuf)
  91         Safefree(tmpbuf);
  92     return gv;
  93 }
  94
  95 void
  96 Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi)
  97 {
  98     register GP *gp;
  99     bool doproto = SvTYPE(gv) > SVt_NULL;
 100     char *proto = (doproto && SvPOK(gv)) ? SvPVX(gv) : NULL;
 101
 102     sv_upgrade((SV*)gv, SVt_PVGV);
 103     if (SvLEN(gv)) {
 104         if (proto) {
 105             SvPVX(gv) = NULL;
 106             SvLEN(gv) = 0;
 107             SvPOK_off(gv);
 108         } else
 109             Safefree(SvPVX(gv));
 110     }
 111     Newz(602, gp, 1, GP);
 112     GvGP(gv) = gp_ref(gp);
 113     GvSV(gv) = NEWSV(72,0);
 114     GvLINE(gv) = CopLINE(PL_curcop);
 115     GvFILE(gv) = CopFILE(PL_curcop) ? CopFILE(PL_curcop) : "";
 116     GvCVGEN(gv) = 0;
 117     GvEGV(gv) = gv;
 118     sv_magic((SV*)gv, (SV*)gv, PERL_MAGIC_glob, Nullch, 0);
 119     GvSTASH(gv) = (HV*)SvREFCNT_inc(stash);
 120     GvNAME(gv) = savepvn(name, len);
 121     GvNAMELEN(gv) = len;
 122     if (multi || doproto)              /* doproto means it _was_ mentioned */
 123         GvMULTI_on(gv);
 124     if (doproto) {                      /* Replicate part of newSUB here. */
 125         SvIOK_off(gv);
 126         ENTER;
 127         /* XXX unsafe for threads if eval_owner isn't held */
 128         start_subparse(0,0);            /* Create CV in compcv. */
 129         GvCV(gv) = PL_compcv;
 130         LEAVE;
 131
 132         PL_sub_generation++;
 133         CvGV(GvCV(gv)) = gv;
 134         CvFILE_set_from_cop(GvCV(gv), PL_curcop);
 135         CvSTASH(GvCV(gv)) = PL_curstash;
 136 #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         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
 502                          newSVpvn("Errno",5), Nullsv);
 503         LEAVE;
 504         SPAGAIN;
 505         stash = gv_stashpvn("Errno",5,FALSE);
 506         if (!stash || !(gv_fetchmethod(stash, "TIEHASH")))
 507             Perl_croak(aTHX_ "Can't use %%! because Errno.pm is not available");
 508     }
 509 }
 510
 511 /*
 512 =for apidoc gv_stashpv
 513
 514 Returns a pointer to the stash for a specified package.  C<name> should
 515 be a valid UTF-8 string.  If C<create> is set then the package will be
 516 created if it does not already exist.  If C<create> is not set and the
 517 package does not exist then NULL is returned.
 518
 519 =cut
 520 */
 521
 522 HV*
 523 Perl_gv_stashpv(pTHX_ const char *name, I32 create)
 524 {
 525     return gv_stashpvn(name, strlen(name), create);
 526 }
 527
 528 HV*
 529 Perl_gv_stashpvn(pTHX_ const char *name, U32 namelen, I32 create)
 530 {
 531     char smallbuf[256];
 532     char *tmpbuf;
 533     HV *stash;
 534     GV *tmpgv;
 535
 536     if (namelen + 3 < sizeof smallbuf)
 537         tmpbuf = smallbuf;
 538     else
 539         New(606, tmpbuf, namelen + 3, char);
 540     Copy(name,tmpbuf,namelen,char);
 541     tmpbuf[namelen++] = ':';
 542     tmpbuf[namelen++] = ':';
 543     tmpbuf[namelen] = '\0';
 544     tmpgv = gv_fetchpv(tmpbuf, create, SVt_PVHV);
 545     if (tmpbuf != smallbuf)
 546         Safefree(tmpbuf);
 547     if (!tmpgv)
 548         return 0;
 549     if (!GvHV(tmpgv))
 550         GvHV(tmpgv) = newHV();
 551     stash = GvHV(tmpgv);
 552     if (!HvNAME(stash))
 553         HvNAME(stash) = savepv(name);
 554     return stash;
 555 }
 556
 557 /*
 558 =for apidoc gv_stashsv
 559
 560 Returns a pointer to the stash for a specified package, which must be a
 561 valid UTF-8 string.  See C<gv_stashpv>.
 562
 563 =cut
 564 */
 565
 566 HV*
 567 Perl_gv_stashsv(pTHX_ SV *sv, I32 create)
 568 {
 569     register char *ptr;
 570     STRLEN len;
 571     ptr = SvPV(sv,len);
 572     return gv_stashpvn(ptr, len, create);
 573 }
 574
 575
 576 GV *
 577 Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type)
 578 {
 579     register const char *name = nambeg;
 580     register GV *gv = 0;
 581     GV**gvp;
 582     I32 len;
 583     register const char *namend;
 584     HV *stash = 0;
 585
 586     if (*name == '*' && isALPHA(name[1])) /* accidental stringify on a GV? */
 587         name++;
 588
 589     for (namend = name; *namend; namend++) {
 590         if ((*namend == ':' && namend[1] == ':')
 591             || (*namend == '\'' && namend[1]))
 592         {
 593             if (!stash)
 594                 stash = PL_defstash;
 595             if (!stash || !SvREFCNT(stash)) /* symbol table under destruction */
 596                 return Nullgv;
 597
 598             len = namend - name;
 599             if (len > 0) {
 600                 char smallbuf[256];
 601                 char *tmpbuf;
 602
 603                 if (len + 3 < sizeof smallbuf)
 604                     tmpbuf = smallbuf;
 605                 else
 606                     New(601, tmpbuf, len+3, char);
 607                 Copy(name, tmpbuf, len, char);
 608                 tmpbuf[len++] = ':';
 609                 tmpbuf[len++] = ':';
 610                 tmpbuf[len] = '\0';
 611                 gvp = (GV**)hv_fetch(stash,tmpbuf,len,add);
 612                 gv = gvp ? *gvp : Nullgv;
 613                 if (gv && gv != (GV*)&PL_sv_undef) {
 614                     if (SvTYPE(gv) != SVt_PVGV)
 615                         gv_init(gv, stash, tmpbuf, len, (add & GV_ADDMULTI));
 616                     else
 617                         GvMULTI_on(gv);
 618                 }
 619                 if (tmpbuf != smallbuf)
 620                     Safefree(tmpbuf);
 621                 if (!gv || gv == (GV*)&PL_sv_undef)
 622                     return Nullgv;
 623
 624                 if (!(stash = GvHV(gv)))
 625                     stash = GvHV(gv) = newHV();
 626
 627                 if (!HvNAME(stash))
 628                     HvNAME(stash) = savepvn(nambeg, namend - nambeg);
 629             }
 630
 631             if (*namend == ':')
 632                 namend++;
 633             namend++;
 634             name = namend;
 635             if (!*name)
 636                 return gv ? gv : (GV*)*hv_fetch(PL_defstash, "main::", 6, TRUE);
 637         }
 638     }
 639     len = namend - name;
 640     if (!len)
 641         len = 1;
 642
 643     /* No stash in name, so see how we can default */
 644
 645     if (!stash) {
 646         if (isIDFIRST_lazy(name)) {
 647             bool global = FALSE;
 648
 649             if (isUPPER(*name)) {
 650                 if (*name == 'S' && (
 651                     strEQ(name, "SIG") ||
 652                     strEQ(name, "STDIN") ||
 653                     strEQ(name, "STDOUT") ||
 654                     strEQ(name, "STDERR")))
 655                     global = TRUE;
 656                 else if (*name == 'I' && strEQ(name, "INC"))
 657                     global = TRUE;
 658                 else if (*name == 'E' && strEQ(name, "ENV"))
 659                     global = TRUE;
 660                 else if (*name == 'A' && (
 661                   strEQ(name, "ARGV") ||
 662                   strEQ(name, "ARGVOUT")))
 663                     global = TRUE;
 664             }
 665             else if (*name == '_' && (!name[1] || strEQ(name,"__ANON__")))
 666                 global = TRUE;
 667
 668             if (global)
 669                 stash = PL_defstash;
 670             else if ((COP*)PL_curcop == &PL_compiling) {
 671                 stash = PL_curstash;
 672                 if (add && (PL_hints & HINT_STRICT_VARS) &&
 673                     sv_type != SVt_PVCV &&
 674                     sv_type != SVt_PVGV &&
 675                     sv_type != SVt_PVFM &&
 676                     sv_type != SVt_PVIO &&
 677                     !(len == 1 && sv_type == SVt_PV && strchr("ab",*name)) )
 678                 {
 679                     gvp = (GV**)hv_fetch(stash,name,len,0);
 680                     if (!gvp ||
 681                         *gvp == (GV*)&PL_sv_undef ||
 682                         SvTYPE(*gvp) != SVt_PVGV)
 683                     {
 684                         stash = 0;
 685                     }
 686                     else if ((sv_type == SVt_PV   && !GvIMPORTED_SV(*gvp)) ||
 687                              (sv_type == SVt_PVAV && !GvIMPORTED_AV(*gvp)) ||
 688                              (sv_type == SVt_PVHV && !GvIMPORTED_HV(*gvp)) )
 689                     {
 690                         Perl_warn(aTHX_ "Variable \"%c%s\" is not imported",
 691                             sv_type == SVt_PVAV ? '@' :
 692                             sv_type == SVt_PVHV ? '%' : '$',
 693                             name);
 694                         if (GvCVu(*gvp))
 695                             Perl_warn(aTHX_ "\t(Did you mean &%s instead?)\n", name);
 696                         stash = 0;
 697                     }
 698                 }
 699             }
 700             else
 701                 stash = CopSTASH(PL_curcop);
 702         }
 703         else
 704             stash = PL_defstash;
 705     }
 706
 707     /* By this point we should have a stash and a name */
 708
 709     if (!stash) {
 710         if (add) {
 711             qerror(Perl_mess(aTHX_
 712                  "Global symbol \"%s%s\" requires explicit package name",
 713                  (sv_type == SVt_PV ? "$"
 714                   : sv_type == SVt_PVAV ? "@"
 715                   : sv_type == SVt_PVHV ? "%"
 716                   : ""), name));
 717             stash = PL_nullstash;
 718         }
 719         else
 720             return Nullgv;
 721     }
 722
 723     if (!SvREFCNT(stash))       /* symbol table under destruction */
 724         return Nullgv;
 725
 726     gvp = (GV**)hv_fetch(stash,name,len,add);
 727     if (!gvp || *gvp == (GV*)&PL_sv_undef)
 728         return Nullgv;
 729     gv = *gvp;
 730     if (SvTYPE(gv) == SVt_PVGV) {
 731         if (add) {
 732             GvMULTI_on(gv);
 733             gv_init_sv(gv, sv_type);
 734             if (*name=='!' && sv_type == SVt_PVHV && len==1)
 735                 require_errno(gv);
 736         }
 737         return gv;
 738     } else if (add & GV_NOINIT) {
 739         return gv;
 740     }
 741
 742     /* Adding a new symbol */
 743
 744     if (add & GV_ADDWARN && ckWARN_d(WARN_INTERNAL))
 745         Perl_warner(aTHX_ WARN_INTERNAL, "Had to create %s unexpectedly", nambeg);
 746     gv_init(gv, stash, name, len, add & GV_ADDMULTI);
 747     gv_init_sv(gv, sv_type);
 748
 749     if (isALPHA(name[0]) && ! (isLEXWARN_on ? ckWARN(WARN_ONCE)
 750                                             : (PL_dowarn & G_WARN_ON ) ) )
 751         GvMULTI_on(gv) ;
 752
 753     /* set up magic where warranted */
 754     switch (*name) {
 755     case 'A':
 756         if (strEQ(name, "ARGV")) {
 757             IoFLAGS(GvIOn(gv)) |= IOf_ARGV|IOf_START;
 758         }
 759         break;
 760     case 'E':
 761         if (strnEQ(name, "EXPORT", 6))
 762             GvMULTI_on(gv);
 763         break;
 764     case 'I':
 765         if (strEQ(name, "ISA")) {
 766             AV* av = GvAVn(gv);
 767             GvMULTI_on(gv);
 768             sv_magic((SV*)av, (SV*)gv, PERL_MAGIC_isa, Nullch, 0);
 769             /* NOTE: No support for tied ISA */
 770             if ((add & GV_ADDMULTI) && strEQ(nambeg,"AnyDBM_File::ISA")
 771                 && AvFILLp(av) == -1)
 772             {
 773                 char *pname;
 774                 av_push(av, newSVpvn(pname = "NDBM_File",9));
 775                 gv_stashpvn(pname, 9, TRUE);
 776                 av_push(av, newSVpvn(pname = "DB_File",7));
 777                 gv_stashpvn(pname, 7, TRUE);
 778                 av_push(av, newSVpvn(pname = "GDBM_File",9));
 779                 gv_stashpvn(pname, 9, TRUE);
 780                 av_push(av, newSVpvn(pname = "SDBM_File",9));
 781                 gv_stashpvn(pname, 9, TRUE);
 782                 av_push(av, newSVpvn(pname = "ODBM_File",9));
 783                 gv_stashpvn(pname, 9, TRUE);
 784             }
 785         }
 786         break;
 787     case 'O':
 788         if (strEQ(name, "OVERLOAD")) {
 789             HV* hv = GvHVn(gv);
 790             GvMULTI_on(gv);
 791             hv_magic(hv, Nullgv, PERL_MAGIC_overload);
 792         }
 793         break;
 794     case 'S':
 795         if (strEQ(name, "SIG")) {
 796             HV *hv;
 797             I32 i;
 798             if (!PL_psig_ptr) {
 799                 Newz(73, PL_psig_ptr,  SIG_SIZE, SV*);
 800                 Newz(73, PL_psig_name, SIG_SIZE, SV*);
 801                 Newz(73, PL_psig_pend, SIG_SIZE, int);
 802             }
 803             GvMULTI_on(gv);
 804             hv = GvHVn(gv);
 805             hv_magic(hv, Nullgv, PERL_MAGIC_sig);
 806             for (i = 1; i < SIG_SIZE; i++) {
 807                 SV ** init;
 808                 init = hv_fetch(hv, PL_sig_name[i], strlen(PL_sig_name[i]), 1);
 809                 if (init)
 810                     sv_setsv(*init, &PL_sv_undef);
 811                 PL_psig_ptr[i] = 0;
 812                 PL_psig_name[i] = 0;
 813                 PL_psig_pend[i] = 0;
 814             }
 815         }
 816         break;
 817     case 'V':
 818         if (strEQ(name, "VERSION"))
 819             GvMULTI_on(gv);
 820         break;
 821
 822     case '&':
 823     case '`':
 824     case '\'':
 825        if (
 826            len > 1 ||
 827            sv_type == SVt_PVAV ||
 828            sv_type == SVt_PVHV ||
 829            sv_type == SVt_PVCV ||
 830            sv_type == SVt_PVFM ||
 831            sv_type == SVt_PVIO
 832        ) { break; }
 833         PL_sawampersand = TRUE;
 834         goto ro_magicalize;
 835
 836     case ':':
 837         if (len > 1)
 838             break;
 839         sv_setpv(GvSV(gv),PL_chopset);
 840         goto magicalize;
 841
 842     case '?':
 843         if (len > 1)
 844             break;
 845 #ifdef COMPLEX_STATUS
 846         (void)SvUPGRADE(GvSV(gv), SVt_PVLV);
 847 #endif
 848         goto magicalize;
 849
 850     case '!':
 851         if (len > 1)
 852             break;
 853
 854         /* If %! has been used, automatically load Errno.pm.
 855            The require will itself set errno, so in order to
 856            preserve its value we have to set up the magic
 857            now (rather than going to magicalize)
 858         */
 859
 860         sv_magic(GvSV(gv), (SV*)gv, PERL_MAGIC_sv, name, len);
 861
 862         if (sv_type == SVt_PVHV)
 863             require_errno(gv);
 864
 865         break;
 866     case '-':
 867         if (len > 1)
 868             break;
 869         else {
 870             AV* av = GvAVn(gv);
 871             sv_magic((SV*)av, Nullsv, PERL_MAGIC_regdata, Nullch, 0);
 872             SvREADONLY_on(av);
 873         }
 874         goto magicalize;
 875     case '#':
 876     case '*':
 877         if (ckWARN(WARN_DEPRECATED) && len == 1 && sv_type == SVt_PV)
 878             Perl_warner(aTHX_ WARN_DEPRECATED, "Use of $%s is deprecated", name);
 879         /* FALL THROUGH */
 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 '/':
 893     case '\001':        /* $^A */
 894     case '\003':        /* $^C */
 895     case '\004':        /* $^D */
 896     case '\006':        /* $^F */
 897     case '\010':        /* $^H */
 898     case '\011':        /* $^I, NOT \t in EBCDIC */
 899     case '\016':        /* $^N */
 900     case '\020':        /* $^P */
 901         if (len > 1)
 902             break;
 903         goto magicalize;
 904     case '|':
 905         if (len > 1)
 906             break;
 907         sv_setiv(GvSV(gv), (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0);
 908         goto magicalize;
 909     case '\005':        /* $^E && $^ENCODING */
 910         if (len > 1 && strNE(name, "\005NCODING"))
 911             break;
 912         goto magicalize;
 913
 914     case '\017':        /* $^O & $^OPEN */
 915         if (len > 1 && strNE(name, "\017PEN"))
 916             break;
 917         goto magicalize;
 918     case '\023':        /* $^S */
 919         if (len > 1)
 920             break;
 921         goto ro_magicalize;
 922     case '\024':        /* $^T, ${^TAINT} */
 923         if (len == 1)
 924             goto magicalize;
 925         else if (strEQ(name, "\024AINT"))
 926             goto ro_magicalize;
 927         else
 928             break;
 929     case '\027':        /* $^W & $^WARNING_BITS */
 930         if (len > 1 && strNE(name, "\027ARNING_BITS")
 931             && strNE(name, "\027IDE_SYSTEM_CALLS"))
 932             break;
 933         goto magicalize;
 934
 935     case '+':
 936         if (len > 1)
 937             break;
 938         else {
 939             AV* av = GvAVn(gv);
 940             sv_magic((SV*)av, (SV*)av, PERL_MAGIC_regdata, Nullch, 0);
 941             SvREADONLY_on(av);
 942         }
 943         /* FALL THROUGH */
 944     case '1':
 945     case '2':
 946     case '3':
 947     case '4':
 948     case '5':
 949     case '6':
 950     case '7':
 951     case '8':
 952     case '9':
 953         /* ensures variable is only digits */
 954         /* ${"1foo"} fails this test (and is thus writeable) */
 955         /* added by japhy, but borrowed from is_gv_magical */
 956
 957         if (len > 1) {
 958             const char *end = name + len;
 959             while (--end > name) {
 960                 if (!isDIGIT(*end)) return gv;
 961             }
 962         }
 963
 964       ro_magicalize:
 965         SvREADONLY_on(GvSV(gv));
 966       magicalize:
 967         sv_magic(GvSV(gv), (SV*)gv, PERL_MAGIC_sv, name, len);
 968         break;
 969
 970     case '\014':        /* $^L */
 971         if (len > 1)
 972             break;
 973         sv_setpv(GvSV(gv),"\f");
 974         PL_formfeed = GvSV(gv);
 975         break;
 976     case ';':
 977         if (len > 1)
 978             break;
 979         sv_setpv(GvSV(gv),"\034");
 980         break;
 981     case ']':
 982         if (len == 1) {
 983             SV *sv = GvSV(gv);
 984             (void)SvUPGRADE(sv, SVt_PVNV);
 985             Perl_sv_setpvf(aTHX_ sv,
 986 #if defined(PERL_SUBVERSION) && (PERL_SUBVERSION > 0)
 987                             "%8.6"
 988 #else
 989                             "%5.3"
 990 #endif
 991                             NVff,
 992                             SvNVX(PL_patchlevel));
 993             SvNVX(sv) = SvNVX(PL_patchlevel);
 994             SvNOK_on(sv);
 995             SvREADONLY_on(sv);
 996         }
 997         break;
 998     case '\026':        /* $^V */
 999         if (len == 1) {
1000             SV *sv = GvSV(gv);
1001             GvSV(gv) = SvREFCNT_inc(PL_patchlevel);
1002             SvREFCNT_dec(sv);
1003         }
1004         break;
1005     }
1006     return gv;
1007 }
1008
1009 void
1010 Perl_gv_fullname4(pTHX_ SV *sv, GV *gv, const char *prefix, bool keepmain)
1011 {
1012     HV *hv = GvSTASH(gv);
1013     if (!hv) {
1014         (void)SvOK_off(sv);
1015         return;
1016     }
1017     sv_setpv(sv, prefix ? prefix : "");
1018     if (keepmain || strNE(HvNAME(hv), "main")) {
1019         sv_catpv(sv,HvNAME(hv));
1020         sv_catpvn(sv,"::", 2);
1021     }
1022     sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv));
1023 }
1024
1025 void
1026 Perl_gv_fullname3(pTHX_ SV *sv, GV *gv, const char *prefix)
1027 {
1028     HV *hv = GvSTASH(gv);
1029     if (!hv) {
1030         (void)SvOK_off(sv);
1031         return;
1032     }
1033     sv_setpv(sv, prefix ? prefix : "");
1034     sv_catpv(sv,HvNAME(hv));
1035     sv_catpvn(sv,"::", 2);
1036     sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv));
1037 }
1038
1039 void
1040 Perl_gv_efullname4(pTHX_ SV *sv, GV *gv, const char *prefix, bool keepmain)
1041 {
1042     GV *egv = GvEGV(gv);
1043     if (!egv)
1044         egv = gv;
1045     gv_fullname4(sv, egv, prefix, keepmain);
1046 }
1047
1048 void
1049 Perl_gv_efullname3(pTHX_ SV *sv, GV *gv, const char *prefix)
1050 {
1051     GV *egv = GvEGV(gv);
1052     if (!egv)
1053         egv = gv;
1054     gv_fullname3(sv, egv, prefix);
1055 }
1056
1057 /* XXX compatibility with versions <= 5.003. */
1058 void
1059 Perl_gv_fullname(pTHX_ SV *sv, GV *gv)
1060 {
1061     gv_fullname3(sv, gv, sv == (SV*)gv ? "*" : "");
1062 }
1063
1064 /* XXX compatibility with versions <= 5.003. */
1065 void
1066 Perl_gv_efullname(pTHX_ SV *sv, GV *gv)
1067 {
1068     gv_efullname3(sv, gv, sv == (SV*)gv ? "*" : "");
1069 }
1070
1071 IO *
1072 Perl_newIO(pTHX)
1073 {
1074     IO *io;
1075     GV *iogv;
1076
1077     io = (IO*)NEWSV(0,0);
1078     sv_upgrade((SV *)io,SVt_PVIO);
1079     SvREFCNT(io) = 1;
1080     SvOBJECT_on(io);
1081     iogv = gv_fetchpv("FileHandle::", FALSE, SVt_PVHV);
1082     /* unless exists($main::{FileHandle}) and defined(%main::FileHandle::) */
1083     if (!(iogv && GvHV(iogv) && HvARRAY(GvHV(iogv))))
1084       iogv = gv_fetchpv("IO::Handle::", TRUE, SVt_PVHV);
1085     SvSTASH(io) = (HV*)SvREFCNT_inc(GvHV(iogv));
1086     return io;
1087 }
1088
1089 void
1090 Perl_gv_check(pTHX_ HV *stash)
1091 {
1092     register HE *entry;
1093     register I32 i;
1094     register GV *gv;
1095     HV *hv;
1096
1097     if (!HvARRAY(stash))
1098         return;
1099     for (i = 0; i <= (I32) HvMAX(stash); i++) {
1100         for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
1101             if (HeKEY(entry)[HeKLEN(entry)-1] == ':' &&
1102                 (gv = (GV*)HeVAL(entry)) && (hv = GvHV(gv)))
1103             {
1104                 if (hv != PL_defstash && hv != stash)
1105                      gv_check(hv);              /* nested package */
1106             }
1107             else if (isALPHA(*HeKEY(entry))) {
1108                 char *file;
1109                 gv = (GV*)HeVAL(entry);
1110                 if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv))
1111                     continue;
1112                 file = GvFILE(gv);
1113                 /* performance hack: if filename is absolute and it's a standard
1114                  * module, don't bother warning */
1115                 if (file
1116                     && PERL_FILE_IS_ABSOLUTE(file)
1117 #ifdef MACOS_TRADITIONAL
1118                     && (instr(file, ":lib:")
1119 #else
1120                     && (instr(file, "/lib/")
1121 #endif
1122                     || instr(file, ".pm")))
1123                 {
1124                     continue;
1125                 }
1126                 CopLINE_set(PL_curcop, GvLINE(gv));
1127 #ifdef USE_ITHREADS
1128                 CopFILE(PL_curcop) = file;      /* set for warning */
1129 #else
1130                 CopFILEGV(PL_curcop) = gv_fetchfile(file);
1131 #endif
1132                 Perl_warner(aTHX_ WARN_ONCE,
1133                         "Name \"%s::%s\" used only once: possible typo",
1134                         HvNAME(stash), GvNAME(gv));
1135             }
1136         }
1137     }
1138 }
1139
1140 GV *
1141 Perl_newGVgen(pTHX_ char *pack)
1142 {
1143     return gv_fetchpv(Perl_form(aTHX_ "%s::_GEN_%ld", pack, (long)PL_gensym++),
1144                       TRUE, SVt_PVGV);
1145 }
1146
1147 /* hopefully this is only called on local symbol table entries */
1148
1149 GP*
1150 Perl_gp_ref(pTHX_ GP *gp)
1151 {
1152     if (!gp)
1153         return (GP*)NULL;
1154     gp->gp_refcnt++;
1155     if (gp->gp_cv) {
1156         if (gp->gp_cvgen) {
1157             /* multi-named GPs cannot be used for method cache */
1158             SvREFCNT_dec(gp->gp_cv);
1159             gp->gp_cv = Nullcv;
1160             gp->gp_cvgen = 0;
1161         }
1162         else {
1163             /* Adding a new name to a subroutine invalidates method cache */
1164             PL_sub_generation++;
1165         }
1166     }
1167     return gp;
1168 }
1169
1170 void
1171 Perl_gp_free(pTHX_ GV *gv)
1172 {
1173     GP* gp;
1174
1175     if (!gv || !(gp = GvGP(gv)))
1176         return;
1177     if (gp->gp_refcnt == 0) {
1178         if (ckWARN_d(WARN_INTERNAL))
1179             Perl_warner(aTHX_ WARN_INTERNAL,
1180                         "Attempt to free unreferenced glob pointers");
1181         return;
1182     }
1183     if (gp->gp_cv) {
1184         /* Deleting the name of a subroutine invalidates method cache */
1185         PL_sub_generation++;
1186     }
1187     if (--gp->gp_refcnt > 0) {
1188         if (gp->gp_egv == gv)
1189             gp->gp_egv = 0;
1190         return;
1191     }
1192
1193     SvREFCNT_dec(gp->gp_sv);
1194     SvREFCNT_dec(gp->gp_av);
1195     SvREFCNT_dec(gp->gp_hv);
1196     SvREFCNT_dec(gp->gp_io);
1197     SvREFCNT_dec(gp->gp_cv);
1198     SvREFCNT_dec(gp->gp_form);
1199
1200     Safefree(gp);
1201     GvGP(gv) = 0;
1202 }
1203
1204 #if defined(CRIPPLED_CC) && (defined(iAPX286) || defined(M_I286) || defined(I80286))
1205 #define MICROPORT
1206 #endif
1207
1208 #ifdef  MICROPORT       /* Microport 2.4 hack */
1209 AV *GvAVn(gv)
1210 register GV *gv;
1211 {
1212     if (GvGP(gv)->gp_av)
1213         return GvGP(gv)->gp_av;
1214     else
1215         return GvGP(gv_AVadd(gv))->gp_av;
1216 }
1217
1218 HV *GvHVn(gv)
1219 register GV *gv;
1220 {
1221     if (GvGP(gv)->gp_hv)
1222         return GvGP(gv)->gp_hv;
1223     else
1224         return GvGP(gv_HVadd(gv))->gp_hv;
1225 }
1226 #endif                  /* Microport 2.4 hack */
1227
1228 int
1229 Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg)
1230 {
1231     AMT *amtp = (AMT*)mg->mg_ptr;
1232     if (amtp && AMT_AMAGIC(amtp)) {
1233         int i;
1234         for (i = 1; i < NofAMmeth; i++) {
1235             CV *cv = amtp->table[i];
1236             if (cv != Nullcv) {
1237                 SvREFCNT_dec((SV *) cv);
1238                 amtp->table[i] = Nullcv;
1239             }
1240         }
1241     }
1242  return 0;
1243 }
1244
1245 /* Updates and caches the CV's */
1246
1247 bool
1248 Perl_Gv_AMupdate(pTHX_ HV *stash)
1249 {
1250   GV* gv;
1251   CV* cv;
1252   MAGIC* mg=mg_find((SV*)stash, PERL_MAGIC_overload_table);
1253   AMT *amtp = (mg) ? (AMT*)mg->mg_ptr: (AMT *) NULL;
1254   AMT amt;
1255
1256   if (mg && amtp->was_ok_am == PL_amagic_generation
1257       && amtp->was_ok_sub == PL_sub_generation)
1258       return AMT_OVERLOADED(amtp);
1259   sv_unmagic((SV*)stash, PERL_MAGIC_overload_table);
1260
1261   DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME(stash)) );
1262
1263   Zero(&amt,1,AMT);
1264   amt.was_ok_am = PL_amagic_generation;
1265   amt.was_ok_sub = PL_sub_generation;
1266   amt.fallback = AMGfallNO;
1267   amt.flags = 0;
1268
1269   {
1270     int filled = 0, have_ovl = 0;
1271     int i, lim = 1;
1272     SV* sv = NULL;
1273
1274     /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
1275
1276     /* Try to find via inheritance. */
1277     gv = gv_fetchmeth(stash, PL_AMG_names[0], 2, -1);
1278     if (gv)
1279         sv = GvSV(gv);
1280
1281     if (!gv)
1282         lim = DESTROY_amg;              /* Skip overloading entries. */
1283     else if (SvTRUE(sv))
1284         amt.fallback=AMGfallYES;
1285     else if (SvOK(sv))
1286         amt.fallback=AMGfallNEVER;
1287
1288     for (i = 1; i < lim; i++)
1289         amt.table[i] = Nullcv;
1290     for (; i < NofAMmeth; i++) {
1291         char *cooky = (char*)PL_AMG_names[i];
1292         /* Human-readable form, for debugging: */
1293         char *cp = (i >= DESTROY_amg ? cooky : AMG_id2name(i));
1294         STRLEN l = strlen(cooky);
1295
1296         DEBUG_o( Perl_deb(aTHX_ "Checking overloading of `%s' in package `%.256s'\n",
1297                      cp, HvNAME(stash)) );
1298         /* don't fill the cache while looking up! */
1299         gv = gv_fetchmeth(stash, cooky, l, -1);
1300         cv = 0;
1301         if (gv && (cv = GvCV(gv))) {
1302             if (GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")
1303                 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "overload")) {
1304                 /* GvSV contains the name of the method. */
1305                 GV *ngv = Nullgv;
1306
1307                 DEBUG_o( Perl_deb(aTHX_ "Resolving method `%.256s' for overloaded `%s' in package `%.256s'\n",
1308                              SvPV_nolen(GvSV(gv)), cp, HvNAME(stash)) );
1309                 if (!SvPOK(GvSV(gv))
1310                     || !(ngv = gv_fetchmethod_autoload(stash, SvPVX(GvSV(gv)),
1311                                                        FALSE)))
1312                 {
1313                     /* Can be an import stub (created by `can'). */
1314                     if (GvCVGEN(gv)) {
1315                         Perl_croak(aTHX_ "Stub found while resolving method `%.256s' overloading `%s' in package `%.256s'",
1316                               (SvPOK(GvSV(gv)) ?  SvPVX(GvSV(gv)) : "???" ),
1317                               cp, HvNAME(stash));
1318                     } else
1319                         Perl_croak(aTHX_ "Can't resolve method `%.256s' overloading `%s' in package `%.256s'",
1320                               (SvPOK(GvSV(gv)) ?  SvPVX(GvSV(gv)) : "???" ),
1321                               cp, HvNAME(stash));
1322                 }
1323                 cv = GvCV(gv = ngv);
1324             }
1325             DEBUG_o( Perl_deb(aTHX_ "Overloading `%s' in package `%.256s' via `%.256s::%.256s' \n",
1326                          cp, HvNAME(stash), HvNAME(GvSTASH(CvGV(cv))),
1327                          GvNAME(CvGV(cv))) );
1328             filled = 1;
1329             if (i < DESTROY_amg)
1330                 have_ovl = 1;
1331         }
1332         amt.table[i]=(CV*)SvREFCNT_inc(cv);
1333     }
1334     if (filled) {
1335       AMT_AMAGIC_on(&amt);
1336       if (have_ovl)
1337           AMT_OVERLOADED_on(&amt);
1338       sv_magic((SV*)stash, 0, PERL_MAGIC_overload_table,
1339                                                 (char*)&amt, sizeof(AMT));
1340       return have_ovl;
1341     }
1342   }
1343   /* Here we have no table: */
1344   /* no_table: */
1345   AMT_AMAGIC_off(&amt);
1346   sv_magic((SV*)stash, 0, PERL_MAGIC_overload_table,
1347                                                 (char*)&amt, sizeof(AMTS));
1348   return FALSE;
1349 }
1350
1351
1352 CV*
1353 Perl_gv_handler(pTHX_ HV *stash, I32 id)
1354 {
1355     MAGIC *mg;
1356     AMT *amtp;
1357
1358     if (!stash)
1359         return Nullcv;
1360     mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
1361     if (!mg) {
1362       do_update:
1363         Gv_AMupdate(stash);
1364         mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
1365     }
1366     amtp = (AMT*)mg->mg_ptr;
1367     if ( amtp->was_ok_am != PL_amagic_generation
1368          || amtp->was_ok_sub != PL_sub_generation )
1369         goto do_update;
1370     if (AMT_AMAGIC(amtp))
1371         return amtp->table[id];
1372     return Nullcv;
1373 }
1374
1375
1376 SV*
1377 Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
1378 {
1379   MAGIC *mg;
1380   CV *cv=NULL;
1381   CV **cvp=NULL, **ocvp=NULL;
1382   AMT *amtp=NULL, *oamtp=NULL;
1383   int off=0, off1, lr=0, assign=AMGf_assign & flags, notfound=0;
1384   int postpr = 0, force_cpy = 0, assignshift = assign ? 1 : 0;
1385 #ifdef DEBUGGING
1386   int fl=0;
1387 #endif
1388   HV* stash=NULL;
1389   if (!(AMGf_noleft & flags) && SvAMAGIC(left)
1390       && (stash = SvSTASH(SvRV(left)))
1391       && (mg = mg_find((SV*)stash, PERL_MAGIC_overload_table))
1392       && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
1393                         ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
1394                         : (CV **) NULL))
1395       && ((cv = cvp[off=method+assignshift])
1396           || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
1397                                                           * usual method */
1398                   (
1399 #ifdef DEBUGGING
1400                    fl = 1,
1401 #endif
1402                    cv = cvp[off=method])))) {
1403     lr = -1;                    /* Call method for left argument */
1404   } else {
1405     if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) {
1406       int logic;
1407
1408       /* look for substituted methods */
1409       /* In all the covered cases we should be called with assign==0. */
1410          switch (method) {
1411          case inc_amg:
1412            force_cpy = 1;
1413            if ((cv = cvp[off=add_ass_amg])
1414                || ((cv = cvp[off = add_amg]) && (force_cpy = 0, postpr = 1))) {
1415              right = &PL_sv_yes; lr = -1; assign = 1;
1416            }
1417            break;
1418          case dec_amg:
1419            force_cpy = 1;
1420            if ((cv = cvp[off = subtr_ass_amg])
1421                || ((cv = cvp[off = subtr_amg]) && (force_cpy = 0, postpr=1))) {
1422              right = &PL_sv_yes; lr = -1; assign = 1;
1423            }
1424            break;
1425          case bool__amg:
1426            (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg]));
1427            break;
1428          case numer_amg:
1429            (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg]));
1430            break;
1431          case string_amg:
1432            (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg]));
1433            break;
1434  case not_amg:
1435    (void)((cv = cvp[off=bool__amg])
1436           || (cv = cvp[off=numer_amg])
1437           || (cv = cvp[off=string_amg]));
1438    postpr = 1;
1439    break;
1440          case copy_amg:
1441            {
1442              /*
1443                   * SV* ref causes confusion with the interpreter variable of
1444                   * the same name
1445                   */
1446              SV* tmpRef=SvRV(left);
1447              if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) {
1448                 /*
1449                  * Just to be extra cautious.  Maybe in some
1450                  * additional cases sv_setsv is safe, too.
1451                  */
1452                 SV* newref = newSVsv(tmpRef);
1453                 SvOBJECT_on(newref);
1454                 SvSTASH(newref) = (HV*)SvREFCNT_inc(SvSTASH(tmpRef));
1455                 return newref;
1456              }
1457            }
1458            break;
1459          case abs_amg:
1460            if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg])
1461                && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) {
1462              SV* nullsv=sv_2mortal(newSViv(0));
1463              if (off1==lt_amg) {
1464                SV* lessp = amagic_call(left,nullsv,
1465                                        lt_amg,AMGf_noright);
1466                logic = SvTRUE(lessp);
1467              } else {
1468                SV* lessp = amagic_call(left,nullsv,
1469                                        ncmp_amg,AMGf_noright);
1470                logic = (SvNV(lessp) < 0);
1471              }
1472              if (logic) {
1473                if (off==subtr_amg) {
1474                  right = left;
1475                  left = nullsv;
1476                  lr = 1;
1477                }
1478              } else {
1479                return left;
1480              }
1481            }
1482            break;
1483          case neg_amg:
1484            if ((cv = cvp[off=subtr_amg])) {
1485              right = left;
1486              left = sv_2mortal(newSViv(0));
1487              lr = 1;
1488            }
1489            break;
1490          case int_amg:
1491          case iter_amg:                 /* XXXX Eventually should do to_gv. */
1492              /* FAIL safe */
1493              return NULL;       /* Delegate operation to standard mechanisms. */
1494              break;
1495          case to_sv_amg:
1496          case to_av_amg:
1497          case to_hv_amg:
1498          case to_gv_amg:
1499          case to_cv_amg:
1500              /* FAIL safe */
1501              return left;       /* Delegate operation to standard mechanisms. */
1502              break;
1503          default:
1504            goto not_found;
1505          }
1506          if (!cv) goto not_found;
1507     } else if (!(AMGf_noright & flags) && SvAMAGIC(right)
1508                && (stash = SvSTASH(SvRV(right)))
1509                && (mg = mg_find((SV*)stash, PERL_MAGIC_overload_table))
1510                && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
1511                           ? (amtp = (AMT*)mg->mg_ptr)->table
1512                           : (CV **) NULL))
1513                && (cv = cvp[off=method])) { /* Method for right
1514                                              * argument found */
1515       lr=1;
1516     } else if (((ocvp && oamtp->fallback > AMGfallNEVER
1517                  && (cvp=ocvp) && (lr = -1))
1518                 || (cvp && amtp->fallback > AMGfallNEVER && (lr=1)))
1519                && !(flags & AMGf_unary)) {
1520                                 /* We look for substitution for
1521                                  * comparison operations and
1522                                  * concatenation */
1523       if (method==concat_amg || method==concat_ass_amg
1524           || method==repeat_amg || method==repeat_ass_amg) {
1525         return NULL;            /* Delegate operation to string conversion */
1526       }
1527       off = -1;
1528       switch (method) {
1529          case lt_amg:
1530          case le_amg:
1531          case gt_amg:
1532          case ge_amg:
1533          case eq_amg:
1534          case ne_amg:
1535            postpr = 1; off=ncmp_amg; break;
1536          case slt_amg:
1537          case sle_amg:
1538          case sgt_amg:
1539          case sge_amg:
1540          case seq_amg:
1541          case sne_amg:
1542            postpr = 1; off=scmp_amg; break;
1543          }
1544       if (off != -1) cv = cvp[off];
1545       if (!cv) {
1546         goto not_found;
1547       }
1548     } else {
1549     not_found:                  /* No method found, either report or croak */
1550       switch (method) {
1551          case to_sv_amg:
1552          case to_av_amg:
1553          case to_hv_amg:
1554          case to_gv_amg:
1555          case to_cv_amg:
1556              /* FAIL safe */
1557              return left;       /* Delegate operation to standard mechanisms. */
1558              break;
1559       }
1560       if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */
1561         notfound = 1; lr = -1;
1562       } else if (cvp && (cv=cvp[nomethod_amg])) {
1563         notfound = 1; lr = 1;
1564       } else {
1565         SV *msg;
1566         if (off==-1) off=method;
1567         msg = sv_2mortal(Perl_newSVpvf(aTHX_
1568                       "Operation `%s': no method found,%sargument %s%s%s%s",
1569                       AMG_id2name(method + assignshift),
1570                       (flags & AMGf_unary ? " " : "\n\tleft "),
1571                       SvAMAGIC(left)?
1572                         "in overloaded package ":
1573                         "has no overloaded magic",
1574                       SvAMAGIC(left)?
1575                         HvNAME(SvSTASH(SvRV(left))):
1576                         "",
1577                       SvAMAGIC(right)?
1578                         ",\n\tright argument in overloaded package ":
1579                         (flags & AMGf_unary
1580                          ? ""
1581                          : ",\n\tright argument has no overloaded magic"),
1582                       SvAMAGIC(right)?
1583                         HvNAME(SvSTASH(SvRV(right))):
1584                         ""));
1585         if (amtp && amtp->fallback >= AMGfallYES) {
1586           DEBUG_o( Perl_deb(aTHX_ "%s", SvPVX(msg)) );
1587         } else {
1588           Perl_croak(aTHX_ "%"SVf, msg);
1589         }
1590         return NULL;
1591       }
1592       force_cpy = force_cpy || assign;
1593     }
1594   }
1595 #ifdef DEBUGGING
1596   if (!notfound) {
1597     DEBUG_o(Perl_deb(aTHX_
1598                      "Overloaded operator `%s'%s%s%s:\n\tmethod%s found%s in package %s%s\n",
1599                      AMG_id2name(off),
1600                      method+assignshift==off? "" :
1601                      " (initially `",
1602                      method+assignshift==off? "" :
1603                      AMG_id2name(method+assignshift),
1604                      method+assignshift==off? "" : "')",
1605                      flags & AMGf_unary? "" :
1606                      lr==1 ? " for right argument": " for left argument",
1607                      flags & AMGf_unary? " for argument" : "",
1608                      stash ? HvNAME(stash) : "null",
1609                      fl? ",\n\tassignment variant used": "") );
1610   }
1611 #endif
1612     /* Since we use shallow copy during assignment, we need
1613      * to dublicate the contents, probably calling user-supplied
1614      * version of copy operator
1615      */
1616     /* We need to copy in following cases:
1617      * a) Assignment form was called.
1618      *          assignshift==1,  assign==T, method + 1 == off
1619      * b) Increment or decrement, called directly.
1620      *          assignshift==0,  assign==0, method + 0 == off
1621      * c) Increment or decrement, translated to assignment add/subtr.
1622      *          assignshift==0,  assign==T,
1623      *          force_cpy == T
1624      * d) Increment or decrement, translated to nomethod.
1625      *          assignshift==0,  assign==0,
1626      *          force_cpy == T
1627      * e) Assignment form translated to nomethod.
1628      *          assignshift==1,  assign==T, method + 1 != off
1629      *          force_cpy == T
1630      */
1631     /*  off is method, method+assignshift, or a result of opcode substitution.
1632      *  In the latter case assignshift==0, so only notfound case is important.
1633      */
1634   if (( (method + assignshift == off)
1635         && (assign || (method == inc_amg) || (method == dec_amg)))
1636       || force_cpy)
1637     RvDEEPCP(left);
1638   {
1639     dSP;
1640     BINOP myop;
1641     SV* res;
1642     bool oldcatch = CATCH_GET;
1643
1644     CATCH_SET(TRUE);
1645     Zero(&myop, 1, BINOP);
1646     myop.op_last = (OP *) &myop;
1647     myop.op_next = Nullop;
1648     myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
1649
1650     PUSHSTACKi(PERLSI_OVERLOAD);
1651     ENTER;
1652     SAVEOP();
1653     PL_op = (OP *) &myop;
1654     if (PERLDB_SUB && PL_curstash != PL_debstash)
1655         PL_op->op_private |= OPpENTERSUB_DB;
1656     PUTBACK;
1657     pp_pushmark();
1658
1659     EXTEND(SP, notfound + 5);
1660     PUSHs(lr>0? right: left);
1661     PUSHs(lr>0? left: right);
1662     PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no ));
1663     if (notfound) {
1664       PUSHs( sv_2mortal(newSVpv(AMG_id2name(method + assignshift),0)));
1665     }
1666     PUSHs((SV*)cv);
1667     PUTBACK;
1668
1669     if ((PL_op = Perl_pp_entersub(aTHX)))
1670       CALLRUNOPS(aTHX);
1671     LEAVE;
1672     SPAGAIN;
1673
1674     res=POPs;
1675     PUTBACK;
1676     POPSTACK;
1677     CATCH_SET(oldcatch);
1678
1679     if (postpr) {
1680       int ans=0;
1681       switch (method) {
1682       case le_amg:
1683       case sle_amg:
1684         ans=SvIV(res)<=0; break;
1685       case lt_amg:
1686       case slt_amg:
1687         ans=SvIV(res)<0; break;
1688       case ge_amg:
1689       case sge_amg:
1690         ans=SvIV(res)>=0; break;
1691       case gt_amg:
1692       case sgt_amg:
1693         ans=SvIV(res)>0; break;
1694       case eq_amg:
1695       case seq_amg:
1696         ans=SvIV(res)==0; break;
1697       case ne_amg:
1698       case sne_amg:
1699         ans=SvIV(res)!=0; break;
1700       case inc_amg:
1701       case dec_amg:
1702         SvSetSV(left,res); return left;
1703       case not_amg:
1704         ans=!SvTRUE(res); break;
1705       }
1706       return boolSV(ans);
1707     } else if (method==copy_amg) {
1708       if (!SvROK(res)) {
1709         Perl_croak(aTHX_ "Copy method did not return a reference");
1710       }
1711       return SvREFCNT_inc(SvRV(res));
1712     } else {
1713       return res;
1714     }
1715   }
1716 }
1717
1718 /*
1719 =for apidoc is_gv_magical
1720
1721 Returns C<TRUE> if given the name of a magical GV.
1722
1723 Currently only useful internally when determining if a GV should be
1724 created even in rvalue contexts.
1725
1726 C<flags> is not used at present but available for future extension to
1727 allow selecting particular classes of magical variable.
1728
1729 =cut
1730 */
1731 bool
1732 Perl_is_gv_magical(pTHX_ char *name, STRLEN len, U32 flags)
1733 {
1734     if (!len)
1735         return FALSE;
1736
1737     switch (*name) {
1738     case 'I':
1739         if (len == 3 && strEQ(name, "ISA"))
1740             goto yes;
1741         break;
1742     case 'O':
1743         if (len == 8 && strEQ(name, "OVERLOAD"))
1744             goto yes;
1745         break;
1746     case 'S':
1747         if (len == 3 && strEQ(name, "SIG"))
1748             goto yes;
1749         break;
1750     case '\017':   /* $^O & $^OPEN */
1751         if (len == 1
1752             || (len == 4 && strEQ(name, "\027PEN")))
1753         {
1754             goto yes;
1755         }
1756         break;
1757     case '\027':   /* $^W & $^WARNING_BITS */
1758         if (len == 1
1759             || (len == 12 && strEQ(name, "\027ARNING_BITS"))
1760             || (len == 17 && strEQ(name, "\027IDE_SYSTEM_CALLS")))
1761         {
1762             goto yes;
1763         }
1764         break;
1765
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 ']':
1792     case '\001':   /* $^A */
1793     case '\003':   /* $^C */
1794     case '\004':   /* $^D */
1795     case '\005':   /* $^E */
1796     case '\006':   /* $^F */
1797     case '\010':   /* $^H */
1798     case '\011':   /* $^I, NOT \t in EBCDIC */
1799     case '\014':   /* $^L */
1800     case '\016':   /* $^N */
1801     case '\020':   /* $^P */
1802     case '\023':   /* $^S */
1803     case '\026':   /* $^V */
1804         if (len == 1)
1805             goto yes;
1806         break;
1807     case '\024':   /* $^T, ${^TAINT} */
1808         if (len == 1 || strEQ(name, "\024AINT"))
1809             goto yes;
1810         break;
1811     case '1':
1812     case '2':
1813     case '3':
1814     case '4':
1815     case '5':
1816     case '6':
1817     case '7':
1818     case '8':
1819     case '9':
1820         if (len > 1) {
1821             char *end = name + len;
1822             while (--end > name) {
1823                 if (!isDIGIT(*end))
1824                     return FALSE;
1825             }
1826         }
1827     yes:
1828         return TRUE;
1829     default:
1830         break;
1831     }
1832     return FALSE;
1833 }