gv.c

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