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