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 *amtp = (AMT*)mg->mg_ptr;
1331     (void)sv;
1332
1333     if (amtp && AMT_AMAGIC(amtp)) {
1334         int i;
1335         for (i = 1; i < NofAMmeth; i++) {
1336             CV *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   GV* gv;
1352   CV* cv;
1353   MAGIC* mg=mg_find((SV*)stash, PERL_MAGIC_overload_table);
1354   AMT *amtp = (mg) ? (AMT*)mg->mg_ptr: (AMT *) NULL;
1355   AMT amt;
1356
1357   if (mg && amtp->was_ok_am == PL_amagic_generation
1358       && amtp->was_ok_sub == PL_sub_generation)
1359       return (bool)AMT_OVERLOADED(amtp);
1360   sv_unmagic((SV*)stash, PERL_MAGIC_overload_table);
1361
1362   DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME_get(stash)) );
1363
1364   Zero(&amt,1,AMT);
1365   amt.was_ok_am = PL_amagic_generation;
1366   amt.was_ok_sub = PL_sub_generation;
1367   amt.fallback = AMGfallNO;
1368   amt.flags = 0;
1369
1370   {
1371     int filled = 0, have_ovl = 0;
1372     int i, lim = 1;
1373     SV* sv = NULL;
1374
1375     /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
1376
1377     /* Try to find via inheritance. */
1378     gv = gv_fetchmeth(stash, PL_AMG_names[0], 2, -1);
1379     if (gv)
1380         sv = GvSV(gv);
1381
1382     if (!gv)
1383         lim = DESTROY_amg;              /* Skip overloading entries. */
1384     else if (SvTRUE(sv))
1385         amt.fallback=AMGfallYES;
1386     else if (SvOK(sv))
1387         amt.fallback=AMGfallNEVER;
1388
1389     for (i = 1; i < lim; i++)
1390         amt.table[i] = Nullcv;
1391     for (; i < NofAMmeth; i++) {
1392         const char *cooky = PL_AMG_names[i];
1393         /* Human-readable form, for debugging: */
1394         const char *cp = (i >= DESTROY_amg ? cooky : AMG_id2name(i));
1395         const STRLEN l = strlen(cooky);
1396
1397         DEBUG_o( Perl_deb(aTHX_ "Checking overloading of \"%s\" in package \"%.256s\"\n",
1398                      cp, HvNAME_get(stash)) );
1399         /* don't fill the cache while looking up!
1400            Creation of inheritance stubs in intermediate packages may
1401            conflict with the logic of runtime method substitution.
1402            Indeed, for inheritance A -> B -> C, if C overloads "+0",
1403            then we could have created stubs for "(+0" in A and C too.
1404            But if B overloads "bool", we may want to use it for
1405            numifying instead of C's "+0". */
1406         if (i >= DESTROY_amg)
1407             gv = Perl_gv_fetchmeth_autoload(aTHX_ stash, cooky, l, 0);
1408         else                            /* Autoload taken care of below */
1409             gv = Perl_gv_fetchmeth(aTHX_ stash, cooky, l, -1);
1410         cv = 0;
1411         if (gv && (cv = GvCV(gv))) {
1412             const char *hvname;
1413             if (GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")
1414                 && strEQ(hvname = HvNAME_get(GvSTASH(CvGV(cv))), "overload")) {
1415                 /* This is a hack to support autoloading..., while
1416                    knowing *which* methods were declared as overloaded. */
1417                 /* GvSV contains the name of the method. */
1418                 GV *ngv = Nullgv;
1419
1420                 DEBUG_o( Perl_deb(aTHX_ "Resolving method \"%"SVf256\
1421                         "\" for overloaded \"%s\" in package \"%.256s\"\n",
1422                              GvSV(gv), cp, hvname) );
1423                 if (!SvPOK(GvSV(gv))
1424                     || !(ngv = gv_fetchmethod_autoload(stash, SvPVX_const(GvSV(gv)),
1425                                                        FALSE)))
1426                 {
1427                     /* Can be an import stub (created by "can"). */
1428                     SV *gvsv = GvSV(gv);
1429                     const char * const name = SvPOK(gvsv) ?  SvPVX_const(gvsv) : "???";
1430                     Perl_croak(aTHX_ "%s method \"%.256s\" overloading \"%s\" "\
1431                                 "in package \"%.256s\"",
1432                                (GvCVGEN(gv) ? "Stub found while resolving"
1433                                 : "Can't resolve"),
1434                                name, cp, hvname);
1435                 }
1436                 cv = GvCV(gv = ngv);
1437             }
1438             DEBUG_o( Perl_deb(aTHX_ "Overloading \"%s\" in package \"%.256s\" via \"%.256s::%.256s\"\n",
1439                          cp, HvNAME_get(stash), HvNAME_get(GvSTASH(CvGV(cv))),
1440                          GvNAME(CvGV(cv))) );
1441             filled = 1;
1442             if (i < DESTROY_amg)
1443                 have_ovl = 1;
1444         } else if (gv) {                /* Autoloaded... */
1445             cv = (CV*)gv;
1446             filled = 1;
1447         }
1448         amt.table[i]=(CV*)SvREFCNT_inc(cv);
1449     }
1450     if (filled) {
1451       AMT_AMAGIC_on(&amt);
1452       if (have_ovl)
1453           AMT_OVERLOADED_on(&amt);
1454       sv_magic((SV*)stash, 0, PERL_MAGIC_overload_table,
1455                                                 (char*)&amt, sizeof(AMT));
1456       return have_ovl;
1457     }
1458   }
1459   /* Here we have no table: */
1460   /* no_table: */
1461   AMT_AMAGIC_off(&amt);
1462   sv_magic((SV*)stash, 0, PERL_MAGIC_overload_table,
1463                                                 (char*)&amt, sizeof(AMTS));
1464   return FALSE;
1465 }
1466
1467
1468 CV*
1469 Perl_gv_handler(pTHX_ HV *stash, I32 id)
1470 {
1471     MAGIC *mg;
1472     AMT *amtp;
1473
1474     if (!stash || !HvNAME_get(stash))
1475         return Nullcv;
1476     mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
1477     if (!mg) {
1478       do_update:
1479         Gv_AMupdate(stash);
1480         mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
1481     }
1482     amtp = (AMT*)mg->mg_ptr;
1483     if ( amtp->was_ok_am != PL_amagic_generation
1484          || amtp->was_ok_sub != PL_sub_generation )
1485         goto do_update;
1486     if (AMT_AMAGIC(amtp)) {
1487         CV * const ret = amtp->table[id];
1488         if (ret && isGV(ret)) {         /* Autoloading stab */
1489             /* Passing it through may have resulted in a warning
1490                "Inherited AUTOLOAD for a non-method deprecated", since
1491                our caller is going through a function call, not a method call.
1492                So return the CV for AUTOLOAD, setting $AUTOLOAD. */
1493             GV *gv = gv_fetchmethod(stash, PL_AMG_names[id]);
1494
1495             if (gv && GvCV(gv))
1496                 return GvCV(gv);
1497         }
1498         return ret;
1499     }
1500
1501     return Nullcv;
1502 }
1503
1504
1505 SV*
1506 Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
1507 {
1508   dVAR;
1509   MAGIC *mg;
1510   CV *cv=NULL;
1511   CV **cvp=NULL, **ocvp=NULL;
1512   AMT *amtp=NULL, *oamtp=NULL;
1513   int off = 0, off1, lr = 0, notfound = 0;
1514   int postpr = 0, force_cpy = 0;
1515   int assign = AMGf_assign & flags;
1516   const int assignshift = assign ? 1 : 0;
1517 #ifdef DEBUGGING
1518   int fl=0;
1519 #endif
1520   HV* stash=NULL;
1521   if (!(AMGf_noleft & flags) && SvAMAGIC(left)
1522       && (stash = SvSTASH(SvRV(left)))
1523       && (mg = mg_find((SV*)stash, PERL_MAGIC_overload_table))
1524       && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
1525                         ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
1526                         : (CV **) NULL))
1527       && ((cv = cvp[off=method+assignshift])
1528           || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
1529                                                           * usual method */
1530                   (
1531 #ifdef DEBUGGING
1532                    fl = 1,
1533 #endif
1534                    cv = cvp[off=method])))) {
1535     lr = -1;                    /* Call method for left argument */
1536   } else {
1537     if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) {
1538       int logic;
1539
1540       /* look for substituted methods */
1541       /* In all the covered cases we should be called with assign==0. */
1542          switch (method) {
1543          case inc_amg:
1544            force_cpy = 1;
1545            if ((cv = cvp[off=add_ass_amg])
1546                || ((cv = cvp[off = add_amg]) && (force_cpy = 0, postpr = 1))) {
1547              right = &PL_sv_yes; lr = -1; assign = 1;
1548            }
1549            break;
1550          case dec_amg:
1551            force_cpy = 1;
1552            if ((cv = cvp[off = subtr_ass_amg])
1553                || ((cv = cvp[off = subtr_amg]) && (force_cpy = 0, postpr=1))) {
1554              right = &PL_sv_yes; lr = -1; assign = 1;
1555            }
1556            break;
1557          case bool__amg:
1558            (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg]));
1559            break;
1560          case numer_amg:
1561            (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg]));
1562            break;
1563          case string_amg:
1564            (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg]));
1565            break;
1566          case not_amg:
1567            (void)((cv = cvp[off=bool__amg])
1568                   || (cv = cvp[off=numer_amg])
1569                   || (cv = cvp[off=string_amg]));
1570            postpr = 1;
1571            break;
1572          case copy_amg:
1573            {
1574              /*
1575                   * SV* ref causes confusion with the interpreter variable of
1576                   * the same name
1577                   */
1578              SV* tmpRef=SvRV(left);
1579              if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) {
1580                 /*
1581                  * Just to be extra cautious.  Maybe in some
1582                  * additional cases sv_setsv is safe, too.
1583                  */
1584                 SV* newref = newSVsv(tmpRef);
1585                 SvOBJECT_on(newref);
1586                 SvSTASH_set(newref, (HV*)SvREFCNT_inc(SvSTASH(tmpRef)));
1587                 return newref;
1588              }
1589            }
1590            break;
1591          case abs_amg:
1592            if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg])
1593                && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) {
1594              SV* nullsv=sv_2mortal(newSViv(0));
1595              if (off1==lt_amg) {
1596                SV* lessp = amagic_call(left,nullsv,
1597                                        lt_amg,AMGf_noright);
1598                logic = SvTRUE(lessp);
1599              } else {
1600                SV* lessp = amagic_call(left,nullsv,
1601                                        ncmp_amg,AMGf_noright);
1602                logic = (SvNV(lessp) < 0);
1603              }
1604              if (logic) {
1605                if (off==subtr_amg) {
1606                  right = left;
1607                  left = nullsv;
1608                  lr = 1;
1609                }
1610              } else {
1611                return left;
1612              }
1613            }
1614            break;
1615          case neg_amg:
1616            if ((cv = cvp[off=subtr_amg])) {
1617              right = left;
1618              left = sv_2mortal(newSViv(0));
1619              lr = 1;
1620            }
1621            break;
1622          case int_amg:
1623          case iter_amg:                 /* XXXX Eventually should do to_gv. */
1624              /* FAIL safe */
1625              return NULL;       /* Delegate operation to standard mechanisms. */
1626              break;
1627          case to_sv_amg:
1628          case to_av_amg:
1629          case to_hv_amg:
1630          case to_gv_amg:
1631          case to_cv_amg:
1632              /* FAIL safe */
1633              return left;       /* Delegate operation to standard mechanisms. */
1634              break;
1635          default:
1636            goto not_found;
1637          }
1638          if (!cv) goto not_found;
1639     } else if (!(AMGf_noright & flags) && SvAMAGIC(right)
1640                && (stash = SvSTASH(SvRV(right)))
1641                && (mg = mg_find((SV*)stash, PERL_MAGIC_overload_table))
1642                && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
1643                           ? (amtp = (AMT*)mg->mg_ptr)->table
1644                           : (CV **) NULL))
1645                && (cv = cvp[off=method])) { /* Method for right
1646                                              * argument found */
1647       lr=1;
1648     } else if (((ocvp && oamtp->fallback > AMGfallNEVER
1649                  && (cvp=ocvp) && (lr = -1))
1650                 || (cvp && amtp->fallback > AMGfallNEVER && (lr=1)))
1651                && !(flags & AMGf_unary)) {
1652                                 /* We look for substitution for
1653                                  * comparison operations and
1654                                  * concatenation */
1655       if (method==concat_amg || method==concat_ass_amg
1656           || method==repeat_amg || method==repeat_ass_amg) {
1657         return NULL;            /* Delegate operation to string conversion */
1658       }
1659       off = -1;
1660       switch (method) {
1661          case lt_amg:
1662          case le_amg:
1663          case gt_amg:
1664          case ge_amg:
1665          case eq_amg:
1666          case ne_amg:
1667            postpr = 1; off=ncmp_amg; break;
1668          case slt_amg:
1669          case sle_amg:
1670          case sgt_amg:
1671          case sge_amg:
1672          case seq_amg:
1673          case sne_amg:
1674            postpr = 1; off=scmp_amg; break;
1675          }
1676       if (off != -1) cv = cvp[off];
1677       if (!cv) {
1678         goto not_found;
1679       }
1680     } else {
1681     not_found:                  /* No method found, either report or croak */
1682       switch (method) {
1683          case to_sv_amg:
1684          case to_av_amg:
1685          case to_hv_amg:
1686          case to_gv_amg:
1687          case to_cv_amg:
1688              /* FAIL safe */
1689              return left;       /* Delegate operation to standard mechanisms. */
1690              break;
1691       }
1692       if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */
1693         notfound = 1; lr = -1;
1694       } else if (cvp && (cv=cvp[nomethod_amg])) {
1695         notfound = 1; lr = 1;
1696       } else {
1697         SV *msg;
1698         if (off==-1) off=method;
1699         msg = sv_2mortal(Perl_newSVpvf(aTHX_
1700                       "Operation \"%s\": no method found,%sargument %s%s%s%s",
1701                       AMG_id2name(method + assignshift),
1702                       (flags & AMGf_unary ? " " : "\n\tleft "),
1703                       SvAMAGIC(left)?
1704                         "in overloaded package ":
1705                         "has no overloaded magic",
1706                       SvAMAGIC(left)?
1707                         HvNAME_get(SvSTASH(SvRV(left))):
1708                         "",
1709                       SvAMAGIC(right)?
1710                         ",\n\tright argument in overloaded package ":
1711                         (flags & AMGf_unary
1712                          ? ""
1713                          : ",\n\tright argument has no overloaded magic"),
1714                       SvAMAGIC(right)?
1715                         HvNAME_get(SvSTASH(SvRV(right))):
1716                         ""));
1717         if (amtp && amtp->fallback >= AMGfallYES) {
1718           DEBUG_o( Perl_deb(aTHX_ "%s", SvPVX_const(msg)) );
1719         } else {
1720           Perl_croak(aTHX_ "%"SVf, msg);
1721         }
1722         return NULL;
1723       }
1724       force_cpy = force_cpy || assign;
1725     }
1726   }
1727 #ifdef DEBUGGING
1728   if (!notfound) {
1729     DEBUG_o(Perl_deb(aTHX_
1730                      "Overloaded operator \"%s\"%s%s%s:\n\tmethod%s found%s in package %s%s\n",
1731                      AMG_id2name(off),
1732                      method+assignshift==off? "" :
1733                      " (initially \"",
1734                      method+assignshift==off? "" :
1735                      AMG_id2name(method+assignshift),
1736                      method+assignshift==off? "" : "\")",
1737                      flags & AMGf_unary? "" :
1738                      lr==1 ? " for right argument": " for left argument",
1739                      flags & AMGf_unary? " for argument" : "",
1740                      stash ? HvNAME_get(stash) : "null",
1741                      fl? ",\n\tassignment variant used": "") );
1742   }
1743 #endif
1744     /* Since we use shallow copy during assignment, we need
1745      * to dublicate the contents, probably calling user-supplied
1746      * version of copy operator
1747      */
1748     /* We need to copy in following cases:
1749      * a) Assignment form was called.
1750      *          assignshift==1,  assign==T, method + 1 == off
1751      * b) Increment or decrement, called directly.
1752      *          assignshift==0,  assign==0, method + 0 == off
1753      * c) Increment or decrement, translated to assignment add/subtr.
1754      *          assignshift==0,  assign==T,
1755      *          force_cpy == T
1756      * d) Increment or decrement, translated to nomethod.
1757      *          assignshift==0,  assign==0,
1758      *          force_cpy == T
1759      * e) Assignment form translated to nomethod.
1760      *          assignshift==1,  assign==T, method + 1 != off
1761      *          force_cpy == T
1762      */
1763     /*  off is method, method+assignshift, or a result of opcode substitution.
1764      *  In the latter case assignshift==0, so only notfound case is important.
1765      */
1766   if (( (method + assignshift == off)
1767         && (assign || (method == inc_amg) || (method == dec_amg)))
1768       || force_cpy)
1769     RvDEEPCP(left);
1770   {
1771     dSP;
1772     BINOP myop;
1773     SV* res;
1774     const bool oldcatch = CATCH_GET;
1775
1776     CATCH_SET(TRUE);
1777     Zero(&myop, 1, BINOP);
1778     myop.op_last = (OP *) &myop;
1779     myop.op_next = Nullop;
1780     myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
1781
1782     PUSHSTACKi(PERLSI_OVERLOAD);
1783     ENTER;
1784     SAVEOP();
1785     PL_op = (OP *) &myop;
1786     if (PERLDB_SUB && PL_curstash != PL_debstash)
1787         PL_op->op_private |= OPpENTERSUB_DB;
1788     PUTBACK;
1789     pp_pushmark();
1790
1791     EXTEND(SP, notfound + 5);
1792     PUSHs(lr>0? right: left);
1793     PUSHs(lr>0? left: right);
1794     PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no ));
1795     if (notfound) {
1796       PUSHs( sv_2mortal(newSVpv(AMG_id2name(method + assignshift),0)));
1797     }
1798     PUSHs((SV*)cv);
1799     PUTBACK;
1800
1801     if ((PL_op = Perl_pp_entersub(aTHX)))
1802       CALLRUNOPS(aTHX);
1803     LEAVE;
1804     SPAGAIN;
1805
1806     res=POPs;
1807     PUTBACK;
1808     POPSTACK;
1809     CATCH_SET(oldcatch);
1810
1811     if (postpr) {
1812       int ans;
1813       switch (method) {
1814       case le_amg:
1815       case sle_amg:
1816         ans=SvIV(res)<=0; break;
1817       case lt_amg:
1818       case slt_amg:
1819         ans=SvIV(res)<0; break;
1820       case ge_amg:
1821       case sge_amg:
1822         ans=SvIV(res)>=0; break;
1823       case gt_amg:
1824       case sgt_amg:
1825         ans=SvIV(res)>0; break;
1826       case eq_amg:
1827       case seq_amg:
1828         ans=SvIV(res)==0; break;
1829       case ne_amg:
1830       case sne_amg:
1831         ans=SvIV(res)!=0; break;
1832       case inc_amg:
1833       case dec_amg:
1834         SvSetSV(left,res); return left;
1835       case not_amg:
1836         ans=!SvTRUE(res); break;
1837       default:
1838         ans=0; break;
1839       }
1840       return boolSV(ans);
1841     } else if (method==copy_amg) {
1842       if (!SvROK(res)) {
1843         Perl_croak(aTHX_ "Copy method did not return a reference");
1844       }
1845       return SvREFCNT_inc(SvRV(res));
1846     } else {
1847       return res;
1848     }
1849   }
1850 }
1851
1852 /*
1853 =for apidoc is_gv_magical_sv
1854
1855 Returns C<TRUE> if given the name of a magical GV. Calls is_gv_magical.
1856
1857 =cut
1858 */
1859
1860 bool
1861 Perl_is_gv_magical_sv(pTHX_ SV *name, U32 flags)
1862 {
1863     STRLEN len;
1864     const char *temp = SvPV_const(name, len);
1865     return is_gv_magical(temp, len, flags);
1866 }
1867
1868 /*
1869 =for apidoc is_gv_magical
1870
1871 Returns C<TRUE> if given the name of a magical GV.
1872
1873 Currently only useful internally when determining if a GV should be
1874 created even in rvalue contexts.
1875
1876 C<flags> is not used at present but available for future extension to
1877 allow selecting particular classes of magical variable.
1878
1879 Currently assumes that C<name> is NUL terminated (as well as len being valid).
1880 This assumption is met by all callers within the perl core, which all pass
1881 pointers returned by SvPV.
1882
1883 =cut
1884 */
1885 bool
1886 Perl_is_gv_magical(pTHX_ const char *name, STRLEN len, U32 flags)
1887 {
1888     (void)flags;
1889     if (len > 1) {
1890         const char * const name1 = name + 1;
1891         switch (*name) {
1892         case 'I':
1893             if (len == 3 && name1[1] == 'S' && name[2] == 'A')
1894                 goto yes;
1895             break;
1896         case 'O':
1897             if (len == 8 && strEQ(name1, "VERLOAD"))
1898                 goto yes;
1899             break;
1900         case 'S':
1901             if (len == 3 && name[1] == 'I' && name[2] == 'G')
1902                 goto yes;
1903             break;
1904             /* Using ${^...} variables is likely to be sufficiently rare that
1905                it seems sensible to avoid the space hit of also checking the
1906                length.  */
1907         case '\017':   /* ${^OPEN} */
1908             if (strEQ(name1, "PEN"))
1909                 goto yes;
1910             break;
1911         case '\024':   /* ${^TAINT} */
1912             if (strEQ(name1, "AINT"))
1913                 goto yes;
1914             break;
1915         case '\025':    /* ${^UNICODE} */
1916             if (strEQ(name1, "NICODE"))
1917                 goto yes;
1918             if (strEQ(name1, "TF8LOCALE"))
1919                 goto yes;
1920             break;
1921         case '\027':   /* ${^WARNING_BITS} */
1922             if (strEQ(name1, "ARNING_BITS"))
1923                 goto yes;
1924             break;
1925         case '1':
1926         case '2':
1927         case '3':
1928         case '4':
1929         case '5':
1930         case '6':
1931         case '7':
1932         case '8':
1933         case '9':
1934         {
1935             const char *end = name + len;
1936             while (--end > name) {
1937                 if (!isDIGIT(*end))
1938                     return FALSE;
1939             }
1940             goto yes;
1941         }
1942         }
1943     } else {
1944         /* Because we're already assuming that name is NUL terminated
1945            below, we can treat an empty name as "\0"  */
1946         switch (*name) {
1947         case '&':
1948         case '`':
1949         case '\'':
1950         case ':':
1951         case '?':
1952         case '!':
1953         case '-':
1954         case '#':
1955         case '[':
1956         case '^':
1957         case '~':
1958         case '=':
1959         case '%':
1960         case '.':
1961         case '(':
1962         case ')':
1963         case '<':
1964         case '>':
1965         case ',':
1966         case '\\':
1967         case '/':
1968         case '|':
1969         case '+':
1970         case ';':
1971         case ']':
1972         case '\001':   /* $^A */
1973         case '\003':   /* $^C */
1974         case '\004':   /* $^D */
1975         case '\005':   /* $^E */
1976         case '\006':   /* $^F */
1977         case '\010':   /* $^H */
1978         case '\011':   /* $^I, NOT \t in EBCDIC */
1979         case '\014':   /* $^L */
1980         case '\016':   /* $^N */
1981         case '\017':   /* $^O */
1982         case '\020':   /* $^P */
1983         case '\023':   /* $^S */
1984         case '\024':   /* $^T */
1985         case '\026':   /* $^V */
1986         case '\027':   /* $^W */
1987         case '1':
1988         case '2':
1989         case '3':
1990         case '4':
1991         case '5':
1992         case '6':
1993         case '7':
1994         case '8':
1995         case '9':
1996         yes:
1997             return TRUE;
1998         default:
1999             break;
2000         }
2001     }
2002     return FALSE;
2003 }
2004
2005 /*
2006  * Local variables:
2007  * c-indentation-style: bsd
2008  * c-basic-offset: 4
2009  * indent-tabs-mode: t
2010  * End:
2011  *
2012  * ex: set ts=8 sts=4 sw=4 noet:
2013  */