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