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