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