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