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