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