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