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