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