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