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