gv.c

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