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