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