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