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