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
Add epigraph for 5.17.10
[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);
32833930 1601 if (is_utf8)
608b3986
AE		 1602 SvUTF8_on(err);
1603 qerror(err);
76f68e9b 1604 gv = gv_fetchpvs("<none>::", GV_ADDMULTI, SVt_PVHV);
e7f343b6
NC		 1605 if(!gv) {
1606 /* symbol table under destruction */
1607 return NULL;
1608 }
1609 stash = GvHV(gv);
a0d0e21e 1610 }
d7aacf4e 1611 else
a0714e2c 1612 return NULL;
a0d0e21e
LW		 1613 }
1614
1615 if (!SvREFCNT(stash)) /* symbol table under destruction */
a0714e2c 1616 return NULL;
a0d0e21e 1617
0be4d16f 1618 gvp = (GV**)hv_fetch(stash,name,is_utf8 ? -len : len,add);
23496c6e
FC		 1619 if (!gvp || *gvp == (const GV *)&PL_sv_undef) {
1620 if (addmg) gv = (GV *)newSV(0);
1621 else return NULL;
1622 }
914ecc63
FC		 1623 else gv = *gvp, addmg = 0;
1624 /* From this point on, addmg means gv has not been inserted in the
1625 symtab yet. */
1626
79072805 1627 if (SvTYPE(gv) == SVt_PVGV) {
a0d0e21e 1628 if (add) {
a5f75d66 1629 GvMULTI_on(gv);
e6066781 1630 gv_init_svtype(gv, sv_type);
ff683671
NC		 1631 /* You reach this path once the typeglob has already been created,
1632 either by the same or a different sigil. If this path didn't
1633 exist, then (say) referencing $! first, and %! second would
1634 mean that %! was not handled correctly. */
b82b06b8
FC		 1635 if (len == 1 && stash == PL_defstash) {
1636 if (sv_type == SVt_PVHV || sv_type == SVt_PVGV) {
44a2ac75
YO		 1637 if (*name == '!')
1638 require_tie_mod(gv, "!", newSVpvs("Errno"), "TIEHASH", 1);
45cbc99a 1639 else if (*name == '-' || *name == '+')
192b9cd1 1640 require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "TIEHASH", 0);
982110e0
NC		 1641 } else if (sv_type == SVt_PV && *name == '#') {
1642 Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED,
1643 WARN_SYNTAX),
1644 "$# is no longer supported");
1645 }
1646 if (*name == '*') {
1647 if (sv_type == SVt_PV)
ff683671
NC		 1648 Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED,
1649 WARN_SYNTAX),
53213d38 1650 "$* is no longer supported, and will become a syntax error");
982110e0
NC		 1651 else
1652 Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
1653 "%c* is deprecated, and will become a syntax error",
1654 sv_type == SVt_PVAV ? '@'
1655 : sv_type == SVt_PVCV ? '&'
1656 : sv_type == SVt_PVHV ? '%'
1657 : '*');
ff683671 1658 }
a289ef89 1659 if (sv_type==SVt_PV || sv_type==SVt_PVGV) {
d3b97530
DM		 1660 switch (*name) {
1661 case '[':
1662 require_tie_mod(gv,name,newSVpvs("arybase"),"FETCH",0);
1663 break;
1a904fc8 1664#ifdef PERL_SAWAMPERSAND
d3b97530
DM		 1665 case '`':
1666 PL_sawampersand |= SAWAMPERSAND_LEFT;
1667 (void)GvSVn(gv);
1668 break;
1669 case '&':
1670 PL_sawampersand |= SAWAMPERSAND_MIDDLE;
1671 (void)GvSVn(gv);
1672 break;
1673 case '\'':
1674 PL_sawampersand |= SAWAMPERSAND_RIGHT;
1675 (void)GvSVn(gv);
1676 break;
1a904fc8 1677#endif
d3b97530 1678 }
a289ef89 1679 }
45cbc99a 1680 }
af16de9f
FC		 1681 else if (len == 3 && sv_type == SVt_PVAV
1682 && strnEQ(name, "ISA", 3)
1683 && (!GvAV(gv) || !SvSMAGICAL(GvAV(gv))))
1684 gv_magicalize_isa(gv);
a0d0e21e 1685 }
79072805 1686 return gv;
add2581e 1687 } else if (no_init) {
23496c6e 1688 assert(!addmg);
55d729e4 1689 return gv;
e26df76a 1690 } else if (no_expand && SvROK(gv)) {
23496c6e 1691 assert(!addmg);
e26df76a 1692 return gv;
79072805 1693 }
93a17b20 1694
5e0caaeb
NC		 1695 /* Adding a new symbol.
1696 Unless of course there was already something non-GV here, in which case
1697 we want to behave as if there was always a GV here, containing some sort
1698 of subroutine.
1699 Otherwise we run the risk of creating things like GvIO, which can cause
1700 subtle bugs. eg the one that tripped up SQL::Translator */
1701
1702 faking_it = SvOK(gv);
93a17b20 1703
9b387841 1704 if (add & GV_ADDWARN)
ecad31f0 1705 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "Had to create %"SVf" unexpectedly",
f1c07be4 1706 SVfARG(newSVpvn_flags(nambeg, name_end-nambeg, SVs_TEMP | is_utf8 )));
04ec7e59 1707 gv_init_pvn(gv, stash, name, len, (add & GV_ADDMULTI)|is_utf8);
93a17b20 1708
ecad31f0
BF		 1709 if ( isIDFIRST_lazy_if(name, is_utf8)
1710 && ! (isLEXWARN_on ? ckWARN(WARN_ONCE) : (PL_dowarn & G_WARN_ON ) ) )
0453d815
PM		 1711 GvMULTI_on(gv) ;
1712
93a17b20 1713 /* set up magic where warranted */
44428a46 1714 if (stash != PL_defstash) { /* not the main stash */
5fdfd519 1715 /* We only have to check for three names here: EXPORT, ISA
4aaa4757
FC		 1716 and VERSION. All the others apply only to the main stash or to
1717 CORE (which is checked right after this). */
f4e68e82 1718 if (len > 2) {
b464bac0 1719 const char * const name2 = name + 1;
cc4c2da6 1720 switch (*name) {
cc4c2da6
NC		 1721 case 'E':
1722 if (strnEQ(name2, "XPORT", 5))
1723 GvMULTI_on(gv);
1724 break;
1725 case 'I':
44428a46 1726 if (strEQ(name2, "SA"))
290a1700 1727 gv_magicalize_isa(gv);
cc4c2da6 1728 break;
44428a46
FC		 1729 case 'V':
1730 if (strEQ(name2, "ERSION"))
1731 GvMULTI_on(gv);
1732 break;
4aaa4757
FC		 1733 default:
1734 goto try_core;
1735 }
23496c6e 1736 goto add_magical_gv;
4aaa4757
FC		 1737 }
1738 try_core:
1739 if (len > 1 /* shortest is uc */ && HvNAMELEN_get(stash) == 4) {
1740 /* Avoid null warning: */
1741 const char * const stashname = HvNAME(stash); assert(stashname);
87566176
FC		 1742 if (strnEQ(stashname, "CORE", 4))
1743 S_maybe_add_coresub(aTHX_ 0, gv, name, len);
44428a46
FC		 1744 }
1745 }
1746 else if (len > 1) {
1747#ifndef EBCDIC
1748 if (*name > 'V' ) {
1749 NOOP;
1750 /* Nothing else to do.
1751 The compiler will probably turn the switch statement into a
1752 branch table. Make sure we avoid even that small overhead for
1753 the common case of lower case variable names. */
1754 } else
1755#endif
1756 {
1757 const char * const name2 = name + 1;
1758 switch (*name) {
1759 case 'A':
1760 if (strEQ(name2, "RGV")) {
1761 IoFLAGS(GvIOn(gv)) |= IOf_ARGV|IOf_START;
1762 }
1763 else if (strEQ(name2, "RGVOUT")) {
1764 GvMULTI_on(gv);
1765 }
1766 break;
1767 case 'E':
1768 if (strnEQ(name2, "XPORT", 5))
1769 GvMULTI_on(gv);
1770 break;
1771 case 'I':
1772 if (strEQ(name2, "SA")) {
290a1700 1773 gv_magicalize_isa(gv);
44428a46
FC		 1774 }
1775 break;
cc4c2da6
NC		 1776 case 'S':
1777 if (strEQ(name2, "IG")) {
1778 HV *hv;
1779 I32 i;
d525a7b2
NC		 1780 if (!PL_psig_name) {
1781 Newxz(PL_psig_name, 2 * SIG_SIZE, SV*);
a02a5408 1782 Newxz(PL_psig_pend, SIG_SIZE, int);
d525a7b2 1783 PL_psig_ptr = PL_psig_name + SIG_SIZE;
0bdedcb3
NC		 1784 } else {
1785 /* I think that the only way to get here is to re-use an
1786 embedded perl interpreter, where the previous
1787 use didn't clean up fully because
1788 PL_perl_destruct_level was 0. I'm not sure that we
1789 "support" that, in that I suspect in that scenario
1790 there are sufficient other garbage values left in the
1791 interpreter structure that something else will crash
1792 before we get here. I suspect that this is one of
1793 those "doctor, it hurts when I do this" bugs. */
d525a7b2 1794 Zero(PL_psig_name, 2 * SIG_SIZE, SV*);
0bdedcb3 1795 Zero(PL_psig_pend, SIG_SIZE, int);
cc4c2da6
NC		 1796 }
1797 GvMULTI_on(gv);
1798 hv = GvHVn(gv);
a0714e2c 1799 hv_magic(hv, NULL, PERL_MAGIC_sig);
cc4c2da6 1800 for (i = 1; i < SIG_SIZE; i++) {
551405c4 1801 SV * const * const init = hv_fetch(hv, PL_sig_name[i], strlen(PL_sig_name[i]), 1);
cc4c2da6
NC		 1802 if (init)
1803 sv_setsv(*init, &PL_sv_undef);
cc4c2da6
NC		 1804 }
1805 }
1806 break;
1807 case 'V':
1808 if (strEQ(name2, "ERSION"))
1809 GvMULTI_on(gv);
1810 break;
e5218da5
GA		 1811 case '\003': /* $^CHILD_ERROR_NATIVE */
1812 if (strEQ(name2, "HILD_ERROR_NATIVE"))
1813 goto magicalize;
1814 break;
cc4c2da6
NC		 1815 case '\005': /* $^ENCODING */
1816 if (strEQ(name2, "NCODING"))
1817 goto magicalize;
1818 break;
9ebf26ad
FR		 1819 case '\007': /* $^GLOBAL_PHASE */
1820 if (strEQ(name2, "LOBAL_PHASE"))
1821 goto ro_magicalize;
1822 break;
8561ea1d
FC		 1823 case '\014': /* $^LAST_FH */
1824 if (strEQ(name2, "AST_FH"))
1825 goto ro_magicalize;
1826 break;
cde0cee5
YO		 1827 case '\015': /* $^MATCH */
1828 if (strEQ(name2, "ATCH"))
2fdbfb4d 1829 goto magicalize;
cc4c2da6
NC		 1830 case '\017': /* $^OPEN */
1831 if (strEQ(name2, "PEN"))
1832 goto magicalize;
1833 break;
cde0cee5
YO		 1834 case '\020': /* $^PREMATCH $^POSTMATCH */
1835 if (strEQ(name2, "REMATCH") || strEQ(name2, "OSTMATCH"))
9ebf26ad
FR		 1836 goto magicalize;
1837 break;
cc4c2da6
NC		 1838 case '\024': /* ${^TAINT} */
1839 if (strEQ(name2, "AINT"))
1840 goto ro_magicalize;
1841 break;
7cebcbc0 1842 case '\025': /* ${^UNICODE}, ${^UTF8LOCALE} */
a0288114 1843 if (strEQ(name2, "NICODE"))
cc4c2da6 1844 goto ro_magicalize;
a0288114 1845 if (strEQ(name2, "TF8LOCALE"))
7cebcbc0 1846 goto ro_magicalize;
e07ea26a
NC		 1847 if (strEQ(name2, "TF8CACHE"))
1848 goto magicalize;
cc4c2da6
NC		 1849 break;
1850 case '\027': /* $^WARNING_BITS */
1851 if (strEQ(name2, "ARNING_BITS"))
1852 goto magicalize;
1853 break;
1854 case '1':
1855 case '2':
1856 case '3':
1857 case '4':
1858 case '5':
1859 case '6':
1860 case '7':
1861 case '8':
1862 case '9':
85e6fe83 1863 {
2fdbfb4d
AB		 1864 /* Ensures that we have an all-digit variable, ${"1foo"} fails
1865 this test */
1866 /* This snippet is taken from is_gv_magical */
cc4c2da6
NC		 1867 const char *end = name + len;
1868 while (--end > name) {
23496c6e 1869 if (!isDIGIT(*end)) goto add_magical_gv;
cc4c2da6 1870 }
2fdbfb4d 1871 goto magicalize;
1d7c1841 1872 }
dc437b57 1873 }
93a17b20 1874 }
392db708
NC		 1875 } else {
1876 /* Names of length 1. (Or 0. But name is NUL terminated, so that will
1877 be case '\0' in this switch statement (ie a default case) */
cc4c2da6 1878 switch (*name) {
6361f656
AB		 1879 case '&': /* $& */
1880 case '`': /* $` */
1881 case '\'': /* $' */
1a904fc8 1882#ifdef PERL_SAWAMPERSAND
a289ef89 1883 if (!(
cc4c2da6
NC		 1884 sv_type == SVt_PVAV ||
1885 sv_type == SVt_PVHV ||
1886 sv_type == SVt_PVCV ||
1887 sv_type == SVt_PVFM ||
1888 sv_type == SVt_PVIO
d3b97530
DM		 1889 )) { PL_sawampersand |=
1890 (*name == '`')
1891 ? SAWAMPERSAND_LEFT
1892 : (*name == '&')
1893 ? SAWAMPERSAND_MIDDLE
1894 : SAWAMPERSAND_RIGHT;
1895 }
1a904fc8 1896#endif
2fdbfb4d 1897 goto magicalize;
cc4c2da6 1898
6361f656 1899 case ':': /* $: */
c69033f2 1900 sv_setpv(GvSVn(gv),PL_chopset);
cc4c2da6
NC		 1901 goto magicalize;
1902
6361f656 1903 case '?': /* $? */
ff0cee69 1904#ifdef COMPLEX_STATUS
c69033f2 1905 SvUPGRADE(GvSVn(gv), SVt_PVLV);
ff0cee69 1906#endif
cc4c2da6 1907 goto magicalize;
ff0cee69 1908
6361f656 1909 case '!': /* $! */
67261566 1910 GvMULTI_on(gv);
44a2ac75 1911 /* If %! has been used, automatically load Errno.pm. */
d2c93421 1912
ad64d0ec 1913 sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
d2c93421 1914
44a2ac75 1915 /* magicalization must be done before require_tie_mod is called */
67261566 1916 if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
ffdb8bcd
FC		 1917 {
1918 if (addmg) (void)hv_store(stash,name,len,(SV *)gv,0);
1919 addmg = 0;
44a2ac75 1920 require_tie_mod(gv, "!", newSVpvs("Errno"), "TIEHASH", 1);
ffdb8bcd 1921 }
d2c93421 1922
6cef1e77 1923 break;
6361f656
AB		 1924 case '-': /* $- */
1925 case '+': /* $+ */
44a2ac75
YO		 1926 GvMULTI_on(gv); /* no used once warnings here */
1927 {
44a2ac75 1928 AV* const av = GvAVn(gv);
ad64d0ec 1929 SV* const avc = (*name == '+') ? MUTABLE_SV(av) : NULL;
44a2ac75 1930
ad64d0ec
NC		 1931 sv_magic(MUTABLE_SV(av), avc, PERL_MAGIC_regdata, NULL, 0);
1932 sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
67261566 1933 if (avc)
44a2ac75 1934 SvREADONLY_on(GvSVn(gv));
44a2ac75 1935 SvREADONLY_on(av);
67261566
YO		 1936
1937 if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
213084e4
FC		 1938 {
1939 if (addmg) (void)hv_store(stash,name,len,(SV *)gv,0);
1940 addmg = 0;
192b9cd1 1941 require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "TIEHASH", 0);
213084e4 1942 }
67261566 1943
80305961 1944 break;
cc4c2da6 1945 }
6361f656 1946 case '*': /* $* */
53213d38
NC		 1947 if (sv_type == SVt_PV)
1948 Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
1949 "$* is no longer supported, and will become a syntax error");
982110e0
NC		 1950 else {
1951 Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
1952 "%c* is deprecated, and will become a syntax error",
1953 sv_type == SVt_PVAV ? '@'
1954 : sv_type == SVt_PVCV ? '&'
1955 : sv_type == SVt_PVHV ? '%'
1956 : '*');
1957 }
53213d38 1958 break;
6361f656 1959 case '#': /* $# */
9b387841
NC		 1960 if (sv_type == SVt_PV)
1961 Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
53213d38 1962 "$# is no longer supported");
8ae1fe26 1963 break;
b3ca2e83
NC		 1964 case '\010': /* $^H */
1965 {
1966 HV *const hv = GvHVn(gv);
1967 hv_magic(hv, NULL, PERL_MAGIC_hints);
1968 }
1969 goto magicalize;
b82b06b8 1970 case '[': /* $[ */
7d69d4a6 1971 if ((sv_type == SVt_PV || sv_type == SVt_PVGV)
2846acbf 1972 && FEATURE_ARYBASE_IS_ENABLED) {
b82b06b8
FC		 1973 if (addmg) (void)hv_store(stash,name,len,(SV *)gv,0);
1974 require_tie_mod(gv,name,newSVpvs("arybase"),"FETCH",0);
1975 addmg = 0;
1976 }
7d69d4a6 1977 else goto magicalize;
b82b06b8 1978 break;
cc4c2da6 1979 case '\023': /* $^S */
2fdbfb4d
AB		 1980 ro_magicalize:
1981 SvREADONLY_on(GvSVn(gv));
1982 /* FALL THROUGH */
6361f656
AB		 1983 case '0': /* $0 */
1984 case '1': /* $1 */
1985 case '2': /* $2 */
1986 case '3': /* $3 */
1987 case '4': /* $4 */
1988 case '5': /* $5 */
1989 case '6': /* $6 */
1990 case '7': /* $7 */
1991 case '8': /* $8 */
1992 case '9': /* $9 */
6361f656
AB		 1993 case '^': /* $^ */
1994 case '~': /* $~ */
1995 case '=': /* $= */
1996 case '%': /* $% */
1997 case '.': /* $. */
1998 case '(': /* $( */
1999 case ')': /* $) */
2000 case '<': /* $< */
2001 case '>': /* $> */
2002 case '\\': /* $\ */
2003 case '/': /* $/ */
4505a31f 2004 case '|': /* $| */
9cdac2a2 2005 case '$': /* $$ */
cc4c2da6
NC		 2006 case '\001': /* $^A */
2007 case '\003': /* $^C */
2008 case '\004': /* $^D */
2009 case '\005': /* $^E */
2010 case '\006': /* $^F */
cc4c2da6
NC		 2011 case '\011': /* $^I, NOT \t in EBCDIC */
2012 case '\016': /* $^N */
2013 case '\017': /* $^O */
2014 case '\020': /* $^P */
2015 case '\024': /* $^T */
2016 case '\027': /* $^W */
2017 magicalize:
ad64d0ec 2018 sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
cc4c2da6 2019 break;
e521374c 2020
cc4c2da6 2021 case '\014': /* $^L */
76f68e9b 2022 sv_setpvs(GvSVn(gv),"\f");
463ee0b2 2023 break;
6361f656 2024 case ';': /* $; */
76f68e9b 2025 sv_setpvs(GvSVn(gv),"\034");
463ee0b2 2026 break;
6361f656 2027 case ']': /* $] */
cc4c2da6 2028 {
3638bf15 2029 SV * const sv = GvSV(gv);
d7aa5382 2030 if (!sv_derived_from(PL_patchlevel, "version"))
ac0e6a2f 2031 upg_version(PL_patchlevel, TRUE);
7d54d38e
SH		 2032 GvSV(gv) = vnumify(PL_patchlevel);
2033 SvREADONLY_on(GvSV(gv));
2034 SvREFCNT_dec(sv);
93a17b20
LW		 2035 }
2036 break;
cc4c2da6
NC		 2037 case '\026': /* $^V */
2038 {
3638bf15 2039 SV * const sv = GvSV(gv);
f9be5ac8
DM		 2040 GvSV(gv) = new_version(PL_patchlevel);
2041 SvREADONLY_on(GvSV(gv));
2042 SvREFCNT_dec(sv);
16070b82
GS		 2043 }
2044 break;
cc4c2da6 2045 }
79072805 2046 }
23496c6e
FC		 2047 add_magical_gv:
2048 if (addmg) {
2049 if (GvAV(gv) || GvHV(gv) || GvIO(gv) || GvCV(gv) || (
2050 GvSV(gv) && (SvOK(GvSV(gv)) || SvMAGICAL(GvSV(gv)))
2051 ))
0f43181e 2052 (void)hv_store(stash,name,len,(SV *)gv,0);
e7881358 2053 else SvREFCNT_dec_NN(gv), gv = NULL;
23496c6e 2054 }
e6066781 2055 if (gv) gv_init_svtype(gv, faking_it ? SVt_PVCV : sv_type);
93a17b20 2056 return gv;
79072805
LW		 2057}
2058
2059void
35a4481c 2060Perl_gv_fullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
43693395 2061{
ed60a868 2062 const char *name;
35a4481c 2063 const HV * const hv = GvSTASH(gv);
7918f24d
NC		 2064
2065 PERL_ARGS_ASSERT_GV_FULLNAME4;
2066
666ea192 2067 sv_setpv(sv, prefix ? prefix : "");
a0288114 2068
52a6327b 2069 if (hv && (name = HvNAME(hv))) {
ed60a868
FC		 2070 const STRLEN len = HvNAMELEN(hv);
2071 if (keepmain || strnNE(name, "main", len)) {
2072 sv_catpvn_flags(sv,name,len,HvNAMEUTF8(hv)?SV_CATUTF8:SV_CATBYTES);
396482e1 2073 sv_catpvs(sv,"::");
ed60a868 2074 }
43693395 2075 }
ed60a868 2076 else sv_catpvs(sv,"__ANON__::");
04f3bf56 2077 sv_catsv(sv,sv_2mortal(newSVhek(GvNAME_HEK(gv))));
43693395
GS		 2078}
2079
2080void
35a4481c 2081Perl_gv_efullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
43693395 2082{
099be4f1 2083 const GV * const egv = GvEGVx(gv);
7918f24d
NC		 2084
2085 PERL_ARGS_ASSERT_GV_EFULLNAME4;
2086
46c461b5 2087 gv_fullname4(sv, egv ? egv : gv, prefix, keepmain);
43693395
GS		 2088}
2089
79072805 2090void
1146e912 2091Perl_gv_check(pTHX_ const HV *stash)
79072805 2092{
97aff369 2093 dVAR;
eb578fdb 2094 I32 i;
463ee0b2 2095
7918f24d
NC		 2096 PERL_ARGS_ASSERT_GV_CHECK;
2097
8990e307
LW		 2098 if (!HvARRAY(stash))
2099 return;
a0d0e21e 2100 for (i = 0; i <= (I32) HvMAX(stash); i++) {
e1ec3a88 2101 const HE *entry;
dc437b57 2102 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
eb578fdb 2103 GV *gv;
b7787f18 2104 HV *hv;
dc437b57 2105 if (HeKEY(entry)[HeKLEN(entry)-1] == ':' &&
159b6efe 2106 (gv = MUTABLE_GV(HeVAL(entry))) && isGV(gv) && (hv = GvHV(gv)))
a0d0e21e 2107 {
19b6c847 2108 if (hv != PL_defstash && hv != stash)
a0d0e21e
LW		 2109 gv_check(hv); /* nested package */
2110 }
ecad31f0
BF		 2111 else if ( *HeKEY(entry) != '_'
2112 && isIDFIRST_lazy_if(HeKEY(entry), HeUTF8(entry)) ) {
e1ec3a88 2113 const char *file;
159b6efe 2114 gv = MUTABLE_GV(HeVAL(entry));
55d729e4 2115 if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv))
463ee0b2 2116 continue;
1d7c1841 2117 file = GvFILE(gv);
1d7c1841
GS		 2118 CopLINE_set(PL_curcop, GvLINE(gv));
2119#ifdef USE_ITHREADS
dd374669 2120 CopFILE(PL_curcop) = (char *)file; /* set for warning */
1d7c1841 2121#else
9bde8eb0
NC		 2122 CopFILEGV(PL_curcop)
2123 = gv_fetchfile_flags(file, HEK_LEN(GvFILE_HEK(gv)), 0);
1d7c1841 2124#endif
9014280d 2125 Perl_warner(aTHX_ packWARN(WARN_ONCE),
d0c0e7dd
FC		 2126 "Name \"%"HEKf"::%"HEKf
2127 "\" used only once: possible typo",
2128 HEKfARG(HvNAME_HEK(stash)),
2129 HEKfARG(GvNAME_HEK(gv)));
463ee0b2 2130 }
79072805
LW		 2131 }
2132 }
2133}
2134
2135GV *
9cc50d5b 2136Perl_newGVgen_flags(pTHX_ const char *pack, U32 flags)
79072805 2137{
97aff369 2138 dVAR;
9cc50d5b 2139 PERL_ARGS_ASSERT_NEWGVGEN_FLAGS;
7918f24d 2140
9cc50d5b
BF		 2141 return gv_fetchpv(Perl_form(aTHX_ "%"SVf"::_GEN_%ld",
2142 SVfARG(newSVpvn_flags(pack, strlen(pack),
2143 SVs_TEMP | flags)),
2144 (long)PL_gensym++),
2145 GV_ADD, SVt_PVGV);
79072805
LW		 2146}
2147
2148/* hopefully this is only called on local symbol table entries */
2149
2150GP*
864dbfa3 2151Perl_gp_ref(pTHX_ GP *gp)
79072805 2152{
97aff369 2153 dVAR;
1d7c1841 2154 if (!gp)
d4c19fe8 2155 return NULL;
79072805 2156 gp->gp_refcnt++;
44a8e56a 2157 if (gp->gp_cv) {
2158 if (gp->gp_cvgen) {
e1a479c5
BB		 2159 /* If the GP they asked for a reference to contains
2160 a method cache entry, clear it first, so that we
2161 don't infect them with our cached entry */
e7881358 2162 SvREFCNT_dec_NN(gp->gp_cv);
601f1833 2163 gp->gp_cv = NULL;
44a8e56a 2164 gp->gp_cvgen = 0;
2165 }
44a8e56a 2166 }
79072805 2167 return gp;
79072805
LW		 2168}
2169
2170void
864dbfa3 2171Perl_gp_free(pTHX_ GV *gv)
79072805 2172{
97aff369 2173 dVAR;
79072805 2174 GP* gp;
b0d55c99 2175 int attempts = 100;
79072805 2176
f7877b28 2177 if (!gv || !isGV_with_GP(gv) || !(gp = GvGP(gv)))
79072805 2178 return;
f248d071 2179 if (gp->gp_refcnt == 0) {
9b387841
NC		 2180 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
2181 "Attempt to free unreferenced glob pointers"
2182 pTHX__FORMAT pTHX__VALUE);
79072805
LW		 2183 return;
2184 }
748a9306
LW		 2185 if (--gp->gp_refcnt > 0) {
2186 if (gp->gp_egv == gv)
2187 gp->gp_egv = 0;
c43ae56f 2188 GvGP_set(gv, NULL);
79072805 2189 return;
748a9306 2190 }
79072805 2191
b0d55c99
FC		 2192 while (1) {
2193 /* Copy and null out all the glob slots, so destructors do not see
2194 freed SVs. */
2195 HEK * const file_hek = gp->gp_file_hek;
2196 SV * const sv = gp->gp_sv;
2197 AV * const av = gp->gp_av;
2198 HV * const hv = gp->gp_hv;
2199 IO * const io = gp->gp_io;
2200 CV * const cv = gp->gp_cv;
2201 CV * const form = gp->gp_form;
2202
2203 gp->gp_file_hek = NULL;
2204 gp->gp_sv = NULL;
2205 gp->gp_av = NULL;
2206 gp->gp_hv = NULL;
2207 gp->gp_io = NULL;
2208 gp->gp_cv = NULL;
2209 gp->gp_form = NULL;
2210
2211 if (file_hek)
2212 unshare_hek(file_hek);
2213
2214 SvREFCNT_dec(sv);
2215 SvREFCNT_dec(av);
2216 /* FIXME - another reference loop GV -> symtab -> GV ?
2217 Somehow gp->gp_hv can end up pointing at freed garbage. */
2218 if (hv && SvTYPE(hv) == SVt_PVHV) {
c2242065 2219 const HEK *hvname_hek = HvNAME_HEK(hv);
103f5a36 2220 DEBUG_o(Perl_deb(aTHX_ "gp_free clearing PL_stashcache for '%"HEKf"'\n", hvname_hek));
c2242065
BF		 2221 if (PL_stashcache && hvname_hek)
2222 (void)hv_delete(PL_stashcache, HEK_KEY(hvname_hek),
2223 (HEK_UTF8(hvname_hek) ? -HEK_LEN(hvname_hek) : HEK_LEN(hvname_hek)),
2224 G_DISCARD);
b0d55c99
FC		 2225 SvREFCNT_dec(hv);
2226 }
2227 SvREFCNT_dec(io);
2228 SvREFCNT_dec(cv);
2229 SvREFCNT_dec(form);
2230
2231 if (!gp->gp_file_hek
2232 && !gp->gp_sv
2233 && !gp->gp_av
2234 && !gp->gp_hv
2235 && !gp->gp_io
2236 && !gp->gp_cv
2237 && !gp->gp_form) break;
2238
2239 if (--attempts == 0) {
2240 Perl_die(aTHX_
2241 "panic: gp_free failed to free glob pointer - "
2242 "something is repeatedly re-creating entries"
2243 );
2244 }
13207a71 2245 }
748a9306 2246
79072805 2247 Safefree(gp);
c43ae56f 2248 GvGP_set(gv, NULL);
79072805
LW		 2249}
2250
d460ef45
NIS		 2251int
2252Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg)
2253{
53c1dcc0
AL		 2254 AMT * const amtp = (AMT*)mg->mg_ptr;
2255 PERL_UNUSED_ARG(sv);
dd374669 2256
7918f24d
NC		 2257 PERL_ARGS_ASSERT_MAGIC_FREEOVRLD;
2258
d460ef45
NIS		 2259 if (amtp && AMT_AMAGIC(amtp)) {
2260 int i;
2261 for (i = 1; i < NofAMmeth; i++) {
53c1dcc0 2262 CV * const cv = amtp->table[i];
b37c2d43 2263 if (cv) {
e7881358 2264 SvREFCNT_dec_NN(MUTABLE_SV(cv));
601f1833 2265 amtp->table[i] = NULL;
d460ef45
NIS		 2266 }
2267 }
2268 }
2269 return 0;
2270}
2271
a0d0e21e 2272/* Updates and caches the CV's */
c3a9a790
RGS		 2273/* Returns:
2274 * 1 on success and there is some overload
2275 * 0 if there is no overload
2276 * -1 if some error occurred and it couldn't croak
2277 */
a0d0e21e 2278
c3a9a790 2279int
242f8760 2280Perl_Gv_AMupdate(pTHX_ HV *stash, bool destructing)
a0d0e21e 2281{
97aff369 2282 dVAR;
ad64d0ec 2283 MAGIC* const mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
a6006777 2284 AMT amt;
9b439311 2285 const struct mro_meta* stash_meta = HvMROMETA(stash);
e1a479c5 2286 U32 newgen;
a0d0e21e 2287
7918f24d
NC		 2288 PERL_ARGS_ASSERT_GV_AMUPDATE;
2289
9b439311 2290 newgen = PL_sub_generation + stash_meta->pkg_gen + stash_meta->cache_gen;
14899595
NC		 2291 if (mg) {
2292 const AMT * const amtp = (AMT*)mg->mg_ptr;
66978156 2293 if (amtp->was_ok_sub == newgen) {
8c34e50d 2294 return AMT_AMAGIC(amtp) ? 1 : 0;
14899595 2295 }
ad64d0ec 2296 sv_unmagic(MUTABLE_SV(stash), PERL_MAGIC_overload_table);
14899595 2297 }
a0d0e21e 2298
bfcb3514 2299 DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME_get(stash)) );
a0d0e21e 2300
d460ef45 2301 Zero(&amt,1,AMT);
e1a479c5 2302 amt.was_ok_sub = newgen;
a6006777 2303 amt.fallback = AMGfallNO;
2304 amt.flags = 0;
2305
a6006777 2306 {
8c34e50d
FC		 2307 int filled = 0;
2308 int i;
a6006777 2309
3866ea3b 2310 /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
a6006777 2311
89ffc314 2312 /* Try to find via inheritance. */
e6919483 2313 GV *gv = gv_fetchmeth_pvn(stash, PL_AMG_names[0], 2, -1, 0);
3866ea3b 2314 SV * const sv = gv ? GvSV(gv) : NULL;
53c1dcc0 2315 CV* cv;
89ffc314
IZ		 2316
2317 if (!gv)
3866ea3b
FC		 2318 {
2319 if (!gv_fetchmeth_pvn(stash, "((", 2, -1, 0))
8c34e50d 2320 goto no_table;
3866ea3b
FC		 2321 }
2322#ifdef PERL_DONT_CREATE_GVSV
2323 else if (!sv) {
6f207bd3 2324 NOOP; /* Equivalent to !SvTRUE and !SvOK */
3866ea3b
FC		 2325 }
2326#endif
79c9643d
JL		 2327 else if (SvTRUE(sv))
2328 /* don't need to set overloading here because fallback => 1
2329 * is the default setting for classes without overloading */
89ffc314 2330 amt.fallback=AMGfallYES;
79c9643d
JL		 2331 else if (SvOK(sv)) {
2332 amt.fallback=AMGfallNEVER;
386a5489 2333 filled = 1;
386a5489 2334 }
79c9643d 2335 else {
386a5489 2336 filled = 1;
386a5489 2337 }
a6006777 2338
8c34e50d 2339 for (i = 1; i < NofAMmeth; i++) {
6136c704 2340 const char * const cooky = PL_AMG_names[i];
32251b26 2341 /* Human-readable form, for debugging: */
8c34e50d 2342 const char * const cp = AMG_id2name(i);
d279ab82 2343 const STRLEN l = PL_AMG_namelens[i];
89ffc314 2344
a0288114 2345 DEBUG_o( Perl_deb(aTHX_ "Checking overloading of \"%s\" in package \"%.256s\"\n",
bfcb3514 2346 cp, HvNAME_get(stash)) );
611c1e95
IZ		 2347 /* don't fill the cache while looking up!
2348 Creation of inheritance stubs in intermediate packages may
2349 conflict with the logic of runtime method substitution.
2350 Indeed, for inheritance A -> B -> C, if C overloads "+0",
2351 then we could have created stubs for "(+0" in A and C too.
2352 But if B overloads "bool", we may want to use it for
2353 numifying instead of C's "+0". */
8c34e50d 2354 gv = Perl_gv_fetchmeth_pvn(aTHX_ stash, cooky, l, -1, 0);
46fc3d4c 2355 cv = 0;
89ffc314 2356 if (gv && (cv = GvCV(gv))) {
f0e9f182
FC		 2357 if(GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")){
2358 const char * const hvname = HvNAME_get(GvSTASH(CvGV(cv)));
2359 if (hvname && HEK_LEN(HvNAME_HEK(GvSTASH(CvGV(cv)))) == 8
2360 && strEQ(hvname, "overload")) {
611c1e95
IZ		 2361 /* This is a hack to support autoloading..., while
2362 knowing *which* methods were declared as overloaded. */
44a8e56a 2363 /* GvSV contains the name of the method. */
6136c704 2364 GV *ngv = NULL;
c69033f2 2365 SV *gvsv = GvSV(gv);
a0288114
AL		 2366
2367 DEBUG_o( Perl_deb(aTHX_ "Resolving method \"%"SVf256\
2368 "\" for overloaded \"%s\" in package \"%.256s\"\n",
f0e9f182 2369 (void*)GvSV(gv), cp, HvNAME(stash)) );
c69033f2 2370 if (!gvsv || !SvPOK(gvsv)
7f415459 2371 || !(ngv = gv_fetchmethod_sv_flags(stash, gvsv, 0)))
dc848c6f 2372 {
a0288114 2373 /* Can be an import stub (created by "can"). */
242f8760 2374 if (destructing) {
c3a9a790 2375 return -1;
242f8760
RGS		 2376 }
2377 else {
d66cca07
BF		 2378 const SV * const name = (gvsv && SvPOK(gvsv))
2379 ? gvsv
2380 : newSVpvs_flags("???", SVs_TEMP);
dcbac5bb 2381 /* diag_listed_as: Can't resolve method "%s" overloading "%s" in package "%s" */
d66cca07
BF		 2382 Perl_croak(aTHX_ "%s method \"%"SVf256
2383 "\" overloading \"%s\" "\
d0c0e7dd 2384 "in package \"%"HEKf256"\"",
242f8760
RGS		 2385 (GvCVGEN(gv) ? "Stub found while resolving"
2386 : "Can't resolve"),
d66cca07 2387 SVfARG(name), cp,
d0c0e7dd 2388 HEKfARG(
d66cca07 2389 HvNAME_HEK(stash)
d0c0e7dd 2390 ));
242f8760 2391 }
44a8e56a 2392 }
dc848c6f 2393 cv = GvCV(gv = ngv);
f0e9f182 2394 }
44a8e56a 2395 }
b464bac0 2396 DEBUG_o( Perl_deb(aTHX_ "Overloading \"%s\" in package \"%.256s\" via \"%.256s::%.256s\"\n",
bfcb3514 2397 cp, HvNAME_get(stash), HvNAME_get(GvSTASH(CvGV(cv))),
44a8e56a 2398 GvNAME(CvGV(cv))) );
2399 filled = 1;
611c1e95 2400 } else if (gv) { /* Autoloaded... */
ea726b52 2401 cv = MUTABLE_CV(gv);
611c1e95 2402 filled = 1;
44a8e56a 2403 }
ea726b52 2404 amt.table[i]=MUTABLE_CV(SvREFCNT_inc_simple(cv));
a0d0e21e 2405 }
a0d0e21e 2406 if (filled) {
a6006777 2407 AMT_AMAGIC_on(&amt);
ad64d0ec 2408 sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table,
14befaf4 2409 (char*)&amt, sizeof(AMT));
8c34e50d 2410 return TRUE;
a0d0e21e
LW		 2411 }
2412 }
a6006777 2413 /* Here we have no table: */
8c34e50d 2414 no_table:
a6006777 2415 AMT_AMAGIC_off(&amt);
ad64d0ec 2416 sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table,
14befaf4 2417 (char*)&amt, sizeof(AMTS));
c3a9a790 2418 return 0;
a0d0e21e
LW		 2419}
2420
32251b26
IZ		 2421
2422CV*
2423Perl_gv_handler(pTHX_ HV *stash, I32 id)
2424{
97aff369 2425 dVAR;
3f8f4626 2426 MAGIC *mg;
32251b26 2427 AMT *amtp;
e1a479c5 2428 U32 newgen;
9b439311 2429 struct mro_meta* stash_meta;
32251b26 2430
bfcb3514 2431 if (!stash || !HvNAME_get(stash))
601f1833 2432 return NULL;
e1a479c5 2433
9b439311
BB		 2434 stash_meta = HvMROMETA(stash);
2435 newgen = PL_sub_generation + stash_meta->pkg_gen + stash_meta->cache_gen;
e1a479c5 2436
ad64d0ec 2437 mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
32251b26
IZ		 2438 if (!mg) {
2439 do_update:
8c34e50d 2440 if (Gv_AMupdate(stash, 0) == -1)
242f8760 2441 return NULL;
ad64d0ec 2442 mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
32251b26 2443 }
a9fd4e40 2444 assert(mg);
32251b26 2445 amtp = (AMT*)mg->mg_ptr;
66978156 2446 if ( amtp->was_ok_sub != newgen )
32251b26 2447 goto do_update;
3ad83ce7 2448 if (AMT_AMAGIC(amtp)) {
b7787f18 2449 CV * const ret = amtp->table[id];
3ad83ce7
AMS		 2450 if (ret && isGV(ret)) { /* Autoloading stab */
2451 /* Passing it through may have resulted in a warning
2452 "Inherited AUTOLOAD for a non-method deprecated", since
2453 our caller is going through a function call, not a method call.
2454 So return the CV for AUTOLOAD, setting $AUTOLOAD. */
890ce7af 2455 GV * const gv = gv_fetchmethod(stash, PL_AMG_names[id]);
3ad83ce7
AMS		 2456
2457 if (gv && GvCV(gv))
2458 return GvCV(gv);
2459 }
2460 return ret;
2461 }
a0288114 2462
601f1833 2463 return NULL;
32251b26
IZ		 2464}
2465
2466
6f1401dc
DM		 2467/* Implement tryAMAGICun_MG macro.
2468 Do get magic, then see if the stack arg is overloaded and if so call it.
2469 Flags:
2470 AMGf_set return the arg using SETs rather than assigning to
2471 the targ
2472 AMGf_numeric apply sv_2num to the stack arg.
2473*/
2474
2475bool
2476Perl_try_amagic_un(pTHX_ int method, int flags) {
2477 dVAR;
2478 dSP;
2479 SV* tmpsv;
2480 SV* const arg = TOPs;
2481
2482 SvGETMAGIC(arg);
2483
9f8bf298
NC		 2484 if (SvAMAGIC(arg) && (tmpsv = amagic_call(arg, &PL_sv_undef, method,
2485 AMGf_noright | AMGf_unary))) {
6f1401dc
DM		 2486 if (flags & AMGf_set) {
2487 SETs(tmpsv);
2488 }
2489 else {
2490 dTARGET;
2491 if (SvPADMY(TARG)) {
2492 sv_setsv(TARG, tmpsv);
2493 SETTARG;
2494 }
2495 else
2496 SETs(tmpsv);
2497 }
2498 PUTBACK;
2499 return TRUE;
2500 }
2501
2502 if ((flags & AMGf_numeric) && SvROK(arg))
2503 *sp = sv_2num(arg);
2504 return FALSE;
2505}
2506
2507
2508/* Implement tryAMAGICbin_MG macro.
2509 Do get magic, then see if the two stack args are overloaded and if so
2510 call it.
2511 Flags:
2512 AMGf_set return the arg using SETs rather than assigning to
2513 the targ
2514 AMGf_assign op may be called as mutator (eg +=)
2515 AMGf_numeric apply sv_2num to the stack arg.
2516*/
2517
2518bool
2519Perl_try_amagic_bin(pTHX_ int method, int flags) {
2520 dVAR;
2521 dSP;
2522 SV* const left = TOPm1s;
2523 SV* const right = TOPs;
2524
2525 SvGETMAGIC(left);
2526 if (left != right)
2527 SvGETMAGIC(right);
2528
2529 if (SvAMAGIC(left) || SvAMAGIC(right)) {
2530 SV * const tmpsv = amagic_call(left, right, method,
2531 ((flags & AMGf_assign) && opASSIGN ? AMGf_assign: 0));
2532 if (tmpsv) {
2533 if (flags & AMGf_set) {
2534 (void)POPs;
2535 SETs(tmpsv);
2536 }
2537 else {
2538 dATARGET;
2539 (void)POPs;
2540 if (opASSIGN || SvPADMY(TARG)) {
2541 sv_setsv(TARG, tmpsv);
2542 SETTARG;
2543 }
2544 else
2545 SETs(tmpsv);
2546 }
2547 PUTBACK;
2548 return TRUE;
2549 }
2550 }
75ea7a12
FC		 2551 if(left==right && SvGMAGICAL(left)) {
2552 SV * const left = sv_newmortal();
2553 *(sp-1) = left;
2554 /* Print the uninitialized warning now, so it includes the vari-
2555 able name. */
2556 if (!SvOK(right)) {
2557 if (ckWARN(WARN_UNINITIALIZED)) report_uninit(right);
2558 sv_setsv_flags(left, &PL_sv_no, 0);
2559 }
2560 else sv_setsv_flags(left, right, 0);
2561 SvGETMAGIC(right);
2562 }
6f1401dc 2563 if (flags & AMGf_numeric) {
75ea7a12
FC		 2564 if (SvROK(TOPm1s))
2565 *(sp-1) = sv_2num(TOPm1s);
6f1401dc
DM		 2566 if (SvROK(right))
2567 *sp = sv_2num(right);
2568 }
2569 return FALSE;
2570}
2571
25a9ffce
NC		 2572SV *
2573Perl_amagic_deref_call(pTHX_ SV *ref, int method) {
2574 SV *tmpsv = NULL;
2575
2576 PERL_ARGS_ASSERT_AMAGIC_DEREF_CALL;
2577
2578 while (SvAMAGIC(ref) &&
2579 (tmpsv = amagic_call(ref, &PL_sv_undef, method,
2580 AMGf_noright | AMGf_unary))) {
2581 if (!SvROK(tmpsv))
2582 Perl_croak(aTHX_ "Overloaded dereference did not return a reference");
2583 if (tmpsv == ref || SvRV(tmpsv) == SvRV(ref)) {
2584 /* Bail out if it returns us the same reference. */
2585 return tmpsv;
2586 }
2587 ref = tmpsv;
2588 }
2589 return tmpsv ? tmpsv : ref;
2590}
6f1401dc 2591
8d569291
FC		 2592bool
2593Perl_amagic_is_enabled(pTHX_ int method)
2594{
2595 SV *lex_mask = cop_hints_fetch_pvs(PL_curcop, "overloading", 0);
2596
2597 assert(PL_curcop->cop_hints & HINT_NO_AMAGIC);
2598
2599 if ( !lex_mask || !SvOK(lex_mask) )
2600 /* overloading lexically disabled */
2601 return FALSE;
2602 else if ( lex_mask && SvPOK(lex_mask) ) {
2603 /* we have an entry in the hints hash, check if method has been
2604 * masked by overloading.pm */
2605 STRLEN len;
2606 const int offset = method / 8;
2607 const int bit = method % 8;
2608 char *pv = SvPV(lex_mask, len);
2609
2610 /* Bit set, so this overloading operator is disabled */
2611 if ( (STRLEN)offset < len && pv[offset] & ( 1 << bit ) )
2612 return FALSE;
2613 }
2614 return TRUE;
2615}
2616
a0d0e21e 2617SV*
864dbfa3 2618Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
a0d0e21e 2619{
27da23d5 2620 dVAR;
b267980d 2621 MAGIC *mg;
9c5ffd7c 2622 CV *cv=NULL;
a0d0e21e 2623 CV **cvp=NULL, **ocvp=NULL;
9c5ffd7c 2624 AMT *amtp=NULL, *oamtp=NULL;
b464bac0
AL		 2625 int off = 0, off1, lr = 0, notfound = 0;
2626 int postpr = 0, force_cpy = 0;
2627 int assign = AMGf_assign & flags;
2628 const int assignshift = assign ? 1 : 0;
bf5522a1 2629 int use_default_op = 0;
67288365 2630 int force_scalar = 0;
497b47a8
JH		 2631#ifdef DEBUGGING
2632 int fl=0;
497b47a8 2633#endif
25716404 2634 HV* stash=NULL;
7918f24d
NC		 2635
2636 PERL_ARGS_ASSERT_AMAGIC_CALL;
2637
e46c382e 2638 if ( PL_curcop->cop_hints & HINT_NO_AMAGIC ) {
8d569291 2639 if (!amagic_is_enabled(method)) return NULL;
e46c382e
YK		 2640 }
2641
a0d0e21e 2642 if (!(AMGf_noleft & flags) && SvAMAGIC(left)
0a2c84ab 2643 && (stash = SvSTASH(SvRV(left))) && Gv_AMG(stash)
ad64d0ec 2644 && (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table))
b267980d 2645 && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
a6006777 2646 ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
d4c19fe8 2647 : NULL))
b267980d 2648 && ((cv = cvp[off=method+assignshift])
748a9306
LW		 2649 || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
2650 * usual method */
497b47a8
JH		 2651 (
2652#ifdef DEBUGGING
2653 fl = 1,
a0288114 2654#endif
497b47a8 2655 cv = cvp[off=method])))) {
a0d0e21e
LW		 2656 lr = -1; /* Call method for left argument */
2657 } else {
2658 if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) {
2659 int logic;
2660
2661 /* look for substituted methods */
ee239bfe 2662 /* In all the covered cases we should be called with assign==0. */
a0d0e21e
LW		 2663 switch (method) {
2664 case inc_amg:
ee239bfe
IZ		 2665 force_cpy = 1;
2666 if ((cv = cvp[off=add_ass_amg])
2667 || ((cv = cvp[off = add_amg]) && (force_cpy = 0, postpr = 1))) {
3280af22 2668 right = &PL_sv_yes; lr = -1; assign = 1;
a0d0e21e
LW		 2669 }
2670 break;
2671 case dec_amg:
ee239bfe
IZ		 2672 force_cpy = 1;
2673 if ((cv = cvp[off = subtr_ass_amg])
2674 || ((cv = cvp[off = subtr_amg]) && (force_cpy = 0, postpr=1))) {
3280af22 2675 right = &PL_sv_yes; lr = -1; assign = 1;
a0d0e21e
LW		 2676 }
2677 break;
2678 case bool__amg:
2679 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg]));
2680 break;
2681 case numer_amg:
2682 (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg]));
2683 break;
2684 case string_amg:
2685 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg]));
2686 break;
b7787f18
AL		 2687 case not_amg:
2688 (void)((cv = cvp[off=bool__amg])
2689 || (cv = cvp[off=numer_amg])
2690 || (cv = cvp[off=string_amg]));
2ab54efd
MB		 2691 if (cv)
2692 postpr = 1;
b7787f18 2693 break;
748a9306
LW		 2694 case copy_amg:
2695 {
76e3520e
GS		 2696 /*
2697 * SV* ref causes confusion with the interpreter variable of
2698 * the same name
2699 */
890ce7af 2700 SV* const tmpRef=SvRV(left);
76e3520e 2701 if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) {
fc36a67e 2702 /*
2703 * Just to be extra cautious. Maybe in some
2704 * additional cases sv_setsv is safe, too.
2705 */
890ce7af 2706 SV* const newref = newSVsv(tmpRef);
748a9306 2707 SvOBJECT_on(newref);
a1cd65be
FC		 2708 /* No need to do SvAMAGIC_on here, as SvAMAGIC macros
2709 delegate to the stash. */
85fbaab2 2710 SvSTASH_set(newref, MUTABLE_HV(SvREFCNT_inc(SvSTASH(tmpRef))));
748a9306
LW		 2711 return newref;
2712 }
2713 }
2714 break;
a0d0e21e 2715 case abs_amg:
b267980d 2716 if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg])
a0d0e21e 2717 && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) {
890ce7af 2718 SV* const nullsv=sv_2mortal(newSViv(0));
a0d0e21e 2719 if (off1==lt_amg) {
890ce7af 2720 SV* const lessp = amagic_call(left,nullsv,
a0d0e21e
LW		 2721 lt_amg,AMGf_noright);
2722 logic = SvTRUE(lessp);
2723 } else {
890ce7af 2724 SV* const lessp = amagic_call(left,nullsv,
a0d0e21e
LW		 2725 ncmp_amg,AMGf_noright);
2726 logic = (SvNV(lessp) < 0);
2727 }
2728 if (logic) {
2729 if (off==subtr_amg) {
2730 right = left;
748a9306 2731 left = nullsv;
a0d0e21e
LW		 2732 lr = 1;
2733 }
2734 } else {
2735 return left;
2736 }
2737 }
2738 break;
2739 case neg_amg:
155aba94 2740 if ((cv = cvp[off=subtr_amg])) {
a0d0e21e
LW		 2741 right = left;
2742 left = sv_2mortal(newSViv(0));
2743 lr = 1;
2744 }
2745 break;
f216259d 2746 case int_amg:
f5284f61 2747 case iter_amg: /* XXXX Eventually should do to_gv. */
c4c7412c 2748 case ftest_amg: /* XXXX Eventually should do to_gv. */
d4b87e75 2749 case regexp_amg:
b267980d
NIS		 2750 /* FAIL safe */
2751 return NULL; /* Delegate operation to standard mechanisms. */
2752 break;
f5284f61
IZ		 2753 case to_sv_amg:
2754 case to_av_amg:
2755 case to_hv_amg:
2756 case to_gv_amg:
2757 case to_cv_amg:
2758 /* FAIL safe */
b267980d 2759 return left; /* Delegate operation to standard mechanisms. */
f5284f61 2760 break;
a0d0e21e
LW		 2761 default:
2762 goto not_found;
2763 }
2764 if (!cv) goto not_found;
2765 } else if (!(AMGf_noright & flags) && SvAMAGIC(right)
0a2c84ab 2766 && (stash = SvSTASH(SvRV(right))) && Gv_AMG(stash)
ad64d0ec 2767 && (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table))
b267980d 2768 && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
a6006777 2769 ? (amtp = (AMT*)mg->mg_ptr)->table
d4c19fe8 2770 : NULL))
69815d08
RS		 2771 && (cv = cvp[off=method])) { /* Method for right
2772 * argument found */
2773 lr=1;
bf5522a1
MB		 2774 } else if (((cvp && amtp->fallback > AMGfallNEVER)
2775 || (ocvp && oamtp->fallback > AMGfallNEVER))
a0d0e21e
LW		 2776 && !(flags & AMGf_unary)) {
2777 /* We look for substitution for
2778 * comparison operations and
fc36a67e 2779 * concatenation */
a0d0e21e
LW		 2780 if (method==concat_amg || method==concat_ass_amg
2781 || method==repeat_amg || method==repeat_ass_amg) {
2782 return NULL; /* Delegate operation to string conversion */
2783 }
2784 off = -1;
2785 switch (method) {
2786 case lt_amg:
2787 case le_amg:
2788 case gt_amg:
2789 case ge_amg:
2790 case eq_amg:
2791 case ne_amg:
2ab54efd
MB		 2792 off = ncmp_amg;
2793 break;
a0d0e21e
LW		 2794 case slt_amg:
2795 case sle_amg:
2796 case sgt_amg:
2797 case sge_amg:
2798 case seq_amg:
2799 case sne_amg:
2ab54efd
MB		 2800 off = scmp_amg;
2801 break;
a0d0e21e 2802 }
bf5522a1
MB		 2803 if (off != -1) {
2804 if (ocvp && (oamtp->fallback > AMGfallNEVER)) {
2805 cv = ocvp[off];
2806 lr = -1;
2807 }
2808 if (!cv && (cvp && amtp->fallback > AMGfallNEVER)) {
2809 cv = cvp[off];
2810 lr = 1;
2811 }
2812 }
2813 if (cv)
2ab54efd
MB		 2814 postpr = 1;
2815 else
2816 goto not_found;
a0d0e21e 2817 } else {
a6006777 2818 not_found: /* No method found, either report or croak */
b267980d
NIS		 2819 switch (method) {
2820 case to_sv_amg:
2821 case to_av_amg:
2822 case to_hv_amg:
2823 case to_gv_amg:
2824 case to_cv_amg:
2825 /* FAIL safe */
2826 return left; /* Delegate operation to standard mechanisms. */
2827 break;
2828 }
a0d0e21e
LW		 2829 if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */
2830 notfound = 1; lr = -1;
2831 } else if (cvp && (cv=cvp[nomethod_amg])) {
2832 notfound = 1; lr = 1;
bf5522a1
MB		 2833 } else if ((use_default_op =
2834 (!ocvp || oamtp->fallback >= AMGfallYES)
2835 && (!cvp || amtp->fallback >= AMGfallYES))
2836 && !DEBUG_o_TEST) {
4cc0ca18
NC		 2837 /* Skip generating the "no method found" message. */
2838 return NULL;
a0d0e21e 2839 } else {
46fc3d4c 2840 SV *msg;
774d564b 2841 if (off==-1) off=method;
b267980d 2842 msg = sv_2mortal(Perl_newSVpvf(aTHX_
d66cca07
BF		 2843 "Operation \"%s\": no method found,%sargument %s%"SVf"%s%"SVf,
2844 AMG_id2name(method + assignshift),
2845 (flags & AMGf_unary ? " " : "\n\tleft "),
2846 SvAMAGIC(left)?
2847 "in overloaded package ":
2848 "has no overloaded magic",
2849 SvAMAGIC(left)?
2850 SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(SvSTASH(SvRV(left)))))):
2851 SVfARG(&PL_sv_no),
2852 SvAMAGIC(right)?
2853 ",\n\tright argument in overloaded package ":
2854 (flags & AMGf_unary
2855 ? ""
2856 : ",\n\tright argument has no overloaded magic"),
2857 SvAMAGIC(right)?
2858 SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(SvSTASH(SvRV(right)))))):
2859 SVfARG(&PL_sv_no)));
bf5522a1 2860 if (use_default_op) {
d66cca07 2861 DEBUG_o( Perl_deb(aTHX_ "%"SVf, SVfARG(msg)) );
a0d0e21e 2862 } else {
be2597df 2863 Perl_croak(aTHX_ "%"SVf, SVfARG(msg));
a0d0e21e
LW		 2864 }
2865 return NULL;
2866 }
ee239bfe 2867 force_cpy = force_cpy || assign;
a0d0e21e
LW		 2868 }
2869 }
67288365
JL		 2870
2871 switch (method) {
2872 /* in these cases, we're calling '+' or '-' as a fallback for a ++ or --
2873 * operation. we need this to return a value, so that it can be assigned
2874 * later on, in the postpr block (case inc_amg/dec_amg), even if the
2875 * increment or decrement was itself called in void context */
2876 case inc_amg:
2877 if (off == add_amg)
2878 force_scalar = 1;
2879 break;
2880 case dec_amg:
2881 if (off == subtr_amg)
2882 force_scalar = 1;
2883 break;
2884 /* in these cases, we're calling an assignment variant of an operator
2885 * (+= rather than +, for instance). regardless of whether it's a
2886 * fallback or not, it always has to return a value, which will be
2887 * assigned to the proper variable later */
2888 case add_amg:
2889 case subtr_amg:
2890 case mult_amg:
2891 case div_amg:
2892 case modulo_amg:
2893 case pow_amg:
2894 case lshift_amg:
2895 case rshift_amg:
2896 case repeat_amg:
2897 case concat_amg:
2898 case band_amg:
2899 case bor_amg:
2900 case bxor_amg:
2901 if (assign)
2902 force_scalar = 1;
2903 break;
2904 /* the copy constructor always needs to return a value */
2905 case copy_amg:
2906 force_scalar = 1;
2907 break;
2908 /* because of the way these are implemented (they don't perform the
2909 * dereferencing themselves, they return a reference that perl then
2910 * dereferences later), they always have to be in scalar context */
2911 case to_sv_amg:
2912 case to_av_amg:
2913 case to_hv_amg:
2914 case to_gv_amg:
2915 case to_cv_amg:
2916 force_scalar = 1;
2917 break;
2918 /* these don't have an op of their own; they're triggered by their parent
2919 * op, so the context there isn't meaningful ('$a and foo()' in void
2920 * context still needs to pass scalar context on to $a's bool overload) */
2921 case bool__amg:
2922 case numer_amg:
2923 case string_amg:
2924 force_scalar = 1;
2925 break;
2926 }
2927
497b47a8 2928#ifdef DEBUGGING
a0d0e21e 2929 if (!notfound) {
497b47a8 2930 DEBUG_o(Perl_deb(aTHX_
d66cca07 2931 "Overloaded operator \"%s\"%s%s%s:\n\tmethod%s found%s in package %"SVf"%s\n",
497b47a8
JH		 2932 AMG_id2name(off),
2933 method+assignshift==off? "" :
a0288114 2934 " (initially \"",
497b47a8
JH		 2935 method+assignshift==off? "" :
2936 AMG_id2name(method+assignshift),
a0288114 2937 method+assignshift==off? "" : "\")",
497b47a8
JH		 2938 flags & AMGf_unary? "" :
2939 lr==1 ? " for right argument": " for left argument",
2940 flags & AMGf_unary? " for argument" : "",
d66cca07 2941 stash ? SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(stash)))) : SVfARG(newSVpvs_flags("null", SVs_TEMP)),
497b47a8 2942 fl? ",\n\tassignment variant used": "") );
ee239bfe 2943 }
497b47a8 2944#endif
748a9306
LW		 2945 /* Since we use shallow copy during assignment, we need
2946 * to dublicate the contents, probably calling user-supplied
2947 * version of copy operator
2948 */
ee239bfe
IZ		 2949 /* We need to copy in following cases:
2950 * a) Assignment form was called.
2951 * assignshift==1, assign==T, method + 1 == off
2952 * b) Increment or decrement, called directly.
2953 * assignshift==0, assign==0, method + 0 == off
2954 * c) Increment or decrement, translated to assignment add/subtr.
b267980d 2955 * assignshift==0, assign==T,
ee239bfe
IZ		 2956 * force_cpy == T
2957 * d) Increment or decrement, translated to nomethod.
b267980d 2958 * assignshift==0, assign==0,
ee239bfe
IZ		 2959 * force_cpy == T
2960 * e) Assignment form translated to nomethod.
2961 * assignshift==1, assign==T, method + 1 != off
2962 * force_cpy == T
2963 */
2964 /* off is method, method+assignshift, or a result of opcode substitution.
2965 * In the latter case assignshift==0, so only notfound case is important.
2966 */
73512201 2967 if ( (lr == -1) && ( ( (method + assignshift == off)
ee239bfe 2968 && (assign || (method == inc_amg) || (method == dec_amg)))
73512201 2969 || force_cpy) )
6f1401dc 2970 {
1b38c28e
NC		 2971 /* newSVsv does not behave as advertised, so we copy missing
2972 * information by hand */
2973 SV *tmpRef = SvRV(left);
2974 SV *rv_copy;
31d632c3 2975 if (SvREFCNT(tmpRef) > 1 && (rv_copy = AMG_CALLunary(left,copy_amg))) {
1b38c28e
NC		 2976 SvRV_set(left, rv_copy);
2977 SvSETMAGIC(left);
e7881358 2978 SvREFCNT_dec_NN(tmpRef);
1b38c28e 2979 }
6f1401dc
DM		 2980 }
2981
a0d0e21e
LW		 2982 {
2983 dSP;
2984 BINOP myop;
2985 SV* res;
b7787f18 2986 const bool oldcatch = CATCH_GET;
67288365
JL		 2987 I32 oldmark, nret;
2988 int gimme = force_scalar ? G_SCALAR : GIMME_V;
a0d0e21e 2989
54310121 2990 CATCH_SET(TRUE);
a0d0e21e
LW		 2991 Zero(&myop, 1, BINOP);
2992 myop.op_last = (OP *) &myop;
b37c2d43 2993 myop.op_next = NULL;
67288365
JL		 2994 myop.op_flags = OPf_STACKED;
2995
2996 switch (gimme) {
2997 case G_VOID:
2998 myop.op_flags |= OPf_WANT_VOID;
2999 break;
3000 case G_ARRAY:
3001 if (flags & AMGf_want_list) {
3002 myop.op_flags |= OPf_WANT_LIST;
3003 break;
3004 }
3005 /* FALLTHROUGH */
3006 default:
3007 myop.op_flags |= OPf_WANT_SCALAR;
3008 break;
3009 }
a0d0e21e 3010
e788e7d3 3011 PUSHSTACKi(PERLSI_OVERLOAD);
a0d0e21e 3012 ENTER;
462e5cf6 3013 SAVEOP();
533c011a 3014 PL_op = (OP *) &myop;
3280af22 3015 if (PERLDB_SUB && PL_curstash != PL_debstash)
533c011a 3016 PL_op->op_private |= OPpENTERSUB_DB;
a0d0e21e 3017 PUTBACK;
897d3989 3018 Perl_pp_pushmark(aTHX);
a0d0e21e 3019
924508f0 3020 EXTEND(SP, notfound + 5);
a0d0e21e
LW		 3021 PUSHs(lr>0? right: left);
3022 PUSHs(lr>0? left: right);
3280af22 3023 PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no ));
a0d0e21e 3024 if (notfound) {
59cd0e26
NC		 3025 PUSHs(newSVpvn_flags(AMG_id2name(method + assignshift),
3026 AMG_id2namelen(method + assignshift), SVs_TEMP));
a0d0e21e 3027 }
ad64d0ec 3028 PUSHs(MUTABLE_SV(cv));
a0d0e21e 3029 PUTBACK;
67288365 3030 oldmark = TOPMARK;
a0d0e21e 3031
139d0ce6 3032 if ((PL_op = PL_ppaddr[OP_ENTERSUB](aTHX)))
cea2e8a9 3033 CALLRUNOPS(aTHX);
a0d0e21e
LW		 3034 LEAVE;
3035 SPAGAIN;
67288365
JL		 3036 nret = SP - (PL_stack_base + oldmark);
3037
3038 switch (gimme) {
3039 case G_VOID:
3040 /* returning NULL has another meaning, and we check the context
3041 * at the call site too, so this can be differentiated from the
3042 * scalar case */
3043 res = &PL_sv_undef;
3044 SP = PL_stack_base + oldmark;
3045 break;
3046 case G_ARRAY: {
3047 if (flags & AMGf_want_list) {
3048 res = sv_2mortal((SV *)newAV());
3049 av_extend((AV *)res, nret);
3050 while (nret--)
3051 av_store((AV *)res, nret, POPs);
3052 break;
3053 }
3054 /* FALLTHROUGH */
3055 }
3056 default:
3057 res = POPs;
3058 break;
3059 }
a0d0e21e 3060
ebafeae7 3061 PUTBACK;
d3acc0f7 3062 POPSTACK;
54310121 3063 CATCH_SET(oldcatch);
a0d0e21e 3064
a0d0e21e 3065 if (postpr) {
b7787f18 3066 int ans;
a0d0e21e
LW		 3067 switch (method) {
3068 case le_amg:
3069 case sle_amg:
3070 ans=SvIV(res)<=0; break;
3071 case lt_amg:
3072 case slt_amg:
3073 ans=SvIV(res)<0; break;
3074 case ge_amg:
3075 case sge_amg:
3076 ans=SvIV(res)>=0; break;
3077 case gt_amg:
3078 case sgt_amg:
3079 ans=SvIV(res)>0; break;
3080 case eq_amg:
3081 case seq_amg:
3082 ans=SvIV(res)==0; break;
3083 case ne_amg:
3084 case sne_amg:
3085 ans=SvIV(res)!=0; break;
3086 case inc_amg:
3087 case dec_amg:
bbce6d69 3088 SvSetSV(left,res); return left;
dc437b57 3089 case not_amg:
fe7ac86a 3090 ans=!SvTRUE(res); break;
b7787f18
AL		 3091 default:
3092 ans=0; break;
a0d0e21e 3093 }
54310121 3094 return boolSV(ans);
748a9306
LW		 3095 } else if (method==copy_amg) {
3096 if (!SvROK(res)) {
cea2e8a9 3097 Perl_croak(aTHX_ "Copy method did not return a reference");
748a9306
LW		 3098 }
3099 return SvREFCNT_inc(SvRV(res));
a0d0e21e
LW		 3100 } else {
3101 return res;
3102 }
3103 }
3104}
c9d5ac95 3105
f5c1e807
NC		 3106void
3107Perl_gv_name_set(pTHX_ GV *gv, const char *name, U32 len, U32 flags)
3108{
3109 dVAR;
acda4c6a 3110 U32 hash;
f5c1e807 3111
7918f24d 3112 PERL_ARGS_ASSERT_GV_NAME_SET;
f5c1e807 3113
acda4c6a
NC		 3114 if (len > I32_MAX)
3115 Perl_croak(aTHX_ "panic: gv name too long (%"UVuf")", (UV) len);
3116
ae8cc45f
NC		 3117 if (!(flags & GV_ADD) && GvNAME_HEK(gv)) {
3118 unshare_hek(GvNAME_HEK(gv));
3119 }
3120
acda4c6a 3121 PERL_HASH(hash, name, len);
c60dbbc3 3122 GvNAME_HEK(gv) = share_hek(name, (flags & SVf_UTF8 ? -(I32)len : (I32)len), hash);
f5c1e807
NC		 3123}
3124
66610fdd 3125/*
f7461760
Z		 3126=for apidoc gv_try_downgrade
3127
2867cdbc
Z		 3128If the typeglob C<gv> can be expressed more succinctly, by having
3129something other than a real GV in its place in the stash, replace it
3130with the optimised form. Basic requirements for this are that C<gv>
3131is a real typeglob, is sufficiently ordinary, and is only referenced
3132from its package. This function is meant to be used when a GV has been
3133looked up in part to see what was there, causing upgrading, but based
3134on what was found it turns out that the real GV isn't required after all.
3135
3136If C<gv> is a completely empty typeglob, it is deleted from the stash.
3137
3138If C<gv> is a typeglob containing only a sufficiently-ordinary constant
3139sub, the typeglob is replaced with a scalar-reference placeholder that
3140more compactly represents the same thing.
f7461760
Z		 3141
3142=cut
3143*/
3144
3145void
3146Perl_gv_try_downgrade(pTHX_ GV *gv)
3147{
3148 HV *stash;
3149 CV *cv;
3150 HEK *namehek;
3151 SV **gvp;
3152 PERL_ARGS_ASSERT_GV_TRY_DOWNGRADE;
95f56751
FC		 3153
3154 /* XXX Why and where does this leave dangling pointers during global
3155 destruction? */
627364f1 3156 if (PL_phase == PERL_PHASE_DESTRUCT) return;
95f56751 3157
2867cdbc 3158 if (!(SvREFCNT(gv) == 1 && SvTYPE(gv) == SVt_PVGV && !SvFAKE(gv) &&
803f2748 3159 !SvOBJECT(gv) && !SvREADONLY(gv) &&
f7461760 3160 isGV_with_GP(gv) && GvGP(gv) &&
2867cdbc 3161 !GvINTRO(gv) && GvREFCNT(gv) == 1 &&
f7461760 3162 !GvSV(gv) && !GvAV(gv) && !GvHV(gv) && !GvIOp(gv) && !GvFORM(gv) &&
099be4f1 3163 GvEGVx(gv) == gv && (stash = GvSTASH(gv))))
2867cdbc 3164 return;
803f2748
DM		 3165 if (SvMAGICAL(gv)) {
3166 MAGIC *mg;
3167 /* only backref magic is allowed */
3168 if (SvGMAGICAL(gv) || SvSMAGICAL(gv))
3169 return;
3170 for (mg = SvMAGIC(gv); mg; mg = mg->mg_moremagic) {
3171 if (mg->mg_type != PERL_MAGIC_backref)
3172 return;
3173 }
3174 }
2867cdbc
Z		 3175 cv = GvCV(gv);
3176 if (!cv) {
3177 HEK *gvnhek = GvNAME_HEK(gv);
3178 (void)hv_delete(stash, HEK_KEY(gvnhek),
3179 HEK_UTF8(gvnhek) ? -HEK_LEN(gvnhek) : HEK_LEN(gvnhek), G_DISCARD);
3180 } else if (GvMULTI(gv) && cv &&
f7461760
Z		 3181 !SvOBJECT(cv) && !SvMAGICAL(cv) && !SvREADONLY(cv) &&
3182 CvSTASH(cv) == stash && CvGV(cv) == gv &&
3183 CvCONST(cv) && !CvMETHOD(cv) && !CvLVALUE(cv) && !CvUNIQUE(cv) &&
3184 !CvNODEBUG(cv) && !CvCLONE(cv) && !CvCLONED(cv) && !CvANON(cv) &&
3185 (namehek = GvNAME_HEK(gv)) &&
3186 (gvp = hv_fetch(stash, HEK_KEY(namehek),
3187 HEK_LEN(namehek)*(HEK_UTF8(namehek) ? -1 : 1), 0)) &&
3188 *gvp == (SV*)gv) {
3189 SV *value = SvREFCNT_inc(CvXSUBANY(cv).any_ptr);
3190 SvREFCNT(gv) = 0;
3191 sv_clear((SV*)gv);
3192 SvREFCNT(gv) = 1;
3193 SvFLAGS(gv) = SVt_IV|SVf_ROK;
3194 SvANY(gv) = (XPVGV*)((char*)&(gv->sv_u.svu_iv) -
3195 STRUCT_OFFSET(XPVIV, xiv_iv));
3196 SvRV_set(gv, value);
3197 }
3198}
3199
4aaa4757
FC		 3200#include "XSUB.h"
3201
3202static void
3203core_xsub(pTHX_ CV* cv)
3204{
3205 Perl_croak(aTHX_
3206 "&CORE::%s cannot be called directly", GvNAME(CvGV(cv))
3207 );
3208}
3209
f7461760 3210/*
66610fdd
RGS		 3211 * Local variables:
3212 * c-indentation-style: bsd
3213 * c-basic-offset: 4
14d04a33 3214 * indent-tabs-mode: nil
66610fdd
RGS		 3215 * End:
3216 *
14d04a33 3217 * ex: set ts=8 sts=4 sw=4 et:
37442d52 3218 */
Unnamed repository; edit this file 'description' to name the repository.