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