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