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