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