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