gv.c

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