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 static const char S_autoload[] = "AUTOLOAD";
  38 static const STRLEN S_autolen = sizeof(S_autoload)-1;
  39
  40 GV *
  41 Perl_gv_AVadd(pTHX_ register GV *gv)
  42 {
  43     if (!gv || SvTYPE((SV*)gv) != SVt_PVGV)
  44         Perl_croak(aTHX_ "Bad symbol for array");
  45     if (!GvAV(gv))
  46         GvAV(gv) = newAV();
  47     return gv;
  48 }
  49
  50 GV *
  51 Perl_gv_HVadd(pTHX_ register GV *gv)
  52 {
  53     if (!gv || SvTYPE((SV*)gv) != SVt_PVGV)
  54         Perl_croak(aTHX_ "Bad symbol for hash");
  55     if (!GvHV(gv))
  56         GvHV(gv) = newHV();
  57     return gv;
  58 }
  59
  60 GV *
  61 Perl_gv_IOadd(pTHX_ register GV *gv)
  62 {
  63     if (!gv || SvTYPE((SV*)gv) != SVt_PVGV)
  64         Perl_croak(aTHX_ "Bad symbol for filehandle");
  65     if (!GvIOp(gv)) {
  66 #ifdef GV_UNIQUE_CHECK
  67         if (GvUNIQUE(gv)) {
  68             Perl_croak(aTHX_ "Bad symbol for filehandle (GV is unique)");
  69         }
  70 #endif
  71         GvIOp(gv) = newIO();
  72     }
  73     return gv;
  74 }
  75
  76 GV *
  77 Perl_gv_fetchfile(pTHX_ const char *name)
  78 {
  79     char smallbuf[256];
  80     char *tmpbuf;
  81     STRLEN tmplen;
  82     GV *gv;
  83
  84     if (!PL_defstash)
  85         return Nullgv;
  86
  87     tmplen = strlen(name) + 2;
  88     if (tmplen < sizeof smallbuf)
  89         tmpbuf = smallbuf;
  90     else
  91         New(603, tmpbuf, tmplen + 1, char);
  92     /* This is where the debugger's %{"::_<$filename"} hash is created */
  93     tmpbuf[0] = '_';
  94     tmpbuf[1] = '<';
  95     strcpy(tmpbuf + 2, name);
  96     gv = *(GV**)hv_fetch(PL_defstash, tmpbuf, tmplen, TRUE);
  97     if (!isGV(gv)) {
  98         gv_init(gv, PL_defstash, tmpbuf, tmplen, FALSE);
  99         sv_setpv(GvSV(gv), name);
 100         if (PERLDB_LINE)
 101             hv_magic(GvHVn(gv_AVadd(gv)), Nullgv, PERL_MAGIC_dbfile);
 102     }
 103     if (tmpbuf != smallbuf)
 104         Safefree(tmpbuf);
 105     return gv;
 106 }
 107
 108 void
 109 Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi)
 110 {
 111     dVAR;
 112     register GP *gp;
 113     const bool doproto = SvTYPE(gv) > SVt_NULL;
 114     const char * const proto = (doproto && SvPOK(gv)) ? SvPVX(gv) : NULL;
 115
 116     sv_upgrade((SV*)gv, SVt_PVGV);
 117     if (SvLEN(gv)) {
 118         if (proto) {
 119             SvPV_set(gv, NULL);
 120             SvLEN_set(gv, 0);
 121             SvPOK_off(gv);
 122         } else
 123             Safefree(SvPVX(gv));
 124     }
 125     Newz(602, gp, 1, GP);
 126     GvGP(gv) = gp_ref(gp);
 127     GvSV(gv) = NEWSV(72,0);
 128     GvLINE(gv) = CopLINE(PL_curcop);
 129     /* XXX Ideally this cast would be replaced with a change to const char*
 130        in the struct.  */
 131     GvFILE(gv) = CopFILE(PL_curcop) ? CopFILE(PL_curcop) : (char *) "";
 132     GvCVGEN(gv) = 0;
 133     GvEGV(gv) = gv;
 134     sv_magic((SV*)gv, (SV*)gv, PERL_MAGIC_glob, Nullch, 0);
 135     GvSTASH(gv) = (HV*)SvREFCNT_inc(stash);
 136     GvNAME(gv) = savepvn(name, len);
 137     GvNAMELEN(gv) = len;
 138     if (multi || doproto)              /* doproto means it _was_ mentioned */
 139         GvMULTI_on(gv);
 140     if (doproto) {                      /* Replicate part of newSUB here. */
 141         SvIOK_off(gv);
 142         ENTER;
 143         /* XXX unsafe for threads if eval_owner isn't held */
 144         start_subparse(0,0);            /* Create CV in compcv. */
 145         GvCV(gv) = PL_compcv;
 146         LEAVE;
 147
 148         PL_sub_generation++;
 149         CvGV(GvCV(gv)) = gv;
 150         CvFILE_set_from_cop(GvCV(gv), PL_curcop);
 151         CvSTASH(GvCV(gv)) = PL_curstash;
 152         if (proto) {
 153             sv_setpv((SV*)GvCV(gv), proto);
 154             Safefree(proto);
 155         }
 156     }
 157 }
 158
 159 STATIC void
 160 S_gv_init_sv(pTHX_ GV *gv, I32 sv_type)
 161 {
 162     switch (sv_type) {
 163     case SVt_PVIO:
 164         (void)GvIOn(gv);
 165         break;
 166     case SVt_PVAV:
 167         (void)GvAVn(gv);
 168         break;
 169     case SVt_PVHV:
 170         (void)GvHVn(gv);
 171         break;
 172     }
 173 }
 174
 175 /*
 176 =for apidoc gv_fetchmeth
 177
 178 Returns the glob with the given C<name> and a defined subroutine or
 179 C<NULL>.  The glob lives in the given C<stash>, or in the stashes
 180 accessible via @ISA and UNIVERSAL::.
 181
 182 The argument C<level> should be either 0 or -1.  If C<level==0>, as a
 183 side-effect creates a glob with the given C<name> in the given C<stash>
 184 which in the case of success contains an alias for the subroutine, and sets
 185 up caching info for this glob.  Similarly for all the searched stashes.
 186
 187 This function grants C<"SUPER"> token as a postfix of the stash name. The
 188 GV returned from C<gv_fetchmeth> may be a method cache entry, which is not
 189 visible to Perl code.  So when calling C<call_sv>, you should not use
 190 the GV directly; instead, you should use the method's CV, which can be
 191 obtained from the GV with the C<GvCV> macro.
 192
 193 =cut
 194 */
 195
 196 GV *
 197 Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level)
 198 {
 199     AV* av;
 200     GV* topgv;
 201     GV* gv;
 202     GV** gvp;
 203     CV* cv;
 204
 205     /* UNIVERSAL methods should be callable without a stash */
 206     if (!stash) {
 207         level = -1;  /* probably appropriate */
 208         if(!(stash = gv_stashpvn("UNIVERSAL", 9, FALSE)))
 209             return 0;
 210     }
 211
 212     if (!HvNAME(stash))
 213       Perl_croak(aTHX_
 214                  "Can't use anonymous symbol table for method lookup");
 215
 216     if ((level > 100) || (level < -100))
 217         Perl_croak(aTHX_ "Recursive inheritance detected while looking for method '%s' in package '%s'",
 218               name, HvNAME(stash));
 219
 220     DEBUG_o( Perl_deb(aTHX_ "Looking for method %s in package %s\n",name,HvNAME(stash)) );
 221
 222     gvp = (GV**)hv_fetch(stash, name, len, (level >= 0));
 223     if (!gvp)
 224         topgv = Nullgv;
 225     else {
 226         topgv = *gvp;
 227         if (SvTYPE(topgv) != SVt_PVGV)
 228             gv_init(topgv, stash, name, len, TRUE);
 229         if ((cv = GvCV(topgv))) {
 230             /* If genuine method or valid cache entry, use it */
 231             if (!GvCVGEN(topgv) || GvCVGEN(topgv) == PL_sub_generation)
 232                 return topgv;
 233             /* Stale cached entry: junk it */
 234             SvREFCNT_dec(cv);
 235             GvCV(topgv) = cv = Nullcv;
 236             GvCVGEN(topgv) = 0;
 237         }
 238         else if (GvCVGEN(topgv) == PL_sub_generation)
 239             return 0;  /* cache indicates sub doesn't exist */
 240     }
 241
 242     gvp = (GV**)hv_fetch(stash, "ISA", 3, FALSE);
 243     av = (gvp && (gv = *gvp) && gv != (GV*)&PL_sv_undef) ? GvAV(gv) : Nullav;
 244
 245     /* create and re-create @.*::SUPER::ISA on demand */
 246     if (!av || !SvMAGIC(av)) {
 247         const char* packname = HvNAME(stash);
 248         STRLEN packlen = strlen(packname);
 249
 250         if (packlen >= 7 && strEQ(packname + packlen - 7, "::SUPER")) {
 251             HV* basestash;
 252
 253             packlen -= 7;
 254             basestash = gv_stashpvn(packname, packlen, TRUE);
 255             gvp = (GV**)hv_fetch(basestash, "ISA", 3, FALSE);
 256             if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (av = GvAV(gv))) {
 257                 gvp = (GV**)hv_fetch(stash, "ISA", 3, TRUE);
 258                 if (!gvp || !(gv = *gvp))
 259                     Perl_croak(aTHX_ "Cannot create %s::ISA", HvNAME(stash));
 260                 if (SvTYPE(gv) != SVt_PVGV)
 261                     gv_init(gv, stash, "ISA", 3, TRUE);
 262                 SvREFCNT_dec(GvAV(gv));
 263                 GvAV(gv) = (AV*)SvREFCNT_inc(av);
 264             }
 265         }
 266     }
 267
 268     if (av) {
 269         SV** svp = AvARRAY(av);
 270         /* NOTE: No support for tied ISA */
 271         I32 items = AvFILLp(av) + 1;
 272         while (items--) {
 273             SV* sv = *svp++;
 274             HV* basestash = gv_stashsv(sv, FALSE);
 275             if (!basestash) {
 276                 if (ckWARN(WARN_MISC))
 277                     Perl_warner(aTHX_ packWARN(WARN_MISC), "Can't locate package %"SVf" for @%s::ISA",
 278                         sv, HvNAME(stash));
 279                 continue;
 280             }
 281             gv = gv_fetchmeth(basestash, name, len,
 282                               (level >= 0) ? level + 1 : level - 1);
 283             if (gv)
 284                 goto gotcha;
 285         }
 286     }
 287
 288     /* if at top level, try UNIVERSAL */
 289
 290     if (level == 0 || level == -1) {
 291         HV* lastchance;
 292
 293         if ((lastchance = gv_stashpvn("UNIVERSAL", 9, FALSE))) {
 294             if ((gv = gv_fetchmeth(lastchance, name, len,
 295                                   (level >= 0) ? level + 1 : level - 1)))
 296             {
 297           gotcha:
 298                 /*
 299                  * Cache method in topgv if:
 300                  *  1. topgv has no synonyms (else inheritance crosses wires)
 301                  *  2. method isn't a stub (else AUTOLOAD fails spectacularly)
 302                  */
 303                 if (topgv &&
 304                     GvREFCNT(topgv) == 1 &&
 305                     (cv = GvCV(gv)) &&
 306                     (CvROOT(cv) || CvXSUB(cv)))
 307                 {
 308                     if ((cv = GvCV(topgv)))
 309                         SvREFCNT_dec(cv);
 310                     GvCV(topgv) = (CV*)SvREFCNT_inc(GvCV(gv));
 311                     GvCVGEN(topgv) = PL_sub_generation;
 312                 }
 313                 return gv;
 314             }
 315             else if (topgv && GvREFCNT(topgv) == 1) {
 316                 /* cache the fact that the method is not defined */
 317                 GvCVGEN(topgv) = PL_sub_generation;
 318             }
 319         }
 320     }
 321
 322     return 0;
 323 }
 324
 325 /*
 326 =for apidoc gv_fetchmeth_autoload
 327
 328 Same as gv_fetchmeth(), but looks for autoloaded subroutines too.
 329 Returns a glob for the subroutine.
 330
 331 For an autoloaded subroutine without a GV, will create a GV even
 332 if C<level < 0>.  For an autoloaded subroutine without a stub, GvCV()
 333 of the result may be zero.
 334
 335 =cut
 336 */
 337
 338 GV *
 339 Perl_gv_fetchmeth_autoload(pTHX_ HV *stash, const char *name, STRLEN len, I32 level)
 340 {
 341     GV *gv = gv_fetchmeth(stash, name, len, level);
 342
 343     if (!gv) {
 344         CV *cv;
 345         GV **gvp;
 346
 347         if (!stash)
 348             return Nullgv;      /* UNIVERSAL::AUTOLOAD could cause trouble */
 349         if (len == S_autolen && strnEQ(name, S_autoload, S_autolen))
 350             return Nullgv;
 351         if (!(gv = gv_fetchmeth(stash, S_autoload, S_autolen, FALSE)))
 352             return Nullgv;
 353         cv = GvCV(gv);
 354         if (!(CvROOT(cv) || CvXSUB(cv)))
 355             return Nullgv;
 356         /* Have an autoload */
 357         if (level < 0)  /* Cannot do without a stub */
 358             gv_fetchmeth(stash, name, len, 0);
 359         gvp = (GV**)hv_fetch(stash, name, len, (level >= 0));
 360         if (!gvp)
 361             return Nullgv;
 362         return *gvp;
 363     }
 364     return gv;
 365 }
 366
 367 /*
 368 =for apidoc gv_fetchmethod
 369
 370 See L<gv_fetchmethod_autoload>.
 371
 372 =cut
 373 */
 374
 375 GV *
 376 Perl_gv_fetchmethod(pTHX_ HV *stash, const char *name)
 377 {
 378     return gv_fetchmethod_autoload(stash, name, TRUE);
 379 }
 380
 381 /*
 382 =for apidoc gv_fetchmethod_autoload
 383
 384 Returns the glob which contains the subroutine to call to invoke the method
 385 on the C<stash>.  In fact in the presence of autoloading this may be the
 386 glob for "AUTOLOAD".  In this case the corresponding variable $AUTOLOAD is
 387 already setup.
 388
 389 The third parameter of C<gv_fetchmethod_autoload> determines whether
 390 AUTOLOAD lookup is performed if the given method is not present: non-zero
 391 means yes, look for AUTOLOAD; zero means no, don't look for AUTOLOAD.
 392 Calling C<gv_fetchmethod> is equivalent to calling C<gv_fetchmethod_autoload>
 393 with a non-zero C<autoload> parameter.
 394
 395 These functions grant C<"SUPER"> token as a prefix of the method name. Note
 396 that if you want to keep the returned glob for a long time, you need to
 397 check for it being "AUTOLOAD", since at the later time the call may load a
 398 different subroutine due to $AUTOLOAD changing its value. Use the glob
 399 created via a side effect to do this.
 400
 401 These functions have the same side-effects and as C<gv_fetchmeth> with
 402 C<level==0>.  C<name> should be writable if contains C<':'> or C<'
 403 ''>. The warning against passing the GV returned by C<gv_fetchmeth> to
 404 C<call_sv> apply equally to these functions.
 405
 406 =cut
 407 */
 408
 409 GV *
 410 Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload)
 411 {
 412     register const char *nend;
 413     const char *nsplit = 0;
 414     GV* gv;
 415     HV* ostash = stash;
 416
 417     if (stash && SvTYPE(stash) < SVt_PVHV)
 418         stash = Nullhv;
 419
 420     for (nend = name; *nend; nend++) {
 421         if (*nend == '\'')
 422             nsplit = nend;
 423         else if (*nend == ':' && *(nend + 1) == ':')
 424             nsplit = ++nend;
 425     }
 426     if (nsplit) {
 427         const char *origname = name;
 428         name = nsplit + 1;
 429         if (*nsplit == ':')
 430             --nsplit;
 431         if ((nsplit - origname) == 5 && strnEQ(origname, "SUPER", 5)) {
 432             /* ->SUPER::method should really be looked up in original stash */
 433             SV *tmpstr = sv_2mortal(Perl_newSVpvf(aTHX_ "%s::SUPER",
 434                                                   CopSTASHPV(PL_curcop)));
 435             /* __PACKAGE__::SUPER stash should be autovivified */
 436             stash = gv_stashpvn(SvPVX(tmpstr), SvCUR(tmpstr), TRUE);
 437             DEBUG_o( Perl_deb(aTHX_ "Treating %s as %s::%s\n",
 438                          origname, HvNAME(stash), name) );
 439         }
 440         else {
 441             /* don't autovifify if ->NoSuchStash::method */
 442             stash = gv_stashpvn(origname, nsplit - origname, FALSE);
 443
 444             /* however, explicit calls to Pkg::SUPER::method may
 445                happen, and may require autovivification to work */
 446             if (!stash && (nsplit - origname) >= 7 &&
 447                 strnEQ(nsplit - 7, "::SUPER", 7) &&
 448                 gv_stashpvn(origname, nsplit - origname - 7, FALSE))
 449               stash = gv_stashpvn(origname, nsplit - origname, TRUE);
 450         }
 451         ostash = stash;
 452     }
 453
 454     gv = gv_fetchmeth(stash, name, nend - name, 0);
 455     if (!gv) {
 456         if (strEQ(name,"import") || strEQ(name,"unimport"))
 457             gv = (GV*)&PL_sv_yes;
 458         else if (autoload)
 459             gv = gv_autoload4(ostash, name, nend - name, TRUE);
 460     }
 461     else if (autoload) {
 462         CV* cv = GvCV(gv);
 463         if (!CvROOT(cv) && !CvXSUB(cv)) {
 464             GV* stubgv;
 465             GV* autogv;
 466
 467             if (CvANON(cv))
 468                 stubgv = gv;
 469             else {
 470                 stubgv = CvGV(cv);
 471                 if (GvCV(stubgv) != cv)         /* orphaned import */
 472                     stubgv = gv;
 473             }
 474             autogv = gv_autoload4(GvSTASH(stubgv),
 475                                   GvNAME(stubgv), GvNAMELEN(stubgv), TRUE);
 476             if (autogv)
 477                 gv = autogv;
 478         }
 479     }
 480
 481     return gv;
 482 }
 483
 484 GV*
 485 Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method)
 486 {
 487     dVAR;
 488     GV* gv;
 489     CV* cv;
 490     HV* varstash;
 491     GV* vargv;
 492     SV* varsv;
 493     const char *packname = "";
 494
 495     if (len == S_autolen && strnEQ(name, S_autoload, S_autolen))
 496         return Nullgv;
 497     if (stash) {
 498         if (SvTYPE(stash) < SVt_PVHV) {
 499             packname = SvPV_nolen((SV*)stash);
 500             stash = Nullhv;
 501         }
 502         else {
 503             packname = HvNAME(stash);
 504         }
 505     }
 506     if (!(gv = gv_fetchmeth(stash, S_autoload, S_autolen, FALSE)))
 507         return Nullgv;
 508     cv = GvCV(gv);
 509
 510     if (!(CvROOT(cv) || CvXSUB(cv)))
 511         return Nullgv;
 512
 513     /*
 514      * Inheriting AUTOLOAD for non-methods works ... for now.
 515      */
 516     if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX) && !method &&
 517         (GvCVGEN(gv) || GvSTASH(gv) != stash))
 518         Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
 519           "Use of inherited AUTOLOAD for non-method %s::%.*s() is deprecated",
 520              packname, (int)len, name);
 521
 522     if (CvXSUB(cv)) {
 523         /* rather than lookup/init $AUTOLOAD here
 524          * only to have the XSUB do another lookup for $AUTOLOAD
 525          * and split that value on the last '::',
 526          * pass along the same data via some unused fields in the CV
 527          */
 528         CvSTASH(cv) = stash;
 529         SvPV_set(cv, (char *)name); /* cast to lose constness warning */
 530         SvCUR_set(cv, len);
 531         return gv;
 532     }
 533
 534     /*
 535      * Given &FOO::AUTOLOAD, set $FOO::AUTOLOAD to desired function name.
 536      * The subroutine's original name may not be "AUTOLOAD", so we don't
 537      * use that, but for lack of anything better we will use the sub's
 538      * original package to look up $AUTOLOAD.
 539      */
 540     varstash = GvSTASH(CvGV(cv));
 541     vargv = *(GV**)hv_fetch(varstash, S_autoload, S_autolen, TRUE);
 542     ENTER;
 543
 544     if (!isGV(vargv))
 545         gv_init(vargv, varstash, S_autoload, S_autolen, FALSE);
 546     LEAVE;
 547     varsv = GvSV(vargv);
 548     sv_setpv(varsv, packname);
 549     sv_catpvn(varsv, "::", 2);
 550     sv_catpvn(varsv, name, len);
 551     SvTAINTED_off(varsv);
 552     return gv;
 553 }
 554
 555 /* The "gv" parameter should be the glob known to Perl code as *!
 556  * The scalar must already have been magicalized.
 557  */
 558 STATIC void
 559 S_require_errno(pTHX_ GV *gv)
 560 {
 561     dVAR;
 562     HV* stash = gv_stashpvn("Errno",5,FALSE);
 563
 564     if (!stash || !(gv_fetchmethod(stash, "TIEHASH"))) {
 565         dSP;
 566         PUTBACK;
 567         ENTER;
 568         save_scalar(gv); /* keep the value of $! */
 569         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
 570                          newSVpvn("Errno",5), Nullsv);
 571         LEAVE;
 572         SPAGAIN;
 573         stash = gv_stashpvn("Errno",5,FALSE);
 574         if (!stash || !(gv_fetchmethod(stash, "TIEHASH")))
 575             Perl_croak(aTHX_ "Can't use %%! because Errno.pm is not available");
 576     }
 577 }
 578
 579 /*
 580 =for apidoc gv_stashpv
 581
 582 Returns a pointer to the stash for a specified package.  C<name> should
 583 be a valid UTF-8 string and must be null-terminated.  If C<create> is set
 584 then the package will be created if it does not already exist.  If C<create>
 585 is not set and the package does not exist then NULL is returned.
 586
 587 =cut
 588 */
 589
 590 HV*
 591 Perl_gv_stashpv(pTHX_ const char *name, I32 create)
 592 {
 593     return gv_stashpvn(name, strlen(name), create);
 594 }
 595
 596 /*
 597 =for apidoc gv_stashpvn
 598
 599 Returns a pointer to the stash for a specified package.  C<name> should
 600 be a valid UTF-8 string.  The C<namelen> parameter indicates the length of
 601 the C<name>, in bytes.  If C<create> is set then the package will be
 602 created if it does not already exist.  If C<create> is not set and the
 603 package does not exist then NULL is returned.
 604
 605 =cut
 606 */
 607
 608 HV*
 609 Perl_gv_stashpvn(pTHX_ const char *name, U32 namelen, I32 create)
 610 {
 611     char smallbuf[256];
 612     char *tmpbuf;
 613     HV *stash;
 614     GV *tmpgv;
 615
 616     if (namelen + 3 < sizeof smallbuf)
 617         tmpbuf = smallbuf;
 618     else
 619         New(606, tmpbuf, namelen + 3, char);
 620     Copy(name,tmpbuf,namelen,char);
 621     tmpbuf[namelen++] = ':';
 622     tmpbuf[namelen++] = ':';
 623     tmpbuf[namelen] = '\0';
 624     tmpgv = gv_fetchpv(tmpbuf, create, SVt_PVHV);
 625     if (tmpbuf != smallbuf)
 626         Safefree(tmpbuf);
 627     if (!tmpgv)
 628         return 0;
 629     if (!GvHV(tmpgv))
 630         GvHV(tmpgv) = newHV();
 631     stash = GvHV(tmpgv);
 632     if (!HvNAME(stash))
 633         HvNAME(stash) = savepv(name);
 634     return stash;
 635 }
 636
 637 /*
 638 =for apidoc gv_stashsv
 639
 640 Returns a pointer to the stash for a specified package, which must be a
 641 valid UTF-8 string.  See C<gv_stashpv>.
 642
 643 =cut
 644 */
 645
 646 HV*
 647 Perl_gv_stashsv(pTHX_ SV *sv, I32 create)
 648 {
 649     STRLEN len;
 650     const char *ptr = SvPV(sv,len);
 651     return gv_stashpvn(ptr, len, create);
 652 }
 653
 654
 655 GV *
 656 Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type) {
 657     return gv_fetchpvn_flags(nambeg, strlen(nambeg), 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     GV *iogv;
1180     IO * const io = (IO*)NEWSV(0,0);
1181
1182     sv_upgrade((SV *)io,SVt_PVIO);
1183     SvREFCNT(io) = 1;
1184     SvOBJECT_on(io);
1185     /* Clear the stashcache because a new IO could overrule a
1186        package name */
1187     hv_clear(PL_stashcache);
1188     iogv = gv_fetchpv("FileHandle::", FALSE, SVt_PVHV);
1189     /* unless exists($main::{FileHandle}) and defined(%main::FileHandle::) */
1190     if (!(iogv && GvHV(iogv) && HvARRAY(GvHV(iogv))))
1191       iogv = gv_fetchpv("IO::Handle::", TRUE, SVt_PVHV);
1192     SvSTASH_set(io, (HV*)SvREFCNT_inc(GvHV(iogv)));
1193     return io;
1194 }
1195
1196 void
1197 Perl_gv_check(pTHX_ HV *stash)
1198 {
1199     register I32 i;
1200
1201     if (!HvARRAY(stash))
1202         return;
1203     for (i = 0; i <= (I32) HvMAX(stash); i++) {
1204         const HE *entry;
1205         for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
1206             register GV *gv;
1207             HV *hv;
1208             if (HeKEY(entry)[HeKLEN(entry)-1] == ':' &&
1209                 (gv = (GV*)HeVAL(entry)) && isGV(gv) && (hv = GvHV(gv)))
1210             {
1211                 if (hv != PL_defstash && hv != stash)
1212                      gv_check(hv);              /* nested package */
1213             }
1214             else if (isALPHA(*HeKEY(entry))) {
1215                 const char *file;
1216                 gv = (GV*)HeVAL(entry);
1217                 if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv))
1218                     continue;
1219                 file = GvFILE(gv);
1220                 /* performance hack: if filename is absolute and it's a standard
1221                  * module, don't bother warning */
1222                 if (file
1223                     && PERL_FILE_IS_ABSOLUTE(file)
1224 #ifdef MACOS_TRADITIONAL
1225                     && (instr(file, ":lib:")
1226 #else
1227                     && (instr(file, "/lib/")
1228 #endif
1229                     || instr(file, ".pm")))
1230                 {
1231                     continue;
1232                 }
1233                 CopLINE_set(PL_curcop, GvLINE(gv));
1234 #ifdef USE_ITHREADS
1235                 CopFILE(PL_curcop) = (char *)file;      /* set for warning */
1236 #else
1237                 CopFILEGV(PL_curcop) = gv_fetchfile(file);
1238 #endif
1239                 Perl_warner(aTHX_ packWARN(WARN_ONCE),
1240                         "Name \"%s::%s\" used only once: possible typo",
1241                         HvNAME(stash), GvNAME(gv));
1242             }
1243         }
1244     }
1245 }
1246
1247 GV *
1248 Perl_newGVgen(pTHX_ const char *pack)
1249 {
1250     return gv_fetchpv(Perl_form(aTHX_ "%s::_GEN_%ld", pack, (long)PL_gensym++),
1251                       TRUE, SVt_PVGV);
1252 }
1253
1254 /* hopefully this is only called on local symbol table entries */
1255
1256 GP*
1257 Perl_gp_ref(pTHX_ GP *gp)
1258 {
1259     if (!gp)
1260         return (GP*)NULL;
1261     gp->gp_refcnt++;
1262     if (gp->gp_cv) {
1263         if (gp->gp_cvgen) {
1264             /* multi-named GPs cannot be used for method cache */
1265             SvREFCNT_dec(gp->gp_cv);
1266             gp->gp_cv = Nullcv;
1267             gp->gp_cvgen = 0;
1268         }
1269         else {
1270             /* Adding a new name to a subroutine invalidates method cache */
1271             PL_sub_generation++;
1272         }
1273     }
1274     return gp;
1275 }
1276
1277 void
1278 Perl_gp_free(pTHX_ GV *gv)
1279 {
1280     GP* gp;
1281
1282     if (!gv || !(gp = GvGP(gv)))
1283         return;
1284     if (gp->gp_refcnt == 0) {
1285         if (ckWARN_d(WARN_INTERNAL))
1286             Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
1287                         "Attempt to free unreferenced glob pointers"
1288                         pTHX__FORMAT pTHX__VALUE);
1289         return;
1290     }
1291     if (gp->gp_cv) {
1292         /* Deleting the name of a subroutine invalidates method cache */
1293         PL_sub_generation++;
1294     }
1295     if (--gp->gp_refcnt > 0) {
1296         if (gp->gp_egv == gv)
1297             gp->gp_egv = 0;
1298         return;
1299     }
1300
1301     if (gp->gp_sv) SvREFCNT_dec(gp->gp_sv);
1302     if (gp->gp_av) SvREFCNT_dec(gp->gp_av);
1303     if (gp->gp_hv) {
1304          if (PL_stashcache && HvNAME(gp->gp_hv))
1305               hv_delete(PL_stashcache,
1306                         HvNAME(gp->gp_hv), strlen(HvNAME(gp->gp_hv)),
1307                         G_DISCARD);
1308          SvREFCNT_dec(gp->gp_hv);
1309     }
1310     if (gp->gp_io)   SvREFCNT_dec(gp->gp_io);
1311     if (gp->gp_cv)   SvREFCNT_dec(gp->gp_cv);
1312     if (gp->gp_form) SvREFCNT_dec(gp->gp_form);
1313
1314     Safefree(gp);
1315     GvGP(gv) = 0;
1316 }
1317
1318 int
1319 Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg)
1320 {
1321     AMT *amtp = (AMT*)mg->mg_ptr;
1322     (void)sv;
1323
1324     if (amtp && AMT_AMAGIC(amtp)) {
1325         int i;
1326         for (i = 1; i < NofAMmeth; i++) {
1327             CV *cv = amtp->table[i];
1328             if (cv != Nullcv) {
1329                 SvREFCNT_dec((SV *) cv);
1330                 amtp->table[i] = Nullcv;
1331             }
1332         }
1333     }
1334  return 0;
1335 }
1336
1337 /* Updates and caches the CV's */
1338
1339 bool
1340 Perl_Gv_AMupdate(pTHX_ HV *stash)
1341 {
1342   GV* gv;
1343   CV* cv;
1344   MAGIC* mg=mg_find((SV*)stash, PERL_MAGIC_overload_table);
1345   AMT *amtp = (mg) ? (AMT*)mg->mg_ptr: (AMT *) NULL;
1346   AMT amt;
1347
1348   if (mg && amtp->was_ok_am == PL_amagic_generation
1349       && amtp->was_ok_sub == PL_sub_generation)
1350       return (bool)AMT_OVERLOADED(amtp);
1351   sv_unmagic((SV*)stash, PERL_MAGIC_overload_table);
1352
1353   DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME(stash)) );
1354
1355   Zero(&amt,1,AMT);
1356   amt.was_ok_am = PL_amagic_generation;
1357   amt.was_ok_sub = PL_sub_generation;
1358   amt.fallback = AMGfallNO;
1359   amt.flags = 0;
1360
1361   {
1362     int filled = 0, have_ovl = 0;
1363     int i, lim = 1;
1364     SV* sv = NULL;
1365
1366     /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
1367
1368     /* Try to find via inheritance. */
1369     gv = gv_fetchmeth(stash, PL_AMG_names[0], 2, -1);
1370     if (gv)
1371         sv = GvSV(gv);
1372
1373     if (!gv)
1374         lim = DESTROY_amg;              /* Skip overloading entries. */
1375     else if (SvTRUE(sv))
1376         amt.fallback=AMGfallYES;
1377     else if (SvOK(sv))
1378         amt.fallback=AMGfallNEVER;
1379
1380     for (i = 1; i < lim; i++)
1381         amt.table[i] = Nullcv;
1382     for (; i < NofAMmeth; i++) {
1383         const char *cooky = PL_AMG_names[i];
1384         /* Human-readable form, for debugging: */
1385         const char *cp = (i >= DESTROY_amg ? cooky : AMG_id2name(i));
1386         const STRLEN l = strlen(cooky);
1387
1388         DEBUG_o( Perl_deb(aTHX_ "Checking overloading of `%s' in package `%.256s'\n",
1389                      cp, HvNAME(stash)) );
1390         /* don't fill the cache while looking up!
1391            Creation of inheritance stubs in intermediate packages may
1392            conflict with the logic of runtime method substitution.
1393            Indeed, for inheritance A -> B -> C, if C overloads "+0",
1394            then we could have created stubs for "(+0" in A and C too.
1395            But if B overloads "bool", we may want to use it for
1396            numifying instead of C's "+0". */
1397         if (i >= DESTROY_amg)
1398             gv = Perl_gv_fetchmeth_autoload(aTHX_ stash, cooky, l, 0);
1399         else                            /* Autoload taken care of below */
1400             gv = Perl_gv_fetchmeth(aTHX_ stash, cooky, l, -1);
1401         cv = 0;
1402         if (gv && (cv = GvCV(gv))) {
1403             if (GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")
1404                 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "overload")) {
1405                 /* This is a hack to support autoloading..., while
1406                    knowing *which* methods were declared as overloaded. */
1407                 /* GvSV contains the name of the method. */
1408                 GV *ngv = Nullgv;
1409
1410                 DEBUG_o( Perl_deb(aTHX_ "Resolving method `%"SVf256\
1411                         "' for overloaded `%s' in package `%.256s'\n",
1412                              GvSV(gv), cp, HvNAME(stash)) );
1413                 if (!SvPOK(GvSV(gv))
1414                     || !(ngv = gv_fetchmethod_autoload(stash, SvPVX(GvSV(gv)),
1415                                                        FALSE)))
1416                 {
1417                     /* Can be an import stub (created by `can'). */
1418                     SV *gvsv = GvSV(gv);
1419                     const char *name = SvPOK(gvsv) ?  SvPVX(gvsv) : "???";
1420                     Perl_croak(aTHX_ "%s method `%.256s' overloading `%s' "\
1421                                 "in package `%.256s'",
1422                                (GvCVGEN(gv) ? "Stub found while resolving"
1423                                 : "Can't resolve"),
1424                                name, cp, HvNAME(stash));
1425                 }
1426                 cv = GvCV(gv = ngv);
1427             }
1428             DEBUG_o( Perl_deb(aTHX_ "Overloading `%s' in package `%.256s' via `%.256s::%.256s' \n",
1429                          cp, HvNAME(stash), HvNAME(GvSTASH(CvGV(cv))),
1430                          GvNAME(CvGV(cv))) );
1431             filled = 1;
1432             if (i < DESTROY_amg)
1433                 have_ovl = 1;
1434         } else if (gv) {                /* Autoloaded... */
1435             cv = (CV*)gv;
1436             filled = 1;
1437         }
1438         amt.table[i]=(CV*)SvREFCNT_inc(cv);
1439     }
1440     if (filled) {
1441       AMT_AMAGIC_on(&amt);
1442       if (have_ovl)
1443           AMT_OVERLOADED_on(&amt);
1444       sv_magic((SV*)stash, 0, PERL_MAGIC_overload_table,
1445                                                 (char*)&amt, sizeof(AMT));
1446       return have_ovl;
1447     }
1448   }
1449   /* Here we have no table: */
1450   /* no_table: */
1451   AMT_AMAGIC_off(&amt);
1452   sv_magic((SV*)stash, 0, PERL_MAGIC_overload_table,
1453                                                 (char*)&amt, sizeof(AMTS));
1454   return FALSE;
1455 }
1456
1457
1458 CV*
1459 Perl_gv_handler(pTHX_ HV *stash, I32 id)
1460 {
1461     MAGIC *mg;
1462     AMT *amtp;
1463
1464     if (!stash || !HvNAME(stash))
1465         return Nullcv;
1466     mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
1467     if (!mg) {
1468       do_update:
1469         Gv_AMupdate(stash);
1470         mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
1471     }
1472     amtp = (AMT*)mg->mg_ptr;
1473     if ( amtp->was_ok_am != PL_amagic_generation
1474          || amtp->was_ok_sub != PL_sub_generation )
1475         goto do_update;
1476     if (AMT_AMAGIC(amtp)) {
1477         CV * const ret = amtp->table[id];
1478         if (ret && isGV(ret)) {         /* Autoloading stab */
1479             /* Passing it through may have resulted in a warning
1480                "Inherited AUTOLOAD for a non-method deprecated", since
1481                our caller is going through a function call, not a method call.
1482                So return the CV for AUTOLOAD, setting $AUTOLOAD. */
1483             GV *gv = gv_fetchmethod(stash, PL_AMG_names[id]);
1484
1485             if (gv && GvCV(gv))
1486                 return GvCV(gv);
1487         }
1488         return ret;
1489     }
1490
1491     return Nullcv;
1492 }
1493
1494
1495 SV*
1496 Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
1497 {
1498   dVAR;
1499   MAGIC *mg;
1500   CV *cv=NULL;
1501   CV **cvp=NULL, **ocvp=NULL;
1502   AMT *amtp=NULL, *oamtp=NULL;
1503   int off=0, off1, lr=0, assign=AMGf_assign & flags, notfound=0;
1504   int postpr = 0, force_cpy = 0, assignshift = assign ? 1 : 0;
1505 #ifdef DEBUGGING
1506   int fl=0;
1507 #endif
1508   HV* stash=NULL;
1509   if (!(AMGf_noleft & flags) && SvAMAGIC(left)
1510       && (stash = SvSTASH(SvRV(left)))
1511       && (mg = mg_find((SV*)stash, PERL_MAGIC_overload_table))
1512       && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
1513                         ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
1514                         : (CV **) NULL))
1515       && ((cv = cvp[off=method+assignshift])
1516           || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
1517                                                           * usual method */
1518                   (
1519 #ifdef DEBUGGING
1520                    fl = 1,
1521 #endif
1522                    cv = cvp[off=method])))) {
1523     lr = -1;                    /* Call method for left argument */
1524   } else {
1525     if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) {
1526       int logic;
1527
1528       /* look for substituted methods */
1529       /* In all the covered cases we should be called with assign==0. */
1530          switch (method) {
1531          case inc_amg:
1532            force_cpy = 1;
1533            if ((cv = cvp[off=add_ass_amg])
1534                || ((cv = cvp[off = add_amg]) && (force_cpy = 0, postpr = 1))) {
1535              right = &PL_sv_yes; lr = -1; assign = 1;
1536            }
1537            break;
1538          case dec_amg:
1539            force_cpy = 1;
1540            if ((cv = cvp[off = subtr_ass_amg])
1541                || ((cv = cvp[off = subtr_amg]) && (force_cpy = 0, postpr=1))) {
1542              right = &PL_sv_yes; lr = -1; assign = 1;
1543            }
1544            break;
1545          case bool__amg:
1546            (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg]));
1547            break;
1548          case numer_amg:
1549            (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg]));
1550            break;
1551          case string_amg:
1552            (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg]));
1553            break;
1554          case not_amg:
1555            (void)((cv = cvp[off=bool__amg])
1556                   || (cv = cvp[off=numer_amg])
1557                   || (cv = cvp[off=string_amg]));
1558            postpr = 1;
1559            break;
1560          case copy_amg:
1561            {
1562              /*
1563                   * SV* ref causes confusion with the interpreter variable of
1564                   * the same name
1565                   */
1566              SV* tmpRef=SvRV(left);
1567              if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) {
1568                 /*
1569                  * Just to be extra cautious.  Maybe in some
1570                  * additional cases sv_setsv is safe, too.
1571                  */
1572                 SV* newref = newSVsv(tmpRef);
1573                 SvOBJECT_on(newref);
1574                 SvSTASH_set(newref, (HV*)SvREFCNT_inc(SvSTASH(tmpRef)));
1575                 return newref;
1576              }
1577            }
1578            break;
1579          case abs_amg:
1580            if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg])
1581                && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) {
1582              SV* nullsv=sv_2mortal(newSViv(0));
1583              if (off1==lt_amg) {
1584                SV* lessp = amagic_call(left,nullsv,
1585                                        lt_amg,AMGf_noright);
1586                logic = SvTRUE(lessp);
1587              } else {
1588                SV* lessp = amagic_call(left,nullsv,
1589                                        ncmp_amg,AMGf_noright);
1590                logic = (SvNV(lessp) < 0);
1591              }
1592              if (logic) {
1593                if (off==subtr_amg) {
1594                  right = left;
1595                  left = nullsv;
1596                  lr = 1;
1597                }
1598              } else {
1599                return left;
1600              }
1601            }
1602            break;
1603          case neg_amg:
1604            if ((cv = cvp[off=subtr_amg])) {
1605              right = left;
1606              left = sv_2mortal(newSViv(0));
1607              lr = 1;
1608            }
1609            break;
1610          case int_amg:
1611          case iter_amg:                 /* XXXX Eventually should do to_gv. */
1612              /* FAIL safe */
1613              return NULL;       /* Delegate operation to standard mechanisms. */
1614              break;
1615          case to_sv_amg:
1616          case to_av_amg:
1617          case to_hv_amg:
1618          case to_gv_amg:
1619          case to_cv_amg:
1620              /* FAIL safe */
1621              return left;       /* Delegate operation to standard mechanisms. */
1622              break;
1623          default:
1624            goto not_found;
1625          }
1626          if (!cv) goto not_found;
1627     } else if (!(AMGf_noright & flags) && SvAMAGIC(right)
1628                && (stash = SvSTASH(SvRV(right)))
1629                && (mg = mg_find((SV*)stash, PERL_MAGIC_overload_table))
1630                && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
1631                           ? (amtp = (AMT*)mg->mg_ptr)->table
1632                           : (CV **) NULL))
1633                && (cv = cvp[off=method])) { /* Method for right
1634                                              * argument found */
1635       lr=1;
1636     } else if (((ocvp && oamtp->fallback > AMGfallNEVER
1637                  && (cvp=ocvp) && (lr = -1))
1638                 || (cvp && amtp->fallback > AMGfallNEVER && (lr=1)))
1639                && !(flags & AMGf_unary)) {
1640                                 /* We look for substitution for
1641                                  * comparison operations and
1642                                  * concatenation */
1643       if (method==concat_amg || method==concat_ass_amg
1644           || method==repeat_amg || method==repeat_ass_amg) {
1645         return NULL;            /* Delegate operation to string conversion */
1646       }
1647       off = -1;
1648       switch (method) {
1649          case lt_amg:
1650          case le_amg:
1651          case gt_amg:
1652          case ge_amg:
1653          case eq_amg:
1654          case ne_amg:
1655            postpr = 1; off=ncmp_amg; break;
1656          case slt_amg:
1657          case sle_amg:
1658          case sgt_amg:
1659          case sge_amg:
1660          case seq_amg:
1661          case sne_amg:
1662            postpr = 1; off=scmp_amg; break;
1663          }
1664       if (off != -1) cv = cvp[off];
1665       if (!cv) {
1666         goto not_found;
1667       }
1668     } else {
1669     not_found:                  /* No method found, either report or croak */
1670       switch (method) {
1671          case to_sv_amg:
1672          case to_av_amg:
1673          case to_hv_amg:
1674          case to_gv_amg:
1675          case to_cv_amg:
1676              /* FAIL safe */
1677              return left;       /* Delegate operation to standard mechanisms. */
1678              break;
1679       }
1680       if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */
1681         notfound = 1; lr = -1;
1682       } else if (cvp && (cv=cvp[nomethod_amg])) {
1683         notfound = 1; lr = 1;
1684       } else {
1685         SV *msg;
1686         if (off==-1) off=method;
1687         msg = sv_2mortal(Perl_newSVpvf(aTHX_
1688                       "Operation `%s': no method found,%sargument %s%s%s%s",
1689                       AMG_id2name(method + assignshift),
1690                       (flags & AMGf_unary ? " " : "\n\tleft "),
1691                       SvAMAGIC(left)?
1692                         "in overloaded package ":
1693                         "has no overloaded magic",
1694                       SvAMAGIC(left)?
1695                         HvNAME(SvSTASH(SvRV(left))):
1696                         "",
1697                       SvAMAGIC(right)?
1698                         ",\n\tright argument in overloaded package ":
1699                         (flags & AMGf_unary
1700                          ? ""
1701                          : ",\n\tright argument has no overloaded magic"),
1702                       SvAMAGIC(right)?
1703                         HvNAME(SvSTASH(SvRV(right))):
1704                         ""));
1705         if (amtp && amtp->fallback >= AMGfallYES) {
1706           DEBUG_o( Perl_deb(aTHX_ "%s", SvPVX(msg)) );
1707         } else {
1708           Perl_croak(aTHX_ "%"SVf, msg);
1709         }
1710         return NULL;
1711       }
1712       force_cpy = force_cpy || assign;
1713     }
1714   }
1715 #ifdef DEBUGGING
1716   if (!notfound) {
1717     DEBUG_o(Perl_deb(aTHX_
1718                      "Overloaded operator `%s'%s%s%s:\n\tmethod%s found%s in package %s%s\n",
1719                      AMG_id2name(off),
1720                      method+assignshift==off? "" :
1721                      " (initially `",
1722                      method+assignshift==off? "" :
1723                      AMG_id2name(method+assignshift),
1724                      method+assignshift==off? "" : "')",
1725                      flags & AMGf_unary? "" :
1726                      lr==1 ? " for right argument": " for left argument",
1727                      flags & AMGf_unary? " for argument" : "",
1728                      stash ? HvNAME(stash) : "null",
1729                      fl? ",\n\tassignment variant used": "") );
1730   }
1731 #endif
1732     /* Since we use shallow copy during assignment, we need
1733      * to dublicate the contents, probably calling user-supplied
1734      * version of copy operator
1735      */
1736     /* We need to copy in following cases:
1737      * a) Assignment form was called.
1738      *          assignshift==1,  assign==T, method + 1 == off
1739      * b) Increment or decrement, called directly.
1740      *          assignshift==0,  assign==0, method + 0 == off
1741      * c) Increment or decrement, translated to assignment add/subtr.
1742      *          assignshift==0,  assign==T,
1743      *          force_cpy == T
1744      * d) Increment or decrement, translated to nomethod.
1745      *          assignshift==0,  assign==0,
1746      *          force_cpy == T
1747      * e) Assignment form translated to nomethod.
1748      *          assignshift==1,  assign==T, method + 1 != off
1749      *          force_cpy == T
1750      */
1751     /*  off is method, method+assignshift, or a result of opcode substitution.
1752      *  In the latter case assignshift==0, so only notfound case is important.
1753      */
1754   if (( (method + assignshift == off)
1755         && (assign || (method == inc_amg) || (method == dec_amg)))
1756       || force_cpy)
1757     RvDEEPCP(left);
1758   {
1759     dSP;
1760     BINOP myop;
1761     SV* res;
1762     const bool oldcatch = CATCH_GET;
1763
1764     CATCH_SET(TRUE);
1765     Zero(&myop, 1, BINOP);
1766     myop.op_last = (OP *) &myop;
1767     myop.op_next = Nullop;
1768     myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
1769
1770     PUSHSTACKi(PERLSI_OVERLOAD);
1771     ENTER;
1772     SAVEOP();
1773     PL_op = (OP *) &myop;
1774     if (PERLDB_SUB && PL_curstash != PL_debstash)
1775         PL_op->op_private |= OPpENTERSUB_DB;
1776     PUTBACK;
1777     pp_pushmark();
1778
1779     EXTEND(SP, notfound + 5);
1780     PUSHs(lr>0? right: left);
1781     PUSHs(lr>0? left: right);
1782     PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no ));
1783     if (notfound) {
1784       PUSHs( sv_2mortal(newSVpv(AMG_id2name(method + assignshift),0)));
1785     }
1786     PUSHs((SV*)cv);
1787     PUTBACK;
1788
1789     if ((PL_op = Perl_pp_entersub(aTHX)))
1790       CALLRUNOPS(aTHX);
1791     LEAVE;
1792     SPAGAIN;
1793
1794     res=POPs;
1795     PUTBACK;
1796     POPSTACK;
1797     CATCH_SET(oldcatch);
1798
1799     if (postpr) {
1800       int ans;
1801       switch (method) {
1802       case le_amg:
1803       case sle_amg:
1804         ans=SvIV(res)<=0; break;
1805       case lt_amg:
1806       case slt_amg:
1807         ans=SvIV(res)<0; break;
1808       case ge_amg:
1809       case sge_amg:
1810         ans=SvIV(res)>=0; break;
1811       case gt_amg:
1812       case sgt_amg:
1813         ans=SvIV(res)>0; break;
1814       case eq_amg:
1815       case seq_amg:
1816         ans=SvIV(res)==0; break;
1817       case ne_amg:
1818       case sne_amg:
1819         ans=SvIV(res)!=0; break;
1820       case inc_amg:
1821       case dec_amg:
1822         SvSetSV(left,res); return left;
1823       case not_amg:
1824         ans=!SvTRUE(res); break;
1825       default:
1826         ans=0; break;
1827       }
1828       return boolSV(ans);
1829     } else if (method==copy_amg) {
1830       if (!SvROK(res)) {
1831         Perl_croak(aTHX_ "Copy method did not return a reference");
1832       }
1833       return SvREFCNT_inc(SvRV(res));
1834     } else {
1835       return res;
1836     }
1837   }
1838 }
1839
1840 /*
1841 =for apidoc is_gv_magical_sv
1842
1843 Returns C<TRUE> if given the name of a magical GV. Calls is_gv_magical.
1844
1845 =cut
1846 */
1847
1848 bool
1849 Perl_is_gv_magical_sv(pTHX_ SV *name, U32 flags)
1850 {
1851     STRLEN len;
1852     const char *temp = SvPV(name, len);
1853     return is_gv_magical(temp, len, flags);
1854 }
1855
1856 /*
1857 =for apidoc is_gv_magical
1858
1859 Returns C<TRUE> if given the name of a magical GV.
1860
1861 Currently only useful internally when determining if a GV should be
1862 created even in rvalue contexts.
1863
1864 C<flags> is not used at present but available for future extension to
1865 allow selecting particular classes of magical variable.
1866
1867 Currently assumes that C<name> is NUL terminated (as well as len being valid).
1868 This assumption is met by all callers within the perl core, which all pass
1869 pointers returned by SvPV.
1870
1871 =cut
1872 */
1873 bool
1874 Perl_is_gv_magical(pTHX_ const char *name, STRLEN len, U32 flags)
1875 {
1876     (void)flags;
1877     if (len > 1) {
1878         const char *name1 = name + 1;
1879         switch (*name) {
1880         case 'I':
1881             if (len == 3 && name1[1] == 'S' && name[2] == 'A')
1882                 goto yes;
1883             break;
1884         case 'O':
1885             if (len == 8 && strEQ(name1, "VERLOAD"))
1886                 goto yes;
1887             break;
1888         case 'S':
1889             if (len == 3 && name[1] == 'I' && name[2] == 'G')
1890                 goto yes;
1891             break;
1892             /* Using ${^...} variables is likely to be sufficiently rare that
1893                it seems sensible to avoid the space hit of also checking the
1894                length.  */
1895         case '\017':   /* ${^OPEN} */
1896             if (strEQ(name1, "PEN"))
1897                 goto yes;
1898             break;
1899         case '\024':   /* ${^TAINT} */
1900             if (strEQ(name1, "AINT"))
1901                 goto yes;
1902             break;
1903         case '\025':    /* ${^UNICODE} */
1904             if (strEQ(name1, "NICODE"))
1905                 goto yes;
1906             if (strEQ(name1, "TF8LOCALE"))
1907                 goto yes;
1908             break;
1909         case '\027':   /* ${^WARNING_BITS} */
1910             if (strEQ(name1, "ARNING_BITS"))
1911                 goto yes;
1912             break;
1913         case '1':
1914         case '2':
1915         case '3':
1916         case '4':
1917         case '5':
1918         case '6':
1919         case '7':
1920         case '8':
1921         case '9':
1922         {
1923             const char *end = name + len;
1924             while (--end > name) {
1925                 if (!isDIGIT(*end))
1926                     return FALSE;
1927             }
1928             goto yes;
1929         }
1930         }
1931     } else {
1932         /* Because we're already assuming that name is NUL terminated
1933            below, we can treat an empty name as "\0"  */
1934         switch (*name) {
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 ']':
1960         case '\001':   /* $^A */
1961         case '\003':   /* $^C */
1962         case '\004':   /* $^D */
1963         case '\005':   /* $^E */
1964         case '\006':   /* $^F */
1965         case '\010':   /* $^H */
1966         case '\011':   /* $^I, NOT \t in EBCDIC */
1967         case '\014':   /* $^L */
1968         case '\016':   /* $^N */
1969         case '\017':   /* $^O */
1970         case '\020':   /* $^P */
1971         case '\023':   /* $^S */
1972         case '\024':   /* $^T */
1973         case '\026':   /* $^V */
1974         case '\027':   /* $^W */
1975         case '1':
1976         case '2':
1977         case '3':
1978         case '4':
1979         case '5':
1980         case '6':
1981         case '7':
1982         case '8':
1983         case '9':
1984         yes:
1985             return TRUE;
1986         default:
1987             break;
1988         }
1989     }
1990     return FALSE;
1991 }