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