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