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