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