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