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     dVAR;
 109     register GP *gp;
 110     const bool doproto = SvTYPE(gv) > SVt_NULL;
 111     char *proto = (doproto && SvPOK(gv)) ? SvPVX(gv) : NULL;
 112
 113     sv_upgrade((SV*)gv, SVt_PVGV);
 114     if (SvLEN(gv)) {
 115         if (proto) {
 116             SvPV_set(gv, NULL);
 117             SvLEN_set(gv, 0);
 118             SvPOK_off(gv);
 119         } else
 120             Safefree(SvPVX(gv));
 121     }
 122     Newz(602, gp, 1, GP);
 123     GvGP(gv) = gp_ref(gp);
 124     GvSV(gv) = NEWSV(72,0);
 125     GvLINE(gv) = CopLINE(PL_curcop);
 126     /* XXX Ideally this cast would be replaced with a change to const char*
 127        in the struct.  */
 128     GvFILE(gv) = CopFILE(PL_curcop) ? CopFILE(PL_curcop) : (char *) "";
 129     GvCVGEN(gv) = 0;
 130     GvEGV(gv) = gv;
 131     sv_magic((SV*)gv, (SV*)gv, PERL_MAGIC_glob, Nullch, 0);
 132     GvSTASH(gv) = (HV*)SvREFCNT_inc(stash);
 133     GvNAME(gv) = savepvn(name, len);
 134     GvNAMELEN(gv) = len;
 135     if (multi || doproto)              /* doproto means it _was_ mentioned */
 136         GvMULTI_on(gv);
 137     if (doproto) {                      /* Replicate part of newSUB here. */
 138         SvIOK_off(gv);
 139         ENTER;
 140         /* XXX unsafe for threads if eval_owner isn't held */
 141         start_subparse(0,0);            /* Create CV in compcv. */
 142         GvCV(gv) = PL_compcv;
 143         LEAVE;
 144
 145         PL_sub_generation++;
 146         CvGV(GvCV(gv)) = gv;
 147         CvFILE_set_from_cop(GvCV(gv), PL_curcop);
 148         CvSTASH(GvCV(gv)) = PL_curstash;
 149         if (proto) {
 150             sv_setpv((SV*)GvCV(gv), proto);
 151             Safefree(proto);
 152         }
 153     }
 154 }
 155
 156 STATIC void
 157 S_gv_init_sv(pTHX_ GV *gv, I32 sv_type)
 158 {
 159     switch (sv_type) {
 160     case SVt_PVIO:
 161         (void)GvIOn(gv);
 162         break;
 163     case SVt_PVAV:
 164         (void)GvAVn(gv);
 165         break;
 166     case SVt_PVHV:
 167         (void)GvHVn(gv);
 168         break;
 169     }
 170 }
 171
 172 /*
 173 =for apidoc gv_fetchmeth
 174
 175 Returns the glob with the given C<name> and a defined subroutine or
 176 C<NULL>.  The glob lives in the given C<stash>, or in the stashes
 177 accessible via @ISA and UNIVERSAL::.
 178
 179 The argument C<level> should be either 0 or -1.  If C<level==0>, as a
 180 side-effect creates a glob with the given C<name> in the given C<stash>
 181 which in the case of success contains an alias for the subroutine, and sets
 182 up caching info for this glob.  Similarly for all the searched stashes.
 183
 184 This function grants C<"SUPER"> token as a postfix of the stash name. The
 185 GV returned from C<gv_fetchmeth> may be a method cache entry, which is not
 186 visible to Perl code.  So when calling C<call_sv>, you should not use
 187 the GV directly; instead, you should use the method's CV, which can be
 188 obtained from the GV with the C<GvCV> macro.
 189
 190 =cut
 191 */
 192
 193 GV *
 194 Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level)
 195 {
 196     AV* av;
 197     GV* topgv;
 198     GV* gv;
 199     GV** gvp;
 200     CV* cv;
 201
 202     /* UNIVERSAL methods should be callable without a stash */
 203     if (!stash) {
 204         level = -1;  /* probably appropriate */
 205         if(!(stash = gv_stashpvn("UNIVERSAL", 9, FALSE)))
 206             return 0;
 207     }
 208
 209     if (!HvNAME(stash))
 210       Perl_croak(aTHX_
 211                  "Can't use anonymous symbol table for method lookup");
 212
 213     if ((level > 100) || (level < -100))
 214         Perl_croak(aTHX_ "Recursive inheritance detected while looking for method '%s' in package '%s'",
 215               name, HvNAME(stash));
 216
 217     DEBUG_o( Perl_deb(aTHX_ "Looking for method %s in package %s\n",name,HvNAME(stash)) );
 218
 219     gvp = (GV**)hv_fetch(stash, name, len, (level >= 0));
 220     if (!gvp)
 221         topgv = Nullgv;
 222     else {
 223         topgv = *gvp;
 224         if (SvTYPE(topgv) != SVt_PVGV)
 225             gv_init(topgv, stash, name, len, TRUE);
 226         if ((cv = GvCV(topgv))) {
 227             /* If genuine method or valid cache entry, use it */
 228             if (!GvCVGEN(topgv) || GvCVGEN(topgv) == PL_sub_generation)
 229                 return topgv;
 230             /* Stale cached entry: junk it */
 231             SvREFCNT_dec(cv);
 232             GvCV(topgv) = cv = Nullcv;
 233             GvCVGEN(topgv) = 0;
 234         }
 235         else if (GvCVGEN(topgv) == PL_sub_generation)
 236             return 0;  /* cache indicates sub doesn't exist */
 237     }
 238
 239     gvp = (GV**)hv_fetch(stash, "ISA", 3, FALSE);
 240     av = (gvp && (gv = *gvp) && gv != (GV*)&PL_sv_undef) ? GvAV(gv) : Nullav;
 241
 242     /* create and re-create @.*::SUPER::ISA on demand */
 243     if (!av || !SvMAGIC(av)) {
 244         const char* packname = HvNAME(stash);
 245         STRLEN packlen = strlen(packname);
 246
 247         if (packlen >= 7 && strEQ(packname + packlen - 7, "::SUPER")) {
 248             HV* basestash;
 249
 250             packlen -= 7;
 251             basestash = gv_stashpvn(packname, packlen, TRUE);
 252             gvp = (GV**)hv_fetch(basestash, "ISA", 3, FALSE);
 253             if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (av = GvAV(gv))) {
 254                 gvp = (GV**)hv_fetch(stash, "ISA", 3, TRUE);
 255                 if (!gvp || !(gv = *gvp))
 256                     Perl_croak(aTHX_ "Cannot create %s::ISA", HvNAME(stash));
 257                 if (SvTYPE(gv) != SVt_PVGV)
 258                     gv_init(gv, stash, "ISA", 3, TRUE);
 259                 SvREFCNT_dec(GvAV(gv));
 260                 GvAV(gv) = (AV*)SvREFCNT_inc(av);
 261             }
 262         }
 263     }
 264
 265     if (av) {
 266         SV** svp = AvARRAY(av);
 267         /* NOTE: No support for tied ISA */
 268         I32 items = AvFILLp(av) + 1;
 269         while (items--) {
 270             SV* sv = *svp++;
 271             HV* basestash = gv_stashsv(sv, FALSE);
 272             if (!basestash) {
 273                 if (ckWARN(WARN_MISC))
 274                     Perl_warner(aTHX_ packWARN(WARN_MISC), "Can't locate package %"SVf" for @%s::ISA",
 275                         sv, HvNAME(stash));
 276                 continue;
 277             }
 278             gv = gv_fetchmeth(basestash, name, len,
 279                               (level >= 0) ? level + 1 : level - 1);
 280             if (gv)
 281                 goto gotcha;
 282         }
 283     }
 284
 285     /* if at top level, try UNIVERSAL */
 286
 287     if (level == 0 || level == -1) {
 288         HV* lastchance;
 289
 290         if ((lastchance = gv_stashpvn("UNIVERSAL", 9, FALSE))) {
 291             if ((gv = gv_fetchmeth(lastchance, name, len,
 292                                   (level >= 0) ? level + 1 : level - 1)))
 293             {
 294           gotcha:
 295                 /*
 296                  * Cache method in topgv if:
 297                  *  1. topgv has no synonyms (else inheritance crosses wires)
 298                  *  2. method isn't a stub (else AUTOLOAD fails spectacularly)
 299                  */
 300                 if (topgv &&
 301                     GvREFCNT(topgv) == 1 &&
 302                     (cv = GvCV(gv)) &&
 303                     (CvROOT(cv) || CvXSUB(cv)))
 304                 {
 305                     if ((cv = GvCV(topgv)))
 306                         SvREFCNT_dec(cv);
 307                     GvCV(topgv) = (CV*)SvREFCNT_inc(GvCV(gv));
 308                     GvCVGEN(topgv) = PL_sub_generation;
 309                 }
 310                 return gv;
 311             }
 312             else if (topgv && GvREFCNT(topgv) == 1) {
 313                 /* cache the fact that the method is not defined */
 314                 GvCVGEN(topgv) = PL_sub_generation;
 315             }
 316         }
 317     }
 318
 319     return 0;
 320 }
 321
 322 /*
 323 =for apidoc gv_fetchmeth_autoload
 324
 325 Same as gv_fetchmeth(), but looks for autoloaded subroutines too.
 326 Returns a glob for the subroutine.
 327
 328 For an autoloaded subroutine without a GV, will create a GV even
 329 if C<level < 0>.  For an autoloaded subroutine without a stub, GvCV()
 330 of the result may be zero.
 331
 332 =cut
 333 */
 334
 335 GV *
 336 Perl_gv_fetchmeth_autoload(pTHX_ HV *stash, const char *name, STRLEN len, I32 level)
 337 {
 338     GV *gv = gv_fetchmeth(stash, name, len, level);
 339
 340     if (!gv) {
 341         const char autoload[] = "AUTOLOAD";
 342         STRLEN autolen = sizeof(autoload)-1;
 343         CV *cv;
 344         GV **gvp;
 345
 346         if (!stash)
 347             return Nullgv;      /* UNIVERSAL::AUTOLOAD could cause trouble */
 348         if (len == autolen && strnEQ(name, autoload, autolen))
 349             return Nullgv;
 350         if (!(gv = gv_fetchmeth(stash, autoload, autolen, FALSE)))
 351             return Nullgv;
 352         cv = GvCV(gv);
 353         if (!(CvROOT(cv) || CvXSUB(cv)))
 354             return Nullgv;
 355         /* Have an autoload */
 356         if (level < 0)  /* Cannot do without a stub */
 357             gv_fetchmeth(stash, name, len, 0);
 358         gvp = (GV**)hv_fetch(stash, name, len, (level >= 0));
 359         if (!gvp)
 360             return Nullgv;
 361         return *gvp;
 362     }
 363     return gv;
 364 }
 365
 366 /*
 367 =for apidoc gv_fetchmethod
 368
 369 See L<gv_fetchmethod_autoload>.
 370
 371 =cut
 372 */
 373
 374 GV *
 375 Perl_gv_fetchmethod(pTHX_ HV *stash, const char *name)
 376 {
 377     return gv_fetchmethod_autoload(stash, name, TRUE);
 378 }
 379
 380 /*
 381 =for apidoc gv_fetchmethod_autoload
 382
 383 Returns the glob which contains the subroutine to call to invoke the method
 384 on the C<stash>.  In fact in the presence of autoloading this may be the
 385 glob for "AUTOLOAD".  In this case the corresponding variable $AUTOLOAD is
 386 already setup.
 387
 388 The third parameter of C<gv_fetchmethod_autoload> determines whether
 389 AUTOLOAD lookup is performed if the given method is not present: non-zero
 390 means yes, look for AUTOLOAD; zero means no, don't look for AUTOLOAD.
 391 Calling C<gv_fetchmethod> is equivalent to calling C<gv_fetchmethod_autoload>
 392 with a non-zero C<autoload> parameter.
 393
 394 These functions grant C<"SUPER"> token as a prefix of the method name. Note
 395 that if you want to keep the returned glob for a long time, you need to
 396 check for it being "AUTOLOAD", since at the later time the call may load a
 397 different subroutine due to $AUTOLOAD changing its value. Use the glob
 398 created via a side effect to do this.
 399
 400 These functions have the same side-effects and as C<gv_fetchmeth> with
 401 C<level==0>.  C<name> should be writable if contains C<':'> or C<'
 402 ''>. The warning against passing the GV returned by C<gv_fetchmeth> to
 403 C<call_sv> apply equally to these functions.
 404
 405 =cut
 406 */
 407
 408 GV *
 409 Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload)
 410 {
 411     register const char *nend;
 412     const char *nsplit = 0;
 413     GV* gv;
 414     HV* ostash = stash;
 415
 416     if (stash && SvTYPE(stash) < SVt_PVHV)
 417         stash = Nullhv;
 418
 419     for (nend = name; *nend; nend++) {
 420         if (*nend == '\'')
 421             nsplit = nend;
 422         else if (*nend == ':' && *(nend + 1) == ':')
 423             nsplit = ++nend;
 424     }
 425     if (nsplit) {
 426         const char *origname = name;
 427         name = nsplit + 1;
 428         if (*nsplit == ':')
 429             --nsplit;
 430         if ((nsplit - origname) == 5 && strnEQ(origname, "SUPER", 5)) {
 431             /* ->SUPER::method should really be looked up in original stash */
 432             SV *tmpstr = sv_2mortal(Perl_newSVpvf(aTHX_ "%s::SUPER",
 433                                                   CopSTASHPV(PL_curcop)));
 434             /* __PACKAGE__::SUPER stash should be autovivified */
 435             stash = gv_stashpvn(SvPVX(tmpstr), SvCUR(tmpstr), TRUE);
 436             DEBUG_o( Perl_deb(aTHX_ "Treating %s as %s::%s\n",
 437                          origname, HvNAME(stash), name) );
 438         }
 439         else {
 440             /* don't autovifify if ->NoSuchStash::method */
 441             stash = gv_stashpvn(origname, nsplit - origname, FALSE);
 442
 443             /* however, explicit calls to Pkg::SUPER::method may
 444                happen, and may require autovivification to work */
 445             if (!stash && (nsplit - origname) >= 7 &&
 446                 strnEQ(nsplit - 7, "::SUPER", 7) &&
 447                 gv_stashpvn(origname, nsplit - origname - 7, FALSE))
 448               stash = gv_stashpvn(origname, nsplit - origname, TRUE);
 449         }
 450         ostash = stash;
 451     }
 452
 453     gv = gv_fetchmeth(stash, name, nend - name, 0);
 454     if (!gv) {
 455         if (strEQ(name,"import") || strEQ(name,"unimport"))
 456             gv = (GV*)&PL_sv_yes;
 457         else if (autoload)
 458             gv = gv_autoload4(ostash, name, nend - name, TRUE);
 459     }
 460     else if (autoload) {
 461         CV* cv = GvCV(gv);
 462         if (!CvROOT(cv) && !CvXSUB(cv)) {
 463             GV* stubgv;
 464             GV* autogv;
 465
 466             if (CvANON(cv))
 467                 stubgv = gv;
 468             else {
 469                 stubgv = CvGV(cv);
 470                 if (GvCV(stubgv) != cv)         /* orphaned import */
 471                     stubgv = gv;
 472             }
 473             autogv = gv_autoload4(GvSTASH(stubgv),
 474                                   GvNAME(stubgv), GvNAMELEN(stubgv), TRUE);
 475             if (autogv)
 476                 gv = autogv;
 477         }
 478     }
 479
 480     return gv;
 481 }
 482
 483 GV*
 484 Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method)
 485 {
 486     dVAR;
 487     const char autoload[] = "AUTOLOAD";
 488     const STRLEN autolen = sizeof(autoload)-1;
 489     GV* gv;
 490     CV* cv;
 491     HV* varstash;
 492     GV* vargv;
 493     SV* varsv;
 494     const char *packname = "";
 495
 496     if (len == autolen && strnEQ(name, autoload, autolen))
 497         return Nullgv;
 498     if (stash) {
 499         if (SvTYPE(stash) < SVt_PVHV) {
 500             packname = SvPV_nolen((SV*)stash);
 501             stash = Nullhv;
 502         }
 503         else {
 504             packname = HvNAME(stash);
 505         }
 506     }
 507     if (!(gv = gv_fetchmeth(stash, autoload, autolen, FALSE)))
 508         return Nullgv;
 509     cv = GvCV(gv);
 510
 511     if (!(CvROOT(cv) || CvXSUB(cv)))
 512         return Nullgv;
 513
 514     /*
 515      * Inheriting AUTOLOAD for non-methods works ... for now.
 516      */
 517     if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX) && !method &&
 518         (GvCVGEN(gv) || GvSTASH(gv) != stash))
 519         Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
 520           "Use of inherited AUTOLOAD for non-method %s::%.*s() is deprecated",
 521              packname, (int)len, name);
 522
 523     if (CvXSUB(cv)) {
 524         /* rather than lookup/init $AUTOLOAD here
 525          * only to have the XSUB do another lookup for $AUTOLOAD
 526          * and split that value on the last '::',
 527          * pass along the same data via some unused fields in the CV
 528          */
 529         CvSTASH(cv) = stash;
 530         SvPV_set(cv, (char *)name); /* cast to lose constness warning */
 531         SvCUR_set(cv, len);
 532         return gv;
 533     }
 534
 535     /*
 536      * Given &FOO::AUTOLOAD, set $FOO::AUTOLOAD to desired function name.
 537      * The subroutine's original name may not be "AUTOLOAD", so we don't
 538      * use that, but for lack of anything better we will use the sub's
 539      * original package to look up $AUTOLOAD.
 540      */
 541     varstash = GvSTASH(CvGV(cv));
 542     vargv = *(GV**)hv_fetch(varstash, autoload, autolen, TRUE);
 543     ENTER;
 544
 545     if (!isGV(vargv))
 546         gv_init(vargv, varstash, autoload, autolen, FALSE);
 547     LEAVE;
 548     varsv = GvSV(vargv);
 549     sv_setpv(varsv, packname);
 550     sv_catpvn(varsv, "::", 2);
 551     sv_catpvn(varsv, name, len);
 552     SvTAINTED_off(varsv);
 553     return gv;
 554 }
 555
 556 /* The "gv" parameter should be the glob known to Perl code as *!
 557  * The scalar must already have been magicalized.
 558  */
 559 STATIC void
 560 S_require_errno(pTHX_ GV *gv)
 561 {
 562     dVAR;
 563     HV* stash = gv_stashpvn("Errno",5,FALSE);
 564
 565     if (!stash || !(gv_fetchmethod(stash, "TIEHASH"))) {
 566         dSP;
 567         PUTBACK;
 568         ENTER;
 569         save_scalar(gv); /* keep the value of $! */
 570         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
 571                          newSVpvn("Errno",5), Nullsv);
 572         LEAVE;
 573         SPAGAIN;
 574         stash = gv_stashpvn("Errno",5,FALSE);
 575         if (!stash || !(gv_fetchmethod(stash, "TIEHASH")))
 576             Perl_croak(aTHX_ "Can't use %%! because Errno.pm is not available");
 577     }
 578 }
 579
 580 /*
 581 =for apidoc gv_stashpv
 582
 583 Returns a pointer to the stash for a specified package.  C<name> should
 584 be a valid UTF-8 string and must be null-terminated.  If C<create> is set
 585 then the package will be created if it does not already exist.  If C<create>
 586 is not set and the package does not exist then NULL is returned.
 587
 588 =cut
 589 */
 590
 591 HV*
 592 Perl_gv_stashpv(pTHX_ const char *name, I32 create)
 593 {
 594     return gv_stashpvn(name, strlen(name), create);
 595 }
 596
 597 /*
 598 =for apidoc gv_stashpvn
 599
 600 Returns a pointer to the stash for a specified package.  C<name> should
 601 be a valid UTF-8 string.  The C<namelen> parameter indicates the length of
 602 the C<name>, in bytes.  If C<create> is set then the package will be
 603 created if it does not already exist.  If C<create> is not set and the
 604 package does not exist then NULL is returned.
 605
 606 =cut
 607 */
 608
 609 HV*
 610 Perl_gv_stashpvn(pTHX_ const char *name, U32 namelen, I32 create)
 611 {
 612     char smallbuf[256];
 613     char *tmpbuf;
 614     HV *stash;
 615     GV *tmpgv;
 616
 617     if (namelen + 3 < sizeof smallbuf)
 618         tmpbuf = smallbuf;
 619     else
 620         New(606, tmpbuf, namelen + 3, char);
 621     Copy(name,tmpbuf,namelen,char);
 622     tmpbuf[namelen++] = ':';
 623     tmpbuf[namelen++] = ':';
 624     tmpbuf[namelen] = '\0';
 625     tmpgv = gv_fetchpv(tmpbuf, create, SVt_PVHV);
 626     if (tmpbuf != smallbuf)
 627         Safefree(tmpbuf);
 628     if (!tmpgv)
 629         return 0;
 630     if (!GvHV(tmpgv))
 631         GvHV(tmpgv) = newHV();
 632     stash = GvHV(tmpgv);
 633     if (!HvNAME(stash))
 634         HvNAME(stash) = savepv(name);
 635     return stash;
 636 }
 637
 638 /*
 639 =for apidoc gv_stashsv
 640
 641 Returns a pointer to the stash for a specified package, which must be a
 642 valid UTF-8 string.  See C<gv_stashpv>.
 643
 644 =cut
 645 */
 646
 647 HV*
 648 Perl_gv_stashsv(pTHX_ SV *sv, I32 create)
 649 {
 650     STRLEN len;
 651     const char *ptr = SvPV(sv,len);
 652     return gv_stashpvn(ptr, len, create);
 653 }
 654
 655
 656 GV *
 657 Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type) {
 658     return gv_fetchpvn_flags(nambeg, strlen(nambeg), add, sv_type);
 659 }
 660
 661 GV *
 662 Perl_gv_fetchsv(pTHX_ SV *name, I32 flags, I32 sv_type) {
 663     STRLEN len;
 664     const char *nambeg = SvPV(name, len);
 665     return gv_fetchpvn_flags(nambeg, len, flags | SvUTF8(name), sv_type);
 666 }
 667
 668 GV *
 669 Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
 670                        I32 sv_type)
 671 {
 672     register const char *name = nambeg;
 673     register GV *gv = 0;
 674     GV**gvp;
 675     I32 len;
 676     register const char *namend;
 677     HV *stash = 0;
 678     const I32 add = flags & ~SVf_UTF8;
 679     (void)full_len;
 680
 681     if (*name == '*' && isALPHA(name[1])) /* accidental stringify on a GV? */
 682         name++;
 683
 684     for (namend = name; *namend; namend++) {
 685         if ((*namend == ':' && namend[1] == ':')
 686             || (*namend == '\'' && namend[1]))
 687         {
 688             if (!stash)
 689                 stash = PL_defstash;
 690             if (!stash || !SvREFCNT(stash)) /* symbol table under destruction */
 691                 return Nullgv;
 692
 693             len = namend - name;
 694             if (len > 0) {
 695                 char smallbuf[256];
 696                 char *tmpbuf;
 697
 698                 if (len + 3 < sizeof (smallbuf))
 699                     tmpbuf = smallbuf;
 700                 else
 701                     New(601, tmpbuf, len+3, char);
 702                 Copy(name, tmpbuf, len, char);
 703                 tmpbuf[len++] = ':';
 704                 tmpbuf[len++] = ':';
 705                 tmpbuf[len] = '\0';
 706                 gvp = (GV**)hv_fetch(stash,tmpbuf,len,add);
 707                 gv = gvp ? *gvp : Nullgv;
 708                 if (gv && gv != (GV*)&PL_sv_undef) {
 709                     if (SvTYPE(gv) != SVt_PVGV)
 710                         gv_init(gv, stash, tmpbuf, len, (add & GV_ADDMULTI));
 711                     else
 712                         GvMULTI_on(gv);
 713                 }
 714                 if (tmpbuf != smallbuf)
 715                     Safefree(tmpbuf);
 716                 if (!gv || gv == (GV*)&PL_sv_undef)
 717                     return Nullgv;
 718
 719                 if (!(stash = GvHV(gv)))
 720                     stash = GvHV(gv) = newHV();
 721
 722                 if (!HvNAME(stash))
 723                     HvNAME(stash) = savepvn(nambeg, namend - nambeg);
 724             }
 725
 726             if (*namend == ':')
 727                 namend++;
 728             namend++;
 729             name = namend;
 730             if (!*name)
 731                 return gv ? gv : (GV*)*hv_fetch(PL_defstash, "main::", 6, TRUE);
 732         }
 733     }
 734     len = namend - name;
 735
 736     /* No stash in name, so see how we can default */
 737
 738     if (!stash) {
 739         if (isIDFIRST_lazy(name)) {
 740             bool global = FALSE;
 741
 742             /* name is always \0 terminated, and initial \0 wouldn't return
 743                true from isIDFIRST_lazy, so we know that name[1] is defined  */
 744             switch (name[1]) {
 745             case '\0':
 746                 if (*name == '_')
 747                     global = TRUE;
 748                 break;
 749             case 'N':
 750                 if (strEQ(name, "INC") || strEQ(name, "ENV"))
 751                     global = TRUE;
 752                 break;
 753             case 'I':
 754                 if (strEQ(name, "SIG"))
 755                     global = TRUE;
 756                 break;
 757             case 'T':
 758                 if (strEQ(name, "STDIN") || strEQ(name, "STDOUT") ||
 759                     strEQ(name, "STDERR"))
 760                     global = TRUE;
 761                 break;
 762             case 'R':
 763                 if (strEQ(name, "ARGV") || strEQ(name, "ARGVOUT"))
 764                     global = TRUE;
 765                 break;
 766             }
 767
 768             if (global)
 769                 stash = PL_defstash;
 770             else if (IN_PERL_COMPILETIME) {
 771                 stash = PL_curstash;
 772                 if (add && (PL_hints & HINT_STRICT_VARS) &&
 773                     sv_type != SVt_PVCV &&
 774                     sv_type != SVt_PVGV &&
 775                     sv_type != SVt_PVFM &&
 776                     sv_type != SVt_PVIO &&
 777                     !(len == 1 && sv_type == SVt_PV &&
 778                       (*name == 'a' || *name == 'b')) )
 779                 {
 780                     gvp = (GV**)hv_fetch(stash,name,len,0);
 781                     if (!gvp ||
 782                         *gvp == (GV*)&PL_sv_undef ||
 783                         SvTYPE(*gvp) != SVt_PVGV)
 784                     {
 785                         stash = 0;
 786                     }
 787                     else if ((sv_type == SVt_PV   && !GvIMPORTED_SV(*gvp)) ||
 788                              (sv_type == SVt_PVAV && !GvIMPORTED_AV(*gvp)) ||
 789                              (sv_type == SVt_PVHV && !GvIMPORTED_HV(*gvp)) )
 790                     {
 791                         Perl_warn(aTHX_ "Variable \"%c%s\" is not imported",
 792                             sv_type == SVt_PVAV ? '@' :
 793                             sv_type == SVt_PVHV ? '%' : '$',
 794                             name);
 795                         if (GvCVu(*gvp))
 796                             Perl_warn(aTHX_ "\t(Did you mean &%s instead?)\n", name);
 797                         stash = 0;
 798                     }
 799                 }
 800             }
 801             else
 802                 stash = CopSTASH(PL_curcop);
 803         }
 804         else
 805             stash = PL_defstash;
 806     }
 807
 808     /* By this point we should have a stash and a name */
 809
 810     if (!stash) {
 811         if (add) {
 812             register SV *err = Perl_mess(aTHX_
 813                  "Global symbol \"%s%s\" requires explicit package name",
 814                  (sv_type == SVt_PV ? "$"
 815                   : sv_type == SVt_PVAV ? "@"
 816                   : sv_type == SVt_PVHV ? "%"
 817                   : ""), name);
 818             if (USE_UTF8_IN_NAMES)
 819                 SvUTF8_on(err);
 820             qerror(err);
 821             stash = GvHV(gv_fetchpv("<none>::", GV_ADDMULTI, SVt_PVHV));
 822         }
 823         else
 824             return Nullgv;
 825     }
 826
 827     if (!SvREFCNT(stash))       /* symbol table under destruction */
 828         return Nullgv;
 829
 830     gvp = (GV**)hv_fetch(stash,name,len,add);
 831     if (!gvp || *gvp == (GV*)&PL_sv_undef)
 832         return Nullgv;
 833     gv = *gvp;
 834     if (SvTYPE(gv) == SVt_PVGV) {
 835         if (add) {
 836             GvMULTI_on(gv);
 837             gv_init_sv(gv, sv_type);
 838             if (*name=='!' && sv_type == SVt_PVHV && len==1)
 839                 require_errno(gv);
 840         }
 841         return gv;
 842     } else if (add & GV_NOINIT) {
 843         return gv;
 844     }
 845
 846     /* Adding a new symbol */
 847
 848     if (add & GV_ADDWARN && ckWARN_d(WARN_INTERNAL))
 849         Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "Had to create %s unexpectedly", nambeg);
 850     gv_init(gv, stash, name, len, add & GV_ADDMULTI);
 851     gv_init_sv(gv, sv_type);
 852
 853     if (isALPHA(name[0]) && ! (isLEXWARN_on ? ckWARN(WARN_ONCE)
 854                                             : (PL_dowarn & G_WARN_ON ) ) )
 855         GvMULTI_on(gv) ;
 856
 857     /* set up magic where warranted */
 858     if (len > 1) {
 859 #ifndef EBCDIC
 860         if (*name > 'V' ) {
 861             /* Nothing else to do.
 862                The compiler will probably turn the switch statement into a
 863                branch table. Make sure we avoid even that small overhead for
 864                the common case of lower case variable names.  */
 865         } else
 866 #endif
 867         {
 868             const char *name2 = name + 1;
 869             switch (*name) {
 870             case 'A':
 871                 if (strEQ(name2, "RGV")) {
 872                     IoFLAGS(GvIOn(gv)) |= IOf_ARGV|IOf_START;
 873                 }
 874                 break;
 875             case 'E':
 876                 if (strnEQ(name2, "XPORT", 5))
 877                     GvMULTI_on(gv);
 878                 break;
 879             case 'I':
 880                 if (strEQ(name2, "SA")) {
 881                     AV* av = GvAVn(gv);
 882                     GvMULTI_on(gv);
 883                     sv_magic((SV*)av, (SV*)gv, PERL_MAGIC_isa, Nullch, 0);
 884                     /* NOTE: No support for tied ISA */
 885                     if ((add & GV_ADDMULTI) && strEQ(nambeg,"AnyDBM_File::ISA")
 886                         && AvFILLp(av) == -1)
 887                         {
 888                             const char *pname;
 889                             av_push(av, newSVpvn(pname = "NDBM_File",9));
 890                             gv_stashpvn(pname, 9, TRUE);
 891                             av_push(av, newSVpvn(pname = "DB_File",7));
 892                             gv_stashpvn(pname, 7, TRUE);
 893                             av_push(av, newSVpvn(pname = "GDBM_File",9));
 894                             gv_stashpvn(pname, 9, TRUE);
 895                             av_push(av, newSVpvn(pname = "SDBM_File",9));
 896                             gv_stashpvn(pname, 9, TRUE);
 897                             av_push(av, newSVpvn(pname = "ODBM_File",9));
 898                             gv_stashpvn(pname, 9, TRUE);
 899                         }
 900                 }
 901                 break;
 902             case 'O':
 903                 if (strEQ(name2, "VERLOAD")) {
 904                     HV* hv = GvHVn(gv);
 905                     GvMULTI_on(gv);
 906                     hv_magic(hv, Nullgv, PERL_MAGIC_overload);
 907                 }
 908                 break;
 909             case 'S':
 910                 if (strEQ(name2, "IG")) {
 911                     HV *hv;
 912                     I32 i;
 913                     if (!PL_psig_ptr) {
 914                         Newz(73, PL_psig_ptr,  SIG_SIZE, SV*);
 915                         Newz(73, PL_psig_name, SIG_SIZE, SV*);
 916                         Newz(73, PL_psig_pend, SIG_SIZE, int);
 917                     }
 918                     GvMULTI_on(gv);
 919                     hv = GvHVn(gv);
 920                     hv_magic(hv, Nullgv, PERL_MAGIC_sig);
 921                     for (i = 1; i < SIG_SIZE; i++) {
 922                         SV ** init;
 923                         init = hv_fetch(hv, PL_sig_name[i], strlen(PL_sig_name[i]), 1);
 924                         if (init)
 925                             sv_setsv(*init, &PL_sv_undef);
 926                         PL_psig_ptr[i] = 0;
 927                         PL_psig_name[i] = 0;
 928                         PL_psig_pend[i] = 0;
 929                     }
 930                 }
 931                 break;
 932             case 'V':
 933                 if (strEQ(name2, "ERSION"))
 934                     GvMULTI_on(gv);
 935                 break;
 936             case '\005':        /* $^ENCODING */
 937                 if (strEQ(name2, "NCODING"))
 938                     goto magicalize;
 939                 break;
 940             case '\017':        /* $^OPEN */
 941                 if (strEQ(name2, "PEN"))
 942                     goto magicalize;
 943                 break;
 944             case '\024':        /* ${^TAINT} */
 945                 if (strEQ(name2, "AINT"))
 946                     goto ro_magicalize;
 947                 break;
 948             case '\025':        /* ${^UNICODE}, ${^UTF8LOCALE} */
 949                 if (strEQ(name2, "NICODE"))
 950                     goto ro_magicalize;
 951                 if (strEQ(name2, "TF8LOCALE"))
 952                     goto ro_magicalize;
 953                 break;
 954             case '\027':        /* $^WARNING_BITS */
 955                 if (strEQ(name2, "ARNING_BITS"))
 956                     goto magicalize;
 957                 break;
 958             case '1':
 959             case '2':
 960             case '3':
 961             case '4':
 962             case '5':
 963             case '6':
 964             case '7':
 965             case '8':
 966             case '9':
 967             {
 968                 /* ensures variable is only digits */
 969                 /* ${"1foo"} fails this test (and is thus writeable) */
 970                 /* added by japhy, but borrowed from is_gv_magical */
 971                 const char *end = name + len;
 972                 while (--end > name) {
 973                     if (!isDIGIT(*end)) return gv;
 974                 }
 975                 goto ro_magicalize;
 976             }
 977             }
 978         }
 979     } else {
 980         /* Names of length 1.  (Or 0. But name is NUL terminated, so that will
 981            be case '\0' in this switch statement (ie a default case)  */
 982         switch (*name) {
 983         case '&':
 984         case '`':
 985         case '\'':
 986             if (
 987                 sv_type == SVt_PVAV ||
 988                 sv_type == SVt_PVHV ||
 989                 sv_type == SVt_PVCV ||
 990                 sv_type == SVt_PVFM ||
 991                 sv_type == SVt_PVIO
 992                 ) { break; }
 993             PL_sawampersand = TRUE;
 994             goto ro_magicalize;
 995
 996         case ':':
 997             sv_setpv(GvSV(gv),PL_chopset);
 998             goto magicalize;
 999
1000         case '?':
1001 #ifdef COMPLEX_STATUS
1002             (void)SvUPGRADE(GvSV(gv), SVt_PVLV);
1003 #endif
1004             goto magicalize;
1005
1006         case '!':
1007
1008             /* If %! has been used, automatically load Errno.pm.
1009                The require will itself set errno, so in order to
1010                preserve its value we have to set up the magic
1011                now (rather than going to magicalize)
1012             */
1013
1014             sv_magic(GvSV(gv), (SV*)gv, PERL_MAGIC_sv, name, len);
1015
1016             if (sv_type == SVt_PVHV)
1017                 require_errno(gv);
1018
1019             break;
1020         case '-':
1021         {
1022             AV* av = GvAVn(gv);
1023             sv_magic((SV*)av, Nullsv, PERL_MAGIC_regdata, Nullch, 0);
1024             SvREADONLY_on(av);
1025             goto magicalize;
1026         }
1027         case '*':
1028             if (sv_type == SVt_PV && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
1029                 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
1030                             "$* is no longer supported");
1031             break;
1032         case '#':
1033             if (sv_type == SVt_PV && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
1034                 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
1035                             "Use of $# is deprecated");
1036             goto magicalize;
1037         case '|':
1038             sv_setiv(GvSV(gv), (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0);
1039             goto magicalize;
1040
1041         case '+':
1042         {
1043             AV* av = GvAVn(gv);
1044             sv_magic((SV*)av, (SV*)av, PERL_MAGIC_regdata, Nullch, 0);
1045             SvREADONLY_on(av);
1046             /* FALL THROUGH */
1047         }
1048         case '\023':    /* $^S */
1049         case '1':
1050         case '2':
1051         case '3':
1052         case '4':
1053         case '5':
1054         case '6':
1055         case '7':
1056         case '8':
1057         case '9':
1058         ro_magicalize:
1059             SvREADONLY_on(GvSV(gv));
1060             /* FALL THROUGH */
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 '/':
1074         case '\001':    /* $^A */
1075         case '\003':    /* $^C */
1076         case '\004':    /* $^D */
1077         case '\005':    /* $^E */
1078         case '\006':    /* $^F */
1079         case '\010':    /* $^H */
1080         case '\011':    /* $^I, NOT \t in EBCDIC */
1081         case '\016':    /* $^N */
1082         case '\017':    /* $^O */
1083         case '\020':    /* $^P */
1084         case '\024':    /* $^T */
1085         case '\027':    /* $^W */
1086         magicalize:
1087             sv_magic(GvSV(gv), (SV*)gv, PERL_MAGIC_sv, name, len);
1088             break;
1089
1090         case '\014':    /* $^L */
1091             sv_setpv(GvSV(gv),"\f");
1092             PL_formfeed = GvSV(gv);
1093             break;
1094         case ';':
1095             sv_setpv(GvSV(gv),"\034");
1096             break;
1097         case ']':
1098         {
1099             SV *sv = GvSV(gv);
1100             if (!sv_derived_from(PL_patchlevel, "version"))
1101                 (void *)upg_version(PL_patchlevel);
1102             GvSV(gv) = vnumify(PL_patchlevel);
1103             SvREADONLY_on(GvSV(gv));
1104             SvREFCNT_dec(sv);
1105         }
1106         break;
1107         case '\026':    /* $^V */
1108         {
1109             SV * const sv = GvSV(gv);
1110             GvSV(gv) = new_version(PL_patchlevel);
1111             SvREADONLY_on(GvSV(gv));
1112             SvREFCNT_dec(sv);
1113         }
1114         break;
1115         }
1116     }
1117     return gv;
1118 }
1119
1120 void
1121 Perl_gv_fullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
1122 {
1123     const char *name;
1124     const HV * const hv = GvSTASH(gv);
1125     if (!hv) {
1126         SvOK_off(sv);
1127         return;
1128     }
1129     sv_setpv(sv, prefix ? prefix : "");
1130
1131     name = HvNAME(hv);
1132     if (!name)
1133         name = "__ANON__";
1134
1135     if (keepmain || strNE(name, "main")) {
1136         sv_catpv(sv,name);
1137         sv_catpvn(sv,"::", 2);
1138     }
1139     sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv));
1140 }
1141
1142 void
1143 Perl_gv_fullname3(pTHX_ SV *sv, const GV *gv, const char *prefix)
1144 {
1145     gv_fullname4(sv, gv, prefix, TRUE);
1146 }
1147
1148 void
1149 Perl_gv_efullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
1150 {
1151     const GV *egv = GvEGV(gv);
1152     if (!egv)
1153         egv = gv;
1154     gv_fullname4(sv, egv, prefix, keepmain);
1155 }
1156
1157 void
1158 Perl_gv_efullname3(pTHX_ SV *sv, const GV *gv, const char *prefix)
1159 {
1160     gv_efullname4(sv, gv, prefix, TRUE);
1161 }
1162
1163 /* compatibility with versions <= 5.003. */
1164 void
1165 Perl_gv_fullname(pTHX_ SV *sv, const GV *gv)
1166 {
1167     gv_fullname3(sv, gv, sv == (const SV*)gv ? "*" : "");
1168 }
1169
1170 /* compatibility with versions <= 5.003. */
1171 void
1172 Perl_gv_efullname(pTHX_ SV *sv, const GV *gv)
1173 {
1174     gv_efullname3(sv, gv, sv == (const SV*)gv ? "*" : "");
1175 }
1176
1177 IO *
1178 Perl_newIO(pTHX)
1179 {
1180     GV *iogv;
1181     IO * const io = (IO*)NEWSV(0,0);
1182
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_set(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
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             register GV *gv;
1208             HV *hv;
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
1465     if (!stash || !HvNAME(stash))
1466         return Nullcv;
1467     mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
1468     if (!mg) {
1469       do_update:
1470         Gv_AMupdate(stash);
1471         mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
1472     }
1473     amtp = (AMT*)mg->mg_ptr;
1474     if ( amtp->was_ok_am != PL_amagic_generation
1475          || amtp->was_ok_sub != PL_sub_generation )
1476         goto do_update;
1477     if (AMT_AMAGIC(amtp)) {
1478         CV * const ret = amtp->table[id];
1479         if (ret && isGV(ret)) {         /* Autoloading stab */
1480             /* Passing it through may have resulted in a warning
1481                "Inherited AUTOLOAD for a non-method deprecated", since
1482                our caller is going through a function call, not a method call.
1483                So return the CV for AUTOLOAD, setting $AUTOLOAD. */
1484             GV *gv = gv_fetchmethod(stash, PL_AMG_names[id]);
1485
1486             if (gv && GvCV(gv))
1487                 return GvCV(gv);
1488         }
1489         return ret;
1490     }
1491
1492     return Nullcv;
1493 }
1494
1495
1496 SV*
1497 Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
1498 {
1499   dVAR;
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_set(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     const 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;
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       default:
1827         ans=0; break;
1828       }
1829       return boolSV(ans);
1830     } else if (method==copy_amg) {
1831       if (!SvROK(res)) {
1832         Perl_croak(aTHX_ "Copy method did not return a reference");
1833       }
1834       return SvREFCNT_inc(SvRV(res));
1835     } else {
1836       return res;
1837     }
1838   }
1839 }
1840
1841 /*
1842 =for apidoc is_gv_magical_sv
1843
1844 Returns C<TRUE> if given the name of a magical GV. Calls is_gv_magical.
1845
1846 =cut
1847 */
1848
1849 bool
1850 Perl_is_gv_magical_sv(pTHX_ SV *name, U32 flags)
1851 {
1852     STRLEN len;
1853     const char *temp = SvPV(name, len);
1854     return is_gv_magical(temp, len, flags);
1855 }
1856
1857 /*
1858 =for apidoc is_gv_magical
1859
1860 Returns C<TRUE> if given the name of a magical GV.
1861
1862 Currently only useful internally when determining if a GV should be
1863 created even in rvalue contexts.
1864
1865 C<flags> is not used at present but available for future extension to
1866 allow selecting particular classes of magical variable.
1867
1868 Currently assumes that C<name> is NUL terminated (as well as len being valid).
1869 This assumption is met by all callers within the perl core, which all pass
1870 pointers returned by SvPV.
1871
1872 =cut
1873 */
1874 bool
1875 Perl_is_gv_magical(pTHX_ const char *name, STRLEN len, U32 flags)
1876 {
1877     (void)flags;
1878     if (len > 1) {
1879         const char *name1 = name + 1;
1880         switch (*name) {
1881         case 'I':
1882             if (len == 3 && name1[1] == 'S' && name[2] == 'A')
1883                 goto yes;
1884             break;
1885         case 'O':
1886             if (len == 8 && strEQ(name1, "VERLOAD"))
1887                 goto yes;
1888             break;
1889         case 'S':
1890             if (len == 3 && name[1] == 'I' && name[2] == 'G')
1891                 goto yes;
1892             break;
1893             /* Using ${^...} variables is likely to be sufficiently rare that
1894                it seems sensible to avoid the space hit of also checking the
1895                length.  */
1896         case '\017':   /* ${^OPEN} */
1897             if (strEQ(name1, "PEN"))
1898                 goto yes;
1899             break;
1900         case '\024':   /* ${^TAINT} */
1901             if (strEQ(name1, "AINT"))
1902                 goto yes;
1903             break;
1904         case '\025':    /* ${^UNICODE} */
1905             if (strEQ(name1, "NICODE"))
1906                 goto yes;
1907             if (strEQ(name1, "TF8LOCALE"))
1908                 goto yes;
1909             break;
1910         case '\027':   /* ${^WARNING_BITS} */
1911             if (strEQ(name1, "ARNING_BITS"))
1912                 goto yes;
1913             break;
1914         case '1':
1915         case '2':
1916         case '3':
1917         case '4':
1918         case '5':
1919         case '6':
1920         case '7':
1921         case '8':
1922         case '9':
1923         {
1924             const char *end = name + len;
1925             while (--end > name) {
1926                 if (!isDIGIT(*end))
1927                     return FALSE;
1928             }
1929             goto yes;
1930         }
1931         }
1932     } else {
1933         /* Because we're already assuming that name is NUL terminated
1934            below, we can treat an empty name as "\0"  */
1935         switch (*name) {
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 ';':
1960         case ']':
1961         case '\001':   /* $^A */
1962         case '\003':   /* $^C */
1963         case '\004':   /* $^D */
1964         case '\005':   /* $^E */
1965         case '\006':   /* $^F */
1966         case '\010':   /* $^H */
1967         case '\011':   /* $^I, NOT \t in EBCDIC */
1968         case '\014':   /* $^L */
1969         case '\016':   /* $^N */
1970         case '\017':   /* $^O */
1971         case '\020':   /* $^P */
1972         case '\023':   /* $^S */
1973         case '\024':   /* $^T */
1974         case '\026':   /* $^V */
1975         case '\027':   /* $^W */
1976         case '1':
1977         case '2':
1978         case '3':
1979         case '4':
1980         case '5':
1981         case '6':
1982         case '7':
1983         case '8':
1984         case '9':
1985         yes:
1986             return TRUE;
1987         default:
1988             break;
1989         }
1990     }
1991     return FALSE;
1992 }