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