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