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