This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Move an assert
[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
6361f656 1472 case '!': /* $! */
67261566 1473 GvMULTI_on(gv);
44a2ac75 1474 /* If %! has been used, automatically load Errno.pm. */
d2c93421 1475
ad64d0ec 1476 sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
d2c93421 1477
44a2ac75 1478 /* magicalization must be done before require_tie_mod is called */
67261566 1479 if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
44a2ac75 1480 require_tie_mod(gv, "!", newSVpvs("Errno"), "TIEHASH", 1);
d2c93421 1481
6cef1e77 1482 break;
6361f656
AB
1483 case '-': /* $- */
1484 case '+': /* $+ */
44a2ac75
YO
1485 GvMULTI_on(gv); /* no used once warnings here */
1486 {
44a2ac75 1487 AV* const av = GvAVn(gv);
ad64d0ec 1488 SV* const avc = (*name == '+') ? MUTABLE_SV(av) : NULL;
44a2ac75 1489
ad64d0ec
NC
1490 sv_magic(MUTABLE_SV(av), avc, PERL_MAGIC_regdata, NULL, 0);
1491 sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
67261566 1492 if (avc)
44a2ac75 1493 SvREADONLY_on(GvSVn(gv));
44a2ac75 1494 SvREADONLY_on(av);
67261566
YO
1495
1496 if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
192b9cd1 1497 require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "TIEHASH", 0);
67261566 1498
80305961 1499 break;
cc4c2da6 1500 }
6361f656
AB
1501 case '*': /* $* */
1502 case '#': /* $# */
9b387841
NC
1503 if (sv_type == SVt_PV)
1504 Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
1505 "$%c is no longer supported", *name);
8ae1fe26 1506 break;
6361f656 1507 case '|': /* $| */
c69033f2 1508 sv_setiv(GvSVn(gv), (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0);
cc4c2da6
NC
1509 goto magicalize;
1510
b3ca2e83
NC
1511 case '\010': /* $^H */
1512 {
1513 HV *const hv = GvHVn(gv);
1514 hv_magic(hv, NULL, PERL_MAGIC_hints);
1515 }
1516 goto magicalize;
cc4c2da6 1517 case '\023': /* $^S */
2fdbfb4d
AB
1518 ro_magicalize:
1519 SvREADONLY_on(GvSVn(gv));
1520 /* FALL THROUGH */
6361f656
AB
1521 case '0': /* $0 */
1522 case '1': /* $1 */
1523 case '2': /* $2 */
1524 case '3': /* $3 */
1525 case '4': /* $4 */
1526 case '5': /* $5 */
1527 case '6': /* $6 */
1528 case '7': /* $7 */
1529 case '8': /* $8 */
1530 case '9': /* $9 */
1531 case '[': /* $[ */
1532 case '^': /* $^ */
1533 case '~': /* $~ */
1534 case '=': /* $= */
1535 case '%': /* $% */
1536 case '.': /* $. */
1537 case '(': /* $( */
1538 case ')': /* $) */
1539 case '<': /* $< */
1540 case '>': /* $> */
1541 case '\\': /* $\ */
1542 case '/': /* $/ */
cc4c2da6
NC
1543 case '\001': /* $^A */
1544 case '\003': /* $^C */
1545 case '\004': /* $^D */
1546 case '\005': /* $^E */
1547 case '\006': /* $^F */
cc4c2da6
NC
1548 case '\011': /* $^I, NOT \t in EBCDIC */
1549 case '\016': /* $^N */
1550 case '\017': /* $^O */
1551 case '\020': /* $^P */
1552 case '\024': /* $^T */
1553 case '\027': /* $^W */
1554 magicalize:
ad64d0ec 1555 sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
cc4c2da6 1556 break;
e521374c 1557
cc4c2da6 1558 case '\014': /* $^L */
76f68e9b 1559 sv_setpvs(GvSVn(gv),"\f");
c69033f2 1560 PL_formfeed = GvSVn(gv);
463ee0b2 1561 break;
6361f656 1562 case ';': /* $; */
76f68e9b 1563 sv_setpvs(GvSVn(gv),"\034");
463ee0b2 1564 break;
6361f656 1565 case ']': /* $] */
cc4c2da6 1566 {
c69033f2 1567 SV * const sv = GvSVn(gv);
d7aa5382 1568 if (!sv_derived_from(PL_patchlevel, "version"))
ac0e6a2f 1569 upg_version(PL_patchlevel, TRUE);
7d54d38e
SH
1570 GvSV(gv) = vnumify(PL_patchlevel);
1571 SvREADONLY_on(GvSV(gv));
1572 SvREFCNT_dec(sv);
93a17b20
LW
1573 }
1574 break;
cc4c2da6
NC
1575 case '\026': /* $^V */
1576 {
c69033f2 1577 SV * const sv = GvSVn(gv);
f9be5ac8
DM
1578 GvSV(gv) = new_version(PL_patchlevel);
1579 SvREADONLY_on(GvSV(gv));
1580 SvREFCNT_dec(sv);
16070b82
GS
1581 }
1582 break;
cc4c2da6 1583 }
79072805 1584 }
93a17b20 1585 return gv;
79072805
LW
1586}
1587
1588void
35a4481c 1589Perl_gv_fullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
43693395 1590{
35a4481c 1591 const char *name;
7423f6db 1592 STRLEN namelen;
35a4481c 1593 const HV * const hv = GvSTASH(gv);
7918f24d
NC
1594
1595 PERL_ARGS_ASSERT_GV_FULLNAME4;
1596
43693395 1597 if (!hv) {
0c34ef67 1598 SvOK_off(sv);
43693395
GS
1599 return;
1600 }
666ea192 1601 sv_setpv(sv, prefix ? prefix : "");
a0288114 1602
bfcb3514 1603 name = HvNAME_get(hv);
7423f6db
NC
1604 if (name) {
1605 namelen = HvNAMELEN_get(hv);
1606 } else {
e27ad1f2 1607 name = "__ANON__";
7423f6db
NC
1608 namelen = 8;
1609 }
a0288114 1610
e27ad1f2 1611 if (keepmain || strNE(name, "main")) {
7423f6db 1612 sv_catpvn(sv,name,namelen);
396482e1 1613 sv_catpvs(sv,"::");
43693395 1614 }
257984c0 1615 sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv));
43693395
GS
1616}
1617
1618void
35a4481c 1619Perl_gv_efullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
43693395 1620{
099be4f1 1621 const GV * const egv = GvEGVx(gv);
7918f24d
NC
1622
1623 PERL_ARGS_ASSERT_GV_EFULLNAME4;
1624
46c461b5 1625 gv_fullname4(sv, egv ? egv : gv, prefix, keepmain);
43693395
GS
1626}
1627
79072805 1628void
1146e912 1629Perl_gv_check(pTHX_ const HV *stash)
79072805 1630{
97aff369 1631 dVAR;
79072805 1632 register I32 i;
463ee0b2 1633
7918f24d
NC
1634 PERL_ARGS_ASSERT_GV_CHECK;
1635
8990e307
LW
1636 if (!HvARRAY(stash))
1637 return;
a0d0e21e 1638 for (i = 0; i <= (I32) HvMAX(stash); i++) {
e1ec3a88 1639 const HE *entry;
dc437b57 1640 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
b7787f18
AL
1641 register GV *gv;
1642 HV *hv;
dc437b57 1643 if (HeKEY(entry)[HeKLEN(entry)-1] == ':' &&
159b6efe 1644 (gv = MUTABLE_GV(HeVAL(entry))) && isGV(gv) && (hv = GvHV(gv)))
a0d0e21e 1645 {
19b6c847 1646 if (hv != PL_defstash && hv != stash)
a0d0e21e
LW
1647 gv_check(hv); /* nested package */
1648 }
dc437b57 1649 else if (isALPHA(*HeKEY(entry))) {
e1ec3a88 1650 const char *file;
159b6efe 1651 gv = MUTABLE_GV(HeVAL(entry));
55d729e4 1652 if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv))
463ee0b2 1653 continue;
1d7c1841 1654 file = GvFILE(gv);
1d7c1841
GS
1655 CopLINE_set(PL_curcop, GvLINE(gv));
1656#ifdef USE_ITHREADS
dd374669 1657 CopFILE(PL_curcop) = (char *)file; /* set for warning */
1d7c1841 1658#else
9bde8eb0
NC
1659 CopFILEGV(PL_curcop)
1660 = gv_fetchfile_flags(file, HEK_LEN(GvFILE_HEK(gv)), 0);
1d7c1841 1661#endif
9014280d 1662 Perl_warner(aTHX_ packWARN(WARN_ONCE),
599cee73 1663 "Name \"%s::%s\" used only once: possible typo",
bfcb3514 1664 HvNAME_get(stash), GvNAME(gv));
463ee0b2 1665 }
79072805
LW
1666 }
1667 }
1668}
1669
1670GV *
e1ec3a88 1671Perl_newGVgen(pTHX_ const char *pack)
79072805 1672{
97aff369 1673 dVAR;
7918f24d
NC
1674
1675 PERL_ARGS_ASSERT_NEWGVGEN;
1676
cea2e8a9 1677 return gv_fetchpv(Perl_form(aTHX_ "%s::_GEN_%ld", pack, (long)PL_gensym++),
6fd99bb3 1678 GV_ADD, SVt_PVGV);
79072805
LW
1679}
1680
1681/* hopefully this is only called on local symbol table entries */
1682
1683GP*
864dbfa3 1684Perl_gp_ref(pTHX_ GP *gp)
79072805 1685{
97aff369 1686 dVAR;
1d7c1841 1687 if (!gp)
d4c19fe8 1688 return NULL;
79072805 1689 gp->gp_refcnt++;
44a8e56a
PP
1690 if (gp->gp_cv) {
1691 if (gp->gp_cvgen) {
e1a479c5
BB
1692 /* If the GP they asked for a reference to contains
1693 a method cache entry, clear it first, so that we
1694 don't infect them with our cached entry */
44a8e56a 1695 SvREFCNT_dec(gp->gp_cv);
601f1833 1696 gp->gp_cv = NULL;
44a8e56a
PP
1697 gp->gp_cvgen = 0;
1698 }
44a8e56a 1699 }
79072805 1700 return gp;
79072805
LW
1701}
1702
1703void
864dbfa3 1704Perl_gp_free(pTHX_ GV *gv)
79072805 1705{
97aff369 1706 dVAR;
79072805 1707 GP* gp;
b0d55c99 1708 int attempts = 100;
79072805 1709
f7877b28 1710 if (!gv || !isGV_with_GP(gv) || !(gp = GvGP(gv)))
79072805 1711 return;
f248d071 1712 if (gp->gp_refcnt == 0) {
9b387841
NC
1713 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
1714 "Attempt to free unreferenced glob pointers"
1715 pTHX__FORMAT pTHX__VALUE);
79072805
LW
1716 return;
1717 }
748a9306
LW
1718 if (--gp->gp_refcnt > 0) {
1719 if (gp->gp_egv == gv)
1720 gp->gp_egv = 0;
c43ae56f 1721 GvGP_set(gv, NULL);
79072805 1722 return;
748a9306 1723 }
79072805 1724
b0d55c99
FC
1725 while (1) {
1726 /* Copy and null out all the glob slots, so destructors do not see
1727 freed SVs. */
1728 HEK * const file_hek = gp->gp_file_hek;
1729 SV * const sv = gp->gp_sv;
1730 AV * const av = gp->gp_av;
1731 HV * const hv = gp->gp_hv;
1732 IO * const io = gp->gp_io;
1733 CV * const cv = gp->gp_cv;
1734 CV * const form = gp->gp_form;
1735
1736 gp->gp_file_hek = NULL;
1737 gp->gp_sv = NULL;
1738 gp->gp_av = NULL;
1739 gp->gp_hv = NULL;
1740 gp->gp_io = NULL;
1741 gp->gp_cv = NULL;
1742 gp->gp_form = NULL;
1743
1744 if (file_hek)
1745 unshare_hek(file_hek);
1746
1747 SvREFCNT_dec(sv);
1748 SvREFCNT_dec(av);
1749 /* FIXME - another reference loop GV -> symtab -> GV ?
1750 Somehow gp->gp_hv can end up pointing at freed garbage. */
1751 if (hv && SvTYPE(hv) == SVt_PVHV) {
1752 const char *hvname = HvNAME_get(hv);
bfcb3514 1753 if (PL_stashcache && hvname)
b0d55c99 1754 (void)hv_delete(PL_stashcache, hvname, HvNAMELEN_get(hv),
7423f6db 1755 G_DISCARD);
b0d55c99
FC
1756 SvREFCNT_dec(hv);
1757 }
1758 SvREFCNT_dec(io);
1759 SvREFCNT_dec(cv);
1760 SvREFCNT_dec(form);
1761
1762 if (!gp->gp_file_hek
1763 && !gp->gp_sv
1764 && !gp->gp_av
1765 && !gp->gp_hv
1766 && !gp->gp_io
1767 && !gp->gp_cv
1768 && !gp->gp_form) break;
1769
1770 if (--attempts == 0) {
1771 Perl_die(aTHX_
1772 "panic: gp_free failed to free glob pointer - "
1773 "something is repeatedly re-creating entries"
1774 );
1775 }
13207a71 1776 }
748a9306 1777
79072805 1778 Safefree(gp);
c43ae56f 1779 GvGP_set(gv, NULL);
79072805
LW
1780}
1781
d460ef45
NIS
1782int
1783Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg)
1784{
53c1dcc0
AL
1785 AMT * const amtp = (AMT*)mg->mg_ptr;
1786 PERL_UNUSED_ARG(sv);
dd374669 1787
7918f24d
NC
1788 PERL_ARGS_ASSERT_MAGIC_FREEOVRLD;
1789
d460ef45
NIS
1790 if (amtp && AMT_AMAGIC(amtp)) {
1791 int i;
1792 for (i = 1; i < NofAMmeth; i++) {
53c1dcc0 1793 CV * const cv = amtp->table[i];
b37c2d43 1794 if (cv) {
ad64d0ec 1795 SvREFCNT_dec(MUTABLE_SV(cv));
601f1833 1796 amtp->table[i] = NULL;
d460ef45
NIS
1797 }
1798 }
1799 }
1800 return 0;
1801}
1802
a0d0e21e 1803/* Updates and caches the CV's */
c3a9a790
RGS
1804/* Returns:
1805 * 1 on success and there is some overload
1806 * 0 if there is no overload
1807 * -1 if some error occurred and it couldn't croak
1808 */
a0d0e21e 1809
c3a9a790 1810int
242f8760 1811Perl_Gv_AMupdate(pTHX_ HV *stash, bool destructing)
a0d0e21e 1812{
97aff369 1813 dVAR;
ad64d0ec 1814 MAGIC* const mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
a6006777 1815 AMT amt;
9b439311 1816 const struct mro_meta* stash_meta = HvMROMETA(stash);
e1a479c5 1817 U32 newgen;
a0d0e21e 1818
7918f24d
NC
1819 PERL_ARGS_ASSERT_GV_AMUPDATE;
1820
9b439311 1821 newgen = PL_sub_generation + stash_meta->pkg_gen + stash_meta->cache_gen;
14899595
NC
1822 if (mg) {
1823 const AMT * const amtp = (AMT*)mg->mg_ptr;
1824 if (amtp->was_ok_am == PL_amagic_generation
e1a479c5 1825 && amtp->was_ok_sub == newgen) {
c3a9a790 1826 return AMT_OVERLOADED(amtp) ? 1 : 0;
14899595 1827 }
ad64d0ec 1828 sv_unmagic(MUTABLE_SV(stash), PERL_MAGIC_overload_table);
14899595 1829 }
a0d0e21e 1830
bfcb3514 1831 DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME_get(stash)) );
a0d0e21e 1832
d460ef45 1833 Zero(&amt,1,AMT);
3280af22 1834 amt.was_ok_am = PL_amagic_generation;
e1a479c5 1835 amt.was_ok_sub = newgen;
a6006777
PP
1836 amt.fallback = AMGfallNO;
1837 amt.flags = 0;
1838
a6006777 1839 {
32251b26
IZ
1840 int filled = 0, have_ovl = 0;
1841 int i, lim = 1;
a6006777 1842
22c35a8c 1843 /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
a6006777 1844
89ffc314 1845 /* Try to find via inheritance. */
53c1dcc0
AL
1846 GV *gv = gv_fetchmeth(stash, PL_AMG_names[0], 2, -1);
1847 SV * const sv = gv ? GvSV(gv) : NULL;
1848 CV* cv;
89ffc314
IZ
1849
1850 if (!gv)
32251b26 1851 lim = DESTROY_amg; /* Skip overloading entries. */
c69033f2
NC
1852#ifdef PERL_DONT_CREATE_GVSV
1853 else if (!sv) {
6f207bd3 1854 NOOP; /* Equivalent to !SvTRUE and !SvOK */
c69033f2
NC
1855 }
1856#endif
89ffc314
IZ
1857 else if (SvTRUE(sv))
1858 amt.fallback=AMGfallYES;
1859 else if (SvOK(sv))
1860 amt.fallback=AMGfallNEVER;
a6006777 1861
32251b26 1862 for (i = 1; i < lim; i++)
601f1833 1863 amt.table[i] = NULL;
32251b26 1864 for (; i < NofAMmeth; i++) {
6136c704 1865 const char * const cooky = PL_AMG_names[i];
32251b26 1866 /* Human-readable form, for debugging: */
6136c704 1867 const char * const cp = (i >= DESTROY_amg ? cooky : AMG_id2name(i));
d279ab82 1868 const STRLEN l = PL_AMG_namelens[i];
89ffc314 1869
a0288114 1870 DEBUG_o( Perl_deb(aTHX_ "Checking overloading of \"%s\" in package \"%.256s\"\n",
bfcb3514 1871 cp, HvNAME_get(stash)) );
611c1e95
IZ
1872 /* don't fill the cache while looking up!
1873 Creation of inheritance stubs in intermediate packages may
1874 conflict with the logic of runtime method substitution.
1875 Indeed, for inheritance A -> B -> C, if C overloads "+0",
1876 then we could have created stubs for "(+0" in A and C too.
1877 But if B overloads "bool", we may want to use it for
1878 numifying instead of C's "+0". */
1879 if (i >= DESTROY_amg)
1880 gv = Perl_gv_fetchmeth_autoload(aTHX_ stash, cooky, l, 0);
1881 else /* Autoload taken care of below */
1882 gv = Perl_gv_fetchmeth(aTHX_ stash, cooky, l, -1);
46fc3d4c 1883 cv = 0;
89ffc314 1884 if (gv && (cv = GvCV(gv))) {
bfcb3514 1885 const char *hvname;
44a8e56a 1886 if (GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")
bfcb3514 1887 && strEQ(hvname = HvNAME_get(GvSTASH(CvGV(cv))), "overload")) {
611c1e95
IZ
1888 /* This is a hack to support autoloading..., while
1889 knowing *which* methods were declared as overloaded. */
44a8e56a 1890 /* GvSV contains the name of the method. */
6136c704 1891 GV *ngv = NULL;
c69033f2 1892 SV *gvsv = GvSV(gv);
a0288114
AL
1893
1894 DEBUG_o( Perl_deb(aTHX_ "Resolving method \"%"SVf256\
1895 "\" for overloaded \"%s\" in package \"%.256s\"\n",
ca0270c4 1896 (void*)GvSV(gv), cp, hvname) );
c69033f2
NC
1897 if (!gvsv || !SvPOK(gvsv)
1898 || !(ngv = gv_fetchmethod_autoload(stash, SvPVX_const(gvsv),
dc848c6f
PP
1899 FALSE)))
1900 {
a0288114 1901 /* Can be an import stub (created by "can"). */
242f8760 1902 if (destructing) {
c3a9a790 1903 return -1;
242f8760
RGS
1904 }
1905 else {
1906 const char * const name = (gvsv && SvPOK(gvsv)) ? SvPVX_const(gvsv) : "???";
1907 Perl_croak(aTHX_ "%s method \"%.256s\" overloading \"%s\" "\
1908 "in package \"%.256s\"",
1909 (GvCVGEN(gv) ? "Stub found while resolving"
1910 : "Can't resolve"),
1911 name, cp, hvname);
1912 }
44a8e56a 1913 }
dc848c6f 1914 cv = GvCV(gv = ngv);
44a8e56a 1915 }
b464bac0 1916 DEBUG_o( Perl_deb(aTHX_ "Overloading \"%s\" in package \"%.256s\" via \"%.256s::%.256s\"\n",
bfcb3514 1917 cp, HvNAME_get(stash), HvNAME_get(GvSTASH(CvGV(cv))),
44a8e56a
PP
1918 GvNAME(CvGV(cv))) );
1919 filled = 1;
32251b26
IZ
1920 if (i < DESTROY_amg)
1921 have_ovl = 1;
611c1e95 1922 } else if (gv) { /* Autoloaded... */
ea726b52 1923 cv = MUTABLE_CV(gv);
611c1e95 1924 filled = 1;
44a8e56a 1925 }
ea726b52 1926 amt.table[i]=MUTABLE_CV(SvREFCNT_inc_simple(cv));
a0d0e21e 1927 }
a0d0e21e 1928 if (filled) {
a6006777 1929 AMT_AMAGIC_on(&amt);
32251b26
IZ
1930 if (have_ovl)
1931 AMT_OVERLOADED_on(&amt);
ad64d0ec 1932 sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table,
14befaf4 1933 (char*)&amt, sizeof(AMT));
32251b26 1934 return have_ovl;
a0d0e21e
LW
1935 }
1936 }
a6006777 1937 /* Here we have no table: */
9cbac4c7 1938 /* no_table: */
a6006777 1939 AMT_AMAGIC_off(&amt);
ad64d0ec 1940 sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table,
14befaf4 1941 (char*)&amt, sizeof(AMTS));
c3a9a790 1942 return 0;
a0d0e21e
LW
1943}
1944
32251b26
IZ
1945
1946CV*
1947Perl_gv_handler(pTHX_ HV *stash, I32 id)
1948{
97aff369 1949 dVAR;
3f8f4626 1950 MAGIC *mg;
32251b26 1951 AMT *amtp;
e1a479c5 1952 U32 newgen;
9b439311 1953 struct mro_meta* stash_meta;
32251b26 1954
bfcb3514 1955 if (!stash || !HvNAME_get(stash))
601f1833 1956 return NULL;
e1a479c5 1957
9b439311
BB
1958 stash_meta = HvMROMETA(stash);
1959 newgen = PL_sub_generation + stash_meta->pkg_gen + stash_meta->cache_gen;
e1a479c5 1960
ad64d0ec 1961 mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
32251b26
IZ
1962 if (!mg) {
1963 do_update:
242f8760
RGS
1964 /* If we're looking up a destructor to invoke, we must avoid
1965 * that Gv_AMupdate croaks, because we might be dying already */
2dcac756 1966 if (Gv_AMupdate(stash, cBOOL(id == DESTROY_amg)) == -1) {
242f8760
RGS
1967 /* and if it didn't found a destructor, we fall back
1968 * to a simpler method that will only look for the
1969 * destructor instead of the whole magic */
1970 if (id == DESTROY_amg) {
1971 GV * const gv = gv_fetchmethod(stash, "DESTROY");
1972 if (gv)
1973 return GvCV(gv);
1974 }
1975 return NULL;
1976 }
ad64d0ec 1977 mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
32251b26 1978 }
a9fd4e40 1979 assert(mg);
32251b26
IZ
1980 amtp = (AMT*)mg->mg_ptr;
1981 if ( amtp->was_ok_am != PL_amagic_generation
e1a479c5 1982 || amtp->was_ok_sub != newgen )
32251b26 1983 goto do_update;
3ad83ce7 1984 if (AMT_AMAGIC(amtp)) {
b7787f18 1985 CV * const ret = amtp->table[id];
3ad83ce7
AMS
1986 if (ret && isGV(ret)) { /* Autoloading stab */
1987 /* Passing it through may have resulted in a warning
1988 "Inherited AUTOLOAD for a non-method deprecated", since
1989 our caller is going through a function call, not a method call.
1990 So return the CV for AUTOLOAD, setting $AUTOLOAD. */
890ce7af 1991 GV * const gv = gv_fetchmethod(stash, PL_AMG_names[id]);
3ad83ce7
AMS
1992
1993 if (gv && GvCV(gv))
1994 return GvCV(gv);
1995 }
1996 return ret;
1997 }
a0288114 1998
601f1833 1999 return NULL;
32251b26
IZ
2000}
2001
2002
6f1401dc
DM
2003/* Implement tryAMAGICun_MG macro.
2004 Do get magic, then see if the stack arg is overloaded and if so call it.
2005 Flags:
2006 AMGf_set return the arg using SETs rather than assigning to
2007 the targ
2008 AMGf_numeric apply sv_2num to the stack arg.
2009*/
2010
2011bool
2012Perl_try_amagic_un(pTHX_ int method, int flags) {
2013 dVAR;
2014 dSP;
2015 SV* tmpsv;
2016 SV* const arg = TOPs;
2017
2018 SvGETMAGIC(arg);
2019
9f8bf298
NC
2020 if (SvAMAGIC(arg) && (tmpsv = amagic_call(arg, &PL_sv_undef, method,
2021 AMGf_noright | AMGf_unary))) {
6f1401dc
DM
2022 if (flags & AMGf_set) {
2023 SETs(tmpsv);
2024 }
2025 else {
2026 dTARGET;
2027 if (SvPADMY(TARG)) {
2028 sv_setsv(TARG, tmpsv);
2029 SETTARG;
2030 }
2031 else
2032 SETs(tmpsv);
2033 }
2034 PUTBACK;
2035 return TRUE;
2036 }
2037
2038 if ((flags & AMGf_numeric) && SvROK(arg))
2039 *sp = sv_2num(arg);
2040 return FALSE;
2041}
2042
2043
2044/* Implement tryAMAGICbin_MG macro.
2045 Do get magic, then see if the two stack args are overloaded and if so
2046 call it.
2047 Flags:
2048 AMGf_set return the arg using SETs rather than assigning to
2049 the targ
2050 AMGf_assign op may be called as mutator (eg +=)
2051 AMGf_numeric apply sv_2num to the stack arg.
2052*/
2053
2054bool
2055Perl_try_amagic_bin(pTHX_ int method, int flags) {
2056 dVAR;
2057 dSP;
2058 SV* const left = TOPm1s;
2059 SV* const right = TOPs;
2060
2061 SvGETMAGIC(left);
2062 if (left != right)
2063 SvGETMAGIC(right);
2064
2065 if (SvAMAGIC(left) || SvAMAGIC(right)) {
2066 SV * const tmpsv = amagic_call(left, right, method,
2067 ((flags & AMGf_assign) && opASSIGN ? AMGf_assign: 0));
2068 if (tmpsv) {
2069 if (flags & AMGf_set) {
2070 (void)POPs;
2071 SETs(tmpsv);
2072 }
2073 else {
2074 dATARGET;
2075 (void)POPs;
2076 if (opASSIGN || SvPADMY(TARG)) {
2077 sv_setsv(TARG, tmpsv);
2078 SETTARG;
2079 }
2080 else
2081 SETs(tmpsv);
2082 }
2083 PUTBACK;
2084 return TRUE;
2085 }
2086 }
75ea7a12
FC
2087 if(left==right && SvGMAGICAL(left)) {
2088 SV * const left = sv_newmortal();
2089 *(sp-1) = left;
2090 /* Print the uninitialized warning now, so it includes the vari-
2091 able name. */
2092 if (!SvOK(right)) {
2093 if (ckWARN(WARN_UNINITIALIZED)) report_uninit(right);
2094 sv_setsv_flags(left, &PL_sv_no, 0);
2095 }
2096 else sv_setsv_flags(left, right, 0);
2097 SvGETMAGIC(right);
2098 }
6f1401dc 2099 if (flags & AMGf_numeric) {
75ea7a12
FC
2100 if (SvROK(TOPm1s))
2101 *(sp-1) = sv_2num(TOPm1s);
6f1401dc
DM
2102 if (SvROK(right))
2103 *sp = sv_2num(right);
2104 }
2105 return FALSE;
2106}
2107
25a9ffce
NC
2108SV *
2109Perl_amagic_deref_call(pTHX_ SV *ref, int method) {
2110 SV *tmpsv = NULL;
2111
2112 PERL_ARGS_ASSERT_AMAGIC_DEREF_CALL;
2113
2114 while (SvAMAGIC(ref) &&
2115 (tmpsv = amagic_call(ref, &PL_sv_undef, method,
2116 AMGf_noright | AMGf_unary))) {
2117 if (!SvROK(tmpsv))
2118 Perl_croak(aTHX_ "Overloaded dereference did not return a reference");
2119 if (tmpsv == ref || SvRV(tmpsv) == SvRV(ref)) {
2120 /* Bail out if it returns us the same reference. */
2121 return tmpsv;
2122 }
2123 ref = tmpsv;
2124 }
2125 return tmpsv ? tmpsv : ref;
2126}
6f1401dc 2127
a0d0e21e 2128SV*
864dbfa3 2129Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
a0d0e21e 2130{
27da23d5 2131 dVAR;
b267980d 2132 MAGIC *mg;
9c5ffd7c 2133 CV *cv=NULL;
a0d0e21e 2134 CV **cvp=NULL, **ocvp=NULL;
9c5ffd7c 2135 AMT *amtp=NULL, *oamtp=NULL;
b464bac0
AL
2136 int off = 0, off1, lr = 0, notfound = 0;
2137 int postpr = 0, force_cpy = 0;
2138 int assign = AMGf_assign & flags;
2139 const int assignshift = assign ? 1 : 0;
bf5522a1 2140 int use_default_op = 0;
497b47a8
JH
2141#ifdef DEBUGGING
2142 int fl=0;
497b47a8 2143#endif
25716404 2144 HV* stash=NULL;
7918f24d
NC
2145
2146 PERL_ARGS_ASSERT_AMAGIC_CALL;
2147
e46c382e 2148 if ( PL_curcop->cop_hints & HINT_NO_AMAGIC ) {
20439bc7 2149 SV *lex_mask = cop_hints_fetch_pvs(PL_curcop, "overloading", 0);
e46c382e
YK
2150
2151 if ( !lex_mask || !SvOK(lex_mask) )
2152 /* overloading lexically disabled */
2153 return NULL;
2154 else if ( lex_mask && SvPOK(lex_mask) ) {
2155 /* we have an entry in the hints hash, check if method has been
2156 * masked by overloading.pm */
d15cd831 2157 STRLEN len;
e46c382e 2158 const int offset = method / 8;
d87d3eed 2159 const int bit = method % 8;
e46c382e
YK
2160 char *pv = SvPV(lex_mask, len);
2161
d15cd831 2162 /* Bit set, so this overloading operator is disabled */
ed15e576 2163 if ( (STRLEN)offset < len && pv[offset] & ( 1 << bit ) )
e46c382e
YK
2164 return NULL;
2165 }
2166 }
2167
a0d0e21e 2168 if (!(AMGf_noleft & flags) && SvAMAGIC(left)
25716404 2169 && (stash = SvSTASH(SvRV(left)))
ad64d0ec 2170 && (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table))
b267980d 2171 && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
a6006777 2172 ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
d4c19fe8 2173 : NULL))
b267980d 2174 && ((cv = cvp[off=method+assignshift])
748a9306
LW
2175 || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
2176 * usual method */
497b47a8
JH
2177 (
2178#ifdef DEBUGGING
2179 fl = 1,
a0288114 2180#endif
497b47a8 2181 cv = cvp[off=method])))) {
a0d0e21e
LW
2182 lr = -1; /* Call method for left argument */
2183 } else {
2184 if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) {
2185 int logic;
2186
2187 /* look for substituted methods */
ee239bfe 2188 /* In all the covered cases we should be called with assign==0. */
a0d0e21e
LW
2189 switch (method) {
2190 case inc_amg:
ee239bfe
IZ
2191 force_cpy = 1;
2192 if ((cv = cvp[off=add_ass_amg])
2193 || ((cv = cvp[off = add_amg]) && (force_cpy = 0, postpr = 1))) {
3280af22 2194 right = &PL_sv_yes; lr = -1; assign = 1;
a0d0e21e
LW
2195 }
2196 break;
2197 case dec_amg:
ee239bfe
IZ
2198 force_cpy = 1;
2199 if ((cv = cvp[off = subtr_ass_amg])
2200 || ((cv = cvp[off = subtr_amg]) && (force_cpy = 0, postpr=1))) {
3280af22 2201 right = &PL_sv_yes; lr = -1; assign = 1;
a0d0e21e
LW
2202 }
2203 break;
2204 case bool__amg:
2205 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg]));
2206 break;
2207 case numer_amg:
2208 (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg]));
2209 break;
2210 case string_amg:
2211 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg]));
2212 break;
b7787f18
AL
2213 case not_amg:
2214 (void)((cv = cvp[off=bool__amg])
2215 || (cv = cvp[off=numer_amg])
2216 || (cv = cvp[off=string_amg]));
2ab54efd
MB
2217 if (cv)
2218 postpr = 1;
b7787f18 2219 break;
748a9306
LW
2220 case copy_amg:
2221 {
76e3520e
GS
2222 /*
2223 * SV* ref causes confusion with the interpreter variable of
2224 * the same name
2225 */
890ce7af 2226 SV* const tmpRef=SvRV(left);
76e3520e 2227 if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) {
fc36a67e
PP
2228 /*
2229 * Just to be extra cautious. Maybe in some
2230 * additional cases sv_setsv is safe, too.
2231 */
890ce7af 2232 SV* const newref = newSVsv(tmpRef);
748a9306 2233 SvOBJECT_on(newref);
96d4b0ee
NC
2234 /* As a bit of a source compatibility hack, SvAMAGIC() and
2235 friends dereference an RV, to behave the same was as when
2236 overloading was stored on the reference, not the referant.
2237 Hence we can't use SvAMAGIC_on()
2238 */
2239 SvFLAGS(newref) |= SVf_AMAGIC;
85fbaab2 2240 SvSTASH_set(newref, MUTABLE_HV(SvREFCNT_inc(SvSTASH(tmpRef))));
748a9306
LW
2241 return newref;
2242 }
2243 }
2244 break;
a0d0e21e 2245 case abs_amg:
b267980d 2246 if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg])
a0d0e21e 2247 && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) {
890ce7af 2248 SV* const nullsv=sv_2mortal(newSViv(0));
a0d0e21e 2249 if (off1==lt_amg) {
890ce7af 2250 SV* const lessp = amagic_call(left,nullsv,
a0d0e21e
LW
2251 lt_amg,AMGf_noright);
2252 logic = SvTRUE(lessp);
2253 } else {
890ce7af 2254 SV* const lessp = amagic_call(left,nullsv,
a0d0e21e
LW
2255 ncmp_amg,AMGf_noright);
2256 logic = (SvNV(lessp) < 0);
2257 }
2258 if (logic) {
2259 if (off==subtr_amg) {
2260 right = left;
748a9306 2261 left = nullsv;
a0d0e21e
LW
2262 lr = 1;
2263 }
2264 } else {
2265 return left;
2266 }
2267 }
2268 break;
2269 case neg_amg:
155aba94 2270 if ((cv = cvp[off=subtr_amg])) {
a0d0e21e
LW
2271 right = left;
2272 left = sv_2mortal(newSViv(0));
2273 lr = 1;
2274 }
2275 break;
f216259d 2276 case int_amg:
f5284f61 2277 case iter_amg: /* XXXX Eventually should do to_gv. */
c4c7412c 2278 case ftest_amg: /* XXXX Eventually should do to_gv. */
d4b87e75 2279 case regexp_amg:
b267980d
NIS
2280 /* FAIL safe */
2281 return NULL; /* Delegate operation to standard mechanisms. */
2282 break;
f5284f61
IZ
2283 case to_sv_amg:
2284 case to_av_amg:
2285 case to_hv_amg:
2286 case to_gv_amg:
2287 case to_cv_amg:
2288 /* FAIL safe */
b267980d 2289 return left; /* Delegate operation to standard mechanisms. */
f5284f61 2290 break;
a0d0e21e
LW
2291 default:
2292 goto not_found;
2293 }
2294 if (!cv) goto not_found;
2295 } else if (!(AMGf_noright & flags) && SvAMAGIC(right)
25716404 2296 && (stash = SvSTASH(SvRV(right)))
ad64d0ec 2297 && (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table))
b267980d 2298 && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
a6006777 2299 ? (amtp = (AMT*)mg->mg_ptr)->table
d4c19fe8 2300 : NULL))
a0d0e21e
LW
2301 && (cv = cvp[off=method])) { /* Method for right
2302 * argument found */
2303 lr=1;
bf5522a1
MB
2304 } else if (((cvp && amtp->fallback > AMGfallNEVER)
2305 || (ocvp && oamtp->fallback > AMGfallNEVER))
a0d0e21e
LW
2306 && !(flags & AMGf_unary)) {
2307 /* We look for substitution for
2308 * comparison operations and
fc36a67e 2309 * concatenation */
a0d0e21e
LW
2310 if (method==concat_amg || method==concat_ass_amg
2311 || method==repeat_amg || method==repeat_ass_amg) {
2312 return NULL; /* Delegate operation to string conversion */
2313 }
2314 off = -1;
2315 switch (method) {
2316 case lt_amg:
2317 case le_amg:
2318 case gt_amg:
2319 case ge_amg:
2320 case eq_amg:
2321 case ne_amg:
2ab54efd
MB
2322 off = ncmp_amg;
2323 break;
a0d0e21e
LW
2324 case slt_amg:
2325 case sle_amg:
2326 case sgt_amg:
2327 case sge_amg:
2328 case seq_amg:
2329 case sne_amg:
2ab54efd
MB
2330 off = scmp_amg;
2331 break;
a0d0e21e 2332 }
bf5522a1
MB
2333 if (off != -1) {
2334 if (ocvp && (oamtp->fallback > AMGfallNEVER)) {
2335 cv = ocvp[off];
2336 lr = -1;
2337 }
2338 if (!cv && (cvp && amtp->fallback > AMGfallNEVER)) {
2339 cv = cvp[off];
2340 lr = 1;
2341 }
2342 }
2343 if (cv)
2ab54efd
MB
2344 postpr = 1;
2345 else
2346 goto not_found;
a0d0e21e 2347 } else {
a6006777 2348 not_found: /* No method found, either report or croak */
b267980d
NIS
2349 switch (method) {
2350 case to_sv_amg:
2351 case to_av_amg:
2352 case to_hv_amg:
2353 case to_gv_amg:
2354 case to_cv_amg:
2355 /* FAIL safe */
2356 return left; /* Delegate operation to standard mechanisms. */
2357 break;
2358 }
a0d0e21e
LW
2359 if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */
2360 notfound = 1; lr = -1;
2361 } else if (cvp && (cv=cvp[nomethod_amg])) {
2362 notfound = 1; lr = 1;
bf5522a1
MB
2363 } else if ((use_default_op =
2364 (!ocvp || oamtp->fallback >= AMGfallYES)
2365 && (!cvp || amtp->fallback >= AMGfallYES))
2366 && !DEBUG_o_TEST) {
4cc0ca18
NC
2367 /* Skip generating the "no method found" message. */
2368 return NULL;
a0d0e21e 2369 } else {
46fc3d4c 2370 SV *msg;
774d564b 2371 if (off==-1) off=method;
b267980d 2372 msg = sv_2mortal(Perl_newSVpvf(aTHX_
a0288114 2373 "Operation \"%s\": no method found,%sargument %s%s%s%s",
89ffc314 2374 AMG_id2name(method + assignshift),
e7ea3e70 2375 (flags & AMGf_unary ? " " : "\n\tleft "),
b267980d 2376 SvAMAGIC(left)?
a0d0e21e
LW
2377 "in overloaded package ":
2378 "has no overloaded magic",
b267980d 2379 SvAMAGIC(left)?
bfcb3514 2380 HvNAME_get(SvSTASH(SvRV(left))):
a0d0e21e 2381 "",
b267980d 2382 SvAMAGIC(right)?
e7ea3e70 2383 ",\n\tright argument in overloaded package ":
b267980d 2384 (flags & AMGf_unary
e7ea3e70
IZ
2385 ? ""
2386 : ",\n\tright argument has no overloaded magic"),
b267980d 2387 SvAMAGIC(right)?
bfcb3514 2388 HvNAME_get(SvSTASH(SvRV(right))):
46fc3d4c 2389 ""));
bf5522a1 2390 if (use_default_op) {
b15aece3 2391 DEBUG_o( Perl_deb(aTHX_ "%s", SvPVX_const(msg)) );
a0d0e21e 2392 } else {
be2597df 2393 Perl_croak(aTHX_ "%"SVf, SVfARG(msg));
a0d0e21e
LW
2394 }
2395 return NULL;
2396 }
ee239bfe 2397 force_cpy = force_cpy || assign;
a0d0e21e
LW
2398 }
2399 }
497b47a8 2400#ifdef DEBUGGING
a0d0e21e 2401 if (!notfound) {
497b47a8 2402 DEBUG_o(Perl_deb(aTHX_
a0288114 2403 "Overloaded operator \"%s\"%s%s%s:\n\tmethod%s found%s in package %s%s\n",
497b47a8
JH
2404 AMG_id2name(off),
2405 method+assignshift==off? "" :
a0288114 2406 " (initially \"",
497b47a8
JH
2407 method+assignshift==off? "" :
2408 AMG_id2name(method+assignshift),
a0288114 2409 method+assignshift==off? "" : "\")",
497b47a8
JH
2410 flags & AMGf_unary? "" :
2411 lr==1 ? " for right argument": " for left argument",
2412 flags & AMGf_unary? " for argument" : "",
bfcb3514 2413 stash ? HvNAME_get(stash) : "null",
497b47a8 2414 fl? ",\n\tassignment variant used": "") );
ee239bfe 2415 }
497b47a8 2416#endif
748a9306
LW
2417 /* Since we use shallow copy during assignment, we need
2418 * to dublicate the contents, probably calling user-supplied
2419 * version of copy operator
2420 */
ee239bfe
IZ
2421 /* We need to copy in following cases:
2422 * a) Assignment form was called.
2423 * assignshift==1, assign==T, method + 1 == off
2424 * b) Increment or decrement, called directly.
2425 * assignshift==0, assign==0, method + 0 == off
2426 * c) Increment or decrement, translated to assignment add/subtr.
b267980d 2427 * assignshift==0, assign==T,
ee239bfe
IZ
2428 * force_cpy == T
2429 * d) Increment or decrement, translated to nomethod.
b267980d 2430 * assignshift==0, assign==0,
ee239bfe
IZ
2431 * force_cpy == T
2432 * e) Assignment form translated to nomethod.
2433 * assignshift==1, assign==T, method + 1 != off
2434 * force_cpy == T
2435 */
2436 /* off is method, method+assignshift, or a result of opcode substitution.
2437 * In the latter case assignshift==0, so only notfound case is important.
2438 */
2439 if (( (method + assignshift == off)
2440 && (assign || (method == inc_amg) || (method == dec_amg)))
2441 || force_cpy)
6f1401dc 2442 {
1b38c28e
NC
2443 /* newSVsv does not behave as advertised, so we copy missing
2444 * information by hand */
2445 SV *tmpRef = SvRV(left);
2446 SV *rv_copy;
31d632c3 2447 if (SvREFCNT(tmpRef) > 1 && (rv_copy = AMG_CALLunary(left,copy_amg))) {
1b38c28e
NC
2448 SvRV_set(left, rv_copy);
2449 SvSETMAGIC(left);
2450 SvREFCNT_dec(tmpRef);
2451 }
6f1401dc
DM
2452 }
2453
a0d0e21e
LW
2454 {
2455 dSP;
2456 BINOP myop;
2457 SV* res;
b7787f18 2458 const bool oldcatch = CATCH_GET;
a0d0e21e 2459
54310121 2460 CATCH_SET(TRUE);
a0d0e21e
LW
2461 Zero(&myop, 1, BINOP);
2462 myop.op_last = (OP *) &myop;
b37c2d43 2463 myop.op_next = NULL;
54310121 2464 myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
a0d0e21e 2465
e788e7d3 2466 PUSHSTACKi(PERLSI_OVERLOAD);
a0d0e21e 2467 ENTER;
462e5cf6 2468 SAVEOP();
533c011a 2469 PL_op = (OP *) &myop;
3280af22 2470 if (PERLDB_SUB && PL_curstash != PL_debstash)
533c011a 2471 PL_op->op_private |= OPpENTERSUB_DB;
a0d0e21e 2472 PUTBACK;
897d3989 2473 Perl_pp_pushmark(aTHX);
a0d0e21e 2474
924508f0 2475 EXTEND(SP, notfound + 5);
a0d0e21e
LW
2476 PUSHs(lr>0? right: left);
2477 PUSHs(lr>0? left: right);
3280af22 2478 PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no ));
a0d0e21e 2479 if (notfound) {
59cd0e26
NC
2480 PUSHs(newSVpvn_flags(AMG_id2name(method + assignshift),
2481 AMG_id2namelen(method + assignshift), SVs_TEMP));
a0d0e21e 2482 }
ad64d0ec 2483 PUSHs(MUTABLE_SV(cv));
a0d0e21e
LW
2484 PUTBACK;
2485
139d0ce6 2486 if ((PL_op = PL_ppaddr[OP_ENTERSUB](aTHX)))
cea2e8a9 2487 CALLRUNOPS(aTHX);
a0d0e21e
LW
2488 LEAVE;
2489 SPAGAIN;
2490
2491 res=POPs;
ebafeae7 2492 PUTBACK;
d3acc0f7 2493 POPSTACK;
54310121 2494 CATCH_SET(oldcatch);
a0d0e21e 2495
a0d0e21e 2496 if (postpr) {
b7787f18 2497 int ans;
a0d0e21e
LW
2498 switch (method) {
2499 case le_amg:
2500 case sle_amg:
2501 ans=SvIV(res)<=0; break;
2502 case lt_amg:
2503 case slt_amg:
2504 ans=SvIV(res)<0; break;
2505 case ge_amg:
2506 case sge_amg:
2507 ans=SvIV(res)>=0; break;
2508 case gt_amg:
2509 case sgt_amg:
2510 ans=SvIV(res)>0; break;
2511 case eq_amg:
2512 case seq_amg:
2513 ans=SvIV(res)==0; break;
2514 case ne_amg:
2515 case sne_amg:
2516 ans=SvIV(res)!=0; break;
2517 case inc_amg:
2518 case dec_amg:
bbce6d69 2519 SvSetSV(left,res); return left;
dc437b57 2520 case not_amg:
fe7ac86a 2521 ans=!SvTRUE(res); break;
b7787f18
AL
2522 default:
2523 ans=0; break;
a0d0e21e 2524 }
54310121 2525 return boolSV(ans);
748a9306
LW
2526 } else if (method==copy_amg) {
2527 if (!SvROK(res)) {
cea2e8a9 2528 Perl_croak(aTHX_ "Copy method did not return a reference");
748a9306
LW
2529 }
2530 return SvREFCNT_inc(SvRV(res));
a0d0e21e
LW
2531 } else {
2532 return res;
2533 }
2534 }
2535}
c9d5ac95
GS
2536
2537/*
7fc63493 2538=for apidoc is_gv_magical_sv
c9d5ac95
GS
2539
2540Returns C<TRUE> if given the name of a magical GV.
2541
2542Currently only useful internally when determining if a GV should be
2543created even in rvalue contexts.
2544
2545C<flags> is not used at present but available for future extension to
2546allow selecting particular classes of magical variable.
2547
b9b0e72c
NC
2548Currently assumes that C<name> is NUL terminated (as well as len being valid).
2549This assumption is met by all callers within the perl core, which all pass
2550pointers returned by SvPV.
2551
c9d5ac95
GS
2552=cut
2553*/
9d8f40c4 2554
c9d5ac95 2555bool
9d8f40c4 2556Perl_is_gv_magical_sv(pTHX_ SV *const name_sv, U32 flags)
c9d5ac95 2557{
9d8f40c4
NC
2558 STRLEN len;
2559 const char *const name = SvPV_const(name_sv, len);
9d4ba2ae 2560
9d8f40c4
NC
2561 PERL_UNUSED_ARG(flags);
2562 PERL_ARGS_ASSERT_IS_GV_MAGICAL_SV;
7918f24d 2563
b9b0e72c 2564 if (len > 1) {
b464bac0 2565 const char * const name1 = name + 1;
b9b0e72c
NC
2566 switch (*name) {
2567 case 'I':
f2df7081 2568 if (len == 3 && name[1] == 'S' && name[2] == 'A')
b9b0e72c
NC
2569 goto yes;
2570 break;
2571 case 'O':
9431620d 2572 if (len == 8 && strEQ(name1, "VERLOAD"))
b9b0e72c
NC
2573 goto yes;
2574 break;
2575 case 'S':
9431620d 2576 if (len == 3 && name[1] == 'I' && name[2] == 'G')
b9b0e72c
NC
2577 goto yes;
2578 break;
2579 /* Using ${^...} variables is likely to be sufficiently rare that
2580 it seems sensible to avoid the space hit of also checking the
2581 length. */
2582 case '\017': /* ${^OPEN} */
9431620d 2583 if (strEQ(name1, "PEN"))
b9b0e72c
NC
2584 goto yes;
2585 break;
2586 case '\024': /* ${^TAINT} */
9431620d 2587 if (strEQ(name1, "AINT"))
b9b0e72c
NC
2588 goto yes;
2589 break;
2590 case '\025': /* ${^UNICODE} */
9431620d 2591 if (strEQ(name1, "NICODE"))
b9b0e72c 2592 goto yes;
a0288114 2593 if (strEQ(name1, "TF8LOCALE"))
7cebcbc0 2594 goto yes;
b9b0e72c
NC
2595 break;
2596 case '\027': /* ${^WARNING_BITS} */
9431620d 2597 if (strEQ(name1, "ARNING_BITS"))
b9b0e72c
NC
2598 goto yes;
2599 break;
2600 case '1':
2601 case '2':
2602 case '3':
2603 case '4':
2604 case '5':
2605 case '6':
2606 case '7':
2607 case '8':
2608 case '9':
c9d5ac95 2609 {
7fc63493 2610 const char *end = name + len;
c9d5ac95
GS
2611 while (--end > name) {
2612 if (!isDIGIT(*end))
2613 return FALSE;
2614 }
b9b0e72c
NC
2615 goto yes;
2616 }
2617 }
2618 } else {
2619 /* Because we're already assuming that name is NUL terminated
2620 below, we can treat an empty name as "\0" */
2621 switch (*name) {
2622 case '&':
2623 case '`':
2624 case '\'':
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 '>':
b9b0e72c
NC
2640 case '\\':
2641 case '/':
2642 case '|':
2643 case '+':
2644 case ';':
2645 case ']':
2646 case '\001': /* $^A */
2647 case '\003': /* $^C */
2648 case '\004': /* $^D */
2649 case '\005': /* $^E */
2650 case '\006': /* $^F */
2651 case '\010': /* $^H */
2652 case '\011': /* $^I, NOT \t in EBCDIC */
2653 case '\014': /* $^L */
2654 case '\016': /* $^N */
2655 case '\017': /* $^O */
2656 case '\020': /* $^P */
2657 case '\023': /* $^S */
2658 case '\024': /* $^T */
2659 case '\026': /* $^V */
2660 case '\027': /* $^W */
2661 case '1':
2662 case '2':
2663 case '3':
2664 case '4':
2665 case '5':
2666 case '6':
2667 case '7':
2668 case '8':
2669 case '9':
2670 yes:
2671 return TRUE;
2672 default:
2673 break;
c9d5ac95 2674 }
c9d5ac95
GS
2675 }
2676 return FALSE;
2677}
66610fdd 2678
f5c1e807
NC
2679void
2680Perl_gv_name_set(pTHX_ GV *gv, const char *name, U32 len, U32 flags)
2681{
2682 dVAR;
acda4c6a 2683 U32 hash;
f5c1e807 2684
7918f24d 2685 PERL_ARGS_ASSERT_GV_NAME_SET;
f5c1e807
NC
2686 PERL_UNUSED_ARG(flags);
2687
acda4c6a
NC
2688 if (len > I32_MAX)
2689 Perl_croak(aTHX_ "panic: gv name too long (%"UVuf")", (UV) len);
2690
ae8cc45f
NC
2691 if (!(flags & GV_ADD) && GvNAME_HEK(gv)) {
2692 unshare_hek(GvNAME_HEK(gv));
2693 }
2694
acda4c6a 2695 PERL_HASH(hash, name, len);
9f616d01 2696 GvNAME_HEK(gv) = share_hek(name, len, hash);
f5c1e807
NC
2697}
2698
66610fdd 2699/*
f7461760
Z
2700=for apidoc gv_try_downgrade
2701
2867cdbc
Z
2702If the typeglob C<gv> can be expressed more succinctly, by having
2703something other than a real GV in its place in the stash, replace it
2704with the optimised form. Basic requirements for this are that C<gv>
2705is a real typeglob, is sufficiently ordinary, and is only referenced
2706from its package. This function is meant to be used when a GV has been
2707looked up in part to see what was there, causing upgrading, but based
2708on what was found it turns out that the real GV isn't required after all.
2709
2710If C<gv> is a completely empty typeglob, it is deleted from the stash.
2711
2712If C<gv> is a typeglob containing only a sufficiently-ordinary constant
2713sub, the typeglob is replaced with a scalar-reference placeholder that
2714more compactly represents the same thing.
f7461760
Z
2715
2716=cut
2717*/
2718
2719void
2720Perl_gv_try_downgrade(pTHX_ GV *gv)
2721{
2722 HV *stash;
2723 CV *cv;
2724 HEK *namehek;
2725 SV **gvp;
2726 PERL_ARGS_ASSERT_GV_TRY_DOWNGRADE;
95f56751
FC
2727
2728 /* XXX Why and where does this leave dangling pointers during global
2729 destruction? */
627364f1 2730 if (PL_phase == PERL_PHASE_DESTRUCT) return;
95f56751 2731
2867cdbc 2732 if (!(SvREFCNT(gv) == 1 && SvTYPE(gv) == SVt_PVGV && !SvFAKE(gv) &&
803f2748 2733 !SvOBJECT(gv) && !SvREADONLY(gv) &&
f7461760 2734 isGV_with_GP(gv) && GvGP(gv) &&
2867cdbc 2735 !GvINTRO(gv) && GvREFCNT(gv) == 1 &&
f7461760 2736 !GvSV(gv) && !GvAV(gv) && !GvHV(gv) && !GvIOp(gv) && !GvFORM(gv) &&
099be4f1 2737 GvEGVx(gv) == gv && (stash = GvSTASH(gv))))
2867cdbc 2738 return;
803f2748
DM
2739 if (SvMAGICAL(gv)) {
2740 MAGIC *mg;
2741 /* only backref magic is allowed */
2742 if (SvGMAGICAL(gv) || SvSMAGICAL(gv))
2743 return;
2744 for (mg = SvMAGIC(gv); mg; mg = mg->mg_moremagic) {
2745 if (mg->mg_type != PERL_MAGIC_backref)
2746 return;
2747 }
2748 }
2867cdbc
Z
2749 cv = GvCV(gv);
2750 if (!cv) {
2751 HEK *gvnhek = GvNAME_HEK(gv);
2752 (void)hv_delete(stash, HEK_KEY(gvnhek),
2753 HEK_UTF8(gvnhek) ? -HEK_LEN(gvnhek) : HEK_LEN(gvnhek), G_DISCARD);
2754 } else if (GvMULTI(gv) && cv &&
f7461760
Z
2755 !SvOBJECT(cv) && !SvMAGICAL(cv) && !SvREADONLY(cv) &&
2756 CvSTASH(cv) == stash && CvGV(cv) == gv &&
2757 CvCONST(cv) && !CvMETHOD(cv) && !CvLVALUE(cv) && !CvUNIQUE(cv) &&
2758 !CvNODEBUG(cv) && !CvCLONE(cv) && !CvCLONED(cv) && !CvANON(cv) &&
2759 (namehek = GvNAME_HEK(gv)) &&
2760 (gvp = hv_fetch(stash, HEK_KEY(namehek),
2761 HEK_LEN(namehek)*(HEK_UTF8(namehek) ? -1 : 1), 0)) &&
2762 *gvp == (SV*)gv) {
2763 SV *value = SvREFCNT_inc(CvXSUBANY(cv).any_ptr);
2764 SvREFCNT(gv) = 0;
2765 sv_clear((SV*)gv);
2766 SvREFCNT(gv) = 1;
2767 SvFLAGS(gv) = SVt_IV|SVf_ROK;
2768 SvANY(gv) = (XPVGV*)((char*)&(gv->sv_u.svu_iv) -
2769 STRUCT_OFFSET(XPVIV, xiv_iv));
2770 SvRV_set(gv, value);
2771 }
2772}
2773
2774/*
66610fdd
RGS
2775 * Local variables:
2776 * c-indentation-style: bsd
2777 * c-basic-offset: 4
2778 * indent-tabs-mode: t
2779 * End:
2780 *
37442d52
RGS
2781 * ex: set ts=8 sts=4 sw=4 noet:
2782 */