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
Remove length magic on scalars
[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;
6361f656 1916 case '|': /* $| */
c69033f2 1917 sv_setiv(GvSVn(gv), (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0);
cc4c2da6
NC		 1918 goto magicalize;
1919
b3ca2e83
NC		 1920 case '\010': /* $^H */
1921 {
1922 HV *const hv = GvHVn(gv);
1923 hv_magic(hv, NULL, PERL_MAGIC_hints);
1924 }
1925 goto magicalize;
b82b06b8 1926 case '[': /* $[ */
7d69d4a6 1927 if ((sv_type == SVt_PV || sv_type == SVt_PVGV)
2846acbf 1928 && FEATURE_ARYBASE_IS_ENABLED) {
b82b06b8
FC		 1929 if (addmg) (void)hv_store(stash,name,len,(SV *)gv,0);
1930 require_tie_mod(gv,name,newSVpvs("arybase"),"FETCH",0);
1931 addmg = 0;
1932 }
7d69d4a6 1933 else goto magicalize;
b82b06b8 1934 break;
cc4c2da6 1935 case '\023': /* $^S */
2fdbfb4d
AB		 1936 ro_magicalize:
1937 SvREADONLY_on(GvSVn(gv));
1938 /* FALL THROUGH */
6361f656
AB		 1939 case '0': /* $0 */
1940 case '1': /* $1 */
1941 case '2': /* $2 */
1942 case '3': /* $3 */
1943 case '4': /* $4 */
1944 case '5': /* $5 */
1945 case '6': /* $6 */
1946 case '7': /* $7 */
1947 case '8': /* $8 */
1948 case '9': /* $9 */
6361f656
AB		 1949 case '^': /* $^ */
1950 case '~': /* $~ */
1951 case '=': /* $= */
1952 case '%': /* $% */
1953 case '.': /* $. */
1954 case '(': /* $( */
1955 case ')': /* $) */
1956 case '<': /* $< */
1957 case '>': /* $> */
1958 case '\\': /* $\ */
1959 case '/': /* $/ */
9cdac2a2 1960 case '$': /* $$ */
cc4c2da6
NC		 1961 case '\001': /* $^A */
1962 case '\003': /* $^C */
1963 case '\004': /* $^D */
1964 case '\005': /* $^E */
1965 case '\006': /* $^F */
cc4c2da6
NC		 1966 case '\011': /* $^I, NOT \t in EBCDIC */
1967 case '\016': /* $^N */
1968 case '\017': /* $^O */
1969 case '\020': /* $^P */
1970 case '\024': /* $^T */
1971 case '\027': /* $^W */
1972 magicalize:
ad64d0ec 1973 sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
cc4c2da6 1974 break;
e521374c 1975
cc4c2da6 1976 case '\014': /* $^L */
76f68e9b 1977 sv_setpvs(GvSVn(gv),"\f");
463ee0b2 1978 break;
6361f656 1979 case ';': /* $; */
76f68e9b 1980 sv_setpvs(GvSVn(gv),"\034");
463ee0b2 1981 break;
6361f656 1982 case ']': /* $] */
cc4c2da6 1983 {
3638bf15 1984 SV * const sv = GvSV(gv);
d7aa5382 1985 if (!sv_derived_from(PL_patchlevel, "version"))
ac0e6a2f 1986 upg_version(PL_patchlevel, TRUE);
7d54d38e
SH		 1987 GvSV(gv) = vnumify(PL_patchlevel);
1988 SvREADONLY_on(GvSV(gv));
1989 SvREFCNT_dec(sv);
93a17b20
LW		 1990 }
1991 break;
cc4c2da6
NC		 1992 case '\026': /* $^V */
1993 {
3638bf15 1994 SV * const sv = GvSV(gv);
f9be5ac8
DM		 1995 GvSV(gv) = new_version(PL_patchlevel);
1996 SvREADONLY_on(GvSV(gv));
1997 SvREFCNT_dec(sv);
16070b82
GS		 1998 }
1999 break;
cc4c2da6 2000 }
79072805 2001 }
23496c6e
FC		 2002 add_magical_gv:
2003 if (addmg) {
2004 if (GvAV(gv) || GvHV(gv) || GvIO(gv) || GvCV(gv) || (
2005 GvSV(gv) && (SvOK(GvSV(gv)) || SvMAGICAL(GvSV(gv)))
2006 ))
0f43181e 2007 (void)hv_store(stash,name,len,(SV *)gv,0);
23496c6e
FC		 2008 else SvREFCNT_dec(gv), gv = NULL;
2009 }
e6066781 2010 if (gv) gv_init_svtype(gv, faking_it ? SVt_PVCV : sv_type);
93a17b20 2011 return gv;
79072805
LW		 2012}
2013
2014void
35a4481c 2015Perl_gv_fullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
43693395 2016{
ed60a868 2017 const char *name;
35a4481c 2018 const HV * const hv = GvSTASH(gv);
7918f24d
NC		 2019
2020 PERL_ARGS_ASSERT_GV_FULLNAME4;
2021
666ea192 2022 sv_setpv(sv, prefix ? prefix : "");
a0288114 2023
52a6327b 2024 if (hv && (name = HvNAME(hv))) {
ed60a868
FC		 2025 const STRLEN len = HvNAMELEN(hv);
2026 if (keepmain || strnNE(name, "main", len)) {
2027 sv_catpvn_flags(sv,name,len,HvNAMEUTF8(hv)?SV_CATUTF8:SV_CATBYTES);
396482e1 2028 sv_catpvs(sv,"::");
ed60a868 2029 }
43693395 2030 }
ed60a868 2031 else sv_catpvs(sv,"__ANON__::");
04f3bf56 2032 sv_catsv(sv,sv_2mortal(newSVhek(GvNAME_HEK(gv))));
43693395
GS		 2033}
2034
2035void
35a4481c 2036Perl_gv_efullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
43693395 2037{
099be4f1 2038 const GV * const egv = GvEGVx(gv);
7918f24d
NC		 2039
2040 PERL_ARGS_ASSERT_GV_EFULLNAME4;
2041
46c461b5 2042 gv_fullname4(sv, egv ? egv : gv, prefix, keepmain);
43693395
GS		 2043}
2044
79072805 2045void
1146e912 2046Perl_gv_check(pTHX_ const HV *stash)
79072805 2047{
97aff369 2048 dVAR;
eb578fdb 2049 I32 i;
463ee0b2 2050
7918f24d
NC		 2051 PERL_ARGS_ASSERT_GV_CHECK;
2052
8990e307
LW		 2053 if (!HvARRAY(stash))
2054 return;
a0d0e21e 2055 for (i = 0; i <= (I32) HvMAX(stash); i++) {
e1ec3a88 2056 const HE *entry;
dc437b57 2057 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
eb578fdb 2058 GV *gv;
b7787f18 2059 HV *hv;
dc437b57 2060 if (HeKEY(entry)[HeKLEN(entry)-1] == ':' &&
159b6efe 2061 (gv = MUTABLE_GV(HeVAL(entry))) && isGV(gv) && (hv = GvHV(gv)))
a0d0e21e 2062 {
19b6c847 2063 if (hv != PL_defstash && hv != stash)
a0d0e21e
LW		 2064 gv_check(hv); /* nested package */
2065 }
ecad31f0
BF		 2066 else if ( *HeKEY(entry) != '_'
2067 && isIDFIRST_lazy_if(HeKEY(entry), HeUTF8(entry)) ) {
e1ec3a88 2068 const char *file;
159b6efe 2069 gv = MUTABLE_GV(HeVAL(entry));
55d729e4 2070 if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv))
463ee0b2 2071 continue;
1d7c1841 2072 file = GvFILE(gv);
1d7c1841
GS		 2073 CopLINE_set(PL_curcop, GvLINE(gv));
2074#ifdef USE_ITHREADS
dd374669 2075 CopFILE(PL_curcop) = (char *)file; /* set for warning */
1d7c1841 2076#else
9bde8eb0
NC		 2077 CopFILEGV(PL_curcop)
2078 = gv_fetchfile_flags(file, HEK_LEN(GvFILE_HEK(gv)), 0);
1d7c1841 2079#endif
9014280d 2080 Perl_warner(aTHX_ packWARN(WARN_ONCE),
d0c0e7dd
FC		 2081 "Name \"%"HEKf"::%"HEKf
2082 "\" used only once: possible typo",
2083 HEKfARG(HvNAME_HEK(stash)),
2084 HEKfARG(GvNAME_HEK(gv)));
463ee0b2 2085 }
79072805
LW		 2086 }
2087 }
2088}
2089
2090GV *
9cc50d5b 2091Perl_newGVgen_flags(pTHX_ const char *pack, U32 flags)
79072805 2092{
97aff369 2093 dVAR;
9cc50d5b 2094 PERL_ARGS_ASSERT_NEWGVGEN_FLAGS;
7918f24d 2095
9cc50d5b
BF		 2096 return gv_fetchpv(Perl_form(aTHX_ "%"SVf"::_GEN_%ld",
2097 SVfARG(newSVpvn_flags(pack, strlen(pack),
2098 SVs_TEMP | flags)),
2099 (long)PL_gensym++),
2100 GV_ADD, SVt_PVGV);
79072805
LW		 2101}
2102
2103/* hopefully this is only called on local symbol table entries */
2104
2105GP*
864dbfa3 2106Perl_gp_ref(pTHX_ GP *gp)
79072805 2107{
97aff369 2108 dVAR;
1d7c1841 2109 if (!gp)
d4c19fe8 2110 return NULL;
79072805 2111 gp->gp_refcnt++;
44a8e56a 2112 if (gp->gp_cv) {
2113 if (gp->gp_cvgen) {
e1a479c5
BB		 2114 /* If the GP they asked for a reference to contains
2115 a method cache entry, clear it first, so that we
2116 don't infect them with our cached entry */
44a8e56a 2117 SvREFCNT_dec(gp->gp_cv);
601f1833 2118 gp->gp_cv = NULL;
44a8e56a 2119 gp->gp_cvgen = 0;
2120 }
44a8e56a 2121 }
79072805 2122 return gp;
79072805
LW		 2123}
2124
2125void
864dbfa3 2126Perl_gp_free(pTHX_ GV *gv)
79072805 2127{
97aff369 2128 dVAR;
79072805 2129 GP* gp;
b0d55c99 2130 int attempts = 100;
79072805 2131
f7877b28 2132 if (!gv || !isGV_with_GP(gv) || !(gp = GvGP(gv)))
79072805 2133 return;
f248d071 2134 if (gp->gp_refcnt == 0) {
9b387841
NC		 2135 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
2136 "Attempt to free unreferenced glob pointers"
2137 pTHX__FORMAT pTHX__VALUE);
79072805
LW		 2138 return;
2139 }
748a9306
LW		 2140 if (--gp->gp_refcnt > 0) {
2141 if (gp->gp_egv == gv)
2142 gp->gp_egv = 0;
c43ae56f 2143 GvGP_set(gv, NULL);
79072805 2144 return;
748a9306 2145 }
79072805 2146
b0d55c99
FC		 2147 while (1) {
2148 /* Copy and null out all the glob slots, so destructors do not see
2149 freed SVs. */
2150 HEK * const file_hek = gp->gp_file_hek;
2151 SV * const sv = gp->gp_sv;
2152 AV * const av = gp->gp_av;
2153 HV * const hv = gp->gp_hv;
2154 IO * const io = gp->gp_io;
2155 CV * const cv = gp->gp_cv;
2156 CV * const form = gp->gp_form;
2157
2158 gp->gp_file_hek = NULL;
2159 gp->gp_sv = NULL;
2160 gp->gp_av = NULL;
2161 gp->gp_hv = NULL;
2162 gp->gp_io = NULL;
2163 gp->gp_cv = NULL;
2164 gp->gp_form = NULL;
2165
2166 if (file_hek)
2167 unshare_hek(file_hek);
2168
2169 SvREFCNT_dec(sv);
2170 SvREFCNT_dec(av);
2171 /* FIXME - another reference loop GV -> symtab -> GV ?
2172 Somehow gp->gp_hv can end up pointing at freed garbage. */
2173 if (hv && SvTYPE(hv) == SVt_PVHV) {
c2242065 2174 const HEK *hvname_hek = HvNAME_HEK(hv);
103f5a36 2175 DEBUG_o(Perl_deb(aTHX_ "gp_free clearing PL_stashcache for '%"HEKf"'\n", hvname_hek));
c2242065
BF		 2176 if (PL_stashcache && hvname_hek)
2177 (void)hv_delete(PL_stashcache, HEK_KEY(hvname_hek),
2178 (HEK_UTF8(hvname_hek) ? -HEK_LEN(hvname_hek) : HEK_LEN(hvname_hek)),
2179 G_DISCARD);
b0d55c99
FC		 2180 SvREFCNT_dec(hv);
2181 }
2182 SvREFCNT_dec(io);
2183 SvREFCNT_dec(cv);
2184 SvREFCNT_dec(form);
2185
2186 if (!gp->gp_file_hek
2187 && !gp->gp_sv
2188 && !gp->gp_av
2189 && !gp->gp_hv
2190 && !gp->gp_io
2191 && !gp->gp_cv
2192 && !gp->gp_form) break;
2193
2194 if (--attempts == 0) {
2195 Perl_die(aTHX_
2196 "panic: gp_free failed to free glob pointer - "
2197 "something is repeatedly re-creating entries"
2198 );
2199 }
13207a71 2200 }
748a9306 2201
79072805 2202 Safefree(gp);
c43ae56f 2203 GvGP_set(gv, NULL);
79072805
LW		 2204}
2205
d460ef45
NIS		 2206int
2207Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg)
2208{
53c1dcc0
AL		 2209 AMT * const amtp = (AMT*)mg->mg_ptr;
2210 PERL_UNUSED_ARG(sv);
dd374669 2211
7918f24d
NC		 2212 PERL_ARGS_ASSERT_MAGIC_FREEOVRLD;
2213
d460ef45
NIS		 2214 if (amtp && AMT_AMAGIC(amtp)) {
2215 int i;
2216 for (i = 1; i < NofAMmeth; i++) {
53c1dcc0 2217 CV * const cv = amtp->table[i];
b37c2d43 2218 if (cv) {
ad64d0ec 2219 SvREFCNT_dec(MUTABLE_SV(cv));
601f1833 2220 amtp->table[i] = NULL;
d460ef45
NIS		 2221 }
2222 }
2223 }
2224 return 0;
2225}
2226
a0d0e21e 2227/* Updates and caches the CV's */
c3a9a790
RGS		 2228/* Returns:
2229 * 1 on success and there is some overload
2230 * 0 if there is no overload
2231 * -1 if some error occurred and it couldn't croak
2232 */
a0d0e21e 2233
c3a9a790 2234int
242f8760 2235Perl_Gv_AMupdate(pTHX_ HV *stash, bool destructing)
a0d0e21e 2236{
97aff369 2237 dVAR;
ad64d0ec 2238 MAGIC* const mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
a6006777 2239 AMT amt;
9b439311 2240 const struct mro_meta* stash_meta = HvMROMETA(stash);
e1a479c5 2241 U32 newgen;
a0d0e21e 2242
7918f24d
NC		 2243 PERL_ARGS_ASSERT_GV_AMUPDATE;
2244
9b439311 2245 newgen = PL_sub_generation + stash_meta->pkg_gen + stash_meta->cache_gen;
14899595
NC		 2246 if (mg) {
2247 const AMT * const amtp = (AMT*)mg->mg_ptr;
66978156 2248 if (amtp->was_ok_sub == newgen) {
c3a9a790 2249 return AMT_OVERLOADED(amtp) ? 1 : 0;
14899595 2250 }
ad64d0ec 2251 sv_unmagic(MUTABLE_SV(stash), PERL_MAGIC_overload_table);
14899595 2252 }
a0d0e21e 2253
bfcb3514 2254 DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME_get(stash)) );
a0d0e21e 2255
d460ef45 2256 Zero(&amt,1,AMT);
e1a479c5 2257 amt.was_ok_sub = newgen;
a6006777 2258 amt.fallback = AMGfallNO;
2259 amt.flags = 0;
2260
a6006777 2261 {
32251b26
IZ		 2262 int filled = 0, have_ovl = 0;
2263 int i, lim = 1;
a6006777 2264
3866ea3b 2265 /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
a6006777 2266
89ffc314 2267 /* Try to find via inheritance. */
e6919483 2268 GV *gv = gv_fetchmeth_pvn(stash, PL_AMG_names[0], 2, -1, 0);
3866ea3b 2269 SV * const sv = gv ? GvSV(gv) : NULL;
53c1dcc0 2270 CV* cv;
89ffc314
IZ		 2271
2272 if (!gv)
3866ea3b
FC		 2273 {
2274 if (!gv_fetchmeth_pvn(stash, "((", 2, -1, 0))
32251b26 2275 lim = DESTROY_amg; /* Skip overloading entries. */
3866ea3b
FC		 2276 }
2277#ifdef PERL_DONT_CREATE_GVSV
2278 else if (!sv) {
6f207bd3 2279 NOOP; /* Equivalent to !SvTRUE and !SvOK */
3866ea3b
FC		 2280 }
2281#endif
79c9643d
JL		 2282 else if (SvTRUE(sv))
2283 /* don't need to set overloading here because fallback => 1
2284 * is the default setting for classes without overloading */
89ffc314 2285 amt.fallback=AMGfallYES;
79c9643d
JL		 2286 else if (SvOK(sv)) {
2287 amt.fallback=AMGfallNEVER;
386a5489
JL		 2288 filled = 1;
2289 have_ovl = 1;
2290 }
79c9643d 2291 else {
386a5489
JL		 2292 filled = 1;
2293 have_ovl = 1;
2294 }
a6006777 2295
32251b26 2296 for (i = 1; i < lim; i++)
601f1833 2297 amt.table[i] = NULL;
32251b26 2298 for (; i < NofAMmeth; i++) {
6136c704 2299 const char * const cooky = PL_AMG_names[i];
32251b26 2300 /* Human-readable form, for debugging: */
6136c704 2301 const char * const cp = (i >= DESTROY_amg ? cooky : AMG_id2name(i));
d279ab82 2302 const STRLEN l = PL_AMG_namelens[i];
89ffc314 2303
a0288114 2304 DEBUG_o( Perl_deb(aTHX_ "Checking overloading of \"%s\" in package \"%.256s\"\n",
bfcb3514 2305 cp, HvNAME_get(stash)) );
611c1e95
IZ		 2306 /* don't fill the cache while looking up!
2307 Creation of inheritance stubs in intermediate packages may
2308 conflict with the logic of runtime method substitution.
2309 Indeed, for inheritance A -> B -> C, if C overloads "+0",
2310 then we could have created stubs for "(+0" in A and C too.
2311 But if B overloads "bool", we may want to use it for
2312 numifying instead of C's "+0". */
2313 if (i >= DESTROY_amg)
d21989ed 2314 gv = Perl_gv_fetchmeth_pvn_autoload(aTHX_ stash, cooky, l, 0, 0);
611c1e95 2315 else /* Autoload taken care of below */
e6919483 2316 gv = Perl_gv_fetchmeth_pvn(aTHX_ stash, cooky, l, -1, 0);
46fc3d4c 2317 cv = 0;
89ffc314 2318 if (gv && (cv = GvCV(gv))) {
f0e9f182
FC		 2319 if(GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")){
2320 const char * const hvname = HvNAME_get(GvSTASH(CvGV(cv)));
2321 if (hvname && HEK_LEN(HvNAME_HEK(GvSTASH(CvGV(cv)))) == 8
2322 && strEQ(hvname, "overload")) {
611c1e95
IZ		 2323 /* This is a hack to support autoloading..., while
2324 knowing *which* methods were declared as overloaded. */
44a8e56a 2325 /* GvSV contains the name of the method. */
6136c704 2326 GV *ngv = NULL;
c69033f2 2327 SV *gvsv = GvSV(gv);
a0288114
AL		 2328
2329 DEBUG_o( Perl_deb(aTHX_ "Resolving method \"%"SVf256\
2330 "\" for overloaded \"%s\" in package \"%.256s\"\n",
f0e9f182 2331 (void*)GvSV(gv), cp, HvNAME(stash)) );
c69033f2 2332 if (!gvsv || !SvPOK(gvsv)
7f415459 2333 || !(ngv = gv_fetchmethod_sv_flags(stash, gvsv, 0)))
dc848c6f 2334 {
a0288114 2335 /* Can be an import stub (created by "can"). */
242f8760 2336 if (destructing) {
c3a9a790 2337 return -1;
242f8760
RGS		 2338 }
2339 else {
d66cca07
BF		 2340 const SV * const name = (gvsv && SvPOK(gvsv))
2341 ? gvsv
2342 : newSVpvs_flags("???", SVs_TEMP);
dcbac5bb 2343 /* diag_listed_as: Can't resolve method "%s" overloading "%s" in package "%s" */
d66cca07
BF		 2344 Perl_croak(aTHX_ "%s method \"%"SVf256
2345 "\" overloading \"%s\" "\
d0c0e7dd 2346 "in package \"%"HEKf256"\"",
242f8760
RGS		 2347 (GvCVGEN(gv) ? "Stub found while resolving"
2348 : "Can't resolve"),
d66cca07 2349 SVfARG(name), cp,
d0c0e7dd 2350 HEKfARG(
d66cca07 2351 HvNAME_HEK(stash)
d0c0e7dd 2352 ));
242f8760 2353 }
44a8e56a 2354 }
dc848c6f 2355 cv = GvCV(gv = ngv);
f0e9f182 2356 }
44a8e56a 2357 }
b464bac0 2358 DEBUG_o( Perl_deb(aTHX_ "Overloading \"%s\" in package \"%.256s\" via \"%.256s::%.256s\"\n",
bfcb3514 2359 cp, HvNAME_get(stash), HvNAME_get(GvSTASH(CvGV(cv))),
44a8e56a 2360 GvNAME(CvGV(cv))) );
2361 filled = 1;
32251b26
IZ		 2362 if (i < DESTROY_amg)
2363 have_ovl = 1;
611c1e95 2364 } else if (gv) { /* Autoloaded... */
ea726b52 2365 cv = MUTABLE_CV(gv);
611c1e95 2366 filled = 1;
44a8e56a 2367 }
ea726b52 2368 amt.table[i]=MUTABLE_CV(SvREFCNT_inc_simple(cv));
a0d0e21e 2369 }
a0d0e21e 2370 if (filled) {
a6006777 2371 AMT_AMAGIC_on(&amt);
32251b26
IZ		 2372 if (have_ovl)
2373 AMT_OVERLOADED_on(&amt);
ad64d0ec 2374 sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table,
14befaf4 2375 (char*)&amt, sizeof(AMT));
32251b26 2376 return have_ovl;
a0d0e21e
LW		 2377 }
2378 }
a6006777 2379 /* Here we have no table: */
9cbac4c7 2380 /* no_table: */
a6006777 2381 AMT_AMAGIC_off(&amt);
ad64d0ec 2382 sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table,
14befaf4 2383 (char*)&amt, sizeof(AMTS));
c3a9a790 2384 return 0;
a0d0e21e
LW		 2385}
2386
32251b26
IZ		 2387
2388CV*
2389Perl_gv_handler(pTHX_ HV *stash, I32 id)
2390{
97aff369 2391 dVAR;
3f8f4626 2392 MAGIC *mg;
32251b26 2393 AMT *amtp;
e1a479c5 2394 U32 newgen;
9b439311 2395 struct mro_meta* stash_meta;
32251b26 2396
bfcb3514 2397 if (!stash || !HvNAME_get(stash))
601f1833 2398 return NULL;
e1a479c5 2399
9b439311
BB		 2400 stash_meta = HvMROMETA(stash);
2401 newgen = PL_sub_generation + stash_meta->pkg_gen + stash_meta->cache_gen;
e1a479c5 2402
ad64d0ec 2403 mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
32251b26
IZ		 2404 if (!mg) {
2405 do_update:
242f8760
RGS		 2406 /* If we're looking up a destructor to invoke, we must avoid
2407 * that Gv_AMupdate croaks, because we might be dying already */
2dcac756 2408 if (Gv_AMupdate(stash, cBOOL(id == DESTROY_amg)) == -1) {
242f8760
RGS		 2409 /* and if it didn't found a destructor, we fall back
2410 * to a simpler method that will only look for the
2411 * destructor instead of the whole magic */
2412 if (id == DESTROY_amg) {
2413 GV * const gv = gv_fetchmethod(stash, "DESTROY");
2414 if (gv)
2415 return GvCV(gv);
2416 }
2417 return NULL;
2418 }
ad64d0ec 2419 mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
32251b26 2420 }
a9fd4e40 2421 assert(mg);
32251b26 2422 amtp = (AMT*)mg->mg_ptr;
66978156 2423 if ( amtp->was_ok_sub != newgen )
32251b26 2424 goto do_update;
3ad83ce7 2425 if (AMT_AMAGIC(amtp)) {
b7787f18 2426 CV * const ret = amtp->table[id];
3ad83ce7
AMS		 2427 if (ret && isGV(ret)) { /* Autoloading stab */
2428 /* Passing it through may have resulted in a warning
2429 "Inherited AUTOLOAD for a non-method deprecated", since
2430 our caller is going through a function call, not a method call.
2431 So return the CV for AUTOLOAD, setting $AUTOLOAD. */
890ce7af 2432 GV * const gv = gv_fetchmethod(stash, PL_AMG_names[id]);
3ad83ce7
AMS		 2433
2434 if (gv && GvCV(gv))
2435 return GvCV(gv);
2436 }
2437 return ret;
2438 }
a0288114 2439
601f1833 2440 return NULL;
32251b26
IZ		 2441}
2442
2443
6f1401dc
DM		 2444/* Implement tryAMAGICun_MG macro.
2445 Do get magic, then see if the stack arg is overloaded and if so call it.
2446 Flags:
2447 AMGf_set return the arg using SETs rather than assigning to
2448 the targ
2449 AMGf_numeric apply sv_2num to the stack arg.
2450*/
2451
2452bool
2453Perl_try_amagic_un(pTHX_ int method, int flags) {
2454 dVAR;
2455 dSP;
2456 SV* tmpsv;
2457 SV* const arg = TOPs;
2458
2459 SvGETMAGIC(arg);
2460
9f8bf298
NC		 2461 if (SvAMAGIC(arg) && (tmpsv = amagic_call(arg, &PL_sv_undef, method,
2462 AMGf_noright | AMGf_unary))) {
6f1401dc
DM		 2463 if (flags & AMGf_set) {
2464 SETs(tmpsv);
2465 }
2466 else {
2467 dTARGET;
2468 if (SvPADMY(TARG)) {
2469 sv_setsv(TARG, tmpsv);
2470 SETTARG;
2471 }
2472 else
2473 SETs(tmpsv);
2474 }
2475 PUTBACK;
2476 return TRUE;
2477 }
2478
2479 if ((flags & AMGf_numeric) && SvROK(arg))
2480 *sp = sv_2num(arg);
2481 return FALSE;
2482}
2483
2484
2485/* Implement tryAMAGICbin_MG macro.
2486 Do get magic, then see if the two stack args are overloaded and if so
2487 call it.
2488 Flags:
2489 AMGf_set return the arg using SETs rather than assigning to
2490 the targ
2491 AMGf_assign op may be called as mutator (eg +=)
2492 AMGf_numeric apply sv_2num to the stack arg.
2493*/
2494
2495bool
2496Perl_try_amagic_bin(pTHX_ int method, int flags) {
2497 dVAR;
2498 dSP;
2499 SV* const left = TOPm1s;
2500 SV* const right = TOPs;
2501
2502 SvGETMAGIC(left);
2503 if (left != right)
2504 SvGETMAGIC(right);
2505
2506 if (SvAMAGIC(left) || SvAMAGIC(right)) {
2507 SV * const tmpsv = amagic_call(left, right, method,
2508 ((flags & AMGf_assign) && opASSIGN ? AMGf_assign: 0));
2509 if (tmpsv) {
2510 if (flags & AMGf_set) {
2511 (void)POPs;
2512 SETs(tmpsv);
2513 }
2514 else {
2515 dATARGET;
2516 (void)POPs;
2517 if (opASSIGN || SvPADMY(TARG)) {
2518 sv_setsv(TARG, tmpsv);
2519 SETTARG;
2520 }
2521 else
2522 SETs(tmpsv);
2523 }
2524 PUTBACK;
2525 return TRUE;
2526 }
2527 }
75ea7a12
FC		 2528 if(left==right && SvGMAGICAL(left)) {
2529 SV * const left = sv_newmortal();
2530 *(sp-1) = left;
2531 /* Print the uninitialized warning now, so it includes the vari-
2532 able name. */
2533 if (!SvOK(right)) {
2534 if (ckWARN(WARN_UNINITIALIZED)) report_uninit(right);
2535 sv_setsv_flags(left, &PL_sv_no, 0);
2536 }
2537 else sv_setsv_flags(left, right, 0);
2538 SvGETMAGIC(right);
2539 }
6f1401dc 2540 if (flags & AMGf_numeric) {
75ea7a12
FC		 2541 if (SvROK(TOPm1s))
2542 *(sp-1) = sv_2num(TOPm1s);
6f1401dc
DM		 2543 if (SvROK(right))
2544 *sp = sv_2num(right);
2545 }
2546 return FALSE;
2547}
2548
25a9ffce
NC		 2549SV *
2550Perl_amagic_deref_call(pTHX_ SV *ref, int method) {
2551 SV *tmpsv = NULL;
2552
2553 PERL_ARGS_ASSERT_AMAGIC_DEREF_CALL;
2554
2555 while (SvAMAGIC(ref) &&
2556 (tmpsv = amagic_call(ref, &PL_sv_undef, method,
2557 AMGf_noright | AMGf_unary))) {
2558 if (!SvROK(tmpsv))
2559 Perl_croak(aTHX_ "Overloaded dereference did not return a reference");
2560 if (tmpsv == ref || SvRV(tmpsv) == SvRV(ref)) {
2561 /* Bail out if it returns us the same reference. */
2562 return tmpsv;
2563 }
2564 ref = tmpsv;
2565 }
2566 return tmpsv ? tmpsv : ref;
2567}
6f1401dc 2568
8d569291
FC		 2569bool
2570Perl_amagic_is_enabled(pTHX_ int method)
2571{
2572 SV *lex_mask = cop_hints_fetch_pvs(PL_curcop, "overloading", 0);
2573
2574 assert(PL_curcop->cop_hints & HINT_NO_AMAGIC);
2575
2576 if ( !lex_mask || !SvOK(lex_mask) )
2577 /* overloading lexically disabled */
2578 return FALSE;
2579 else if ( lex_mask && SvPOK(lex_mask) ) {
2580 /* we have an entry in the hints hash, check if method has been
2581 * masked by overloading.pm */
2582 STRLEN len;
2583 const int offset = method / 8;
2584 const int bit = method % 8;
2585 char *pv = SvPV(lex_mask, len);
2586
2587 /* Bit set, so this overloading operator is disabled */
2588 if ( (STRLEN)offset < len && pv[offset] & ( 1 << bit ) )
2589 return FALSE;
2590 }
2591 return TRUE;
2592}
2593
a0d0e21e 2594SV*
864dbfa3 2595Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
a0d0e21e 2596{
27da23d5 2597 dVAR;
b267980d 2598 MAGIC *mg;
9c5ffd7c 2599 CV *cv=NULL;
a0d0e21e 2600 CV **cvp=NULL, **ocvp=NULL;
9c5ffd7c 2601 AMT *amtp=NULL, *oamtp=NULL;
b464bac0
AL		 2602 int off = 0, off1, lr = 0, notfound = 0;
2603 int postpr = 0, force_cpy = 0;
2604 int assign = AMGf_assign & flags;
2605 const int assignshift = assign ? 1 : 0;
bf5522a1 2606 int use_default_op = 0;
67288365 2607 int force_scalar = 0;
497b47a8
JH		 2608#ifdef DEBUGGING
2609 int fl=0;
497b47a8 2610#endif
25716404 2611 HV* stash=NULL;
7918f24d
NC		 2612
2613 PERL_ARGS_ASSERT_AMAGIC_CALL;
2614
e46c382e 2615 if ( PL_curcop->cop_hints & HINT_NO_AMAGIC ) {
8d569291 2616 if (!amagic_is_enabled(method)) return NULL;
e46c382e
YK		 2617 }
2618
a0d0e21e 2619 if (!(AMGf_noleft & flags) && SvAMAGIC(left)
0a2c84ab 2620 && (stash = SvSTASH(SvRV(left))) && Gv_AMG(stash)
ad64d0ec 2621 && (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table))
b267980d 2622 && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
a6006777 2623 ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
d4c19fe8 2624 : NULL))
b267980d 2625 && ((cv = cvp[off=method+assignshift])
748a9306
LW		 2626 || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
2627 * usual method */
497b47a8
JH		 2628 (
2629#ifdef DEBUGGING
2630 fl = 1,
a0288114 2631#endif
497b47a8 2632 cv = cvp[off=method])))) {
a0d0e21e
LW		 2633 lr = -1; /* Call method for left argument */
2634 } else {
2635 if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) {
2636 int logic;
2637
2638 /* look for substituted methods */
ee239bfe 2639 /* In all the covered cases we should be called with assign==0. */
a0d0e21e
LW		 2640 switch (method) {
2641 case inc_amg:
ee239bfe
IZ		 2642 force_cpy = 1;
2643 if ((cv = cvp[off=add_ass_amg])
2644 || ((cv = cvp[off = add_amg]) && (force_cpy = 0, postpr = 1))) {
3280af22 2645 right = &PL_sv_yes; lr = -1; assign = 1;
a0d0e21e
LW		 2646 }
2647 break;
2648 case dec_amg:
ee239bfe
IZ		 2649 force_cpy = 1;
2650 if ((cv = cvp[off = subtr_ass_amg])
2651 || ((cv = cvp[off = subtr_amg]) && (force_cpy = 0, postpr=1))) {
3280af22 2652 right = &PL_sv_yes; lr = -1; assign = 1;
a0d0e21e
LW		 2653 }
2654 break;
2655 case bool__amg:
2656 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg]));
2657 break;
2658 case numer_amg:
2659 (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg]));
2660 break;
2661 case string_amg:
2662 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg]));
2663 break;
b7787f18
AL		 2664 case not_amg:
2665 (void)((cv = cvp[off=bool__amg])
2666 || (cv = cvp[off=numer_amg])
2667 || (cv = cvp[off=string_amg]));
2ab54efd
MB		 2668 if (cv)
2669 postpr = 1;
b7787f18 2670 break;
748a9306
LW		 2671 case copy_amg:
2672 {
76e3520e
GS		 2673 /*
2674 * SV* ref causes confusion with the interpreter variable of
2675 * the same name
2676 */
890ce7af 2677 SV* const tmpRef=SvRV(left);
76e3520e 2678 if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) {
fc36a67e 2679 /*
2680 * Just to be extra cautious. Maybe in some
2681 * additional cases sv_setsv is safe, too.
2682 */
890ce7af 2683 SV* const newref = newSVsv(tmpRef);
748a9306 2684 SvOBJECT_on(newref);
a1cd65be
FC		 2685 /* No need to do SvAMAGIC_on here, as SvAMAGIC macros
2686 delegate to the stash. */
85fbaab2 2687 SvSTASH_set(newref, MUTABLE_HV(SvREFCNT_inc(SvSTASH(tmpRef))));
748a9306
LW		 2688 return newref;
2689 }
2690 }
2691 break;
a0d0e21e 2692 case abs_amg:
b267980d 2693 if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg])
a0d0e21e 2694 && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) {
890ce7af 2695 SV* const nullsv=sv_2mortal(newSViv(0));
a0d0e21e 2696 if (off1==lt_amg) {
890ce7af 2697 SV* const lessp = amagic_call(left,nullsv,
a0d0e21e
LW		 2698 lt_amg,AMGf_noright);
2699 logic = SvTRUE(lessp);
2700 } else {
890ce7af 2701 SV* const lessp = amagic_call(left,nullsv,
a0d0e21e
LW		 2702 ncmp_amg,AMGf_noright);
2703 logic = (SvNV(lessp) < 0);
2704 }
2705 if (logic) {
2706 if (off==subtr_amg) {
2707 right = left;
748a9306 2708 left = nullsv;
a0d0e21e
LW		 2709 lr = 1;
2710 }
2711 } else {
2712 return left;
2713 }
2714 }
2715 break;
2716 case neg_amg:
155aba94 2717 if ((cv = cvp[off=subtr_amg])) {
a0d0e21e
LW		 2718 right = left;
2719 left = sv_2mortal(newSViv(0));
2720 lr = 1;
2721 }
2722 break;
f216259d 2723 case int_amg:
f5284f61 2724 case iter_amg: /* XXXX Eventually should do to_gv. */
c4c7412c 2725 case ftest_amg: /* XXXX Eventually should do to_gv. */
d4b87e75 2726 case regexp_amg:
b267980d
NIS		 2727 /* FAIL safe */
2728 return NULL; /* Delegate operation to standard mechanisms. */
2729 break;
f5284f61
IZ		 2730 case to_sv_amg:
2731 case to_av_amg:
2732 case to_hv_amg:
2733 case to_gv_amg:
2734 case to_cv_amg:
2735 /* FAIL safe */
b267980d 2736 return left; /* Delegate operation to standard mechanisms. */
f5284f61 2737 break;
a0d0e21e
LW		 2738 default:
2739 goto not_found;
2740 }
2741 if (!cv) goto not_found;
2742 } else if (!(AMGf_noright & flags) && SvAMAGIC(right)
0a2c84ab 2743 && (stash = SvSTASH(SvRV(right))) && Gv_AMG(stash)
ad64d0ec 2744 && (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table))
b267980d 2745 && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
a6006777 2746 ? (amtp = (AMT*)mg->mg_ptr)->table
d4c19fe8 2747 : NULL))
f041cf0f
RGS		 2748 && ((cv = cvp[off=method+assignshift])
2749 || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
2750 * usual method */
2751 (
2752#ifdef DEBUGGING
2753 fl = 1,
2754#endif
2755 cv = cvp[off=method])))) { /* Method for right
2756 * argument found */
2757 lr=1;
bf5522a1
MB		 2758 } else if (((cvp && amtp->fallback > AMGfallNEVER)
2759 || (ocvp && oamtp->fallback > AMGfallNEVER))
a0d0e21e
LW		 2760 && !(flags & AMGf_unary)) {
2761 /* We look for substitution for
2762 * comparison operations and
fc36a67e 2763 * concatenation */
a0d0e21e
LW		 2764 if (method==concat_amg || method==concat_ass_amg
2765 || method==repeat_amg || method==repeat_ass_amg) {
2766 return NULL; /* Delegate operation to string conversion */
2767 }
2768 off = -1;
2769 switch (method) {
2770 case lt_amg:
2771 case le_amg:
2772 case gt_amg:
2773 case ge_amg:
2774 case eq_amg:
2775 case ne_amg:
2ab54efd
MB		 2776 off = ncmp_amg;
2777 break;
a0d0e21e
LW		 2778 case slt_amg:
2779 case sle_amg:
2780 case sgt_amg:
2781 case sge_amg:
2782 case seq_amg:
2783 case sne_amg:
2ab54efd
MB		 2784 off = scmp_amg;
2785 break;
a0d0e21e 2786 }
bf5522a1
MB		 2787 if (off != -1) {
2788 if (ocvp && (oamtp->fallback > AMGfallNEVER)) {
2789 cv = ocvp[off];
2790 lr = -1;
2791 }
2792 if (!cv && (cvp && amtp->fallback > AMGfallNEVER)) {
2793 cv = cvp[off];
2794 lr = 1;
2795 }
2796 }
2797 if (cv)
2ab54efd
MB		 2798 postpr = 1;
2799 else
2800 goto not_found;
a0d0e21e 2801 } else {
a6006777 2802 not_found: /* No method found, either report or croak */
b267980d
NIS		 2803 switch (method) {
2804 case to_sv_amg:
2805 case to_av_amg:
2806 case to_hv_amg:
2807 case to_gv_amg:
2808 case to_cv_amg:
2809 /* FAIL safe */
2810 return left; /* Delegate operation to standard mechanisms. */
2811 break;
2812 }
a0d0e21e
LW		 2813 if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */
2814 notfound = 1; lr = -1;
2815 } else if (cvp && (cv=cvp[nomethod_amg])) {
2816 notfound = 1; lr = 1;
bf5522a1
MB		 2817 } else if ((use_default_op =
2818 (!ocvp || oamtp->fallback >= AMGfallYES)
2819 && (!cvp || amtp->fallback >= AMGfallYES))
2820 && !DEBUG_o_TEST) {
4cc0ca18
NC		 2821 /* Skip generating the "no method found" message. */
2822 return NULL;
a0d0e21e 2823 } else {
46fc3d4c 2824 SV *msg;
774d564b 2825 if (off==-1) off=method;
b267980d 2826 msg = sv_2mortal(Perl_newSVpvf(aTHX_
d66cca07
BF		 2827 "Operation \"%s\": no method found,%sargument %s%"SVf"%s%"SVf,
2828 AMG_id2name(method + assignshift),
2829 (flags & AMGf_unary ? " " : "\n\tleft "),
2830 SvAMAGIC(left)?
2831 "in overloaded package ":
2832 "has no overloaded magic",
2833 SvAMAGIC(left)?
2834 SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(SvSTASH(SvRV(left)))))):
2835 SVfARG(&PL_sv_no),
2836 SvAMAGIC(right)?
2837 ",\n\tright argument in overloaded package ":
2838 (flags & AMGf_unary
2839 ? ""
2840 : ",\n\tright argument has no overloaded magic"),
2841 SvAMAGIC(right)?
2842 SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(SvSTASH(SvRV(right)))))):
2843 SVfARG(&PL_sv_no)));
bf5522a1 2844 if (use_default_op) {
d66cca07 2845 DEBUG_o( Perl_deb(aTHX_ "%"SVf, SVfARG(msg)) );
a0d0e21e 2846 } else {
be2597df 2847 Perl_croak(aTHX_ "%"SVf, SVfARG(msg));
a0d0e21e
LW		 2848 }
2849 return NULL;
2850 }
ee239bfe 2851 force_cpy = force_cpy || assign;
a0d0e21e
LW		 2852 }
2853 }
67288365
JL		 2854
2855 switch (method) {
2856 /* in these cases, we're calling '+' or '-' as a fallback for a ++ or --
2857 * operation. we need this to return a value, so that it can be assigned
2858 * later on, in the postpr block (case inc_amg/dec_amg), even if the
2859 * increment or decrement was itself called in void context */
2860 case inc_amg:
2861 if (off == add_amg)
2862 force_scalar = 1;
2863 break;
2864 case dec_amg:
2865 if (off == subtr_amg)
2866 force_scalar = 1;
2867 break;
2868 /* in these cases, we're calling an assignment variant of an operator
2869 * (+= rather than +, for instance). regardless of whether it's a
2870 * fallback or not, it always has to return a value, which will be
2871 * assigned to the proper variable later */
2872 case add_amg:
2873 case subtr_amg:
2874 case mult_amg:
2875 case div_amg:
2876 case modulo_amg:
2877 case pow_amg:
2878 case lshift_amg:
2879 case rshift_amg:
2880 case repeat_amg:
2881 case concat_amg:
2882 case band_amg:
2883 case bor_amg:
2884 case bxor_amg:
2885 if (assign)
2886 force_scalar = 1;
2887 break;
2888 /* the copy constructor always needs to return a value */
2889 case copy_amg:
2890 force_scalar = 1;
2891 break;
2892 /* because of the way these are implemented (they don't perform the
2893 * dereferencing themselves, they return a reference that perl then
2894 * dereferences later), they always have to be in scalar context */
2895 case to_sv_amg:
2896 case to_av_amg:
2897 case to_hv_amg:
2898 case to_gv_amg:
2899 case to_cv_amg:
2900 force_scalar = 1;
2901 break;
2902 /* these don't have an op of their own; they're triggered by their parent
2903 * op, so the context there isn't meaningful ('$a and foo()' in void
2904 * context still needs to pass scalar context on to $a's bool overload) */
2905 case bool__amg:
2906 case numer_amg:
2907 case string_amg:
2908 force_scalar = 1;
2909 break;
2910 }
2911
497b47a8 2912#ifdef DEBUGGING
a0d0e21e 2913 if (!notfound) {
497b47a8 2914 DEBUG_o(Perl_deb(aTHX_
d66cca07 2915 "Overloaded operator \"%s\"%s%s%s:\n\tmethod%s found%s in package %"SVf"%s\n",
497b47a8
JH		 2916 AMG_id2name(off),
2917 method+assignshift==off? "" :
a0288114 2918 " (initially \"",
497b47a8
JH		 2919 method+assignshift==off? "" :
2920 AMG_id2name(method+assignshift),
a0288114 2921 method+assignshift==off? "" : "\")",
497b47a8
JH		 2922 flags & AMGf_unary? "" :
2923 lr==1 ? " for right argument": " for left argument",
2924 flags & AMGf_unary? " for argument" : "",
d66cca07 2925 stash ? SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(stash)))) : SVfARG(newSVpvs_flags("null", SVs_TEMP)),
497b47a8 2926 fl? ",\n\tassignment variant used": "") );
ee239bfe 2927 }
497b47a8 2928#endif
748a9306
LW		 2929 /* Since we use shallow copy during assignment, we need
2930 * to dublicate the contents, probably calling user-supplied
2931 * version of copy operator
2932 */
ee239bfe
IZ		 2933 /* We need to copy in following cases:
2934 * a) Assignment form was called.
2935 * assignshift==1, assign==T, method + 1 == off
2936 * b) Increment or decrement, called directly.
2937 * assignshift==0, assign==0, method + 0 == off
2938 * c) Increment or decrement, translated to assignment add/subtr.
b267980d 2939 * assignshift==0, assign==T,
ee239bfe
IZ		 2940 * force_cpy == T
2941 * d) Increment or decrement, translated to nomethod.
b267980d 2942 * assignshift==0, assign==0,
ee239bfe
IZ		 2943 * force_cpy == T
2944 * e) Assignment form translated to nomethod.
2945 * assignshift==1, assign==T, method + 1 != off
2946 * force_cpy == T
2947 */
2948 /* off is method, method+assignshift, or a result of opcode substitution.
2949 * In the latter case assignshift==0, so only notfound case is important.
2950 */
73512201 2951 if ( (lr == -1) && ( ( (method + assignshift == off)
ee239bfe 2952 && (assign || (method == inc_amg) || (method == dec_amg)))
73512201 2953 || force_cpy) )
6f1401dc 2954 {
1b38c28e
NC		 2955 /* newSVsv does not behave as advertised, so we copy missing
2956 * information by hand */
2957 SV *tmpRef = SvRV(left);
2958 SV *rv_copy;
31d632c3 2959 if (SvREFCNT(tmpRef) > 1 && (rv_copy = AMG_CALLunary(left,copy_amg))) {
1b38c28e
NC		 2960 SvRV_set(left, rv_copy);
2961 SvSETMAGIC(left);
2962 SvREFCNT_dec(tmpRef);
2963 }
6f1401dc
DM		 2964 }
2965
a0d0e21e
LW		 2966 {
2967 dSP;
2968 BINOP myop;
2969 SV* res;
b7787f18 2970 const bool oldcatch = CATCH_GET;
67288365
JL		 2971 I32 oldmark, nret;
2972 int gimme = force_scalar ? G_SCALAR : GIMME_V;
a0d0e21e 2973
54310121 2974 CATCH_SET(TRUE);
a0d0e21e
LW		 2975 Zero(&myop, 1, BINOP);
2976 myop.op_last = (OP *) &myop;
b37c2d43 2977 myop.op_next = NULL;
67288365
JL		 2978 myop.op_flags = OPf_STACKED;
2979
2980 switch (gimme) {
2981 case G_VOID:
2982 myop.op_flags |= OPf_WANT_VOID;
2983 break;
2984 case G_ARRAY:
2985 if (flags & AMGf_want_list) {
2986 myop.op_flags |= OPf_WANT_LIST;
2987 break;
2988 }
2989 /* FALLTHROUGH */
2990 default:
2991 myop.op_flags |= OPf_WANT_SCALAR;
2992 break;
2993 }
a0d0e21e 2994
e788e7d3 2995 PUSHSTACKi(PERLSI_OVERLOAD);
a0d0e21e 2996 ENTER;
462e5cf6 2997 SAVEOP();
533c011a 2998 PL_op = (OP *) &myop;
3280af22 2999 if (PERLDB_SUB && PL_curstash != PL_debstash)
533c011a 3000 PL_op->op_private |= OPpENTERSUB_DB;
a0d0e21e 3001 PUTBACK;
897d3989 3002 Perl_pp_pushmark(aTHX);
a0d0e21e 3003
924508f0 3004 EXTEND(SP, notfound + 5);
a0d0e21e
LW		 3005 PUSHs(lr>0? right: left);
3006 PUSHs(lr>0? left: right);
3280af22 3007 PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no ));
a0d0e21e 3008 if (notfound) {
59cd0e26
NC		 3009 PUSHs(newSVpvn_flags(AMG_id2name(method + assignshift),
3010 AMG_id2namelen(method + assignshift), SVs_TEMP));
a0d0e21e 3011 }
ad64d0ec 3012 PUSHs(MUTABLE_SV(cv));
a0d0e21e 3013 PUTBACK;
67288365 3014 oldmark = TOPMARK;
a0d0e21e 3015
139d0ce6 3016 if ((PL_op = PL_ppaddr[OP_ENTERSUB](aTHX)))
cea2e8a9 3017 CALLRUNOPS(aTHX);
a0d0e21e
LW		 3018 LEAVE;
3019 SPAGAIN;
67288365
JL		 3020 nret = SP - (PL_stack_base + oldmark);
3021
3022 switch (gimme) {
3023 case G_VOID:
3024 /* returning NULL has another meaning, and we check the context
3025 * at the call site too, so this can be differentiated from the
3026 * scalar case */
3027 res = &PL_sv_undef;
3028 SP = PL_stack_base + oldmark;
3029 break;
3030 case G_ARRAY: {
3031 if (flags & AMGf_want_list) {
3032 res = sv_2mortal((SV *)newAV());
3033 av_extend((AV *)res, nret);
3034 while (nret--)
3035 av_store((AV *)res, nret, POPs);
3036 break;
3037 }
3038 /* FALLTHROUGH */
3039 }
3040 default:
3041 res = POPs;
3042 break;
3043 }
a0d0e21e 3044
ebafeae7 3045 PUTBACK;
d3acc0f7 3046 POPSTACK;
54310121 3047 CATCH_SET(oldcatch);
a0d0e21e 3048
a0d0e21e 3049 if (postpr) {
b7787f18 3050 int ans;
a0d0e21e
LW		 3051 switch (method) {
3052 case le_amg:
3053 case sle_amg:
3054 ans=SvIV(res)<=0; break;
3055 case lt_amg:
3056 case slt_amg:
3057 ans=SvIV(res)<0; break;
3058 case ge_amg:
3059 case sge_amg:
3060 ans=SvIV(res)>=0; break;
3061 case gt_amg:
3062 case sgt_amg:
3063 ans=SvIV(res)>0; break;
3064 case eq_amg:
3065 case seq_amg:
3066 ans=SvIV(res)==0; break;
3067 case ne_amg:
3068 case sne_amg:
3069 ans=SvIV(res)!=0; break;
3070 case inc_amg:
3071 case dec_amg:
bbce6d69 3072 SvSetSV(left,res); return left;
dc437b57 3073 case not_amg:
fe7ac86a 3074 ans=!SvTRUE(res); break;
b7787f18
AL		 3075 default:
3076 ans=0; break;
a0d0e21e 3077 }
54310121 3078 return boolSV(ans);
748a9306
LW		 3079 } else if (method==copy_amg) {
3080 if (!SvROK(res)) {
cea2e8a9 3081 Perl_croak(aTHX_ "Copy method did not return a reference");
748a9306
LW		 3082 }
3083 return SvREFCNT_inc(SvRV(res));
a0d0e21e
LW		 3084 } else {
3085 return res;
3086 }
3087 }
3088}
c9d5ac95 3089
f5c1e807
NC		 3090void
3091Perl_gv_name_set(pTHX_ GV *gv, const char *name, U32 len, U32 flags)
3092{
3093 dVAR;
acda4c6a 3094 U32 hash;
f5c1e807 3095
7918f24d 3096 PERL_ARGS_ASSERT_GV_NAME_SET;
f5c1e807 3097
acda4c6a
NC		 3098 if (len > I32_MAX)
3099 Perl_croak(aTHX_ "panic: gv name too long (%"UVuf")", (UV) len);
3100
ae8cc45f
NC		 3101 if (!(flags & GV_ADD) && GvNAME_HEK(gv)) {
3102 unshare_hek(GvNAME_HEK(gv));
3103 }
3104
acda4c6a 3105 PERL_HASH(hash, name, len);
c60dbbc3 3106 GvNAME_HEK(gv) = share_hek(name, (flags & SVf_UTF8 ? -(I32)len : (I32)len), hash);
f5c1e807
NC		 3107}
3108
66610fdd 3109/*
f7461760
Z		 3110=for apidoc gv_try_downgrade
3111
2867cdbc
Z		 3112If the typeglob C<gv> can be expressed more succinctly, by having
3113something other than a real GV in its place in the stash, replace it
3114with the optimised form. Basic requirements for this are that C<gv>
3115is a real typeglob, is sufficiently ordinary, and is only referenced
3116from its package. This function is meant to be used when a GV has been
3117looked up in part to see what was there, causing upgrading, but based
3118on what was found it turns out that the real GV isn't required after all.
3119
3120If C<gv> is a completely empty typeglob, it is deleted from the stash.
3121
3122If C<gv> is a typeglob containing only a sufficiently-ordinary constant
3123sub, the typeglob is replaced with a scalar-reference placeholder that
3124more compactly represents the same thing.
f7461760
Z		 3125
3126=cut
3127*/
3128
3129void
3130Perl_gv_try_downgrade(pTHX_ GV *gv)
3131{
3132 HV *stash;
3133 CV *cv;
3134 HEK *namehek;
3135 SV **gvp;
3136 PERL_ARGS_ASSERT_GV_TRY_DOWNGRADE;
95f56751
FC		 3137
3138 /* XXX Why and where does this leave dangling pointers during global
3139 destruction? */
627364f1 3140 if (PL_phase == PERL_PHASE_DESTRUCT) return;
95f56751 3141
2867cdbc 3142 if (!(SvREFCNT(gv) == 1 && SvTYPE(gv) == SVt_PVGV && !SvFAKE(gv) &&
803f2748 3143 !SvOBJECT(gv) && !SvREADONLY(gv) &&
f7461760 3144 isGV_with_GP(gv) && GvGP(gv) &&
2867cdbc 3145 !GvINTRO(gv) && GvREFCNT(gv) == 1 &&
f7461760 3146 !GvSV(gv) && !GvAV(gv) && !GvHV(gv) && !GvIOp(gv) && !GvFORM(gv) &&
099be4f1 3147 GvEGVx(gv) == gv && (stash = GvSTASH(gv))))
2867cdbc 3148 return;
803f2748
DM		 3149 if (SvMAGICAL(gv)) {
3150 MAGIC *mg;
3151 /* only backref magic is allowed */
3152 if (SvGMAGICAL(gv) || SvSMAGICAL(gv))
3153 return;
3154 for (mg = SvMAGIC(gv); mg; mg = mg->mg_moremagic) {
3155 if (mg->mg_type != PERL_MAGIC_backref)
3156 return;
3157 }
3158 }
2867cdbc
Z		 3159 cv = GvCV(gv);
3160 if (!cv) {
3161 HEK *gvnhek = GvNAME_HEK(gv);
3162 (void)hv_delete(stash, HEK_KEY(gvnhek),
3163 HEK_UTF8(gvnhek) ? -HEK_LEN(gvnhek) : HEK_LEN(gvnhek), G_DISCARD);
3164 } else if (GvMULTI(gv) && cv &&
f7461760
Z		 3165 !SvOBJECT(cv) && !SvMAGICAL(cv) && !SvREADONLY(cv) &&
3166 CvSTASH(cv) == stash && CvGV(cv) == gv &&
3167 CvCONST(cv) && !CvMETHOD(cv) && !CvLVALUE(cv) && !CvUNIQUE(cv) &&
3168 !CvNODEBUG(cv) && !CvCLONE(cv) && !CvCLONED(cv) && !CvANON(cv) &&
3169 (namehek = GvNAME_HEK(gv)) &&
3170 (gvp = hv_fetch(stash, HEK_KEY(namehek),
3171 HEK_LEN(namehek)*(HEK_UTF8(namehek) ? -1 : 1), 0)) &&
3172 *gvp == (SV*)gv) {
3173 SV *value = SvREFCNT_inc(CvXSUBANY(cv).any_ptr);
3174 SvREFCNT(gv) = 0;
3175 sv_clear((SV*)gv);
3176 SvREFCNT(gv) = 1;
3177 SvFLAGS(gv) = SVt_IV|SVf_ROK;
3178 SvANY(gv) = (XPVGV*)((char*)&(gv->sv_u.svu_iv) -
3179 STRUCT_OFFSET(XPVIV, xiv_iv));
3180 SvRV_set(gv, value);
3181 }
3182}
3183
4aaa4757
FC		 3184#include "XSUB.h"
3185
3186static void
3187core_xsub(pTHX_ CV* cv)
3188{
3189 Perl_croak(aTHX_
3190 "&CORE::%s cannot be called directly", GvNAME(CvGV(cv))
3191 );
3192}
3193
f7461760 3194/*
66610fdd
RGS		 3195 * Local variables:
3196 * c-indentation-style: bsd
3197 * c-basic-offset: 4
14d04a33 3198 * indent-tabs-mode: nil
66610fdd
RGS		 3199 * End:
3200 *
14d04a33 3201 * ex: set ts=8 sts=4 sw=4 et:
37442d52 3202 */
Unnamed repository; edit this file 'description' to name the repository.