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_const((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_const(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_const(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 * const 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             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         case '#':
1035             if (sv_type == SVt_PV && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
1036                 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
1037                             "$%c is no longer supported", *name);
1038             break;
1039         case '|':
1040             sv_setiv(GvSV(gv), (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0);
1041             goto magicalize;
1042
1043         case '+':
1044         {
1045             AV* av = GvAVn(gv);
1046             sv_magic((SV*)av, (SV*)av, PERL_MAGIC_regdata, Nullch, 0);
1047             SvREADONLY_on(av);
1048             /* FALL THROUGH */
1049         }
1050         case '\023':    /* $^S */
1051         case '1':
1052         case '2':
1053         case '3':
1054         case '4':
1055         case '5':
1056         case '6':
1057         case '7':
1058         case '8':
1059         case '9':
1060         ro_magicalize:
1061             SvREADONLY_on(GvSV(gv));
1062             /* FALL THROUGH */
1063         case '[':
1064         case '^':
1065         case '~':
1066         case '=':
1067         case '%':
1068         case '.':
1069         case '(':
1070         case ')':
1071         case '<':
1072         case '>':
1073         case ',':
1074         case '\\':
1075         case '/':
1076         case '\001':    /* $^A */
1077         case '\003':    /* $^C */
1078         case '\004':    /* $^D */
1079         case '\005':    /* $^E */
1080         case '\006':    /* $^F */
1081         case '\010':    /* $^H */
1082         case '\011':    /* $^I, NOT \t in EBCDIC */
1083         case '\016':    /* $^N */
1084         case '\017':    /* $^O */
1085         case '\020':    /* $^P */
1086         case '\024':    /* $^T */
1087         case '\027':    /* $^W */
1088         magicalize:
1089             sv_magic(GvSV(gv), (SV*)gv, PERL_MAGIC_sv, name, len);
1090             break;
1091
1092         case '\014':    /* $^L */
1093             sv_setpvn(GvSV(gv),"\f",1);
1094             PL_formfeed = GvSV(gv);
1095             break;
1096         case ';':
1097             sv_setpvn(GvSV(gv),"\034",1);
1098             break;
1099         case ']':
1100         {
1101             SV *sv = GvSV(gv);
1102             if (!sv_derived_from(PL_patchlevel, "version"))
1103                 (void *)upg_version(PL_patchlevel);
1104             GvSV(gv) = vnumify(PL_patchlevel);
1105             SvREADONLY_on(GvSV(gv));
1106             SvREFCNT_dec(sv);
1107         }
1108         break;
1109         case '\026':    /* $^V */
1110         {
1111             SV * const sv = GvSV(gv);
1112             GvSV(gv) = new_version(PL_patchlevel);
1113             SvREADONLY_on(GvSV(gv));
1114             SvREFCNT_dec(sv);
1115         }
1116         break;
1117         }
1118     }
1119     return gv;
1120 }
1121
1122 void
1123 Perl_gv_fullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
1124 {
1125     const char *name;
1126     STRLEN namelen;
1127     const HV * const hv = GvSTASH(gv);
1128     if (!hv) {
1129         SvOK_off(sv);
1130         return;
1131     }
1132     sv_setpv(sv, prefix ? prefix : "");
1133
1134     name = HvNAME_get(hv);
1135     if (name) {
1136         namelen = HvNAMELEN_get(hv);
1137     } else {
1138         name = "__ANON__";
1139         namelen = 8;
1140     }
1141
1142     if (keepmain || strNE(name, "main")) {
1143         sv_catpvn(sv,name,namelen);
1144         sv_catpvn(sv,"::", 2);
1145     }
1146     sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv));
1147 }
1148
1149 void
1150 Perl_gv_fullname3(pTHX_ SV *sv, const GV *gv, const char *prefix)
1151 {
1152     gv_fullname4(sv, gv, prefix, TRUE);
1153 }
1154
1155 void
1156 Perl_gv_efullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
1157 {
1158     const GV *egv = GvEGV(gv);
1159     if (!egv)
1160         egv = gv;
1161     gv_fullname4(sv, egv, prefix, keepmain);
1162 }
1163
1164 void
1165 Perl_gv_efullname3(pTHX_ SV *sv, const GV *gv, const char *prefix)
1166 {
1167     gv_efullname4(sv, gv, prefix, TRUE);
1168 }
1169
1170 /* compatibility with versions <= 5.003. */
1171 void
1172 Perl_gv_fullname(pTHX_ SV *sv, const GV *gv)
1173 {
1174     gv_fullname3(sv, gv, sv == (const SV*)gv ? "*" : "");
1175 }
1176
1177 /* compatibility with versions <= 5.003. */
1178 void
1179 Perl_gv_efullname(pTHX_ SV *sv, const GV *gv)
1180 {
1181     gv_efullname3(sv, gv, sv == (const SV*)gv ? "*" : "");
1182 }
1183
1184 IO *
1185 Perl_newIO(pTHX)
1186 {
1187     GV *iogv;
1188     IO * const io = (IO*)NEWSV(0,0);
1189
1190     sv_upgrade((SV *)io,SVt_PVIO);
1191     SvREFCNT(io) = 1;
1192     SvOBJECT_on(io);
1193     /* Clear the stashcache because a new IO could overrule a package name */
1194     hv_clear(PL_stashcache);
1195     iogv = gv_fetchpv("FileHandle::", FALSE, SVt_PVHV);
1196     /* unless exists($main::{FileHandle}) and defined(%main::FileHandle::) */
1197     if (!(iogv && GvHV(iogv) && HvARRAY(GvHV(iogv))))
1198       iogv = gv_fetchpv("IO::Handle::", TRUE, SVt_PVHV);
1199     SvSTASH_set(io, (HV*)SvREFCNT_inc(GvHV(iogv)));
1200     return io;
1201 }
1202
1203 void
1204 Perl_gv_check(pTHX_ HV *stash)
1205 {
1206     register I32 i;
1207
1208     if (!HvARRAY(stash))
1209         return;
1210     for (i = 0; i <= (I32) HvMAX(stash); i++) {
1211         const HE *entry;
1212         for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
1213             register GV *gv;
1214             HV *hv;
1215             if (HeKEY(entry)[HeKLEN(entry)-1] == ':' &&
1216                 (gv = (GV*)HeVAL(entry)) && isGV(gv) && (hv = GvHV(gv)))
1217             {
1218                 if (hv != PL_defstash && hv != stash)
1219                      gv_check(hv);              /* nested package */
1220             }
1221             else if (isALPHA(*HeKEY(entry))) {
1222                 const char *file;
1223                 gv = (GV*)HeVAL(entry);
1224                 if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv))
1225                     continue;
1226                 file = GvFILE(gv);
1227                 /* performance hack: if filename is absolute and it's a standard
1228                  * module, don't bother warning */
1229                 if (file
1230                     && PERL_FILE_IS_ABSOLUTE(file)
1231 #ifdef MACOS_TRADITIONAL
1232                     && (instr(file, ":lib:")
1233 #else
1234                     && (instr(file, "/lib/")
1235 #endif
1236                     || instr(file, ".pm")))
1237                 {
1238                     continue;
1239                 }
1240                 CopLINE_set(PL_curcop, GvLINE(gv));
1241 #ifdef USE_ITHREADS
1242                 CopFILE(PL_curcop) = (char *)file;      /* set for warning */
1243 #else
1244                 CopFILEGV(PL_curcop) = gv_fetchfile(file);
1245 #endif
1246                 Perl_warner(aTHX_ packWARN(WARN_ONCE),
1247                         "Name \"%s::%s\" used only once: possible typo",
1248                         HvNAME_get(stash), GvNAME(gv));
1249             }
1250         }
1251     }
1252 }
1253
1254 GV *
1255 Perl_newGVgen(pTHX_ const char *pack)
1256 {
1257     return gv_fetchpv(Perl_form(aTHX_ "%s::_GEN_%ld", pack, (long)PL_gensym++),
1258                       TRUE, SVt_PVGV);
1259 }
1260
1261 /* hopefully this is only called on local symbol table entries */
1262
1263 GP*
1264 Perl_gp_ref(pTHX_ GP *gp)
1265 {
1266     if (!gp)
1267         return (GP*)NULL;
1268     gp->gp_refcnt++;
1269     if (gp->gp_cv) {
1270         if (gp->gp_cvgen) {
1271             /* multi-named GPs cannot be used for method cache */
1272             SvREFCNT_dec(gp->gp_cv);
1273             gp->gp_cv = Nullcv;
1274             gp->gp_cvgen = 0;
1275         }
1276         else {
1277             /* Adding a new name to a subroutine invalidates method cache */
1278             PL_sub_generation++;
1279         }
1280     }
1281     return gp;
1282 }
1283
1284 void
1285 Perl_gp_free(pTHX_ GV *gv)
1286 {
1287     GP* gp;
1288
1289     if (!gv || !(gp = GvGP(gv)))
1290         return;
1291     if (gp->gp_refcnt == 0) {
1292         if (ckWARN_d(WARN_INTERNAL))
1293             Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
1294                         "Attempt to free unreferenced glob pointers"
1295                         pTHX__FORMAT pTHX__VALUE);
1296         return;
1297     }
1298     if (gp->gp_cv) {
1299         /* Deleting the name of a subroutine invalidates method cache */
1300         PL_sub_generation++;
1301     }
1302     if (--gp->gp_refcnt > 0) {
1303         if (gp->gp_egv == gv)
1304             gp->gp_egv = 0;
1305         return;
1306     }
1307
1308     if (gp->gp_sv) SvREFCNT_dec(gp->gp_sv);
1309     if (gp->gp_av) SvREFCNT_dec(gp->gp_av);
1310     /* FIXME - another reference loop GV -> symtab -> GV ?
1311        Somehow gp->gp_hv can end up pointing at freed garbage.  */
1312     if (gp->gp_hv && SvTYPE(gp->gp_hv) == SVt_PVHV) {
1313         const char *hvname = HvNAME_get(gp->gp_hv);
1314         if (PL_stashcache && hvname)
1315             hv_delete(PL_stashcache, hvname, HvNAMELEN_get(gp->gp_hv),
1316                       G_DISCARD);
1317         SvREFCNT_dec(gp->gp_hv);
1318     }
1319     if (gp->gp_io)   SvREFCNT_dec(gp->gp_io);
1320     if (gp->gp_cv)   SvREFCNT_dec(gp->gp_cv);
1321     if (gp->gp_form) SvREFCNT_dec(gp->gp_form);
1322
1323     Safefree(gp);
1324     GvGP(gv) = 0;
1325 }
1326
1327 int
1328 Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg)
1329 {
1330     AMT * const amtp = (AMT*)mg->mg_ptr;
1331     PERL_UNUSED_ARG(sv);
1332
1333     if (amtp && AMT_AMAGIC(amtp)) {
1334         int i;
1335         for (i = 1; i < NofAMmeth; i++) {
1336             CV * const cv = amtp->table[i];
1337             if (cv != Nullcv) {
1338                 SvREFCNT_dec((SV *) cv);
1339                 amtp->table[i] = Nullcv;
1340             }
1341         }
1342     }
1343  return 0;
1344 }
1345
1346 /* Updates and caches the CV's */
1347
1348 bool
1349 Perl_Gv_AMupdate(pTHX_ HV *stash)
1350 {
1351   MAGIC* const mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
1352   AMT * const amtp = (mg) ? (AMT*)mg->mg_ptr: (AMT *) NULL;
1353   AMT amt;
1354
1355   if (mg && amtp->was_ok_am == PL_amagic_generation
1356       && amtp->was_ok_sub == PL_sub_generation)
1357       return (bool)AMT_OVERLOADED(amtp);
1358   sv_unmagic((SV*)stash, PERL_MAGIC_overload_table);
1359
1360   DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME_get(stash)) );
1361
1362   Zero(&amt,1,AMT);
1363   amt.was_ok_am = PL_amagic_generation;
1364   amt.was_ok_sub = PL_sub_generation;
1365   amt.fallback = AMGfallNO;
1366   amt.flags = 0;
1367
1368   {
1369     int filled = 0, have_ovl = 0;
1370     int i, lim = 1;
1371
1372     /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
1373
1374     /* Try to find via inheritance. */
1375     GV *gv = gv_fetchmeth(stash, PL_AMG_names[0], 2, -1);
1376     SV * const sv = gv ? GvSV(gv) : NULL;
1377     CV* cv;
1378
1379     if (!gv)
1380         lim = DESTROY_amg;              /* Skip overloading entries. */
1381     else if (SvTRUE(sv))
1382         amt.fallback=AMGfallYES;
1383     else if (SvOK(sv))
1384         amt.fallback=AMGfallNEVER;
1385
1386     for (i = 1; i < lim; i++)
1387         amt.table[i] = Nullcv;
1388     for (; i < NofAMmeth; i++) {
1389         const char *cooky = PL_AMG_names[i];
1390         /* Human-readable form, for debugging: */
1391         const char *cp = (i >= DESTROY_amg ? cooky : AMG_id2name(i));
1392         const STRLEN l = strlen(cooky);
1393
1394         DEBUG_o( Perl_deb(aTHX_ "Checking overloading of \"%s\" in package \"%.256s\"\n",
1395                      cp, HvNAME_get(stash)) );
1396         /* don't fill the cache while looking up!
1397            Creation of inheritance stubs in intermediate packages may
1398            conflict with the logic of runtime method substitution.
1399            Indeed, for inheritance A -> B -> C, if C overloads "+0",
1400            then we could have created stubs for "(+0" in A and C too.
1401            But if B overloads "bool", we may want to use it for
1402            numifying instead of C's "+0". */
1403         if (i >= DESTROY_amg)
1404             gv = Perl_gv_fetchmeth_autoload(aTHX_ stash, cooky, l, 0);
1405         else                            /* Autoload taken care of below */
1406             gv = Perl_gv_fetchmeth(aTHX_ stash, cooky, l, -1);
1407         cv = 0;
1408         if (gv && (cv = GvCV(gv))) {
1409             const char *hvname;
1410             if (GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")
1411                 && strEQ(hvname = HvNAME_get(GvSTASH(CvGV(cv))), "overload")) {
1412                 /* This is a hack to support autoloading..., while
1413                    knowing *which* methods were declared as overloaded. */
1414                 /* GvSV contains the name of the method. */
1415                 GV *ngv = Nullgv;
1416
1417                 DEBUG_o( Perl_deb(aTHX_ "Resolving method \"%"SVf256\
1418                         "\" for overloaded \"%s\" in package \"%.256s\"\n",
1419                              GvSV(gv), cp, hvname) );
1420                 if (!SvPOK(GvSV(gv))
1421                     || !(ngv = gv_fetchmethod_autoload(stash, SvPVX_const(GvSV(gv)),
1422                                                        FALSE)))
1423                 {
1424                     /* Can be an import stub (created by "can"). */
1425                     SV *gvsv = GvSV(gv);
1426                     const char * const name = SvPOK(gvsv) ?  SvPVX_const(gvsv) : "???";
1427                     Perl_croak(aTHX_ "%s method \"%.256s\" overloading \"%s\" "\
1428                                 "in package \"%.256s\"",
1429                                (GvCVGEN(gv) ? "Stub found while resolving"
1430                                 : "Can't resolve"),
1431                                name, cp, hvname);
1432                 }
1433                 cv = GvCV(gv = ngv);
1434             }
1435             DEBUG_o( Perl_deb(aTHX_ "Overloading \"%s\" in package \"%.256s\" via \"%.256s::%.256s\"\n",
1436                          cp, HvNAME_get(stash), HvNAME_get(GvSTASH(CvGV(cv))),
1437                          GvNAME(CvGV(cv))) );
1438             filled = 1;
1439             if (i < DESTROY_amg)
1440                 have_ovl = 1;
1441         } else if (gv) {                /* Autoloaded... */
1442             cv = (CV*)gv;
1443             filled = 1;
1444         }
1445         amt.table[i]=(CV*)SvREFCNT_inc(cv);
1446     }
1447     if (filled) {
1448       AMT_AMAGIC_on(&amt);
1449       if (have_ovl)
1450           AMT_OVERLOADED_on(&amt);
1451       sv_magic((SV*)stash, 0, PERL_MAGIC_overload_table,
1452                                                 (char*)&amt, sizeof(AMT));
1453       return have_ovl;
1454     }
1455   }
1456   /* Here we have no table: */
1457   /* no_table: */
1458   AMT_AMAGIC_off(&amt);
1459   sv_magic((SV*)stash, 0, PERL_MAGIC_overload_table,
1460                                                 (char*)&amt, sizeof(AMTS));
1461   return FALSE;
1462 }
1463
1464
1465 CV*
1466 Perl_gv_handler(pTHX_ HV *stash, I32 id)
1467 {
1468     MAGIC *mg;
1469     AMT *amtp;
1470
1471     if (!stash || !HvNAME_get(stash))
1472         return Nullcv;
1473     mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
1474     if (!mg) {
1475       do_update:
1476         Gv_AMupdate(stash);
1477         mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
1478     }
1479     amtp = (AMT*)mg->mg_ptr;
1480     if ( amtp->was_ok_am != PL_amagic_generation
1481          || amtp->was_ok_sub != PL_sub_generation )
1482         goto do_update;
1483     if (AMT_AMAGIC(amtp)) {
1484         CV * const ret = amtp->table[id];
1485         if (ret && isGV(ret)) {         /* Autoloading stab */
1486             /* Passing it through may have resulted in a warning
1487                "Inherited AUTOLOAD for a non-method deprecated", since
1488                our caller is going through a function call, not a method call.
1489                So return the CV for AUTOLOAD, setting $AUTOLOAD. */
1490             GV *gv = gv_fetchmethod(stash, PL_AMG_names[id]);
1491
1492             if (gv && GvCV(gv))
1493                 return GvCV(gv);
1494         }
1495         return ret;
1496     }
1497
1498     return Nullcv;
1499 }
1500
1501
1502 SV*
1503 Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
1504 {
1505   dVAR;
1506   MAGIC *mg;
1507   CV *cv=NULL;
1508   CV **cvp=NULL, **ocvp=NULL;
1509   AMT *amtp=NULL, *oamtp=NULL;
1510   int off = 0, off1, lr = 0, notfound = 0;
1511   int postpr = 0, force_cpy = 0;
1512   int assign = AMGf_assign & flags;
1513   const int 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_const(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 * const 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  */