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             if (sv_type == SVt_PV && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
1035                 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
1036                             "$* is no longer supported");
1037             break;
1038         case '#':
1039             if (sv_type == SVt_PV && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
1040                 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
1041                             "Use of $# is deprecated");
1042             goto magicalize;
1043         case '|':
1044             sv_setiv(GvSV(gv), (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0);
1045             goto magicalize;
1046
1047         case '+':
1048         {
1049             AV* av = GvAVn(gv);
1050             sv_magic((SV*)av, (SV*)av, PERL_MAGIC_regdata, Nullch, 0);
1051             SvREADONLY_on(av);
1052             /* FALL THROUGH */
1053         }
1054         case '\023':    /* $^S */
1055         case '1':
1056         case '2':
1057         case '3':
1058         case '4':
1059         case '5':
1060         case '6':
1061         case '7':
1062         case '8':
1063         case '9':
1064         ro_magicalize:
1065             SvREADONLY_on(GvSV(gv));
1066             /* FALL THROUGH */
1067         case '[':
1068         case '^':
1069         case '~':
1070         case '=':
1071         case '%':
1072         case '.':
1073         case '(':
1074         case ')':
1075         case '<':
1076         case '>':
1077         case ',':
1078         case '\\':
1079         case '/':
1080         case '\001':    /* $^A */
1081         case '\003':    /* $^C */
1082         case '\004':    /* $^D */
1083         case '\005':    /* $^E */
1084         case '\006':    /* $^F */
1085         case '\010':    /* $^H */
1086         case '\011':    /* $^I, NOT \t in EBCDIC */
1087         case '\016':    /* $^N */
1088         case '\017':    /* $^O */
1089         case '\020':    /* $^P */
1090         case '\024':    /* $^T */
1091         case '\027':    /* $^W */
1092         magicalize:
1093             sv_magic(GvSV(gv), (SV*)gv, PERL_MAGIC_sv, name, len);
1094             break;
1095
1096         case '\014':    /* $^L */
1097             sv_setpvn(GvSV(gv),"\f",1);
1098             PL_formfeed = GvSV(gv);
1099             break;
1100         case ';':
1101             sv_setpvn(GvSV(gv),"\034",1);
1102             break;
1103         case ']':
1104         {
1105             SV *sv = GvSV(gv);
1106             if (!sv_derived_from(PL_patchlevel, "version"))
1107                 (void *)upg_version(PL_patchlevel);
1108             GvSV(gv) = vnumify(PL_patchlevel);
1109             SvREADONLY_on(GvSV(gv));
1110             SvREFCNT_dec(sv);
1111         }
1112         break;
1113         case '\026':    /* $^V */
1114         {
1115             SV * const sv = GvSV(gv);
1116             GvSV(gv) = new_version(PL_patchlevel);
1117             SvREADONLY_on(GvSV(gv));
1118             SvREFCNT_dec(sv);
1119         }
1120         break;
1121         }
1122     }
1123     return gv;
1124 }
1125
1126 void
1127 Perl_gv_fullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
1128 {
1129     const char *name;
1130     STRLEN namelen;
1131     const HV * const hv = GvSTASH(gv);
1132     if (!hv) {
1133         SvOK_off(sv);
1134         return;
1135     }
1136     sv_setpv(sv, prefix ? prefix : "");
1137
1138     name = HvNAME_get(hv);
1139     if (name) {
1140         namelen = HvNAMELEN_get(hv);
1141     } else {
1142         name = "__ANON__";
1143         namelen = 8;
1144     }
1145
1146     if (keepmain || strNE(name, "main")) {
1147         sv_catpvn(sv,name,namelen);
1148         sv_catpvn(sv,"::", 2);
1149     }
1150     sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv));
1151 }
1152
1153 void
1154 Perl_gv_fullname3(pTHX_ SV *sv, const GV *gv, const char *prefix)
1155 {
1156     gv_fullname4(sv, gv, prefix, TRUE);
1157 }
1158
1159 void
1160 Perl_gv_efullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
1161 {
1162     const GV *egv = GvEGV(gv);
1163     if (!egv)
1164         egv = gv;
1165     gv_fullname4(sv, egv, prefix, keepmain);
1166 }
1167
1168 void
1169 Perl_gv_efullname3(pTHX_ SV *sv, const GV *gv, const char *prefix)
1170 {
1171     gv_efullname4(sv, gv, prefix, TRUE);
1172 }
1173
1174 /* compatibility with versions <= 5.003. */
1175 void
1176 Perl_gv_fullname(pTHX_ SV *sv, const GV *gv)
1177 {
1178     gv_fullname3(sv, gv, sv == (const SV*)gv ? "*" : "");
1179 }
1180
1181 /* compatibility with versions <= 5.003. */
1182 void
1183 Perl_gv_efullname(pTHX_ SV *sv, const GV *gv)
1184 {
1185     gv_efullname3(sv, gv, sv == (const SV*)gv ? "*" : "");
1186 }
1187
1188 IO *
1189 Perl_newIO(pTHX)
1190 {
1191     GV *iogv;
1192     IO * const io = (IO*)NEWSV(0,0);
1193
1194     sv_upgrade((SV *)io,SVt_PVIO);
1195     SvREFCNT(io) = 1;
1196     SvOBJECT_on(io);
1197     /* Clear the stashcache because a new IO could overrule a package name */
1198     hv_clear(PL_stashcache);
1199     iogv = gv_fetchpv("FileHandle::", FALSE, SVt_PVHV);
1200     /* unless exists($main::{FileHandle}) and defined(%main::FileHandle::) */
1201     if (!(iogv && GvHV(iogv) && HvARRAY(GvHV(iogv))))
1202       iogv = gv_fetchpv("IO::Handle::", TRUE, SVt_PVHV);
1203     SvSTASH_set(io, (HV*)SvREFCNT_inc(GvHV(iogv)));
1204     return io;
1205 }
1206
1207 void
1208 Perl_gv_check(pTHX_ HV *stash)
1209 {
1210     register I32 i;
1211
1212     if (!HvARRAY(stash))
1213         return;
1214     for (i = 0; i <= (I32) HvMAX(stash); i++) {
1215         const HE *entry;
1216         for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
1217             register GV *gv;
1218             HV *hv;
1219             if (HeKEY(entry)[HeKLEN(entry)-1] == ':' &&
1220                 (gv = (GV*)HeVAL(entry)) && isGV(gv) && (hv = GvHV(gv)))
1221             {
1222                 if (hv != PL_defstash && hv != stash)
1223                      gv_check(hv);              /* nested package */
1224             }
1225             else if (isALPHA(*HeKEY(entry))) {
1226                 const char *file;
1227                 gv = (GV*)HeVAL(entry);
1228                 if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv))
1229                     continue;
1230                 file = GvFILE(gv);
1231                 /* performance hack: if filename is absolute and it's a standard
1232                  * module, don't bother warning */
1233                 if (file
1234                     && PERL_FILE_IS_ABSOLUTE(file)
1235 #ifdef MACOS_TRADITIONAL
1236                     && (instr(file, ":lib:")
1237 #else
1238                     && (instr(file, "/lib/")
1239 #endif
1240                     || instr(file, ".pm")))
1241                 {
1242                     continue;
1243                 }
1244                 CopLINE_set(PL_curcop, GvLINE(gv));
1245 #ifdef USE_ITHREADS
1246                 CopFILE(PL_curcop) = (char *)file;      /* set for warning */
1247 #else
1248                 CopFILEGV(PL_curcop) = gv_fetchfile(file);
1249 #endif
1250                 Perl_warner(aTHX_ packWARN(WARN_ONCE),
1251                         "Name \"%s::%s\" used only once: possible typo",
1252                         HvNAME_get(stash), GvNAME(gv));
1253             }
1254         }
1255     }
1256 }
1257
1258 GV *
1259 Perl_newGVgen(pTHX_ const char *pack)
1260 {
1261     return gv_fetchpv(Perl_form(aTHX_ "%s::_GEN_%ld", pack, (long)PL_gensym++),
1262                       TRUE, SVt_PVGV);
1263 }
1264
1265 /* hopefully this is only called on local symbol table entries */
1266
1267 GP*
1268 Perl_gp_ref(pTHX_ GP *gp)
1269 {
1270     if (!gp)
1271         return (GP*)NULL;
1272     gp->gp_refcnt++;
1273     if (gp->gp_cv) {
1274         if (gp->gp_cvgen) {
1275             /* multi-named GPs cannot be used for method cache */
1276             SvREFCNT_dec(gp->gp_cv);
1277             gp->gp_cv = Nullcv;
1278             gp->gp_cvgen = 0;
1279         }
1280         else {
1281             /* Adding a new name to a subroutine invalidates method cache */
1282             PL_sub_generation++;
1283         }
1284     }
1285     return gp;
1286 }
1287
1288 void
1289 Perl_gp_free(pTHX_ GV *gv)
1290 {
1291     GP* gp;
1292
1293     if (!gv || !(gp = GvGP(gv)))
1294         return;
1295     if (gp->gp_refcnt == 0) {
1296         if (ckWARN_d(WARN_INTERNAL))
1297             Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
1298                         "Attempt to free unreferenced glob pointers"
1299                         pTHX__FORMAT pTHX__VALUE);
1300         return;
1301     }
1302     if (gp->gp_cv) {
1303         /* Deleting the name of a subroutine invalidates method cache */
1304         PL_sub_generation++;
1305     }
1306     if (--gp->gp_refcnt > 0) {
1307         if (gp->gp_egv == gv)
1308             gp->gp_egv = 0;
1309         return;
1310     }
1311
1312     if (gp->gp_sv) SvREFCNT_dec(gp->gp_sv);
1313     if (gp->gp_av) SvREFCNT_dec(gp->gp_av);
1314     /* FIXME - another reference loop GV -> symtab -> GV ?
1315        Somehow gp->gp_hv can end up pointing at freed garbage.  */
1316     if (gp->gp_hv && SvTYPE(gp->gp_hv) == SVt_PVHV) {
1317         const char *hvname = HvNAME_get(gp->gp_hv);
1318         if (PL_stashcache && hvname)
1319             hv_delete(PL_stashcache, hvname, HvNAMELEN_get(gp->gp_hv),
1320                       G_DISCARD);
1321         SvREFCNT_dec(gp->gp_hv);
1322     }
1323     if (gp->gp_io)   SvREFCNT_dec(gp->gp_io);
1324     if (gp->gp_cv)   SvREFCNT_dec(gp->gp_cv);
1325     if (gp->gp_form) SvREFCNT_dec(gp->gp_form);
1326
1327     Safefree(gp);
1328     GvGP(gv) = 0;
1329 }
1330
1331 int
1332 Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg)
1333 {
1334     AMT *amtp = (AMT*)mg->mg_ptr;
1335     (void)sv;
1336
1337     if (amtp && AMT_AMAGIC(amtp)) {
1338         int i;
1339         for (i = 1; i < NofAMmeth; i++) {
1340             CV *cv = amtp->table[i];
1341             if (cv != Nullcv) {
1342                 SvREFCNT_dec((SV *) cv);
1343                 amtp->table[i] = Nullcv;
1344             }
1345         }
1346     }
1347  return 0;
1348 }
1349
1350 /* Updates and caches the CV's */
1351
1352 bool
1353 Perl_Gv_AMupdate(pTHX_ HV *stash)
1354 {
1355   GV* gv;
1356   CV* cv;
1357   MAGIC* mg=mg_find((SV*)stash, PERL_MAGIC_overload_table);
1358   AMT *amtp = (mg) ? (AMT*)mg->mg_ptr: (AMT *) NULL;
1359   AMT amt;
1360
1361   if (mg && amtp->was_ok_am == PL_amagic_generation
1362       && amtp->was_ok_sub == PL_sub_generation)
1363       return (bool)AMT_OVERLOADED(amtp);
1364   sv_unmagic((SV*)stash, PERL_MAGIC_overload_table);
1365
1366   DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME_get(stash)) );
1367
1368   Zero(&amt,1,AMT);
1369   amt.was_ok_am = PL_amagic_generation;
1370   amt.was_ok_sub = PL_sub_generation;
1371   amt.fallback = AMGfallNO;
1372   amt.flags = 0;
1373
1374   {
1375     int filled = 0, have_ovl = 0;
1376     int i, lim = 1;
1377     SV* sv = NULL;
1378
1379     /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
1380
1381     /* Try to find via inheritance. */
1382     gv = gv_fetchmeth(stash, PL_AMG_names[0], 2, -1);
1383     if (gv)
1384         sv = GvSV(gv);
1385
1386     if (!gv)
1387         lim = DESTROY_amg;              /* Skip overloading entries. */
1388     else if (SvTRUE(sv))
1389         amt.fallback=AMGfallYES;
1390     else if (SvOK(sv))
1391         amt.fallback=AMGfallNEVER;
1392
1393     for (i = 1; i < lim; i++)
1394         amt.table[i] = Nullcv;
1395     for (; i < NofAMmeth; i++) {
1396         const char *cooky = PL_AMG_names[i];
1397         /* Human-readable form, for debugging: */
1398         const char *cp = (i >= DESTROY_amg ? cooky : AMG_id2name(i));
1399         const STRLEN l = strlen(cooky);
1400
1401         DEBUG_o( Perl_deb(aTHX_ "Checking overloading of \"%s\" in package \"%.256s\"\n",
1402                      cp, HvNAME_get(stash)) );
1403         /* don't fill the cache while looking up!
1404            Creation of inheritance stubs in intermediate packages may
1405            conflict with the logic of runtime method substitution.
1406            Indeed, for inheritance A -> B -> C, if C overloads "+0",
1407            then we could have created stubs for "(+0" in A and C too.
1408            But if B overloads "bool", we may want to use it for
1409            numifying instead of C's "+0". */
1410         if (i >= DESTROY_amg)
1411             gv = Perl_gv_fetchmeth_autoload(aTHX_ stash, cooky, l, 0);
1412         else                            /* Autoload taken care of below */
1413             gv = Perl_gv_fetchmeth(aTHX_ stash, cooky, l, -1);
1414         cv = 0;
1415         if (gv && (cv = GvCV(gv))) {
1416             const char *hvname;
1417             if (GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")
1418                 && strEQ(hvname = HvNAME_get(GvSTASH(CvGV(cv))), "overload")) {
1419                 /* This is a hack to support autoloading..., while
1420                    knowing *which* methods were declared as overloaded. */
1421                 /* GvSV contains the name of the method. */
1422                 GV *ngv = Nullgv;
1423
1424                 DEBUG_o( Perl_deb(aTHX_ "Resolving method \"%"SVf256\
1425                         "\" for overloaded \"%s\" in package \"%.256s\"\n",
1426                              GvSV(gv), cp, hvname) );
1427                 if (!SvPOK(GvSV(gv))
1428                     || !(ngv = gv_fetchmethod_autoload(stash, SvPVX_const(GvSV(gv)),
1429                                                        FALSE)))
1430                 {
1431                     /* Can be an import stub (created by "can"). */
1432                     SV *gvsv = GvSV(gv);
1433                     const char * const name = SvPOK(gvsv) ?  SvPVX_const(gvsv) : "???";
1434                     Perl_croak(aTHX_ "%s method \"%.256s\" overloading \"%s\" "\
1435                                 "in package \"%.256s\"",
1436                                (GvCVGEN(gv) ? "Stub found while resolving"
1437                                 : "Can't resolve"),
1438                                name, cp, hvname);
1439                 }
1440                 cv = GvCV(gv = ngv);
1441             }
1442             DEBUG_o( Perl_deb(aTHX_ "Overloading \"%s\" in package \"%.256s\" via \"%.256s::%.256s\"\n",
1443                          cp, HvNAME_get(stash), HvNAME_get(GvSTASH(CvGV(cv))),
1444                          GvNAME(CvGV(cv))) );
1445             filled = 1;
1446             if (i < DESTROY_amg)
1447                 have_ovl = 1;
1448         } else if (gv) {                /* Autoloaded... */
1449             cv = (CV*)gv;
1450             filled = 1;
1451         }
1452         amt.table[i]=(CV*)SvREFCNT_inc(cv);
1453     }
1454     if (filled) {
1455       AMT_AMAGIC_on(&amt);
1456       if (have_ovl)
1457           AMT_OVERLOADED_on(&amt);
1458       sv_magic((SV*)stash, 0, PERL_MAGIC_overload_table,
1459                                                 (char*)&amt, sizeof(AMT));
1460       return have_ovl;
1461     }
1462   }
1463   /* Here we have no table: */
1464   /* no_table: */
1465   AMT_AMAGIC_off(&amt);
1466   sv_magic((SV*)stash, 0, PERL_MAGIC_overload_table,
1467                                                 (char*)&amt, sizeof(AMTS));
1468   return FALSE;
1469 }
1470
1471
1472 CV*
1473 Perl_gv_handler(pTHX_ HV *stash, I32 id)
1474 {
1475     MAGIC *mg;
1476     AMT *amtp;
1477
1478     if (!stash || !HvNAME_get(stash))
1479         return Nullcv;
1480     mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
1481     if (!mg) {
1482       do_update:
1483         Gv_AMupdate(stash);
1484         mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
1485     }
1486     amtp = (AMT*)mg->mg_ptr;
1487     if ( amtp->was_ok_am != PL_amagic_generation
1488          || amtp->was_ok_sub != PL_sub_generation )
1489         goto do_update;
1490     if (AMT_AMAGIC(amtp)) {
1491         CV * const ret = amtp->table[id];
1492         if (ret && isGV(ret)) {         /* Autoloading stab */
1493             /* Passing it through may have resulted in a warning
1494                "Inherited AUTOLOAD for a non-method deprecated", since
1495                our caller is going through a function call, not a method call.
1496                So return the CV for AUTOLOAD, setting $AUTOLOAD. */
1497             GV *gv = gv_fetchmethod(stash, PL_AMG_names[id]);
1498
1499             if (gv && GvCV(gv))
1500                 return GvCV(gv);
1501         }
1502         return ret;
1503     }
1504
1505     return Nullcv;
1506 }
1507
1508
1509 SV*
1510 Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
1511 {
1512   dVAR;
1513   MAGIC *mg;
1514   CV *cv=NULL;
1515   CV **cvp=NULL, **ocvp=NULL;
1516   AMT *amtp=NULL, *oamtp=NULL;
1517   int off = 0, off1, lr = 0, notfound = 0;
1518   int postpr = 0, force_cpy = 0;
1519   int assign = AMGf_assign & flags;
1520   const int assignshift = assign ? 1 : 0;
1521 #ifdef DEBUGGING
1522   int fl=0;
1523 #endif
1524   HV* stash=NULL;
1525   if (!(AMGf_noleft & flags) && SvAMAGIC(left)
1526       && (stash = SvSTASH(SvRV(left)))
1527       && (mg = mg_find((SV*)stash, PERL_MAGIC_overload_table))
1528       && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
1529                         ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
1530                         : (CV **) NULL))
1531       && ((cv = cvp[off=method+assignshift])
1532           || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
1533                                                           * usual method */
1534                   (
1535 #ifdef DEBUGGING
1536                    fl = 1,
1537 #endif
1538                    cv = cvp[off=method])))) {
1539     lr = -1;                    /* Call method for left argument */
1540   } else {
1541     if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) {
1542       int logic;
1543
1544       /* look for substituted methods */
1545       /* In all the covered cases we should be called with assign==0. */
1546          switch (method) {
1547          case inc_amg:
1548            force_cpy = 1;
1549            if ((cv = cvp[off=add_ass_amg])
1550                || ((cv = cvp[off = add_amg]) && (force_cpy = 0, postpr = 1))) {
1551              right = &PL_sv_yes; lr = -1; assign = 1;
1552            }
1553            break;
1554          case dec_amg:
1555            force_cpy = 1;
1556            if ((cv = cvp[off = subtr_ass_amg])
1557                || ((cv = cvp[off = subtr_amg]) && (force_cpy = 0, postpr=1))) {
1558              right = &PL_sv_yes; lr = -1; assign = 1;
1559            }
1560            break;
1561          case bool__amg:
1562            (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg]));
1563            break;
1564          case numer_amg:
1565            (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg]));
1566            break;
1567          case string_amg:
1568            (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg]));
1569            break;
1570          case not_amg:
1571            (void)((cv = cvp[off=bool__amg])
1572                   || (cv = cvp[off=numer_amg])
1573                   || (cv = cvp[off=string_amg]));
1574            postpr = 1;
1575            break;
1576          case copy_amg:
1577            {
1578              /*
1579                   * SV* ref causes confusion with the interpreter variable of
1580                   * the same name
1581                   */
1582              SV* tmpRef=SvRV(left);
1583              if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) {
1584                 /*
1585                  * Just to be extra cautious.  Maybe in some
1586                  * additional cases sv_setsv is safe, too.
1587                  */
1588                 SV* newref = newSVsv(tmpRef);
1589                 SvOBJECT_on(newref);
1590                 SvSTASH_set(newref, (HV*)SvREFCNT_inc(SvSTASH(tmpRef)));
1591                 return newref;
1592              }
1593            }
1594            break;
1595          case abs_amg:
1596            if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg])
1597                && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) {
1598              SV* nullsv=sv_2mortal(newSViv(0));
1599              if (off1==lt_amg) {
1600                SV* lessp = amagic_call(left,nullsv,
1601                                        lt_amg,AMGf_noright);
1602                logic = SvTRUE(lessp);
1603              } else {
1604                SV* lessp = amagic_call(left,nullsv,
1605                                        ncmp_amg,AMGf_noright);
1606                logic = (SvNV(lessp) < 0);
1607              }
1608              if (logic) {
1609                if (off==subtr_amg) {
1610                  right = left;
1611                  left = nullsv;
1612                  lr = 1;
1613                }
1614              } else {
1615                return left;
1616              }
1617            }
1618            break;
1619          case neg_amg:
1620            if ((cv = cvp[off=subtr_amg])) {
1621              right = left;
1622              left = sv_2mortal(newSViv(0));
1623              lr = 1;
1624            }
1625            break;
1626          case int_amg:
1627          case iter_amg:                 /* XXXX Eventually should do to_gv. */
1628              /* FAIL safe */
1629              return NULL;       /* Delegate operation to standard mechanisms. */
1630              break;
1631          case to_sv_amg:
1632          case to_av_amg:
1633          case to_hv_amg:
1634          case to_gv_amg:
1635          case to_cv_amg:
1636              /* FAIL safe */
1637              return left;       /* Delegate operation to standard mechanisms. */
1638              break;
1639          default:
1640            goto not_found;
1641          }
1642          if (!cv) goto not_found;
1643     } else if (!(AMGf_noright & flags) && SvAMAGIC(right)
1644                && (stash = SvSTASH(SvRV(right)))
1645                && (mg = mg_find((SV*)stash, PERL_MAGIC_overload_table))
1646                && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
1647                           ? (amtp = (AMT*)mg->mg_ptr)->table
1648                           : (CV **) NULL))
1649                && (cv = cvp[off=method])) { /* Method for right
1650                                              * argument found */
1651       lr=1;
1652     } else if (((ocvp && oamtp->fallback > AMGfallNEVER
1653                  && (cvp=ocvp) && (lr = -1))
1654                 || (cvp && amtp->fallback > AMGfallNEVER && (lr=1)))
1655                && !(flags & AMGf_unary)) {
1656                                 /* We look for substitution for
1657                                  * comparison operations and
1658                                  * concatenation */
1659       if (method==concat_amg || method==concat_ass_amg
1660           || method==repeat_amg || method==repeat_ass_amg) {
1661         return NULL;            /* Delegate operation to string conversion */
1662       }
1663       off = -1;
1664       switch (method) {
1665          case lt_amg:
1666          case le_amg:
1667          case gt_amg:
1668          case ge_amg:
1669          case eq_amg:
1670          case ne_amg:
1671            postpr = 1; off=ncmp_amg; break;
1672          case slt_amg:
1673          case sle_amg:
1674          case sgt_amg:
1675          case sge_amg:
1676          case seq_amg:
1677          case sne_amg:
1678            postpr = 1; off=scmp_amg; break;
1679          }
1680       if (off != -1) cv = cvp[off];
1681       if (!cv) {
1682         goto not_found;
1683       }
1684     } else {
1685     not_found:                  /* No method found, either report or croak */
1686       switch (method) {
1687          case to_sv_amg:
1688          case to_av_amg:
1689          case to_hv_amg:
1690          case to_gv_amg:
1691          case to_cv_amg:
1692              /* FAIL safe */
1693              return left;       /* Delegate operation to standard mechanisms. */
1694              break;
1695       }
1696       if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */
1697         notfound = 1; lr = -1;
1698       } else if (cvp && (cv=cvp[nomethod_amg])) {
1699         notfound = 1; lr = 1;
1700       } else {
1701         SV *msg;
1702         if (off==-1) off=method;
1703         msg = sv_2mortal(Perl_newSVpvf(aTHX_
1704                       "Operation \"%s\": no method found,%sargument %s%s%s%s",
1705                       AMG_id2name(method + assignshift),
1706                       (flags & AMGf_unary ? " " : "\n\tleft "),
1707                       SvAMAGIC(left)?
1708                         "in overloaded package ":
1709                         "has no overloaded magic",
1710                       SvAMAGIC(left)?
1711                         HvNAME_get(SvSTASH(SvRV(left))):
1712                         "",
1713                       SvAMAGIC(right)?
1714                         ",\n\tright argument in overloaded package ":
1715                         (flags & AMGf_unary
1716                          ? ""
1717                          : ",\n\tright argument has no overloaded magic"),
1718                       SvAMAGIC(right)?
1719                         HvNAME_get(SvSTASH(SvRV(right))):
1720                         ""));
1721         if (amtp && amtp->fallback >= AMGfallYES) {
1722           DEBUG_o( Perl_deb(aTHX_ "%s", SvPVX_const(msg)) );
1723         } else {
1724           Perl_croak(aTHX_ "%"SVf, msg);
1725         }
1726         return NULL;
1727       }
1728       force_cpy = force_cpy || assign;
1729     }
1730   }
1731 #ifdef DEBUGGING
1732   if (!notfound) {
1733     DEBUG_o(Perl_deb(aTHX_
1734                      "Overloaded operator \"%s\"%s%s%s:\n\tmethod%s found%s in package %s%s\n",
1735                      AMG_id2name(off),
1736                      method+assignshift==off? "" :
1737                      " (initially \"",
1738                      method+assignshift==off? "" :
1739                      AMG_id2name(method+assignshift),
1740                      method+assignshift==off? "" : "\")",
1741                      flags & AMGf_unary? "" :
1742                      lr==1 ? " for right argument": " for left argument",
1743                      flags & AMGf_unary? " for argument" : "",
1744                      stash ? HvNAME_get(stash) : "null",
1745                      fl? ",\n\tassignment variant used": "") );
1746   }
1747 #endif
1748     /* Since we use shallow copy during assignment, we need
1749      * to dublicate the contents, probably calling user-supplied
1750      * version of copy operator
1751      */
1752     /* We need to copy in following cases:
1753      * a) Assignment form was called.
1754      *          assignshift==1,  assign==T, method + 1 == off
1755      * b) Increment or decrement, called directly.
1756      *          assignshift==0,  assign==0, method + 0 == off
1757      * c) Increment or decrement, translated to assignment add/subtr.
1758      *          assignshift==0,  assign==T,
1759      *          force_cpy == T
1760      * d) Increment or decrement, translated to nomethod.
1761      *          assignshift==0,  assign==0,
1762      *          force_cpy == T
1763      * e) Assignment form translated to nomethod.
1764      *          assignshift==1,  assign==T, method + 1 != off
1765      *          force_cpy == T
1766      */
1767     /*  off is method, method+assignshift, or a result of opcode substitution.
1768      *  In the latter case assignshift==0, so only notfound case is important.
1769      */
1770   if (( (method + assignshift == off)
1771         && (assign || (method == inc_amg) || (method == dec_amg)))
1772       || force_cpy)
1773     RvDEEPCP(left);
1774   {
1775     dSP;
1776     BINOP myop;
1777     SV* res;
1778     const bool oldcatch = CATCH_GET;
1779
1780     CATCH_SET(TRUE);
1781     Zero(&myop, 1, BINOP);
1782     myop.op_last = (OP *) &myop;
1783     myop.op_next = Nullop;
1784     myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
1785
1786     PUSHSTACKi(PERLSI_OVERLOAD);
1787     ENTER;
1788     SAVEOP();
1789     PL_op = (OP *) &myop;
1790     if (PERLDB_SUB && PL_curstash != PL_debstash)
1791         PL_op->op_private |= OPpENTERSUB_DB;
1792     PUTBACK;
1793     pp_pushmark();
1794
1795     EXTEND(SP, notfound + 5);
1796     PUSHs(lr>0? right: left);
1797     PUSHs(lr>0? left: right);
1798     PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no ));
1799     if (notfound) {
1800       PUSHs( sv_2mortal(newSVpv(AMG_id2name(method + assignshift),0)));
1801     }
1802     PUSHs((SV*)cv);
1803     PUTBACK;
1804
1805     if ((PL_op = Perl_pp_entersub(aTHX)))
1806       CALLRUNOPS(aTHX);
1807     LEAVE;
1808     SPAGAIN;
1809
1810     res=POPs;
1811     PUTBACK;
1812     POPSTACK;
1813     CATCH_SET(oldcatch);
1814
1815     if (postpr) {
1816       int ans;
1817       switch (method) {
1818       case le_amg:
1819       case sle_amg:
1820         ans=SvIV(res)<=0; break;
1821       case lt_amg:
1822       case slt_amg:
1823         ans=SvIV(res)<0; break;
1824       case ge_amg:
1825       case sge_amg:
1826         ans=SvIV(res)>=0; break;
1827       case gt_amg:
1828       case sgt_amg:
1829         ans=SvIV(res)>0; break;
1830       case eq_amg:
1831       case seq_amg:
1832         ans=SvIV(res)==0; break;
1833       case ne_amg:
1834       case sne_amg:
1835         ans=SvIV(res)!=0; break;
1836       case inc_amg:
1837       case dec_amg:
1838         SvSetSV(left,res); return left;
1839       case not_amg:
1840         ans=!SvTRUE(res); break;
1841       default:
1842         ans=0; break;
1843       }
1844       return boolSV(ans);
1845     } else if (method==copy_amg) {
1846       if (!SvROK(res)) {
1847         Perl_croak(aTHX_ "Copy method did not return a reference");
1848       }
1849       return SvREFCNT_inc(SvRV(res));
1850     } else {
1851       return res;
1852     }
1853   }
1854 }
1855
1856 /*
1857 =for apidoc is_gv_magical_sv
1858
1859 Returns C<TRUE> if given the name of a magical GV. Calls is_gv_magical.
1860
1861 =cut
1862 */
1863
1864 bool
1865 Perl_is_gv_magical_sv(pTHX_ SV *name, U32 flags)
1866 {
1867     STRLEN len;
1868     const char *temp = SvPV_const(name, len);
1869     return is_gv_magical(temp, len, flags);
1870 }
1871
1872 /*
1873 =for apidoc is_gv_magical
1874
1875 Returns C<TRUE> if given the name of a magical GV.
1876
1877 Currently only useful internally when determining if a GV should be
1878 created even in rvalue contexts.
1879
1880 C<flags> is not used at present but available for future extension to
1881 allow selecting particular classes of magical variable.
1882
1883 Currently assumes that C<name> is NUL terminated (as well as len being valid).
1884 This assumption is met by all callers within the perl core, which all pass
1885 pointers returned by SvPV.
1886
1887 =cut
1888 */
1889 bool
1890 Perl_is_gv_magical(pTHX_ const char *name, STRLEN len, U32 flags)
1891 {
1892     (void)flags;
1893     if (len > 1) {
1894         const char * const name1 = name + 1;
1895         switch (*name) {
1896         case 'I':
1897             if (len == 3 && name1[1] == 'S' && name[2] == 'A')
1898                 goto yes;
1899             break;
1900         case 'O':
1901             if (len == 8 && strEQ(name1, "VERLOAD"))
1902                 goto yes;
1903             break;
1904         case 'S':
1905             if (len == 3 && name[1] == 'I' && name[2] == 'G')
1906                 goto yes;
1907             break;
1908             /* Using ${^...} variables is likely to be sufficiently rare that
1909                it seems sensible to avoid the space hit of also checking the
1910                length.  */
1911         case '\017':   /* ${^OPEN} */
1912             if (strEQ(name1, "PEN"))
1913                 goto yes;
1914             break;
1915         case '\024':   /* ${^TAINT} */
1916             if (strEQ(name1, "AINT"))
1917                 goto yes;
1918             break;
1919         case '\025':    /* ${^UNICODE} */
1920             if (strEQ(name1, "NICODE"))
1921                 goto yes;
1922             if (strEQ(name1, "TF8LOCALE"))
1923                 goto yes;
1924             break;
1925         case '\027':   /* ${^WARNING_BITS} */
1926             if (strEQ(name1, "ARNING_BITS"))
1927                 goto yes;
1928             break;
1929         case '1':
1930         case '2':
1931         case '3':
1932         case '4':
1933         case '5':
1934         case '6':
1935         case '7':
1936         case '8':
1937         case '9':
1938         {
1939             const char *end = name + len;
1940             while (--end > name) {
1941                 if (!isDIGIT(*end))
1942                     return FALSE;
1943             }
1944             goto yes;
1945         }
1946         }
1947     } else {
1948         /* Because we're already assuming that name is NUL terminated
1949            below, we can treat an empty name as "\0"  */
1950         switch (*name) {
1951         case '&':
1952         case '`':
1953         case '\'':
1954         case ':':
1955         case '?':
1956         case '!':
1957         case '-':
1958         case '#':
1959         case '[':
1960         case '^':
1961         case '~':
1962         case '=':
1963         case '%':
1964         case '.':
1965         case '(':
1966         case ')':
1967         case '<':
1968         case '>':
1969         case ',':
1970         case '\\':
1971         case '/':
1972         case '|':
1973         case '+':
1974         case ';':
1975         case ']':
1976         case '\001':   /* $^A */
1977         case '\003':   /* $^C */
1978         case '\004':   /* $^D */
1979         case '\005':   /* $^E */
1980         case '\006':   /* $^F */
1981         case '\010':   /* $^H */
1982         case '\011':   /* $^I, NOT \t in EBCDIC */
1983         case '\014':   /* $^L */
1984         case '\016':   /* $^N */
1985         case '\017':   /* $^O */
1986         case '\020':   /* $^P */
1987         case '\023':   /* $^S */
1988         case '\024':   /* $^T */
1989         case '\026':   /* $^V */
1990         case '\027':   /* $^W */
1991         case '1':
1992         case '2':
1993         case '3':
1994         case '4':
1995         case '5':
1996         case '6':
1997         case '7':
1998         case '8':
1999         case '9':
2000         yes:
2001             return TRUE;
2002         default:
2003             break;
2004         }
2005     }
2006     return FALSE;
2007 }
2008
2009 /*
2010  * Local variables:
2011  * c-indentation-style: bsd
2012  * c-basic-offset: 4
2013  * indent-tabs-mode: t
2014  * End:
2015  *
2016  * ex: set ts=8 sts=4 sw=4 noet:
2017  */