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