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