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