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