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