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