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