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