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