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