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