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