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