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