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