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