This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Make my_exit behave the same as the Perl exit. And add tests for it
[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 */
cea2e8a9 1064 Perl_warn(aTHX_ "Variable \"%c%s\" is not imported",
4633a7c4
LW
1065 sv_type == SVt_PVAV ? '@' :
1066 sv_type == SVt_PVHV ? '%' : '$',
1067 name);
8ebc5c01 1068 if (GvCVu(*gvp))
cc507455 1069 Perl_warn(aTHX_ "\t(Did you mean &%s instead?)\n", name);
d4c19fe8 1070 stash = NULL;
4633a7c4 1071 }
a0d0e21e 1072 }
85e6fe83 1073 }
463ee0b2 1074 else
1d7c1841 1075 stash = CopSTASH(PL_curcop);
463ee0b2
LW
1076 }
1077 else
3280af22 1078 stash = PL_defstash;
463ee0b2
LW
1079 }
1080
1081 /* By this point we should have a stash and a name */
1082
a0d0e21e 1083 if (!stash) {
5a844595 1084 if (add) {
9d4ba2ae 1085 SV * const err = Perl_mess(aTHX_
5a844595
GS
1086 "Global symbol \"%s%s\" requires explicit package name",
1087 (sv_type == SVt_PV ? "$"
1088 : sv_type == SVt_PVAV ? "@"
1089 : sv_type == SVt_PVHV ? "%"
608b3986 1090 : ""), name);
e7f343b6 1091 GV *gv;
608b3986
AE
1092 if (USE_UTF8_IN_NAMES)
1093 SvUTF8_on(err);
1094 qerror(err);
76f68e9b 1095 gv = gv_fetchpvs("<none>::", GV_ADDMULTI, SVt_PVHV);
e7f343b6
NC
1096 if(!gv) {
1097 /* symbol table under destruction */
1098 return NULL;
1099 }
1100 stash = GvHV(gv);
a0d0e21e 1101 }
d7aacf4e 1102 else
a0714e2c 1103 return NULL;
a0d0e21e
LW
1104 }
1105
1106 if (!SvREFCNT(stash)) /* symbol table under destruction */
a0714e2c 1107 return NULL;
a0d0e21e 1108
79072805 1109 gvp = (GV**)hv_fetch(stash,name,len,add);
159b6efe 1110 if (!gvp || *gvp == (const GV *)&PL_sv_undef)
a0714e2c 1111 return NULL;
79072805
LW
1112 gv = *gvp;
1113 if (SvTYPE(gv) == SVt_PVGV) {
a0d0e21e 1114 if (add) {
a5f75d66 1115 GvMULTI_on(gv);
a0d0e21e 1116 gv_init_sv(gv, sv_type);
45cbc99a 1117 if (len == 1 && (sv_type == SVt_PVHV || sv_type == SVt_PVGV)) {
44a2ac75
YO
1118 if (*name == '!')
1119 require_tie_mod(gv, "!", newSVpvs("Errno"), "TIEHASH", 1);
45cbc99a 1120 else if (*name == '-' || *name == '+')
192b9cd1 1121 require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "TIEHASH", 0);
45cbc99a 1122 }
a0d0e21e 1123 }
79072805 1124 return gv;
add2581e 1125 } else if (no_init) {
55d729e4 1126 return gv;
e26df76a
NC
1127 } else if (no_expand && SvROK(gv)) {
1128 return gv;
79072805 1129 }
93a17b20 1130
5e0caaeb
NC
1131 /* Adding a new symbol.
1132 Unless of course there was already something non-GV here, in which case
1133 we want to behave as if there was always a GV here, containing some sort
1134 of subroutine.
1135 Otherwise we run the risk of creating things like GvIO, which can cause
1136 subtle bugs. eg the one that tripped up SQL::Translator */
1137
1138 faking_it = SvOK(gv);
93a17b20 1139
9b387841
NC
1140 if (add & GV_ADDWARN)
1141 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "Had to create %s unexpectedly", nambeg);
55d729e4 1142 gv_init(gv, stash, name, len, add & GV_ADDMULTI);
5e0caaeb 1143 gv_init_sv(gv, faking_it ? SVt_PVCV : sv_type);
93a17b20 1144
a0288114 1145 if (isALPHA(name[0]) && ! (isLEXWARN_on ? ckWARN(WARN_ONCE)
7272584d 1146 : (PL_dowarn & G_WARN_ON ) ) )
0453d815
PM
1147 GvMULTI_on(gv) ;
1148
93a17b20 1149 /* set up magic where warranted */
cc4c2da6 1150 if (len > 1) {
9431620d 1151#ifndef EBCDIC
cc4c2da6 1152 if (*name > 'V' ) {
6f207bd3 1153 NOOP;
cc4c2da6 1154 /* Nothing else to do.
91f565cb 1155 The compiler will probably turn the switch statement into a
cc4c2da6
NC
1156 branch table. Make sure we avoid even that small overhead for
1157 the common case of lower case variable names. */
9431620d
NC
1158 } else
1159#endif
1160 {
b464bac0 1161 const char * const name2 = name + 1;
cc4c2da6
NC
1162 switch (*name) {
1163 case 'A':
1164 if (strEQ(name2, "RGV")) {
1165 IoFLAGS(GvIOn(gv)) |= IOf_ARGV|IOf_START;
1166 }
7b8203e3
YST
1167 else if (strEQ(name2, "RGVOUT")) {
1168 GvMULTI_on(gv);
1169 }
cc4c2da6
NC
1170 break;
1171 case 'E':
1172 if (strnEQ(name2, "XPORT", 5))
1173 GvMULTI_on(gv);
1174 break;
1175 case 'I':
1176 if (strEQ(name2, "SA")) {
9d4ba2ae 1177 AV* const av = GvAVn(gv);
cc4c2da6 1178 GvMULTI_on(gv);
ad64d0ec
NC
1179 sv_magic(MUTABLE_SV(av), MUTABLE_SV(gv), PERL_MAGIC_isa,
1180 NULL, 0);
cc4c2da6
NC
1181 /* NOTE: No support for tied ISA */
1182 if ((add & GV_ADDMULTI) && strEQ(nambeg,"AnyDBM_File::ISA")
1183 && AvFILLp(av) == -1)
1184 {
e84ce9a2
MHM
1185 av_push(av, newSVpvs("NDBM_File"));
1186 gv_stashpvs("NDBM_File", GV_ADD);
1187 av_push(av, newSVpvs("DB_File"));
1188 gv_stashpvs("DB_File", GV_ADD);
1189 av_push(av, newSVpvs("GDBM_File"));
1190 gv_stashpvs("GDBM_File", GV_ADD);
1191 av_push(av, newSVpvs("SDBM_File"));
1192 gv_stashpvs("SDBM_File", GV_ADD);
1193 av_push(av, newSVpvs("ODBM_File"));
1194 gv_stashpvs("ODBM_File", GV_ADD);
cc4c2da6
NC
1195 }
1196 }
1197 break;
1198 case 'O':
1199 if (strEQ(name2, "VERLOAD")) {
9d4ba2ae 1200 HV* const hv = GvHVn(gv);
cc4c2da6 1201 GvMULTI_on(gv);
a0714e2c 1202 hv_magic(hv, NULL, PERL_MAGIC_overload);
cc4c2da6
NC
1203 }
1204 break;
1205 case 'S':
1206 if (strEQ(name2, "IG")) {
1207 HV *hv;
1208 I32 i;
d525a7b2
NC
1209 if (!PL_psig_name) {
1210 Newxz(PL_psig_name, 2 * SIG_SIZE, SV*);
a02a5408 1211 Newxz(PL_psig_pend, SIG_SIZE, int);
d525a7b2 1212 PL_psig_ptr = PL_psig_name + SIG_SIZE;
0bdedcb3
NC
1213 } else {
1214 /* I think that the only way to get here is to re-use an
1215 embedded perl interpreter, where the previous
1216 use didn't clean up fully because
1217 PL_perl_destruct_level was 0. I'm not sure that we
1218 "support" that, in that I suspect in that scenario
1219 there are sufficient other garbage values left in the
1220 interpreter structure that something else will crash
1221 before we get here. I suspect that this is one of
1222 those "doctor, it hurts when I do this" bugs. */
d525a7b2 1223 Zero(PL_psig_name, 2 * SIG_SIZE, SV*);
0bdedcb3 1224 Zero(PL_psig_pend, SIG_SIZE, int);
cc4c2da6
NC
1225 }
1226 GvMULTI_on(gv);
1227 hv = GvHVn(gv);
a0714e2c 1228 hv_magic(hv, NULL, PERL_MAGIC_sig);
cc4c2da6 1229 for (i = 1; i < SIG_SIZE; i++) {
551405c4 1230 SV * const * const init = hv_fetch(hv, PL_sig_name[i], strlen(PL_sig_name[i]), 1);
cc4c2da6
NC
1231 if (init)
1232 sv_setsv(*init, &PL_sv_undef);
cc4c2da6
NC
1233 }
1234 }
1235 break;
1236 case 'V':
1237 if (strEQ(name2, "ERSION"))
1238 GvMULTI_on(gv);
1239 break;
e5218da5
GA
1240 case '\003': /* $^CHILD_ERROR_NATIVE */
1241 if (strEQ(name2, "HILD_ERROR_NATIVE"))
1242 goto magicalize;
1243 break;
cc4c2da6
NC
1244 case '\005': /* $^ENCODING */
1245 if (strEQ(name2, "NCODING"))
1246 goto magicalize;
1247 break;
cde0cee5
YO
1248 case '\015': /* $^MATCH */
1249 if (strEQ(name2, "ATCH"))
2fdbfb4d 1250 goto magicalize;
cc4c2da6
NC
1251 case '\017': /* $^OPEN */
1252 if (strEQ(name2, "PEN"))
1253 goto magicalize;
1254 break;
cde0cee5
YO
1255 case '\020': /* $^PREMATCH $^POSTMATCH */
1256 if (strEQ(name2, "REMATCH") || strEQ(name2, "OSTMATCH"))
2fdbfb4d 1257 goto magicalize;
cc4c2da6
NC
1258 case '\024': /* ${^TAINT} */
1259 if (strEQ(name2, "AINT"))
1260 goto ro_magicalize;
1261 break;
7cebcbc0 1262 case '\025': /* ${^UNICODE}, ${^UTF8LOCALE} */
a0288114 1263 if (strEQ(name2, "NICODE"))
cc4c2da6 1264 goto ro_magicalize;
a0288114 1265 if (strEQ(name2, "TF8LOCALE"))
7cebcbc0 1266 goto ro_magicalize;
e07ea26a
NC
1267 if (strEQ(name2, "TF8CACHE"))
1268 goto magicalize;
cc4c2da6
NC
1269 break;
1270 case '\027': /* $^WARNING_BITS */
1271 if (strEQ(name2, "ARNING_BITS"))
1272 goto magicalize;
1273 break;
1274 case '1':
1275 case '2':
1276 case '3':
1277 case '4':
1278 case '5':
1279 case '6':
1280 case '7':
1281 case '8':
1282 case '9':
85e6fe83 1283 {
2fdbfb4d
AB
1284 /* Ensures that we have an all-digit variable, ${"1foo"} fails
1285 this test */
1286 /* This snippet is taken from is_gv_magical */
cc4c2da6
NC
1287 const char *end = name + len;
1288 while (--end > name) {
2fdbfb4d 1289 if (!isDIGIT(*end)) return gv;
cc4c2da6 1290 }
2fdbfb4d 1291 goto magicalize;
1d7c1841 1292 }
dc437b57 1293 }
93a17b20 1294 }
392db708
NC
1295 } else {
1296 /* Names of length 1. (Or 0. But name is NUL terminated, so that will
1297 be case '\0' in this switch statement (ie a default case) */
cc4c2da6
NC
1298 switch (*name) {
1299 case '&':
1300 case '`':
1301 case '\'':
1302 if (
1303 sv_type == SVt_PVAV ||
1304 sv_type == SVt_PVHV ||
1305 sv_type == SVt_PVCV ||
1306 sv_type == SVt_PVFM ||
1307 sv_type == SVt_PVIO
1308 ) { break; }
1309 PL_sawampersand = TRUE;
2fdbfb4d 1310 goto magicalize;
cc4c2da6
NC
1311
1312 case ':':
c69033f2 1313 sv_setpv(GvSVn(gv),PL_chopset);
cc4c2da6
NC
1314 goto magicalize;
1315
1316 case '?':
ff0cee69 1317#ifdef COMPLEX_STATUS
c69033f2 1318 SvUPGRADE(GvSVn(gv), SVt_PVLV);
ff0cee69 1319#endif
cc4c2da6 1320 goto magicalize;
ff0cee69 1321
cc4c2da6 1322 case '!':
67261566 1323 GvMULTI_on(gv);
44a2ac75 1324 /* If %! has been used, automatically load Errno.pm. */
d2c93421 1325
ad64d0ec 1326 sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
d2c93421 1327
44a2ac75 1328 /* magicalization must be done before require_tie_mod is called */
67261566 1329 if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
44a2ac75 1330 require_tie_mod(gv, "!", newSVpvs("Errno"), "TIEHASH", 1);
d2c93421 1331
6cef1e77 1332 break;
cc4c2da6 1333 case '-':
44a2ac75
YO
1334 case '+':
1335 GvMULTI_on(gv); /* no used once warnings here */
1336 {
44a2ac75 1337 AV* const av = GvAVn(gv);
ad64d0ec 1338 SV* const avc = (*name == '+') ? MUTABLE_SV(av) : NULL;
44a2ac75 1339
ad64d0ec
NC
1340 sv_magic(MUTABLE_SV(av), avc, PERL_MAGIC_regdata, NULL, 0);
1341 sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
67261566 1342 if (avc)
44a2ac75 1343 SvREADONLY_on(GvSVn(gv));
44a2ac75 1344 SvREADONLY_on(av);
67261566
YO
1345
1346 if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
192b9cd1 1347 require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "TIEHASH", 0);
67261566 1348
80305961 1349 break;
cc4c2da6
NC
1350 }
1351 case '*':
cc4c2da6 1352 case '#':
9b387841
NC
1353 if (sv_type == SVt_PV)
1354 Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
1355 "$%c is no longer supported", *name);
8ae1fe26 1356 break;
cc4c2da6 1357 case '|':
c69033f2 1358 sv_setiv(GvSVn(gv), (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0);
cc4c2da6
NC
1359 goto magicalize;
1360
b3ca2e83
NC
1361 case '\010': /* $^H */
1362 {
1363 HV *const hv = GvHVn(gv);
1364 hv_magic(hv, NULL, PERL_MAGIC_hints);
1365 }
1366 goto magicalize;
cc4c2da6 1367 case '\023': /* $^S */
2fdbfb4d
AB
1368 ro_magicalize:
1369 SvREADONLY_on(GvSVn(gv));
1370 /* FALL THROUGH */
e69c155a 1371 case '0':
cc4c2da6
NC
1372 case '1':
1373 case '2':
1374 case '3':
1375 case '4':
1376 case '5':
1377 case '6':
1378 case '7':
1379 case '8':
1380 case '9':
cc4c2da6
NC
1381 case '[':
1382 case '^':
1383 case '~':
1384 case '=':
1385 case '%':
1386 case '.':
1387 case '(':
1388 case ')':
1389 case '<':
1390 case '>':
cc4c2da6
NC
1391 case '\\':
1392 case '/':
1393 case '\001': /* $^A */
1394 case '\003': /* $^C */
1395 case '\004': /* $^D */
1396 case '\005': /* $^E */
1397 case '\006': /* $^F */
cc4c2da6
NC
1398 case '\011': /* $^I, NOT \t in EBCDIC */
1399 case '\016': /* $^N */
1400 case '\017': /* $^O */
1401 case '\020': /* $^P */
1402 case '\024': /* $^T */
1403 case '\027': /* $^W */
1404 magicalize:
ad64d0ec 1405 sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
cc4c2da6 1406 break;
e521374c 1407
cc4c2da6 1408 case '\014': /* $^L */
76f68e9b 1409 sv_setpvs(GvSVn(gv),"\f");
c69033f2 1410 PL_formfeed = GvSVn(gv);
463ee0b2 1411 break;
cc4c2da6 1412 case ';':
76f68e9b 1413 sv_setpvs(GvSVn(gv),"\034");
463ee0b2 1414 break;
cc4c2da6
NC
1415 case ']':
1416 {
c69033f2 1417 SV * const sv = GvSVn(gv);
d7aa5382 1418 if (!sv_derived_from(PL_patchlevel, "version"))
ac0e6a2f 1419 upg_version(PL_patchlevel, TRUE);
7d54d38e
SH
1420 GvSV(gv) = vnumify(PL_patchlevel);
1421 SvREADONLY_on(GvSV(gv));
1422 SvREFCNT_dec(sv);
93a17b20
LW
1423 }
1424 break;
cc4c2da6
NC
1425 case '\026': /* $^V */
1426 {
c69033f2 1427 SV * const sv = GvSVn(gv);
f9be5ac8
DM
1428 GvSV(gv) = new_version(PL_patchlevel);
1429 SvREADONLY_on(GvSV(gv));
1430 SvREFCNT_dec(sv);
16070b82
GS
1431 }
1432 break;
cc4c2da6 1433 }
79072805 1434 }
93a17b20 1435 return gv;
79072805
LW
1436}
1437
1438void
35a4481c 1439Perl_gv_fullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
43693395 1440{
35a4481c 1441 const char *name;
7423f6db 1442 STRLEN namelen;
35a4481c 1443 const HV * const hv = GvSTASH(gv);
7918f24d
NC
1444
1445 PERL_ARGS_ASSERT_GV_FULLNAME4;
1446
43693395 1447 if (!hv) {
0c34ef67 1448 SvOK_off(sv);
43693395
GS
1449 return;
1450 }
666ea192 1451 sv_setpv(sv, prefix ? prefix : "");
a0288114 1452
bfcb3514 1453 name = HvNAME_get(hv);
7423f6db
NC
1454 if (name) {
1455 namelen = HvNAMELEN_get(hv);
1456 } else {
e27ad1f2 1457 name = "__ANON__";
7423f6db
NC
1458 namelen = 8;
1459 }
a0288114 1460
e27ad1f2 1461 if (keepmain || strNE(name, "main")) {
7423f6db 1462 sv_catpvn(sv,name,namelen);
396482e1 1463 sv_catpvs(sv,"::");
43693395 1464 }
257984c0 1465 sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv));
43693395
GS
1466}
1467
1468void
35a4481c 1469Perl_gv_efullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
43693395 1470{
46c461b5 1471 const GV * const egv = GvEGV(gv);
7918f24d
NC
1472
1473 PERL_ARGS_ASSERT_GV_EFULLNAME4;
1474
46c461b5 1475 gv_fullname4(sv, egv ? egv : gv, prefix, keepmain);
43693395
GS
1476}
1477
79072805 1478void
1146e912 1479Perl_gv_check(pTHX_ const HV *stash)
79072805 1480{
97aff369 1481 dVAR;
79072805 1482 register I32 i;
463ee0b2 1483
7918f24d
NC
1484 PERL_ARGS_ASSERT_GV_CHECK;
1485
8990e307
LW
1486 if (!HvARRAY(stash))
1487 return;
a0d0e21e 1488 for (i = 0; i <= (I32) HvMAX(stash); i++) {
e1ec3a88 1489 const HE *entry;
dc437b57 1490 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
b7787f18
AL
1491 register GV *gv;
1492 HV *hv;
dc437b57 1493 if (HeKEY(entry)[HeKLEN(entry)-1] == ':' &&
159b6efe 1494 (gv = MUTABLE_GV(HeVAL(entry))) && isGV(gv) && (hv = GvHV(gv)))
a0d0e21e 1495 {
19b6c847 1496 if (hv != PL_defstash && hv != stash)
a0d0e21e
LW
1497 gv_check(hv); /* nested package */
1498 }
dc437b57 1499 else if (isALPHA(*HeKEY(entry))) {
e1ec3a88 1500 const char *file;
159b6efe 1501 gv = MUTABLE_GV(HeVAL(entry));
55d729e4 1502 if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv))
463ee0b2 1503 continue;
1d7c1841 1504 file = GvFILE(gv);
1d7c1841
GS
1505 CopLINE_set(PL_curcop, GvLINE(gv));
1506#ifdef USE_ITHREADS
dd374669 1507 CopFILE(PL_curcop) = (char *)file; /* set for warning */
1d7c1841 1508#else
9bde8eb0
NC
1509 CopFILEGV(PL_curcop)
1510 = gv_fetchfile_flags(file, HEK_LEN(GvFILE_HEK(gv)), 0);
1d7c1841 1511#endif
9014280d 1512 Perl_warner(aTHX_ packWARN(WARN_ONCE),
599cee73 1513 "Name \"%s::%s\" used only once: possible typo",
bfcb3514 1514 HvNAME_get(stash), GvNAME(gv));
463ee0b2 1515 }
79072805
LW
1516 }
1517 }
1518}
1519
1520GV *
e1ec3a88 1521Perl_newGVgen(pTHX_ const char *pack)
79072805 1522{
97aff369 1523 dVAR;
7918f24d
NC
1524
1525 PERL_ARGS_ASSERT_NEWGVGEN;
1526
cea2e8a9 1527 return gv_fetchpv(Perl_form(aTHX_ "%s::_GEN_%ld", pack, (long)PL_gensym++),
6fd99bb3 1528 GV_ADD, SVt_PVGV);
79072805
LW
1529}
1530
1531/* hopefully this is only called on local symbol table entries */
1532
1533GP*
864dbfa3 1534Perl_gp_ref(pTHX_ GP *gp)
79072805 1535{
97aff369 1536 dVAR;
1d7c1841 1537 if (!gp)
d4c19fe8 1538 return NULL;
79072805 1539 gp->gp_refcnt++;
44a8e56a
PP
1540 if (gp->gp_cv) {
1541 if (gp->gp_cvgen) {
e1a479c5
BB
1542 /* If the GP they asked for a reference to contains
1543 a method cache entry, clear it first, so that we
1544 don't infect them with our cached entry */
44a8e56a 1545 SvREFCNT_dec(gp->gp_cv);
601f1833 1546 gp->gp_cv = NULL;
44a8e56a
PP
1547 gp->gp_cvgen = 0;
1548 }
44a8e56a 1549 }
79072805 1550 return gp;
79072805
LW
1551}
1552
1553void
864dbfa3 1554Perl_gp_free(pTHX_ GV *gv)
79072805 1555{
97aff369 1556 dVAR;
79072805
LW
1557 GP* gp;
1558
f7877b28 1559 if (!gv || !isGV_with_GP(gv) || !(gp = GvGP(gv)))
79072805 1560 return;
f248d071 1561 if (gp->gp_refcnt == 0) {
9b387841
NC
1562 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
1563 "Attempt to free unreferenced glob pointers"
1564 pTHX__FORMAT pTHX__VALUE);
79072805
LW
1565 return;
1566 }
748a9306
LW
1567 if (--gp->gp_refcnt > 0) {
1568 if (gp->gp_egv == gv)
1569 gp->gp_egv = 0;
dd38834b 1570 GvGP(gv) = 0;
79072805 1571 return;
748a9306 1572 }
79072805 1573
c9ce39a9
RGS
1574 if (gp->gp_file_hek)
1575 unshare_hek(gp->gp_file_hek);
c9da69fb
AL
1576 SvREFCNT_dec(gp->gp_sv);
1577 SvREFCNT_dec(gp->gp_av);
bfcb3514
NC
1578 /* FIXME - another reference loop GV -> symtab -> GV ?
1579 Somehow gp->gp_hv can end up pointing at freed garbage. */
1580 if (gp->gp_hv && SvTYPE(gp->gp_hv) == SVt_PVHV) {
bfcb3514
NC
1581 const char *hvname = HvNAME_get(gp->gp_hv);
1582 if (PL_stashcache && hvname)
04fe65b0 1583 (void)hv_delete(PL_stashcache, hvname, HvNAMELEN_get(gp->gp_hv),
7423f6db 1584 G_DISCARD);
bfcb3514 1585 SvREFCNT_dec(gp->gp_hv);
13207a71 1586 }
c9da69fb
AL
1587 SvREFCNT_dec(gp->gp_io);
1588 SvREFCNT_dec(gp->gp_cv);
1589 SvREFCNT_dec(gp->gp_form);
748a9306 1590
79072805
LW
1591 Safefree(gp);
1592 GvGP(gv) = 0;
1593}
1594
d460ef45
NIS
1595int
1596Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg)
1597{
53c1dcc0
AL
1598 AMT * const amtp = (AMT*)mg->mg_ptr;
1599 PERL_UNUSED_ARG(sv);
dd374669 1600
7918f24d
NC
1601 PERL_ARGS_ASSERT_MAGIC_FREEOVRLD;
1602
d460ef45
NIS
1603 if (amtp && AMT_AMAGIC(amtp)) {
1604 int i;
1605 for (i = 1; i < NofAMmeth; i++) {
53c1dcc0 1606 CV * const cv = amtp->table[i];
b37c2d43 1607 if (cv) {
ad64d0ec 1608 SvREFCNT_dec(MUTABLE_SV(cv));
601f1833 1609 amtp->table[i] = NULL;
d460ef45
NIS
1610 }
1611 }
1612 }
1613 return 0;
1614}
1615
a0d0e21e 1616/* Updates and caches the CV's */
c3a9a790
RGS
1617/* Returns:
1618 * 1 on success and there is some overload
1619 * 0 if there is no overload
1620 * -1 if some error occurred and it couldn't croak
1621 */
a0d0e21e 1622
c3a9a790 1623int
242f8760 1624Perl_Gv_AMupdate(pTHX_ HV *stash, bool destructing)
a0d0e21e 1625{
97aff369 1626 dVAR;
ad64d0ec 1627 MAGIC* const mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
a6006777 1628 AMT amt;
9b439311 1629 const struct mro_meta* stash_meta = HvMROMETA(stash);
e1a479c5 1630 U32 newgen;
a0d0e21e 1631
7918f24d
NC
1632 PERL_ARGS_ASSERT_GV_AMUPDATE;
1633
9b439311 1634 newgen = PL_sub_generation + stash_meta->pkg_gen + stash_meta->cache_gen;
14899595
NC
1635 if (mg) {
1636 const AMT * const amtp = (AMT*)mg->mg_ptr;
1637 if (amtp->was_ok_am == PL_amagic_generation
e1a479c5 1638 && amtp->was_ok_sub == newgen) {
c3a9a790 1639 return AMT_OVERLOADED(amtp) ? 1 : 0;
14899595 1640 }
ad64d0ec 1641 sv_unmagic(MUTABLE_SV(stash), PERL_MAGIC_overload_table);
14899595 1642 }
a0d0e21e 1643
bfcb3514 1644 DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME_get(stash)) );
a0d0e21e 1645
d460ef45 1646 Zero(&amt,1,AMT);
3280af22 1647 amt.was_ok_am = PL_amagic_generation;
e1a479c5 1648 amt.was_ok_sub = newgen;
a6006777
PP
1649 amt.fallback = AMGfallNO;
1650 amt.flags = 0;
1651
a6006777 1652 {
32251b26
IZ
1653 int filled = 0, have_ovl = 0;
1654 int i, lim = 1;
a6006777 1655
22c35a8c 1656 /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
a6006777 1657
89ffc314 1658 /* Try to find via inheritance. */
53c1dcc0
AL
1659 GV *gv = gv_fetchmeth(stash, PL_AMG_names[0], 2, -1);
1660 SV * const sv = gv ? GvSV(gv) : NULL;
1661 CV* cv;
89ffc314
IZ
1662
1663 if (!gv)
32251b26 1664 lim = DESTROY_amg; /* Skip overloading entries. */
c69033f2
NC
1665#ifdef PERL_DONT_CREATE_GVSV
1666 else if (!sv) {
6f207bd3 1667 NOOP; /* Equivalent to !SvTRUE and !SvOK */
c69033f2
NC
1668 }
1669#endif
89ffc314
IZ
1670 else if (SvTRUE(sv))
1671 amt.fallback=AMGfallYES;
1672 else if (SvOK(sv))
1673 amt.fallback=AMGfallNEVER;
a6006777 1674
32251b26 1675 for (i = 1; i < lim; i++)
601f1833 1676 amt.table[i] = NULL;
32251b26 1677 for (; i < NofAMmeth; i++) {
6136c704 1678 const char * const cooky = PL_AMG_names[i];
32251b26 1679 /* Human-readable form, for debugging: */
6136c704 1680 const char * const cp = (i >= DESTROY_amg ? cooky : AMG_id2name(i));
d279ab82 1681 const STRLEN l = PL_AMG_namelens[i];
89ffc314 1682
a0288114 1683 DEBUG_o( Perl_deb(aTHX_ "Checking overloading of \"%s\" in package \"%.256s\"\n",
bfcb3514 1684 cp, HvNAME_get(stash)) );
611c1e95
IZ
1685 /* don't fill the cache while looking up!
1686 Creation of inheritance stubs in intermediate packages may
1687 conflict with the logic of runtime method substitution.
1688 Indeed, for inheritance A -> B -> C, if C overloads "+0",
1689 then we could have created stubs for "(+0" in A and C too.
1690 But if B overloads "bool", we may want to use it for
1691 numifying instead of C's "+0". */
1692 if (i >= DESTROY_amg)
1693 gv = Perl_gv_fetchmeth_autoload(aTHX_ stash, cooky, l, 0);
1694 else /* Autoload taken care of below */
1695 gv = Perl_gv_fetchmeth(aTHX_ stash, cooky, l, -1);
46fc3d4c 1696 cv = 0;
89ffc314 1697 if (gv && (cv = GvCV(gv))) {
bfcb3514 1698 const char *hvname;
44a8e56a 1699 if (GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")
bfcb3514 1700 && strEQ(hvname = HvNAME_get(GvSTASH(CvGV(cv))), "overload")) {
611c1e95
IZ
1701 /* This is a hack to support autoloading..., while
1702 knowing *which* methods were declared as overloaded. */
44a8e56a 1703 /* GvSV contains the name of the method. */
6136c704 1704 GV *ngv = NULL;
c69033f2 1705 SV *gvsv = GvSV(gv);
a0288114
AL
1706
1707 DEBUG_o( Perl_deb(aTHX_ "Resolving method \"%"SVf256\
1708 "\" for overloaded \"%s\" in package \"%.256s\"\n",
ca0270c4 1709 (void*)GvSV(gv), cp, hvname) );
c69033f2
NC
1710 if (!gvsv || !SvPOK(gvsv)
1711 || !(ngv = gv_fetchmethod_autoload(stash, SvPVX_const(gvsv),
dc848c6f
PP
1712 FALSE)))
1713 {
a0288114 1714 /* Can be an import stub (created by "can"). */
242f8760 1715 if (destructing) {
c3a9a790 1716 return -1;
242f8760
RGS
1717 }
1718 else {
1719 const char * const name = (gvsv && SvPOK(gvsv)) ? SvPVX_const(gvsv) : "???";
1720 Perl_croak(aTHX_ "%s method \"%.256s\" overloading \"%s\" "\
1721 "in package \"%.256s\"",
1722 (GvCVGEN(gv) ? "Stub found while resolving"
1723 : "Can't resolve"),
1724 name, cp, hvname);
1725 }
44a8e56a 1726 }
dc848c6f 1727 cv = GvCV(gv = ngv);
44a8e56a 1728 }
b464bac0 1729 DEBUG_o( Perl_deb(aTHX_ "Overloading \"%s\" in package \"%.256s\" via \"%.256s::%.256s\"\n",
bfcb3514 1730 cp, HvNAME_get(stash), HvNAME_get(GvSTASH(CvGV(cv))),
44a8e56a
PP
1731 GvNAME(CvGV(cv))) );
1732 filled = 1;
32251b26
IZ
1733 if (i < DESTROY_amg)
1734 have_ovl = 1;
611c1e95 1735 } else if (gv) { /* Autoloaded... */
ea726b52 1736 cv = MUTABLE_CV(gv);
611c1e95 1737 filled = 1;
44a8e56a 1738 }
ea726b52 1739 amt.table[i]=MUTABLE_CV(SvREFCNT_inc_simple(cv));
a0d0e21e 1740 }
a0d0e21e 1741 if (filled) {
a6006777 1742 AMT_AMAGIC_on(&amt);
32251b26
IZ
1743 if (have_ovl)
1744 AMT_OVERLOADED_on(&amt);
ad64d0ec 1745 sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table,
14befaf4 1746 (char*)&amt, sizeof(AMT));
32251b26 1747 return have_ovl;
a0d0e21e
LW
1748 }
1749 }
a6006777 1750 /* Here we have no table: */
9cbac4c7 1751 /* no_table: */
a6006777 1752 AMT_AMAGIC_off(&amt);
ad64d0ec 1753 sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table,
14befaf4 1754 (char*)&amt, sizeof(AMTS));
c3a9a790 1755 return 0;
a0d0e21e
LW
1756}
1757
32251b26
IZ
1758
1759CV*
1760Perl_gv_handler(pTHX_ HV *stash, I32 id)
1761{
97aff369 1762 dVAR;
3f8f4626 1763 MAGIC *mg;
32251b26 1764 AMT *amtp;
e1a479c5 1765 U32 newgen;
9b439311 1766 struct mro_meta* stash_meta;
32251b26 1767
bfcb3514 1768 if (!stash || !HvNAME_get(stash))
601f1833 1769 return NULL;
e1a479c5 1770
9b439311
BB
1771 stash_meta = HvMROMETA(stash);
1772 newgen = PL_sub_generation + stash_meta->pkg_gen + stash_meta->cache_gen;
e1a479c5 1773
ad64d0ec 1774 mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
32251b26
IZ
1775 if (!mg) {
1776 do_update:
242f8760
RGS
1777 /* If we're looking up a destructor to invoke, we must avoid
1778 * that Gv_AMupdate croaks, because we might be dying already */
c3a9a790 1779 if (Gv_AMupdate(stash, id == DESTROY_amg) == -1) {
242f8760
RGS
1780 /* and if it didn't found a destructor, we fall back
1781 * to a simpler method that will only look for the
1782 * destructor instead of the whole magic */
1783 if (id == DESTROY_amg) {
1784 GV * const gv = gv_fetchmethod(stash, "DESTROY");
1785 if (gv)
1786 return GvCV(gv);
1787 }
1788 return NULL;
1789 }
ad64d0ec 1790 mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
32251b26 1791 }
a9fd4e40 1792 assert(mg);
32251b26
IZ
1793 amtp = (AMT*)mg->mg_ptr;
1794 if ( amtp->was_ok_am != PL_amagic_generation
e1a479c5 1795 || amtp->was_ok_sub != newgen )
32251b26 1796 goto do_update;
3ad83ce7 1797 if (AMT_AMAGIC(amtp)) {
b7787f18 1798 CV * const ret = amtp->table[id];
3ad83ce7
AMS
1799 if (ret && isGV(ret)) { /* Autoloading stab */
1800 /* Passing it through may have resulted in a warning
1801 "Inherited AUTOLOAD for a non-method deprecated", since
1802 our caller is going through a function call, not a method call.
1803 So return the CV for AUTOLOAD, setting $AUTOLOAD. */
890ce7af 1804 GV * const gv = gv_fetchmethod(stash, PL_AMG_names[id]);
3ad83ce7
AMS
1805
1806 if (gv && GvCV(gv))
1807 return GvCV(gv);
1808 }
1809 return ret;
1810 }
a0288114 1811
601f1833 1812 return NULL;
32251b26
IZ
1813}
1814
1815
a0d0e21e 1816SV*
864dbfa3 1817Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
a0d0e21e 1818{
27da23d5 1819 dVAR;
b267980d 1820 MAGIC *mg;
9c5ffd7c 1821 CV *cv=NULL;
a0d0e21e 1822 CV **cvp=NULL, **ocvp=NULL;
9c5ffd7c 1823 AMT *amtp=NULL, *oamtp=NULL;
b464bac0
AL
1824 int off = 0, off1, lr = 0, notfound = 0;
1825 int postpr = 0, force_cpy = 0;
1826 int assign = AMGf_assign & flags;
1827 const int assignshift = assign ? 1 : 0;
497b47a8
JH
1828#ifdef DEBUGGING
1829 int fl=0;
497b47a8 1830#endif
25716404 1831 HV* stash=NULL;
7918f24d
NC
1832
1833 PERL_ARGS_ASSERT_AMAGIC_CALL;
1834
e46c382e
YK
1835 if ( PL_curcop->cop_hints & HINT_NO_AMAGIC ) {
1836 SV *lex_mask = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash,
1837 0, "overloading", 11, 0, 0);
1838
1839 if ( !lex_mask || !SvOK(lex_mask) )
1840 /* overloading lexically disabled */
1841 return NULL;
1842 else if ( lex_mask && SvPOK(lex_mask) ) {
1843 /* we have an entry in the hints hash, check if method has been
1844 * masked by overloading.pm */
d15cd831 1845 STRLEN len;
e46c382e 1846 const int offset = method / 8;
d87d3eed 1847 const int bit = method % 8;
e46c382e
YK
1848 char *pv = SvPV(lex_mask, len);
1849
d15cd831 1850 /* Bit set, so this overloading operator is disabled */
ed15e576 1851 if ( (STRLEN)offset < len && pv[offset] & ( 1 << bit ) )
e46c382e
YK
1852 return NULL;
1853 }
1854 }
1855
a0d0e21e 1856 if (!(AMGf_noleft & flags) && SvAMAGIC(left)
25716404 1857 && (stash = SvSTASH(SvRV(left)))
ad64d0ec 1858 && (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table))
b267980d 1859 && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
a6006777 1860 ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
d4c19fe8 1861 : NULL))
b267980d 1862 && ((cv = cvp[off=method+assignshift])
748a9306
LW
1863 || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
1864 * usual method */
497b47a8
JH
1865 (
1866#ifdef DEBUGGING
1867 fl = 1,
a0288114 1868#endif
497b47a8 1869 cv = cvp[off=method])))) {
a0d0e21e
LW
1870 lr = -1; /* Call method for left argument */
1871 } else {
1872 if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) {
1873 int logic;
1874
1875 /* look for substituted methods */
ee239bfe 1876 /* In all the covered cases we should be called with assign==0. */
a0d0e21e
LW
1877 switch (method) {
1878 case inc_amg:
ee239bfe
IZ
1879 force_cpy = 1;
1880 if ((cv = cvp[off=add_ass_amg])
1881 || ((cv = cvp[off = add_amg]) && (force_cpy = 0, postpr = 1))) {
3280af22 1882 right = &PL_sv_yes; lr = -1; assign = 1;
a0d0e21e
LW
1883 }
1884 break;
1885 case dec_amg:
ee239bfe
IZ
1886 force_cpy = 1;
1887 if ((cv = cvp[off = subtr_ass_amg])
1888 || ((cv = cvp[off = subtr_amg]) && (force_cpy = 0, postpr=1))) {
3280af22 1889 right = &PL_sv_yes; lr = -1; assign = 1;
a0d0e21e
LW
1890 }
1891 break;
1892 case bool__amg:
1893 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg]));
1894 break;
1895 case numer_amg:
1896 (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg]));
1897 break;
1898 case string_amg:
1899 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg]));
1900 break;
b7787f18
AL
1901 case not_amg:
1902 (void)((cv = cvp[off=bool__amg])
1903 || (cv = cvp[off=numer_amg])
1904 || (cv = cvp[off=string_amg]));
1905 postpr = 1;
1906 break;
748a9306
LW
1907 case copy_amg:
1908 {
76e3520e
GS
1909 /*
1910 * SV* ref causes confusion with the interpreter variable of
1911 * the same name
1912 */
890ce7af 1913 SV* const tmpRef=SvRV(left);
76e3520e 1914 if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) {
fc36a67e
PP
1915 /*
1916 * Just to be extra cautious. Maybe in some
1917 * additional cases sv_setsv is safe, too.
1918 */
890ce7af 1919 SV* const newref = newSVsv(tmpRef);
748a9306 1920 SvOBJECT_on(newref);
96d4b0ee
NC
1921 /* As a bit of a source compatibility hack, SvAMAGIC() and
1922 friends dereference an RV, to behave the same was as when
1923 overloading was stored on the reference, not the referant.
1924 Hence we can't use SvAMAGIC_on()
1925 */
1926 SvFLAGS(newref) |= SVf_AMAGIC;
85fbaab2 1927 SvSTASH_set(newref, MUTABLE_HV(SvREFCNT_inc(SvSTASH(tmpRef))));
748a9306
LW
1928 return newref;
1929 }
1930 }
1931 break;
a0d0e21e 1932 case abs_amg:
b267980d 1933 if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg])
a0d0e21e 1934 && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) {
890ce7af 1935 SV* const nullsv=sv_2mortal(newSViv(0));
a0d0e21e 1936 if (off1==lt_amg) {
890ce7af 1937 SV* const lessp = amagic_call(left,nullsv,
a0d0e21e
LW
1938 lt_amg,AMGf_noright);
1939 logic = SvTRUE(lessp);
1940 } else {
890ce7af 1941 SV* const lessp = amagic_call(left,nullsv,
a0d0e21e
LW
1942 ncmp_amg,AMGf_noright);
1943 logic = (SvNV(lessp) < 0);
1944 }
1945 if (logic) {
1946 if (off==subtr_amg) {
1947 right = left;
748a9306 1948 left = nullsv;
a0d0e21e
LW
1949 lr = 1;
1950 }
1951 } else {
1952 return left;
1953 }
1954 }
1955 break;
1956 case neg_amg:
155aba94 1957 if ((cv = cvp[off=subtr_amg])) {
a0d0e21e
LW
1958 right = left;
1959 left = sv_2mortal(newSViv(0));
1960 lr = 1;
1961 }
1962 break;
f216259d 1963 case int_amg:
f5284f61 1964 case iter_amg: /* XXXX Eventually should do to_gv. */
c4c7412c 1965 case ftest_amg: /* XXXX Eventually should do to_gv. */
d4b87e75 1966 case regexp_amg:
b267980d
NIS
1967 /* FAIL safe */
1968 return NULL; /* Delegate operation to standard mechanisms. */
1969 break;
f5284f61
IZ
1970 case to_sv_amg:
1971 case to_av_amg:
1972 case to_hv_amg:
1973 case to_gv_amg:
1974 case to_cv_amg:
1975 /* FAIL safe */
b267980d 1976 return left; /* Delegate operation to standard mechanisms. */
f5284f61 1977 break;
a0d0e21e
LW
1978 default:
1979 goto not_found;
1980 }
1981 if (!cv) goto not_found;
1982 } else if (!(AMGf_noright & flags) && SvAMAGIC(right)
25716404 1983 && (stash = SvSTASH(SvRV(right)))
ad64d0ec 1984 && (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table))
b267980d 1985 && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
a6006777 1986 ? (amtp = (AMT*)mg->mg_ptr)->table
d4c19fe8 1987 : NULL))
a0d0e21e
LW
1988 && (cv = cvp[off=method])) { /* Method for right
1989 * argument found */
1990 lr=1;
b267980d
NIS
1991 } else if (((ocvp && oamtp->fallback > AMGfallNEVER
1992 && (cvp=ocvp) && (lr = -1))
a0d0e21e
LW
1993 || (cvp && amtp->fallback > AMGfallNEVER && (lr=1)))
1994 && !(flags & AMGf_unary)) {
1995 /* We look for substitution for
1996 * comparison operations and
fc36a67e 1997 * concatenation */
a0d0e21e
LW
1998 if (method==concat_amg || method==concat_ass_amg
1999 || method==repeat_amg || method==repeat_ass_amg) {
2000 return NULL; /* Delegate operation to string conversion */
2001 }
2002 off = -1;
2003 switch (method) {
2004 case lt_amg:
2005 case le_amg:
2006 case gt_amg:
2007 case ge_amg:
2008 case eq_amg:
2009 case ne_amg:
2010 postpr = 1; off=ncmp_amg; break;
2011 case slt_amg:
2012 case sle_amg:
2013 case sgt_amg:
2014 case sge_amg:
2015 case seq_amg:
2016 case sne_amg:
2017 postpr = 1; off=scmp_amg; break;
2018 }
2019 if (off != -1) cv = cvp[off];
2020 if (!cv) {
2021 goto not_found;
2022 }
2023 } else {
a6006777 2024 not_found: /* No method found, either report or croak */
b267980d 2025 switch (method) {
d11ee47c
RD
2026 case lt_amg:
2027 case le_amg:
2028 case gt_amg:
2029 case ge_amg:
2030 case eq_amg:
2031 case ne_amg:
2032 case slt_amg:
2033 case sle_amg:
2034 case sgt_amg:
2035 case sge_amg:
2036 case seq_amg:
2037 case sne_amg:
2038 postpr = 0; break;
b267980d
NIS
2039 case to_sv_amg:
2040 case to_av_amg:
2041 case to_hv_amg:
2042 case to_gv_amg:
2043 case to_cv_amg:
2044 /* FAIL safe */
2045 return left; /* Delegate operation to standard mechanisms. */
2046 break;
2047 }
a0d0e21e
LW
2048 if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */
2049 notfound = 1; lr = -1;
2050 } else if (cvp && (cv=cvp[nomethod_amg])) {
2051 notfound = 1; lr = 1;
4cc0ca18
NC
2052 } else if ((amtp && amtp->fallback >= AMGfallYES) && !DEBUG_o_TEST) {
2053 /* Skip generating the "no method found" message. */
2054 return NULL;
a0d0e21e 2055 } else {
46fc3d4c 2056 SV *msg;
774d564b 2057 if (off==-1) off=method;
b267980d 2058 msg = sv_2mortal(Perl_newSVpvf(aTHX_
a0288114 2059 "Operation \"%s\": no method found,%sargument %s%s%s%s",
89ffc314 2060 AMG_id2name(method + assignshift),
e7ea3e70 2061 (flags & AMGf_unary ? " " : "\n\tleft "),
b267980d 2062 SvAMAGIC(left)?
a0d0e21e
LW
2063 "in overloaded package ":
2064 "has no overloaded magic",
b267980d 2065 SvAMAGIC(left)?
bfcb3514 2066 HvNAME_get(SvSTASH(SvRV(left))):
a0d0e21e 2067 "",
b267980d 2068 SvAMAGIC(right)?
e7ea3e70 2069 ",\n\tright argument in overloaded package ":
b267980d 2070 (flags & AMGf_unary
e7ea3e70
IZ
2071 ? ""
2072 : ",\n\tright argument has no overloaded magic"),
b267980d 2073 SvAMAGIC(right)?
bfcb3514 2074 HvNAME_get(SvSTASH(SvRV(right))):
46fc3d4c 2075 ""));
a0d0e21e 2076 if (amtp && amtp->fallback >= AMGfallYES) {
b15aece3 2077 DEBUG_o( Perl_deb(aTHX_ "%s", SvPVX_const(msg)) );
a0d0e21e 2078 } else {
be2597df 2079 Perl_croak(aTHX_ "%"SVf, SVfARG(msg));
a0d0e21e
LW
2080 }
2081 return NULL;
2082 }
ee239bfe 2083 force_cpy = force_cpy || assign;
a0d0e21e
LW
2084 }
2085 }
497b47a8 2086#ifdef DEBUGGING
a0d0e21e 2087 if (!notfound) {
497b47a8 2088 DEBUG_o(Perl_deb(aTHX_
a0288114 2089 "Overloaded operator \"%s\"%s%s%s:\n\tmethod%s found%s in package %s%s\n",
497b47a8
JH
2090 AMG_id2name(off),
2091 method+assignshift==off? "" :
a0288114 2092 " (initially \"",
497b47a8
JH
2093 method+assignshift==off? "" :
2094 AMG_id2name(method+assignshift),
a0288114 2095 method+assignshift==off? "" : "\")",
497b47a8
JH
2096 flags & AMGf_unary? "" :
2097 lr==1 ? " for right argument": " for left argument",
2098 flags & AMGf_unary? " for argument" : "",
bfcb3514 2099 stash ? HvNAME_get(stash) : "null",
497b47a8 2100 fl? ",\n\tassignment variant used": "") );
ee239bfe 2101 }
497b47a8 2102#endif
748a9306
LW
2103 /* Since we use shallow copy during assignment, we need
2104 * to dublicate the contents, probably calling user-supplied
2105 * version of copy operator
2106 */
ee239bfe
IZ
2107 /* We need to copy in following cases:
2108 * a) Assignment form was called.
2109 * assignshift==1, assign==T, method + 1 == off
2110 * b) Increment or decrement, called directly.
2111 * assignshift==0, assign==0, method + 0 == off
2112 * c) Increment or decrement, translated to assignment add/subtr.
b267980d 2113 * assignshift==0, assign==T,
ee239bfe
IZ
2114 * force_cpy == T
2115 * d) Increment or decrement, translated to nomethod.
b267980d 2116 * assignshift==0, assign==0,
ee239bfe
IZ
2117 * force_cpy == T
2118 * e) Assignment form translated to nomethod.
2119 * assignshift==1, assign==T, method + 1 != off
2120 * force_cpy == T
2121 */
2122 /* off is method, method+assignshift, or a result of opcode substitution.
2123 * In the latter case assignshift==0, so only notfound case is important.
2124 */
2125 if (( (method + assignshift == off)
2126 && (assign || (method == inc_amg) || (method == dec_amg)))
2127 || force_cpy)
2128 RvDEEPCP(left);
a0d0e21e
LW
2129 {
2130 dSP;
2131 BINOP myop;
2132 SV* res;
b7787f18 2133 const bool oldcatch = CATCH_GET;
a0d0e21e 2134
54310121 2135 CATCH_SET(TRUE);
a0d0e21e
LW
2136 Zero(&myop, 1, BINOP);
2137 myop.op_last = (OP *) &myop;
b37c2d43 2138 myop.op_next = NULL;
54310121 2139 myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
a0d0e21e 2140
e788e7d3 2141 PUSHSTACKi(PERLSI_OVERLOAD);
a0d0e21e 2142 ENTER;
462e5cf6 2143 SAVEOP();
533c011a 2144 PL_op = (OP *) &myop;
3280af22 2145 if (PERLDB_SUB && PL_curstash != PL_debstash)
533c011a 2146 PL_op->op_private |= OPpENTERSUB_DB;
a0d0e21e 2147 PUTBACK;
cea2e8a9 2148 pp_pushmark();
a0d0e21e 2149
924508f0 2150 EXTEND(SP, notfound + 5);
a0d0e21e
LW
2151 PUSHs(lr>0? right: left);
2152 PUSHs(lr>0? left: right);
3280af22 2153 PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no ));
a0d0e21e 2154 if (notfound) {
59cd0e26
NC
2155 PUSHs(newSVpvn_flags(AMG_id2name(method + assignshift),
2156 AMG_id2namelen(method + assignshift), SVs_TEMP));
a0d0e21e 2157 }
ad64d0ec 2158 PUSHs(MUTABLE_SV(cv));
a0d0e21e
LW
2159 PUTBACK;
2160
139d0ce6 2161 if ((PL_op = PL_ppaddr[OP_ENTERSUB](aTHX)))
cea2e8a9 2162 CALLRUNOPS(aTHX);
a0d0e21e
LW
2163 LEAVE;
2164 SPAGAIN;
2165
2166 res=POPs;
ebafeae7 2167 PUTBACK;
d3acc0f7 2168 POPSTACK;
54310121 2169 CATCH_SET(oldcatch);
a0d0e21e 2170
a0d0e21e 2171 if (postpr) {
b7787f18 2172 int ans;
a0d0e21e
LW
2173 switch (method) {
2174 case le_amg:
2175 case sle_amg:
2176 ans=SvIV(res)<=0; break;
2177 case lt_amg:
2178 case slt_amg:
2179 ans=SvIV(res)<0; break;
2180 case ge_amg:
2181 case sge_amg:
2182 ans=SvIV(res)>=0; break;
2183 case gt_amg:
2184 case sgt_amg:
2185 ans=SvIV(res)>0; break;
2186 case eq_amg:
2187 case seq_amg:
2188 ans=SvIV(res)==0; break;
2189 case ne_amg:
2190 case sne_amg:
2191 ans=SvIV(res)!=0; break;
2192 case inc_amg:
2193 case dec_amg:
bbce6d69 2194 SvSetSV(left,res); return left;
dc437b57 2195 case not_amg:
fe7ac86a 2196 ans=!SvTRUE(res); break;
b7787f18
AL
2197 default:
2198 ans=0; break;
a0d0e21e 2199 }
54310121 2200 return boolSV(ans);
748a9306
LW
2201 } else if (method==copy_amg) {
2202 if (!SvROK(res)) {
cea2e8a9 2203 Perl_croak(aTHX_ "Copy method did not return a reference");
748a9306
LW
2204 }
2205 return SvREFCNT_inc(SvRV(res));
a0d0e21e
LW
2206 } else {
2207 return res;
2208 }
2209 }
2210}
c9d5ac95
GS
2211
2212/*
7fc63493 2213=for apidoc is_gv_magical_sv
c9d5ac95
GS
2214
2215Returns C<TRUE> if given the name of a magical GV.
2216
2217Currently only useful internally when determining if a GV should be
2218created even in rvalue contexts.
2219
2220C<flags> is not used at present but available for future extension to
2221allow selecting particular classes of magical variable.
2222
b9b0e72c
NC
2223Currently assumes that C<name> is NUL terminated (as well as len being valid).
2224This assumption is met by all callers within the perl core, which all pass
2225pointers returned by SvPV.
2226
c9d5ac95
GS
2227=cut
2228*/
9d8f40c4 2229
c9d5ac95 2230bool
9d8f40c4 2231Perl_is_gv_magical_sv(pTHX_ SV *const name_sv, U32 flags)
c9d5ac95 2232{
9d8f40c4
NC
2233 STRLEN len;
2234 const char *const name = SvPV_const(name_sv, len);
9d4ba2ae 2235
9d8f40c4
NC
2236 PERL_UNUSED_ARG(flags);
2237 PERL_ARGS_ASSERT_IS_GV_MAGICAL_SV;
7918f24d 2238
b9b0e72c 2239 if (len > 1) {
b464bac0 2240 const char * const name1 = name + 1;
b9b0e72c
NC
2241 switch (*name) {
2242 case 'I':
f2df7081 2243 if (len == 3 && name[1] == 'S' && name[2] == 'A')
b9b0e72c
NC
2244 goto yes;
2245 break;
2246 case 'O':
9431620d 2247 if (len == 8 && strEQ(name1, "VERLOAD"))
b9b0e72c
NC
2248 goto yes;
2249 break;
2250 case 'S':
9431620d 2251 if (len == 3 && name[1] == 'I' && name[2] == 'G')
b9b0e72c
NC
2252 goto yes;
2253 break;
2254 /* Using ${^...} variables is likely to be sufficiently rare that
2255 it seems sensible to avoid the space hit of also checking the
2256 length. */
2257 case '\017': /* ${^OPEN} */
9431620d 2258 if (strEQ(name1, "PEN"))
b9b0e72c
NC
2259 goto yes;
2260 break;
2261 case '\024': /* ${^TAINT} */
9431620d 2262 if (strEQ(name1, "AINT"))
b9b0e72c
NC
2263 goto yes;
2264 break;
2265 case '\025': /* ${^UNICODE} */
9431620d 2266 if (strEQ(name1, "NICODE"))
b9b0e72c 2267 goto yes;
a0288114 2268 if (strEQ(name1, "TF8LOCALE"))
7cebcbc0 2269 goto yes;
b9b0e72c
NC
2270 break;
2271 case '\027': /* ${^WARNING_BITS} */
9431620d 2272 if (strEQ(name1, "ARNING_BITS"))
b9b0e72c
NC
2273 goto yes;
2274 break;
2275 case '1':
2276 case '2':
2277 case '3':
2278 case '4':
2279 case '5':
2280 case '6':
2281 case '7':
2282 case '8':
2283 case '9':
c9d5ac95 2284 {
7fc63493 2285 const char *end = name + len;
c9d5ac95
GS
2286 while (--end > name) {
2287 if (!isDIGIT(*end))
2288 return FALSE;
2289 }
b9b0e72c
NC
2290 goto yes;
2291 }
2292 }
2293 } else {
2294 /* Because we're already assuming that name is NUL terminated
2295 below, we can treat an empty name as "\0" */
2296 switch (*name) {
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 '%':
2310 case '.':
2311 case '(':
2312 case ')':
2313 case '<':
2314 case '>':
b9b0e72c
NC
2315 case '\\':
2316 case '/':
2317 case '|':
2318 case '+':
2319 case ';':
2320 case ']':
2321 case '\001': /* $^A */
2322 case '\003': /* $^C */
2323 case '\004': /* $^D */
2324 case '\005': /* $^E */
2325 case '\006': /* $^F */
2326 case '\010': /* $^H */
2327 case '\011': /* $^I, NOT \t in EBCDIC */
2328 case '\014': /* $^L */
2329 case '\016': /* $^N */
2330 case '\017': /* $^O */
2331 case '\020': /* $^P */
2332 case '\023': /* $^S */
2333 case '\024': /* $^T */
2334 case '\026': /* $^V */
2335 case '\027': /* $^W */
2336 case '1':
2337 case '2':
2338 case '3':
2339 case '4':
2340 case '5':
2341 case '6':
2342 case '7':
2343 case '8':
2344 case '9':
2345 yes:
2346 return TRUE;
2347 default:
2348 break;
c9d5ac95 2349 }
c9d5ac95
GS
2350 }
2351 return FALSE;
2352}
66610fdd 2353
f5c1e807
NC
2354void
2355Perl_gv_name_set(pTHX_ GV *gv, const char *name, U32 len, U32 flags)
2356{
2357 dVAR;
acda4c6a 2358 U32 hash;
f5c1e807 2359
7918f24d 2360 PERL_ARGS_ASSERT_GV_NAME_SET;
f5c1e807
NC
2361 PERL_UNUSED_ARG(flags);
2362
acda4c6a
NC
2363 if (len > I32_MAX)
2364 Perl_croak(aTHX_ "panic: gv name too long (%"UVuf")", (UV) len);
2365
ae8cc45f
NC
2366 if (!(flags & GV_ADD) && GvNAME_HEK(gv)) {
2367 unshare_hek(GvNAME_HEK(gv));
2368 }
2369
acda4c6a 2370 PERL_HASH(hash, name, len);
9f616d01 2371 GvNAME_HEK(gv) = share_hek(name, len, hash);
f5c1e807
NC
2372}
2373
66610fdd
RGS
2374/*
2375 * Local variables:
2376 * c-indentation-style: bsd
2377 * c-basic-offset: 4
2378 * indent-tabs-mode: t
2379 * End:
2380 *
37442d52
RGS
2381 * ex: set ts=8 sts=4 sw=4 noet:
2382 */