HTTP/2 302 server: nginx date: Thu, 31 Jul 2025 07:51:42 GMT content-type: text/plain; charset=utf-8 content-length: 0 x-archive-redirect-reason: found capture at 20210123234101 location: https://web.archive.org/web/20210123234101/https://perl5.git.perl.org/perl5.git/blame/HEAD:/gv.c server-timing: captures_list;dur=0.502273, exclusion.robots;dur=0.017432, exclusion.robots.policy;dur=0.008421, esindex;dur=0.009870, cdx.remote;dur=7.444831, LoadShardBlock;dur=315.466957, PetaboxLoader3.datanode;dur=215.159617, PetaboxLoader3.resolve;dur=88.146247 x-app-server: wwwb-app218 x-ts: 302 x-tr: 350 server-timing: TR;dur=0,Tw;dur=0,Tc;dur=0 set-cookie: SERVER=wwwb-app218; path=/ x-location: All x-rl: 0 x-na: 0 x-page-cache: MISS server-timing: MISS x-nid: DigitalOcean referrer-policy: no-referrer-when-downgrade permissions-policy: interest-cohort=() HTTP/2 200 server: nginx date: Thu, 31 Jul 2025 07:51:44 GMT content-type: application/xhtml+xml; charset=utf-8 x-archive-orig-date: Sat, 23 Jan 2021 23:40:57 GMT x-archive-orig-server: Apache/2.4.6 (CentOS) OpenSSL/1.0.2k-fips x-archive-orig-keep-alive: timeout=5, max=100 x-archive-orig-connection: Keep-Alive x-archive-orig-x-crawler-transfer-encoding: chunked x-archive-orig-content-length: 1048576 x-archive-guessed-content-type: text/html x-archive-guessed-charset: iso-8859-1 memento-datetime: Sat, 23 Jan 2021 23:41:01 GMT link: ; rel="original", ; rel="timemap"; type="application/link-format", ; rel="timegate", ; rel="first memento"; datetime="Sat, 23 Jan 2021 23:41:01 GMT", ; rel="memento"; datetime="Sat, 23 Jan 2021 23:41:01 GMT", ; rel="last memento"; datetime="Sat, 23 Jan 2021 23:41:01 GMT" content-security-policy: default-src 'self' 'unsafe-eval' 'unsafe-inline' data: blob: archive.org web.archive.org web-static.archive.org wayback-api.archive.org athena.archive.org analytics.archive.org pragma.archivelab.org wwwb-events.archive.org x-archive-src: CC-MAIN-2021-04-1610703538741.56-0017/CC-MAIN-20210123222657-20210124012657-00340.warc.gz server-timing: captures_list;dur=0.485441, exclusion.robots;dur=0.018800, exclusion.robots.policy;dur=0.008829, esindex;dur=0.009188, cdx.remote;dur=22.237416, LoadShardBlock;dur=180.370828, PetaboxLoader3.datanode;dur=175.844910, PetaboxLoader3.resolve;dur=252.263386, load_resource;dur=280.819621 x-app-server: wwwb-app218 x-ts: 200 x-tr: 1698 server-timing: TR;dur=0,Tw;dur=0,Tc;dur=0 x-location: All x-rl: 0 x-na: 0 x-page-cache: MISS server-timing: MISS x-nid: DigitalOcean referrer-policy: no-referrer-when-downgrade permissions-policy: interest-cohort=() This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5

https://perl5.git.perl.org / perl5.git / blame

commit grep author committer pickaxe ^? search: re

summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD

Import perl5321delta.pod

[perl5.git] / gv.c

<td class=

• HOME
• ABOUT
• AUCTIONS
• SHIPPING
• FEES
• TOOLS
• HOW
• FAQ
• CONTACT

 

Original Source | Taken Source

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