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