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