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