gv.c

   1 /*    gv.c
   2  *
   3  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
   4  *    2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 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 in 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  *     [p.599 of _The Lord of the Rings_, III/xi: "The Palantír"]
  20  */
  21
  22 /*
  23 =head1 GV Functions
  24 A GV is a structure which corresponds to to a Perl typeglob, ie *foo.
  25 It is a structure that holds a pointer to a scalar, an array, a hash etc,
  26 corresponding to $foo, @foo, %foo.
  27
  28 GVs are usually found as values in stashes (symbol table hashes) where
  29 Perl stores its global variables.
  30
  31 =cut
  32 */
  33
  34 #include "EXTERN.h"
  35 #define PERL_IN_GV_C
  36 #include "perl.h"
  37 #include "overload.c"
  38 #include "keywords.h"
  39 #include "feature.h"
  40
  41 static const char S_autoload[] = "AUTOLOAD";
  42 static const STRLEN S_autolen = sizeof(S_autoload)-1;
  43
  44 SV *
  45 Perl_gv_add_by_type_p(pTHX_ GV *gv, gv_add_type type)
  46 {
  47     SV **where;
  48     SV * sv;
  49     PERL_ARGS_ASSERT_GV_ADD_BY_TYPE_P;
  50
  51     if ( SvTYPE((const SV *)gv) != SVt_PVGV
  52          && SvTYPE((const SV *)gv) != SVt_PVLV
  53     ) {
  54         const char *what;
  55         if (type == GPe_IO) {
  56             /*
  57              * if it walks like a dirhandle, then let's assume that
  58              * this is a dirhandle.
  59              */
  60             what = OP_IS_DIRHOP(PL_op->op_type) ?
  61                 "dirhandle" : "filehandle";
  62         } else if (type == GPe_HV) {
  63             what = "hash";
  64         } else {
  65             what = type == GPe_AV ? "array" : "scalar";
  66         }
  67         /* diag_listed_as: Bad symbol for filehandle */
  68         Perl_croak(aTHX_ "Bad symbol for %s", what);
  69     }
  70
  71     where = (SV **)((Size_t)GvGP(gv)+ (Size_t)type);
  72
  73     sv = *where;
  74     if (!sv) {
  75 /* this is table of GP members to their SV types, SVt_LAST triggers a panic */
  76         static const U8 addtype_to_svtype
  77 #if PTRSIZE == 8
  78              /*gp_sv   , gp_io   , gp_cv   , cvgn/cnt, gp_hv   , gp_av */
  79         [6] = {SVt_NULL, SVt_PVIO, SVt_LAST, SVt_LAST, SVt_PVHV, SVt_PVAV};
  80 #elif PTRSIZE == 4
  81              /*gp_sv   , gp_io   , gp_cv   , gp_cvgen, gp_rfcnt, gp_hv   , gp_av */
  82         [7] = {SVt_NULL, SVt_PVIO, SVt_LAST, SVt_LAST, SVt_LAST, SVt_PVHV, SVt_PVAV};
  83 #else
  84 #  error unknown pointer size
  85 #endif
  86         svtype svtypevar = (svtype)addtype_to_svtype[PTRPTR2IDX(type)];
  87
  88         assert(PTRPTR2IDX(type) < sizeof(addtype_to_svtype));
  89         sv = *where = newSV_type(svtypevar);
  90         if (type == GPe_AV && memEQs(GvNAME(gv), GvNAMELEN(gv), "ISA"))
  91             sv_magic(sv, (SV *)gv, PERL_MAGIC_isa, NULL, 0);
  92     }
  93     return sv;
  94 }
  95
  96 GV *
  97 Perl_gv_fetchfile(pTHX_ const char *name)
  98 {
  99     PERL_ARGS_ASSERT_GV_FETCHFILE;
 100     return gv_fetchfile_flags(name, strlen(name), 0);
 101 }
 102
 103 GV *
 104 Perl_gv_fetchfile_flags(pTHX_ const char *const name, const STRLEN namelen,
 105                         const U32 flags)
 106 {
 107     char smallbuf[128];
 108     char *tmpbuf;
 109     const STRLEN tmplen = namelen + 2;
 110     GV *gv;
 111
 112     PERL_ARGS_ASSERT_GV_FETCHFILE_FLAGS;
 113     PERL_UNUSED_ARG(flags);
 114
 115     if (!PL_defstash)
 116         return NULL;
 117
 118     if (tmplen <= sizeof smallbuf)
 119         tmpbuf = smallbuf;
 120     else
 121         Newx(tmpbuf, tmplen, char);
 122     /* This is where the debugger's %{"::_<$filename"} hash is created */
 123     tmpbuf[0] = '_';
 124     tmpbuf[1] = '<';
 125     memcpy(tmpbuf + 2, name, namelen);
 126     gv = *(GV**)hv_fetch(PL_defstash, tmpbuf, tmplen, TRUE);
 127     if (!isGV(gv)) {
 128         gv_init(gv, PL_defstash, tmpbuf, tmplen, FALSE);
 129 #ifdef PERL_DONT_CREATE_GVSV
 130         GvSV(gv) = newSVpvn(name, namelen);
 131 #else
 132         sv_setpvn(GvSV(gv), name, namelen);
 133 #endif
 134     }
 135     if ((PERLDB_LINE || PERLDB_SAVESRC) && !GvAV(gv))
 136             hv_magic(GvHVn(gv), GvAVn(gv), PERL_MAGIC_dbfile);
 137     if (tmpbuf != smallbuf)
 138         Safefree(tmpbuf);
 139     return gv;
 140 }
 141
 142 /*
 143 =for apidoc gv_const_sv
 144
 145 If C<gv> is a typeglob whose subroutine entry is a constant sub eligible for
 146 inlining, or C<gv> is a placeholder reference that would be promoted to such
 147 a typeglob, then returns the value returned by the sub.  Otherwise, returns
 148 NULL.
 149
 150 =cut
 151 */
 152
 153 SV *
 154 Perl_gv_const_sv(pTHX_ GV *gv)
 155 {
 156     PERL_ARGS_ASSERT_GV_CONST_SV;
 157     PERL_UNUSED_CONTEXT;
 158
 159     if (SvTYPE(gv) == SVt_PVGV)
 160         return cv_const_sv(GvCVu(gv));
 161     return SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVAV ? SvRV(gv) : NULL;
 162 }
 163
 164 GP *
 165 Perl_newGP(pTHX_ GV *const gv)
 166 {
 167     GP *gp;
 168     U32 hash;
 169     const char *file;
 170     STRLEN len;
 171 #ifndef USE_ITHREADS
 172     GV *filegv;
 173 #endif
 174     dVAR;
 175
 176     PERL_ARGS_ASSERT_NEWGP;
 177     Newxz(gp, 1, GP);
 178     gp->gp_egv = gv; /* allow compiler to reuse gv after this */
 179 #ifndef PERL_DONT_CREATE_GVSV
 180     gp->gp_sv = newSV(0);
 181 #endif
 182
 183     /* PL_curcop may be null here.  E.g.,
 184         INIT { bless {} and exit }
 185        frees INIT before looking up DESTROY (and creating *DESTROY)
 186     */
 187     if (PL_curcop) {
 188         gp->gp_line = CopLINE(PL_curcop); /* 0 otherwise Newxz */
 189 #ifdef USE_ITHREADS
 190         if (CopFILE(PL_curcop)) {
 191             file = CopFILE(PL_curcop);
 192             len = strlen(file);
 193         }
 194 #else
 195         filegv = CopFILEGV(PL_curcop);
 196         if (filegv) {
 197             file = GvNAME(filegv)+2;
 198             len = GvNAMELEN(filegv)-2;
 199         }
 200 #endif
 201         else goto no_file;
 202     }
 203     else {
 204         no_file:
 205         file = "";
 206         len = 0;
 207     }
 208
 209     PERL_HASH(hash, file, len);
 210     gp->gp_file_hek = share_hek(file, len, hash);
 211     gp->gp_refcnt = 1;
 212
 213     return gp;
 214 }
 215
 216 /* Assign CvGV(cv) = gv, handling weak references.
 217  * See also S_anonymise_cv_maybe */
 218
 219 void
 220 Perl_cvgv_set(pTHX_ CV* cv, GV* gv)
 221 {
 222     GV * const oldgv = CvNAMED(cv) ? NULL : SvANY(cv)->xcv_gv_u.xcv_gv;
 223     HEK *hek;
 224     PERL_ARGS_ASSERT_CVGV_SET;
 225
 226     if (oldgv == gv)
 227         return;
 228
 229     if (oldgv) {
 230         if (CvCVGV_RC(cv)) {
 231             SvREFCNT_dec_NN(oldgv);
 232             CvCVGV_RC_off(cv);
 233         }
 234         else {
 235             sv_del_backref(MUTABLE_SV(oldgv), MUTABLE_SV(cv));
 236         }
 237     }
 238     else if ((hek = CvNAME_HEK(cv))) {
 239         unshare_hek(hek);
 240         CvLEXICAL_off(cv);
 241     }
 242
 243     CvNAMED_off(cv);
 244     SvANY(cv)->xcv_gv_u.xcv_gv = gv;
 245     assert(!CvCVGV_RC(cv));
 246
 247     if (!gv)
 248         return;
 249
 250     if (isGV_with_GP(gv) && GvGP(gv) && (GvCV(gv) == cv || GvFORM(gv) == cv))
 251         Perl_sv_add_backref(aTHX_ MUTABLE_SV(gv), MUTABLE_SV(cv));
 252     else {
 253         CvCVGV_RC_on(cv);
 254         SvREFCNT_inc_simple_void_NN(gv);
 255     }
 256 }
 257
 258 /* Convert CvSTASH + CvNAME_HEK into a GV.  Conceptually, all subs have a
 259    GV, but for efficiency that GV may not in fact exist.  This function,
 260    called by CvGV, reifies it. */
 261
 262 GV *
 263 Perl_cvgv_from_hek(pTHX_ CV *cv)
 264 {
 265     GV *gv;
 266     SV **svp;
 267     PERL_ARGS_ASSERT_CVGV_FROM_HEK;
 268     assert(SvTYPE(cv) == SVt_PVCV);
 269     if (!CvSTASH(cv)) return NULL;
 270     ASSUME(CvNAME_HEK(cv));
 271     svp = hv_fetchhek(CvSTASH(cv), CvNAME_HEK(cv), 0);
 272     gv = MUTABLE_GV(svp && *svp ? *svp : newSV(0));
 273     if (!isGV(gv))
 274         gv_init_pvn(gv, CvSTASH(cv), HEK_KEY(CvNAME_HEK(cv)),
 275                 HEK_LEN(CvNAME_HEK(cv)),
 276                 SVf_UTF8 * !!HEK_UTF8(CvNAME_HEK(cv)));
 277     if (!CvNAMED(cv)) { /* gv_init took care of it */
 278         assert (SvANY(cv)->xcv_gv_u.xcv_gv == gv);
 279         return gv;
 280     }
 281     unshare_hek(CvNAME_HEK(cv));
 282     CvNAMED_off(cv);
 283     SvANY(cv)->xcv_gv_u.xcv_gv = gv;
 284     if (svp && *svp) SvREFCNT_inc_simple_void_NN(gv);
 285     CvCVGV_RC_on(cv);
 286     return gv;
 287 }
 288
 289 /* Assign CvSTASH(cv) = st, handling weak references. */
 290
 291 void
 292 Perl_cvstash_set(pTHX_ CV *cv, HV *st)
 293 {
 294     HV *oldst = CvSTASH(cv);
 295     PERL_ARGS_ASSERT_CVSTASH_SET;
 296     if (oldst == st)
 297         return;
 298     if (oldst)
 299         sv_del_backref(MUTABLE_SV(oldst), MUTABLE_SV(cv));
 300     SvANY(cv)->xcv_stash = st;
 301     if (st)
 302         Perl_sv_add_backref(aTHX_ MUTABLE_SV(st), MUTABLE_SV(cv));
 303 }
 304
 305 /*
 306 =for apidoc gv_init_pvn
 307
 308 Converts a scalar into a typeglob.  This is an incoercible typeglob;
 309 assigning a reference to it will assign to one of its slots, instead of
 310 overwriting it as happens with typeglobs created by SvSetSV.  Converting
 311 any scalar that is SvOK() may produce unpredictable results and is reserved
 312 for perl's internal use.
 313
 314 C<gv> is the scalar to be converted.
 315
 316 C<stash> is the parent stash/package, if any.
 317
 318 C<name> and C<len> give the name.  The name must be unqualified;
 319 that is, it must not include the package name.  If C<gv> is a
 320 stash element, it is the caller's responsibility to ensure that the name
 321 passed to this function matches the name of the element.  If it does not
 322 match, perl's internal bookkeeping will get out of sync.
 323
 324 C<flags> can be set to SVf_UTF8 if C<name> is a UTF8 string, or
 325 the return value of SvUTF8(sv).  It can also take the
 326 GV_ADDMULTI flag, which means to pretend that the GV has been
 327 seen before (i.e., suppress "Used once" warnings).
 328
 329 =for apidoc gv_init
 330
 331 The old form of gv_init_pvn().  It does not work with UTF8 strings, as it
 332 has no flags parameter.  If the C<multi> parameter is set, the
 333 GV_ADDMULTI flag will be passed to gv_init_pvn().
 334
 335 =for apidoc gv_init_pv
 336
 337 Same as gv_init_pvn(), but takes a nul-terminated string for the name
 338 instead of separate char * and length parameters.
 339
 340 =for apidoc gv_init_sv
 341
 342 Same as gv_init_pvn(), but takes an SV * for the name instead of separate
 343 char * and length parameters.  C<flags> is currently unused.
 344
 345 =cut
 346 */
 347
 348 void
 349 Perl_gv_init_sv(pTHX_ GV *gv, HV *stash, SV* namesv, U32 flags)
 350 {
 351    char *namepv;
 352    STRLEN namelen;
 353    PERL_ARGS_ASSERT_GV_INIT_SV;
 354    namepv = SvPV(namesv, namelen);
 355    if (SvUTF8(namesv))
 356        flags |= SVf_UTF8;
 357    gv_init_pvn(gv, stash, namepv, namelen, flags);
 358 }
 359
 360 void
 361 Perl_gv_init_pv(pTHX_ GV *gv, HV *stash, const char *name, U32 flags)
 362 {
 363    PERL_ARGS_ASSERT_GV_INIT_PV;
 364    gv_init_pvn(gv, stash, name, strlen(name), flags);
 365 }
 366
 367 void
 368 Perl_gv_init_pvn(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, U32 flags)
 369 {
 370     const U32 old_type = SvTYPE(gv);
 371     const bool doproto = old_type > SVt_NULL;
 372     char * const proto = (doproto && SvPOK(gv))
 373         ? ((void)(SvIsCOW(gv) && (sv_force_normal((SV *)gv), 0)), SvPVX(gv))
 374         : NULL;
 375     const STRLEN protolen = proto ? SvCUR(gv) : 0;
 376     const U32 proto_utf8  = proto ? SvUTF8(gv) : 0;
 377     SV *const has_constant = doproto && SvROK(gv) ? SvRV(gv) : NULL;
 378     const U32 exported_constant = has_constant ? SvPCS_IMPORTED(gv) : 0;
 379
 380     PERL_ARGS_ASSERT_GV_INIT_PVN;
 381     assert (!(proto && has_constant));
 382
 383     if (has_constant) {
 384         /* The constant has to be a scalar, array or subroutine.  */
 385         switch (SvTYPE(has_constant)) {
 386         case SVt_PVHV:
 387         case SVt_PVFM:
 388         case SVt_PVIO:
 389             Perl_croak(aTHX_ "Cannot convert a reference to %s to typeglob",
 390                        sv_reftype(has_constant, 0));
 391
 392         default: NOOP;
 393         }
 394         SvRV_set(gv, NULL);
 395         SvROK_off(gv);
 396     }
 397
 398
 399     if (old_type < SVt_PVGV) {
 400         if (old_type >= SVt_PV)
 401             SvCUR_set(gv, 0);
 402         sv_upgrade(MUTABLE_SV(gv), SVt_PVGV);
 403     }
 404     if (SvLEN(gv)) {
 405         if (proto) {
 406             SvPV_set(gv, NULL);
 407             SvLEN_set(gv, 0);
 408             SvPOK_off(gv);
 409         } else
 410             Safefree(SvPVX_mutable(gv));
 411     }
 412     SvIOK_off(gv);
 413     isGV_with_GP_on(gv);
 414
 415     GvGP_set(gv, Perl_newGP(aTHX_ gv));
 416     GvSTASH(gv) = stash;
 417     if (stash)
 418         Perl_sv_add_backref(aTHX_ MUTABLE_SV(stash), MUTABLE_SV(gv));
 419     gv_name_set(gv, name, len, GV_ADD | ( flags & SVf_UTF8 ? SVf_UTF8 : 0 ));
 420     if (flags & GV_ADDMULTI || doproto) /* doproto means it */
 421         GvMULTI_on(gv);                 /* _was_ mentioned */
 422     if (has_constant && SvTYPE(has_constant) == SVt_PVCV) {
 423         /* Not actually a constant.  Just a regular sub.  */
 424         CV * const cv = (CV *)has_constant;
 425         GvCV_set(gv,cv);
 426         if (CvSTASH(cv) == stash && (
 427                CvNAME_HEK(cv) == GvNAME_HEK(gv)
 428             || (  HEK_LEN(CvNAME_HEK(cv)) == HEK_LEN(GvNAME_HEK(gv))
 429                && HEK_FLAGS(CvNAME_HEK(cv)) != HEK_FLAGS(GvNAME_HEK(gv))
 430                && HEK_UTF8(CvNAME_HEK(cv)) == HEK_UTF8(GvNAME_HEK(gv))
 431                && memEQ(HEK_KEY(CvNAME_HEK(cv)), GvNAME(gv), GvNAMELEN(gv))
 432                )
 433            ))
 434             CvGV_set(cv,gv);
 435     }
 436     else if (doproto) {
 437         CV *cv;
 438         if (has_constant) {
 439             /* newCONSTSUB takes ownership of the reference from us.  */
 440             cv = newCONSTSUB_flags(stash, name, len, flags, has_constant);
 441             /* In case op.c:S_process_special_blocks stole it: */
 442             if (!GvCV(gv))
 443                 GvCV_set(gv, (CV *)SvREFCNT_inc_simple_NN(cv));
 444             assert(GvCV(gv) == cv); /* newCONSTSUB should have set this */
 445             /* If this reference was a copy of another, then the subroutine
 446                must have been "imported", by a Perl space assignment to a GV
 447                from a reference to CV.  */
 448             if (exported_constant)
 449                 GvIMPORTED_CV_on(gv);
 450             CvSTASH_set(cv, PL_curstash); /* XXX Why is this needed? */
 451         } else {
 452             cv = newSTUB(gv,1);
 453         }
 454         if (proto) {
 455             sv_usepvn_flags(MUTABLE_SV(cv), proto, protolen,
 456                             SV_HAS_TRAILING_NUL);
 457             if ( proto_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
 458         }
 459     }
 460 }
 461
 462 STATIC void
 463 S_gv_init_svtype(pTHX_ GV *gv, const svtype sv_type)
 464 {
 465     Size_t addtype;
 466 #define SGVINIT_SKIP 0xFF
 467 #ifdef PERL_DONT_CREATE_GVSV
 468 #  define SGVINIT_SV GPe_SV
 469 #else
 470 #  define SGVINIT_SV SGVINIT_SKIP
 471 #endif
 472     static const U8 svtype2add [] = {
 473         /*SVt_NULL,     0 */
 474         SGVINIT_SKIP,
 475         /*SVt_IV,       1 */
 476         SGVINIT_SV,
 477         /*SVt_NV,       2 */
 478         SGVINIT_SV,
 479         /*SVt_PV,       3 */
 480         SGVINIT_SV,
 481         /*SVt_INVLIST,  4 implemented as a PV */
 482         SGVINIT_SV,
 483         /*SVt_PVIV,     5 */
 484         SGVINIT_SV,
 485         /*SVt_PVNV,     6 */
 486         SGVINIT_SV,
 487         /*SVt_PVMG,     7 */
 488         SGVINIT_SV,
 489         /*SVt_REGEXP,   8 */
 490         SGVINIT_SV,
 491         /*SVt_PVGV,     9 */
 492         SGVINIT_SKIP,
 493         /*SVt_PVLV,     10 */
 494         SGVINIT_SV,
 495         /*SVt_PVAV,     11 */
 496         GPe_AV,
 497         /*SVt_PVHV,     12 */
 498         GPe_HV,
 499         /*SVt_PVCV,     13 */
 500         SGVINIT_SKIP,
 501         /*SVt_PVFM,     14 */
 502         SGVINIT_SKIP,
 503         /*SVt_PVIO,     15 */
 504         GPe_IO,
 505         /*SVt_LAST      keep last in enum. used to size arrays */
 506         /* invalid, this is slot 0x10, dont define it so this array is
 507         a nice 16 bytes long */
 508     };
 509     PERL_ARGS_ASSERT_GV_INIT_SVTYPE;
 510     addtype = svtype2add[sv_type];
 511     if(addtype != SGVINIT_SKIP) {
 512         SV ** where = (SV **)((Size_t)GvGP(gv)+ addtype);
 513         if (!*where)
 514             gv_add_by_type_p(gv, (gv_add_type)addtype);
 515     }
 516     return;
 517 #undef SGVINIT_SV
 518 #undef SGVINIT_SKIP
 519 }
 520
 521 static void core_xsub(pTHX_ CV* cv);
 522
 523 static GV *
 524 S_maybe_add_coresub(pTHX_ HV * const stash, GV *gv,
 525                           const char * const name, const STRLEN len)
 526 {
 527     const int code = keyword(name, len, 1);
 528     static const char file[] = __FILE__;
 529     CV *cv, *oldcompcv = NULL;
 530     int opnum = 0;
 531     bool ampable = TRUE; /* &{}-able */
 532     COP *oldcurcop = NULL;
 533     yy_parser *oldparser = NULL;
 534     I32 oldsavestack_ix = 0;
 535
 536     assert(gv || stash);
 537     assert(name);
 538
 539     if (!code) return NULL; /* Not a keyword */
 540     switch (code < 0 ? -code : code) {
 541      /* no support for \&CORE::infix;
 542         no support for funcs that do not parse like funcs */
 543     case KEY___DATA__: case KEY___END__: case KEY_and: case KEY_AUTOLOAD:
 544     case KEY_BEGIN   : case KEY_CHECK  : case KEY_cmp:
 545     case KEY_default : case KEY_DESTROY:
 546     case KEY_do      : case KEY_dump   : case KEY_else  : case KEY_elsif  :
 547     case KEY_END     : case KEY_eq     : case KEY_eval  :
 548     case KEY_for     : case KEY_foreach: case KEY_format: case KEY_ge     :
 549     case KEY_given   : case KEY_goto   : case KEY_grep  :
 550     case KEY_gt   : case KEY_if: case KEY_INIT: case KEY_last: case KEY_le:
 551     case KEY_local: case KEY_lt: case KEY_m   : case KEY_map : case KEY_my:
 552     case KEY_ne   : case KEY_next : case KEY_no: case KEY_or: case KEY_our:
 553     case KEY_package: case KEY_print: case KEY_printf:
 554     case KEY_q    : case KEY_qq   : case KEY_qr     : case KEY_qw    :
 555     case KEY_qx   : case KEY_redo : case KEY_require: case KEY_return:
 556     case KEY_s    : case KEY_say  : case KEY_sort   :
 557     case KEY_state: case KEY_sub  :
 558     case KEY_tr   : case KEY_UNITCHECK: case KEY_unless:
 559     case KEY_until: case KEY_use  : case KEY_when     : case KEY_while :
 560     case KEY_x    : case KEY_xor  : case KEY_y        :
 561         return NULL;
 562     case KEY_chdir:
 563     case KEY_chomp: case KEY_chop: case KEY_defined: case KEY_delete:
 564     case KEY_each : case KEY_eof : case KEY_exec   : case KEY_exists:
 565     case KEY_keys:
 566     case KEY_lstat:
 567     case KEY_pop:
 568     case KEY_push:
 569     case KEY_shift:
 570     case KEY_splice: case KEY_split:
 571     case KEY_stat:
 572     case KEY_system:
 573     case KEY_truncate: case KEY_unlink:
 574     case KEY_unshift:
 575     case KEY_values:
 576         ampable = FALSE;
 577     }
 578     if (!gv) {
 579         gv = (GV *)newSV(0);
 580         gv_init(gv, stash, name, len, TRUE);
 581     }
 582     GvMULTI_on(gv);
 583     if (ampable) {
 584         ENTER;
 585         oldcurcop = PL_curcop;
 586         oldparser = PL_parser;
 587         lex_start(NULL, NULL, 0);
 588         oldcompcv = PL_compcv;
 589         PL_compcv = NULL; /* Prevent start_subparse from setting
 590                              CvOUTSIDE. */
 591         oldsavestack_ix = start_subparse(FALSE,0);
 592         cv = PL_compcv;
 593     }
 594     else {
 595         /* Avoid calling newXS, as it calls us, and things start to
 596            get hairy. */
 597         cv = MUTABLE_CV(newSV_type(SVt_PVCV));
 598         GvCV_set(gv,cv);
 599         GvCVGEN(gv) = 0;
 600         CvISXSUB_on(cv);
 601         CvXSUB(cv) = core_xsub;
 602         PoisonPADLIST(cv);
 603     }
 604     CvGV_set(cv, gv); /* This stops new ATTRSUB from setting CvFILE
 605                          from PL_curcop. */
 606     (void)gv_fetchfile(file);
 607     CvFILE(cv) = (char *)file;
 608     /* XXX This is inefficient, as doing things this order causes
 609            a prototype check in newATTRSUB.  But we have to do
 610            it this order as we need an op number before calling
 611            new ATTRSUB. */
 612     (void)core_prototype((SV *)cv, name, code, &opnum);
 613     if (stash)
 614         (void)hv_store(stash,name,len,(SV *)gv,0);
 615     if (ampable) {
 616 #ifdef DEBUGGING
 617         CV *orig_cv = cv;
 618 #endif
 619         CvLVALUE_on(cv);
 620         /* newATTRSUB will free the CV and return NULL if we're still
 621            compiling after a syntax error */
 622         if ((cv = newATTRSUB_x(
 623                    oldsavestack_ix, (OP *)gv,
 624                    NULL,NULL,
 625                    coresub_op(
 626                      opnum
 627                        ? newSVuv((UV)opnum)
 628                        : newSVpvn(name,len),
 629                      code, opnum
 630                    ),
 631                    TRUE
 632                )) != NULL) {
 633             assert(GvCV(gv) == orig_cv);
 634             if (opnum != OP_VEC && opnum != OP_SUBSTR && opnum != OP_POS
 635                 && opnum != OP_UNDEF)
 636                 CvLVALUE_off(cv); /* Now *that* was a neat trick. */
 637         }
 638         LEAVE;
 639         PL_parser = oldparser;
 640         PL_curcop = oldcurcop;
 641         PL_compcv = oldcompcv;
 642     }
 643     if (cv) {
 644         SV *opnumsv = opnum ? newSVuv((UV)opnum) : (SV *)NULL;
 645         cv_set_call_checker(
 646           cv, Perl_ck_entersub_args_core, opnumsv ? opnumsv : (SV *)cv
 647         );
 648         SvREFCNT_dec(opnumsv);
 649     }
 650
 651     return gv;
 652 }
 653
 654 /*
 655 =for apidoc gv_fetchmeth
 656
 657 Like L</gv_fetchmeth_pvn>, but lacks a flags parameter.
 658
 659 =for apidoc gv_fetchmeth_sv
 660
 661 Exactly like L</gv_fetchmeth_pvn>, but takes the name string in the form
 662 of an SV instead of a string/length pair.
 663
 664 =cut
 665 */
 666
 667 GV *
 668 Perl_gv_fetchmeth_sv(pTHX_ HV *stash, SV *namesv, I32 level, U32 flags)
 669 {
 670     char *namepv;
 671     STRLEN namelen;
 672     PERL_ARGS_ASSERT_GV_FETCHMETH_SV;
 673     if (LIKELY(SvPOK_nog(namesv))) /* common case */
 674         return gv_fetchmeth_internal(stash, namesv, NULL, 0, level, flags);
 675     namepv = SvPV(namesv, namelen);
 676     if (SvUTF8(namesv)) flags |= SVf_UTF8;
 677     return gv_fetchmeth_pvn(stash, namepv, namelen, level, flags);
 678 }
 679
 680 /*
 681 =for apidoc gv_fetchmeth_pv
 682
 683 Exactly like L</gv_fetchmeth_pvn>, but takes a nul-terminated string
 684 instead of a string/length pair.
 685
 686 =cut
 687 */
 688
 689 GV *
 690 Perl_gv_fetchmeth_pv(pTHX_ HV *stash, const char *name, I32 level, U32 flags)
 691 {
 692     PERL_ARGS_ASSERT_GV_FETCHMETH_PV;
 693     return gv_fetchmeth_internal(stash, NULL, name, strlen(name), level, flags);
 694 }
 695
 696 /*
 697 =for apidoc gv_fetchmeth_pvn
 698
 699 Returns the glob with the given C<name> and a defined subroutine or
 700 C<NULL>.  The glob lives in the given C<stash>, or in the stashes
 701 accessible via @ISA and UNIVERSAL::.
 702
 703 The argument C<level> should be either 0 or -1.  If C<level==0>, as a
 704 side-effect creates a glob with the given C<name> in the given C<stash>
 705 which in the case of success contains an alias for the subroutine, and sets
 706 up caching info for this glob.
 707
 708 The only significant values for C<flags> are GV_SUPER and SVf_UTF8.
 709
 710 GV_SUPER indicates that we want to look up the method in the superclasses
 711 of the C<stash>.
 712
 713 The
 714 GV returned from C<gv_fetchmeth> may be a method cache entry, which is not
 715 visible to Perl code.  So when calling C<call_sv>, you should not use
 716 the GV directly; instead, you should use the method's CV, which can be
 717 obtained from the GV with the C<GvCV> macro.
 718
 719 =cut
 720 */
 721
 722 /* NOTE: No support for tied ISA */
 723
 724 PERL_STATIC_INLINE GV*
 725 S_gv_fetchmeth_internal(pTHX_ HV* stash, SV* meth, const char* name, STRLEN len, I32 level, U32 flags)
 726 {
 727     GV** gvp;
 728     HE* he;
 729     AV* linear_av;
 730     SV** linear_svp;
 731     SV* linear_sv;
 732     HV* cstash, *cachestash;
 733     GV* candidate = NULL;
 734     CV* cand_cv = NULL;
 735     GV* topgv = NULL;
 736     const char *hvname;
 737     I32 create = (level >= 0) ? HV_FETCH_LVALUE : 0;
 738     I32 items;
 739     U32 topgen_cmp;
 740     U32 is_utf8 = flags & SVf_UTF8;
 741
 742     /* UNIVERSAL methods should be callable without a stash */
 743     if (!stash) {
 744         create = 0;  /* probably appropriate */
 745         if(!(stash = gv_stashpvs("UNIVERSAL", 0)))
 746             return 0;
 747     }
 748
 749     assert(stash);
 750
 751     hvname = HvNAME_get(stash);
 752     if (!hvname)
 753       Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup");
 754
 755     assert(hvname);
 756     assert(name || meth);
 757
 758     DEBUG_o( Perl_deb(aTHX_ "Looking for %smethod %s in package %s\n",
 759                       flags & GV_SUPER ? "SUPER " : "",
 760                       name ? name : SvPV_nolen(meth), hvname) );
 761
 762     topgen_cmp = HvMROMETA(stash)->cache_gen + PL_sub_generation;
 763
 764     if (flags & GV_SUPER) {
 765         if (!HvAUX(stash)->xhv_mro_meta->super)
 766             HvAUX(stash)->xhv_mro_meta->super = newHV();
 767         cachestash = HvAUX(stash)->xhv_mro_meta->super;
 768     }
 769     else cachestash = stash;
 770
 771     /* check locally for a real method or a cache entry */
 772     he = (HE*)hv_common(
 773         cachestash, meth, name, len, (flags & SVf_UTF8) ? HVhek_UTF8 : 0, create, NULL, 0
 774     );
 775     if (he) gvp = (GV**)&HeVAL(he);
 776     else gvp = NULL;
 777
 778     if(gvp) {
 779         topgv = *gvp;
 780       have_gv:
 781         assert(topgv);
 782         if (SvTYPE(topgv) != SVt_PVGV)
 783         {
 784             if (!name)
 785                 name = SvPV_nomg(meth, len);
 786             gv_init_pvn(topgv, stash, name, len, GV_ADDMULTI|is_utf8);
 787         }
 788         if ((cand_cv = GvCV(topgv))) {
 789             /* If genuine method or valid cache entry, use it */
 790             if (!GvCVGEN(topgv) || GvCVGEN(topgv) == topgen_cmp) {
 791                 return topgv;
 792             }
 793             else {
 794                 /* stale cache entry, junk it and move on */
 795                 SvREFCNT_dec_NN(cand_cv);
 796                 GvCV_set(topgv, NULL);
 797                 cand_cv = NULL;
 798                 GvCVGEN(topgv) = 0;
 799             }
 800         }
 801         else if (GvCVGEN(topgv) == topgen_cmp) {
 802             /* cache indicates no such method definitively */
 803             return 0;
 804         }
 805         else if (stash == cachestash
 806               && len > 1 /* shortest is uc */ && HvNAMELEN_get(stash) == 4
 807               && strnEQ(hvname, "CORE", 4)
 808               && S_maybe_add_coresub(aTHX_ NULL,topgv,name,len))
 809             goto have_gv;
 810     }
 811
 812     linear_av = mro_get_linear_isa(stash); /* has ourselves at the top of the list */
 813     linear_svp = AvARRAY(linear_av) + 1; /* skip over self */
 814     items = AvFILLp(linear_av); /* no +1, to skip over self */
 815     while (items--) {
 816         linear_sv = *linear_svp++;
 817         assert(linear_sv);
 818         cstash = gv_stashsv(linear_sv, 0);
 819
 820         if (!cstash) {
 821             Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
 822                            "Can't locate package %"SVf" for @%"HEKf"::ISA",
 823                            SVfARG(linear_sv),
 824                            HEKfARG(HvNAME_HEK(stash)));
 825             continue;
 826         }
 827
 828         assert(cstash);
 829
 830         gvp = (GV**)hv_fetch(cstash, name, is_utf8 ? -(I32)len : (I32)len, 0);
 831         if (!gvp) {
 832             if (len > 1 && HvNAMELEN_get(cstash) == 4) {
 833                 const char *hvname = HvNAME(cstash); assert(hvname);
 834                 if (strnEQ(hvname, "CORE", 4)
 835                  && (candidate =
 836                       S_maybe_add_coresub(aTHX_ cstash,NULL,name,len)
 837                     ))
 838                     goto have_candidate;
 839             }
 840             continue;
 841         }
 842         else candidate = *gvp;
 843        have_candidate:
 844         assert(candidate);
 845         if (SvTYPE(candidate) != SVt_PVGV)
 846             gv_init_pvn(candidate, cstash, name, len, GV_ADDMULTI|is_utf8);
 847         if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) {
 848             /*
 849              * Found real method, cache method in topgv if:
 850              *  1. topgv has no synonyms (else inheritance crosses wires)
 851              *  2. method isn't a stub (else AUTOLOAD fails spectacularly)
 852              */
 853             if (topgv && (GvREFCNT(topgv) == 1) && (CvROOT(cand_cv) || CvXSUB(cand_cv))) {
 854                   CV *old_cv = GvCV(topgv);
 855                   SvREFCNT_dec(old_cv);
 856                   SvREFCNT_inc_simple_void_NN(cand_cv);
 857                   GvCV_set(topgv, cand_cv);
 858                   GvCVGEN(topgv) = topgen_cmp;
 859             }
 860             return candidate;
 861         }
 862     }
 863
 864     /* Check UNIVERSAL without caching */
 865     if(level == 0 || level == -1) {
 866         candidate = gv_fetchmeth_internal(NULL, meth, name, len, 1,
 867                                           flags &~GV_SUPER);
 868         if(candidate) {
 869             cand_cv = GvCV(candidate);
 870             if (topgv && (GvREFCNT(topgv) == 1) && (CvROOT(cand_cv) || CvXSUB(cand_cv))) {
 871                   CV *old_cv = GvCV(topgv);
 872                   SvREFCNT_dec(old_cv);
 873                   SvREFCNT_inc_simple_void_NN(cand_cv);
 874                   GvCV_set(topgv, cand_cv);
 875                   GvCVGEN(topgv) = topgen_cmp;
 876             }
 877             return candidate;
 878         }
 879     }
 880
 881     if (topgv && GvREFCNT(topgv) == 1) {
 882         /* cache the fact that the method is not defined */
 883         GvCVGEN(topgv) = topgen_cmp;
 884     }
 885
 886     return 0;
 887 }
 888
 889 GV *
 890 Perl_gv_fetchmeth_pvn(pTHX_ HV *stash, const char *name, STRLEN len, I32 level, U32 flags)
 891 {
 892     PERL_ARGS_ASSERT_GV_FETCHMETH_PVN;
 893     return gv_fetchmeth_internal(stash, NULL, name, len, level, flags);
 894 }
 895
 896 /*
 897 =for apidoc gv_fetchmeth_autoload
 898
 899 This is the old form of L</gv_fetchmeth_pvn_autoload>, which has no flags
 900 parameter.
 901
 902 =for apidoc gv_fetchmeth_sv_autoload
 903
 904 Exactly like L</gv_fetchmeth_pvn_autoload>, but takes the name string in the form
 905 of an SV instead of a string/length pair.
 906
 907 =cut
 908 */
 909
 910 GV *
 911 Perl_gv_fetchmeth_sv_autoload(pTHX_ HV *stash, SV *namesv, I32 level, U32 flags)
 912 {
 913    char *namepv;
 914    STRLEN namelen;
 915    PERL_ARGS_ASSERT_GV_FETCHMETH_SV_AUTOLOAD;
 916    namepv = SvPV(namesv, namelen);
 917    if (SvUTF8(namesv))
 918        flags |= SVf_UTF8;
 919    return gv_fetchmeth_pvn_autoload(stash, namepv, namelen, level, flags);
 920 }
 921
 922 /*
 923 =for apidoc gv_fetchmeth_pv_autoload
 924
 925 Exactly like L</gv_fetchmeth_pvn_autoload>, but takes a nul-terminated string
 926 instead of a string/length pair.
 927
 928 =cut
 929 */
 930
 931 GV *
 932 Perl_gv_fetchmeth_pv_autoload(pTHX_ HV *stash, const char *name, I32 level, U32 flags)
 933 {
 934     PERL_ARGS_ASSERT_GV_FETCHMETH_PV_AUTOLOAD;
 935     return gv_fetchmeth_pvn_autoload(stash, name, strlen(name), level, flags);
 936 }
 937
 938 /*
 939 =for apidoc gv_fetchmeth_pvn_autoload
 940
 941 Same as gv_fetchmeth_pvn(), but looks for autoloaded subroutines too.
 942 Returns a glob for the subroutine.
 943
 944 For an autoloaded subroutine without a GV, will create a GV even
 945 if C<level < 0>.  For an autoloaded subroutine without a stub, GvCV()
 946 of the result may be zero.
 947
 948 Currently, the only significant value for C<flags> is SVf_UTF8.
 949
 950 =cut
 951 */
 952
 953 GV *
 954 Perl_gv_fetchmeth_pvn_autoload(pTHX_ HV *stash, const char *name, STRLEN len, I32 level, U32 flags)
 955 {
 956     GV *gv = gv_fetchmeth_pvn(stash, name, len, level, flags);
 957
 958     PERL_ARGS_ASSERT_GV_FETCHMETH_PVN_AUTOLOAD;
 959
 960     if (!gv) {
 961         CV *cv;
 962         GV **gvp;
 963
 964         if (!stash)
 965             return NULL;        /* UNIVERSAL::AUTOLOAD could cause trouble */
 966         if (len == S_autolen && memEQ(name, S_autoload, S_autolen))
 967             return NULL;
 968         if (!(gv = gv_fetchmeth_pvn(stash, S_autoload, S_autolen, FALSE, flags)))
 969             return NULL;
 970         cv = GvCV(gv);
 971         if (!(CvROOT(cv) || CvXSUB(cv)))
 972             return NULL;
 973         /* Have an autoload */
 974         if (level < 0)  /* Cannot do without a stub */
 975             gv_fetchmeth_pvn(stash, name, len, 0, flags);
 976         gvp = (GV**)hv_fetch(stash, name,
 977                         (flags & SVf_UTF8) ? -(I32)len : (I32)len, (level >= 0));
 978         if (!gvp)
 979             return NULL;
 980         return *gvp;
 981     }
 982     return gv;
 983 }
 984
 985 /*
 986 =for apidoc gv_fetchmethod_autoload
 987
 988 Returns the glob which contains the subroutine to call to invoke the method
 989 on the C<stash>.  In fact in the presence of autoloading this may be the
 990 glob for "AUTOLOAD".  In this case the corresponding variable $AUTOLOAD is
 991 already setup.
 992
 993 The third parameter of C<gv_fetchmethod_autoload> determines whether
 994 AUTOLOAD lookup is performed if the given method is not present: non-zero
 995 means yes, look for AUTOLOAD; zero means no, don't look for AUTOLOAD.
 996 Calling C<gv_fetchmethod> is equivalent to calling C<gv_fetchmethod_autoload>
 997 with a non-zero C<autoload> parameter.
 998
 999 These functions grant C<"SUPER"> token
1000 as a prefix of the method name.  Note
1001 that if you want to keep the returned glob for a long time, you need to
1002 check for it being "AUTOLOAD", since at the later time the call may load a
1003 different subroutine due to $AUTOLOAD changing its value.  Use the glob
1004 created as a side effect to do this.
1005
1006 These functions have the same side-effects as C<gv_fetchmeth> with
1007 C<level==0>.  The warning against passing the GV returned by
1008 C<gv_fetchmeth> to C<call_sv> applies equally to these functions.
1009
1010 =cut
1011 */
1012
1013 GV *
1014 Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload)
1015 {
1016     PERL_ARGS_ASSERT_GV_FETCHMETHOD_AUTOLOAD;
1017
1018     return gv_fetchmethod_flags(stash, name, autoload ? GV_AUTOLOAD : 0);
1019 }
1020
1021 GV *
1022 Perl_gv_fetchmethod_sv_flags(pTHX_ HV *stash, SV *namesv, U32 flags)
1023 {
1024     char *namepv;
1025     STRLEN namelen;
1026     PERL_ARGS_ASSERT_GV_FETCHMETHOD_SV_FLAGS;
1027     namepv = SvPV(namesv, namelen);
1028     if (SvUTF8(namesv))
1029        flags |= SVf_UTF8;
1030     return gv_fetchmethod_pvn_flags(stash, namepv, namelen, flags);
1031 }
1032
1033 GV *
1034 Perl_gv_fetchmethod_pv_flags(pTHX_ HV *stash, const char *name, U32 flags)
1035 {
1036     PERL_ARGS_ASSERT_GV_FETCHMETHOD_PV_FLAGS;
1037     return gv_fetchmethod_pvn_flags(stash, name, strlen(name), flags);
1038 }
1039
1040 /* Don't merge this yet, as it's likely to get a len parameter, and possibly
1041    even a U32 hash */
1042 GV *
1043 Perl_gv_fetchmethod_pvn_flags(pTHX_ HV *stash, const char *name, const STRLEN len, U32 flags)
1044 {
1045     const char *nend;
1046     const char *nsplit = NULL;
1047     GV* gv;
1048     HV* ostash = stash;
1049     const char * const origname = name;
1050     SV *const error_report = MUTABLE_SV(stash);
1051     const U32 autoload = flags & GV_AUTOLOAD;
1052     const U32 do_croak = flags & GV_CROAK;
1053     const U32 is_utf8  = flags & SVf_UTF8;
1054
1055     PERL_ARGS_ASSERT_GV_FETCHMETHOD_PVN_FLAGS;
1056
1057     if (SvTYPE(stash) < SVt_PVHV)
1058         stash = NULL;
1059     else {
1060         /* The only way stash can become NULL later on is if nsplit is set,
1061            which in turn means that there is no need for a SVt_PVHV case
1062            the error reporting code.  */
1063     }
1064
1065     for (nend = name; *nend || nend != (origname + len); nend++) {
1066         if (*nend == '\'') {
1067             nsplit = nend;
1068             name = nend + 1;
1069         }
1070         else if (*nend == ':' && *(nend + 1) == ':') {
1071             nsplit = nend++;
1072             name = nend + 1;
1073         }
1074     }
1075     if (nsplit) {
1076         if ((nsplit - origname) == 5 && memEQ(origname, "SUPER", 5)) {
1077             /* ->SUPER::method should really be looked up in original stash */
1078             stash = CopSTASH(PL_curcop);
1079             flags |= GV_SUPER;
1080             DEBUG_o( Perl_deb(aTHX_ "Treating %s as %s::%s\n",
1081                          origname, HvENAME_get(stash), name) );
1082         }
1083         else if ((nsplit - origname) >= 7 &&
1084                  strnEQ(nsplit - 7, "::SUPER", 7)) {
1085             /* don't autovifify if ->NoSuchStash::SUPER::method */
1086             stash = gv_stashpvn(origname, nsplit - origname - 7, is_utf8);
1087             if (stash) flags |= GV_SUPER;
1088         }
1089         else {
1090             /* don't autovifify if ->NoSuchStash::method */
1091             stash = gv_stashpvn(origname, nsplit - origname, is_utf8);
1092         }
1093         ostash = stash;
1094     }
1095
1096     gv = gv_fetchmeth_pvn(stash, name, nend - name, 0, flags);
1097     if (!gv) {
1098         if (strEQ(name,"import") || strEQ(name,"unimport"))
1099             gv = MUTABLE_GV(&PL_sv_yes);
1100         else if (autoload)
1101             gv = gv_autoload_pvn(
1102                 ostash, name, nend - name, GV_AUTOLOAD_ISMETHOD|flags
1103             );
1104         if (!gv && do_croak) {
1105             /* Right now this is exclusively for the benefit of S_method_common
1106                in pp_hot.c  */
1107             if (stash) {
1108                 /* If we can't find an IO::File method, it might be a call on
1109                  * a filehandle. If IO:File has not been loaded, try to
1110                  * require it first instead of croaking */
1111                 const char *stash_name = HvNAME_get(stash);
1112                 if (stash_name && memEQs(stash_name, HvNAMELEN_get(stash), "IO::File")
1113                     && !Perl_hv_common(aTHX_ GvHVn(PL_incgv), NULL,
1114                                        STR_WITH_LEN("IO/File.pm"), 0,
1115                                        HV_FETCH_ISEXISTS, NULL, 0)
1116                 ) {
1117                     require_pv("IO/File.pm");
1118                     gv = gv_fetchmeth_pvn(stash, name, nend - name, 0, flags);
1119                     if (gv)
1120                         return gv;
1121                 }
1122                 Perl_croak(aTHX_
1123                            "Can't locate object method \"%"UTF8f
1124                            "\" via package \"%"HEKf"\"",
1125                                     UTF8fARG(is_utf8, nend - name, name),
1126                                     HEKfARG(HvNAME_HEK(stash)));
1127             }
1128             else {
1129                 SV* packnamesv;
1130
1131                 if (nsplit) {
1132                     packnamesv = newSVpvn_flags(origname, nsplit - origname,
1133                                                     SVs_TEMP | is_utf8);
1134                 } else {
1135                     packnamesv = error_report;
1136                 }
1137
1138                 Perl_croak(aTHX_
1139                            "Can't locate object method \"%"UTF8f
1140                            "\" via package \"%"SVf"\""
1141                            " (perhaps you forgot to load \"%"SVf"\"?)",
1142                            UTF8fARG(is_utf8, nend - name, name),
1143                            SVfARG(packnamesv), SVfARG(packnamesv));
1144             }
1145         }
1146     }
1147     else if (autoload) {
1148         CV* const cv = GvCV(gv);
1149         if (!CvROOT(cv) && !CvXSUB(cv)) {
1150             GV* stubgv;
1151             GV* autogv;
1152
1153             if (CvANON(cv) || CvLEXICAL(cv))
1154                 stubgv = gv;
1155             else {
1156                 stubgv = CvGV(cv);
1157                 if (GvCV(stubgv) != cv)         /* orphaned import */
1158                     stubgv = gv;
1159             }
1160             autogv = gv_autoload_pvn(GvSTASH(stubgv),
1161                                   GvNAME(stubgv), GvNAMELEN(stubgv),
1162                                   GV_AUTOLOAD_ISMETHOD
1163                                    | (GvNAMEUTF8(stubgv) ? SVf_UTF8 : 0));
1164             if (autogv)
1165                 gv = autogv;
1166         }
1167     }
1168
1169     return gv;
1170 }
1171
1172 GV*
1173 Perl_gv_autoload_sv(pTHX_ HV *stash, SV* namesv, U32 flags)
1174 {
1175    char *namepv;
1176    STRLEN namelen;
1177    PERL_ARGS_ASSERT_GV_AUTOLOAD_SV;
1178    namepv = SvPV(namesv, namelen);
1179    if (SvUTF8(namesv))
1180        flags |= SVf_UTF8;
1181    return gv_autoload_pvn(stash, namepv, namelen, flags);
1182 }
1183
1184 GV*
1185 Perl_gv_autoload_pv(pTHX_ HV *stash, const char *namepv, U32 flags)
1186 {
1187    PERL_ARGS_ASSERT_GV_AUTOLOAD_PV;
1188    return gv_autoload_pvn(stash, namepv, strlen(namepv), flags);
1189 }
1190
1191 GV*
1192 Perl_gv_autoload_pvn(pTHX_ HV *stash, const char *name, STRLEN len, U32 flags)
1193 {
1194     GV* gv;
1195     CV* cv;
1196     HV* varstash;
1197     GV* vargv;
1198     SV* varsv;
1199     SV *packname = NULL;
1200     U32 is_utf8 = flags & SVf_UTF8 ? SVf_UTF8 : 0;
1201
1202     PERL_ARGS_ASSERT_GV_AUTOLOAD_PVN;
1203
1204     if (len == S_autolen && memEQ(name, S_autoload, S_autolen))
1205         return NULL;
1206     if (stash) {
1207         if (SvTYPE(stash) < SVt_PVHV) {
1208             STRLEN packname_len = 0;
1209             const char * const packname_ptr = SvPV_const(MUTABLE_SV(stash), packname_len);
1210             packname = newSVpvn_flags(packname_ptr, packname_len,
1211                                       SVs_TEMP | SvUTF8(stash));
1212             stash = NULL;
1213         }
1214         else
1215             packname = sv_2mortal(newSVhek(HvNAME_HEK(stash)));
1216         if (flags & GV_SUPER) sv_catpvs(packname, "::SUPER");
1217     }
1218     if (!(gv = gv_fetchmeth_pvn(stash, S_autoload, S_autolen, FALSE,
1219                                 is_utf8 | (flags & GV_SUPER))))
1220         return NULL;
1221     cv = GvCV(gv);
1222
1223     if (!(CvROOT(cv) || CvXSUB(cv)))
1224         return NULL;
1225
1226     /*
1227      * Inheriting AUTOLOAD for non-methods works ... for now.
1228      */
1229     if (
1230         !(flags & GV_AUTOLOAD_ISMETHOD)
1231      && (GvCVGEN(gv) || GvSTASH(gv) != stash)
1232     )
1233         Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
1234                          "Use of inherited AUTOLOAD for non-method %"SVf
1235                          "::%"UTF8f"() is deprecated",
1236                          SVfARG(packname),
1237                          UTF8fARG(is_utf8, len, name));
1238
1239     if (CvISXSUB(cv)) {
1240         /* Instead of forcing the XSUB do another lookup for $AUTOLOAD
1241          * and split that value on the last '::', pass along the same data
1242          * via the SvPVX field in the CV, and the stash in CvSTASH.
1243          *
1244          * Due to an unfortunate accident of history, the SvPVX field
1245          * serves two purposes.  It is also used for the subroutine's pro-
1246          * type.  Since SvPVX has been documented as returning the sub name
1247          * for a long time, but not as returning the prototype, we have
1248          * to preserve the SvPVX AUTOLOAD behaviour and put the prototype
1249          * elsewhere.
1250          *
1251          * We put the prototype in the same allocated buffer, but after
1252          * the sub name.  The SvPOK flag indicates the presence of a proto-
1253          * type.  The CvAUTOLOAD flag indicates the presence of a sub name.
1254          * If both flags are on, then SvLEN is used to indicate the end of
1255          * the prototype (artificially lower than what is actually allo-
1256          * cated), at the risk of having to reallocate a few bytes unneces-
1257          * sarily--but that should happen very rarely, if ever.
1258          *
1259          * We use SvUTF8 for both prototypes and sub names, so if one is
1260          * UTF8, the other must be upgraded.
1261          */
1262         CvSTASH_set(cv, stash);
1263         if (SvPOK(cv)) { /* Ouch! */
1264             SV * const tmpsv = newSVpvn_flags(name, len, is_utf8);
1265             STRLEN ulen;
1266             const char *proto = CvPROTO(cv);
1267             assert(proto);
1268             if (SvUTF8(cv))
1269                 sv_utf8_upgrade_flags_grow(tmpsv, 0, CvPROTOLEN(cv) + 2);
1270             ulen = SvCUR(tmpsv);
1271             SvCUR(tmpsv)++; /* include null in string */
1272             sv_catpvn_flags(
1273                 tmpsv, proto, CvPROTOLEN(cv), SV_CATBYTES*!SvUTF8(cv)
1274             );
1275             SvTEMP_on(tmpsv); /* Allow theft */
1276             sv_setsv_nomg((SV *)cv, tmpsv);
1277             SvTEMP_off(tmpsv);
1278             SvREFCNT_dec_NN(tmpsv);
1279             SvLEN(cv) = SvCUR(cv) + 1;
1280             SvCUR(cv) = ulen;
1281         }
1282         else {
1283           sv_setpvn((SV *)cv, name, len);
1284           SvPOK_off(cv);
1285           if (is_utf8)
1286             SvUTF8_on(cv);
1287           else SvUTF8_off(cv);
1288         }
1289         CvAUTOLOAD_on(cv);
1290     }
1291
1292     /*
1293      * Given &FOO::AUTOLOAD, set $FOO::AUTOLOAD to desired function name.
1294      * The subroutine's original name may not be "AUTOLOAD", so we don't
1295      * use that, but for lack of anything better we will use the sub's
1296      * original package to look up $AUTOLOAD.
1297      */
1298     varstash = CvNAMED(cv) ? CvSTASH(cv) : GvSTASH(CvGV(cv));
1299     vargv = *(GV**)hv_fetch(varstash, S_autoload, S_autolen, TRUE);
1300     ENTER;
1301
1302     if (!isGV(vargv)) {
1303         gv_init_pvn(vargv, varstash, S_autoload, S_autolen, 0);
1304 #ifdef PERL_DONT_CREATE_GVSV
1305         GvSV(vargv) = newSV(0);
1306 #endif
1307     }
1308     LEAVE;
1309     varsv = GvSVn(vargv);
1310     SvTAINTED_off(varsv); /* previous $AUTOLOAD taint is obsolete */
1311     /* XXX: this process is not careful to avoid extra magic gets and sets; tied $AUTOLOAD will get noise */
1312     sv_setsv(varsv, packname);
1313     sv_catpvs(varsv, "::");
1314     /* Ensure SvSETMAGIC() is called if necessary. In particular, to clear
1315        tainting if $FOO::AUTOLOAD was previously tainted, but is not now.  */
1316     sv_catpvn_flags(
1317         varsv, name, len,
1318         SV_SMAGIC|(is_utf8 ? SV_CATUTF8 : SV_CATBYTES)
1319     );
1320     if (is_utf8)
1321         SvUTF8_on(varsv);
1322     return gv;
1323 }
1324
1325
1326 /* require_tie_mod() internal routine for requiring a module
1327  * that implements the logic of automatic ties like %! and %-
1328  *
1329  * The "gv" parameter should be the glob.
1330  * "varpv" holds the name of the var, used for error messages.
1331  * "namesv" holds the module name. Its refcount will be decremented.
1332  * "methpv" holds the method name to test for to check that things
1333  *   are working reasonably close to as expected.
1334  * "flags": if flag & 1 then save the scalar before loading.
1335  * For the protection of $! to work (it is set by this routine)
1336  * the sv slot must already be magicalized.
1337  */
1338 STATIC HV*
1339 S_require_tie_mod(pTHX_ GV *gv, const char *varpv, SV* namesv, const char *methpv,const U32 flags)
1340 {
1341     HV* stash = gv_stashsv(namesv, 0);
1342
1343     PERL_ARGS_ASSERT_REQUIRE_TIE_MOD;
1344
1345     if (!stash || !(gv_fetchmethod_autoload(stash, methpv, FALSE))) {
1346         SV *module = newSVsv(namesv);
1347         char varname = *varpv; /* varpv might be clobbered by load_module,
1348                                   so save it. For the moment it's always
1349                                   a single char. */
1350         const char type = varname == '[' ? '$' : '%';
1351 #ifdef DEBUGGING
1352         dSP;
1353 #endif
1354         ENTER;
1355         SAVEFREESV(namesv);
1356         if ( flags & 1 )
1357             save_scalar(gv);
1358         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, module, NULL);
1359         assert(sp == PL_stack_sp);
1360         stash = gv_stashsv(namesv, 0);
1361         if (!stash)
1362             Perl_croak(aTHX_ "panic: Can't use %c%c because %"SVf" is not available",
1363                     type, varname, SVfARG(namesv));
1364         else if (!gv_fetchmethod(stash, methpv))
1365             Perl_croak(aTHX_ "panic: Can't use %c%c because %"SVf" does not support method %s",
1366                     type, varname, SVfARG(namesv), methpv);
1367         LEAVE;
1368     }
1369     else SvREFCNT_dec_NN(namesv);
1370     return stash;
1371 }
1372
1373 /*
1374 =for apidoc gv_stashpv
1375
1376 Returns a pointer to the stash for a specified package.  Uses C<strlen> to
1377 determine the length of C<name>, then calls C<gv_stashpvn()>.
1378
1379 =cut
1380 */
1381
1382 HV*
1383 Perl_gv_stashpv(pTHX_ const char *name, I32 create)
1384 {
1385     PERL_ARGS_ASSERT_GV_STASHPV;
1386     return gv_stashpvn(name, strlen(name), create);
1387 }
1388
1389 /*
1390 =for apidoc gv_stashpvn
1391
1392 Returns a pointer to the stash for a specified package.  The C<namelen>
1393 parameter indicates the length of the C<name>, in bytes.  C<flags> is passed
1394 to C<gv_fetchpvn_flags()>, so if set to C<GV_ADD> then the package will be
1395 created if it does not already exist.  If the package does not exist and
1396 C<flags> is 0 (or any other setting that does not create packages) then NULL
1397 is returned.
1398
1399 Flags may be one of:
1400
1401     GV_ADD
1402     SVf_UTF8
1403     GV_NOADD_NOINIT
1404     GV_NOINIT
1405     GV_NOEXPAND
1406     GV_ADDMG
1407
1408 The most important of which are probably GV_ADD and SVf_UTF8.
1409
1410 Note, use of C<gv_stashsv> instead of C<gv_stashpvn> where possible is strongly
1411 recommended for performance reasons.
1412
1413 =cut
1414 */
1415
1416 /*
1417 gv_stashpvn_internal
1418
1419 Perform the internal bits of gv_stashsvpvn_cached. You could think of this
1420 as being one half of the logic. Not to be called except from gv_stashsvpvn_cached().
1421
1422 */
1423
1424 PERL_STATIC_INLINE HV*
1425 S_gv_stashpvn_internal(pTHX_ const char *name, U32 namelen, I32 flags)
1426 {
1427     char smallbuf[128];
1428     char *tmpbuf;
1429     HV *stash;
1430     GV *tmpgv;
1431     U32 tmplen = namelen + 2;
1432
1433     PERL_ARGS_ASSERT_GV_STASHPVN_INTERNAL;
1434
1435     if (tmplen <= sizeof smallbuf)
1436         tmpbuf = smallbuf;
1437     else
1438         Newx(tmpbuf, tmplen, char);
1439     Copy(name, tmpbuf, namelen, char);
1440     tmpbuf[namelen]   = ':';
1441     tmpbuf[namelen+1] = ':';
1442     tmpgv = gv_fetchpvn_flags(tmpbuf, tmplen, flags, SVt_PVHV);
1443     if (tmpbuf != smallbuf)
1444         Safefree(tmpbuf);
1445     if (!tmpgv)
1446         return NULL;
1447     stash = GvHV(tmpgv);
1448     if (!(flags & ~GV_NOADD_MASK) && !stash) return NULL;
1449     assert(stash);
1450     if (!HvNAME_get(stash)) {
1451         hv_name_set(stash, name, namelen, flags & SVf_UTF8 ? SVf_UTF8 : 0 );
1452
1453         /* FIXME: This is a repeat of logic in gv_fetchpvn_flags */
1454         /* If the containing stash has multiple effective
1455            names, see that this one gets them, too. */
1456         if (HvAUX(GvSTASH(tmpgv))->xhv_name_count)
1457             mro_package_moved(stash, NULL, tmpgv, 1);
1458     }
1459     return stash;
1460 }
1461
1462 /*
1463 gv_stashsvpvn_cached
1464
1465 Returns a pointer to the stash for a specified package, possibly
1466 cached.  Implements both C<gv_stashpvn> and C<gc_stashsv>.
1467
1468 Requires one of either namesv or namepv to be non-null.
1469
1470 See C<gv_stashpvn> for details on "flags".
1471
1472 Note the sv interface is strongly preferred for performance reasons.
1473
1474 */
1475
1476 #define PERL_ARGS_ASSERT_GV_STASHSVPVN_CACHED \
1477     assert(namesv || name)
1478
1479 PERL_STATIC_INLINE HV*
1480 S_gv_stashsvpvn_cached(pTHX_ SV *namesv, const char *name, U32 namelen, I32 flags)
1481 {
1482     HV* stash;
1483     HE* he;
1484
1485     PERL_ARGS_ASSERT_GV_STASHSVPVN_CACHED;
1486
1487     he = (HE *)hv_common(
1488         PL_stashcache, namesv, name, namelen,
1489         (flags & SVf_UTF8) ? HVhek_UTF8 : 0, 0, NULL, 0
1490     );
1491
1492     if (he) return INT2PTR(HV*,SvIVX(HeVAL(he)));
1493     else if (flags & GV_CACHE_ONLY) return NULL;
1494
1495     if (namesv) {
1496         if (SvOK(namesv)) { /* prevent double uninit warning */
1497             STRLEN len;
1498             name = SvPV_const(namesv, len);
1499             namelen = len;
1500             flags |= SvUTF8(namesv);
1501         } else {
1502             name = ""; namelen = 0;
1503         }
1504     }
1505     stash = gv_stashpvn_internal(name, namelen, flags);
1506
1507     if (stash && namelen) {
1508         SV* const ref = newSViv(PTR2IV(stash));
1509         (void)hv_store(PL_stashcache, name,
1510             (flags & SVf_UTF8) ? -(I32)namelen : (I32)namelen, ref, 0);
1511     }
1512
1513     return stash;
1514 }
1515
1516 HV*
1517 Perl_gv_stashpvn(pTHX_ const char *name, U32 namelen, I32 flags)
1518 {
1519     PERL_ARGS_ASSERT_GV_STASHPVN;
1520     return gv_stashsvpvn_cached(NULL, name, namelen, flags);
1521 }
1522
1523 /*
1524 =for apidoc gv_stashsv
1525
1526 Returns a pointer to the stash for a specified package.  See C<gv_stashpvn>.
1527
1528 Note this interface is strongly preferred over C<gv_stashpvn> for performance reasons.
1529
1530 =cut
1531 */
1532
1533 HV*
1534 Perl_gv_stashsv(pTHX_ SV *sv, I32 flags)
1535 {
1536     PERL_ARGS_ASSERT_GV_STASHSV;
1537     return gv_stashsvpvn_cached(sv, NULL, 0, flags);
1538 }
1539
1540
1541 GV *
1542 Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, const svtype sv_type) {
1543     PERL_ARGS_ASSERT_GV_FETCHPV;
1544     return gv_fetchpvn_flags(nambeg, strlen(nambeg), add, sv_type);
1545 }
1546
1547 GV *
1548 Perl_gv_fetchsv(pTHX_ SV *name, I32 flags, const svtype sv_type) {
1549     STRLEN len;
1550     const char * const nambeg =
1551        SvPV_flags_const(name, len, flags & GV_NO_SVGMAGIC ? 0 : SV_GMAGIC);
1552     PERL_ARGS_ASSERT_GV_FETCHSV;
1553     return gv_fetchpvn_flags(nambeg, len, flags | SvUTF8(name), sv_type);
1554 }
1555
1556 PERL_STATIC_INLINE void
1557 S_gv_magicalize_isa(pTHX_ GV *gv)
1558 {
1559     AV* av;
1560
1561     PERL_ARGS_ASSERT_GV_MAGICALIZE_ISA;
1562
1563     av = GvAVn(gv);
1564     GvMULTI_on(gv);
1565     sv_magic(MUTABLE_SV(av), MUTABLE_SV(gv), PERL_MAGIC_isa,
1566              NULL, 0);
1567 }
1568
1569 /* This function grabs name and tries to split a stash and glob
1570  * from its contents. TODO better description, comments
1571  *
1572  * If the function returns TRUE and 'name == name_end', then
1573  * 'gv' can be directly returned to the caller of gv_fetchpvn_flags
1574  */
1575 PERL_STATIC_INLINE bool
1576 S_parse_gv_stash_name(pTHX_ HV **stash, GV **gv, const char **name,
1577                STRLEN *len, const char *nambeg, STRLEN full_len,
1578                const U32 is_utf8, const I32 add)
1579 {
1580     const char *name_cursor;
1581     const char *const name_end = nambeg + full_len;
1582     const char *const name_em1 = name_end - 1;
1583
1584     PERL_ARGS_ASSERT_PARSE_GV_STASH_NAME;
1585
1586     if (full_len > 2 && **name == '*' && isIDFIRST_lazy_if(*name + 1, is_utf8)) {
1587         /* accidental stringify on a GV? */
1588         (*name)++;
1589     }
1590
1591     for (name_cursor = *name; name_cursor < name_end; name_cursor++) {
1592         if (name_cursor < name_em1 &&
1593             ((*name_cursor == ':' && name_cursor[1] == ':')
1594            || *name_cursor == '\''))
1595         {
1596             if (!*stash)
1597                 *stash = PL_defstash;
1598             if (!*stash || !SvREFCNT(*stash)) /* symbol table under destruction */
1599                 return FALSE;
1600
1601             *len = name_cursor - *name;
1602             if (name_cursor > nambeg) { /* Skip for initial :: or ' */
1603                 const char *key;
1604                 GV**gvp;
1605                 if (*name_cursor == ':') {
1606                     key = *name;
1607                     *len += 2;
1608                 }
1609                 else {
1610                     char *tmpbuf;
1611                     Newx(tmpbuf, *len+2, char);
1612                     Copy(*name, tmpbuf, *len, char);
1613                     tmpbuf[(*len)++] = ':';
1614                     tmpbuf[(*len)++] = ':';
1615                     key = tmpbuf;
1616                 }
1617                 gvp = (GV**)hv_fetch(*stash, key, is_utf8 ? -((I32)*len) : (I32)*len, add);
1618                 *gv = gvp ? *gvp : NULL;
1619                 if (*gv && *gv != (const GV *)&PL_sv_undef) {
1620                     if (SvTYPE(*gv) != SVt_PVGV)
1621                         gv_init_pvn(*gv, *stash, key, *len, (add & GV_ADDMULTI)|is_utf8);
1622                     else
1623                         GvMULTI_on(*gv);
1624                 }
1625                 if (key != *name)
1626                     Safefree(key);
1627                 if (!*gv || *gv == (const GV *)&PL_sv_undef)
1628                     return FALSE;
1629
1630                 if (!(*stash = GvHV(*gv))) {
1631                     *stash = GvHV(*gv) = newHV();
1632                     if (!HvNAME_get(*stash)) {
1633                         if (GvSTASH(*gv) == PL_defstash && *len == 6
1634                             && strnEQ(*name, "CORE", 4))
1635                             hv_name_set(*stash, "CORE", 4, 0);
1636                         else
1637                             hv_name_set(
1638                                 *stash, nambeg, name_cursor-nambeg, is_utf8
1639                             );
1640                     /* If the containing stash has multiple effective
1641                     names, see that this one gets them, too. */
1642                     if (HvAUX(GvSTASH(*gv))->xhv_name_count)
1643                         mro_package_moved(*stash, NULL, *gv, 1);
1644                     }
1645                 }
1646                 else if (!HvNAME_get(*stash))
1647                     hv_name_set(*stash, nambeg, name_cursor - nambeg, is_utf8);
1648             }
1649
1650             if (*name_cursor == ':')
1651                 name_cursor++;
1652             *name = name_cursor+1;
1653             if (*name == name_end) {
1654                 if (!*gv)
1655                     *gv = MUTABLE_GV(*hv_fetchs(PL_defstash, "main::", TRUE));
1656                 return TRUE;
1657             }
1658         }
1659     }
1660     *len = name_cursor - *name;
1661     return TRUE;
1662 }
1663
1664 /* Checks if an unqualified name is in the main stash */
1665 PERL_STATIC_INLINE bool
1666 S_gv_is_in_main(pTHX_ const char *name, STRLEN len, const U32 is_utf8)
1667 {
1668     PERL_ARGS_ASSERT_GV_IS_IN_MAIN;
1669
1670     /* If it's an alphanumeric variable */
1671     if ( len && isIDFIRST_lazy_if(name, is_utf8) ) {
1672         /* Some "normal" variables are always in main::,
1673          * like INC or STDOUT.
1674          */
1675         switch (len) {
1676             case 1:
1677             if (*name == '_')
1678                 return TRUE;
1679             break;
1680             case 3:
1681             if ((name[0] == 'I' && name[1] == 'N' && name[2] == 'C')
1682                 || (name[0] == 'E' && name[1] == 'N' && name[2] == 'V')
1683                 || (name[0] == 'S' && name[1] == 'I' && name[2] == 'G'))
1684                 return TRUE;
1685             break;
1686             case 4:
1687             if (name[0] == 'A' && name[1] == 'R' && name[2] == 'G'
1688                 && name[3] == 'V')
1689                 return TRUE;
1690             break;
1691             case 5:
1692             if (name[0] == 'S' && name[1] == 'T' && name[2] == 'D'
1693                 && name[3] == 'I' && name[4] == 'N')
1694                 return TRUE;
1695             break;
1696             case 6:
1697             if ((name[0] == 'S' && name[1] == 'T' && name[2] == 'D')
1698                 &&((name[3] == 'O' && name[4] == 'U' && name[5] == 'T')
1699                     ||(name[3] == 'E' && name[4] == 'R' && name[5] == 'R')))
1700                 return TRUE;
1701             break;
1702             case 7:
1703             if (name[0] == 'A' && name[1] == 'R' && name[2] == 'G'
1704                 && name[3] == 'V' && name[4] == 'O' && name[5] == 'U'
1705                 && name[6] == 'T')
1706                 return TRUE;
1707             break;
1708         }
1709     }
1710     /* *{""}, or a special variable like $@ */
1711     else
1712         return TRUE;
1713
1714     return FALSE;
1715 }
1716
1717
1718 /* This function is called if parse_gv_stash_name() failed to
1719  * find a stash, or if GV_NOTQUAL or an empty name was passed
1720  * to gv_fetchpvn_flags.
1721  *
1722  * It returns FALSE if the default stash can't be found nor created,
1723  * which might happen during global destruction.
1724  */
1725 PERL_STATIC_INLINE bool
1726 S_find_default_stash(pTHX_ HV **stash, const char *name, STRLEN len,
1727                const U32 is_utf8, const I32 add,
1728                const svtype sv_type)
1729 {
1730     PERL_ARGS_ASSERT_FIND_DEFAULT_STASH;
1731
1732     /* No stash in name, so see how we can default */
1733
1734     if ( gv_is_in_main(name, len, is_utf8) ) {
1735         *stash = PL_defstash;
1736     }
1737     else {
1738         if (IN_PERL_COMPILETIME) {
1739             *stash = PL_curstash;
1740             if (add && (PL_hints & HINT_STRICT_VARS) &&
1741                 sv_type != SVt_PVCV &&
1742                 sv_type != SVt_PVGV &&
1743                 sv_type != SVt_PVFM &&
1744                 sv_type != SVt_PVIO &&
1745                 !(len == 1 && sv_type == SVt_PV &&
1746                 (*name == 'a' || *name == 'b')) )
1747             {
1748                 GV**gvp = (GV**)hv_fetch(*stash,name,is_utf8 ? -(I32)len : (I32)len,0);
1749                 if (!gvp || *gvp == (const GV *)&PL_sv_undef ||
1750                     SvTYPE(*gvp) != SVt_PVGV)
1751                 {
1752                     *stash = NULL;
1753                 }
1754                 else if ((sv_type == SVt_PV   && !GvIMPORTED_SV(*gvp)) ||
1755                          (sv_type == SVt_PVAV && !GvIMPORTED_AV(*gvp)) ||
1756                          (sv_type == SVt_PVHV && !GvIMPORTED_HV(*gvp)) )
1757                 {
1758                     /* diag_listed_as: Variable "%s" is not imported%s */
1759                     Perl_ck_warner_d(
1760                         aTHX_ packWARN(WARN_MISC),
1761                         "Variable \"%c%"UTF8f"\" is not imported",
1762                         sv_type == SVt_PVAV ? '@' :
1763                         sv_type == SVt_PVHV ? '%' : '$',
1764                         UTF8fARG(is_utf8, len, name));
1765                     if (GvCVu(*gvp))
1766                         Perl_ck_warner_d(
1767                             aTHX_ packWARN(WARN_MISC),
1768                             "\t(Did you mean &%"UTF8f" instead?)\n",
1769                             UTF8fARG(is_utf8, len, name)
1770                         );
1771                     *stash = NULL;
1772                 }
1773             }
1774         }
1775         else {
1776             /* Use the current op's stash */
1777             *stash = CopSTASH(PL_curcop);
1778         }
1779     }
1780
1781     if (!*stash) {
1782         if (add && !PL_in_clean_all) {
1783             GV *gv;
1784             qerror(Perl_mess(aTHX_
1785                  "Global symbol \"%s%"UTF8f
1786                  "\" requires explicit package name (did you forget to "
1787                  "declare \"my %s%"UTF8f"\"?)",
1788                  (sv_type == SVt_PV ? "$"
1789                   : sv_type == SVt_PVAV ? "@"
1790                   : sv_type == SVt_PVHV ? "%"
1791                   : ""), UTF8fARG(is_utf8, len, name),
1792                  (sv_type == SVt_PV ? "$"
1793                   : sv_type == SVt_PVAV ? "@"
1794                   : sv_type == SVt_PVHV ? "%"
1795                   : ""), UTF8fARG(is_utf8, len, name)));
1796             /* To maintain the output of errors after the strict exception
1797              * above, and to keep compat with older releases, rather than
1798              * placing the variables in the pad, we place
1799              * them in the <none>:: stash.
1800              */
1801             gv = gv_fetchpvs("<none>::", GV_ADDMULTI, SVt_PVHV);
1802             if (!gv) {
1803                 /* symbol table under destruction */
1804                 return FALSE;
1805             }
1806             *stash = GvHV(gv);
1807         }
1808         else
1809             return FALSE;
1810     }
1811
1812     if (!SvREFCNT(*stash))   /* symbol table under destruction */
1813         return FALSE;
1814
1815     return TRUE;
1816 }
1817
1818 /* gv_magicalize only turns on the SVf_READONLY flag, not SVf_PROTECT.  So
1819    redefine SvREADONLY_on for that purpose.  We don’t use it later on in
1820    this file.  */
1821 #undef SvREADONLY_on
1822 #define SvREADONLY_on(sv) (SvFLAGS(sv) |= SVf_READONLY)
1823
1824 /* gv_magicalize() is called by gv_fetchpvn_flags when creating
1825  * a new GV.
1826  * Note that it does not insert the GV into the stash prior to
1827  * magicalization, which some variables require need in order
1828  * to work (like $[, %+, %-, %!), so callers must take care of
1829  * that beforehand.
1830  *
1831  * The return value has a specific meaning for gv_fetchpvn_flags:
1832  * If it returns true, and the gv is empty, it indicates that its
1833  * refcount should be decreased.
1834  */
1835 PERL_STATIC_INLINE bool
1836 S_gv_magicalize(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len,
1837                bool addmg, const svtype sv_type)
1838 {
1839     SSize_t paren;
1840
1841     PERL_ARGS_ASSERT_GV_MAGICALIZE;
1842
1843     if (stash != PL_defstash) { /* not the main stash */
1844         /* We only have to check for a few names here: a, b, EXPORT, ISA
1845            and VERSION. All the others apply only to the main stash or to
1846            CORE (which is checked right after this). */
1847         if (len) {
1848             const char * const name2 = name + 1;
1849             switch (*name) {
1850             case 'E':
1851                 if (strnEQ(name2, "XPORT", 5))
1852                     GvMULTI_on(gv);
1853                 break;
1854             case 'I':
1855                 if (strEQ(name2, "SA"))
1856                     gv_magicalize_isa(gv);
1857                 break;
1858             case 'V':
1859                 if (strEQ(name2, "ERSION"))
1860                     GvMULTI_on(gv);
1861                 break;
1862             case 'a':
1863             case 'b':
1864                 if (len == 1 && sv_type == SVt_PV)
1865                     GvMULTI_on(gv);
1866                 /* FALLTHROUGH */
1867             default:
1868                 goto try_core;
1869             }
1870             return addmg;
1871         }
1872       try_core:
1873         if (len > 1 /* shortest is uc */ && HvNAMELEN_get(stash) == 4) {
1874           /* Avoid null warning: */
1875           const char * const stashname = HvNAME(stash); assert(stashname);
1876           if (strnEQ(stashname, "CORE", 4))
1877             S_maybe_add_coresub(aTHX_ 0, gv, name, len);
1878         }
1879     }
1880     else if (len > 1) {
1881 #ifndef EBCDIC
1882         if (*name > 'V' ) {
1883             NOOP;
1884             /* Nothing else to do.
1885                The compiler will probably turn the switch statement into a
1886                branch table. Make sure we avoid even that small overhead for
1887                the common case of lower case variable names.  (On EBCDIC
1888                platforms, we can't just do:
1889                  if (NATIVE_TO_ASCII(*name) > NATIVE_TO_ASCII('V') ) {
1890                because cases like '\027' in the switch statement below are
1891                C1 (non-ASCII) controls on those platforms, so the remapping
1892                would make them larger than 'V')
1893              */
1894         } else
1895 #endif
1896         {
1897             const char * name2 = name + 1;
1898             switch (*name) {
1899             case 'A':
1900                 if (strEQ(name2, "RGV")) {
1901                     IoFLAGS(GvIOn(gv)) |= IOf_ARGV|IOf_START;
1902                 }
1903                 else if (strEQ(name2, "RGVOUT")) {
1904                     GvMULTI_on(gv);
1905                 }
1906                 break;
1907             case 'E':
1908                 if (strnEQ(name2, "XPORT", 5))
1909                     GvMULTI_on(gv);
1910                 break;
1911             case 'I':
1912                 if (strEQ(name2, "SA")) {
1913                     gv_magicalize_isa(gv);
1914                 }
1915                 break;
1916             case 'S':
1917                 if (strEQ(name2, "IG")) {
1918                     HV *hv;
1919                     I32 i;
1920                     if (!PL_psig_name) {
1921                         Newxz(PL_psig_name, 2 * SIG_SIZE, SV*);
1922                         Newxz(PL_psig_pend, SIG_SIZE, int);
1923                         PL_psig_ptr = PL_psig_name + SIG_SIZE;
1924                     } else {
1925                         /* I think that the only way to get here is to re-use an
1926                            embedded perl interpreter, where the previous
1927                            use didn't clean up fully because
1928                            PL_perl_destruct_level was 0. I'm not sure that we
1929                            "support" that, in that I suspect in that scenario
1930                            there are sufficient other garbage values left in the
1931                            interpreter structure that something else will crash
1932                            before we get here. I suspect that this is one of
1933                            those "doctor, it hurts when I do this" bugs.  */
1934                         Zero(PL_psig_name, 2 * SIG_SIZE, SV*);
1935                         Zero(PL_psig_pend, SIG_SIZE, int);
1936                     }
1937                     GvMULTI_on(gv);
1938                     hv = GvHVn(gv);
1939                     hv_magic(hv, NULL, PERL_MAGIC_sig);
1940                     for (i = 1; i < SIG_SIZE; i++) {
1941                         SV * const * const init = hv_fetch(hv, PL_sig_name[i], strlen(PL_sig_name[i]), 1);
1942                         if (init)
1943                             sv_setsv(*init, &PL_sv_undef);
1944                     }
1945                 }
1946                 break;
1947             case 'V':
1948                 if (strEQ(name2, "ERSION"))
1949                     GvMULTI_on(gv);
1950                 break;
1951             case '\003':        /* $^CHILD_ERROR_NATIVE */
1952                 if (strEQ(name2, "HILD_ERROR_NATIVE"))
1953                     goto magicalize;
1954                 break;
1955             case '\005':        /* $^ENCODING */
1956                 if (*name2 == '_') {
1957                     name2++;
1958                 }
1959                 if (strEQ(name2, "NCODING"))
1960                     goto magicalize;
1961                 break;
1962             case '\007':        /* $^GLOBAL_PHASE */
1963                 if (strEQ(name2, "LOBAL_PHASE"))
1964                     goto ro_magicalize;
1965                 break;
1966             case '\014':        /* $^LAST_FH */
1967                 if (strEQ(name2, "AST_FH"))
1968                     goto ro_magicalize;
1969                 break;
1970             case '\015':        /* $^MATCH */
1971                 if (strEQ(name2, "ATCH")) {
1972                     paren = RX_BUFF_IDX_CARET_FULLMATCH;
1973                     goto storeparen;
1974                 }
1975                 break;
1976             case '\017':        /* $^OPEN */
1977                 if (strEQ(name2, "PEN"))
1978                     goto magicalize;
1979                 break;
1980             case '\020':        /* $^PREMATCH  $^POSTMATCH */
1981                 if (strEQ(name2, "REMATCH")) {
1982                     paren = RX_BUFF_IDX_CARET_PREMATCH;
1983                     goto storeparen;
1984                 }
1985                 if (strEQ(name2, "OSTMATCH")) {
1986                     paren = RX_BUFF_IDX_CARET_POSTMATCH;
1987                     goto storeparen;
1988                 }
1989                 break;
1990             case '\024':        /* ${^TAINT} */
1991                 if (strEQ(name2, "AINT"))
1992                     goto ro_magicalize;
1993                 break;
1994             case '\025':        /* ${^UNICODE}, ${^UTF8LOCALE} */
1995                 if (strEQ(name2, "NICODE"))
1996                     goto ro_magicalize;
1997                 if (strEQ(name2, "TF8LOCALE"))
1998                     goto ro_magicalize;
1999                 if (strEQ(name2, "TF8CACHE"))
2000                     goto magicalize;
2001                 break;
2002             case '\027':        /* $^WARNING_BITS */
2003                 if (strEQ(name2, "ARNING_BITS"))
2004                     goto magicalize;
2005                 break;
2006             case '1':
2007             case '2':
2008             case '3':
2009             case '4':
2010             case '5':
2011             case '6':
2012             case '7':
2013             case '8':
2014             case '9':
2015             {
2016                 /* Ensures that we have an all-digit variable, ${"1foo"} fails
2017                    this test  */
2018                 /* This snippet is taken from is_gv_magical */
2019                 const char *end = name + len;
2020                 while (--end > name) {
2021                     if (!isDIGIT(*end))
2022                         return addmg;
2023                 }
2024                 paren = grok_atou(name, NULL);
2025                 goto storeparen;
2026             }
2027             }
2028         }
2029     } else {
2030         /* Names of length 1.  (Or 0. But name is NUL terminated, so that will
2031            be case '\0' in this switch statement (ie a default case)  */
2032         switch (*name) {
2033         case '&':               /* $& */
2034             paren = RX_BUFF_IDX_FULLMATCH;
2035             goto sawampersand;
2036         case '`':               /* $` */
2037             paren = RX_BUFF_IDX_PREMATCH;
2038             goto sawampersand;
2039         case '\'':              /* $' */
2040             paren = RX_BUFF_IDX_POSTMATCH;
2041         sawampersand:
2042 #ifdef PERL_SAWAMPERSAND
2043             if (!(
2044                 sv_type == SVt_PVAV ||
2045                 sv_type == SVt_PVHV ||
2046                 sv_type == SVt_PVCV ||
2047                 sv_type == SVt_PVFM ||
2048                 sv_type == SVt_PVIO
2049                 )) { PL_sawampersand |=
2050                         (*name == '`')
2051                             ? SAWAMPERSAND_LEFT
2052                             : (*name == '&')
2053                                 ? SAWAMPERSAND_MIDDLE
2054                                 : SAWAMPERSAND_RIGHT;
2055                 }
2056 #endif
2057             goto storeparen;
2058         case '1':               /* $1 */
2059         case '2':               /* $2 */
2060         case '3':               /* $3 */
2061         case '4':               /* $4 */
2062         case '5':               /* $5 */
2063         case '6':               /* $6 */
2064         case '7':               /* $7 */
2065         case '8':               /* $8 */
2066         case '9':               /* $9 */
2067             paren = *name - '0';
2068
2069         storeparen:
2070             /* Flag the capture variables with a NULL mg_ptr
2071                Use mg_len for the array index to lookup.  */
2072             sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, NULL, paren);
2073             break;
2074
2075         case ':':               /* $: */
2076             sv_setpv(GvSVn(gv),PL_chopset);
2077             goto magicalize;
2078
2079         case '?':               /* $? */
2080 #ifdef COMPLEX_STATUS
2081             SvUPGRADE(GvSVn(gv), SVt_PVLV);
2082 #endif
2083             goto magicalize;
2084
2085         case '!':               /* $! */
2086             GvMULTI_on(gv);
2087             /* If %! has been used, automatically load Errno.pm. */
2088
2089             sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
2090
2091             /* magicalization must be done before require_tie_mod is called */
2092             if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
2093             {
2094                 require_tie_mod(gv, "!", newSVpvs("Errno"), "TIEHASH", 1);
2095                 addmg = FALSE;
2096             }
2097
2098             break;
2099         case '-':               /* $- */
2100         case '+':               /* $+ */
2101         GvMULTI_on(gv); /* no used once warnings here */
2102         {
2103             AV* const av = GvAVn(gv);
2104             SV* const avc = (*name == '+') ? MUTABLE_SV(av) : NULL;
2105
2106             sv_magic(MUTABLE_SV(av), avc, PERL_MAGIC_regdata, NULL, 0);
2107             sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
2108             if (avc)
2109                 SvREADONLY_on(GvSVn(gv));
2110             SvREADONLY_on(av);
2111
2112             if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
2113             {
2114                 require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "TIEHASH", 0);
2115                 addmg = FALSE;
2116             }
2117
2118             break;
2119         }
2120         case '*':               /* $* */
2121         case '#':               /* $# */
2122             if (sv_type == SVt_PV)
2123                 /* diag_listed_as: $* is no longer supported */
2124                 Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
2125                                  "$%c is no longer supported", *name);
2126             break;
2127         case '\010':    /* $^H */
2128             {
2129                 HV *const hv = GvHVn(gv);
2130                 hv_magic(hv, NULL, PERL_MAGIC_hints);
2131             }
2132             goto magicalize;
2133         case '[':               /* $[ */
2134             if ((sv_type == SVt_PV || sv_type == SVt_PVGV)
2135              && FEATURE_ARYBASE_IS_ENABLED) {
2136                 require_tie_mod(gv,name,newSVpvs("arybase"),"FETCH",0);
2137                 addmg = FALSE;
2138             }
2139             else goto magicalize;
2140             break;
2141         case '\023':    /* $^S */
2142         ro_magicalize:
2143             SvREADONLY_on(GvSVn(gv));
2144             /* FALLTHROUGH */
2145         case '0':               /* $0 */
2146         case '^':               /* $^ */
2147         case '~':               /* $~ */
2148         case '=':               /* $= */
2149         case '%':               /* $% */
2150         case '.':               /* $. */
2151         case '(':               /* $( */
2152         case ')':               /* $) */
2153         case '<':               /* $< */
2154         case '>':               /* $> */
2155         case '\\':              /* $\ */
2156         case '/':               /* $/ */
2157         case '|':               /* $| */
2158         case '$':               /* $$ */
2159         case '\001':    /* $^A */
2160         case '\003':    /* $^C */
2161         case '\004':    /* $^D */
2162         case '\005':    /* $^E */
2163         case '\006':    /* $^F */
2164         case '\011':    /* $^I, NOT \t in EBCDIC */
2165         case '\016':    /* $^N */
2166         case '\017':    /* $^O */
2167         case '\020':    /* $^P */
2168         case '\024':    /* $^T */
2169         case '\027':    /* $^W */
2170         magicalize:
2171             sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
2172             break;
2173
2174         case '\014':    /* $^L */
2175             sv_setpvs(GvSVn(gv),"\f");
2176             break;
2177         case ';':               /* $; */
2178             sv_setpvs(GvSVn(gv),"\034");
2179             break;
2180         case ']':               /* $] */
2181         {
2182             SV * const sv = GvSV(gv);
2183             if (!sv_derived_from(PL_patchlevel, "version"))
2184                 upg_version(PL_patchlevel, TRUE);
2185             GvSV(gv) = vnumify(PL_patchlevel);
2186             SvREADONLY_on(GvSV(gv));
2187             SvREFCNT_dec(sv);
2188         }
2189         break;
2190         case '\026':    /* $^V */
2191         {
2192             SV * const sv = GvSV(gv);
2193             GvSV(gv) = new_version(PL_patchlevel);
2194             SvREADONLY_on(GvSV(gv));
2195             SvREFCNT_dec(sv);
2196         }
2197         break;
2198         case 'a':
2199         case 'b':
2200             if (sv_type == SVt_PV)
2201                 GvMULTI_on(gv);
2202         }
2203     }
2204
2205     return addmg;
2206 }
2207
2208 /* If we do ever start using this later on in the file, we need to make
2209    sure we don’t accidentally use the wrong definition.  */
2210 #undef SvREADONLY_on
2211
2212 /* This function is called when the stash already holds the GV of the magic
2213  * variable we're looking for, but we need to check that it has the correct
2214  * kind of magic.  For example, if someone first uses $! and then %!, the
2215  * latter would end up here, and we add the Errno tie to the HASH slot of
2216  * the *! glob.
2217  */
2218 PERL_STATIC_INLINE void
2219 S_maybe_multimagic_gv(pTHX_ GV *gv, const char *name, const svtype sv_type)
2220 {
2221     PERL_ARGS_ASSERT_MAYBE_MULTIMAGIC_GV;
2222
2223     if (sv_type == SVt_PVHV || sv_type == SVt_PVGV) {
2224         if (*name == '!')
2225             require_tie_mod(gv, "!", newSVpvs("Errno"), "TIEHASH", 1);
2226         else if (*name == '-' || *name == '+')
2227             require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "TIEHASH", 0);
2228     } else if (sv_type == SVt_PV) {
2229         if (*name == '*' || *name == '#') {
2230             /* diag_listed_as: $* is no longer supported */
2231             Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED,
2232                                              WARN_SYNTAX),
2233                              "$%c is no longer supported", *name);
2234         }
2235     }
2236     if (sv_type==SVt_PV || sv_type==SVt_PVGV) {
2237       switch (*name) {
2238       case '[':
2239           require_tie_mod(gv,name,newSVpvs("arybase"),"FETCH",0);
2240           break;
2241 #ifdef PERL_SAWAMPERSAND
2242       case '`':
2243           PL_sawampersand |= SAWAMPERSAND_LEFT;
2244           (void)GvSVn(gv);
2245           break;
2246       case '&':
2247           PL_sawampersand |= SAWAMPERSAND_MIDDLE;
2248           (void)GvSVn(gv);
2249           break;
2250       case '\'':
2251           PL_sawampersand |= SAWAMPERSAND_RIGHT;
2252           (void)GvSVn(gv);
2253           break;
2254 #endif
2255       }
2256     }
2257 }
2258
2259 GV *
2260 Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
2261                        const svtype sv_type)
2262 {
2263     const char *name = nambeg;
2264     GV *gv = NULL;
2265     GV**gvp;
2266     STRLEN len;
2267     HV *stash = NULL;
2268     const I32 no_init = flags & (GV_NOADD_NOINIT | GV_NOINIT);
2269     const I32 no_expand = flags & GV_NOEXPAND;
2270     const I32 add = flags & ~GV_NOADD_MASK;
2271     const U32 is_utf8 = flags & SVf_UTF8;
2272     bool addmg = cBOOL(flags & GV_ADDMG);
2273     const char *const name_end = nambeg + full_len;
2274     U32 faking_it;
2275
2276     PERL_ARGS_ASSERT_GV_FETCHPVN_FLAGS;
2277
2278      /* If we have GV_NOTQUAL, the caller promised that
2279       * there is no stash, so we can skip the check.
2280       * Similarly if full_len is 0, since then we're
2281       * dealing with something like *{""} or ""->foo()
2282       */
2283     if ((flags & GV_NOTQUAL) || !full_len) {
2284         len = full_len;
2285     }
2286     else if (parse_gv_stash_name(&stash, &gv, &name, &len, nambeg, full_len, is_utf8, add)) {
2287         if (name == name_end) return gv;
2288     }
2289     else {
2290         return NULL;
2291     }
2292
2293     if (!stash && !find_default_stash(&stash, name, len, is_utf8, add, sv_type)) {
2294         return NULL;
2295     }
2296
2297     /* By this point we should have a stash and a name */
2298     gvp = (GV**)hv_fetch(stash,name,is_utf8 ? -(I32)len : (I32)len,add);
2299     if (!gvp || *gvp == (const GV *)&PL_sv_undef) {
2300         if (addmg) gv = (GV *)newSV(0);
2301         else return NULL;
2302     }
2303     else gv = *gvp, addmg = 0;
2304     /* From this point on, addmg means gv has not been inserted in the
2305        symtab yet. */
2306
2307     if (SvTYPE(gv) == SVt_PVGV) {
2308         /* The GV already exists, so return it, but check if we need to do
2309          * anything else with it before that.
2310          */
2311         if (add) {
2312             /* This is the heuristic that handles if a variable triggers the
2313              * 'used only once' warning.  If there's already a GV in the stash
2314              * with this name, then we assume that the variable has been used
2315              * before and turn its MULTI flag on.
2316              * It's a heuristic because it can easily be "tricked", like with
2317              * BEGIN { $a = 1; $::{foo} = *a }; () = $foo
2318              * not warning about $main::foo being used just once
2319              */
2320             GvMULTI_on(gv);
2321             gv_init_svtype(gv, sv_type);
2322             /* You reach this path once the typeglob has already been created,
2323                either by the same or a different sigil.  If this path didn't
2324                exist, then (say) referencing $! first, and %! second would
2325                mean that %! was not handled correctly.  */
2326             if (len == 1 && stash == PL_defstash) {
2327                 maybe_multimagic_gv(gv, name, sv_type);
2328             }
2329             else if (len == 3 && sv_type == SVt_PVAV
2330                   && strnEQ(name, "ISA", 3)
2331                   && (!GvAV(gv) || !SvSMAGICAL(GvAV(gv))))
2332                 gv_magicalize_isa(gv);
2333         }
2334         return gv;
2335     } else if (no_init) {
2336         assert(!addmg);
2337         return gv;
2338     }
2339     /* If GV_NOEXPAND is true and what we got off the stash is a ref,
2340      * don't expand it to a glob. This is an optimization so that things
2341      * copying constants over, like Exporter, don't have to be rewritten
2342      * to take into account that you can store more than just globs in
2343      * stashes.
2344      */
2345     else if (no_expand && SvROK(gv)) {
2346         assert(!addmg);
2347         return gv;
2348     }
2349
2350     /* Adding a new symbol.
2351        Unless of course there was already something non-GV here, in which case
2352        we want to behave as if there was always a GV here, containing some sort
2353        of subroutine.
2354        Otherwise we run the risk of creating things like GvIO, which can cause
2355        subtle bugs. eg the one that tripped up SQL::Translator  */
2356
2357     faking_it = SvOK(gv);
2358
2359     if (add & GV_ADDWARN)
2360         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
2361                 "Had to create %"UTF8f" unexpectedly",
2362                  UTF8fARG(is_utf8, name_end-nambeg, nambeg));
2363     gv_init_pvn(gv, stash, name, len, (add & GV_ADDMULTI)|is_utf8);
2364
2365     if ( isIDFIRST_lazy_if(name, is_utf8) && !ckWARN(WARN_ONCE) )
2366         GvMULTI_on(gv) ;
2367
2368     /* First, store the gv in the symtab if we're adding magic,
2369      * but only for non-empty GVs
2370      */
2371 #define GvEMPTY(gv)      !(GvAV(gv) || GvHV(gv) || GvIO(gv) \
2372                         || GvCV(gv) || (GvSV(gv) && SvOK(GvSV(gv))))
2373
2374     if ( addmg && !GvEMPTY(gv) ) {
2375         (void)hv_store(stash,name,len,(SV *)gv,0);
2376     }
2377
2378     /* set up magic where warranted */
2379     if ( gv_magicalize(gv, stash, name, len, addmg, sv_type) ) {
2380         /* See 23496c6 */
2381         if (GvEMPTY(gv)) {
2382             if ( GvSV(gv) && SvMAGICAL(GvSV(gv)) ) {
2383                 /* The GV was and still is "empty", except that now
2384                  * it has the magic flags turned on, so we want it
2385                  * stored in the symtab.
2386                  */
2387                 (void)hv_store(stash,name,len,(SV *)gv,0);
2388             }
2389             else {
2390                 /* Most likely the temporary GV created above */
2391                 SvREFCNT_dec_NN(gv);
2392                 gv = NULL;
2393             }
2394         }
2395     }
2396
2397     if (gv) gv_init_svtype(gv, faking_it ? SVt_PVCV : sv_type);
2398     return gv;
2399 }
2400
2401 void
2402 Perl_gv_fullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
2403 {
2404     const char *name;
2405     const HV * const hv = GvSTASH(gv);
2406
2407     PERL_ARGS_ASSERT_GV_FULLNAME4;
2408
2409     sv_setpv(sv, prefix ? prefix : "");
2410
2411     if (hv && (name = HvNAME(hv))) {
2412       const STRLEN len = HvNAMELEN(hv);
2413       if (keepmain || strnNE(name, "main", len)) {
2414         sv_catpvn_flags(sv,name,len,HvNAMEUTF8(hv)?SV_CATUTF8:SV_CATBYTES);
2415         sv_catpvs(sv,"::");
2416       }
2417     }
2418     else sv_catpvs(sv,"__ANON__::");
2419     sv_catsv(sv,sv_2mortal(newSVhek(GvNAME_HEK(gv))));
2420 }
2421
2422 void
2423 Perl_gv_efullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
2424 {
2425     const GV * const egv = GvEGVx(gv);
2426
2427     PERL_ARGS_ASSERT_GV_EFULLNAME4;
2428
2429     gv_fullname4(sv, egv ? egv : gv, prefix, keepmain);
2430 }
2431
2432
2433 /* recursively scan a stash and any nested stashes looking for entries
2434  * that need the "only used once" warning raised
2435  */
2436
2437 void
2438 Perl_gv_check(pTHX_ HV *stash)
2439 {
2440     I32 i;
2441
2442     PERL_ARGS_ASSERT_GV_CHECK;
2443
2444     if (!HvARRAY(stash))
2445         return;
2446
2447     assert(SvOOK(stash));
2448
2449     for (i = 0; i <= (I32) HvMAX(stash); i++) {
2450         const HE *entry;
2451         /* mark stash is being scanned, to avoid recursing */
2452         HvAUX(stash)->xhv_aux_flags |= HvAUXf_SCAN_STASH;
2453         for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
2454             GV *gv;
2455             HV *hv;
2456             if (HeKEY(entry)[HeKLEN(entry)-1] == ':' &&
2457                 (gv = MUTABLE_GV(HeVAL(entry))) && isGV(gv) && (hv = GvHV(gv)))
2458             {
2459                 if (hv != PL_defstash && hv != stash
2460                     && !(SvOOK(hv)
2461                         && (HvAUX(hv)->xhv_aux_flags & HvAUXf_SCAN_STASH))
2462                 )
2463                      gv_check(hv);              /* nested package */
2464             }
2465             else if ( *HeKEY(entry) != '_'
2466                         && isIDFIRST_lazy_if(HeKEY(entry), HeUTF8(entry)) ) {
2467                 const char *file;
2468                 gv = MUTABLE_GV(HeVAL(entry));
2469                 if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv))
2470                     continue;
2471                 file = GvFILE(gv);
2472                 CopLINE_set(PL_curcop, GvLINE(gv));
2473 #ifdef USE_ITHREADS
2474                 CopFILE(PL_curcop) = (char *)file;      /* set for warning */
2475 #else
2476                 CopFILEGV(PL_curcop)
2477                     = gv_fetchfile_flags(file, HEK_LEN(GvFILE_HEK(gv)), 0);
2478 #endif
2479                 Perl_warner(aTHX_ packWARN(WARN_ONCE),
2480                         "Name \"%"HEKf"::%"HEKf
2481                         "\" used only once: possible typo",
2482                             HEKfARG(HvNAME_HEK(stash)),
2483                             HEKfARG(GvNAME_HEK(gv)));
2484             }
2485         }
2486         HvAUX(stash)->xhv_aux_flags &= ~HvAUXf_SCAN_STASH;
2487     }
2488 }
2489
2490 GV *
2491 Perl_newGVgen_flags(pTHX_ const char *pack, U32 flags)
2492 {
2493     PERL_ARGS_ASSERT_NEWGVGEN_FLAGS;
2494     assert(!(flags & ~SVf_UTF8));
2495
2496     return gv_fetchpv(Perl_form(aTHX_ "%"UTF8f"::_GEN_%ld",
2497                                 UTF8fARG(flags, strlen(pack), pack),
2498                                 (long)PL_gensym++),
2499                       GV_ADD, SVt_PVGV);
2500 }
2501
2502 /* hopefully this is only called on local symbol table entries */
2503
2504 GP*
2505 Perl_gp_ref(pTHX_ GP *gp)
2506 {
2507     if (!gp)
2508         return NULL;
2509     gp->gp_refcnt++;
2510     if (gp->gp_cv) {
2511         if (gp->gp_cvgen) {
2512             /* If the GP they asked for a reference to contains
2513                a method cache entry, clear it first, so that we
2514                don't infect them with our cached entry */
2515             SvREFCNT_dec_NN(gp->gp_cv);
2516             gp->gp_cv = NULL;
2517             gp->gp_cvgen = 0;
2518         }
2519     }
2520     return gp;
2521 }
2522
2523 void
2524 Perl_gp_free(pTHX_ GV *gv)
2525 {
2526     GP* gp;
2527     int attempts = 100;
2528
2529     if (!gv || !isGV_with_GP(gv) || !(gp = GvGP(gv)))
2530         return;
2531     if (gp->gp_refcnt == 0) {
2532         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
2533                          "Attempt to free unreferenced glob pointers"
2534                          pTHX__FORMAT pTHX__VALUE);
2535         return;
2536     }
2537     if (gp->gp_refcnt > 1) {
2538        borrowed:
2539         if (gp->gp_egv == gv)
2540             gp->gp_egv = 0;
2541         gp->gp_refcnt--;
2542         GvGP_set(gv, NULL);
2543         return;
2544     }
2545
2546     while (1) {
2547       /* Copy and null out all the glob slots, so destructors do not see
2548          freed SVs. */
2549       HEK * const file_hek = gp->gp_file_hek;
2550       SV  * const sv       = gp->gp_sv;
2551       AV  * const av       = gp->gp_av;
2552       HV  * const hv       = gp->gp_hv;
2553       IO  * const io       = gp->gp_io;
2554       CV  * const cv       = gp->gp_cv;
2555       CV  * const form     = gp->gp_form;
2556
2557       gp->gp_file_hek = NULL;
2558       gp->gp_sv       = NULL;
2559       gp->gp_av       = NULL;
2560       gp->gp_hv       = NULL;
2561       gp->gp_io       = NULL;
2562       gp->gp_cv       = NULL;
2563       gp->gp_form     = NULL;
2564
2565       if (file_hek)
2566         unshare_hek(file_hek);
2567
2568       SvREFCNT_dec(sv);
2569       SvREFCNT_dec(av);
2570       /* FIXME - another reference loop GV -> symtab -> GV ?
2571          Somehow gp->gp_hv can end up pointing at freed garbage.  */
2572       if (hv && SvTYPE(hv) == SVt_PVHV) {
2573         const HEK *hvname_hek = HvNAME_HEK(hv);
2574         DEBUG_o(Perl_deb(aTHX_ "gp_free clearing PL_stashcache for '%"HEKf"'\n", HEKfARG(hvname_hek)));
2575         if (PL_stashcache && hvname_hek)
2576            (void)hv_deletehek(PL_stashcache, hvname_hek, G_DISCARD);
2577         SvREFCNT_dec(hv);
2578       }
2579       if (io && SvREFCNT(io) == 1 && IoIFP(io)
2580              && (IoTYPE(io) == IoTYPE_WRONLY ||
2581                  IoTYPE(io) == IoTYPE_RDWR   ||
2582                  IoTYPE(io) == IoTYPE_APPEND)
2583              && ckWARN_d(WARN_IO)
2584              && IoIFP(io) != PerlIO_stdin()
2585              && IoIFP(io) != PerlIO_stdout()
2586              && IoIFP(io) != PerlIO_stderr()
2587              && !(IoFLAGS(io) & IOf_FAKE_DIRP))
2588         io_close(io, gv, FALSE, TRUE);
2589       SvREFCNT_dec(io);
2590       SvREFCNT_dec(cv);
2591       SvREFCNT_dec(form);
2592
2593       /* Possibly reallocated by a destructor */
2594       gp = GvGP(gv);
2595
2596       if (!gp->gp_file_hek
2597        && !gp->gp_sv
2598        && !gp->gp_av
2599        && !gp->gp_hv
2600        && !gp->gp_io
2601        && !gp->gp_cv
2602        && !gp->gp_form) break;
2603
2604       if (--attempts == 0) {
2605         Perl_die(aTHX_
2606           "panic: gp_free failed to free glob pointer - "
2607           "something is repeatedly re-creating entries"
2608         );
2609       }
2610     }
2611
2612     /* Possibly incremented by a destructor doing glob assignment */
2613     if (gp->gp_refcnt > 1) goto borrowed;
2614     Safefree(gp);
2615     GvGP_set(gv, NULL);
2616 }
2617
2618 int
2619 Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg)
2620 {
2621     AMT * const amtp = (AMT*)mg->mg_ptr;
2622     PERL_UNUSED_ARG(sv);
2623
2624     PERL_ARGS_ASSERT_MAGIC_FREEOVRLD;
2625
2626     if (amtp && AMT_AMAGIC(amtp)) {
2627         int i;
2628         for (i = 1; i < NofAMmeth; i++) {
2629             CV * const cv = amtp->table[i];
2630             if (cv) {
2631                 SvREFCNT_dec_NN(MUTABLE_SV(cv));
2632                 amtp->table[i] = NULL;
2633             }
2634         }
2635     }
2636  return 0;
2637 }
2638
2639 /* Updates and caches the CV's */
2640 /* Returns:
2641  * 1 on success and there is some overload
2642  * 0 if there is no overload
2643  * -1 if some error occurred and it couldn't croak
2644  */
2645
2646 int
2647 Perl_Gv_AMupdate(pTHX_ HV *stash, bool destructing)
2648 {
2649   MAGIC* const mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
2650   AMT amt;
2651   const struct mro_meta* stash_meta = HvMROMETA(stash);
2652   U32 newgen;
2653
2654   PERL_ARGS_ASSERT_GV_AMUPDATE;
2655
2656   newgen = PL_sub_generation + stash_meta->pkg_gen + stash_meta->cache_gen;
2657   if (mg) {
2658       const AMT * const amtp = (AMT*)mg->mg_ptr;
2659       if (amtp->was_ok_sub == newgen) {
2660           return AMT_AMAGIC(amtp) ? 1 : 0;
2661       }
2662       sv_unmagic(MUTABLE_SV(stash), PERL_MAGIC_overload_table);
2663   }
2664
2665   DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME_get(stash)) );
2666
2667   Zero(&amt,1,AMT);
2668   amt.was_ok_sub = newgen;
2669   amt.fallback = AMGfallNO;
2670   amt.flags = 0;
2671
2672   {
2673     int filled = 0;
2674     int i;
2675     bool deref_seen = 0;
2676
2677
2678     /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
2679
2680     /* Try to find via inheritance. */
2681     GV *gv = gv_fetchmeth_pvn(stash, PL_AMG_names[0], 2, -1, 0);
2682     SV * const sv = gv ? GvSV(gv) : NULL;
2683     CV* cv;
2684
2685     if (!gv)
2686     {
2687       if (!gv_fetchmeth_pvn(stash, "((", 2, -1, 0))
2688         goto no_table;
2689     }
2690 #ifdef PERL_DONT_CREATE_GVSV
2691     else if (!sv) {
2692         NOOP;   /* Equivalent to !SvTRUE and !SvOK  */
2693     }
2694 #endif
2695     else if (SvTRUE(sv))
2696         /* don't need to set overloading here because fallback => 1
2697          * is the default setting for classes without overloading */
2698         amt.fallback=AMGfallYES;
2699     else if (SvOK(sv)) {
2700         amt.fallback=AMGfallNEVER;
2701         filled = 1;
2702     }
2703     else {
2704         filled = 1;
2705     }
2706
2707     assert(SvOOK(stash));
2708     /* initially assume the worst */
2709     HvAUX(stash)->xhv_aux_flags &= ~HvAUXf_NO_DEREF;
2710
2711     for (i = 1; i < NofAMmeth; i++) {
2712         const char * const cooky = PL_AMG_names[i];
2713         /* Human-readable form, for debugging: */
2714         const char * const cp = AMG_id2name(i);
2715         const STRLEN l = PL_AMG_namelens[i];
2716
2717         DEBUG_o( Perl_deb(aTHX_ "Checking overloading of \"%s\" in package \"%.256s\"\n",
2718                      cp, HvNAME_get(stash)) );
2719         /* don't fill the cache while looking up!
2720            Creation of inheritance stubs in intermediate packages may
2721            conflict with the logic of runtime method substitution.
2722            Indeed, for inheritance A -> B -> C, if C overloads "+0",
2723            then we could have created stubs for "(+0" in A and C too.
2724            But if B overloads "bool", we may want to use it for
2725            numifying instead of C's "+0". */
2726         gv = Perl_gv_fetchmeth_pvn(aTHX_ stash, cooky, l, -1, 0);
2727         cv = 0;
2728         if (gv && (cv = GvCV(gv)) && CvHASGV(cv)) {
2729             const HEK * const gvhek =
2730                 CvNAMED(cv) ? CvNAME_HEK(cv) : GvNAME_HEK(CvGV(cv));
2731             const HEK * const stashek =
2732                 HvNAME_HEK(CvNAMED(cv) ? CvSTASH(cv) : GvSTASH(CvGV(cv)));
2733             if (HEK_LEN(gvhek) == 3 && strEQ(HEK_KEY(gvhek), "nil")
2734              && stashek && HEK_LEN(stashek) == 8
2735              && strEQ(HEK_KEY(stashek), "overload")) {
2736                 /* This is a hack to support autoloading..., while
2737                    knowing *which* methods were declared as overloaded. */
2738                 /* GvSV contains the name of the method. */
2739                 GV *ngv = NULL;
2740                 SV *gvsv = GvSV(gv);
2741
2742                 DEBUG_o( Perl_deb(aTHX_ "Resolving method \"%"SVf256\
2743                         "\" for overloaded \"%s\" in package \"%.256s\"\n",
2744                              (void*)GvSV(gv), cp, HvNAME(stash)) );
2745                 if (!gvsv || !SvPOK(gvsv)
2746                     || !(ngv = gv_fetchmethod_sv_flags(stash, gvsv, 0)))
2747                 {
2748                     /* Can be an import stub (created by "can"). */
2749                     if (destructing) {
2750                         return -1;
2751                     }
2752                     else {
2753                         const SV * const name = (gvsv && SvPOK(gvsv))
2754                                                     ? gvsv
2755                                                     : newSVpvs_flags("???", SVs_TEMP);
2756                         /* diag_listed_as: Can't resolve method "%s" overloading "%s" in package "%s" */
2757                         Perl_croak(aTHX_ "%s method \"%"SVf256
2758                                     "\" overloading \"%s\" "\
2759                                     "in package \"%"HEKf256"\"",
2760                                    (GvCVGEN(gv) ? "Stub found while resolving"
2761                                     : "Can't resolve"),
2762                                    SVfARG(name), cp,
2763                                    HEKfARG(
2764                                         HvNAME_HEK(stash)
2765                                    ));
2766                     }
2767                 }
2768                 cv = GvCV(gv = ngv);
2769             }
2770             DEBUG_o( Perl_deb(aTHX_ "Overloading \"%s\" in package \"%.256s\" via \"%.256s::%.256s\"\n",
2771                          cp, HvNAME_get(stash), HvNAME_get(GvSTASH(CvGV(cv))),
2772                          GvNAME(CvGV(cv))) );
2773             filled = 1;
2774         } else if (gv) {                /* Autoloaded... */
2775             cv = MUTABLE_CV(gv);
2776             filled = 1;
2777         }
2778         amt.table[i]=MUTABLE_CV(SvREFCNT_inc_simple(cv));
2779
2780         if (gv) {
2781             switch (i) {
2782             case to_sv_amg:
2783             case to_av_amg:
2784             case to_hv_amg:
2785             case to_gv_amg:
2786             case to_cv_amg:
2787             case nomethod_amg:
2788                 deref_seen = 1;
2789                 break;
2790             }
2791         }
2792     }
2793     if (!deref_seen)
2794         /* none of @{} etc overloaded; we can do $obj->[N] quicker.
2795          * NB - aux var invalid here, HvARRAY() could have been
2796          * reallocated since it was assigned to */
2797         HvAUX(stash)->xhv_aux_flags |= HvAUXf_NO_DEREF;
2798
2799     if (filled) {
2800       AMT_AMAGIC_on(&amt);
2801       sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table,
2802                                                 (char*)&amt, sizeof(AMT));
2803       return TRUE;
2804     }
2805   }
2806   /* Here we have no table: */
2807  no_table:
2808   AMT_AMAGIC_off(&amt);
2809   sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table,
2810                                                 (char*)&amt, sizeof(AMTS));
2811   return 0;
2812 }
2813
2814
2815 CV*
2816 Perl_gv_handler(pTHX_ HV *stash, I32 id)
2817 {
2818     MAGIC *mg;
2819     AMT *amtp;
2820     U32 newgen;
2821     struct mro_meta* stash_meta;
2822
2823     if (!stash || !HvNAME_get(stash))
2824         return NULL;
2825
2826     stash_meta = HvMROMETA(stash);
2827     newgen = PL_sub_generation + stash_meta->pkg_gen + stash_meta->cache_gen;
2828
2829     mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
2830     if (!mg) {
2831       do_update:
2832         if (Gv_AMupdate(stash, 0) == -1)
2833             return NULL;
2834         mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
2835     }
2836     assert(mg);
2837     amtp = (AMT*)mg->mg_ptr;
2838     if ( amtp->was_ok_sub != newgen )
2839         goto do_update;
2840     if (AMT_AMAGIC(amtp)) {
2841         CV * const ret = amtp->table[id];
2842         if (ret && isGV(ret)) {         /* Autoloading stab */
2843             /* Passing it through may have resulted in a warning
2844                "Inherited AUTOLOAD for a non-method deprecated", since
2845                our caller is going through a function call, not a method call.
2846                So return the CV for AUTOLOAD, setting $AUTOLOAD. */
2847             GV * const gv = gv_fetchmethod(stash, PL_AMG_names[id]);
2848
2849             if (gv && GvCV(gv))
2850                 return GvCV(gv);
2851         }
2852         return ret;
2853     }
2854
2855     return NULL;
2856 }
2857
2858
2859 /* Implement tryAMAGICun_MG macro.
2860    Do get magic, then see if the stack arg is overloaded and if so call it.
2861    Flags:
2862         AMGf_set     return the arg using SETs rather than assigning to
2863                      the targ
2864         AMGf_numeric apply sv_2num to the stack arg.
2865 */
2866
2867 bool
2868 Perl_try_amagic_un(pTHX_ int method, int flags) {
2869     dSP;
2870     SV* tmpsv;
2871     SV* const arg = TOPs;
2872
2873     SvGETMAGIC(arg);
2874
2875     if (SvAMAGIC(arg) && (tmpsv = amagic_call(arg, &PL_sv_undef, method,
2876                                               AMGf_noright | AMGf_unary))) {
2877         if (flags & AMGf_set) {
2878             SETs(tmpsv);
2879         }
2880         else {
2881             dTARGET;
2882             if (SvPADMY(TARG)) {
2883                 sv_setsv(TARG, tmpsv);
2884                 SETTARG;
2885             }
2886             else
2887                 SETs(tmpsv);
2888         }
2889         PUTBACK;
2890         return TRUE;
2891     }
2892
2893     if ((flags & AMGf_numeric) && SvROK(arg))
2894         *sp = sv_2num(arg);
2895     return FALSE;
2896 }
2897
2898
2899 /* Implement tryAMAGICbin_MG macro.
2900    Do get magic, then see if the two stack args are overloaded and if so
2901    call it.
2902    Flags:
2903         AMGf_set     return the arg using SETs rather than assigning to
2904                      the targ
2905         AMGf_assign  op may be called as mutator (eg +=)
2906         AMGf_numeric apply sv_2num to the stack arg.
2907 */
2908
2909 bool
2910 Perl_try_amagic_bin(pTHX_ int method, int flags) {
2911     dSP;
2912     SV* const left = TOPm1s;
2913     SV* const right = TOPs;
2914
2915     SvGETMAGIC(left);
2916     if (left != right)
2917         SvGETMAGIC(right);
2918
2919     if (SvAMAGIC(left) || SvAMAGIC(right)) {
2920         SV * const tmpsv = amagic_call(left, right, method,
2921                     ((flags & AMGf_assign) && opASSIGN ? AMGf_assign: 0));
2922         if (tmpsv) {
2923             if (flags & AMGf_set) {
2924                 (void)POPs;
2925                 SETs(tmpsv);
2926             }
2927             else {
2928                 dATARGET;
2929                 (void)POPs;
2930                 if (opASSIGN || SvPADMY(TARG)) {
2931                     sv_setsv(TARG, tmpsv);
2932                     SETTARG;
2933                 }
2934                 else
2935                     SETs(tmpsv);
2936             }
2937             PUTBACK;
2938             return TRUE;
2939         }
2940     }
2941     if(left==right && SvGMAGICAL(left)) {
2942         SV * const left = sv_newmortal();
2943         *(sp-1) = left;
2944         /* Print the uninitialized warning now, so it includes the vari-
2945            able name. */
2946         if (!SvOK(right)) {
2947             if (ckWARN(WARN_UNINITIALIZED)) report_uninit(right);
2948             sv_setsv_flags(left, &PL_sv_no, 0);
2949         }
2950         else sv_setsv_flags(left, right, 0);
2951         SvGETMAGIC(right);
2952     }
2953     if (flags & AMGf_numeric) {
2954         if (SvROK(TOPm1s))
2955             *(sp-1) = sv_2num(TOPm1s);
2956         if (SvROK(right))
2957             *sp     = sv_2num(right);
2958     }
2959     return FALSE;
2960 }
2961
2962 SV *
2963 Perl_amagic_deref_call(pTHX_ SV *ref, int method) {
2964     SV *tmpsv = NULL;
2965     HV *stash;
2966
2967     PERL_ARGS_ASSERT_AMAGIC_DEREF_CALL;
2968
2969     if (!SvAMAGIC(ref))
2970         return ref;
2971     /* return quickly if none of the deref ops are overloaded */
2972     stash = SvSTASH(SvRV(ref));
2973     assert(SvOOK(stash));
2974     if (HvAUX(stash)->xhv_aux_flags & HvAUXf_NO_DEREF)
2975         return ref;
2976
2977     while ((tmpsv = amagic_call(ref, &PL_sv_undef, method,
2978                                 AMGf_noright | AMGf_unary))) {
2979         if (!SvROK(tmpsv))
2980             Perl_croak(aTHX_ "Overloaded dereference did not return a reference");
2981         if (tmpsv == ref || SvRV(tmpsv) == SvRV(ref)) {
2982             /* Bail out if it returns us the same reference.  */
2983             return tmpsv;
2984         }
2985         ref = tmpsv;
2986         if (!SvAMAGIC(ref))
2987             break;
2988     }
2989     return tmpsv ? tmpsv : ref;
2990 }
2991
2992 bool
2993 Perl_amagic_is_enabled(pTHX_ int method)
2994 {
2995       SV *lex_mask = cop_hints_fetch_pvs(PL_curcop, "overloading", 0);
2996
2997       assert(PL_curcop->cop_hints & HINT_NO_AMAGIC);
2998
2999       if ( !lex_mask || !SvOK(lex_mask) )
3000           /* overloading lexically disabled */
3001           return FALSE;
3002       else if ( lex_mask && SvPOK(lex_mask) ) {
3003           /* we have an entry in the hints hash, check if method has been
3004            * masked by overloading.pm */
3005           STRLEN len;
3006           const int offset = method / 8;
3007           const int bit    = method % 8;
3008           char *pv = SvPV(lex_mask, len);
3009
3010           /* Bit set, so this overloading operator is disabled */
3011           if ( (STRLEN)offset < len && pv[offset] & ( 1 << bit ) )
3012               return FALSE;
3013       }
3014       return TRUE;
3015 }
3016
3017 SV*
3018 Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
3019 {
3020   dVAR;
3021   MAGIC *mg;
3022   CV *cv=NULL;
3023   CV **cvp=NULL, **ocvp=NULL;
3024   AMT *amtp=NULL, *oamtp=NULL;
3025   int off = 0, off1, lr = 0, notfound = 0;
3026   int postpr = 0, force_cpy = 0;
3027   int assign = AMGf_assign & flags;
3028   const int assignshift = assign ? 1 : 0;
3029   int use_default_op = 0;
3030   int force_scalar = 0;
3031 #ifdef DEBUGGING
3032   int fl=0;
3033 #endif
3034   HV* stash=NULL;
3035
3036   PERL_ARGS_ASSERT_AMAGIC_CALL;
3037
3038   if ( PL_curcop->cop_hints & HINT_NO_AMAGIC ) {
3039       if (!amagic_is_enabled(method)) return NULL;
3040   }
3041
3042   if (!(AMGf_noleft & flags) && SvAMAGIC(left)
3043       && (stash = SvSTASH(SvRV(left))) && Gv_AMG(stash)
3044       && (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table))
3045       && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
3046                         ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
3047                         : NULL))
3048       && ((cv = cvp[off=method+assignshift])
3049           || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
3050                                                           * usual method */
3051                   (
3052 #ifdef DEBUGGING
3053                    fl = 1,
3054 #endif
3055                    cv = cvp[off=method])))) {
3056     lr = -1;                    /* Call method for left argument */
3057   } else {
3058     if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) {
3059       int logic;
3060
3061       /* look for substituted methods */
3062       /* In all the covered cases we should be called with assign==0. */
3063          switch (method) {
3064          case inc_amg:
3065            force_cpy = 1;
3066            if ((cv = cvp[off=add_ass_amg])
3067                || ((cv = cvp[off = add_amg]) && (force_cpy = 0, postpr = 1))) {
3068              right = &PL_sv_yes; lr = -1; assign = 1;
3069            }
3070            break;
3071          case dec_amg:
3072            force_cpy = 1;
3073            if ((cv = cvp[off = subtr_ass_amg])
3074                || ((cv = cvp[off = subtr_amg]) && (force_cpy = 0, postpr=1))) {
3075              right = &PL_sv_yes; lr = -1; assign = 1;
3076            }
3077            break;
3078          case bool__amg:
3079            (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg]));
3080            break;
3081          case numer_amg:
3082            (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg]));
3083            break;
3084          case string_amg:
3085            (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg]));
3086            break;
3087          case not_amg:
3088            (void)((cv = cvp[off=bool__amg])
3089                   || (cv = cvp[off=numer_amg])
3090                   || (cv = cvp[off=string_amg]));
3091            if (cv)
3092                postpr = 1;
3093            break;
3094          case copy_amg:
3095            {
3096              /*
3097                   * SV* ref causes confusion with the interpreter variable of
3098                   * the same name
3099                   */
3100              SV* const tmpRef=SvRV(left);
3101              if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) {
3102                 /*
3103                  * Just to be extra cautious.  Maybe in some
3104                  * additional cases sv_setsv is safe, too.
3105                  */
3106                 SV* const newref = newSVsv(tmpRef);
3107                 SvOBJECT_on(newref);
3108                 /* No need to do SvAMAGIC_on here, as SvAMAGIC macros
3109                    delegate to the stash. */
3110                 SvSTASH_set(newref, MUTABLE_HV(SvREFCNT_inc(SvSTASH(tmpRef))));
3111                 return newref;
3112              }
3113            }
3114            break;
3115          case abs_amg:
3116            if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg])
3117                && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) {
3118              SV* const nullsv=sv_2mortal(newSViv(0));
3119              if (off1==lt_amg) {
3120                SV* const lessp = amagic_call(left,nullsv,
3121                                        lt_amg,AMGf_noright);
3122                logic = SvTRUE(lessp);
3123              } else {
3124                SV* const lessp = amagic_call(left,nullsv,
3125                                        ncmp_amg,AMGf_noright);
3126                logic = (SvNV(lessp) < 0);
3127              }
3128              if (logic) {
3129                if (off==subtr_amg) {
3130                  right = left;
3131                  left = nullsv;
3132                  lr = 1;
3133                }
3134              } else {
3135                return left;
3136              }
3137            }
3138            break;
3139          case neg_amg:
3140            if ((cv = cvp[off=subtr_amg])) {
3141              right = left;
3142              left = sv_2mortal(newSViv(0));
3143              lr = 1;
3144            }
3145            break;
3146          case int_amg:
3147          case iter_amg:                 /* XXXX Eventually should do to_gv. */
3148          case ftest_amg:                /* XXXX Eventually should do to_gv. */
3149          case regexp_amg:
3150              /* FAIL safe */
3151              return NULL;       /* Delegate operation to standard mechanisms. */
3152
3153          case to_sv_amg:
3154          case to_av_amg:
3155          case to_hv_amg:
3156          case to_gv_amg:
3157          case to_cv_amg:
3158              /* FAIL safe */
3159              return left;       /* Delegate operation to standard mechanisms. */
3160
3161          default:
3162            goto not_found;
3163          }
3164          if (!cv) goto not_found;
3165     } else if (!(AMGf_noright & flags) && SvAMAGIC(right)
3166                && (stash = SvSTASH(SvRV(right))) && Gv_AMG(stash)
3167                && (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table))
3168                && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
3169                           ? (amtp = (AMT*)mg->mg_ptr)->table
3170                           : NULL))
3171                && (cv = cvp[off=method])) { /* Method for right
3172                                              * argument found */
3173       lr=1;
3174     } else if (((cvp && amtp->fallback > AMGfallNEVER)
3175                 || (ocvp && oamtp->fallback > AMGfallNEVER))
3176                && !(flags & AMGf_unary)) {
3177                                 /* We look for substitution for
3178                                  * comparison operations and
3179                                  * concatenation */
3180       if (method==concat_amg || method==concat_ass_amg
3181           || method==repeat_amg || method==repeat_ass_amg) {
3182         return NULL;            /* Delegate operation to string conversion */
3183       }
3184       off = -1;
3185       switch (method) {
3186          case lt_amg:
3187          case le_amg:
3188          case gt_amg:
3189          case ge_amg:
3190          case eq_amg:
3191          case ne_amg:
3192              off = ncmp_amg;
3193              break;
3194          case slt_amg:
3195          case sle_amg:
3196          case sgt_amg:
3197          case sge_amg:
3198          case seq_amg:
3199          case sne_amg:
3200              off = scmp_amg;
3201              break;
3202          }
3203       if (off != -1) {
3204           if (ocvp && (oamtp->fallback > AMGfallNEVER)) {
3205               cv = ocvp[off];
3206               lr = -1;
3207           }
3208           if (!cv && (cvp && amtp->fallback > AMGfallNEVER)) {
3209               cv = cvp[off];
3210               lr = 1;
3211           }
3212       }
3213       if (cv)
3214           postpr = 1;
3215       else
3216           goto not_found;
3217     } else {
3218     not_found:                  /* No method found, either report or croak */
3219       switch (method) {
3220          case to_sv_amg:
3221          case to_av_amg:
3222          case to_hv_amg:
3223          case to_gv_amg:
3224          case to_cv_amg:
3225              /* FAIL safe */
3226              return left;       /* Delegate operation to standard mechanisms. */
3227       }
3228       if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */
3229         notfound = 1; lr = -1;
3230       } else if (cvp && (cv=cvp[nomethod_amg])) {
3231         notfound = 1; lr = 1;
3232       } else if ((use_default_op =
3233                   (!ocvp || oamtp->fallback >= AMGfallYES)
3234                   && (!cvp || amtp->fallback >= AMGfallYES))
3235                  && !DEBUG_o_TEST) {
3236         /* Skip generating the "no method found" message.  */
3237         return NULL;
3238       } else {
3239         SV *msg;
3240         if (off==-1) off=method;
3241         msg = sv_2mortal(Perl_newSVpvf(aTHX_
3242                       "Operation \"%s\": no method found,%sargument %s%"SVf"%s%"SVf,
3243                       AMG_id2name(method + assignshift),
3244                       (flags & AMGf_unary ? " " : "\n\tleft "),
3245                       SvAMAGIC(left)?
3246                         "in overloaded package ":
3247                         "has no overloaded magic",
3248                       SvAMAGIC(left)?
3249                         SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(SvSTASH(SvRV(left)))))):
3250                         SVfARG(&PL_sv_no),
3251                       SvAMAGIC(right)?
3252                         ",\n\tright argument in overloaded package ":
3253                         (flags & AMGf_unary
3254                          ? ""
3255                          : ",\n\tright argument has no overloaded magic"),
3256                       SvAMAGIC(right)?
3257                         SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(SvSTASH(SvRV(right)))))):
3258                         SVfARG(&PL_sv_no)));
3259         if (use_default_op) {
3260           DEBUG_o( Perl_deb(aTHX_ "%"SVf, SVfARG(msg)) );
3261         } else {
3262           Perl_croak(aTHX_ "%"SVf, SVfARG(msg));
3263         }
3264         return NULL;
3265       }
3266       force_cpy = force_cpy || assign;
3267     }
3268   }
3269
3270   switch (method) {
3271     /* in these cases, we're calling '+' or '-' as a fallback for a ++ or --
3272      * operation. we need this to return a value, so that it can be assigned
3273      * later on, in the postpr block (case inc_amg/dec_amg), even if the
3274      * increment or decrement was itself called in void context */
3275     case inc_amg:
3276       if (off == add_amg)
3277         force_scalar = 1;
3278       break;
3279     case dec_amg:
3280       if (off == subtr_amg)
3281         force_scalar = 1;
3282       break;
3283     /* in these cases, we're calling an assignment variant of an operator
3284      * (+= rather than +, for instance). regardless of whether it's a
3285      * fallback or not, it always has to return a value, which will be
3286      * assigned to the proper variable later */
3287     case add_amg:
3288     case subtr_amg:
3289     case mult_amg:
3290     case div_amg:
3291     case modulo_amg:
3292     case pow_amg:
3293     case lshift_amg:
3294     case rshift_amg:
3295     case repeat_amg:
3296     case concat_amg:
3297     case band_amg:
3298     case bor_amg:
3299     case bxor_amg:
3300       if (assign)
3301         force_scalar = 1;
3302       break;
3303     /* the copy constructor always needs to return a value */
3304     case copy_amg:
3305       force_scalar = 1;
3306       break;
3307     /* because of the way these are implemented (they don't perform the
3308      * dereferencing themselves, they return a reference that perl then
3309      * dereferences later), they always have to be in scalar context */
3310     case to_sv_amg:
3311     case to_av_amg:
3312     case to_hv_amg:
3313     case to_gv_amg:
3314     case to_cv_amg:
3315       force_scalar = 1;
3316       break;
3317     /* these don't have an op of their own; they're triggered by their parent
3318      * op, so the context there isn't meaningful ('$a and foo()' in void
3319      * context still needs to pass scalar context on to $a's bool overload) */
3320     case bool__amg:
3321     case numer_amg:
3322     case string_amg:
3323       force_scalar = 1;
3324       break;
3325   }
3326
3327 #ifdef DEBUGGING
3328   if (!notfound) {
3329     DEBUG_o(Perl_deb(aTHX_
3330                      "Overloaded operator \"%s\"%s%s%s:\n\tmethod%s found%s in package %"SVf"%s\n",
3331                      AMG_id2name(off),
3332                      method+assignshift==off? "" :
3333                      " (initially \"",
3334                      method+assignshift==off? "" :
3335                      AMG_id2name(method+assignshift),
3336                      method+assignshift==off? "" : "\")",
3337                      flags & AMGf_unary? "" :
3338                      lr==1 ? " for right argument": " for left argument",
3339                      flags & AMGf_unary? " for argument" : "",
3340                      stash ? SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(stash)))) : SVfARG(newSVpvs_flags("null", SVs_TEMP)),
3341                      fl? ",\n\tassignment variant used": "") );
3342   }
3343 #endif
3344     /* Since we use shallow copy during assignment, we need
3345      * to dublicate the contents, probably calling user-supplied
3346      * version of copy operator
3347      */
3348     /* We need to copy in following cases:
3349      * a) Assignment form was called.
3350      *          assignshift==1,  assign==T, method + 1 == off
3351      * b) Increment or decrement, called directly.
3352      *          assignshift==0,  assign==0, method + 0 == off
3353      * c) Increment or decrement, translated to assignment add/subtr.
3354      *          assignshift==0,  assign==T,
3355      *          force_cpy == T
3356      * d) Increment or decrement, translated to nomethod.
3357      *          assignshift==0,  assign==0,
3358      *          force_cpy == T
3359      * e) Assignment form translated to nomethod.
3360      *          assignshift==1,  assign==T, method + 1 != off
3361      *          force_cpy == T
3362      */
3363     /*  off is method, method+assignshift, or a result of opcode substitution.
3364      *  In the latter case assignshift==0, so only notfound case is important.
3365      */
3366   if ( (lr == -1) && ( ( (method + assignshift == off)
3367         && (assign || (method == inc_amg) || (method == dec_amg)))
3368       || force_cpy) )
3369   {
3370       /* newSVsv does not behave as advertised, so we copy missing
3371        * information by hand */
3372       SV *tmpRef = SvRV(left);
3373       SV *rv_copy;
3374       if (SvREFCNT(tmpRef) > 1 && (rv_copy = AMG_CALLunary(left,copy_amg))) {
3375           SvRV_set(left, rv_copy);
3376           SvSETMAGIC(left);
3377           SvREFCNT_dec_NN(tmpRef);
3378       }
3379   }
3380
3381   {
3382     dSP;
3383     BINOP myop;
3384     SV* res;
3385     const bool oldcatch = CATCH_GET;
3386     I32 oldmark, nret;
3387     int gimme = force_scalar ? G_SCALAR : GIMME_V;
3388
3389     CATCH_SET(TRUE);
3390     Zero(&myop, 1, BINOP);
3391     myop.op_last = (OP *) &myop;
3392     myop.op_next = NULL;
3393     myop.op_flags = OPf_STACKED;
3394
3395     switch (gimme) {
3396         case G_VOID:
3397             myop.op_flags |= OPf_WANT_VOID;
3398             break;
3399         case G_ARRAY:
3400             if (flags & AMGf_want_list) {
3401                 myop.op_flags |= OPf_WANT_LIST;
3402                 break;
3403             }
3404             /* FALLTHROUGH */
3405         default:
3406             myop.op_flags |= OPf_WANT_SCALAR;
3407             break;
3408     }
3409
3410     PUSHSTACKi(PERLSI_OVERLOAD);
3411     ENTER;
3412     SAVEOP();
3413     PL_op = (OP *) &myop;
3414     if (PERLDB_SUB && PL_curstash != PL_debstash)
3415         PL_op->op_private |= OPpENTERSUB_DB;
3416     Perl_pp_pushmark(aTHX);
3417
3418     EXTEND(SP, notfound + 5);
3419     PUSHs(lr>0? right: left);
3420     PUSHs(lr>0? left: right);
3421     PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no ));
3422     if (notfound) {
3423       PUSHs(newSVpvn_flags(AMG_id2name(method + assignshift),
3424                            AMG_id2namelen(method + assignshift), SVs_TEMP));
3425     }
3426     PUSHs(MUTABLE_SV(cv));
3427     PUTBACK;
3428     oldmark = TOPMARK;
3429
3430     if ((PL_op = PL_ppaddr[OP_ENTERSUB](aTHX)))
3431       CALLRUNOPS(aTHX);
3432     LEAVE;
3433     SPAGAIN;
3434     nret = SP - (PL_stack_base + oldmark);
3435
3436     switch (gimme) {
3437         case G_VOID:
3438             /* returning NULL has another meaning, and we check the context
3439              * at the call site too, so this can be differentiated from the
3440              * scalar case */
3441             res = &PL_sv_undef;
3442             SP = PL_stack_base + oldmark;
3443             break;
3444         case G_ARRAY: {
3445             if (flags & AMGf_want_list) {
3446                 res = sv_2mortal((SV *)newAV());
3447                 av_extend((AV *)res, nret);
3448                 while (nret--)
3449                     av_store((AV *)res, nret, POPs);
3450                 break;
3451             }
3452             /* FALLTHROUGH */
3453         }
3454         default:
3455             res = POPs;
3456             break;
3457     }
3458
3459     PUTBACK;
3460     POPSTACK;
3461     CATCH_SET(oldcatch);
3462
3463     if (postpr) {
3464       int ans;
3465       switch (method) {
3466       case le_amg:
3467       case sle_amg:
3468         ans=SvIV(res)<=0; break;
3469       case lt_amg:
3470       case slt_amg:
3471         ans=SvIV(res)<0; break;
3472       case ge_amg:
3473       case sge_amg:
3474         ans=SvIV(res)>=0; break;
3475       case gt_amg:
3476       case sgt_amg:
3477         ans=SvIV(res)>0; break;
3478       case eq_amg:
3479       case seq_amg:
3480         ans=SvIV(res)==0; break;
3481       case ne_amg:
3482       case sne_amg:
3483         ans=SvIV(res)!=0; break;
3484       case inc_amg:
3485       case dec_amg:
3486         SvSetSV(left,res); return left;
3487       case not_amg:
3488         ans=!SvTRUE(res); break;
3489       default:
3490         ans=0; break;
3491       }
3492       return boolSV(ans);
3493     } else if (method==copy_amg) {
3494       if (!SvROK(res)) {
3495         Perl_croak(aTHX_ "Copy method did not return a reference");
3496       }
3497       return SvREFCNT_inc(SvRV(res));
3498     } else {
3499       return res;
3500     }
3501   }
3502 }
3503
3504 void
3505 Perl_gv_name_set(pTHX_ GV *gv, const char *name, U32 len, U32 flags)
3506 {
3507     dVAR;
3508     U32 hash;
3509
3510     PERL_ARGS_ASSERT_GV_NAME_SET;
3511
3512     if (len > I32_MAX)
3513         Perl_croak(aTHX_ "panic: gv name too long (%"UVuf")", (UV) len);
3514
3515     if (!(flags & GV_ADD) && GvNAME_HEK(gv)) {
3516         unshare_hek(GvNAME_HEK(gv));
3517     }
3518
3519     PERL_HASH(hash, name, len);
3520     GvNAME_HEK(gv) = share_hek(name, (flags & SVf_UTF8 ? -(I32)len : (I32)len), hash);
3521 }
3522
3523 /*
3524 =for apidoc gv_try_downgrade
3525
3526 If the typeglob C<gv> can be expressed more succinctly, by having
3527 something other than a real GV in its place in the stash, replace it
3528 with the optimised form.  Basic requirements for this are that C<gv>
3529 is a real typeglob, is sufficiently ordinary, and is only referenced
3530 from its package.  This function is meant to be used when a GV has been
3531 looked up in part to see what was there, causing upgrading, but based
3532 on what was found it turns out that the real GV isn't required after all.
3533
3534 If C<gv> is a completely empty typeglob, it is deleted from the stash.
3535
3536 If C<gv> is a typeglob containing only a sufficiently-ordinary constant
3537 sub, the typeglob is replaced with a scalar-reference placeholder that
3538 more compactly represents the same thing.
3539
3540 =cut
3541 */
3542
3543 void
3544 Perl_gv_try_downgrade(pTHX_ GV *gv)
3545 {
3546     HV *stash;
3547     CV *cv;
3548     HEK *namehek;
3549     SV **gvp;
3550     PERL_ARGS_ASSERT_GV_TRY_DOWNGRADE;
3551
3552     /* XXX Why and where does this leave dangling pointers during global
3553        destruction? */
3554     if (PL_phase == PERL_PHASE_DESTRUCT) return;
3555
3556     if (!(SvREFCNT(gv) == 1 && SvTYPE(gv) == SVt_PVGV && !SvFAKE(gv) &&
3557             !SvOBJECT(gv) && !SvREADONLY(gv) &&
3558             isGV_with_GP(gv) && GvGP(gv) &&
3559             !GvINTRO(gv) && GvREFCNT(gv) == 1 &&
3560             !GvSV(gv) && !GvAV(gv) && !GvHV(gv) && !GvIOp(gv) && !GvFORM(gv) &&
3561             GvEGVx(gv) == gv && (stash = GvSTASH(gv))))
3562         return;
3563     if (gv == PL_statgv || gv == PL_last_in_gv || gv == PL_stderrgv)
3564         return;
3565     if (SvMAGICAL(gv)) {
3566         MAGIC *mg;
3567         /* only backref magic is allowed */
3568         if (SvGMAGICAL(gv) || SvSMAGICAL(gv))
3569             return;
3570         for (mg = SvMAGIC(gv); mg; mg = mg->mg_moremagic) {
3571             if (mg->mg_type != PERL_MAGIC_backref)
3572                 return;
3573         }
3574     }
3575     cv = GvCV(gv);
3576     if (!cv) {
3577         HEK *gvnhek = GvNAME_HEK(gv);
3578         (void)hv_deletehek(stash, gvnhek, G_DISCARD);
3579     } else if (GvMULTI(gv) && cv && SvREFCNT(cv) == 1 &&
3580             !SvOBJECT(cv) && !SvMAGICAL(cv) && !SvREADONLY(cv) &&
3581             CvSTASH(cv) == stash && !CvNAMED(cv) && CvGV(cv) == gv &&
3582             CvCONST(cv) && !CvMETHOD(cv) && !CvLVALUE(cv) && !CvUNIQUE(cv) &&
3583             !CvNODEBUG(cv) && !CvCLONE(cv) && !CvCLONED(cv) && !CvANON(cv) &&
3584             (namehek = GvNAME_HEK(gv)) &&
3585             (gvp = hv_fetchhek(stash, namehek, 0)) &&
3586             *gvp == (SV*)gv) {
3587         SV *value = SvREFCNT_inc(CvXSUBANY(cv).any_ptr);
3588         const bool imported = !!GvIMPORTED_CV(gv);
3589         SvREFCNT(gv) = 0;
3590         sv_clear((SV*)gv);
3591         SvREFCNT(gv) = 1;
3592         SvFLAGS(gv) = SVt_IV|SVf_ROK|SVprv_PCS_IMPORTED * imported;
3593
3594         /* See also: 'SET_SVANY_FOR_BODYLESS_IV' in sv.c */
3595         SvANY(gv) = (XPVGV*)((char*)&(gv->sv_u.svu_iv) -
3596                                 STRUCT_OFFSET(XPVIV, xiv_iv));
3597         SvRV_set(gv, value);
3598     }
3599 }
3600
3601 GV *
3602 Perl_gv_override(pTHX_ const char * const name, const STRLEN len)
3603 {
3604     GV *gv = gv_fetchpvn(name, len, GV_NOTQUAL, SVt_PVCV);
3605     GV * const *gvp;
3606     PERL_ARGS_ASSERT_GV_OVERRIDE;
3607     if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) return gv;
3608     gvp = (GV**)hv_fetch(PL_globalstash, name, len, FALSE);
3609     gv = gvp ? *gvp : NULL;
3610     if (gv && !isGV(gv)) {
3611         if (!SvPCS_IMPORTED(gv)) return NULL;
3612         gv_init(gv, PL_globalstash, name, len, 0);
3613         return gv;
3614     }
3615     return gv && GvCVu(gv) && GvIMPORTED_CV(gv) ? gv : NULL;
3616 }
3617
3618 #include "XSUB.h"
3619
3620 static void
3621 core_xsub(pTHX_ CV* cv)
3622 {
3623     Perl_croak(aTHX_
3624        "&CORE::%s cannot be called directly", GvNAME(CvGV(cv))
3625     );
3626 }
3627
3628 /*
3629  * Local variables:
3630  * c-indentation-style: bsd
3631  * c-basic-offset: 4
3632  * indent-tabs-mode: nil
3633  * End:
3634  *
3635  * ex: set ts=8 sts=4 sw=4 et:
3636  */