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