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