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