/repo: perl-5.22.2/gv.c comparison

comparison perl-5.22.2/gv.c @ 8045:a16537d2fe07

<xfix> tar xf perl-5.22.2.tar.gz # Ah, whatever, I\'m doing it anyway

author	HackBot
date	Sat, 14 May 2016 14:54:38 +0000
parents
children

comparison

equal deleted inserted replaced

-:711c038a7dce
+:a16537d2fe07
+/*    gv.c
+*
+*    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
+*    2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 by Larry Wall and others
+*
+*    You may distribute under the terms of either the GNU General Public
+*    License or the Artistic License, as specified in the README file.
+*
+*/
+/*
+*   'Mercy!' cried Gandalf.  'If the giving of information is to be the cure
+* of your inquisitiveness, I shall spend all the rest of my days in answering
+* you.  What more do you want to know?'
+*   'The names of all the stars, and of all living things, and the whole
+* history of Middle-earth and Over-heaven and of the Sundering Seas,'
+* laughed Pippin.
+*
+*     [p.599 of _The Lord of the Rings_, III/xi: "The Palantír"]
+*/
+/*
+=head1 GV Functions
+A GV is a structure which corresponds to to a Perl typeglob, ie *foo.
+It is a structure that holds a pointer to a scalar, an array, a hash etc,
+corresponding to $foo, @foo, %foo.
+GVs are usually found as values in stashes (symbol table hashes) where
+Perl stores its global variables.
+=cut
+*/
+#include "EXTERN.h"
+#define PERL_IN_GV_C
+#include "perl.h"
+#include "overload.c"
+#include "keywords.h"
+#include "feature.h"
+static const char S_autoload[] = "AUTOLOAD";
+#define S_autolen (sizeof("AUTOLOAD")-1)
+GV *
+Perl_gv_add_by_type(pTHX_ GV *gv, svtype type)
+{
+SV **where;
+if (
+!gv
+|| (
+SvTYPE((const SV *)gv) != SVt_PVGV
+&& SvTYPE((const SV *)gv) != SVt_PVLV
+)
+) {
+	const char *what;
+	if (type == SVt_PVIO) {
+	    /*
+	     * if it walks like a dirhandle, then let's assume that
+	     * this is a dirhandle.
+	     */
+	    what = OP_IS_DIRHOP(PL_op->op_type) ?
+		"dirhandle" : "filehandle";
+	} else if (type == SVt_PVHV) {
+	    what = "hash";
+	} else {
+	    what = type == SVt_PVAV ? "array" : "scalar";
+	}
+	/* diag_listed_as: Bad symbol for filehandle */
+	Perl_croak(aTHX_ "Bad symbol for %s", what);
+}
+if (type == SVt_PVHV) {
+	where = (SV **)&GvHV(gv);
+} else if (type == SVt_PVAV) {
+	where = (SV **)&GvAV(gv);
+} else if (type == SVt_PVIO) {
+	where = (SV **)&GvIOp(gv);
+} else {
+	where = &GvSV(gv);
+}
+if (!*where)
+{
+	*where = newSV_type(type);
+	    if (type == SVt_PVAV && GvNAMELEN(gv) == 3
+	     && strnEQ(GvNAME(gv), "ISA", 3))
+	    sv_magic(*where, (SV *)gv, PERL_MAGIC_isa, NULL, 0);
+}
+return gv;
+}
+GV *
+Perl_gv_fetchfile(pTHX_ const char *name)
+{
+PERL_ARGS_ASSERT_GV_FETCHFILE;
+return gv_fetchfile_flags(name, strlen(name), 0);
+}
+GV *
+Perl_gv_fetchfile_flags(pTHX_ const char *const name, const STRLEN namelen,
+			const U32 flags)
+{
+char smallbuf[128];
+char *tmpbuf;
+const STRLEN tmplen = namelen + 2;
+GV *gv;
+PERL_ARGS_ASSERT_GV_FETCHFILE_FLAGS;
+PERL_UNUSED_ARG(flags);
+if (!PL_defstash)
+	return NULL;
+if (tmplen <= sizeof smallbuf)
+	tmpbuf = smallbuf;
+else
+	Newx(tmpbuf, tmplen, char);
+/* This is where the debugger's %{"::_<$filename"} hash is created */
+tmpbuf[0] = '_';
+tmpbuf[1] = '<';
+memcpy(tmpbuf + 2, name, namelen);
+gv = *(GV**)hv_fetch(PL_defstash, tmpbuf, tmplen, TRUE);
+if (!isGV(gv)) {
+	gv_init(gv, PL_defstash, tmpbuf, tmplen, FALSE);
+#ifdef PERL_DONT_CREATE_GVSV
+	GvSV(gv) = newSVpvn(name, namelen);
+#else
+	sv_setpvn(GvSV(gv), name, namelen);
+#endif
+}
+if ((PERLDB_LINE || PERLDB_SAVESRC) && !GvAV(gv))
+	    hv_magic(GvHVn(gv), GvAVn(gv), PERL_MAGIC_dbfile);
+if (tmpbuf != smallbuf)
+	Safefree(tmpbuf);
+return gv;
+}
+/*
+=for apidoc gv_const_sv
+If C<gv> is a typeglob whose subroutine entry is a constant sub eligible for
+inlining, or C<gv> is a placeholder reference that would be promoted to such
+a typeglob, then returns the value returned by the sub.  Otherwise, returns
+NULL.
+=cut
+*/
+SV *
+Perl_gv_const_sv(pTHX_ GV *gv)
+{
+PERL_ARGS_ASSERT_GV_CONST_SV;
+PERL_UNUSED_CONTEXT;
+if (SvTYPE(gv) == SVt_PVGV)
+	return cv_const_sv(GvCVu(gv));
+return SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVAV && SvTYPE(SvRV(gv)) != SVt_PVCV ? SvRV(gv) : NULL;
+}
+GP *
+Perl_newGP(pTHX_ GV *const gv)
+{
+GP *gp;
+U32 hash;
+const char *file;
+STRLEN len;
+#ifndef USE_ITHREADS
+GV *filegv;
+#endif
+dVAR;
+PERL_ARGS_ASSERT_NEWGP;
+Newxz(gp, 1, GP);
+gp->gp_egv = gv; /* allow compiler to reuse gv after this */
+#ifndef PERL_DONT_CREATE_GVSV
+gp->gp_sv = newSV(0);
+#endif
+/* PL_curcop may be null here.  E.g.,
+	INIT { bless {} and exit }
+frees INIT before looking up DESTROY (and creating *DESTROY)
+*/
+if (PL_curcop) {
+	gp->gp_line = CopLINE(PL_curcop); /* 0 otherwise Newxz */
+#ifdef USE_ITHREADS
+	if (CopFILE(PL_curcop)) {
+	    file = CopFILE(PL_curcop);
+	    len = strlen(file);
+	}
+#else
+	filegv = CopFILEGV(PL_curcop);
+	if (filegv) {
+	    file = GvNAME(filegv)+2;
+	    len = GvNAMELEN(filegv)-2;
+	}
+#endif
+	else goto no_file;
+}
+else {
+	no_file:
+	file = "";
+	len = 0;
+}
+PERL_HASH(hash, file, len);
+gp->gp_file_hek = share_hek(file, len, hash);
+gp->gp_refcnt = 1;
+return gp;
+}
+/* Assign CvGV(cv) = gv, handling weak references.
+* See also S_anonymise_cv_maybe */
+void
+Perl_cvgv_set(pTHX_ CV* cv, GV* gv)
+{
+GV * const oldgv = CvNAMED(cv) ? NULL : SvANY(cv)->xcv_gv_u.xcv_gv;
+HEK *hek;
+PERL_ARGS_ASSERT_CVGV_SET;
+if (oldgv == gv)
+	return;
+if (oldgv) {
+	if (CvCVGV_RC(cv)) {
+	    SvREFCNT_dec_NN(oldgv);
+	    CvCVGV_RC_off(cv);
+	}
+	else {
+	    sv_del_backref(MUTABLE_SV(oldgv), MUTABLE_SV(cv));
+	}
+}
+else if ((hek = CvNAME_HEK(cv))) {
+	unshare_hek(hek);
+	CvLEXICAL_off(cv);
+}
+CvNAMED_off(cv);
+SvANY(cv)->xcv_gv_u.xcv_gv = gv;
+assert(!CvCVGV_RC(cv));
+if (!gv)
+	return;
+if (isGV_with_GP(gv) && GvGP(gv) && (GvCV(gv) == cv || GvFORM(gv) == cv))
+	Perl_sv_add_backref(aTHX_ MUTABLE_SV(gv), MUTABLE_SV(cv));
+else {
+	CvCVGV_RC_on(cv);
+	SvREFCNT_inc_simple_void_NN(gv);
+}
+}
+/* Convert CvSTASH + CvNAME_HEK into a GV.  Conceptually, all subs have a
+GV, but for efficiency that GV may not in fact exist.  This function,
+called by CvGV, reifies it. */
+GV *
+Perl_cvgv_from_hek(pTHX_ CV *cv)
+{
+GV *gv;
+SV **svp;
+PERL_ARGS_ASSERT_CVGV_FROM_HEK;
+assert(SvTYPE(cv) == SVt_PVCV);
+if (!CvSTASH(cv)) return NULL;
+ASSUME(CvNAME_HEK(cv));
+svp = hv_fetchhek(CvSTASH(cv), CvNAME_HEK(cv), 0);
+gv = MUTABLE_GV(svp && *svp ? *svp : newSV(0));
+if (!isGV(gv))
+	gv_init_pvn(gv, CvSTASH(cv), HEK_KEY(CvNAME_HEK(cv)),
+		HEK_LEN(CvNAME_HEK(cv)),
+		SVf_UTF8 * !!HEK_UTF8(CvNAME_HEK(cv)));
+if (!CvNAMED(cv)) { /* gv_init took care of it */
+	assert (SvANY(cv)->xcv_gv_u.xcv_gv == gv);
+	return gv;
+}
+unshare_hek(CvNAME_HEK(cv));
+CvNAMED_off(cv);
+SvANY(cv)->xcv_gv_u.xcv_gv = gv;
+if (svp && *svp) SvREFCNT_inc_simple_void_NN(gv);
+CvCVGV_RC_on(cv);
+return gv;
+}
+/* Assign CvSTASH(cv) = st, handling weak references. */
+void
+Perl_cvstash_set(pTHX_ CV *cv, HV *st)
+{
+HV *oldst = CvSTASH(cv);
+PERL_ARGS_ASSERT_CVSTASH_SET;
+if (oldst == st)
+	return;
+if (oldst)
+	sv_del_backref(MUTABLE_SV(oldst), MUTABLE_SV(cv));
+SvANY(cv)->xcv_stash = st;
+if (st)
+	Perl_sv_add_backref(aTHX_ MUTABLE_SV(st), MUTABLE_SV(cv));
+}
+/*
+=for apidoc gv_init_pvn
+Converts a scalar into a typeglob.  This is an incoercible typeglob;
+assigning a reference to it will assign to one of its slots, instead of
+overwriting it as happens with typeglobs created by SvSetSV.  Converting
+any scalar that is SvOK() may produce unpredictable results and is reserved
+for perl's internal use.
+C<gv> is the scalar to be converted.
+C<stash> is the parent stash/package, if any.
+C<name> and C<len> give the name.  The name must be unqualified;
+that is, it must not include the package name.  If C<gv> is a
+stash element, it is the caller's responsibility to ensure that the name
+passed to this function matches the name of the element.  If it does not
+match, perl's internal bookkeeping will get out of sync.
+C<flags> can be set to SVf_UTF8 if C<name> is a UTF8 string, or
+the return value of SvUTF8(sv).  It can also take the
+GV_ADDMULTI flag, which means to pretend that the GV has been
+seen before (i.e., suppress "Used once" warnings).
+=for apidoc gv_init
+The old form of gv_init_pvn().  It does not work with UTF8 strings, as it
+has no flags parameter.  If the C<multi> parameter is set, the
+GV_ADDMULTI flag will be passed to gv_init_pvn().
+=for apidoc gv_init_pv
+Same as gv_init_pvn(), but takes a nul-terminated string for the name
+instead of separate char * and length parameters.
+=for apidoc gv_init_sv
+Same as gv_init_pvn(), but takes an SV * for the name instead of separate
+char * and length parameters.  C<flags> is currently unused.
+=cut
+*/
+void
+Perl_gv_init_sv(pTHX_ GV *gv, HV *stash, SV* namesv, U32 flags)
+{
+char *namepv;
+STRLEN namelen;
+PERL_ARGS_ASSERT_GV_INIT_SV;
+namepv = SvPV(namesv, namelen);
+if (SvUTF8(namesv))
+flags |= SVf_UTF8;
+gv_init_pvn(gv, stash, namepv, namelen, flags);
+}
+void
+Perl_gv_init_pv(pTHX_ GV *gv, HV *stash, const char *name, U32 flags)
+{
+PERL_ARGS_ASSERT_GV_INIT_PV;
+gv_init_pvn(gv, stash, name, strlen(name), flags);
+}
+void
+Perl_gv_init_pvn(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, U32 flags)
+{
+const U32 old_type = SvTYPE(gv);
+const bool doproto = old_type > SVt_NULL;
+char * const proto = (doproto && SvPOK(gv))
+	? ((void)(SvIsCOW(gv) && (sv_force_normal((SV *)gv), 0)), SvPVX(gv))
+	: NULL;
+const STRLEN protolen = proto ? SvCUR(gv) : 0;
+const U32 proto_utf8  = proto ? SvUTF8(gv) : 0;
+SV *const has_constant = doproto && SvROK(gv) ? SvRV(gv) : NULL;
+const U32 exported_constant = has_constant ? SvPCS_IMPORTED(gv) : 0;
+PERL_ARGS_ASSERT_GV_INIT_PVN;
+assert (!(proto && has_constant));
+if (has_constant) {
+	/* The constant has to be a scalar, array or subroutine.  */
+	switch (SvTYPE(has_constant)) {
+	case SVt_PVHV:
+	case SVt_PVFM:
+	case SVt_PVIO:
+Perl_croak(aTHX_ "Cannot convert a reference to %s to typeglob",
+		       sv_reftype(has_constant, 0));
+	default: NOOP;
+	}
+	SvRV_set(gv, NULL);
+	SvROK_off(gv);
+}
+if (old_type < SVt_PVGV) {
+	if (old_type >= SVt_PV)
+	    SvCUR_set(gv, 0);
+	sv_upgrade(MUTABLE_SV(gv), SVt_PVGV);
+}
+if (SvLEN(gv)) {
+	if (proto) {
+	    SvPV_set(gv, NULL);
+	    SvLEN_set(gv, 0);
+	    SvPOK_off(gv);
+	} else
+	    Safefree(SvPVX_mutable(gv));
+}
+SvIOK_off(gv);
+isGV_with_GP_on(gv);
+GvGP_set(gv, Perl_newGP(aTHX_ gv));
+GvSTASH(gv) = stash;
+if (stash)
+	Perl_sv_add_backref(aTHX_ MUTABLE_SV(stash), MUTABLE_SV(gv));
+gv_name_set(gv, name, len, GV_ADD | ( flags & SVf_UTF8 ? SVf_UTF8 : 0 ));
+if (flags & GV_ADDMULTI || doproto)	/* doproto means it */
+	GvMULTI_on(gv);			/* _was_ mentioned */
+if (has_constant && SvTYPE(has_constant) == SVt_PVCV) {
+	/* Not actually a constant.  Just a regular sub.  */
+	CV * const cv = (CV *)has_constant;
+	GvCV_set(gv,cv);
+	if (CvSTASH(cv) == stash && (
+	       CvNAME_HEK(cv) == GvNAME_HEK(gv)
+	    || (  HEK_LEN(CvNAME_HEK(cv)) == HEK_LEN(GvNAME_HEK(gv))
+	       && HEK_FLAGS(CvNAME_HEK(cv)) != HEK_FLAGS(GvNAME_HEK(gv))
+	       && HEK_UTF8(CvNAME_HEK(cv)) == HEK_UTF8(GvNAME_HEK(gv))
+	       && memEQ(HEK_KEY(CvNAME_HEK(cv)), GvNAME(gv), GvNAMELEN(gv))
+	       )
+	   ))
+	    CvGV_set(cv,gv);
+}
+else if (doproto) {
+	CV *cv;
+	if (has_constant) {
+	    /* newCONSTSUB takes ownership of the reference from us.  */
+	    cv = newCONSTSUB_flags(stash, name, len, flags, has_constant);
+	    /* In case op.c:S_process_special_blocks stole it: */
+	    if (!GvCV(gv))
+		GvCV_set(gv, (CV *)SvREFCNT_inc_simple_NN(cv));
+	    assert(GvCV(gv) == cv); /* newCONSTSUB should have set this */
+	    /* If this reference was a copy of another, then the subroutine
+	       must have been "imported", by a Perl space assignment to a GV
+	       from a reference to CV.  */
+	    if (exported_constant)
+		GvIMPORTED_CV_on(gv);
+	    CvSTASH_set(cv, PL_curstash); /* XXX Why is this needed? */
+	} else {
+	    cv = newSTUB(gv,1);
+	}
+	if (proto) {
+	    sv_usepvn_flags(MUTABLE_SV(cv), proto, protolen,
+			    SV_HAS_TRAILING_NUL);
+if ( proto_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
+	}
+}
+}
+STATIC void
+S_gv_init_svtype(pTHX_ GV *gv, const svtype sv_type)
+{
+PERL_ARGS_ASSERT_GV_INIT_SVTYPE;
+switch (sv_type) {
+case SVt_PVIO:
+	(void)GvIOn(gv);
+	break;
+case SVt_PVAV:
+	(void)GvAVn(gv);
+	break;
+case SVt_PVHV:
+	(void)GvHVn(gv);
+	break;
+#ifdef PERL_DONT_CREATE_GVSV
+case SVt_NULL:
+case SVt_PVCV:
+case SVt_PVFM:
+case SVt_PVGV:
+	break;
+default:
+	if(GvSVn(gv)) {
+	    /* Work round what appears to be a bug in Sun C++ 5.8 2005/10/13
+	       If we just cast GvSVn(gv) to void, it ignores evaluating it for
+	       its side effect */
+	}
+#endif
+}
+}
+static void core_xsub(pTHX_ CV* cv);
+static GV *
+S_maybe_add_coresub(pTHX_ HV * const stash, GV *gv,
+const char * const name, const STRLEN len)
+{
+const int code = keyword(name, len, 1);
+static const char file[] = __FILE__;
+CV *cv, *oldcompcv = NULL;
+int opnum = 0;
+bool ampable = TRUE; /* &{}-able */
+COP *oldcurcop = NULL;
+yy_parser *oldparser = NULL;
+I32 oldsavestack_ix = 0;
+assert(gv || stash);
+assert(name);
+if (!code) return NULL; /* Not a keyword */
+switch (code < 0 ? -code : code) {
+/* no support for \&CORE::infix;
+no support for funcs that do not parse like funcs */
+case KEY___DATA__: case KEY___END__: case KEY_and: case KEY_AUTOLOAD:
+case KEY_BEGIN   : case KEY_CHECK  : case KEY_cmp:
+case KEY_default : case KEY_DESTROY:
+case KEY_do      : case KEY_dump   : case KEY_else  : case KEY_elsif  :
+case KEY_END     : case KEY_eq     : case KEY_eval  :
+case KEY_for     : case KEY_foreach: case KEY_format: case KEY_ge     :
+case KEY_given   : case KEY_goto   : case KEY_grep  :
+case KEY_gt   : case KEY_if: case KEY_INIT: case KEY_last: case KEY_le:
+case KEY_local: case KEY_lt: case KEY_m   : case KEY_map : case KEY_my:
+case KEY_ne   : case KEY_next : case KEY_no: case KEY_or: case KEY_our:
+case KEY_package: case KEY_print: case KEY_printf:
+case KEY_q    : case KEY_qq   : case KEY_qr     : case KEY_qw    :
+case KEY_qx   : case KEY_redo : case KEY_require: case KEY_return:
+case KEY_s    : case KEY_say  : case KEY_sort   :
+case KEY_state: case KEY_sub  :
+case KEY_tr   : case KEY_UNITCHECK: case KEY_unless:
+case KEY_until: case KEY_use  : case KEY_when     : case KEY_while :
+case KEY_x    : case KEY_xor  : case KEY_y        :
+	return NULL;
+case KEY_chdir:
+case KEY_chomp: case KEY_chop: case KEY_defined: case KEY_delete:
+case KEY_each : case KEY_eof : case KEY_exec   : case KEY_exists:
+case KEY_keys:
+case KEY_lstat:
+case KEY_pop:
+case KEY_push:
+case KEY_shift:
+case KEY_splice: case KEY_split:
+case KEY_stat:
+case KEY_system:
+case KEY_truncate: case KEY_unlink:
+case KEY_unshift:
+case KEY_values:
+	ampable = FALSE;
+}
+if (!gv) {
+	gv = (GV *)newSV(0);
+	gv_init(gv, stash, name, len, TRUE);
+}
+GvMULTI_on(gv);
+if (ampable) {
+	ENTER;
+	oldcurcop = PL_curcop;
+	oldparser = PL_parser;
+	lex_start(NULL, NULL, 0);
+	oldcompcv = PL_compcv;
+	PL_compcv = NULL; /* Prevent start_subparse from setting
+	                     CvOUTSIDE. */
+	oldsavestack_ix = start_subparse(FALSE,0);
+	cv = PL_compcv;
+}
+else {
+	/* Avoid calling newXS, as it calls us, and things start to
+	   get hairy. */
+	cv = MUTABLE_CV(newSV_type(SVt_PVCV));
+	GvCV_set(gv,cv);
+	GvCVGEN(gv) = 0;
+	CvISXSUB_on(cv);
+	CvXSUB(cv) = core_xsub;
+	PoisonPADLIST(cv);
+}
+CvGV_set(cv, gv); /* This stops new ATTRSUB from setting CvFILE
+from PL_curcop. */
+(void)gv_fetchfile(file);
+CvFILE(cv) = (char *)file;
+/* XXX This is inefficient, as doing things this order causes
+a prototype check in newATTRSUB.  But we have to do
+it this order as we need an op number before calling
+new ATTRSUB. */
+(void)core_prototype((SV *)cv, name, code, &opnum);
+if (stash)
+	(void)hv_store(stash,name,len,(SV *)gv,0);
+if (ampable) {
+#ifdef DEBUGGING
+CV *orig_cv = cv;
+#endif
+	CvLVALUE_on(cv);
+/* newATTRSUB will free the CV and return NULL if we're still
+compiling after a syntax error */
+	if ((cv = newATTRSUB_x(
+		   oldsavestack_ix, (OP *)gv,
+	           NULL,NULL,
+	           coresub_op(
+	             opnum
+	               ? newSVuv((UV)opnum)
+	               : newSVpvn(name,len),
+	             code, opnum
+	           ),
+	           TRUE
+)) != NULL) {
+assert(GvCV(gv) == orig_cv);
+if (opnum != OP_VEC && opnum != OP_SUBSTR && opnum != OP_POS
+&& opnum != OP_UNDEF)
+CvLVALUE_off(cv); /* Now *that* was a neat trick. */
+}
+	LEAVE;
+	PL_parser = oldparser;
+	PL_curcop = oldcurcop;
+	PL_compcv = oldcompcv;
+}
+if (cv) {
+SV *opnumsv = opnum ? newSVuv((UV)opnum) : (SV *)NULL;
+cv_set_call_checker(
+cv, Perl_ck_entersub_args_core, opnumsv ? opnumsv : (SV *)cv
+);
+SvREFCNT_dec(opnumsv);
+}
+return gv;
+}
+/*
+=for apidoc gv_fetchmeth
+Like L</gv_fetchmeth_pvn>, but lacks a flags parameter.
+=for apidoc gv_fetchmeth_sv
+Exactly like L</gv_fetchmeth_pvn>, but takes the name string in the form
+of an SV instead of a string/length pair.
+=cut
+*/
+GV *
+Perl_gv_fetchmeth_sv(pTHX_ HV *stash, SV *namesv, I32 level, U32 flags)
+{
+char *namepv;
+STRLEN namelen;
+PERL_ARGS_ASSERT_GV_FETCHMETH_SV;
+if (LIKELY(SvPOK_nog(namesv))) /* common case */
+return gv_fetchmeth_internal(stash, namesv, NULL, 0, level, flags);
+namepv = SvPV(namesv, namelen);
+if (SvUTF8(namesv)) flags |= SVf_UTF8;
+return gv_fetchmeth_pvn(stash, namepv, namelen, level, flags);
+}
+/*
+=for apidoc gv_fetchmeth_pv
+Exactly like L</gv_fetchmeth_pvn>, but takes a nul-terminated string
+instead of a string/length pair.
+=cut
+*/
+GV *
+Perl_gv_fetchmeth_pv(pTHX_ HV *stash, const char *name, I32 level, U32 flags)
+{
+PERL_ARGS_ASSERT_GV_FETCHMETH_PV;
+return gv_fetchmeth_internal(stash, NULL, name, strlen(name), level, flags);
+}
+/*
+=for apidoc gv_fetchmeth_pvn
+Returns the glob with the given C<name> and a defined subroutine or
+C<NULL>.  The glob lives in the given C<stash>, or in the stashes
+accessible via @ISA and UNIVERSAL::.
+The argument C<level> should be either 0 or -1.  If C<level==0>, as a
+side-effect creates a glob with the given C<name> in the given C<stash>
+which in the case of success contains an alias for the subroutine, and sets
+up caching info for this glob.
+The only significant values for C<flags> are GV_SUPER and SVf_UTF8.
+GV_SUPER indicates that we want to look up the method in the superclasses
+of the C<stash>.
+The
+GV returned from C<gv_fetchmeth> may be a method cache entry, which is not
+visible to Perl code.  So when calling C<call_sv>, you should not use
+the GV directly; instead, you should use the method's CV, which can be
+obtained from the GV with the C<GvCV> macro.
+=cut
+*/
+/* NOTE: No support for tied ISA */
+PERL_STATIC_INLINE GV*
+S_gv_fetchmeth_internal(pTHX_ HV* stash, SV* meth, const char* name, STRLEN len, I32 level, U32 flags)
+{
+GV** gvp;
+HE* he;
+AV* linear_av;
+SV** linear_svp;
+SV* linear_sv;
+HV* cstash, *cachestash;
+GV* candidate = NULL;
+CV* cand_cv = NULL;
+GV* topgv = NULL;
+const char *hvname;
+I32 create = (level >= 0) ? HV_FETCH_LVALUE : 0;
+I32 items;
+U32 topgen_cmp;
+U32 is_utf8 = flags & SVf_UTF8;
+/* UNIVERSAL methods should be callable without a stash */
+if (!stash) {
+	create = 0;  /* probably appropriate */
+	if(!(stash = gv_stashpvs("UNIVERSAL", 0)))
+	    return 0;
+}
+assert(stash);
+hvname = HvNAME_get(stash);
+if (!hvname)
+Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup");
+assert(hvname);
+assert(name || meth);
+DEBUG_o( Perl_deb(aTHX_ "Looking for %smethod %s in package %s\n",
+		      flags & GV_SUPER ? "SUPER " : "",
+		      name ? name : SvPV_nolen(meth), hvname) );
+topgen_cmp = HvMROMETA(stash)->cache_gen + PL_sub_generation;
+if (flags & GV_SUPER) {
+	if (!HvAUX(stash)->xhv_mro_meta->super)
+	    HvAUX(stash)->xhv_mro_meta->super = newHV();
+	cachestash = HvAUX(stash)->xhv_mro_meta->super;
+}
+else cachestash = stash;
+/* check locally for a real method or a cache entry */
+he = (HE*)hv_common(
+cachestash, meth, name, len, (flags & SVf_UTF8) ? HVhek_UTF8 : 0, create, NULL, 0
+);
+if (he) gvp = (GV**)&HeVAL(he);
+else gvp = NULL;
+if(gvp) {
+topgv = *gvp;
+have_gv:
+assert(topgv);
+if (SvTYPE(topgv) != SVt_PVGV)
+{
+if (!name)
+name = SvPV_nomg(meth, len);
+gv_init_pvn(topgv, stash, name, len, GV_ADDMULTI|is_utf8);
+}
+if ((cand_cv = GvCV(topgv))) {
+/* If genuine method or valid cache entry, use it */
+if (!GvCVGEN(topgv) || GvCVGEN(topgv) == topgen_cmp) {
+return topgv;
+}
+else {
+/* stale cache entry, junk it and move on */
+	        SvREFCNT_dec_NN(cand_cv);
+	        GvCV_set(topgv, NULL);
+		cand_cv = NULL;
+	        GvCVGEN(topgv) = 0;
+}
+}
+else if (GvCVGEN(topgv) == topgen_cmp) {
+/* cache indicates no such method definitively */
+return 0;
+}
+	else if (stash == cachestash
+	      && len > 1 /* shortest is uc */ && HvNAMELEN_get(stash) == 4
+&& strnEQ(hvname, "CORE", 4)
+&& S_maybe_add_coresub(aTHX_ NULL,topgv,name,len))
+	    goto have_gv;
+}
+linear_av = mro_get_linear_isa(stash); /* has ourselves at the top of the list */
+linear_svp = AvARRAY(linear_av) + 1; /* skip over self */
+items = AvFILLp(linear_av); /* no +1, to skip over self */
+while (items--) {
+linear_sv = *linear_svp++;
+assert(linear_sv);
+cstash = gv_stashsv(linear_sv, 0);
+if (!cstash) {
+	    Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
+"Can't locate package %"SVf" for @%"HEKf"::ISA",
+			   SVfARG(linear_sv),
+HEKfARG(HvNAME_HEK(stash)));
+continue;
+}
+assert(cstash);
+gvp = (GV**)hv_fetch(cstash, name, is_utf8 ? -(I32)len : (I32)len, 0);
+if (!gvp) {
+if (len > 1 && HvNAMELEN_get(cstash) == 4) {
+const char *hvname = HvNAME(cstash); assert(hvname);
+if (strnEQ(hvname, "CORE", 4)
+&& (candidate =
+S_maybe_add_coresub(aTHX_ cstash,NULL,name,len)
+))
+goto have_candidate;
+}
+continue;
+}
+else candidate = *gvp;
+have_candidate:
+assert(candidate);
+if (SvTYPE(candidate) != SVt_PVGV)
+gv_init_pvn(candidate, cstash, name, len, GV_ADDMULTI|is_utf8);
+if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) {
+/*
+* Found real method, cache method in topgv if:
+*  1. topgv has no synonyms (else inheritance crosses wires)
+*  2. method isn't a stub (else AUTOLOAD fails spectacularly)
+*/
+if (topgv && (GvREFCNT(topgv) == 1) && (CvROOT(cand_cv) || CvXSUB(cand_cv))) {
+CV *old_cv = GvCV(topgv);
+SvREFCNT_dec(old_cv);
+SvREFCNT_inc_simple_void_NN(cand_cv);
+GvCV_set(topgv, cand_cv);
+GvCVGEN(topgv) = topgen_cmp;
+}
+	    return candidate;
+}
+}
+/* Check UNIVERSAL without caching */
+if(level == 0 || level == -1) {
+candidate = gv_fetchmeth_internal(NULL, meth, name, len, 1,
+flags &~GV_SUPER);
+if(candidate) {
+cand_cv = GvCV(candidate);
+if (topgv && (GvREFCNT(topgv) == 1) && (CvROOT(cand_cv) || CvXSUB(cand_cv))) {
+CV *old_cv = GvCV(topgv);
+SvREFCNT_dec(old_cv);
+SvREFCNT_inc_simple_void_NN(cand_cv);
+GvCV_set(topgv, cand_cv);
+GvCVGEN(topgv) = topgen_cmp;
+}
+return candidate;
+}
+}
+if (topgv && GvREFCNT(topgv) == 1) {
+/* cache the fact that the method is not defined */
+GvCVGEN(topgv) = topgen_cmp;
+}
+return 0;
+}
+GV *
+Perl_gv_fetchmeth_pvn(pTHX_ HV *stash, const char *name, STRLEN len, I32 level, U32 flags)
+{
+PERL_ARGS_ASSERT_GV_FETCHMETH_PVN;
+return gv_fetchmeth_internal(stash, NULL, name, len, level, flags);
+}
+/*
+=for apidoc gv_fetchmeth_autoload
+This is the old form of L</gv_fetchmeth_pvn_autoload>, which has no flags
+parameter.
+=for apidoc gv_fetchmeth_sv_autoload
+Exactly like L</gv_fetchmeth_pvn_autoload>, but takes the name string in the form
+of an SV instead of a string/length pair.
+=cut
+*/
+GV *
+Perl_gv_fetchmeth_sv_autoload(pTHX_ HV *stash, SV *namesv, I32 level, U32 flags)
+{
+char *namepv;
+STRLEN namelen;
+PERL_ARGS_ASSERT_GV_FETCHMETH_SV_AUTOLOAD;
+namepv = SvPV(namesv, namelen);
+if (SvUTF8(namesv))
+flags |= SVf_UTF8;
+return gv_fetchmeth_pvn_autoload(stash, namepv, namelen, level, flags);
+}
+/*
+=for apidoc gv_fetchmeth_pv_autoload
+Exactly like L</gv_fetchmeth_pvn_autoload>, but takes a nul-terminated string
+instead of a string/length pair.
+=cut
+*/
+GV *
+Perl_gv_fetchmeth_pv_autoload(pTHX_ HV *stash, const char *name, I32 level, U32 flags)
+{
+PERL_ARGS_ASSERT_GV_FETCHMETH_PV_AUTOLOAD;
+return gv_fetchmeth_pvn_autoload(stash, name, strlen(name), level, flags);
+}
+/*
+=for apidoc gv_fetchmeth_pvn_autoload
+Same as gv_fetchmeth_pvn(), but looks for autoloaded subroutines too.
+Returns a glob for the subroutine.
+For an autoloaded subroutine without a GV, will create a GV even
+if C<level < 0>.  For an autoloaded subroutine without a stub, GvCV()
+of the result may be zero.
+Currently, the only significant value for C<flags> is SVf_UTF8.
+=cut
+*/
+GV *
+Perl_gv_fetchmeth_pvn_autoload(pTHX_ HV *stash, const char *name, STRLEN len, I32 level, U32 flags)
+{
+GV *gv = gv_fetchmeth_pvn(stash, name, len, level, flags);
+PERL_ARGS_ASSERT_GV_FETCHMETH_PVN_AUTOLOAD;
+if (!gv) {
+	CV *cv;
+	GV **gvp;
+	if (!stash)
+	    return NULL;	/* UNIVERSAL::AUTOLOAD could cause trouble */
+	if (len == S_autolen && memEQ(name, S_autoload, S_autolen))
+	    return NULL;
+	if (!(gv = gv_fetchmeth_pvn(stash, S_autoload, S_autolen, FALSE, flags)))
+	    return NULL;
+	cv = GvCV(gv);
+	if (!(CvROOT(cv) || CvXSUB(cv)))
+	    return NULL;
+	/* Have an autoload */
+	if (level < 0)	/* Cannot do without a stub */
+	    gv_fetchmeth_pvn(stash, name, len, 0, flags);
+	gvp = (GV**)hv_fetch(stash, name,
+(flags & SVf_UTF8) ? -(I32)len : (I32)len, (level >= 0));
+	if (!gvp)
+	    return NULL;
+	return *gvp;
+}
+return gv;
+}
+/*
+=for apidoc gv_fetchmethod_autoload
+Returns the glob which contains the subroutine to call to invoke the method
+on the C<stash>.  In fact in the presence of autoloading this may be the
+glob for "AUTOLOAD".  In this case the corresponding variable $AUTOLOAD is
+already setup.
+The third parameter of C<gv_fetchmethod_autoload> determines whether
+AUTOLOAD lookup is performed if the given method is not present: non-zero
+means yes, look for AUTOLOAD; zero means no, don't look for AUTOLOAD.
+Calling C<gv_fetchmethod> is equivalent to calling C<gv_fetchmethod_autoload>
+with a non-zero C<autoload> parameter.
+These functions grant C<"SUPER"> token
+as a prefix of the method name.  Note
+that if you want to keep the returned glob for a long time, you need to
+check for it being "AUTOLOAD", since at the later time the call may load a
+different subroutine due to $AUTOLOAD changing its value.  Use the glob
+created as a side effect to do this.
+These functions have the same side-effects as C<gv_fetchmeth> with
+C<level==0>.  The warning against passing the GV returned by
+C<gv_fetchmeth> to C<call_sv> applies equally to these functions.
+=cut
+*/
+GV *
+Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload)
+{
+PERL_ARGS_ASSERT_GV_FETCHMETHOD_AUTOLOAD;
+return gv_fetchmethod_flags(stash, name, autoload ? GV_AUTOLOAD : 0);
+}
+GV *
+Perl_gv_fetchmethod_sv_flags(pTHX_ HV *stash, SV *namesv, U32 flags)
+{
+char *namepv;
+STRLEN namelen;
+PERL_ARGS_ASSERT_GV_FETCHMETHOD_SV_FLAGS;
+namepv = SvPV(namesv, namelen);
+if (SvUTF8(namesv))
+flags |= SVf_UTF8;
+return gv_fetchmethod_pvn_flags(stash, namepv, namelen, flags);
+}
+GV *
+Perl_gv_fetchmethod_pv_flags(pTHX_ HV *stash, const char *name, U32 flags)
+{
+PERL_ARGS_ASSERT_GV_FETCHMETHOD_PV_FLAGS;
+return gv_fetchmethod_pvn_flags(stash, name, strlen(name), flags);
+}
+/* Don't merge this yet, as it's likely to get a len parameter, and possibly
+even a U32 hash */
+GV *
+Perl_gv_fetchmethod_pvn_flags(pTHX_ HV *stash, const char *name, const STRLEN len, U32 flags)
+{
+const char *nend;
+const char *nsplit = NULL;
+GV* gv;
+HV* ostash = stash;
+const char * const origname = name;
+SV *const error_report = MUTABLE_SV(stash);
+const U32 autoload = flags & GV_AUTOLOAD;
+const U32 do_croak = flags & GV_CROAK;
+const U32 is_utf8  = flags & SVf_UTF8;
+PERL_ARGS_ASSERT_GV_FETCHMETHOD_PVN_FLAGS;
+if (SvTYPE(stash) < SVt_PVHV)
+	stash = NULL;
+else {
+	/* The only way stash can become NULL later on is if nsplit is set,
+	   which in turn means that there is no need for a SVt_PVHV case
+	   the error reporting code.  */
+}
+for (nend = name; *nend || nend != (origname + len); nend++) {
+	if (*nend == '\'') {
+	    nsplit = nend;
+	    name = nend + 1;
+	}
+	else if (*nend == ':' && *(nend + 1) == ':') {
+	    nsplit = nend++;
+	    name = nend + 1;
+	}
+}
+if (nsplit) {
+	if ((nsplit - origname) == 5 && memEQ(origname, "SUPER", 5)) {
+	    /* ->SUPER::method should really be looked up in original stash */
+	    stash = CopSTASH(PL_curcop);
+	    flags |= GV_SUPER;
+	    DEBUG_o( Perl_deb(aTHX_ "Treating %s as %s::%s\n",
+			 origname, HvENAME_get(stash), name) );
+	}
+	else if ((nsplit - origname) >= 7 &&
+		 strnEQ(nsplit - 7, "::SUPER", 7)) {
+/* don't autovifify if ->NoSuchStash::SUPER::method */
+	    stash = gv_stashpvn(origname, nsplit - origname - 7, is_utf8);
+	    if (stash) flags |= GV_SUPER;
+	}
+	else {
+/* don't autovifify if ->NoSuchStash::method */
+stash = gv_stashpvn(origname, nsplit - origname, is_utf8);
+	}
+	ostash = stash;
+}
+gv = gv_fetchmeth_pvn(stash, name, nend - name, 0, flags);
+if (!gv) {
+	if (strEQ(name,"import") || strEQ(name,"unimport"))
+	    gv = MUTABLE_GV(&PL_sv_yes);
+	else if (autoload)
+	    gv = gv_autoload_pvn(
+		ostash, name, nend - name, GV_AUTOLOAD_ISMETHOD|flags
+	    );
+	if (!gv && do_croak) {
+	    /* Right now this is exclusively for the benefit of S_method_common
+	       in pp_hot.c  */
+	    if (stash) {
+		/* If we can't find an IO::File method, it might be a call on
+		 * a filehandle. If IO:File has not been loaded, try to
+		 * require it first instead of croaking */
+		const char *stash_name = HvNAME_get(stash);
+		if (stash_name && memEQs(stash_name, HvNAMELEN_get(stash), "IO::File")
+		    && !Perl_hv_common(aTHX_ GvHVn(PL_incgv), NULL,
+				       STR_WITH_LEN("IO/File.pm"), 0,
+				       HV_FETCH_ISEXISTS, NULL, 0)
+		) {
+		    require_pv("IO/File.pm");
+		    gv = gv_fetchmeth_pvn(stash, name, nend - name, 0, flags);
+		    if (gv)
+			return gv;
+		}
+		Perl_croak(aTHX_
+			   "Can't locate object method \"%"UTF8f
+			   "\" via package \"%"HEKf"\"",
+			            UTF8fARG(is_utf8, nend - name, name),
+HEKfARG(HvNAME_HEK(stash)));
+	    }
+	    else {
+SV* packnamesv;
+		if (nsplit) {
+		    packnamesv = newSVpvn_flags(origname, nsplit - origname,
+SVs_TEMP | is_utf8);
+		} else {
+		    packnamesv = error_report;
+		}
+		Perl_croak(aTHX_
+			   "Can't locate object method \"%"UTF8f
+			   "\" via package \"%"SVf"\""
+			   " (perhaps you forgot to load \"%"SVf"\"?)",
+			   UTF8fARG(is_utf8, nend - name, name),
+SVfARG(packnamesv), SVfARG(packnamesv));
+	    }
+	}
+}
+else if (autoload) {
+	CV* const cv = GvCV(gv);
+	if (!CvROOT(cv) && !CvXSUB(cv)) {
+	    GV* stubgv;
+	    GV* autogv;
+	    if (CvANON(cv) || CvLEXICAL(cv))
+		stubgv = gv;
+	    else {
+		stubgv = CvGV(cv);
+		if (GvCV(stubgv) != cv)		/* orphaned import */
+		    stubgv = gv;
+	    }
+autogv = gv_autoload_pvn(GvSTASH(stubgv),
+GvNAME(stubgv), GvNAMELEN(stubgv),
+GV_AUTOLOAD_ISMETHOD
+| (GvNAMEUTF8(stubgv) ? SVf_UTF8 : 0));
+	    if (autogv)
+		gv = autogv;
+	}
+}
+return gv;
+}
+GV*
+Perl_gv_autoload_sv(pTHX_ HV *stash, SV* namesv, U32 flags)
+{
+char *namepv;
+STRLEN namelen;
+PERL_ARGS_ASSERT_GV_AUTOLOAD_SV;
+namepv = SvPV(namesv, namelen);
+if (SvUTF8(namesv))
+flags |= SVf_UTF8;
+return gv_autoload_pvn(stash, namepv, namelen, flags);
+}
+GV*
+Perl_gv_autoload_pv(pTHX_ HV *stash, const char *namepv, U32 flags)
+{
+PERL_ARGS_ASSERT_GV_AUTOLOAD_PV;
+return gv_autoload_pvn(stash, namepv, strlen(namepv), flags);
+}
+GV*
+Perl_gv_autoload_pvn(pTHX_ HV *stash, const char *name, STRLEN len, U32 flags)
+{
+GV* gv;
+CV* cv;
+HV* varstash;
+GV* vargv;
+SV* varsv;
+SV *packname = NULL;
+U32 is_utf8 = flags & SVf_UTF8 ? SVf_UTF8 : 0;
+PERL_ARGS_ASSERT_GV_AUTOLOAD_PVN;
+if (len == S_autolen && memEQ(name, S_autoload, S_autolen))
+	return NULL;
+if (stash) {
+	if (SvTYPE(stash) < SVt_PVHV) {
+STRLEN packname_len = 0;
+const char * const packname_ptr = SvPV_const(MUTABLE_SV(stash), packname_len);
+packname = newSVpvn_flags(packname_ptr, packname_len,
+SVs_TEMP | SvUTF8(stash));
+	    stash = NULL;
+	}
+	else
+	    packname = sv_2mortal(newSVhek(HvNAME_HEK(stash)));
+	if (flags & GV_SUPER) sv_catpvs(packname, "::SUPER");
+}
+if (!(gv = gv_fetchmeth_pvn(stash, S_autoload, S_autolen, FALSE,
+				is_utf8 | (flags & GV_SUPER))))
+	return NULL;
+cv = GvCV(gv);
+if (!(CvROOT(cv) || CvXSUB(cv)))
+	return NULL;
+/*
+* Inheriting AUTOLOAD for non-methods works ... for now.
+*/
+if (
+!(flags & GV_AUTOLOAD_ISMETHOD)
+&& (GvCVGEN(gv) || GvSTASH(gv) != stash)
+)
+	Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
+			 "Use of inherited AUTOLOAD for non-method %"SVf
+			 "::%"UTF8f"() is deprecated",
+			 SVfARG(packname),
+UTF8fARG(is_utf8, len, name));
+if (CvISXSUB(cv)) {
+/* Instead of forcing the XSUB do another lookup for $AUTOLOAD
+* and split that value on the last '::', pass along the same data
+* via the SvPVX field in the CV, and the stash in CvSTASH.
+*
+* Due to an unfortunate accident of history, the SvPVX field
+* serves two purposes.  It is also used for the subroutine's pro-
+* type.  Since SvPVX has been documented as returning the sub name
+* for a long time, but not as returning the prototype, we have
+* to preserve the SvPVX AUTOLOAD behaviour and put the prototype
+* elsewhere.
+*
+* We put the prototype in the same allocated buffer, but after
+* the sub name.  The SvPOK flag indicates the presence of a proto-
+* type.  The CvAUTOLOAD flag indicates the presence of a sub name.
+* If both flags are on, then SvLEN is used to indicate the end of
+* the prototype (artificially lower than what is actually allo-
+* cated), at the risk of having to reallocate a few bytes unneces-
+* sarily--but that should happen very rarely, if ever.
+*
+* We use SvUTF8 for both prototypes and sub names, so if one is
+* UTF8, the other must be upgraded.
+*/
+	CvSTASH_set(cv, stash);
+	if (SvPOK(cv)) { /* Ouch! */
+	    SV * const tmpsv = newSVpvn_flags(name, len, is_utf8);
+	    STRLEN ulen;
+	    const char *proto = CvPROTO(cv);
+	    assert(proto);
+	    if (SvUTF8(cv))
+		sv_utf8_upgrade_flags_grow(tmpsv, 0, CvPROTOLEN(cv) + 2);
+	    ulen = SvCUR(tmpsv);
+	    SvCUR(tmpsv)++; /* include null in string */
+	    sv_catpvn_flags(
+		tmpsv, proto, CvPROTOLEN(cv), SV_CATBYTES*!SvUTF8(cv)
+	    );
+	    SvTEMP_on(tmpsv); /* Allow theft */
+	    sv_setsv_nomg((SV *)cv, tmpsv);
+	    SvTEMP_off(tmpsv);
+	    SvREFCNT_dec_NN(tmpsv);
+	    SvLEN(cv) = SvCUR(cv) + 1;
+	    SvCUR(cv) = ulen;
+	}
+	else {
+	  sv_setpvn((SV *)cv, name, len);
+	  SvPOK_off(cv);
+	  if (is_utf8)
+SvUTF8_on(cv);
+	  else SvUTF8_off(cv);
+	}
+	CvAUTOLOAD_on(cv);
+}
+/*
+* Given &FOO::AUTOLOAD, set $FOO::AUTOLOAD to desired function name.
+* The subroutine's original name may not be "AUTOLOAD", so we don't
+* use that, but for lack of anything better we will use the sub's
+* original package to look up $AUTOLOAD.
+*/
+varstash = CvNAMED(cv) ? CvSTASH(cv) : GvSTASH(CvGV(cv));
+vargv = *(GV**)hv_fetch(varstash, S_autoload, S_autolen, TRUE);
+ENTER;
+if (!isGV(vargv)) {
+	gv_init_pvn(vargv, varstash, S_autoload, S_autolen, 0);
+#ifdef PERL_DONT_CREATE_GVSV
+	GvSV(vargv) = newSV(0);
+#endif
+}
+LEAVE;
+varsv = GvSVn(vargv);
+SvTAINTED_off(varsv); /* previous $AUTOLOAD taint is obsolete */
+/* XXX: this process is not careful to avoid extra magic gets and sets; tied $AUTOLOAD will get noise */
+sv_setsv(varsv, packname);
+sv_catpvs(varsv, "::");
+/* Ensure SvSETMAGIC() is called if necessary. In particular, to clear
+tainting if $FOO::AUTOLOAD was previously tainted, but is not now.  */
+sv_catpvn_flags(
+	varsv, name, len,
+	SV_SMAGIC|(is_utf8 ? SV_CATUTF8 : SV_CATBYTES)
+);
+if (is_utf8)
+SvUTF8_on(varsv);
+return gv;
+}
+/* require_tie_mod() internal routine for requiring a module
+* that implements the logic of automatic ties like %! and %-
+*
+* The "gv" parameter should be the glob.
+* "varpv" holds the name of the var, used for error messages.
+* "namesv" holds the module name. Its refcount will be decremented.
+* "methpv" holds the method name to test for to check that things
+*   are working reasonably close to as expected.
+* "flags": if flag & 1 then save the scalar before loading.
+* For the protection of $! to work (it is set by this routine)
+* the sv slot must already be magicalized.
+*/
+STATIC HV*
+S_require_tie_mod(pTHX_ GV *gv, const char *varpv, SV* namesv, const char *methpv,const U32 flags)
+{
+HV* stash = gv_stashsv(namesv, 0);
+PERL_ARGS_ASSERT_REQUIRE_TIE_MOD;
+if (!stash || !(gv_fetchmethod_autoload(stash, methpv, FALSE))) {
+	SV *module = newSVsv(namesv);
+	char varname = *varpv; /* varpv might be clobbered by load_module,
+				  so save it. For the moment it's always
+				  a single char. */
+	const char type = varname == '[' ? '$' : '%';
+#ifdef DEBUGGING
+	dSP;
+#endif
+	ENTER;
+	SAVEFREESV(namesv);
+	if ( flags & 1 )
+	    save_scalar(gv);
+	Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, module, NULL);
+	assert(sp == PL_stack_sp);
+	stash = gv_stashsv(namesv, 0);
+	if (!stash)
+	    Perl_croak(aTHX_ "panic: Can't use %c%c because %"SVf" is not available",
+		    type, varname, SVfARG(namesv));
+	else if (!gv_fetchmethod(stash, methpv))
+	    Perl_croak(aTHX_ "panic: Can't use %c%c because %"SVf" does not support method %s",
+		    type, varname, SVfARG(namesv), methpv);
+	LEAVE;
+}
+else SvREFCNT_dec_NN(namesv);
+return stash;
+}
+/*
+=for apidoc gv_stashpv
+Returns a pointer to the stash for a specified package.  Uses C<strlen> to
+determine the length of C<name>, then calls C<gv_stashpvn()>.
+=cut
+*/
+HV*
+Perl_gv_stashpv(pTHX_ const char *name, I32 create)
+{
+PERL_ARGS_ASSERT_GV_STASHPV;
+return gv_stashpvn(name, strlen(name), create);
+}
+/*
+=for apidoc gv_stashpvn
+Returns a pointer to the stash for a specified package.  The C<namelen>
+parameter indicates the length of the C<name>, in bytes.  C<flags> is passed
+to C<gv_fetchpvn_flags()>, so if set to C<GV_ADD> then the package will be
+created if it does not already exist.  If the package does not exist and
+C<flags> is 0 (or any other setting that does not create packages) then NULL
+is returned.
+Flags may be one of:
+GV_ADD
+SVf_UTF8
+GV_NOADD_NOINIT
+GV_NOINIT
+GV_NOEXPAND
+GV_ADDMG
+The most important of which are probably GV_ADD and SVf_UTF8.
+Note, use of C<gv_stashsv> instead of C<gv_stashpvn> where possible is strongly
+recommended for performance reasons.
+=cut
+*/
+/*
+gv_stashpvn_internal
+Perform the internal bits of gv_stashsvpvn_cached. You could think of this
+as being one half of the logic. Not to be called except from gv_stashsvpvn_cached().
+*/
+PERL_STATIC_INLINE HV*
+S_gv_stashpvn_internal(pTHX_ const char *name, U32 namelen, I32 flags)
+{
+char smallbuf[128];
+char *tmpbuf;
+HV *stash;
+GV *tmpgv;
+U32 tmplen = namelen + 2;
+PERL_ARGS_ASSERT_GV_STASHPVN_INTERNAL;
+if (tmplen <= sizeof smallbuf)
+	tmpbuf = smallbuf;
+else
+	Newx(tmpbuf, tmplen, char);
+Copy(name, tmpbuf, namelen, char);
+tmpbuf[namelen]   = ':';
+tmpbuf[namelen+1] = ':';
+tmpgv = gv_fetchpvn_flags(tmpbuf, tmplen, flags, SVt_PVHV);
+if (tmpbuf != smallbuf)
+	Safefree(tmpbuf);
+if (!tmpgv || !isGV_with_GP(tmpgv))
+	return NULL;
+stash = GvHV(tmpgv);
+if (!(flags & ~GV_NOADD_MASK) && !stash) return NULL;
+assert(stash);
+if (!HvNAME_get(stash)) {
+	hv_name_set(stash, name, namelen, flags & SVf_UTF8 ? SVf_UTF8 : 0 );
+	/* FIXME: This is a repeat of logic in gv_fetchpvn_flags */
+	/* If the containing stash has multiple effective
+	   names, see that this one gets them, too. */
+	if (HvAUX(GvSTASH(tmpgv))->xhv_name_count)
+	    mro_package_moved(stash, NULL, tmpgv, 1);
+}
+return stash;
+}
+/*
+gv_stashsvpvn_cached
+Returns a pointer to the stash for a specified package, possibly
+cached.  Implements both C<gv_stashpvn> and C<gc_stashsv>.
+Requires one of either namesv or namepv to be non-null.
+See C<gv_stashpvn> for details on "flags".
+Note the sv interface is strongly preferred for performance reasons.
+*/
+#define PERL_ARGS_ASSERT_GV_STASHSVPVN_CACHED \
+assert(namesv || name)
+PERL_STATIC_INLINE HV*
+S_gv_stashsvpvn_cached(pTHX_ SV *namesv, const char *name, U32 namelen, I32 flags)
+{
+HV* stash;
+HE* he;
+PERL_ARGS_ASSERT_GV_STASHSVPVN_CACHED;
+he = (HE *)hv_common(
+PL_stashcache, namesv, name, namelen,
+(flags & SVf_UTF8) ? HVhek_UTF8 : 0, 0, NULL, 0
+);
+if (he) return INT2PTR(HV*,SvIVX(HeVAL(he)));
+else if (flags & GV_CACHE_ONLY) return NULL;
+if (namesv) {
+if (SvOK(namesv)) { /* prevent double uninit warning */
+STRLEN len;
+name = SvPV_const(namesv, len);
+namelen = len;
+flags |= SvUTF8(namesv);
+} else {
+name = ""; namelen = 0;
+}
+}
+stash = gv_stashpvn_internal(name, namelen, flags);
+if (stash && namelen) {
+SV* const ref = newSViv(PTR2IV(stash));
+(void)hv_store(PL_stashcache, name,
+(flags & SVf_UTF8) ? -(I32)namelen : (I32)namelen, ref, 0);
+}
+return stash;
+}
+HV*
+Perl_gv_stashpvn(pTHX_ const char *name, U32 namelen, I32 flags)
+{
+PERL_ARGS_ASSERT_GV_STASHPVN;
+return gv_stashsvpvn_cached(NULL, name, namelen, flags);
+}
+/*
+=for apidoc gv_stashsv
+Returns a pointer to the stash for a specified package.  See C<gv_stashpvn>.
+Note this interface is strongly preferred over C<gv_stashpvn> for performance reasons.
+=cut
+*/
+HV*
+Perl_gv_stashsv(pTHX_ SV *sv, I32 flags)
+{
+PERL_ARGS_ASSERT_GV_STASHSV;
+return gv_stashsvpvn_cached(sv, NULL, 0, flags);
+}
+GV *
+Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, const svtype sv_type) {
+PERL_ARGS_ASSERT_GV_FETCHPV;
+return gv_fetchpvn_flags(nambeg, strlen(nambeg), add, sv_type);
+}
+GV *
+Perl_gv_fetchsv(pTHX_ SV *name, I32 flags, const svtype sv_type) {
+STRLEN len;
+const char * const nambeg =
+SvPV_flags_const(name, len, flags & GV_NO_SVGMAGIC ? 0 : SV_GMAGIC);
+PERL_ARGS_ASSERT_GV_FETCHSV;
+return gv_fetchpvn_flags(nambeg, len, flags | SvUTF8(name), sv_type);
+}
+PERL_STATIC_INLINE void
+S_gv_magicalize_isa(pTHX_ GV *gv)
+{
+AV* av;
+PERL_ARGS_ASSERT_GV_MAGICALIZE_ISA;
+av = GvAVn(gv);
+GvMULTI_on(gv);
+sv_magic(MUTABLE_SV(av), MUTABLE_SV(gv), PERL_MAGIC_isa,
+	     NULL, 0);
+}
+/* This function grabs name and tries to split a stash and glob
+* from its contents. TODO better description, comments
+*
+* If the function returns TRUE and 'name == name_end', then
+* 'gv' can be directly returned to the caller of gv_fetchpvn_flags
+*/
+PERL_STATIC_INLINE bool
+S_parse_gv_stash_name(pTHX_ HV **stash, GV **gv, const char **name,
+STRLEN *len, const char *nambeg, STRLEN full_len,
+const U32 is_utf8, const I32 add)
+{
+const char *name_cursor;
+const char *const name_end = nambeg + full_len;
+const char *const name_em1 = name_end - 1;
+PERL_ARGS_ASSERT_PARSE_GV_STASH_NAME;
+if (full_len > 2 && **name == '*' && isIDFIRST_lazy_if(*name + 1, is_utf8)) {
+/* accidental stringify on a GV? */
+(*name)++;
+}
+for (name_cursor = *name; name_cursor < name_end; name_cursor++) {
+if (name_cursor < name_em1 &&
+((*name_cursor == ':' && name_cursor[1] == ':')
+|| *name_cursor == '\''))
+{
+if (!*stash)
+*stash = PL_defstash;
+if (!*stash || !SvREFCNT(*stash)) /* symbol table under destruction */
+return FALSE;
+*len = name_cursor - *name;
+if (name_cursor > nambeg) { /* Skip for initial :: or ' */
+const char *key;
+GV**gvp;
+if (*name_cursor == ':') {
+key = *name;
+*len += 2;
+}
+else {
+char *tmpbuf;
+Newx(tmpbuf, *len+2, char);
+Copy(*name, tmpbuf, *len, char);
+tmpbuf[(*len)++] = ':';
+tmpbuf[(*len)++] = ':';
+key = tmpbuf;
+}
+gvp = (GV**)hv_fetch(*stash, key, is_utf8 ? -((I32)*len) : (I32)*len, add);
+*gv = gvp ? *gvp : NULL;
+if (*gv && *gv != (const GV *)&PL_sv_undef) {
+if (SvTYPE(*gv) != SVt_PVGV)
+gv_init_pvn(*gv, *stash, key, *len, (add & GV_ADDMULTI)|is_utf8);
+else
+GvMULTI_on(*gv);
+}
+if (key != *name)
+Safefree(key);
+if (!*gv || *gv == (const GV *)&PL_sv_undef)
+return FALSE;
+if (!(*stash = GvHV(*gv))) {
+*stash = GvHV(*gv) = newHV();
+if (!HvNAME_get(*stash)) {
+if (GvSTASH(*gv) == PL_defstash && *len == 6
+&& strnEQ(*name, "CORE", 4))
+hv_name_set(*stash, "CORE", 4, 0);
+else
+hv_name_set(
+*stash, nambeg, name_cursor-nambeg, is_utf8
+);
+/* If the containing stash has multiple effective
+names, see that this one gets them, too. */
+if (HvAUX(GvSTASH(*gv))->xhv_name_count)
+mro_package_moved(*stash, NULL, *gv, 1);
+}
+}
+else if (!HvNAME_get(*stash))
+hv_name_set(*stash, nambeg, name_cursor - nambeg, is_utf8);
+}
+if (*name_cursor == ':')
+name_cursor++;
+*name = name_cursor+1;
+if (*name == name_end) {
+if (!*gv)
+*gv = MUTABLE_GV(*hv_fetchs(PL_defstash, "main::", TRUE));
+return TRUE;
+}
+}
+}
+*len = name_cursor - *name;
+return TRUE;
+}
+/* Checks if an unqualified name is in the main stash */
+PERL_STATIC_INLINE bool
+S_gv_is_in_main(pTHX_ const char *name, STRLEN len, const U32 is_utf8)
+{
+PERL_ARGS_ASSERT_GV_IS_IN_MAIN;
+/* If it's an alphanumeric variable */
+if ( len && isIDFIRST_lazy_if(name, is_utf8) ) {
+/* Some "normal" variables are always in main::,
+* like INC or STDOUT.
+*/
+switch (len) {
+case 1:
+if (*name == '_')
+return TRUE;
+break;
+case 3:
+if ((name[0] == 'I' && name[1] == 'N' && name[2] == 'C')
+|| (name[0] == 'E' && name[1] == 'N' && name[2] == 'V')
+|| (name[0] == 'S' && name[1] == 'I' && name[2] == 'G'))
+return TRUE;
+break;
+case 4:
+if (name[0] == 'A' && name[1] == 'R' && name[2] == 'G'
+&& name[3] == 'V')
+return TRUE;
+break;
+case 5:
+if (name[0] == 'S' && name[1] == 'T' && name[2] == 'D'
+&& name[3] == 'I' && name[4] == 'N')
+return TRUE;
+break;
+case 6:
+if ((name[0] == 'S' && name[1] == 'T' && name[2] == 'D')
+&&((name[3] == 'O' && name[4] == 'U' && name[5] == 'T')
+||(name[3] == 'E' && name[4] == 'R' && name[5] == 'R')))
+return TRUE;
+break;
+case 7:
+if (name[0] == 'A' && name[1] == 'R' && name[2] == 'G'
+&& name[3] == 'V' && name[4] == 'O' && name[5] == 'U'
+&& name[6] == 'T')
+return TRUE;
+break;
+}
+}
+/* *{""}, or a special variable like $@ */
+else
+return TRUE;
+return FALSE;
+}
+/* This function is called if parse_gv_stash_name() failed to
+* find a stash, or if GV_NOTQUAL or an empty name was passed
+* to gv_fetchpvn_flags.
+*
+* It returns FALSE if the default stash can't be found nor created,
+* which might happen during global destruction.
+*/
+PERL_STATIC_INLINE bool
+S_find_default_stash(pTHX_ HV **stash, const char *name, STRLEN len,
+const U32 is_utf8, const I32 add,
+const svtype sv_type)
+{
+PERL_ARGS_ASSERT_FIND_DEFAULT_STASH;
+/* No stash in name, so see how we can default */
+if ( gv_is_in_main(name, len, is_utf8) ) {
+*stash = PL_defstash;
+}
+else {
+if (IN_PERL_COMPILETIME) {
+*stash = PL_curstash;
+if (add && (PL_hints & HINT_STRICT_VARS) &&
+sv_type != SVt_PVCV &&
+sv_type != SVt_PVGV &&
+sv_type != SVt_PVFM &&
+sv_type != SVt_PVIO &&
+!(len == 1 && sv_type == SVt_PV &&
+(*name == 'a' || *name == 'b')) )
+{
+GV**gvp = (GV**)hv_fetch(*stash,name,is_utf8 ? -(I32)len : (I32)len,0);
+if (!gvp || *gvp == (const GV *)&PL_sv_undef ||
+SvTYPE(*gvp) != SVt_PVGV)
+{
+*stash = NULL;
+}
+else if ((sv_type == SVt_PV   && !GvIMPORTED_SV(*gvp)) ||
+(sv_type == SVt_PVAV && !GvIMPORTED_AV(*gvp)) ||
+(sv_type == SVt_PVHV && !GvIMPORTED_HV(*gvp)) )
+{
+/* diag_listed_as: Variable "%s" is not imported%s */
+Perl_ck_warner_d(
+aTHX_ packWARN(WARN_MISC),
+"Variable \"%c%"UTF8f"\" is not imported",
+sv_type == SVt_PVAV ? '@' :
+sv_type == SVt_PVHV ? '%' : '$',
+UTF8fARG(is_utf8, len, name));
+if (GvCVu(*gvp))
+Perl_ck_warner_d(
+aTHX_ packWARN(WARN_MISC),
+"\t(Did you mean &%"UTF8f" instead?)\n",
+UTF8fARG(is_utf8, len, name)
+);
+*stash = NULL;
+}
+}
+}
+else {
+/* Use the current op's stash */
+*stash = CopSTASH(PL_curcop);
+}
+}
+if (!*stash) {
+if (add && !PL_in_clean_all) {
+GV *gv;
+qerror(Perl_mess(aTHX_
+"Global symbol \"%s%"UTF8f
+"\" requires explicit package name (did you forget to "
+"declare \"my %s%"UTF8f"\"?)",
+(sv_type == SVt_PV ? "$"
+: sv_type == SVt_PVAV ? "@"
+: sv_type == SVt_PVHV ? "%"
+: ""), UTF8fARG(is_utf8, len, name),
+(sv_type == SVt_PV ? "$"
+: sv_type == SVt_PVAV ? "@"
+: sv_type == SVt_PVHV ? "%"
+: ""), UTF8fARG(is_utf8, len, name)));
+/* To maintain the output of errors after the strict exception
+* above, and to keep compat with older releases, rather than
+* placing the variables in the pad, we place
+* them in the <none>:: stash.
+*/
+gv = gv_fetchpvs("<none>::", GV_ADDMULTI, SVt_PVHV);
+if (!gv) {
+/* symbol table under destruction */
+return FALSE;
+}
+*stash = GvHV(gv);
+}
+else
+return FALSE;
+}
+if (!SvREFCNT(*stash))   /* symbol table under destruction */
+return FALSE;
+return TRUE;
+}
+/* gv_magicalize only turns on the SVf_READONLY flag, not SVf_PROTECT.  So
+redefine SvREADONLY_on for that purpose.  We don’t use it later on in
+this file.  */
+#undef SvREADONLY_on
+#define SvREADONLY_on(sv) (SvFLAGS(sv) |= SVf_READONLY)
+/* gv_magicalize() is called by gv_fetchpvn_flags when creating
+* a new GV.
+* Note that it does not insert the GV into the stash prior to
+* magicalization, which some variables require need in order
+* to work (like $[, %+, %-, %!), so callers must take care of
+* that beforehand.
+*
+* The return value has a specific meaning for gv_fetchpvn_flags:
+* If it returns true, and the gv is empty, it indicates that its
+* refcount should be decreased.
+*/
+PERL_STATIC_INLINE bool
+S_gv_magicalize(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len,
+bool addmg, const svtype sv_type)
+{
+SSize_t paren;
+PERL_ARGS_ASSERT_GV_MAGICALIZE;
+if (stash != PL_defstash) { /* not the main stash */
+	/* We only have to check for a few names here: a, b, EXPORT, ISA
+	   and VERSION. All the others apply only to the main stash or to
+	   CORE (which is checked right after this). */
+	if (len) {
+	    const char * const name2 = name + 1;
+	    switch (*name) {
+	    case 'E':
+		if (strnEQ(name2, "XPORT", 5))
+		    GvMULTI_on(gv);
+		break;
+	    case 'I':
+		if (strEQ(name2, "SA"))
+		    gv_magicalize_isa(gv);
+		break;
+	    case 'V':
+		if (strEQ(name2, "ERSION"))
+		    GvMULTI_on(gv);
+		break;
+	    case 'a':
+	    case 'b':
+		if (len == 1 && sv_type == SVt_PV)
+		    GvMULTI_on(gv);
+		/* FALLTHROUGH */
+	    default:
+		goto try_core;
+	    }
+	    return addmg;
+	}
+try_core:
+	if (len > 1 /* shortest is uc */ && HvNAMELEN_get(stash) == 4) {
+	  /* Avoid null warning: */
+	  const char * const stashname = HvNAME(stash); assert(stashname);
+	  if (strnEQ(stashname, "CORE", 4))
+	    S_maybe_add_coresub(aTHX_ 0, gv, name, len);
+	}
+}
+else if (len > 1) {
+#ifndef EBCDIC
+	if (*name > 'V' ) {
+	    NOOP;
+	    /* Nothing else to do.
+	       The compiler will probably turn the switch statement into a
+	       branch table. Make sure we avoid even that small overhead for
+the common case of lower case variable names.  (On EBCDIC
+platforms, we can't just do:
+if (NATIVE_TO_ASCII(*name) > NATIVE_TO_ASCII('V') ) {
+because cases like '\027' in the switch statement below are
+C1 (non-ASCII) controls on those platforms, so the remapping
+would make them larger than 'V')
+*/
+	} else
+#endif
+	{
+	    const char * name2 = name + 1;
+	    switch (*name) {
+	    case 'A':
+		if (strEQ(name2, "RGV")) {
+		    IoFLAGS(GvIOn(gv)) |= IOf_ARGV|IOf_START;
+		}
+		else if (strEQ(name2, "RGVOUT")) {
+		    GvMULTI_on(gv);
+		}
+		break;
+	    case 'E':
+		if (strnEQ(name2, "XPORT", 5))
+		    GvMULTI_on(gv);
+		break;
+	    case 'I':
+		if (strEQ(name2, "SA")) {
+		    gv_magicalize_isa(gv);
+		}
+		break;
+	    case 'S':
+		if (strEQ(name2, "IG")) {
+		    HV *hv;
+		    I32 i;
+		    if (!PL_psig_name) {
+			Newxz(PL_psig_name, 2 * SIG_SIZE, SV*);
+			Newxz(PL_psig_pend, SIG_SIZE, int);
+			PL_psig_ptr = PL_psig_name + SIG_SIZE;
+		    } else {
+			/* I think that the only way to get here is to re-use an
+			   embedded perl interpreter, where the previous
+			   use didn't clean up fully because
+			   PL_perl_destruct_level was 0. I'm not sure that we
+			   "support" that, in that I suspect in that scenario
+			   there are sufficient other garbage values left in the
+			   interpreter structure that something else will crash
+			   before we get here. I suspect that this is one of
+			   those "doctor, it hurts when I do this" bugs.  */
+			Zero(PL_psig_name, 2 * SIG_SIZE, SV*);
+			Zero(PL_psig_pend, SIG_SIZE, int);
+		    }
+		    GvMULTI_on(gv);
+		    hv = GvHVn(gv);
+		    hv_magic(hv, NULL, PERL_MAGIC_sig);
+		    for (i = 1; i < SIG_SIZE; i++) {
+			SV * const * const init = hv_fetch(hv, PL_sig_name[i], strlen(PL_sig_name[i]), 1);
+			if (init)
+			    sv_setsv(*init, &PL_sv_undef);
+		    }
+		}
+		break;
+	    case 'V':
+		if (strEQ(name2, "ERSION"))
+		    GvMULTI_on(gv);
+		break;
+case '\003':        /* $^CHILD_ERROR_NATIVE */
+		if (strEQ(name2, "HILD_ERROR_NATIVE"))
+		    goto magicalize;
+		break;
+	    case '\005':	/* $^ENCODING */
+if (*name2 == '_') {
+name2++;
+}
+		if (strEQ(name2, "NCODING"))
+		    goto magicalize;
+		break;
+	    case '\007':	/* $^GLOBAL_PHASE */
+		if (strEQ(name2, "LOBAL_PHASE"))
+		    goto ro_magicalize;
+		break;
+	    case '\014':	/* $^LAST_FH */
+		if (strEQ(name2, "AST_FH"))
+		    goto ro_magicalize;
+		break;
+case '\015':        /* $^MATCH */
+if (strEQ(name2, "ATCH")) {
+paren = RX_BUFF_IDX_CARET_FULLMATCH;
+goto storeparen;
+}
+break;
+	    case '\017':	/* $^OPEN */
+		if (strEQ(name2, "PEN"))
+		    goto magicalize;
+		break;
+	    case '\020':        /* $^PREMATCH  $^POSTMATCH */
+if (strEQ(name2, "REMATCH")) {
+paren = RX_BUFF_IDX_CARET_PREMATCH;
+goto storeparen;
+}
+	        if (strEQ(name2, "OSTMATCH")) {
+paren = RX_BUFF_IDX_CARET_POSTMATCH;
+goto storeparen;
+}
+		break;
+	    case '\024':	/* ${^TAINT} */
+		if (strEQ(name2, "AINT"))
+		    goto ro_magicalize;
+		break;
+	    case '\025':	/* ${^UNICODE}, ${^UTF8LOCALE} */
+		if (strEQ(name2, "NICODE"))
+		    goto ro_magicalize;
+		if (strEQ(name2, "TF8LOCALE"))
+		    goto ro_magicalize;
+		if (strEQ(name2, "TF8CACHE"))
+		    goto magicalize;
+		break;
+	    case '\027':	/* $^WARNING_BITS */
+		if (strEQ(name2, "ARNING_BITS"))
+		    goto magicalize;
+		break;
+	    case '1':
+	    case '2':
+	    case '3':
+	    case '4':
+	    case '5':
+	    case '6':
+	    case '7':
+	    case '8':
+	    case '9':
+	    {
+		/* Ensures that we have an all-digit variable, ${"1foo"} fails
+		   this test  */
+UV uv;
+if (!grok_atoUV(name, &uv, NULL) || uv > I32_MAX)
+return addmg;
+/* XXX why are we using a SSize_t? */
+paren = (SSize_t)(I32)uv;
+goto storeparen;
+	    }
+	    }
+	}
+} else {
+	/* Names of length 1.  (Or 0. But name is NUL terminated, so that will
+	   be case '\0' in this switch statement (ie a default case)  */
+	switch (*name) {
+	case '&':		/* $& */
+paren = RX_BUFF_IDX_FULLMATCH;
+goto sawampersand;
+	case '`':		/* $` */
+paren = RX_BUFF_IDX_PREMATCH;
+goto sawampersand;
+	case '\'':		/* $' */
+paren = RX_BUFF_IDX_POSTMATCH;
+sawampersand:
+#ifdef PERL_SAWAMPERSAND
+	    if (!(
+		sv_type == SVt_PVAV ||
+		sv_type == SVt_PVHV ||
+		sv_type == SVt_PVCV ||
+		sv_type == SVt_PVFM ||
+		sv_type == SVt_PVIO
+		)) { PL_sawampersand |=
+(*name == '`')
+? SAWAMPERSAND_LEFT
+: (*name == '&')
+? SAWAMPERSAND_MIDDLE
+: SAWAMPERSAND_RIGHT;
+}
+#endif
+goto storeparen;
+case '1':               /* $1 */
+case '2':               /* $2 */
+case '3':               /* $3 */
+case '4':               /* $4 */
+case '5':               /* $5 */
+case '6':               /* $6 */
+case '7':               /* $7 */
+case '8':               /* $8 */
+case '9':               /* $9 */
+paren = *name - '0';
+storeparen:
+/* Flag the capture variables with a NULL mg_ptr
+Use mg_len for the array index to lookup.  */
+sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, NULL, paren);
+break;
+	case ':':		/* $: */
+	    sv_setpv(GvSVn(gv),PL_chopset);
+	    goto magicalize;
+	case '?':		/* $? */
+#ifdef COMPLEX_STATUS
+	    SvUPGRADE(GvSVn(gv), SVt_PVLV);
+#endif
+	    goto magicalize;
+	case '!':		/* $! */
+	    GvMULTI_on(gv);
+	    /* If %! has been used, automatically load Errno.pm. */
+	    sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
+/* magicalization must be done before require_tie_mod is called */
+	    if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
+	    {
+		require_tie_mod(gv, "!", newSVpvs("Errno"), "TIEHASH", 1);
+addmg = FALSE;
+	    }
+	    break;
+	case '-':		/* $- */
+	case '+':		/* $+ */
+	GvMULTI_on(gv); /* no used once warnings here */
+{
+AV* const av = GvAVn(gv);
+	    SV* const avc = (*name == '+') ? MUTABLE_SV(av) : NULL;
+	    sv_magic(MUTABLE_SV(av), avc, PERL_MAGIC_regdata, NULL, 0);
+sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
+if (avc)
+SvREADONLY_on(GvSVn(gv));
+SvREADONLY_on(av);
+if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
+	    {
+require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "TIEHASH", 0);
+addmg = FALSE;
+	    }
+break;
+	}
+	case '*':		/* $* */
+	case '#':		/* $# */
+	    if (sv_type == SVt_PV)
+		/* diag_listed_as: $* is no longer supported */
+		Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
+				 "$%c is no longer supported", *name);
+	    break;
+	case '\010':	/* $^H */
+	    {
+		HV *const hv = GvHVn(gv);
+		hv_magic(hv, NULL, PERL_MAGIC_hints);
+	    }
+	    goto magicalize;
+	case '[':		/* $[ */
+	    if ((sv_type == SVt_PV || sv_type == SVt_PVGV)
+	     && FEATURE_ARYBASE_IS_ENABLED) {
+		require_tie_mod(gv,name,newSVpvs("arybase"),"FETCH",0);
+addmg = FALSE;
+	    }
+	    else goto magicalize;
+break;
+	case '\023':	/* $^S */
+	ro_magicalize:
+	    SvREADONLY_on(GvSVn(gv));
+	    /* FALLTHROUGH */
+	case '0':		/* $0 */
+	case '^':		/* $^ */
+	case '~':		/* $~ */
+	case '=':		/* $= */
+	case '%':		/* $% */
+	case '.':		/* $. */
+	case '(':		/* $( */
+	case ')':		/* $) */
+	case '<':		/* $< */
+	case '>':		/* $> */
+	case '\\':		/* $\ */
+	case '/':		/* $/ */
+	case '|':		/* $| */
+	case '$':		/* $$ */
+	case '\001':	/* $^A */
+	case '\003':	/* $^C */
+	case '\004':	/* $^D */
+	case '\005':	/* $^E */
+	case '\006':	/* $^F */
+	case '\011':	/* $^I, NOT \t in EBCDIC */
+	case '\016':	/* $^N */
+	case '\017':	/* $^O */
+	case '\020':	/* $^P */
+	case '\024':	/* $^T */
+	case '\027':	/* $^W */
+	magicalize:
+	    sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
+	    break;
+	case '\014':	/* $^L */
+	    sv_setpvs(GvSVn(gv),"\f");
+	    break;
+	case ';':		/* $; */
+	    sv_setpvs(GvSVn(gv),"\034");
+	    break;
+	case ']':		/* $] */
+	{
+	    SV * const sv = GvSV(gv);
+	    if (!sv_derived_from(PL_patchlevel, "version"))
+		upg_version(PL_patchlevel, TRUE);
+	    GvSV(gv) = vnumify(PL_patchlevel);
+	    SvREADONLY_on(GvSV(gv));
+	    SvREFCNT_dec(sv);
+	}
+	break;
+	case '\026':	/* $^V */
+	{
+	    SV * const sv = GvSV(gv);
+	    GvSV(gv) = new_version(PL_patchlevel);
+	    SvREADONLY_on(GvSV(gv));
+	    SvREFCNT_dec(sv);
+	}
+	break;
+	case 'a':
+	case 'b':
+	    if (sv_type == SVt_PV)
+		GvMULTI_on(gv);
+	}
+}
+return addmg;
+}
+/* If we do ever start using this later on in the file, we need to make
+sure we don’t accidentally use the wrong definition.  */
+#undef SvREADONLY_on
+/* This function is called when the stash already holds the GV of the magic
+* variable we're looking for, but we need to check that it has the correct
+* kind of magic.  For example, if someone first uses $! and then %!, the
+* latter would end up here, and we add the Errno tie to the HASH slot of
+* the *! glob.
+*/
+PERL_STATIC_INLINE void
+S_maybe_multimagic_gv(pTHX_ GV *gv, const char *name, const svtype sv_type)
+{
+PERL_ARGS_ASSERT_MAYBE_MULTIMAGIC_GV;
+if (sv_type == SVt_PVHV || sv_type == SVt_PVGV) {
+if (*name == '!')
+require_tie_mod(gv, "!", newSVpvs("Errno"), "TIEHASH", 1);
+else if (*name == '-' || *name == '+')
+require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "TIEHASH", 0);
+} else if (sv_type == SVt_PV) {
+if (*name == '*' || *name == '#') {
+/* diag_listed_as: $* is no longer supported */
+Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED,
+WARN_SYNTAX),
+"$%c is no longer supported", *name);
+}
+}
+if (sv_type==SVt_PV || sv_type==SVt_PVGV) {
+switch (*name) {
+case '[':
+require_tie_mod(gv,name,newSVpvs("arybase"),"FETCH",0);
+break;
+#ifdef PERL_SAWAMPERSAND
+case '`':
+PL_sawampersand |= SAWAMPERSAND_LEFT;
+(void)GvSVn(gv);
+break;
+case '&':
+PL_sawampersand |= SAWAMPERSAND_MIDDLE;
+(void)GvSVn(gv);
+break;
+case '\'':
+PL_sawampersand |= SAWAMPERSAND_RIGHT;
+(void)GvSVn(gv);
+break;
+#endif
+}
+}
+}
+GV *
+Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
+		       const svtype sv_type)
+{
+const char *name = nambeg;
+GV *gv = NULL;
+GV**gvp;
+STRLEN len;
+HV *stash = NULL;
+const I32 no_init = flags & (GV_NOADD_NOINIT | GV_NOINIT);
+const I32 no_expand = flags & GV_NOEXPAND;
+const I32 add = flags & ~GV_NOADD_MASK;
+const U32 is_utf8 = flags & SVf_UTF8;
+bool addmg = cBOOL(flags & GV_ADDMG);
+const char *const name_end = nambeg + full_len;
+U32 faking_it;
+PERL_ARGS_ASSERT_GV_FETCHPVN_FLAGS;
+/* If we have GV_NOTQUAL, the caller promised that
+* there is no stash, so we can skip the check.
+* Similarly if full_len is 0, since then we're
+* dealing with something like *{""} or ""->foo()
+*/
+if ((flags & GV_NOTQUAL) || !full_len) {
+len = full_len;
+}
+else if (parse_gv_stash_name(&stash, &gv, &name, &len, nambeg, full_len, is_utf8, add)) {
+if (name == name_end) return gv;
+}
+else {
+return NULL;
+}
+if (!stash && !find_default_stash(&stash, name, len, is_utf8, add, sv_type)) {
+return NULL;
+}
+/* By this point we should have a stash and a name */
+gvp = (GV**)hv_fetch(stash,name,is_utf8 ? -(I32)len : (I32)len,add);
+if (!gvp || *gvp == (const GV *)&PL_sv_undef) {
+	if (addmg) gv = (GV *)newSV(0);
+	else return NULL;
+}
+else gv = *gvp, addmg = 0;
+/* From this point on, addmg means gv has not been inserted in the
+symtab yet. */
+if (SvTYPE(gv) == SVt_PVGV) {
+/* The GV already exists, so return it, but check if we need to do
+* anything else with it before that.
+*/
+	if (add) {
+/* This is the heuristic that handles if a variable triggers the
+* 'used only once' warning.  If there's already a GV in the stash
+* with this name, then we assume that the variable has been used
+* before and turn its MULTI flag on.
+* It's a heuristic because it can easily be "tricked", like with
+* BEGIN { $a = 1; $::{foo} = *a }; () = $foo
+* not warning about $main::foo being used just once
+*/
+	    GvMULTI_on(gv);
+	    gv_init_svtype(gv, sv_type);
+/* You reach this path once the typeglob has already been created,
+either by the same or a different sigil.  If this path didn't
+exist, then (say) referencing $! first, and %! second would
+mean that %! was not handled correctly.  */
+	    if (len == 1 && stash == PL_defstash) {
+maybe_multimagic_gv(gv, name, sv_type);
+	    }
+	    else if (len == 3 && sv_type == SVt_PVAV
+	          && strnEQ(name, "ISA", 3)
+	          && (!GvAV(gv) || !SvSMAGICAL(GvAV(gv))))
+		gv_magicalize_isa(gv);
+	}
+	return gv;
+} else if (no_init) {
+	assert(!addmg);
+	return gv;
+}
+/* If GV_NOEXPAND is true and what we got off the stash is a ref,
+* don't expand it to a glob. This is an optimization so that things
+* copying constants over, like Exporter, don't have to be rewritten
+* to take into account that you can store more than just globs in
+* stashes.
+*/
+else if (no_expand && SvROK(gv)) {
+	assert(!addmg);
+	return gv;
+}
+/* Adding a new symbol.
+Unless of course there was already something non-GV here, in which case
+we want to behave as if there was always a GV here, containing some sort
+of subroutine.
+Otherwise we run the risk of creating things like GvIO, which can cause
+subtle bugs. eg the one that tripped up SQL::Translator  */
+faking_it = SvOK(gv);
+if (add & GV_ADDWARN)
+	Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
+		"Had to create %"UTF8f" unexpectedly",
+		 UTF8fARG(is_utf8, name_end-nambeg, nambeg));
+gv_init_pvn(gv, stash, name, len, (add & GV_ADDMULTI)|is_utf8);
+if ( isIDFIRST_lazy_if(name, is_utf8) && !ckWARN(WARN_ONCE) )
+GvMULTI_on(gv) ;
+/* First, store the gv in the symtab if we're adding magic,
+* but only for non-empty GVs
+*/
+#define GvEMPTY(gv)      !(GvAV(gv) || GvHV(gv) || GvIO(gv) \
+|| GvCV(gv) || (GvSV(gv) && SvOK(GvSV(gv))))
+if ( addmg && !GvEMPTY(gv) ) {
+(void)hv_store(stash,name,len,(SV *)gv,0);
+}
+/* set up magic where warranted */
+if ( gv_magicalize(gv, stash, name, len, addmg, sv_type) ) {
+/* See 23496c6 */
+if (GvEMPTY(gv)) {
+if ( GvSV(gv) && SvMAGICAL(GvSV(gv)) ) {
+/* The GV was and still is "empty", except that now
+* it has the magic flags turned on, so we want it
+* stored in the symtab.
+*/
+(void)hv_store(stash,name,len,(SV *)gv,0);
+}
+else {
+/* Most likely the temporary GV created above */
+SvREFCNT_dec_NN(gv);
+gv = NULL;
+}
+}
+}
+if (gv) gv_init_svtype(gv, faking_it ? SVt_PVCV : sv_type);
+return gv;
+}
+void
+Perl_gv_fullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
+{
+const char *name;
+const HV * const hv = GvSTASH(gv);
+PERL_ARGS_ASSERT_GV_FULLNAME4;
+sv_setpv(sv, prefix ? prefix : "");
+if (hv && (name = HvNAME(hv))) {
+const STRLEN len = HvNAMELEN(hv);
+if (keepmain || strnNE(name, "main", len)) {
+	sv_catpvn_flags(sv,name,len,HvNAMEUTF8(hv)?SV_CATUTF8:SV_CATBYTES);
+	sv_catpvs(sv,"::");
+}
+}
+else sv_catpvs(sv,"__ANON__::");
+sv_catsv(sv,sv_2mortal(newSVhek(GvNAME_HEK(gv))));
+}
+void
+Perl_gv_efullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
+{
+const GV * const egv = GvEGVx(gv);
+PERL_ARGS_ASSERT_GV_EFULLNAME4;
+gv_fullname4(sv, egv ? egv : gv, prefix, keepmain);
+}
+/* recursively scan a stash and any nested stashes looking for entries
+* that need the "only used once" warning raised
+*/
+void
+Perl_gv_check(pTHX_ HV *stash)
+{
+I32 i;
+PERL_ARGS_ASSERT_GV_CHECK;
+if (!HvARRAY(stash))
+	return;
+assert(SvOOK(stash));
+for (i = 0; i <= (I32) HvMAX(stash); i++) {
+const HE *entry;
+/* mark stash is being scanned, to avoid recursing */
+HvAUX(stash)->xhv_aux_flags |= HvAUXf_SCAN_STASH;
+	for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
+GV *gv;
+HV *hv;
+	    if (HeKEY(entry)[HeKLEN(entry)-1] == ':' &&
+		(gv = MUTABLE_GV(HeVAL(entry))) && isGV(gv) && (hv = GvHV(gv)))
+	    {
+		if (hv != PL_defstash && hv != stash
+&& !(SvOOK(hv)
+&& (HvAUX(hv)->xhv_aux_flags & HvAUXf_SCAN_STASH))
+)
+		     gv_check(hv);              /* nested package */
+	    }
+else if ( *HeKEY(entry) != '_'
+&& isIDFIRST_lazy_if(HeKEY(entry), HeUTF8(entry)) ) {
+const char *file;
+		gv = MUTABLE_GV(HeVAL(entry));
+		if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv))
+		    continue;
+		file = GvFILE(gv);
+		CopLINE_set(PL_curcop, GvLINE(gv));
+#ifdef USE_ITHREADS
+		CopFILE(PL_curcop) = (char *)file;	/* set for warning */
+#else
+		CopFILEGV(PL_curcop)
+		    = gv_fetchfile_flags(file, HEK_LEN(GvFILE_HEK(gv)), 0);
+#endif
+		Perl_warner(aTHX_ packWARN(WARN_ONCE),
+			"Name \"%"HEKf"::%"HEKf
+			"\" used only once: possible typo",
+HEKfARG(HvNAME_HEK(stash)),
+HEKfARG(GvNAME_HEK(gv)));
+	    }
+	}
+HvAUX(stash)->xhv_aux_flags &= ~HvAUXf_SCAN_STASH;
+}
+}
+GV *
+Perl_newGVgen_flags(pTHX_ const char *pack, U32 flags)
+{
+PERL_ARGS_ASSERT_NEWGVGEN_FLAGS;
+assert(!(flags & ~SVf_UTF8));
+return gv_fetchpv(Perl_form(aTHX_ "%"UTF8f"::_GEN_%ld",
+UTF8fARG(flags, strlen(pack), pack),
+(long)PL_gensym++),
+GV_ADD, SVt_PVGV);
+}
+/* hopefully this is only called on local symbol table entries */
+GP*
+Perl_gp_ref(pTHX_ GP *gp)
+{
+if (!gp)
+	return NULL;
+gp->gp_refcnt++;
+if (gp->gp_cv) {
+	if (gp->gp_cvgen) {
+	    /* If the GP they asked for a reference to contains
+a method cache entry, clear it first, so that we
+don't infect them with our cached entry */
+	    SvREFCNT_dec_NN(gp->gp_cv);
+	    gp->gp_cv = NULL;
+	    gp->gp_cvgen = 0;
+	}
+}
+return gp;
+}
+void
+Perl_gp_free(pTHX_ GV *gv)
+{
+GP* gp;
+int attempts = 100;
+if (!gv || !isGV_with_GP(gv) || !(gp = GvGP(gv)))
+	return;
+if (gp->gp_refcnt == 0) {
+	Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
+			 "Attempt to free unreferenced glob pointers"
+			 pTHX__FORMAT pTHX__VALUE);
+return;
+}
+if (gp->gp_refcnt > 1) {
+borrowed:
+	if (gp->gp_egv == gv)
+	    gp->gp_egv = 0;
+	gp->gp_refcnt--;
+	GvGP_set(gv, NULL);
+return;
+}
+while (1) {
+/* Copy and null out all the glob slots, so destructors do not see
+freed SVs. */
+HEK * const file_hek = gp->gp_file_hek;
+SV  * const sv       = gp->gp_sv;
+AV  * const av       = gp->gp_av;
+HV  * const hv       = gp->gp_hv;
+IO  * const io       = gp->gp_io;
+CV  * const cv       = gp->gp_cv;
+CV  * const form     = gp->gp_form;
+gp->gp_file_hek = NULL;
+gp->gp_sv       = NULL;
+gp->gp_av       = NULL;
+gp->gp_hv       = NULL;
+gp->gp_io       = NULL;
+gp->gp_cv       = NULL;
+gp->gp_form     = NULL;
+if (file_hek)
+	unshare_hek(file_hek);
+SvREFCNT_dec(sv);
+SvREFCNT_dec(av);
+/* FIXME - another reference loop GV -> symtab -> GV ?
+Somehow gp->gp_hv can end up pointing at freed garbage.  */
+if (hv && SvTYPE(hv) == SVt_PVHV) {
+const HEK *hvname_hek = HvNAME_HEK(hv);
+if (PL_stashcache && hvname_hek) {
+DEBUG_o(Perl_deb(aTHX_
+"gp_free clearing PL_stashcache for '%"HEKf"'\n",
+HEKfARG(hvname_hek)));
+(void)hv_deletehek(PL_stashcache, hvname_hek, G_DISCARD);
+}
+	SvREFCNT_dec(hv);
+}
+if (io && SvREFCNT(io) == 1 && IoIFP(io)
+	     && (IoTYPE(io) == IoTYPE_WRONLY ||
+		 IoTYPE(io) == IoTYPE_RDWR   ||
+		 IoTYPE(io) == IoTYPE_APPEND)
+	     && ckWARN_d(WARN_IO)
+	     && IoIFP(io) != PerlIO_stdin()
+	     && IoIFP(io) != PerlIO_stdout()
+	     && IoIFP(io) != PerlIO_stderr()
+	     && !(IoFLAGS(io) & IOf_FAKE_DIRP))
+	io_close(io, gv, FALSE, TRUE);
+SvREFCNT_dec(io);
+SvREFCNT_dec(cv);
+SvREFCNT_dec(form);
+/* Possibly reallocated by a destructor */
+gp = GvGP(gv);
+if (!gp->gp_file_hek
+&& !gp->gp_sv
+&& !gp->gp_av
+&& !gp->gp_hv
+&& !gp->gp_io
+&& !gp->gp_cv
+&& !gp->gp_form) break;
+if (--attempts == 0) {
+	Perl_die(aTHX_
+	  "panic: gp_free failed to free glob pointer - "
+	  "something is repeatedly re-creating entries"
+	);
+}
+}
+/* Possibly incremented by a destructor doing glob assignment */
+if (gp->gp_refcnt > 1) goto borrowed;
+Safefree(gp);
+GvGP_set(gv, NULL);
+}
+int
+Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg)
+{
+AMT * const amtp = (AMT*)mg->mg_ptr;
+PERL_UNUSED_ARG(sv);
+PERL_ARGS_ASSERT_MAGIC_FREEOVRLD;
+if (amtp && AMT_AMAGIC(amtp)) {
+	int i;
+	for (i = 1; i < NofAMmeth; i++) {
+	    CV * const cv = amtp->table[i];
+	    if (cv) {
+		SvREFCNT_dec_NN(MUTABLE_SV(cv));
+		amtp->table[i] = NULL;
+	    }
+	}
+}
+return 0;
+}
+/* Updates and caches the CV's */
+/* Returns:
+* 1 on success and there is some overload
+* 0 if there is no overload
+* -1 if some error occurred and it couldn't croak
+*/
+int
+Perl_Gv_AMupdate(pTHX_ HV *stash, bool destructing)
+{
+MAGIC* const mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
+AMT amt;
+const struct mro_meta* stash_meta = HvMROMETA(stash);
+U32 newgen;
+PERL_ARGS_ASSERT_GV_AMUPDATE;
+newgen = PL_sub_generation + stash_meta->pkg_gen + stash_meta->cache_gen;
+if (mg) {
+const AMT * const amtp = (AMT*)mg->mg_ptr;
+if (amtp->was_ok_sub == newgen) {
+	  return AMT_AMAGIC(amtp) ? 1 : 0;
+}
+sv_unmagic(MUTABLE_SV(stash), PERL_MAGIC_overload_table);
+}
+DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME_get(stash)) );
+Zero(&amt,1,AMT);
+amt.was_ok_sub = newgen;
+amt.fallback = AMGfallNO;
+amt.flags = 0;
+{
+int filled = 0;
+int i;
+bool deref_seen = 0;
+/* Work with "fallback" key, which we assume to be first in PL_AMG_names */
+/* Try to find via inheritance. */
+GV *gv = gv_fetchmeth_pvn(stash, PL_AMG_names[0], 2, -1, 0);
+SV * const sv = gv ? GvSV(gv) : NULL;
+CV* cv;
+if (!gv)
+{
+if (!gv_fetchmeth_pvn(stash, "((", 2, -1, 0))
+	goto no_table;
+}
+#ifdef PERL_DONT_CREATE_GVSV
+else if (!sv) {
+	NOOP;   /* Equivalent to !SvTRUE and !SvOK  */
+}
+#endif
+else if (SvTRUE(sv))
+/* don't need to set overloading here because fallback => 1
+* is the default setting for classes without overloading */
+	amt.fallback=AMGfallYES;
+else if (SvOK(sv)) {
+	amt.fallback=AMGfallNEVER;
+filled = 1;
+}
+else {
+filled = 1;
+}
+assert(SvOOK(stash));
+/* initially assume the worst */
+HvAUX(stash)->xhv_aux_flags &= ~HvAUXf_NO_DEREF;
+for (i = 1; i < NofAMmeth; i++) {
+	const char * const cooky = PL_AMG_names[i];
+	/* Human-readable form, for debugging: */
+	const char * const cp = AMG_id2name(i);
+	const STRLEN l = PL_AMG_namelens[i];
+	DEBUG_o( Perl_deb(aTHX_ "Checking overloading of \"%s\" in package \"%.256s\"\n",
+		     cp, HvNAME_get(stash)) );
+	/* don't fill the cache while looking up!
+	   Creation of inheritance stubs in intermediate packages may
+	   conflict with the logic of runtime method substitution.
+	   Indeed, for inheritance A -> B -> C, if C overloads "+0",
+	   then we could have created stubs for "(+0" in A and C too.
+	   But if B overloads "bool", we may want to use it for
+	   numifying instead of C's "+0". */
+	gv = Perl_gv_fetchmeth_pvn(aTHX_ stash, cooky, l, -1, 0);
+cv = 0;
+if (gv && (cv = GvCV(gv)) && CvHASGV(cv)) {
+const HEK * const gvhek =
+CvNAMED(cv) ? CvNAME_HEK(cv) : GvNAME_HEK(CvGV(cv));
+const HEK * const stashek =
+HvNAME_HEK(CvNAMED(cv) ? CvSTASH(cv) : GvSTASH(CvGV(cv)));
+if (HEK_LEN(gvhek) == 3 && strEQ(HEK_KEY(gvhek), "nil")
+&& stashek && HEK_LEN(stashek) == 8
+&& strEQ(HEK_KEY(stashek), "overload")) {
+		/* This is a hack to support autoloading..., while
+		   knowing *which* methods were declared as overloaded. */
+		/* GvSV contains the name of the method. */
+		GV *ngv = NULL;
+		SV *gvsv = GvSV(gv);
+		DEBUG_o( Perl_deb(aTHX_ "Resolving method \"%"SVf256\
+			"\" for overloaded \"%s\" in package \"%.256s\"\n",
+			     (void*)GvSV(gv), cp, HvNAME(stash)) );
+		if (!gvsv || !SvPOK(gvsv)
+		    || !(ngv = gv_fetchmethod_sv_flags(stash, gvsv, 0)))
+		{
+		    /* Can be an import stub (created by "can"). */
+		    if (destructing) {
+			return -1;
+		    }
+		    else {
+			const SV * const name = (gvsv && SvPOK(gvsv))
+? gvsv
+: newSVpvs_flags("???", SVs_TEMP);
+			/* diag_listed_as: Can't resolve method "%s" overloading "%s" in package "%s" */
+			Perl_croak(aTHX_ "%s method \"%"SVf256
+				    "\" overloading \"%s\" "\
+				    "in package \"%"HEKf256"\"",
+				   (GvCVGEN(gv) ? "Stub found while resolving"
+				    : "Can't resolve"),
+				   SVfARG(name), cp,
+HEKfARG(
+					HvNAME_HEK(stash)
+				   ));
+		    }
+		}
+		cv = GvCV(gv = ngv);
+	    }
+	    DEBUG_o( Perl_deb(aTHX_ "Overloading \"%s\" in package \"%.256s\" via \"%.256s::%.256s\"\n",
+			 cp, HvNAME_get(stash), HvNAME_get(GvSTASH(CvGV(cv))),
+			 GvNAME(CvGV(cv))) );
+	    filled = 1;
+	} else if (gv) {		/* Autoloaded... */
+	    cv = MUTABLE_CV(gv);
+	    filled = 1;
+	}
+	amt.table[i]=MUTABLE_CV(SvREFCNT_inc_simple(cv));
+if (gv) {
+switch (i) {
+case to_sv_amg:
+case to_av_amg:
+case to_hv_amg:
+case to_gv_amg:
+case to_cv_amg:
+case nomethod_amg:
+deref_seen = 1;
+break;
+}
+}
+}
+if (!deref_seen)
+/* none of @{} etc overloaded; we can do $obj->[N] quicker.
+* NB - aux var invalid here, HvARRAY() could have been
+* reallocated since it was assigned to */
+HvAUX(stash)->xhv_aux_flags |= HvAUXf_NO_DEREF;
+if (filled) {
+AMT_AMAGIC_on(&amt);
+sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table,
+						(char*)&amt, sizeof(AMT));
+return TRUE;
+}
+}
+/* Here we have no table: */
+no_table:
+AMT_AMAGIC_off(&amt);
+sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table,
+						(char*)&amt, sizeof(AMTS));
+return 0;
+}
+CV*
+Perl_gv_handler(pTHX_ HV *stash, I32 id)
+{
+MAGIC *mg;
+AMT *amtp;
+U32 newgen;
+struct mro_meta* stash_meta;
+if (!stash || !HvNAME_get(stash))
+return NULL;
+stash_meta = HvMROMETA(stash);
+newgen = PL_sub_generation + stash_meta->pkg_gen + stash_meta->cache_gen;
+mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
+if (!mg) {
+do_update:
+	if (Gv_AMupdate(stash, 0) == -1)
+	    return NULL;
+	mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
+}
+assert(mg);
+amtp = (AMT*)mg->mg_ptr;
+if ( amtp->was_ok_sub != newgen )
+	goto do_update;
+if (AMT_AMAGIC(amtp)) {
+	CV * const ret = amtp->table[id];
+	if (ret && isGV(ret)) {		/* Autoloading stab */
+	    /* Passing it through may have resulted in a warning
+	       "Inherited AUTOLOAD for a non-method deprecated", since
+	       our caller is going through a function call, not a method call.
+	       So return the CV for AUTOLOAD, setting $AUTOLOAD. */
+	    GV * const gv = gv_fetchmethod(stash, PL_AMG_names[id]);
+	    if (gv && GvCV(gv))
+		return GvCV(gv);
+	}
+	return ret;
+}
+return NULL;
+}
+/* Implement tryAMAGICun_MG macro.
+Do get magic, then see if the stack arg is overloaded and if so call it.
+Flags:
+	AMGf_set     return the arg using SETs rather than assigning to
+		     the targ
+	AMGf_numeric apply sv_2num to the stack arg.
+*/
+bool
+Perl_try_amagic_un(pTHX_ int method, int flags) {
+dSP;
+SV* tmpsv;
+SV* const arg = TOPs;
+SvGETMAGIC(arg);
+if (SvAMAGIC(arg) && (tmpsv = amagic_call(arg, &PL_sv_undef, method,
+					      AMGf_noright | AMGf_unary
+					    | (flags & AMGf_numarg))))
+{
+	if (flags & AMGf_set) {
+	    SETs(tmpsv);
+	}
+	else {
+	    dTARGET;
+	    if (SvPADMY(TARG)) {
+		sv_setsv(TARG, tmpsv);
+		SETTARG;
+	    }
+	    else
+		SETs(tmpsv);
+	}
+	PUTBACK;
+	return TRUE;
+}
+if ((flags & AMGf_numeric) && SvROK(arg))
+	*sp = sv_2num(arg);
+return FALSE;
+}
+/* Implement tryAMAGICbin_MG macro.
+Do get magic, then see if the two stack args are overloaded and if so
+call it.
+Flags:
+	AMGf_set     return the arg using SETs rather than assigning to
+		     the targ
+	AMGf_assign  op may be called as mutator (eg +=)
+	AMGf_numeric apply sv_2num to the stack arg.
+*/
+bool
+Perl_try_amagic_bin(pTHX_ int method, int flags) {
+dSP;
+SV* const left = TOPm1s;
+SV* const right = TOPs;
+SvGETMAGIC(left);
+if (left != right)
+	SvGETMAGIC(right);
+if (SvAMAGIC(left) || SvAMAGIC(right)) {
+	SV * const tmpsv = amagic_call(left, right, method,
+		    ((flags & AMGf_assign) && opASSIGN ? AMGf_assign: 0)
+		  | (flags & AMGf_numarg));
+	if (tmpsv) {
+	    if (flags & AMGf_set) {
+		(void)POPs;
+		SETs(tmpsv);
+	    }
+	    else {
+		dATARGET;
+		(void)POPs;
+		if (opASSIGN || SvPADMY(TARG)) {
+		    sv_setsv(TARG, tmpsv);
+		    SETTARG;
+		}
+		else
+		    SETs(tmpsv);
+	    }
+	    PUTBACK;
+	    return TRUE;
+	}
+}
+if(left==right && SvGMAGICAL(left)) {
+	SV * const left = sv_newmortal();
+	*(sp-1) = left;
+	/* Print the uninitialized warning now, so it includes the vari-
+	   able name. */
+	if (!SvOK(right)) {
+	    if (ckWARN(WARN_UNINITIALIZED)) report_uninit(right);
+	    sv_setsv_flags(left, &PL_sv_no, 0);
+	}
+	else sv_setsv_flags(left, right, 0);
+	SvGETMAGIC(right);
+}
+if (flags & AMGf_numeric) {
+	if (SvROK(TOPm1s))
+	    *(sp-1) = sv_2num(TOPm1s);
+	if (SvROK(right))
+	    *sp     = sv_2num(right);
+}
+return FALSE;
+}
+SV *
+Perl_amagic_deref_call(pTHX_ SV *ref, int method) {
+SV *tmpsv = NULL;
+HV *stash;
+PERL_ARGS_ASSERT_AMAGIC_DEREF_CALL;
+if (!SvAMAGIC(ref))
+return ref;
+/* return quickly if none of the deref ops are overloaded */
+stash = SvSTASH(SvRV(ref));
+assert(SvOOK(stash));
+if (HvAUX(stash)->xhv_aux_flags & HvAUXf_NO_DEREF)
+return ref;
+while ((tmpsv = amagic_call(ref, &PL_sv_undef, method,
+				AMGf_noright | AMGf_unary))) {
+	if (!SvROK(tmpsv))
+	    Perl_croak(aTHX_ "Overloaded dereference did not return a reference");
+	if (tmpsv == ref || SvRV(tmpsv) == SvRV(ref)) {
+	    /* Bail out if it returns us the same reference.  */
+	    return tmpsv;
+	}
+	ref = tmpsv;
+if (!SvAMAGIC(ref))
+break;
+}
+return tmpsv ? tmpsv : ref;
+}
+bool
+Perl_amagic_is_enabled(pTHX_ int method)
+{
+SV *lex_mask = cop_hints_fetch_pvs(PL_curcop, "overloading", 0);
+assert(PL_curcop->cop_hints & HINT_NO_AMAGIC);
+if ( !lex_mask || !SvOK(lex_mask) )
+	  /* overloading lexically disabled */
+	  return FALSE;
+else if ( lex_mask && SvPOK(lex_mask) ) {
+	  /* we have an entry in the hints hash, check if method has been
+	   * masked by overloading.pm */
+	  STRLEN len;
+	  const int offset = method / 8;
+	  const int bit    = method % 8;
+	  char *pv = SvPV(lex_mask, len);
+	  /* Bit set, so this overloading operator is disabled */
+	  if ( (STRLEN)offset < len && pv[offset] & ( 1 << bit ) )
+	      return FALSE;
+}
+return TRUE;
+}
+SV*
+Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
+{
+dVAR;
+MAGIC *mg;
+CV *cv=NULL;
+CV **cvp=NULL, **ocvp=NULL;
+AMT *amtp=NULL, *oamtp=NULL;
+int off = 0, off1, lr = 0, notfound = 0;
+int postpr = 0, force_cpy = 0;
+int assign = AMGf_assign & flags;
+const int assignshift = assign ? 1 : 0;
+int use_default_op = 0;
+int force_scalar = 0;
+#ifdef DEBUGGING
+int fl=0;
+#endif
+HV* stash=NULL;
+PERL_ARGS_ASSERT_AMAGIC_CALL;
+if ( PL_curcop->cop_hints & HINT_NO_AMAGIC ) {
+if (!amagic_is_enabled(method)) return NULL;
+}
+if (!(AMGf_noleft & flags) && SvAMAGIC(left)
+&& (stash = SvSTASH(SvRV(left))) && Gv_AMG(stash)
+&& (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table))
+&& (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
+			? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
+			: NULL))
+&& ((cv = cvp[off=method+assignshift])
+	  || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
+						          * usual method */
+		  (
+#ifdef DEBUGGING
+		   fl = 1,
+#endif
+		   cv = cvp[off=method])))) {
+lr = -1;			/* Call method for left argument */
+} else {
+if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) {
+int logic;
+/* look for substituted methods */
+/* In all the covered cases we should be called with assign==0. */
+	 switch (method) {
+	 case inc_amg:
+	   force_cpy = 1;
+	   if ((cv = cvp[off=add_ass_amg])
+	       || ((cv = cvp[off = add_amg]) && (force_cpy = 0, postpr = 1))) {
+	     right = &PL_sv_yes; lr = -1; assign = 1;
+	   }
+	   break;
+	 case dec_amg:
+	   force_cpy = 1;
+	   if ((cv = cvp[off = subtr_ass_amg])
+	       || ((cv = cvp[off = subtr_amg]) && (force_cpy = 0, postpr=1))) {
+	     right = &PL_sv_yes; lr = -1; assign = 1;
+	   }
+	   break;
+	 case bool__amg:
+	   (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg]));
+	   break;
+	 case numer_amg:
+	   (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg]));
+	   break;
+	 case string_amg:
+	   (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg]));
+	   break;
+case not_amg:
+(void)((cv = cvp[off=bool__amg])
+|| (cv = cvp[off=numer_amg])
+|| (cv = cvp[off=string_amg]));
+if (cv)
+postpr = 1;
+break;
+	 case copy_amg:
+	   {
+	     /*
+		  * SV* ref causes confusion with the interpreter variable of
+		  * the same name
+		  */
+	     SV* const tmpRef=SvRV(left);
+	     if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) {
+		/*
+		 * Just to be extra cautious.  Maybe in some
+		 * additional cases sv_setsv is safe, too.
+		 */
+		SV* const newref = newSVsv(tmpRef);
+		SvOBJECT_on(newref);
+		/* No need to do SvAMAGIC_on here, as SvAMAGIC macros
+		   delegate to the stash. */
+		SvSTASH_set(newref, MUTABLE_HV(SvREFCNT_inc(SvSTASH(tmpRef))));
+		return newref;
+	     }
+	   }
+	   break;
+	 case abs_amg:
+	   if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg])
+	       && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) {
+	     SV* const nullsv=sv_2mortal(newSViv(0));
+	     if (off1==lt_amg) {
+	       SV* const lessp = amagic_call(left,nullsv,
+				       lt_amg,AMGf_noright);
+	       logic = SvTRUE(lessp);
+	     } else {
+	       SV* const lessp = amagic_call(left,nullsv,
+				       ncmp_amg,AMGf_noright);
+	       logic = (SvNV(lessp) < 0);
+	     }
+	     if (logic) {
+	       if (off==subtr_amg) {
+		 right = left;
+		 left = nullsv;
+		 lr = 1;
+	       }
+	     } else {
+	       return left;
+	     }
+	   }
+	   break;
+	 case neg_amg:
+	   if ((cv = cvp[off=subtr_amg])) {
+	     right = left;
+	     left = sv_2mortal(newSViv(0));
+	     lr = 1;
+	   }
+	   break;
+	 case int_amg:
+	 case iter_amg:			/* XXXX Eventually should do to_gv. */
+	 case ftest_amg:		/* XXXX Eventually should do to_gv. */
+	 case regexp_amg:
+	     /* FAIL safe */
+	     return NULL;	/* Delegate operation to standard mechanisms. */
+	 case to_sv_amg:
+	 case to_av_amg:
+	 case to_hv_amg:
+	 case to_gv_amg:
+	 case to_cv_amg:
+	     /* FAIL safe */
+	     return left;	/* Delegate operation to standard mechanisms. */
+	 default:
+	   goto not_found;
+	 }
+	 if (!cv) goto not_found;
+} else if (!(AMGf_noright & flags) && SvAMAGIC(right)
+	       && (stash = SvSTASH(SvRV(right))) && Gv_AMG(stash)
+	       && (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table))
+	       && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
+			  ? (amtp = (AMT*)mg->mg_ptr)->table
+			  : NULL))
+	       && (cv = cvp[off=method])) { /* Method for right
+					     * argument found */
+lr=1;
+} else if (((cvp && amtp->fallback > AMGfallNEVER)
+|| (ocvp && oamtp->fallback > AMGfallNEVER))
+	       && !(flags & AMGf_unary)) {
+				/* We look for substitution for
+				 * comparison operations and
+				 * concatenation */
+if (method==concat_amg || method==concat_ass_amg
+	  || method==repeat_amg || method==repeat_ass_amg) {
+	return NULL;		/* Delegate operation to string conversion */
+}
+off = -1;
+switch (method) {
+	 case lt_amg:
+	 case le_amg:
+	 case gt_amg:
+	 case ge_amg:
+	 case eq_amg:
+	 case ne_amg:
+off = ncmp_amg;
+break;
+	 case slt_amg:
+	 case sle_amg:
+	 case sgt_amg:
+	 case sge_amg:
+	 case seq_amg:
+	 case sne_amg:
+off = scmp_amg;
+break;
+	 }
+if (off != -1) {
+if (ocvp && (oamtp->fallback > AMGfallNEVER)) {
+cv = ocvp[off];
+lr = -1;
+}
+if (!cv && (cvp && amtp->fallback > AMGfallNEVER)) {
+cv = cvp[off];
+lr = 1;
+}
+}
+if (cv)
+postpr = 1;
+else
+goto not_found;
+} else {
+not_found:			/* No method found, either report or croak */
+switch (method) {
+	 case to_sv_amg:
+	 case to_av_amg:
+	 case to_hv_amg:
+	 case to_gv_amg:
+	 case to_cv_amg:
+	     /* FAIL safe */
+	     return left;	/* Delegate operation to standard mechanisms. */
+}
+if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */
+	notfound = 1; lr = -1;
+} else if (cvp && (cv=cvp[nomethod_amg])) {
+	notfound = 1; lr = 1;
+} else if ((use_default_op =
+(!ocvp || oamtp->fallback >= AMGfallYES)
+&& (!cvp || amtp->fallback >= AMGfallYES))
+&& !DEBUG_o_TEST) {
+	/* Skip generating the "no method found" message.  */
+	return NULL;
+} else {
+	SV *msg;
+	if (off==-1) off=method;
+	msg = sv_2mortal(Perl_newSVpvf(aTHX_
+		      "Operation \"%s\": no method found,%sargument %s%"SVf"%s%"SVf,
+		      AMG_id2name(method + assignshift),
+		      (flags & AMGf_unary ? " " : "\n\tleft "),
+		      SvAMAGIC(left)?
+		        "in overloaded package ":
+		        "has no overloaded magic",
+		      SvAMAGIC(left)?
+		        SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(SvSTASH(SvRV(left)))))):
+		        SVfARG(&PL_sv_no),
+		      SvAMAGIC(right)?
+		        ",\n\tright argument in overloaded package ":
+		        (flags & AMGf_unary
+			 ? ""
+			 : ",\n\tright argument has no overloaded magic"),
+		      SvAMAGIC(right)?
+		        SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(SvSTASH(SvRV(right)))))):
+		        SVfARG(&PL_sv_no)));
+if (use_default_op) {
+	  DEBUG_o( Perl_deb(aTHX_ "%"SVf, SVfARG(msg)) );
+	} else {
+	  Perl_croak(aTHX_ "%"SVf, SVfARG(msg));
+	}
+	return NULL;
+}
+force_cpy = force_cpy || assign;
+}
+}
+switch (method) {
+/* in these cases, we're calling '+' or '-' as a fallback for a ++ or --
+* operation. we need this to return a value, so that it can be assigned
+* later on, in the postpr block (case inc_amg/dec_amg), even if the
+* increment or decrement was itself called in void context */
+case inc_amg:
+if (off == add_amg)
+force_scalar = 1;
+break;
+case dec_amg:
+if (off == subtr_amg)
+force_scalar = 1;
+break;
+/* in these cases, we're calling an assignment variant of an operator
+* (+= rather than +, for instance). regardless of whether it's a
+* fallback or not, it always has to return a value, which will be
+* assigned to the proper variable later */
+case add_amg:
+case subtr_amg:
+case mult_amg:
+case div_amg:
+case modulo_amg:
+case pow_amg:
+case lshift_amg:
+case rshift_amg:
+case repeat_amg:
+case concat_amg:
+case band_amg:
+case bor_amg:
+case bxor_amg:
+case sband_amg:
+case sbor_amg:
+case sbxor_amg:
+if (assign)
+force_scalar = 1;
+break;
+/* the copy constructor always needs to return a value */
+case copy_amg:
+force_scalar = 1;
+break;
+/* because of the way these are implemented (they don't perform the
+* dereferencing themselves, they return a reference that perl then
+* dereferences later), they always have to be in scalar context */
+case to_sv_amg:
+case to_av_amg:
+case to_hv_amg:
+case to_gv_amg:
+case to_cv_amg:
+force_scalar = 1;
+break;
+/* these don't have an op of their own; they're triggered by their parent
+* op, so the context there isn't meaningful ('$a and foo()' in void
+* context still needs to pass scalar context on to $a's bool overload) */
+case bool__amg:
+case numer_amg:
+case string_amg:
+force_scalar = 1;
+break;
+}
+#ifdef DEBUGGING
+if (!notfound) {
+DEBUG_o(Perl_deb(aTHX_
+		     "Overloaded operator \"%s\"%s%s%s:\n\tmethod%s found%s in package %"SVf"%s\n",
+		     AMG_id2name(off),
+		     method+assignshift==off? "" :
+		     " (initially \"",
+		     method+assignshift==off? "" :
+		     AMG_id2name(method+assignshift),
+		     method+assignshift==off? "" : "\")",
+		     flags & AMGf_unary? "" :
+		     lr==1 ? " for right argument": " for left argument",
+		     flags & AMGf_unary? " for argument" : "",
+		     stash ? SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(stash)))) : SVfARG(newSVpvs_flags("null", SVs_TEMP)),
+		     fl? ",\n\tassignment variant used": "") );
+}
+#endif
+/* Since we use shallow copy during assignment, we need
+* to dublicate the contents, probably calling user-supplied
+* version of copy operator
+*/
+/* We need to copy in following cases:
+* a) Assignment form was called.
+* 		assignshift==1,  assign==T, method + 1 == off
+* b) Increment or decrement, called directly.
+* 		assignshift==0,  assign==0, method + 0 == off
+* c) Increment or decrement, translated to assignment add/subtr.
+* 		assignshift==0,  assign==T,
+*		force_cpy == T
+* d) Increment or decrement, translated to nomethod.
+* 		assignshift==0,  assign==0,
+*		force_cpy == T
+* e) Assignment form translated to nomethod.
+* 		assignshift==1,  assign==T, method + 1 != off
+*		force_cpy == T
+*/
+/*	off is method, method+assignshift, or a result of opcode substitution.
+*	In the latter case assignshift==0, so only notfound case is important.
+*/
+if ( (lr == -1) && ( ( (method + assignshift == off)
+	&& (assign || (method == inc_amg) || (method == dec_amg)))
+|| force_cpy) )
+{
+/* newSVsv does not behave as advertised, so we copy missing
+* information by hand */
+SV *tmpRef = SvRV(left);
+SV *rv_copy;
+if (SvREFCNT(tmpRef) > 1 && (rv_copy = AMG_CALLunary(left,copy_amg))) {
+	  SvRV_set(left, rv_copy);
+	  SvSETMAGIC(left);
+	  SvREFCNT_dec_NN(tmpRef);
+}
+}
+{
+dSP;
+BINOP myop;
+SV* res;
+const bool oldcatch = CATCH_GET;
+I32 oldmark, nret;
+int gimme = force_scalar ? G_SCALAR : GIMME_V;
+CATCH_SET(TRUE);
+Zero(&myop, 1, BINOP);
+myop.op_last = (OP *) &myop;
+myop.op_next = NULL;
+myop.op_flags = OPf_STACKED;
+switch (gimme) {
+case G_VOID:
+myop.op_flags |= OPf_WANT_VOID;
+break;
+case G_ARRAY:
+if (flags & AMGf_want_list) {
+myop.op_flags |= OPf_WANT_LIST;
+break;
+}
+/* FALLTHROUGH */
+default:
+myop.op_flags |= OPf_WANT_SCALAR;
+break;
+}
+PUSHSTACKi(PERLSI_OVERLOAD);
+ENTER;
+SAVEOP();
+PL_op = (OP *) &myop;
+if (PERLDB_SUB && PL_curstash != PL_debstash)
+	PL_op->op_private |= OPpENTERSUB_DB;
+Perl_pp_pushmark(aTHX);
+EXTEND(SP, notfound + 5);
+PUSHs(lr>0? right: left);
+PUSHs(lr>0? left: right);
+PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no ));
+if (notfound) {
+PUSHs(newSVpvn_flags(AMG_id2name(method + assignshift),
+			   AMG_id2namelen(method + assignshift), SVs_TEMP));
+}
+else if (flags & AMGf_numarg)
+PUSHs(&PL_sv_undef);
+if (flags & AMGf_numarg)
+PUSHs(&PL_sv_yes);
+PUSHs(MUTABLE_SV(cv));
+PUTBACK;
+oldmark = TOPMARK;
+if ((PL_op = PL_ppaddr[OP_ENTERSUB](aTHX)))
+CALLRUNOPS(aTHX);
+LEAVE;
+SPAGAIN;
+nret = SP - (PL_stack_base + oldmark);
+switch (gimme) {
+case G_VOID:
+/* returning NULL has another meaning, and we check the context
+* at the call site too, so this can be differentiated from the
+* scalar case */
+res = &PL_sv_undef;
+SP = PL_stack_base + oldmark;
+break;
+case G_ARRAY: {
+if (flags & AMGf_want_list) {
+res = sv_2mortal((SV *)newAV());
+av_extend((AV *)res, nret);
+while (nret--)
+av_store((AV *)res, nret, POPs);
+break;
+}
+/* FALLTHROUGH */
+}
+default:
+res = POPs;
+break;
+}
+PUTBACK;
+POPSTACK;
+CATCH_SET(oldcatch);
+if (postpr) {
+int ans;
+switch (method) {
+case le_amg:
+case sle_amg:
+	ans=SvIV(res)<=0; break;
+case lt_amg:
+case slt_amg:
+	ans=SvIV(res)<0; break;
+case ge_amg:
+case sge_amg:
+	ans=SvIV(res)>=0; break;
+case gt_amg:
+case sgt_amg:
+	ans=SvIV(res)>0; break;
+case eq_amg:
+case seq_amg:
+	ans=SvIV(res)==0; break;
+case ne_amg:
+case sne_amg:
+	ans=SvIV(res)!=0; break;
+case inc_amg:
+case dec_amg:
+	SvSetSV(left,res); return left;
+case not_amg:
+	ans=!SvTRUE(res); break;
+default:
+ans=0; break;
+}
+return boolSV(ans);
+} else if (method==copy_amg) {
+if (!SvROK(res)) {
+	Perl_croak(aTHX_ "Copy method did not return a reference");
+}
+return SvREFCNT_inc(SvRV(res));
+} else {
+return res;
+}
+}
+}
+void
+Perl_gv_name_set(pTHX_ GV *gv, const char *name, U32 len, U32 flags)
+{
+dVAR;
+U32 hash;
+PERL_ARGS_ASSERT_GV_NAME_SET;
+if (len > I32_MAX)
+	Perl_croak(aTHX_ "panic: gv name too long (%"UVuf")", (UV) len);
+if (!(flags & GV_ADD) && GvNAME_HEK(gv)) {
+	unshare_hek(GvNAME_HEK(gv));
+}
+PERL_HASH(hash, name, len);
+GvNAME_HEK(gv) = share_hek(name, (flags & SVf_UTF8 ? -(I32)len : (I32)len), hash);
+}
+/*
+=for apidoc gv_try_downgrade
+If the typeglob C<gv> can be expressed more succinctly, by having
+something other than a real GV in its place in the stash, replace it
+with the optimised form.  Basic requirements for this are that C<gv>
+is a real typeglob, is sufficiently ordinary, and is only referenced
+from its package.  This function is meant to be used when a GV has been
+looked up in part to see what was there, causing upgrading, but based
+on what was found it turns out that the real GV isn't required after all.
+If C<gv> is a completely empty typeglob, it is deleted from the stash.
+If C<gv> is a typeglob containing only a sufficiently-ordinary constant
+sub, the typeglob is replaced with a scalar-reference placeholder that
+more compactly represents the same thing.
+=cut
+*/
+void
+Perl_gv_try_downgrade(pTHX_ GV *gv)
+{
+HV *stash;
+CV *cv;
+HEK *namehek;
+SV **gvp;
+PERL_ARGS_ASSERT_GV_TRY_DOWNGRADE;
+/* XXX Why and where does this leave dangling pointers during global
+destruction? */
+if (PL_phase == PERL_PHASE_DESTRUCT) return;
+if (!(SvREFCNT(gv) == 1 && SvTYPE(gv) == SVt_PVGV && !SvFAKE(gv) &&
+	    !SvOBJECT(gv) && !SvREADONLY(gv) &&
+	    isGV_with_GP(gv) && GvGP(gv) &&
+	    !GvINTRO(gv) && GvREFCNT(gv) == 1 &&
+	    !GvSV(gv) && !GvAV(gv) && !GvHV(gv) && !GvIOp(gv) && !GvFORM(gv) &&
+	    GvEGVx(gv) == gv && (stash = GvSTASH(gv))))
+	return;
+if (gv == PL_statgv || gv == PL_last_in_gv || gv == PL_stderrgv)
+	return;
+if (SvMAGICAL(gv)) {
+MAGIC *mg;
+	/* only backref magic is allowed */
+	if (SvGMAGICAL(gv) || SvSMAGICAL(gv))
+	    return;
+for (mg = SvMAGIC(gv); mg; mg = mg->mg_moremagic) {
+if (mg->mg_type != PERL_MAGIC_backref)
+return;
+	}
+}
+cv = GvCV(gv);
+if (!cv) {
+	HEK *gvnhek = GvNAME_HEK(gv);
+	(void)hv_deletehek(stash, gvnhek, G_DISCARD);
+} else if (GvMULTI(gv) && cv && SvREFCNT(cv) == 1 &&
+	    !SvOBJECT(cv) && !SvMAGICAL(cv) && !SvREADONLY(cv) &&
+	    CvSTASH(cv) == stash && !CvNAMED(cv) && CvGV(cv) == gv &&
+	    CvCONST(cv) && !CvMETHOD(cv) && !CvLVALUE(cv) && !CvUNIQUE(cv) &&
+	    !CvNODEBUG(cv) && !CvCLONE(cv) && !CvCLONED(cv) && !CvANON(cv) &&
+	    (namehek = GvNAME_HEK(gv)) &&
+	    (gvp = hv_fetchhek(stash, namehek, 0)) &&
+	    *gvp == (SV*)gv) {
+	SV *value = SvREFCNT_inc(CvXSUBANY(cv).any_ptr);
+	const bool imported = !!GvIMPORTED_CV(gv);
+	SvREFCNT(gv) = 0;
+	sv_clear((SV*)gv);
+	SvREFCNT(gv) = 1;
+	SvFLAGS(gv) = SVt_IV|SVf_ROK|SVprv_PCS_IMPORTED * imported;
+/* See also: 'SET_SVANY_FOR_BODYLESS_IV' in sv.c */
+	SvANY(gv) = (XPVGV*)((char*)&(gv->sv_u.svu_iv) -
+				STRUCT_OFFSET(XPVIV, xiv_iv));
+	SvRV_set(gv, value);
+}
+}
+GV *
+Perl_gv_override(pTHX_ const char * const name, const STRLEN len)
+{
+GV *gv = gv_fetchpvn(name, len, GV_NOTQUAL, SVt_PVCV);
+GV * const *gvp;
+PERL_ARGS_ASSERT_GV_OVERRIDE;
+if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) return gv;
+gvp = (GV**)hv_fetch(PL_globalstash, name, len, FALSE);
+gv = gvp ? *gvp : NULL;
+if (gv && !isGV(gv)) {
+	if (!SvPCS_IMPORTED(gv)) return NULL;
+	gv_init(gv, PL_globalstash, name, len, 0);
+	return gv;
+}
+return gv && GvCVu(gv) && GvIMPORTED_CV(gv) ? gv : NULL;
+}
+#include "XSUB.h"
+static void
+core_xsub(pTHX_ CV* cv)
+{
+Perl_croak(aTHX_
+"&CORE::%s cannot be called directly", GvNAME(CvGV(cv))
+);
+}
+/*
+* ex: set ts=8 sts=4 sw=4 et:
+*/

Mercurial > repo

comparison perl-5.22.2/gv.c @ 8045:a16537d2fe07