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