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) = NULL;
 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 = NULL;
 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[128];
 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_fetchpvn_flags(tmpbuf, namelen, 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 = NULL;
 740     GV**gvp;
 741     I32 len;
 742     register const char *namend;
 743     HV *stash = NULL;
 744     const I32 no_init = flags & (GV_NOADD_NOINIT | GV_NOINIT);
 745     const I32 no_expand = flags & GV_NOEXPAND;
 746     const I32 add = flags & ~SVf_UTF8 & ~GV_NOADD_NOINIT & ~GV_NOEXPAND;
 747
 748     PERL_UNUSED_ARG(full_len);
 749
 750     if (*name == '*' && isALPHA(name[1])) /* accidental stringify on a GV? */
 751         name++;
 752
 753     for (namend = name; *namend; namend++) {
 754         if ((*namend == ':' && namend[1] == ':')
 755             || (*namend == '\'' && namend[1]))
 756         {
 757             if (!stash)
 758                 stash = PL_defstash;
 759             if (!stash || !SvREFCNT(stash)) /* symbol table under destruction */
 760                 return Nullgv;
 761
 762             len = namend - name;
 763             if (len > 0) {
 764                 char smallbuf[128];
 765                 char *tmpbuf;
 766
 767                 if (len + 3 < sizeof (smallbuf))
 768                     tmpbuf = smallbuf;
 769                 else
 770                     Newx(tmpbuf, len+3, char);
 771                 Copy(name, tmpbuf, len, char);
 772                 tmpbuf[len++] = ':';
 773                 tmpbuf[len++] = ':';
 774                 tmpbuf[len] = '\0';
 775                 gvp = (GV**)hv_fetch(stash,tmpbuf,len,add);
 776                 gv = gvp ? *gvp : Nullgv;
 777                 if (gv && gv != (GV*)&PL_sv_undef) {
 778                     if (SvTYPE(gv) != SVt_PVGV)
 779                         gv_init(gv, stash, tmpbuf, len, (add & GV_ADDMULTI));
 780                     else
 781                         GvMULTI_on(gv);
 782                 }
 783                 if (tmpbuf != smallbuf)
 784                     Safefree(tmpbuf);
 785                 if (!gv || gv == (GV*)&PL_sv_undef)
 786                     return Nullgv;
 787
 788                 if (!(stash = GvHV(gv)))
 789                     stash = GvHV(gv) = newHV();
 790
 791                 if (!HvNAME_get(stash))
 792                     hv_name_set(stash, nambeg, namend - nambeg, 0);
 793             }
 794
 795             if (*namend == ':')
 796                 namend++;
 797             namend++;
 798             name = namend;
 799             if (!*name)
 800                 return gv ? gv : (GV*)*hv_fetch(PL_defstash, "main::", 6, TRUE);
 801         }
 802     }
 803     len = namend - name;
 804
 805     /* No stash in name, so see how we can default */
 806
 807     if (!stash) {
 808         if (isIDFIRST_lazy(name)) {
 809             bool global = FALSE;
 810
 811             /* name is always \0 terminated, and initial \0 wouldn't return
 812                true from isIDFIRST_lazy, so we know that name[1] is defined  */
 813             switch (name[1]) {
 814             case '\0':
 815                 if (*name == '_')
 816                     global = TRUE;
 817                 break;
 818             case 'N':
 819                 if (strEQ(name, "INC") || strEQ(name, "ENV"))
 820                     global = TRUE;
 821                 break;
 822             case 'I':
 823                 if (strEQ(name, "SIG"))
 824                     global = TRUE;
 825                 break;
 826             case 'T':
 827                 if (strEQ(name, "STDIN") || strEQ(name, "STDOUT") ||
 828                     strEQ(name, "STDERR"))
 829                     global = TRUE;
 830                 break;
 831             case 'R':
 832                 if (strEQ(name, "ARGV") || strEQ(name, "ARGVOUT"))
 833                     global = TRUE;
 834                 break;
 835             }
 836
 837             if (global)
 838                 stash = PL_defstash;
 839             else if (IN_PERL_COMPILETIME) {
 840                 stash = PL_curstash;
 841                 if (add && (PL_hints & HINT_STRICT_VARS) &&
 842                     sv_type != SVt_PVCV &&
 843                     sv_type != SVt_PVGV &&
 844                     sv_type != SVt_PVFM &&
 845                     sv_type != SVt_PVIO &&
 846                     !(len == 1 && sv_type == SVt_PV &&
 847                       (*name == 'a' || *name == 'b')) )
 848                 {
 849                     gvp = (GV**)hv_fetch(stash,name,len,0);
 850                     if (!gvp ||
 851                         *gvp == (GV*)&PL_sv_undef ||
 852                         SvTYPE(*gvp) != SVt_PVGV)
 853                     {
 854                         stash = 0;
 855                     }
 856                     else if ((sv_type == SVt_PV   && !GvIMPORTED_SV(*gvp)) ||
 857                              (sv_type == SVt_PVAV && !GvIMPORTED_AV(*gvp)) ||
 858                              (sv_type == SVt_PVHV && !GvIMPORTED_HV(*gvp)) )
 859                     {
 860                         Perl_warn(aTHX_ "Variable \"%c%s\" is not imported",
 861                             sv_type == SVt_PVAV ? '@' :
 862                             sv_type == SVt_PVHV ? '%' : '$',
 863                             name);
 864                         if (GvCVu(*gvp))
 865                             Perl_warn(aTHX_ "\t(Did you mean &%s instead?)\n", name);
 866                         stash = 0;
 867                     }
 868                 }
 869             }
 870             else
 871                 stash = CopSTASH(PL_curcop);
 872         }
 873         else
 874             stash = PL_defstash;
 875     }
 876
 877     /* By this point we should have a stash and a name */
 878
 879     if (!stash) {
 880         if (add) {
 881             SV * const err = Perl_mess(aTHX_
 882                  "Global symbol \"%s%s\" requires explicit package name",
 883                  (sv_type == SVt_PV ? "$"
 884                   : sv_type == SVt_PVAV ? "@"
 885                   : sv_type == SVt_PVHV ? "%"
 886                   : ""), name);
 887             if (USE_UTF8_IN_NAMES)
 888                 SvUTF8_on(err);
 889             qerror(err);
 890             stash = GvHV(gv_fetchpvn_flags("<none>::", 8, GV_ADDMULTI, SVt_PVHV));
 891         }
 892         else
 893             return Nullgv;
 894     }
 895
 896     if (!SvREFCNT(stash))       /* symbol table under destruction */
 897         return Nullgv;
 898
 899     gvp = (GV**)hv_fetch(stash,name,len,add);
 900     if (!gvp || *gvp == (GV*)&PL_sv_undef)
 901         return Nullgv;
 902     gv = *gvp;
 903     if (SvTYPE(gv) == SVt_PVGV) {
 904         if (add) {
 905             GvMULTI_on(gv);
 906             gv_init_sv(gv, sv_type);
 907             if (*name=='!' && sv_type == SVt_PVHV && len==1)
 908                 require_errno(gv);
 909         }
 910         return gv;
 911     } else if (no_init) {
 912         return gv;
 913     } else if (no_expand && SvROK(gv)) {
 914         return gv;
 915     }
 916
 917     /* Adding a new symbol */
 918
 919     if (add & GV_ADDWARN && ckWARN_d(WARN_INTERNAL))
 920         Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "Had to create %s unexpectedly", nambeg);
 921     gv_init(gv, stash, name, len, add & GV_ADDMULTI);
 922     gv_init_sv(gv, sv_type);
 923
 924     if (isALPHA(name[0]) && ! (isLEXWARN_on ? ckWARN(WARN_ONCE)
 925                                             : (PL_dowarn & G_WARN_ON ) ) )
 926         GvMULTI_on(gv) ;
 927
 928     /* set up magic where warranted */
 929     if (len > 1) {
 930 #ifndef EBCDIC
 931         if (*name > 'V' ) {
 932             /* Nothing else to do.
 933                The compiler will probably turn the switch statement into a
 934                branch table. Make sure we avoid even that small overhead for
 935                the common case of lower case variable names.  */
 936         } else
 937 #endif
 938         {
 939             const char * const name2 = name + 1;
 940             switch (*name) {
 941             case 'A':
 942                 if (strEQ(name2, "RGV")) {
 943                     IoFLAGS(GvIOn(gv)) |= IOf_ARGV|IOf_START;
 944                 }
 945                 break;
 946             case 'E':
 947                 if (strnEQ(name2, "XPORT", 5))
 948                     GvMULTI_on(gv);
 949                 break;
 950             case 'I':
 951                 if (strEQ(name2, "SA")) {
 952                     AV* const av = GvAVn(gv);
 953                     GvMULTI_on(gv);
 954                     sv_magic((SV*)av, (SV*)gv, PERL_MAGIC_isa, Nullch, 0);
 955                     /* NOTE: No support for tied ISA */
 956                     if ((add & GV_ADDMULTI) && strEQ(nambeg,"AnyDBM_File::ISA")
 957                         && AvFILLp(av) == -1)
 958                         {
 959                             const char *pname;
 960                             av_push(av, newSVpvn(pname = "NDBM_File",9));
 961                             gv_stashpvn(pname, 9, TRUE);
 962                             av_push(av, newSVpvn(pname = "DB_File",7));
 963                             gv_stashpvn(pname, 7, TRUE);
 964                             av_push(av, newSVpvn(pname = "GDBM_File",9));
 965                             gv_stashpvn(pname, 9, TRUE);
 966                             av_push(av, newSVpvn(pname = "SDBM_File",9));
 967                             gv_stashpvn(pname, 9, TRUE);
 968                             av_push(av, newSVpvn(pname = "ODBM_File",9));
 969                             gv_stashpvn(pname, 9, TRUE);
 970                         }
 971                 }
 972                 break;
 973             case 'O':
 974                 if (strEQ(name2, "VERLOAD")) {
 975                     HV* const hv = GvHVn(gv);
 976                     GvMULTI_on(gv);
 977                     hv_magic(hv, Nullgv, PERL_MAGIC_overload);
 978                 }
 979                 break;
 980             case 'S':
 981                 if (strEQ(name2, "IG")) {
 982                     HV *hv;
 983                     I32 i;
 984                     if (!PL_psig_ptr) {
 985                         Newxz(PL_psig_ptr,  SIG_SIZE, SV*);
 986                         Newxz(PL_psig_name, SIG_SIZE, SV*);
 987                         Newxz(PL_psig_pend, SIG_SIZE, int);
 988                     }
 989                     GvMULTI_on(gv);
 990                     hv = GvHVn(gv);
 991                     hv_magic(hv, Nullgv, PERL_MAGIC_sig);
 992                     for (i = 1; i < SIG_SIZE; i++) {
 993                         SV * const * const init = hv_fetch(hv, PL_sig_name[i], strlen(PL_sig_name[i]), 1);
 994                         if (init)
 995                             sv_setsv(*init, &PL_sv_undef);
 996                         PL_psig_ptr[i] = 0;
 997                         PL_psig_name[i] = 0;
 998                         PL_psig_pend[i] = 0;
 999                     }
1000                 }
1001                 break;
1002             case 'V':
1003                 if (strEQ(name2, "ERSION"))
1004                     GvMULTI_on(gv);
1005                 break;
1006             case '\003':        /* $^CHILD_ERROR_NATIVE */
1007                 if (strEQ(name2, "HILD_ERROR_NATIVE"))
1008                     goto magicalize;
1009                 break;
1010             case '\005':        /* $^ENCODING */
1011                 if (strEQ(name2, "NCODING"))
1012                     goto magicalize;
1013                 break;
1014             case '\017':        /* $^OPEN */
1015                 if (strEQ(name2, "PEN"))
1016                     goto magicalize;
1017                 break;
1018             case '\024':        /* ${^TAINT} */
1019                 if (strEQ(name2, "AINT"))
1020                     goto ro_magicalize;
1021                 break;
1022             case '\025':        /* ${^UNICODE}, ${^UTF8LOCALE} */
1023                 if (strEQ(name2, "NICODE"))
1024                     goto ro_magicalize;
1025                 if (strEQ(name2, "TF8LOCALE"))
1026                     goto ro_magicalize;
1027                 break;
1028             case '\027':        /* $^WARNING_BITS */
1029                 if (strEQ(name2, "ARNING_BITS"))
1030                     goto magicalize;
1031                 break;
1032             case '1':
1033             case '2':
1034             case '3':
1035             case '4':
1036             case '5':
1037             case '6':
1038             case '7':
1039             case '8':
1040             case '9':
1041             {
1042                 /* ensures variable is only digits */
1043                 /* ${"1foo"} fails this test (and is thus writeable) */
1044                 /* added by japhy, but borrowed from is_gv_magical */
1045                 const char *end = name + len;
1046                 while (--end > name) {
1047                     if (!isDIGIT(*end)) return gv;
1048                 }
1049                 goto ro_magicalize;
1050             }
1051             }
1052         }
1053     } else {
1054         /* Names of length 1.  (Or 0. But name is NUL terminated, so that will
1055            be case '\0' in this switch statement (ie a default case)  */
1056         switch (*name) {
1057         case '&':
1058         case '`':
1059         case '\'':
1060             if (
1061                 sv_type == SVt_PVAV ||
1062                 sv_type == SVt_PVHV ||
1063                 sv_type == SVt_PVCV ||
1064                 sv_type == SVt_PVFM ||
1065                 sv_type == SVt_PVIO
1066                 ) { break; }
1067             PL_sawampersand = TRUE;
1068             goto ro_magicalize;
1069
1070         case ':':
1071             sv_setpv(GvSVn(gv),PL_chopset);
1072             goto magicalize;
1073
1074         case '?':
1075 #ifdef COMPLEX_STATUS
1076             SvUPGRADE(GvSVn(gv), SVt_PVLV);
1077 #endif
1078             goto magicalize;
1079
1080         case '!':
1081
1082             /* If %! has been used, automatically load Errno.pm.
1083                The require will itself set errno, so in order to
1084                preserve its value we have to set up the magic
1085                now (rather than going to magicalize)
1086             */
1087
1088             sv_magic(GvSVn(gv), (SV*)gv, PERL_MAGIC_sv, name, len);
1089
1090             if (sv_type == SVt_PVHV)
1091                 require_errno(gv);
1092
1093             break;
1094         case '-':
1095         {
1096             AV* const av = GvAVn(gv);
1097             sv_magic((SV*)av, Nullsv, PERL_MAGIC_regdata, Nullch, 0);
1098             SvREADONLY_on(av);
1099             goto magicalize;
1100         }
1101         case '*':
1102         case '#':
1103             if (sv_type == SVt_PV && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
1104                 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
1105                             "$%c is no longer supported", *name);
1106             break;
1107         case '|':
1108             sv_setiv(GvSVn(gv), (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0);
1109             goto magicalize;
1110
1111         case '+':
1112         {
1113             AV* const av = GvAVn(gv);
1114             sv_magic((SV*)av, (SV*)av, PERL_MAGIC_regdata, Nullch, 0);
1115             SvREADONLY_on(av);
1116             /* FALL THROUGH */
1117         }
1118         case '\023':    /* $^S */
1119         case '1':
1120         case '2':
1121         case '3':
1122         case '4':
1123         case '5':
1124         case '6':
1125         case '7':
1126         case '8':
1127         case '9':
1128         ro_magicalize:
1129             SvREADONLY_on(GvSVn(gv));
1130             /* FALL THROUGH */
1131         case '[':
1132         case '^':
1133         case '~':
1134         case '=':
1135         case '%':
1136         case '.':
1137         case '(':
1138         case ')':
1139         case '<':
1140         case '>':
1141         case ',':
1142         case '\\':
1143         case '/':
1144         case '\001':    /* $^A */
1145         case '\003':    /* $^C */
1146         case '\004':    /* $^D */
1147         case '\005':    /* $^E */
1148         case '\006':    /* $^F */
1149         case '\010':    /* $^H */
1150         case '\011':    /* $^I, NOT \t in EBCDIC */
1151         case '\016':    /* $^N */
1152         case '\017':    /* $^O */
1153         case '\020':    /* $^P */
1154         case '\024':    /* $^T */
1155         case '\027':    /* $^W */
1156         magicalize:
1157             sv_magic(GvSVn(gv), (SV*)gv, PERL_MAGIC_sv, name, len);
1158             break;
1159
1160         case '\014':    /* $^L */
1161             sv_setpvn(GvSVn(gv),"\f",1);
1162             PL_formfeed = GvSVn(gv);
1163             break;
1164         case ';':
1165             sv_setpvn(GvSVn(gv),"\034",1);
1166             break;
1167         case ']':
1168         {
1169             SV * const sv = GvSVn(gv);
1170             if (!sv_derived_from(PL_patchlevel, "version"))
1171                 upg_version(PL_patchlevel);
1172             GvSV(gv) = vnumify(PL_patchlevel);
1173             SvREADONLY_on(GvSV(gv));
1174             SvREFCNT_dec(sv);
1175         }
1176         break;
1177         case '\026':    /* $^V */
1178         {
1179             SV * const sv = GvSVn(gv);
1180             GvSV(gv) = new_version(PL_patchlevel);
1181             SvREADONLY_on(GvSV(gv));
1182             SvREFCNT_dec(sv);
1183         }
1184         break;
1185         }
1186     }
1187     return gv;
1188 }
1189
1190 void
1191 Perl_gv_fullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
1192 {
1193     const char *name;
1194     STRLEN namelen;
1195     const HV * const hv = GvSTASH(gv);
1196     if (!hv) {
1197         SvOK_off(sv);
1198         return;
1199     }
1200     sv_setpv(sv, prefix ? prefix : "");
1201
1202     name = HvNAME_get(hv);
1203     if (name) {
1204         namelen = HvNAMELEN_get(hv);
1205     } else {
1206         name = "__ANON__";
1207         namelen = 8;
1208     }
1209
1210     if (keepmain || strNE(name, "main")) {
1211         sv_catpvn(sv,name,namelen);
1212         sv_catpvn(sv,"::", 2);
1213     }
1214     sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv));
1215 }
1216
1217 void
1218 Perl_gv_efullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
1219 {
1220     const GV * const egv = GvEGV(gv);
1221     gv_fullname4(sv, egv ? egv : gv, prefix, keepmain);
1222 }
1223
1224 IO *
1225 Perl_newIO(pTHX)
1226 {
1227     GV *iogv;
1228     IO * const io = (IO*)NEWSV(0,0);
1229
1230     sv_upgrade((SV *)io,SVt_PVIO);
1231     /* This used to read SvREFCNT(io) = 1;
1232        It's not clear why the reference count needed an explicit reset. NWC
1233     */
1234     assert (SvREFCNT(io) == 1);
1235     SvOBJECT_on(io);
1236     /* Clear the stashcache because a new IO could overrule a package name */
1237     hv_clear(PL_stashcache);
1238     iogv = gv_fetchpvn_flags("FileHandle::", 12, 0, SVt_PVHV);
1239     /* unless exists($main::{FileHandle}) and defined(%main::FileHandle::) */
1240     if (!(iogv && GvHV(iogv) && HvARRAY(GvHV(iogv))))
1241       iogv = gv_fetchpvn_flags("IO::Handle::", 12, TRUE, SVt_PVHV);
1242     SvSTASH_set(io, (HV*)SvREFCNT_inc(GvHV(iogv)));
1243     return io;
1244 }
1245
1246 void
1247 Perl_gv_check(pTHX_ HV *stash)
1248 {
1249     register I32 i;
1250
1251     if (!HvARRAY(stash))
1252         return;
1253     for (i = 0; i <= (I32) HvMAX(stash); i++) {
1254         const HE *entry;
1255         for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
1256             register GV *gv;
1257             HV *hv;
1258             if (HeKEY(entry)[HeKLEN(entry)-1] == ':' &&
1259                 (gv = (GV*)HeVAL(entry)) && isGV(gv) && (hv = GvHV(gv)))
1260             {
1261                 if (hv != PL_defstash && hv != stash)
1262                      gv_check(hv);              /* nested package */
1263             }
1264             else if (isALPHA(*HeKEY(entry))) {
1265                 const char *file;
1266                 gv = (GV*)HeVAL(entry);
1267                 if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv))
1268                     continue;
1269                 file = GvFILE(gv);
1270                 /* performance hack: if filename is absolute and it's a standard
1271                  * module, don't bother warning */
1272 #ifdef MACOS_TRADITIONAL
1273 #   define LIB_COMPONENT ":lib:"
1274 #else
1275 #   define LIB_COMPONENT "/lib/"
1276 #endif
1277                 if (file
1278                     && PERL_FILE_IS_ABSOLUTE(file)
1279                     && (instr(file, LIB_COMPONENT) || instr(file, ".pm")))
1280                 {
1281                     continue;
1282                 }
1283                 CopLINE_set(PL_curcop, GvLINE(gv));
1284 #ifdef USE_ITHREADS
1285                 CopFILE(PL_curcop) = (char *)file;      /* set for warning */
1286 #else
1287                 CopFILEGV(PL_curcop) = gv_fetchfile(file);
1288 #endif
1289                 Perl_warner(aTHX_ packWARN(WARN_ONCE),
1290                         "Name \"%s::%s\" used only once: possible typo",
1291                         HvNAME_get(stash), GvNAME(gv));
1292             }
1293         }
1294     }
1295 }
1296
1297 GV *
1298 Perl_newGVgen(pTHX_ const char *pack)
1299 {
1300     return gv_fetchpv(Perl_form(aTHX_ "%s::_GEN_%ld", pack, (long)PL_gensym++),
1301                       TRUE, SVt_PVGV);
1302 }
1303
1304 /* hopefully this is only called on local symbol table entries */
1305
1306 GP*
1307 Perl_gp_ref(pTHX_ GP *gp)
1308 {
1309     if (!gp)
1310         return (GP*)NULL;
1311     gp->gp_refcnt++;
1312     if (gp->gp_cv) {
1313         if (gp->gp_cvgen) {
1314             /* multi-named GPs cannot be used for method cache */
1315             SvREFCNT_dec(gp->gp_cv);
1316             gp->gp_cv = Nullcv;
1317             gp->gp_cvgen = 0;
1318         }
1319         else {
1320             /* Adding a new name to a subroutine invalidates method cache */
1321             PL_sub_generation++;
1322         }
1323     }
1324     return gp;
1325 }
1326
1327 void
1328 Perl_gp_free(pTHX_ GV *gv)
1329 {
1330     GP* gp;
1331
1332     if (!gv || !(gp = GvGP(gv)))
1333         return;
1334     if (gp->gp_refcnt == 0) {
1335         if (ckWARN_d(WARN_INTERNAL))
1336             Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
1337                         "Attempt to free unreferenced glob pointers"
1338                         pTHX__FORMAT pTHX__VALUE);
1339         return;
1340     }
1341     if (gp->gp_cv) {
1342         /* Deleting the name of a subroutine invalidates method cache */
1343         PL_sub_generation++;
1344     }
1345     if (--gp->gp_refcnt > 0) {
1346         if (gp->gp_egv == gv)
1347             gp->gp_egv = 0;
1348         return;
1349     }
1350
1351     if (gp->gp_sv) SvREFCNT_dec(gp->gp_sv);
1352     if (gp->gp_av) SvREFCNT_dec(gp->gp_av);
1353     /* FIXME - another reference loop GV -> symtab -> GV ?
1354        Somehow gp->gp_hv can end up pointing at freed garbage.  */
1355     if (gp->gp_hv && SvTYPE(gp->gp_hv) == SVt_PVHV) {
1356         const char *hvname = HvNAME_get(gp->gp_hv);
1357         if (PL_stashcache && hvname)
1358             hv_delete(PL_stashcache, hvname, HvNAMELEN_get(gp->gp_hv),
1359                       G_DISCARD);
1360         SvREFCNT_dec(gp->gp_hv);
1361     }
1362     if (gp->gp_io)   SvREFCNT_dec(gp->gp_io);
1363     if (gp->gp_cv)   SvREFCNT_dec(gp->gp_cv);
1364     if (gp->gp_form) SvREFCNT_dec(gp->gp_form);
1365
1366     Safefree(gp);
1367     GvGP(gv) = 0;
1368 }
1369
1370 int
1371 Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg)
1372 {
1373     AMT * const amtp = (AMT*)mg->mg_ptr;
1374     PERL_UNUSED_ARG(sv);
1375
1376     if (amtp && AMT_AMAGIC(amtp)) {
1377         int i;
1378         for (i = 1; i < NofAMmeth; i++) {
1379             CV * const cv = amtp->table[i];
1380             if (cv != Nullcv) {
1381                 SvREFCNT_dec((SV *) cv);
1382                 amtp->table[i] = Nullcv;
1383             }
1384         }
1385     }
1386  return 0;
1387 }
1388
1389 /* Updates and caches the CV's */
1390
1391 bool
1392 Perl_Gv_AMupdate(pTHX_ HV *stash)
1393 {
1394   MAGIC* const mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
1395   AMT * const amtp = (mg) ? (AMT*)mg->mg_ptr: (AMT *) NULL;
1396   AMT amt;
1397
1398   if (mg && amtp->was_ok_am == PL_amagic_generation
1399       && amtp->was_ok_sub == PL_sub_generation)
1400       return (bool)AMT_OVERLOADED(amtp);
1401   sv_unmagic((SV*)stash, PERL_MAGIC_overload_table);
1402
1403   DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME_get(stash)) );
1404
1405   Zero(&amt,1,AMT);
1406   amt.was_ok_am = PL_amagic_generation;
1407   amt.was_ok_sub = PL_sub_generation;
1408   amt.fallback = AMGfallNO;
1409   amt.flags = 0;
1410
1411   {
1412     int filled = 0, have_ovl = 0;
1413     int i, lim = 1;
1414
1415     /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
1416
1417     /* Try to find via inheritance. */
1418     GV *gv = gv_fetchmeth(stash, PL_AMG_names[0], 2, -1);
1419     SV * const sv = gv ? GvSV(gv) : NULL;
1420     CV* cv;
1421
1422     if (!gv)
1423         lim = DESTROY_amg;              /* Skip overloading entries. */
1424 #ifdef PERL_DONT_CREATE_GVSV
1425     else if (!sv) {
1426         /* Equivalent to !SvTRUE and !SvOK  */
1427     }
1428 #endif
1429     else if (SvTRUE(sv))
1430         amt.fallback=AMGfallYES;
1431     else if (SvOK(sv))
1432         amt.fallback=AMGfallNEVER;
1433
1434     for (i = 1; i < lim; i++)
1435         amt.table[i] = Nullcv;
1436     for (; i < NofAMmeth; i++) {
1437         const char *cooky = PL_AMG_names[i];
1438         /* Human-readable form, for debugging: */
1439         const char *cp = (i >= DESTROY_amg ? cooky : AMG_id2name(i));
1440         const STRLEN l = strlen(cooky);
1441
1442         DEBUG_o( Perl_deb(aTHX_ "Checking overloading of \"%s\" in package \"%.256s\"\n",
1443                      cp, HvNAME_get(stash)) );
1444         /* don't fill the cache while looking up!
1445            Creation of inheritance stubs in intermediate packages may
1446            conflict with the logic of runtime method substitution.
1447            Indeed, for inheritance A -> B -> C, if C overloads "+0",
1448            then we could have created stubs for "(+0" in A and C too.
1449            But if B overloads "bool", we may want to use it for
1450            numifying instead of C's "+0". */
1451         if (i >= DESTROY_amg)
1452             gv = Perl_gv_fetchmeth_autoload(aTHX_ stash, cooky, l, 0);
1453         else                            /* Autoload taken care of below */
1454             gv = Perl_gv_fetchmeth(aTHX_ stash, cooky, l, -1);
1455         cv = 0;
1456         if (gv && (cv = GvCV(gv))) {
1457             const char *hvname;
1458             if (GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")
1459                 && strEQ(hvname = HvNAME_get(GvSTASH(CvGV(cv))), "overload")) {
1460                 /* This is a hack to support autoloading..., while
1461                    knowing *which* methods were declared as overloaded. */
1462                 /* GvSV contains the name of the method. */
1463                 GV *ngv = Nullgv;
1464                 SV *gvsv = GvSV(gv);
1465
1466                 DEBUG_o( Perl_deb(aTHX_ "Resolving method \"%"SVf256\
1467                         "\" for overloaded \"%s\" in package \"%.256s\"\n",
1468                              GvSV(gv), cp, hvname) );
1469                 if (!gvsv || !SvPOK(gvsv)
1470                     || !(ngv = gv_fetchmethod_autoload(stash, SvPVX_const(gvsv),
1471                                                        FALSE)))
1472                 {
1473                     /* Can be an import stub (created by "can"). */
1474                     const char * const name = (gvsv && SvPOK(gvsv)) ?  SvPVX_const(gvsv) : "???";
1475                     Perl_croak(aTHX_ "%s method \"%.256s\" overloading \"%s\" "\
1476                                 "in package \"%.256s\"",
1477                                (GvCVGEN(gv) ? "Stub found while resolving"
1478                                 : "Can't resolve"),
1479                                name, cp, hvname);
1480                 }
1481                 cv = GvCV(gv = ngv);
1482             }
1483             DEBUG_o( Perl_deb(aTHX_ "Overloading \"%s\" in package \"%.256s\" via \"%.256s::%.256s\"\n",
1484                          cp, HvNAME_get(stash), HvNAME_get(GvSTASH(CvGV(cv))),
1485                          GvNAME(CvGV(cv))) );
1486             filled = 1;
1487             if (i < DESTROY_amg)
1488                 have_ovl = 1;
1489         } else if (gv) {                /* Autoloaded... */
1490             cv = (CV*)gv;
1491             filled = 1;
1492         }
1493         amt.table[i]=(CV*)SvREFCNT_inc(cv);
1494     }
1495     if (filled) {
1496       AMT_AMAGIC_on(&amt);
1497       if (have_ovl)
1498           AMT_OVERLOADED_on(&amt);
1499       sv_magic((SV*)stash, 0, PERL_MAGIC_overload_table,
1500                                                 (char*)&amt, sizeof(AMT));
1501       return have_ovl;
1502     }
1503   }
1504   /* Here we have no table: */
1505   /* no_table: */
1506   AMT_AMAGIC_off(&amt);
1507   sv_magic((SV*)stash, 0, PERL_MAGIC_overload_table,
1508                                                 (char*)&amt, sizeof(AMTS));
1509   return FALSE;
1510 }
1511
1512
1513 CV*
1514 Perl_gv_handler(pTHX_ HV *stash, I32 id)
1515 {
1516     MAGIC *mg;
1517     AMT *amtp;
1518
1519     if (!stash || !HvNAME_get(stash))
1520         return Nullcv;
1521     mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
1522     if (!mg) {
1523       do_update:
1524         Gv_AMupdate(stash);
1525         mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
1526     }
1527     amtp = (AMT*)mg->mg_ptr;
1528     if ( amtp->was_ok_am != PL_amagic_generation
1529          || amtp->was_ok_sub != PL_sub_generation )
1530         goto do_update;
1531     if (AMT_AMAGIC(amtp)) {
1532         CV * const ret = amtp->table[id];
1533         if (ret && isGV(ret)) {         /* Autoloading stab */
1534             /* Passing it through may have resulted in a warning
1535                "Inherited AUTOLOAD for a non-method deprecated", since
1536                our caller is going through a function call, not a method call.
1537                So return the CV for AUTOLOAD, setting $AUTOLOAD. */
1538             GV * const gv = gv_fetchmethod(stash, PL_AMG_names[id]);
1539
1540             if (gv && GvCV(gv))
1541                 return GvCV(gv);
1542         }
1543         return ret;
1544     }
1545
1546     return Nullcv;
1547 }
1548
1549
1550 SV*
1551 Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
1552 {
1553   dVAR;
1554   MAGIC *mg;
1555   CV *cv=NULL;
1556   CV **cvp=NULL, **ocvp=NULL;
1557   AMT *amtp=NULL, *oamtp=NULL;
1558   int off = 0, off1, lr = 0, notfound = 0;
1559   int postpr = 0, force_cpy = 0;
1560   int assign = AMGf_assign & flags;
1561   const int assignshift = assign ? 1 : 0;
1562 #ifdef DEBUGGING
1563   int fl=0;
1564 #endif
1565   HV* stash=NULL;
1566   if (!(AMGf_noleft & flags) && SvAMAGIC(left)
1567       && (stash = SvSTASH(SvRV(left)))
1568       && (mg = mg_find((SV*)stash, PERL_MAGIC_overload_table))
1569       && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
1570                         ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
1571                         : (CV **) NULL))
1572       && ((cv = cvp[off=method+assignshift])
1573           || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
1574                                                           * usual method */
1575                   (
1576 #ifdef DEBUGGING
1577                    fl = 1,
1578 #endif
1579                    cv = cvp[off=method])))) {
1580     lr = -1;                    /* Call method for left argument */
1581   } else {
1582     if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) {
1583       int logic;
1584
1585       /* look for substituted methods */
1586       /* In all the covered cases we should be called with assign==0. */
1587          switch (method) {
1588          case inc_amg:
1589            force_cpy = 1;
1590            if ((cv = cvp[off=add_ass_amg])
1591                || ((cv = cvp[off = add_amg]) && (force_cpy = 0, postpr = 1))) {
1592              right = &PL_sv_yes; lr = -1; assign = 1;
1593            }
1594            break;
1595          case dec_amg:
1596            force_cpy = 1;
1597            if ((cv = cvp[off = subtr_ass_amg])
1598                || ((cv = cvp[off = subtr_amg]) && (force_cpy = 0, postpr=1))) {
1599              right = &PL_sv_yes; lr = -1; assign = 1;
1600            }
1601            break;
1602          case bool__amg:
1603            (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg]));
1604            break;
1605          case numer_amg:
1606            (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg]));
1607            break;
1608          case string_amg:
1609            (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg]));
1610            break;
1611          case not_amg:
1612            (void)((cv = cvp[off=bool__amg])
1613                   || (cv = cvp[off=numer_amg])
1614                   || (cv = cvp[off=string_amg]));
1615            postpr = 1;
1616            break;
1617          case copy_amg:
1618            {
1619              /*
1620                   * SV* ref causes confusion with the interpreter variable of
1621                   * the same name
1622                   */
1623              SV* const tmpRef=SvRV(left);
1624              if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) {
1625                 /*
1626                  * Just to be extra cautious.  Maybe in some
1627                  * additional cases sv_setsv is safe, too.
1628                  */
1629                 SV* const newref = newSVsv(tmpRef);
1630                 SvOBJECT_on(newref);
1631                 SvSTASH_set(newref, (HV*)SvREFCNT_inc(SvSTASH(tmpRef)));
1632                 return newref;
1633              }
1634            }
1635            break;
1636          case abs_amg:
1637            if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg])
1638                && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) {
1639              SV* const nullsv=sv_2mortal(newSViv(0));
1640              if (off1==lt_amg) {
1641                SV* const lessp = amagic_call(left,nullsv,
1642                                        lt_amg,AMGf_noright);
1643                logic = SvTRUE(lessp);
1644              } else {
1645                SV* const lessp = amagic_call(left,nullsv,
1646                                        ncmp_amg,AMGf_noright);
1647                logic = (SvNV(lessp) < 0);
1648              }
1649              if (logic) {
1650                if (off==subtr_amg) {
1651                  right = left;
1652                  left = nullsv;
1653                  lr = 1;
1654                }
1655              } else {
1656                return left;
1657              }
1658            }
1659            break;
1660          case neg_amg:
1661            if ((cv = cvp[off=subtr_amg])) {
1662              right = left;
1663              left = sv_2mortal(newSViv(0));
1664              lr = 1;
1665            }
1666            break;
1667          case int_amg:
1668          case iter_amg:                 /* XXXX Eventually should do to_gv. */
1669              /* FAIL safe */
1670              return NULL;       /* Delegate operation to standard mechanisms. */
1671              break;
1672          case to_sv_amg:
1673          case to_av_amg:
1674          case to_hv_amg:
1675          case to_gv_amg:
1676          case to_cv_amg:
1677              /* FAIL safe */
1678              return left;       /* Delegate operation to standard mechanisms. */
1679              break;
1680          default:
1681            goto not_found;
1682          }
1683          if (!cv) goto not_found;
1684     } else if (!(AMGf_noright & flags) && SvAMAGIC(right)
1685                && (stash = SvSTASH(SvRV(right)))
1686                && (mg = mg_find((SV*)stash, PERL_MAGIC_overload_table))
1687                && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
1688                           ? (amtp = (AMT*)mg->mg_ptr)->table
1689                           : (CV **) NULL))
1690                && (cv = cvp[off=method])) { /* Method for right
1691                                              * argument found */
1692       lr=1;
1693     } else if (((ocvp && oamtp->fallback > AMGfallNEVER
1694                  && (cvp=ocvp) && (lr = -1))
1695                 || (cvp && amtp->fallback > AMGfallNEVER && (lr=1)))
1696                && !(flags & AMGf_unary)) {
1697                                 /* We look for substitution for
1698                                  * comparison operations and
1699                                  * concatenation */
1700       if (method==concat_amg || method==concat_ass_amg
1701           || method==repeat_amg || method==repeat_ass_amg) {
1702         return NULL;            /* Delegate operation to string conversion */
1703       }
1704       off = -1;
1705       switch (method) {
1706          case lt_amg:
1707          case le_amg:
1708          case gt_amg:
1709          case ge_amg:
1710          case eq_amg:
1711          case ne_amg:
1712            postpr = 1; off=ncmp_amg; break;
1713          case slt_amg:
1714          case sle_amg:
1715          case sgt_amg:
1716          case sge_amg:
1717          case seq_amg:
1718          case sne_amg:
1719            postpr = 1; off=scmp_amg; break;
1720          }
1721       if (off != -1) cv = cvp[off];
1722       if (!cv) {
1723         goto not_found;
1724       }
1725     } else {
1726     not_found:                  /* No method found, either report or croak */
1727       switch (method) {
1728          case to_sv_amg:
1729          case to_av_amg:
1730          case to_hv_amg:
1731          case to_gv_amg:
1732          case to_cv_amg:
1733              /* FAIL safe */
1734              return left;       /* Delegate operation to standard mechanisms. */
1735              break;
1736       }
1737       if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */
1738         notfound = 1; lr = -1;
1739       } else if (cvp && (cv=cvp[nomethod_amg])) {
1740         notfound = 1; lr = 1;
1741       } else {
1742         SV *msg;
1743         if (off==-1) off=method;
1744         msg = sv_2mortal(Perl_newSVpvf(aTHX_
1745                       "Operation \"%s\": no method found,%sargument %s%s%s%s",
1746                       AMG_id2name(method + assignshift),
1747                       (flags & AMGf_unary ? " " : "\n\tleft "),
1748                       SvAMAGIC(left)?
1749                         "in overloaded package ":
1750                         "has no overloaded magic",
1751                       SvAMAGIC(left)?
1752                         HvNAME_get(SvSTASH(SvRV(left))):
1753                         "",
1754                       SvAMAGIC(right)?
1755                         ",\n\tright argument in overloaded package ":
1756                         (flags & AMGf_unary
1757                          ? ""
1758                          : ",\n\tright argument has no overloaded magic"),
1759                       SvAMAGIC(right)?
1760                         HvNAME_get(SvSTASH(SvRV(right))):
1761                         ""));
1762         if (amtp && amtp->fallback >= AMGfallYES) {
1763           DEBUG_o( Perl_deb(aTHX_ "%s", SvPVX_const(msg)) );
1764         } else {
1765           Perl_croak(aTHX_ "%"SVf, msg);
1766         }
1767         return NULL;
1768       }
1769       force_cpy = force_cpy || assign;
1770     }
1771   }
1772 #ifdef DEBUGGING
1773   if (!notfound) {
1774     DEBUG_o(Perl_deb(aTHX_
1775                      "Overloaded operator \"%s\"%s%s%s:\n\tmethod%s found%s in package %s%s\n",
1776                      AMG_id2name(off),
1777                      method+assignshift==off? "" :
1778                      " (initially \"",
1779                      method+assignshift==off? "" :
1780                      AMG_id2name(method+assignshift),
1781                      method+assignshift==off? "" : "\")",
1782                      flags & AMGf_unary? "" :
1783                      lr==1 ? " for right argument": " for left argument",
1784                      flags & AMGf_unary? " for argument" : "",
1785                      stash ? HvNAME_get(stash) : "null",
1786                      fl? ",\n\tassignment variant used": "") );
1787   }
1788 #endif
1789     /* Since we use shallow copy during assignment, we need
1790      * to dublicate the contents, probably calling user-supplied
1791      * version of copy operator
1792      */
1793     /* We need to copy in following cases:
1794      * a) Assignment form was called.
1795      *          assignshift==1,  assign==T, method + 1 == off
1796      * b) Increment or decrement, called directly.
1797      *          assignshift==0,  assign==0, method + 0 == off
1798      * c) Increment or decrement, translated to assignment add/subtr.
1799      *          assignshift==0,  assign==T,
1800      *          force_cpy == T
1801      * d) Increment or decrement, translated to nomethod.
1802      *          assignshift==0,  assign==0,
1803      *          force_cpy == T
1804      * e) Assignment form translated to nomethod.
1805      *          assignshift==1,  assign==T, method + 1 != off
1806      *          force_cpy == T
1807      */
1808     /*  off is method, method+assignshift, or a result of opcode substitution.
1809      *  In the latter case assignshift==0, so only notfound case is important.
1810      */
1811   if (( (method + assignshift == off)
1812         && (assign || (method == inc_amg) || (method == dec_amg)))
1813       || force_cpy)
1814     RvDEEPCP(left);
1815   {
1816     dSP;
1817     BINOP myop;
1818     SV* res;
1819     const bool oldcatch = CATCH_GET;
1820
1821     CATCH_SET(TRUE);
1822     Zero(&myop, 1, BINOP);
1823     myop.op_last = (OP *) &myop;
1824     myop.op_next = Nullop;
1825     myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
1826
1827     PUSHSTACKi(PERLSI_OVERLOAD);
1828     ENTER;
1829     SAVEOP();
1830     PL_op = (OP *) &myop;
1831     if (PERLDB_SUB && PL_curstash != PL_debstash)
1832         PL_op->op_private |= OPpENTERSUB_DB;
1833     PUTBACK;
1834     pp_pushmark();
1835
1836     EXTEND(SP, notfound + 5);
1837     PUSHs(lr>0? right: left);
1838     PUSHs(lr>0? left: right);
1839     PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no ));
1840     if (notfound) {
1841       PUSHs( sv_2mortal(newSVpv(AMG_id2name(method + assignshift),0)));
1842     }
1843     PUSHs((SV*)cv);
1844     PUTBACK;
1845
1846     if ((PL_op = Perl_pp_entersub(aTHX)))
1847       CALLRUNOPS(aTHX);
1848     LEAVE;
1849     SPAGAIN;
1850
1851     res=POPs;
1852     PUTBACK;
1853     POPSTACK;
1854     CATCH_SET(oldcatch);
1855
1856     if (postpr) {
1857       int ans;
1858       switch (method) {
1859       case le_amg:
1860       case sle_amg:
1861         ans=SvIV(res)<=0; break;
1862       case lt_amg:
1863       case slt_amg:
1864         ans=SvIV(res)<0; break;
1865       case ge_amg:
1866       case sge_amg:
1867         ans=SvIV(res)>=0; break;
1868       case gt_amg:
1869       case sgt_amg:
1870         ans=SvIV(res)>0; break;
1871       case eq_amg:
1872       case seq_amg:
1873         ans=SvIV(res)==0; break;
1874       case ne_amg:
1875       case sne_amg:
1876         ans=SvIV(res)!=0; break;
1877       case inc_amg:
1878       case dec_amg:
1879         SvSetSV(left,res); return left;
1880       case not_amg:
1881         ans=!SvTRUE(res); break;
1882       default:
1883         ans=0; break;
1884       }
1885       return boolSV(ans);
1886     } else if (method==copy_amg) {
1887       if (!SvROK(res)) {
1888         Perl_croak(aTHX_ "Copy method did not return a reference");
1889       }
1890       return SvREFCNT_inc(SvRV(res));
1891     } else {
1892       return res;
1893     }
1894   }
1895 }
1896
1897 /*
1898 =for apidoc is_gv_magical_sv
1899
1900 Returns C<TRUE> if given the name of a magical GV. Calls is_gv_magical.
1901
1902 =cut
1903 */
1904
1905 bool
1906 Perl_is_gv_magical_sv(pTHX_ SV *name, U32 flags)
1907 {
1908     STRLEN len;
1909     const char * const temp = SvPV_const(name, len);
1910     return is_gv_magical(temp, len, flags);
1911 }
1912
1913 /*
1914 =for apidoc is_gv_magical
1915
1916 Returns C<TRUE> if given the name of a magical GV.
1917
1918 Currently only useful internally when determining if a GV should be
1919 created even in rvalue contexts.
1920
1921 C<flags> is not used at present but available for future extension to
1922 allow selecting particular classes of magical variable.
1923
1924 Currently assumes that C<name> is NUL terminated (as well as len being valid).
1925 This assumption is met by all callers within the perl core, which all pass
1926 pointers returned by SvPV.
1927
1928 =cut
1929 */
1930 bool
1931 Perl_is_gv_magical(pTHX_ const char *name, STRLEN len, U32 flags)
1932 {
1933     PERL_UNUSED_ARG(flags);
1934
1935     if (len > 1) {
1936         const char * const name1 = name + 1;
1937         switch (*name) {
1938         case 'I':
1939             if (len == 3 && name1[1] == 'S' && name[2] == 'A')
1940                 goto yes;
1941             break;
1942         case 'O':
1943             if (len == 8 && strEQ(name1, "VERLOAD"))
1944                 goto yes;
1945             break;
1946         case 'S':
1947             if (len == 3 && name[1] == 'I' && name[2] == 'G')
1948                 goto yes;
1949             break;
1950             /* Using ${^...} variables is likely to be sufficiently rare that
1951                it seems sensible to avoid the space hit of also checking the
1952                length.  */
1953         case '\017':   /* ${^OPEN} */
1954             if (strEQ(name1, "PEN"))
1955                 goto yes;
1956             break;
1957         case '\024':   /* ${^TAINT} */
1958             if (strEQ(name1, "AINT"))
1959                 goto yes;
1960             break;
1961         case '\025':    /* ${^UNICODE} */
1962             if (strEQ(name1, "NICODE"))
1963                 goto yes;
1964             if (strEQ(name1, "TF8LOCALE"))
1965                 goto yes;
1966             break;
1967         case '\027':   /* ${^WARNING_BITS} */
1968             if (strEQ(name1, "ARNING_BITS"))
1969                 goto yes;
1970             break;
1971         case '1':
1972         case '2':
1973         case '3':
1974         case '4':
1975         case '5':
1976         case '6':
1977         case '7':
1978         case '8':
1979         case '9':
1980         {
1981             const char *end = name + len;
1982             while (--end > name) {
1983                 if (!isDIGIT(*end))
1984                     return FALSE;
1985             }
1986             goto yes;
1987         }
1988         }
1989     } else {
1990         /* Because we're already assuming that name is NUL terminated
1991            below, we can treat an empty name as "\0"  */
1992         switch (*name) {
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 '+':
2016         case ';':
2017         case ']':
2018         case '\001':   /* $^A */
2019         case '\003':   /* $^C */
2020         case '\004':   /* $^D */
2021         case '\005':   /* $^E */
2022         case '\006':   /* $^F */
2023         case '\010':   /* $^H */
2024         case '\011':   /* $^I, NOT \t in EBCDIC */
2025         case '\014':   /* $^L */
2026         case '\016':   /* $^N */
2027         case '\017':   /* $^O */
2028         case '\020':   /* $^P */
2029         case '\023':   /* $^S */
2030         case '\024':   /* $^T */
2031         case '\026':   /* $^V */
2032         case '\027':   /* $^W */
2033         case '1':
2034         case '2':
2035         case '3':
2036         case '4':
2037         case '5':
2038         case '6':
2039         case '7':
2040         case '8':
2041         case '9':
2042         yes:
2043             return TRUE;
2044         default:
2045             break;
2046         }
2047     }
2048     return FALSE;
2049 }
2050
2051 /*
2052  * Local variables:
2053  * c-indentation-style: bsd
2054  * c-basic-offset: 4
2055  * indent-tabs-mode: t
2056  * End:
2057  *
2058  * ex: set ts=8 sts=4 sw=4 noet:
2059  */