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