gv.c

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