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