gv.c

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