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