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