This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Re: [perl #31793] Data::Dumper: Useqq interacts badly with overloading
[perl5.git] / gv.c
CommitLineData
a0d0e21e 1/* gv.c
79072805 2 *
4bb101f2 3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
9431620d 4 * 2000, 2001, 2002, 2003, 2004, 2005, 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
LW
35#include "perl.h"
36
37GV *
864dbfa3 38Perl_gv_AVadd(pTHX_ register GV *gv)
79072805 39{
a0d0e21e 40 if (!gv || SvTYPE((SV*)gv) != SVt_PVGV)
cea2e8a9 41 Perl_croak(aTHX_ "Bad symbol for array");
79072805
LW
42 if (!GvAV(gv))
43 GvAV(gv) = newAV();
44 return gv;
45}
46
47GV *
864dbfa3 48Perl_gv_HVadd(pTHX_ register GV *gv)
79072805 49{
a0d0e21e 50 if (!gv || SvTYPE((SV*)gv) != SVt_PVGV)
cea2e8a9 51 Perl_croak(aTHX_ "Bad symbol for hash");
79072805 52 if (!GvHV(gv))
463ee0b2 53 GvHV(gv) = newHV();
79072805
LW
54 return gv;
55}
56
57GV *
864dbfa3 58Perl_gv_IOadd(pTHX_ register GV *gv)
a0d0e21e
LW
59{
60 if (!gv || SvTYPE((SV*)gv) != SVt_PVGV)
cea2e8a9 61 Perl_croak(aTHX_ "Bad symbol for filehandle");
5bd07a3d 62 if (!GvIOp(gv)) {
7fb37951
AMS
63#ifdef GV_UNIQUE_CHECK
64 if (GvUNIQUE(gv)) {
65 Perl_croak(aTHX_ "Bad symbol for filehandle (GV is unique)");
5bd07a3d
DM
66 }
67#endif
a0d0e21e 68 GvIOp(gv) = newIO();
5bd07a3d 69 }
a0d0e21e
LW
70 return gv;
71}
72
73GV *
864dbfa3 74Perl_gv_fetchfile(pTHX_ const char *name)
79072805 75{
eacec437 76 char smallbuf[256];
53d95988 77 char *tmpbuf;
8ebc5c01 78 STRLEN tmplen;
79072805
LW
79 GV *gv;
80
1d7c1841
GS
81 if (!PL_defstash)
82 return Nullgv;
83
53d95988
CS
84 tmplen = strlen(name) + 2;
85 if (tmplen < sizeof smallbuf)
86 tmpbuf = smallbuf;
87 else
88 New(603, tmpbuf, tmplen + 1, char);
0ac0412a 89 /* This is where the debugger's %{"::_<$filename"} hash is created */
53d95988
CS
90 tmpbuf[0] = '_';
91 tmpbuf[1] = '<';
92 strcpy(tmpbuf + 2, name);
3280af22 93 gv = *(GV**)hv_fetch(PL_defstash, tmpbuf, tmplen, TRUE);
1d7c1841 94 if (!isGV(gv)) {
3280af22 95 gv_init(gv, PL_defstash, tmpbuf, tmplen, FALSE);
1d7c1841
GS
96 sv_setpv(GvSV(gv), name);
97 if (PERLDB_LINE)
14befaf4 98 hv_magic(GvHVn(gv_AVadd(gv)), Nullgv, PERL_MAGIC_dbfile);
1d7c1841 99 }
53d95988
CS
100 if (tmpbuf != smallbuf)
101 Safefree(tmpbuf);
79072805
LW
102 return gv;
103}
104
463ee0b2 105void
864dbfa3 106Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi)
463ee0b2 107{
27da23d5 108 dVAR;
463ee0b2 109 register GP *gp;
e1ec3a88 110 const bool doproto = SvTYPE(gv) > SVt_NULL;
55d729e4 111 char *proto = (doproto && SvPOK(gv)) ? SvPVX(gv) : NULL;
463ee0b2 112
dc437b57 113 sv_upgrade((SV*)gv, SVt_PVGV);
55d729e4
GS
114 if (SvLEN(gv)) {
115 if (proto) {
f880fe2f 116 SvPV_set(gv, NULL);
b162af07 117 SvLEN_set(gv, 0);
55d729e4
GS
118 SvPOK_off(gv);
119 } else
120 Safefree(SvPVX(gv));
121 }
44a8e56a 122 Newz(602, gp, 1, GP);
8990e307 123 GvGP(gv) = gp_ref(gp);
463ee0b2 124 GvSV(gv) = NEWSV(72,0);
1d7c1841 125 GvLINE(gv) = CopLINE(PL_curcop);
07409e01
NC
126 /* XXX Ideally this cast would be replaced with a change to const char*
127 in the struct. */
128 GvFILE(gv) = CopFILE(PL_curcop) ? CopFILE(PL_curcop) : (char *) "";
005a453c 129 GvCVGEN(gv) = 0;
463ee0b2 130 GvEGV(gv) = gv;
14befaf4 131 sv_magic((SV*)gv, (SV*)gv, PERL_MAGIC_glob, Nullch, 0);
85aff577 132 GvSTASH(gv) = (HV*)SvREFCNT_inc(stash);
a0d0e21e 133 GvNAME(gv) = savepvn(name, len);
463ee0b2 134 GvNAMELEN(gv) = len;
23ad5bf5 135 if (multi || doproto) /* doproto means it _was_ mentioned */
a5f75d66 136 GvMULTI_on(gv);
55d729e4 137 if (doproto) { /* Replicate part of newSUB here. */
57ff9a15 138 SvIOK_off(gv);
55d729e4 139 ENTER;
b099ddc0 140 /* XXX unsafe for threads if eval_owner isn't held */
55d729e4 141 start_subparse(0,0); /* Create CV in compcv. */
3280af22 142 GvCV(gv) = PL_compcv;
55d729e4
GS
143 LEAVE;
144
3280af22 145 PL_sub_generation++;
65c50114 146 CvGV(GvCV(gv)) = gv;
e0d088d0 147 CvFILE_set_from_cop(GvCV(gv), PL_curcop);
3280af22 148 CvSTASH(GvCV(gv)) = PL_curstash;
55d729e4
GS
149 if (proto) {
150 sv_setpv((SV*)GvCV(gv), proto);
151 Safefree(proto);
152 }
153 }
463ee0b2
LW
154}
155
76e3520e 156STATIC void
cea2e8a9 157S_gv_init_sv(pTHX_ GV *gv, I32 sv_type)
a0d0e21e
LW
158{
159 switch (sv_type) {
160 case SVt_PVIO:
161 (void)GvIOn(gv);
162 break;
163 case SVt_PVAV:
164 (void)GvAVn(gv);
165 break;
166 case SVt_PVHV:
167 (void)GvHVn(gv);
168 break;
169 }
170}
171
954c1994
GS
172/*
173=for apidoc gv_fetchmeth
174
175Returns the glob with the given C<name> and a defined subroutine or
176C<NULL>. The glob lives in the given C<stash>, or in the stashes
07766739 177accessible via @ISA and UNIVERSAL::.
954c1994
GS
178
179The argument C<level> should be either 0 or -1. If C<level==0>, as a
180side-effect creates a glob with the given C<name> in the given C<stash>
181which in the case of success contains an alias for the subroutine, and sets
b267980d 182up caching info for this glob. Similarly for all the searched stashes.
954c1994
GS
183
184This function grants C<"SUPER"> token as a postfix of the stash name. The
185GV returned from C<gv_fetchmeth> may be a method cache entry, which is not
4929bf7b 186visible to Perl code. So when calling C<call_sv>, you should not use
954c1994 187the GV directly; instead, you should use the method's CV, which can be
b267980d 188obtained from the GV with the C<GvCV> macro.
954c1994
GS
189
190=cut
191*/
192
79072805 193GV *
864dbfa3 194Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level)
79072805
LW
195{
196 AV* av;
463ee0b2 197 GV* topgv;
79072805 198 GV* gv;
463ee0b2 199 GV** gvp;
748a9306 200 CV* cv;
a0d0e21e 201
af09ea45
IK
202 /* UNIVERSAL methods should be callable without a stash */
203 if (!stash) {
204 level = -1; /* probably appropriate */
205 if(!(stash = gv_stashpvn("UNIVERSAL", 9, FALSE)))
206 return 0;
207 }
208
e27ad1f2
AV
209 if (!HvNAME(stash))
210 Perl_croak(aTHX_
211 "Can't use anonymous symbol table for method lookup");
212
44a8e56a 213 if ((level > 100) || (level < -100))
cea2e8a9 214 Perl_croak(aTHX_ "Recursive inheritance detected while looking for method '%s' in package '%s'",
3e0ccd42 215 name, HvNAME(stash));
463ee0b2 216
cea2e8a9 217 DEBUG_o( Perl_deb(aTHX_ "Looking for method %s in package %s\n",name,HvNAME(stash)) );
44a8e56a
PP
218
219 gvp = (GV**)hv_fetch(stash, name, len, (level >= 0));
220 if (!gvp)
221 topgv = Nullgv;
222 else {
223 topgv = *gvp;
224 if (SvTYPE(topgv) != SVt_PVGV)
225 gv_init(topgv, stash, name, len, TRUE);
155aba94 226 if ((cv = GvCV(topgv))) {
44a8e56a 227 /* If genuine method or valid cache entry, use it */
3280af22 228 if (!GvCVGEN(topgv) || GvCVGEN(topgv) == PL_sub_generation)
7a4c00b4 229 return topgv;
44a8e56a
PP
230 /* Stale cached entry: junk it */
231 SvREFCNT_dec(cv);
232 GvCV(topgv) = cv = Nullcv;
233 GvCVGEN(topgv) = 0;
748a9306 234 }
3280af22 235 else if (GvCVGEN(topgv) == PL_sub_generation)
005a453c 236 return 0; /* cache indicates sub doesn't exist */
463ee0b2 237 }
79072805 238
9607fc9c 239 gvp = (GV**)hv_fetch(stash, "ISA", 3, FALSE);
3280af22 240 av = (gvp && (gv = *gvp) && gv != (GV*)&PL_sv_undef) ? GvAV(gv) : Nullav;
9607fc9c 241
fb73857a
PP
242 /* create and re-create @.*::SUPER::ISA on demand */
243 if (!av || !SvMAGIC(av)) {
9607fc9c
PP
244 char* packname = HvNAME(stash);
245 STRLEN packlen = strlen(packname);
246
247 if (packlen >= 7 && strEQ(packname + packlen - 7, "::SUPER")) {
248 HV* basestash;
249
250 packlen -= 7;
251 basestash = gv_stashpvn(packname, packlen, TRUE);
252 gvp = (GV**)hv_fetch(basestash, "ISA", 3, FALSE);
3280af22 253 if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (av = GvAV(gv))) {
9607fc9c
PP
254 gvp = (GV**)hv_fetch(stash, "ISA", 3, TRUE);
255 if (!gvp || !(gv = *gvp))
cea2e8a9 256 Perl_croak(aTHX_ "Cannot create %s::ISA", HvNAME(stash));
9607fc9c
PP
257 if (SvTYPE(gv) != SVt_PVGV)
258 gv_init(gv, stash, "ISA", 3, TRUE);
259 SvREFCNT_dec(GvAV(gv));
260 GvAV(gv) = (AV*)SvREFCNT_inc(av);
261 }
262 }
263 }
264
265 if (av) {
79072805 266 SV** svp = AvARRAY(av);
93965878
NIS
267 /* NOTE: No support for tied ISA */
268 I32 items = AvFILLp(av) + 1;
79072805 269 while (items--) {
79072805 270 SV* sv = *svp++;
a0d0e21e 271 HV* basestash = gv_stashsv(sv, FALSE);
9bbf4081 272 if (!basestash) {
599cee73 273 if (ckWARN(WARN_MISC))
35c1215d
NC
274 Perl_warner(aTHX_ packWARN(WARN_MISC), "Can't locate package %"SVf" for @%s::ISA",
275 sv, HvNAME(stash));
79072805
LW
276 continue;
277 }
44a8e56a
PP
278 gv = gv_fetchmeth(basestash, name, len,
279 (level >= 0) ? level + 1 : level - 1);
280 if (gv)
281 goto gotcha;
79072805
LW
282 }
283 }
a0d0e21e 284
9607fc9c
PP
285 /* if at top level, try UNIVERSAL */
286
44a8e56a 287 if (level == 0 || level == -1) {
9607fc9c
PP
288 HV* lastchance;
289
155aba94
GS
290 if ((lastchance = gv_stashpvn("UNIVERSAL", 9, FALSE))) {
291 if ((gv = gv_fetchmeth(lastchance, name, len,
292 (level >= 0) ? level + 1 : level - 1)))
293 {
44a8e56a 294 gotcha:
dc848c6f
PP
295 /*
296 * Cache method in topgv if:
297 * 1. topgv has no synonyms (else inheritance crosses wires)
298 * 2. method isn't a stub (else AUTOLOAD fails spectacularly)
299 */
300 if (topgv &&
301 GvREFCNT(topgv) == 1 &&
302 (cv = GvCV(gv)) &&
303 (CvROOT(cv) || CvXSUB(cv)))
304 {
155aba94 305 if ((cv = GvCV(topgv)))
44a8e56a
PP
306 SvREFCNT_dec(cv);
307 GvCV(topgv) = (CV*)SvREFCNT_inc(GvCV(gv));
3280af22 308 GvCVGEN(topgv) = PL_sub_generation;
44a8e56a 309 }
a0d0e21e
LW
310 return gv;
311 }
005a453c
JP
312 else if (topgv && GvREFCNT(topgv) == 1) {
313 /* cache the fact that the method is not defined */
3280af22 314 GvCVGEN(topgv) = PL_sub_generation;
005a453c 315 }
a0d0e21e
LW
316 }
317 }
318
79072805
LW
319 return 0;
320}
321
954c1994 322/*
611c1e95
IZ
323=for apidoc gv_fetchmeth_autoload
324
325Same as gv_fetchmeth(), but looks for autoloaded subroutines too.
326Returns a glob for the subroutine.
327
328For an autoloaded subroutine without a GV, will create a GV even
329if C<level < 0>. For an autoloaded subroutine without a stub, GvCV()
330of the result may be zero.
331
332=cut
333*/
334
335GV *
336Perl_gv_fetchmeth_autoload(pTHX_ HV *stash, const char *name, STRLEN len, I32 level)
337{
338 GV *gv = gv_fetchmeth(stash, name, len, level);
339
340 if (!gv) {
341 char autoload[] = "AUTOLOAD";
342 STRLEN autolen = sizeof(autoload)-1;
343 CV *cv;
344 GV **gvp;
345
346 if (!stash)
347 return Nullgv; /* UNIVERSAL::AUTOLOAD could cause trouble */
348 if (len == autolen && strnEQ(name, autoload, autolen))
349 return Nullgv;
350 if (!(gv = gv_fetchmeth(stash, autoload, autolen, FALSE)))
351 return Nullgv;
352 cv = GvCV(gv);
353 if (!(CvROOT(cv) || CvXSUB(cv)))
354 return Nullgv;
355 /* Have an autoload */
356 if (level < 0) /* Cannot do without a stub */
357 gv_fetchmeth(stash, name, len, 0);
358 gvp = (GV**)hv_fetch(stash, name, len, (level >= 0));
359 if (!gvp)
360 return Nullgv;
361 return *gvp;
362 }
363 return gv;
364}
365
366/*
954c1994
GS
367=for apidoc gv_fetchmethod
368
6d0f518e 369See L<gv_fetchmethod_autoload>.
954c1994
GS
370
371=cut
372*/
373
79072805 374GV *
864dbfa3 375Perl_gv_fetchmethod(pTHX_ HV *stash, const char *name)
463ee0b2 376{
dc848c6f
PP
377 return gv_fetchmethod_autoload(stash, name, TRUE);
378}
379
954c1994
GS
380/*
381=for apidoc gv_fetchmethod_autoload
382
383Returns the glob which contains the subroutine to call to invoke the method
384on the C<stash>. In fact in the presence of autoloading this may be the
385glob for "AUTOLOAD". In this case the corresponding variable $AUTOLOAD is
b267980d 386already setup.
954c1994
GS
387
388The third parameter of C<gv_fetchmethod_autoload> determines whether
389AUTOLOAD lookup is performed if the given method is not present: non-zero
b267980d 390means yes, look for AUTOLOAD; zero means no, don't look for AUTOLOAD.
954c1994 391Calling C<gv_fetchmethod> is equivalent to calling C<gv_fetchmethod_autoload>
b267980d 392with a non-zero C<autoload> parameter.
954c1994
GS
393
394These functions grant C<"SUPER"> token as a prefix of the method name. Note
395that if you want to keep the returned glob for a long time, you need to
396check for it being "AUTOLOAD", since at the later time the call may load a
397different subroutine due to $AUTOLOAD changing its value. Use the glob
b267980d 398created via a side effect to do this.
954c1994
GS
399
400These functions have the same side-effects and as C<gv_fetchmeth> with
401C<level==0>. C<name> should be writable if contains C<':'> or C<'
402''>. The warning against passing the GV returned by C<gv_fetchmeth> to
b267980d 403C<call_sv> apply equally to these functions.
954c1994
GS
404
405=cut
406*/
407
dc848c6f 408GV *
864dbfa3 409Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload)
dc848c6f 410{
08105a92
GS
411 register const char *nend;
412 const char *nsplit = 0;
a0d0e21e 413 GV* gv;
0dae17bd
GS
414 HV* ostash = stash;
415
416 if (stash && SvTYPE(stash) < SVt_PVHV)
417 stash = Nullhv;
b267980d 418
463ee0b2 419 for (nend = name; *nend; nend++) {
9607fc9c 420 if (*nend == '\'')
a0d0e21e 421 nsplit = nend;
9607fc9c
PP
422 else if (*nend == ':' && *(nend + 1) == ':')
423 nsplit = ++nend;
a0d0e21e
LW
424 }
425 if (nsplit) {
08105a92 426 const char *origname = name;
a0d0e21e 427 name = nsplit + 1;
a0d0e21e
LW
428 if (*nsplit == ':')
429 --nsplit;
9607fc9c
PP
430 if ((nsplit - origname) == 5 && strnEQ(origname, "SUPER", 5)) {
431 /* ->SUPER::method should really be looked up in original stash */
cea2e8a9 432 SV *tmpstr = sv_2mortal(Perl_newSVpvf(aTHX_ "%s::SUPER",
1d7c1841 433 CopSTASHPV(PL_curcop)));
af09ea45 434 /* __PACKAGE__::SUPER stash should be autovivified */
9607fc9c 435 stash = gv_stashpvn(SvPVX(tmpstr), SvCUR(tmpstr), TRUE);
cea2e8a9 436 DEBUG_o( Perl_deb(aTHX_ "Treating %s as %s::%s\n",
9607fc9c 437 origname, HvNAME(stash), name) );
4633a7c4 438 }
e189a56d 439 else {
af09ea45
IK
440 /* don't autovifify if ->NoSuchStash::method */
441 stash = gv_stashpvn(origname, nsplit - origname, FALSE);
e189a56d
IK
442
443 /* however, explicit calls to Pkg::SUPER::method may
444 happen, and may require autovivification to work */
445 if (!stash && (nsplit - origname) >= 7 &&
446 strnEQ(nsplit - 7, "::SUPER", 7) &&
447 gv_stashpvn(origname, nsplit - origname - 7, FALSE))
448 stash = gv_stashpvn(origname, nsplit - origname, TRUE);
449 }
0dae17bd 450 ostash = stash;
4633a7c4
LW
451 }
452
9607fc9c 453 gv = gv_fetchmeth(stash, name, nend - name, 0);
a0d0e21e 454 if (!gv) {
2f6e0fe7 455 if (strEQ(name,"import") || strEQ(name,"unimport"))
3280af22 456 gv = (GV*)&PL_sv_yes;
dc848c6f 457 else if (autoload)
0dae17bd 458 gv = gv_autoload4(ostash, name, nend - name, TRUE);
463ee0b2 459 }
dc848c6f
PP
460 else if (autoload) {
461 CV* cv = GvCV(gv);
09280a33
CS
462 if (!CvROOT(cv) && !CvXSUB(cv)) {
463 GV* stubgv;
464 GV* autogv;
465
466 if (CvANON(cv))
467 stubgv = gv;
468 else {
469 stubgv = CvGV(cv);
470 if (GvCV(stubgv) != cv) /* orphaned import */
471 stubgv = gv;
472 }
473 autogv = gv_autoload4(GvSTASH(stubgv),
474 GvNAME(stubgv), GvNAMELEN(stubgv), TRUE);
dc848c6f
PP
475 if (autogv)
476 gv = autogv;
477 }
478 }
44a8e56a
PP
479
480 return gv;
481}
482
483GV*
864dbfa3 484Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method)
44a8e56a 485{
27da23d5 486 dVAR;
df3728a2
JH
487 char autoload[] = "AUTOLOAD";
488 STRLEN autolen = sizeof(autoload)-1;
44a8e56a
PP
489 GV* gv;
490 CV* cv;
491 HV* varstash;
492 GV* vargv;
493 SV* varsv;
e1ec3a88 494 const char *packname = "";
44a8e56a
PP
495
496 if (len == autolen && strnEQ(name, autoload, autolen))
497 return Nullgv;
0dae17bd
GS
498 if (stash) {
499 if (SvTYPE(stash) < SVt_PVHV) {
500 packname = SvPV_nolen((SV*)stash);
501 stash = Nullhv;
502 }
503 else {
504 packname = HvNAME(stash);
505 }
506 }
dc848c6f
PP
507 if (!(gv = gv_fetchmeth(stash, autoload, autolen, FALSE)))
508 return Nullgv;
509 cv = GvCV(gv);
510
adb5a9ae 511 if (!(CvROOT(cv) || CvXSUB(cv)))
ed850460
JH
512 return Nullgv;
513
dc848c6f
PP
514 /*
515 * Inheriting AUTOLOAD for non-methods works ... for now.
516 */
12bcd1a6 517 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX) && !method &&
599cee73 518 (GvCVGEN(gv) || GvSTASH(gv) != stash))
12bcd1a6 519 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
dc848c6f 520 "Use of inherited AUTOLOAD for non-method %s::%.*s() is deprecated",
0dae17bd 521 packname, (int)len, name);
44a8e56a 522
adb5a9ae
DM
523 if (CvXSUB(cv)) {
524 /* rather than lookup/init $AUTOLOAD here
525 * only to have the XSUB do another lookup for $AUTOLOAD
526 * and split that value on the last '::',
527 * pass along the same data via some unused fields in the CV
528 */
529 CvSTASH(cv) = stash;
f880fe2f 530 SvPV_set(cv, (char *)name); /* cast to lose constness warning */
b162af07 531 SvCUR_set(cv, len);
adb5a9ae
DM
532 return gv;
533 }
adb5a9ae 534
44a8e56a
PP
535 /*
536 * Given &FOO::AUTOLOAD, set $FOO::AUTOLOAD to desired function name.
537 * The subroutine's original name may not be "AUTOLOAD", so we don't
538 * use that, but for lack of anything better we will use the sub's
539 * original package to look up $AUTOLOAD.
540 */
541 varstash = GvSTASH(CvGV(cv));
542 vargv = *(GV**)hv_fetch(varstash, autoload, autolen, TRUE);
3d35f11b
GS
543 ENTER;
544
44a8e56a
PP
545 if (!isGV(vargv))
546 gv_init(vargv, varstash, autoload, autolen, FALSE);
3d35f11b 547 LEAVE;
44a8e56a 548 varsv = GvSV(vargv);
0dae17bd 549 sv_setpv(varsv, packname);
44a8e56a
PP
550 sv_catpvn(varsv, "::", 2);
551 sv_catpvn(varsv, name, len);
552 SvTAINTED_off(varsv);
a0d0e21e
LW
553 return gv;
554}
555
d2c93421
RH
556/* The "gv" parameter should be the glob known to Perl code as *!
557 * The scalar must already have been magicalized.
558 */
559STATIC void
560S_require_errno(pTHX_ GV *gv)
561{
27da23d5 562 dVAR;
d2c93421
RH
563 HV* stash = gv_stashpvn("Errno",5,FALSE);
564
565 if (!stash || !(gv_fetchmethod(stash, "TIEHASH"))) {
566 dSP;
567 PUTBACK;
568 ENTER;
569 save_scalar(gv); /* keep the value of $! */
84f1fa11
AMS
570 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
571 newSVpvn("Errno",5), Nullsv);
d2c93421
RH
572 LEAVE;
573 SPAGAIN;
574 stash = gv_stashpvn("Errno",5,FALSE);
575 if (!stash || !(gv_fetchmethod(stash, "TIEHASH")))
576 Perl_croak(aTHX_ "Can't use %%! because Errno.pm is not available");
577 }
578}
579
954c1994
GS
580/*
581=for apidoc gv_stashpv
582
386d01d6 583Returns a pointer to the stash for a specified package. C<name> should
bc96cb06
SH
584be a valid UTF-8 string and must be null-terminated. If C<create> is set
585then the package will be created if it does not already exist. If C<create>
586is not set and the package does not exist then NULL is returned.
954c1994
GS
587
588=cut
589*/
590
a0d0e21e 591HV*
864dbfa3 592Perl_gv_stashpv(pTHX_ const char *name, I32 create)
a0d0e21e 593{
dc437b57
PP
594 return gv_stashpvn(name, strlen(name), create);
595}
596
bc96cb06
SH
597/*
598=for apidoc gv_stashpvn
599
600Returns a pointer to the stash for a specified package. C<name> should
601be a valid UTF-8 string. The C<namelen> parameter indicates the length of
602the C<name>, in bytes. If C<create> is set then the package will be
603created if it does not already exist. If C<create> is not set and the
604package does not exist then NULL is returned.
605
606=cut
607*/
608
dc437b57 609HV*
864dbfa3 610Perl_gv_stashpvn(pTHX_ const char *name, U32 namelen, I32 create)
dc437b57 611{
46fc3d4c
PP
612 char smallbuf[256];
613 char *tmpbuf;
a0d0e21e
LW
614 HV *stash;
615 GV *tmpgv;
dc437b57 616
46fc3d4c
PP
617 if (namelen + 3 < sizeof smallbuf)
618 tmpbuf = smallbuf;
619 else
620 New(606, tmpbuf, namelen + 3, char);
dc437b57
PP
621 Copy(name,tmpbuf,namelen,char);
622 tmpbuf[namelen++] = ':';
623 tmpbuf[namelen++] = ':';
624 tmpbuf[namelen] = '\0';
46fc3d4c
PP
625 tmpgv = gv_fetchpv(tmpbuf, create, SVt_PVHV);
626 if (tmpbuf != smallbuf)
627 Safefree(tmpbuf);
a0d0e21e
LW
628 if (!tmpgv)
629 return 0;
630 if (!GvHV(tmpgv))
631 GvHV(tmpgv) = newHV();
632 stash = GvHV(tmpgv);
633 if (!HvNAME(stash))
634 HvNAME(stash) = savepv(name);
635 return stash;
463ee0b2
LW
636}
637
954c1994
GS
638/*
639=for apidoc gv_stashsv
640
386d01d6
GS
641Returns a pointer to the stash for a specified package, which must be a
642valid UTF-8 string. See C<gv_stashpv>.
954c1994
GS
643
644=cut
645*/
646
a0d0e21e 647HV*
864dbfa3 648Perl_gv_stashsv(pTHX_ SV *sv, I32 create)
a0d0e21e 649{
dc437b57
PP
650 register char *ptr;
651 STRLEN len;
652 ptr = SvPV(sv,len);
653 return gv_stashpvn(ptr, len, create);
a0d0e21e
LW
654}
655
656
463ee0b2 657GV *
7a5fd60d
NC
658Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type) {
659 STRLEN len = strlen (nambeg);
660 return gv_fetchpvn_flags(nambeg, len, add, sv_type);
661}
662
663GV *
664Perl_gv_fetchsv(pTHX_ SV *name, I32 flags, I32 sv_type) {
665 STRLEN len;
666 const char *nambeg = SvPV(name, len);
667 return gv_fetchpvn_flags(nambeg, len, flags | SvUTF8(name), sv_type);
668}
669
670GV *
671Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
672 I32 sv_type)
79072805 673{
08105a92 674 register const char *name = nambeg;
463ee0b2 675 register GV *gv = 0;
79072805 676 GV**gvp;
79072805 677 I32 len;
08105a92 678 register const char *namend;
463ee0b2 679 HV *stash = 0;
dd374669
AL
680 const I32 add = flags & ~SVf_UTF8;
681 (void)full_len;
79072805 682
c07a80fd
PP
683 if (*name == '*' && isALPHA(name[1])) /* accidental stringify on a GV? */
684 name++;
685
79072805 686 for (namend = name; *namend; namend++) {
1d7c1841
GS
687 if ((*namend == ':' && namend[1] == ':')
688 || (*namend == '\'' && namend[1]))
463ee0b2 689 {
463ee0b2 690 if (!stash)
3280af22 691 stash = PL_defstash;
dc437b57 692 if (!stash || !SvREFCNT(stash)) /* symbol table under destruction */
a0d0e21e 693 return Nullgv;
463ee0b2 694
85e6fe83
LW
695 len = namend - name;
696 if (len > 0) {
3c78fafa 697 char smallbuf[256];
62b57502 698 char *tmpbuf;
62b57502 699
25c09a70 700 if (len + 3 < sizeof (smallbuf))
3c78fafa 701 tmpbuf = smallbuf;
62b57502
MB
702 else
703 New(601, tmpbuf, len+3, char);
a0d0e21e
LW
704 Copy(name, tmpbuf, len, char);
705 tmpbuf[len++] = ':';
706 tmpbuf[len++] = ':';
707 tmpbuf[len] = '\0';
463ee0b2 708 gvp = (GV**)hv_fetch(stash,tmpbuf,len,add);
6fa846a0 709 gv = gvp ? *gvp : Nullgv;
3280af22 710 if (gv && gv != (GV*)&PL_sv_undef) {
6fa846a0 711 if (SvTYPE(gv) != SVt_PVGV)
0f303493 712 gv_init(gv, stash, tmpbuf, len, (add & GV_ADDMULTI));
6fa846a0
GS
713 else
714 GvMULTI_on(gv);
715 }
3c78fafa 716 if (tmpbuf != smallbuf)
62b57502 717 Safefree(tmpbuf);
3280af22 718 if (!gv || gv == (GV*)&PL_sv_undef)
a0d0e21e 719 return Nullgv;
85e6fe83 720
463ee0b2
LW
721 if (!(stash = GvHV(gv)))
722 stash = GvHV(gv) = newHV();
85e6fe83 723
463ee0b2 724 if (!HvNAME(stash))
a0d0e21e 725 HvNAME(stash) = savepvn(nambeg, namend - nambeg);
463ee0b2
LW
726 }
727
728 if (*namend == ':')
729 namend++;
730 namend++;
731 name = namend;
732 if (!*name)
3280af22 733 return gv ? gv : (GV*)*hv_fetch(PL_defstash, "main::", 6, TRUE);
79072805 734 }
79072805 735 }
a0d0e21e 736 len = namend - name;
463ee0b2
LW
737
738 /* No stash in name, so see how we can default */
739
740 if (!stash) {
7e2040f0 741 if (isIDFIRST_lazy(name)) {
9607fc9c
PP
742 bool global = FALSE;
743
18ea00d7
NC
744 /* name is always \0 terminated, and initial \0 wouldn't return
745 true from isIDFIRST_lazy, so we know that name[1] is defined */
746 switch (name[1]) {
747 case '\0':
748 if (*name == '_')
9d116dd7 749 global = TRUE;
18ea00d7
NC
750 break;
751 case 'N':
752 if (strEQ(name, "INC") || strEQ(name, "ENV"))
9d116dd7 753 global = TRUE;
18ea00d7
NC
754 break;
755 case 'I':
756 if (strEQ(name, "SIG"))
9d116dd7 757 global = TRUE;
18ea00d7
NC
758 break;
759 case 'T':
760 if (strEQ(name, "STDIN") || strEQ(name, "STDOUT") ||
761 strEQ(name, "STDERR"))
463ee0b2 762 global = TRUE;
18ea00d7
NC
763 break;
764 case 'R':
765 if (strEQ(name, "ARGV") || strEQ(name, "ARGVOUT"))
766 global = TRUE;
767 break;
463ee0b2 768 }
9607fc9c 769
463ee0b2 770 if (global)
3280af22 771 stash = PL_defstash;
923e4eb5 772 else if (IN_PERL_COMPILETIME) {
3280af22
NIS
773 stash = PL_curstash;
774 if (add && (PL_hints & HINT_STRICT_VARS) &&
748a9306
LW
775 sv_type != SVt_PVCV &&
776 sv_type != SVt_PVGV &&
4633a7c4 777 sv_type != SVt_PVFM &&
c07a80fd 778 sv_type != SVt_PVIO &&
70ec6265
NC
779 !(len == 1 && sv_type == SVt_PV &&
780 (*name == 'a' || *name == 'b')) )
748a9306 781 {
4633a7c4
LW
782 gvp = (GV**)hv_fetch(stash,name,len,0);
783 if (!gvp ||
3280af22 784 *gvp == (GV*)&PL_sv_undef ||
a5f75d66
AD
785 SvTYPE(*gvp) != SVt_PVGV)
786 {
4633a7c4 787 stash = 0;
a5f75d66 788 }
155aba94
GS
789 else if ((sv_type == SVt_PV && !GvIMPORTED_SV(*gvp)) ||
790 (sv_type == SVt_PVAV && !GvIMPORTED_AV(*gvp)) ||
791 (sv_type == SVt_PVHV && !GvIMPORTED_HV(*gvp)) )
4633a7c4 792 {
cea2e8a9 793 Perl_warn(aTHX_ "Variable \"%c%s\" is not imported",
4633a7c4
LW
794 sv_type == SVt_PVAV ? '@' :
795 sv_type == SVt_PVHV ? '%' : '$',
796 name);
8ebc5c01 797 if (GvCVu(*gvp))
cc507455 798 Perl_warn(aTHX_ "\t(Did you mean &%s instead?)\n", name);
a0d0e21e 799 stash = 0;
4633a7c4 800 }
a0d0e21e 801 }
85e6fe83 802 }
463ee0b2 803 else
1d7c1841 804 stash = CopSTASH(PL_curcop);
463ee0b2
LW
805 }
806 else
3280af22 807 stash = PL_defstash;
463ee0b2
LW
808 }
809
810 /* By this point we should have a stash and a name */
811
a0d0e21e 812 if (!stash) {
5a844595 813 if (add) {
608b3986 814 register SV *err = Perl_mess(aTHX_
5a844595
GS
815 "Global symbol \"%s%s\" requires explicit package name",
816 (sv_type == SVt_PV ? "$"
817 : sv_type == SVt_PVAV ? "@"
818 : sv_type == SVt_PVHV ? "%"
608b3986
AE
819 : ""), name);
820 if (USE_UTF8_IN_NAMES)
821 SvUTF8_on(err);
822 qerror(err);
d7aacf4e 823 stash = GvHV(gv_fetchpv("<none>::", GV_ADDMULTI, SVt_PVHV));
a0d0e21e 824 }
d7aacf4e
RGS
825 else
826 return Nullgv;
a0d0e21e
LW
827 }
828
829 if (!SvREFCNT(stash)) /* symbol table under destruction */
830 return Nullgv;
831
79072805 832 gvp = (GV**)hv_fetch(stash,name,len,add);
3280af22 833 if (!gvp || *gvp == (GV*)&PL_sv_undef)
79072805
LW
834 return Nullgv;
835 gv = *gvp;
836 if (SvTYPE(gv) == SVt_PVGV) {
a0d0e21e 837 if (add) {
a5f75d66 838 GvMULTI_on(gv);
a0d0e21e 839 gv_init_sv(gv, sv_type);
d2c93421
RH
840 if (*name=='!' && sv_type == SVt_PVHV && len==1)
841 require_errno(gv);
a0d0e21e 842 }
79072805 843 return gv;
55d729e4
GS
844 } else if (add & GV_NOINIT) {
845 return gv;
79072805 846 }
93a17b20
LW
847
848 /* Adding a new symbol */
849
0453d815 850 if (add & GV_ADDWARN && ckWARN_d(WARN_INTERNAL))
9014280d 851 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "Had to create %s unexpectedly", nambeg);
55d729e4 852 gv_init(gv, stash, name, len, add & GV_ADDMULTI);
a0d0e21e 853 gv_init_sv(gv, sv_type);
93a17b20 854
7272584d
PM
855 if (isALPHA(name[0]) && ! (isLEXWARN_on ? ckWARN(WARN_ONCE)
856 : (PL_dowarn & G_WARN_ON ) ) )
0453d815
PM
857 GvMULTI_on(gv) ;
858
93a17b20 859 /* set up magic where warranted */
cc4c2da6 860 if (len > 1) {
9431620d 861#ifndef EBCDIC
cc4c2da6
NC
862 if (*name > 'V' ) {
863 /* Nothing else to do.
91f565cb 864 The compiler will probably turn the switch statement into a
cc4c2da6
NC
865 branch table. Make sure we avoid even that small overhead for
866 the common case of lower case variable names. */
9431620d
NC
867 } else
868#endif
869 {
cc4c2da6
NC
870 const char *name2 = name + 1;
871 switch (*name) {
872 case 'A':
873 if (strEQ(name2, "RGV")) {
874 IoFLAGS(GvIOn(gv)) |= IOf_ARGV|IOf_START;
875 }
876 break;
877 case 'E':
878 if (strnEQ(name2, "XPORT", 5))
879 GvMULTI_on(gv);
880 break;
881 case 'I':
882 if (strEQ(name2, "SA")) {
883 AV* av = GvAVn(gv);
884 GvMULTI_on(gv);
885 sv_magic((SV*)av, (SV*)gv, PERL_MAGIC_isa, Nullch, 0);
886 /* NOTE: No support for tied ISA */
887 if ((add & GV_ADDMULTI) && strEQ(nambeg,"AnyDBM_File::ISA")
888 && AvFILLp(av) == -1)
889 {
e1ec3a88 890 const char *pname;
cc4c2da6
NC
891 av_push(av, newSVpvn(pname = "NDBM_File",9));
892 gv_stashpvn(pname, 9, TRUE);
893 av_push(av, newSVpvn(pname = "DB_File",7));
894 gv_stashpvn(pname, 7, TRUE);
895 av_push(av, newSVpvn(pname = "GDBM_File",9));
896 gv_stashpvn(pname, 9, TRUE);
897 av_push(av, newSVpvn(pname = "SDBM_File",9));
898 gv_stashpvn(pname, 9, TRUE);
899 av_push(av, newSVpvn(pname = "ODBM_File",9));
900 gv_stashpvn(pname, 9, TRUE);
901 }
902 }
903 break;
904 case 'O':
905 if (strEQ(name2, "VERLOAD")) {
906 HV* hv = GvHVn(gv);
907 GvMULTI_on(gv);
908 hv_magic(hv, Nullgv, PERL_MAGIC_overload);
909 }
910 break;
911 case 'S':
912 if (strEQ(name2, "IG")) {
913 HV *hv;
914 I32 i;
915 if (!PL_psig_ptr) {
916 Newz(73, PL_psig_ptr, SIG_SIZE, SV*);
917 Newz(73, PL_psig_name, SIG_SIZE, SV*);
918 Newz(73, PL_psig_pend, SIG_SIZE, int);
919 }
920 GvMULTI_on(gv);
921 hv = GvHVn(gv);
922 hv_magic(hv, Nullgv, PERL_MAGIC_sig);
923 for (i = 1; i < SIG_SIZE; i++) {
924 SV ** init;
925 init = hv_fetch(hv, PL_sig_name[i], strlen(PL_sig_name[i]), 1);
926 if (init)
927 sv_setsv(*init, &PL_sv_undef);
928 PL_psig_ptr[i] = 0;
929 PL_psig_name[i] = 0;
930 PL_psig_pend[i] = 0;
931 }
932 }
933 break;
934 case 'V':
935 if (strEQ(name2, "ERSION"))
936 GvMULTI_on(gv);
937 break;
938 case '\005': /* $^ENCODING */
939 if (strEQ(name2, "NCODING"))
940 goto magicalize;
941 break;
942 case '\017': /* $^OPEN */
943 if (strEQ(name2, "PEN"))
944 goto magicalize;
945 break;
946 case '\024': /* ${^TAINT} */
947 if (strEQ(name2, "AINT"))
948 goto ro_magicalize;
949 break;
7cebcbc0 950 case '\025': /* ${^UNICODE}, ${^UTF8LOCALE} */
cc4c2da6
NC
951 if (strEQ(name2, "NICODE"))
952 goto ro_magicalize;
7cebcbc0
NC
953 if (strEQ(name2, "TF8LOCALE"))
954 goto ro_magicalize;
cc4c2da6
NC
955 break;
956 case '\027': /* $^WARNING_BITS */
957 if (strEQ(name2, "ARNING_BITS"))
958 goto magicalize;
959 break;
960 case '1':
961 case '2':
962 case '3':
963 case '4':
964 case '5':
965 case '6':
966 case '7':
967 case '8':
968 case '9':
85e6fe83 969 {
cc4c2da6
NC
970 /* ensures variable is only digits */
971 /* ${"1foo"} fails this test (and is thus writeable) */
972 /* added by japhy, but borrowed from is_gv_magical */
973 const char *end = name + len;
974 while (--end > name) {
975 if (!isDIGIT(*end)) return gv;
976 }
977 goto ro_magicalize;
1d7c1841 978 }
dc437b57 979 }
93a17b20 980 }
392db708
NC
981 } else {
982 /* Names of length 1. (Or 0. But name is NUL terminated, so that will
983 be case '\0' in this switch statement (ie a default case) */
cc4c2da6
NC
984 switch (*name) {
985 case '&':
986 case '`':
987 case '\'':
988 if (
989 sv_type == SVt_PVAV ||
990 sv_type == SVt_PVHV ||
991 sv_type == SVt_PVCV ||
992 sv_type == SVt_PVFM ||
993 sv_type == SVt_PVIO
994 ) { break; }
995 PL_sawampersand = TRUE;
996 goto ro_magicalize;
997
998 case ':':
999 sv_setpv(GvSV(gv),PL_chopset);
1000 goto magicalize;
1001
1002 case '?':
ff0cee69 1003#ifdef COMPLEX_STATUS
cc4c2da6 1004 (void)SvUPGRADE(GvSV(gv), SVt_PVLV);
ff0cee69 1005#endif
cc4c2da6 1006 goto magicalize;
ff0cee69 1007
cc4c2da6 1008 case '!':
d2c93421 1009
cc4c2da6
NC
1010 /* If %! has been used, automatically load Errno.pm.
1011 The require will itself set errno, so in order to
1012 preserve its value we have to set up the magic
1013 now (rather than going to magicalize)
1014 */
d2c93421 1015
cc4c2da6 1016 sv_magic(GvSV(gv), (SV*)gv, PERL_MAGIC_sv, name, len);
d2c93421 1017
cc4c2da6
NC
1018 if (sv_type == SVt_PVHV)
1019 require_errno(gv);
d2c93421 1020
6cef1e77 1021 break;
cc4c2da6
NC
1022 case '-':
1023 {
6cef1e77 1024 AV* av = GvAVn(gv);
14befaf4 1025 sv_magic((SV*)av, Nullsv, PERL_MAGIC_regdata, Nullch, 0);
03a27ae7 1026 SvREADONLY_on(av);
cc4c2da6
NC
1027 goto magicalize;
1028 }
1029 case '*':
1030 if (sv_type == SVt_PV && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
1031 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
1032 "$* is no longer supported");
6cef1e77 1033 break;
cc4c2da6
NC
1034 case '#':
1035 if (sv_type == SVt_PV && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
1036 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
1037 "Use of $# is deprecated");
1038 goto magicalize;
1039 case '|':
1040 sv_setiv(GvSV(gv), (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0);
1041 goto magicalize;
1042
1043 case '+':
1044 {
1045 AV* av = GvAVn(gv);
14befaf4 1046 sv_magic((SV*)av, (SV*)av, PERL_MAGIC_regdata, Nullch, 0);
03a27ae7 1047 SvREADONLY_on(av);
cc4c2da6 1048 /* FALL THROUGH */
e521374c 1049 }
cc4c2da6
NC
1050 case '\023': /* $^S */
1051 case '1':
1052 case '2':
1053 case '3':
1054 case '4':
1055 case '5':
1056 case '6':
1057 case '7':
1058 case '8':
1059 case '9':
1060 ro_magicalize:
1061 SvREADONLY_on(GvSV(gv));
1062 /* FALL THROUGH */
1063 case '[':
1064 case '^':
1065 case '~':
1066 case '=':
1067 case '%':
1068 case '.':
1069 case '(':
1070 case ')':
1071 case '<':
1072 case '>':
1073 case ',':
1074 case '\\':
1075 case '/':
1076 case '\001': /* $^A */
1077 case '\003': /* $^C */
1078 case '\004': /* $^D */
1079 case '\005': /* $^E */
1080 case '\006': /* $^F */
1081 case '\010': /* $^H */
1082 case '\011': /* $^I, NOT \t in EBCDIC */
1083 case '\016': /* $^N */
1084 case '\017': /* $^O */
1085 case '\020': /* $^P */
1086 case '\024': /* $^T */
1087 case '\027': /* $^W */
1088 magicalize:
1089 sv_magic(GvSV(gv), (SV*)gv, PERL_MAGIC_sv, name, len);
1090 break;
e521374c 1091
cc4c2da6
NC
1092 case '\014': /* $^L */
1093 sv_setpv(GvSV(gv),"\f");
1094 PL_formfeed = GvSV(gv);
463ee0b2 1095 break;
cc4c2da6
NC
1096 case ';':
1097 sv_setpv(GvSV(gv),"\034");
463ee0b2 1098 break;
cc4c2da6
NC
1099 case ']':
1100 {
f86702cc 1101 SV *sv = GvSV(gv);
d7aa5382
JP
1102 if (!sv_derived_from(PL_patchlevel, "version"))
1103 (void *)upg_version(PL_patchlevel);
7d54d38e
SH
1104 GvSV(gv) = vnumify(PL_patchlevel);
1105 SvREADONLY_on(GvSV(gv));
1106 SvREFCNT_dec(sv);
93a17b20
LW
1107 }
1108 break;
cc4c2da6
NC
1109 case '\026': /* $^V */
1110 {
35a4481c 1111 SV * const sv = GvSV(gv);
f9be5ac8
DM
1112 GvSV(gv) = new_version(PL_patchlevel);
1113 SvREADONLY_on(GvSV(gv));
1114 SvREFCNT_dec(sv);
16070b82
GS
1115 }
1116 break;
cc4c2da6 1117 }
79072805 1118 }
93a17b20 1119 return gv;
79072805
LW
1120}
1121
1122void
35a4481c 1123Perl_gv_fullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
43693395 1124{
35a4481c
AL
1125 const char *name;
1126 const HV * const hv = GvSTASH(gv);
43693395 1127 if (!hv) {
0c34ef67 1128 SvOK_off(sv);
43693395
GS
1129 return;
1130 }
1131 sv_setpv(sv, prefix ? prefix : "");
e27ad1f2 1132
9dde0ab5
NC
1133 name = HvNAME(hv);
1134 if (!name)
e27ad1f2 1135 name = "__ANON__";
9dde0ab5 1136
e27ad1f2 1137 if (keepmain || strNE(name, "main")) {
6a7a3232
NC
1138 sv_catpv(sv,name);
1139 sv_catpvn(sv,"::", 2);
43693395 1140 }
257984c0 1141 sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv));
43693395
GS
1142}
1143
1144void
35a4481c 1145Perl_gv_fullname3(pTHX_ SV *sv, const GV *gv, const char *prefix)
79072805 1146{
84e79d79 1147 gv_fullname4(sv, gv, prefix, TRUE);
79072805
LW
1148}
1149
1150void
35a4481c 1151Perl_gv_efullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
43693395 1152{
35a4481c 1153 const GV *egv = GvEGV(gv);
43693395
GS
1154 if (!egv)
1155 egv = gv;
1156 gv_fullname4(sv, egv, prefix, keepmain);
1157}
1158
1159void
35a4481c 1160Perl_gv_efullname3(pTHX_ SV *sv, const GV *gv, const char *prefix)
79072805 1161{
84e79d79 1162 gv_efullname4(sv, gv, prefix, TRUE);
f6aff53a
PP
1163}
1164
35a4481c 1165/* compatibility with versions <= 5.003. */
f6aff53a 1166void
35a4481c 1167Perl_gv_fullname(pTHX_ SV *sv, const GV *gv)
f6aff53a 1168{
35a4481c 1169 gv_fullname3(sv, gv, sv == (const SV*)gv ? "*" : "");
f6aff53a
PP
1170}
1171
35a4481c 1172/* compatibility with versions <= 5.003. */
f6aff53a 1173void
35a4481c 1174Perl_gv_efullname(pTHX_ SV *sv, const GV *gv)
f6aff53a 1175{
e1ec3a88 1176 gv_efullname3(sv, gv, sv == (const SV*)gv ? "*" : "");
79072805
LW
1177}
1178
1179IO *
864dbfa3 1180Perl_newIO(pTHX)
79072805
LW
1181{
1182 IO *io;
8990e307
LW
1183 GV *iogv;
1184
1185 io = (IO*)NEWSV(0,0);
a0d0e21e 1186 sv_upgrade((SV *)io,SVt_PVIO);
8990e307
LW
1187 SvREFCNT(io) = 1;
1188 SvOBJECT_on(io);
081fc587
AB
1189 /* Clear the stashcache because a new IO could overrule a
1190 package name */
1191 hv_clear(PL_stashcache);
c9de509e 1192 iogv = gv_fetchpv("FileHandle::", FALSE, SVt_PVHV);
5f2d631d
GS
1193 /* unless exists($main::{FileHandle}) and defined(%main::FileHandle::) */
1194 if (!(iogv && GvHV(iogv) && HvARRAY(GvHV(iogv))))
c9de509e 1195 iogv = gv_fetchpv("IO::Handle::", TRUE, SVt_PVHV);
b162af07 1196 SvSTASH_set(io, (HV*)SvREFCNT_inc(GvHV(iogv)));
79072805
LW
1197 return io;
1198}
1199
1200void
864dbfa3 1201Perl_gv_check(pTHX_ HV *stash)
79072805 1202{
79072805
LW
1203 register I32 i;
1204 register GV *gv;
463ee0b2
LW
1205 HV *hv;
1206
8990e307
LW
1207 if (!HvARRAY(stash))
1208 return;
a0d0e21e 1209 for (i = 0; i <= (I32) HvMAX(stash); i++) {
e1ec3a88 1210 const HE *entry;
dc437b57
PP
1211 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
1212 if (HeKEY(entry)[HeKLEN(entry)-1] == ':' &&
b862623f 1213 (gv = (GV*)HeVAL(entry)) && isGV(gv) && (hv = GvHV(gv)))
a0d0e21e 1214 {
19b6c847 1215 if (hv != PL_defstash && hv != stash)
a0d0e21e
LW
1216 gv_check(hv); /* nested package */
1217 }
dc437b57 1218 else if (isALPHA(*HeKEY(entry))) {
e1ec3a88 1219 const char *file;
dc437b57 1220 gv = (GV*)HeVAL(entry);
55d729e4 1221 if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv))
463ee0b2 1222 continue;
1d7c1841
GS
1223 file = GvFILE(gv);
1224 /* performance hack: if filename is absolute and it's a standard
1225 * module, don't bother warning */
1226 if (file
1227 && PERL_FILE_IS_ABSOLUTE(file)
6eb630b7
CN
1228#ifdef MACOS_TRADITIONAL
1229 && (instr(file, ":lib:")
1230#else
1231 && (instr(file, "/lib/")
1232#endif
1233 || instr(file, ".pm")))
1d7c1841 1234 {
8990e307 1235 continue;
1d7c1841
GS
1236 }
1237 CopLINE_set(PL_curcop, GvLINE(gv));
1238#ifdef USE_ITHREADS
dd374669 1239 CopFILE(PL_curcop) = (char *)file; /* set for warning */
1d7c1841
GS
1240#else
1241 CopFILEGV(PL_curcop) = gv_fetchfile(file);
1242#endif
9014280d 1243 Perl_warner(aTHX_ packWARN(WARN_ONCE),
599cee73 1244 "Name \"%s::%s\" used only once: possible typo",
a0d0e21e 1245 HvNAME(stash), GvNAME(gv));
463ee0b2 1246 }
79072805
LW
1247 }
1248 }
1249}
1250
1251GV *
e1ec3a88 1252Perl_newGVgen(pTHX_ const char *pack)
79072805 1253{
cea2e8a9 1254 return gv_fetchpv(Perl_form(aTHX_ "%s::_GEN_%ld", pack, (long)PL_gensym++),
46fc3d4c 1255 TRUE, SVt_PVGV);
79072805
LW
1256}
1257
1258/* hopefully this is only called on local symbol table entries */
1259
1260GP*
864dbfa3 1261Perl_gp_ref(pTHX_ GP *gp)
79072805 1262{
1d7c1841
GS
1263 if (!gp)
1264 return (GP*)NULL;
79072805 1265 gp->gp_refcnt++;
44a8e56a
PP
1266 if (gp->gp_cv) {
1267 if (gp->gp_cvgen) {
1268 /* multi-named GPs cannot be used for method cache */
1269 SvREFCNT_dec(gp->gp_cv);
1270 gp->gp_cv = Nullcv;
1271 gp->gp_cvgen = 0;
1272 }
1273 else {
1274 /* Adding a new name to a subroutine invalidates method cache */
3280af22 1275 PL_sub_generation++;
44a8e56a
PP
1276 }
1277 }
79072805 1278 return gp;
79072805
LW
1279}
1280
1281void
864dbfa3 1282Perl_gp_free(pTHX_ GV *gv)
79072805 1283{
79072805
LW
1284 GP* gp;
1285
1286 if (!gv || !(gp = GvGP(gv)))
1287 return;
f248d071
GS
1288 if (gp->gp_refcnt == 0) {
1289 if (ckWARN_d(WARN_INTERNAL))
9014280d 1290 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
472d47bc
SB
1291 "Attempt to free unreferenced glob pointers"
1292 pTHX__FORMAT pTHX__VALUE);
79072805
LW
1293 return;
1294 }
44a8e56a
PP
1295 if (gp->gp_cv) {
1296 /* Deleting the name of a subroutine invalidates method cache */
3280af22 1297 PL_sub_generation++;
44a8e56a 1298 }
748a9306
LW
1299 if (--gp->gp_refcnt > 0) {
1300 if (gp->gp_egv == gv)
1301 gp->gp_egv = 0;
79072805 1302 return;
748a9306 1303 }
79072805 1304
13207a71 1305 if (gp->gp_sv) SvREFCNT_dec(gp->gp_sv);
8926f269 1306 if (gp->gp_av) SvREFCNT_dec(gp->gp_av);
13207a71
JH
1307 if (gp->gp_hv) {
1308 if (PL_stashcache && HvNAME(gp->gp_hv))
1309 hv_delete(PL_stashcache,
1310 HvNAME(gp->gp_hv), strlen(HvNAME(gp->gp_hv)),
1311 G_DISCARD);
1312 SvREFCNT_dec(gp->gp_hv);
1313 }
1314 if (gp->gp_io) SvREFCNT_dec(gp->gp_io);
1315 if (gp->gp_cv) SvREFCNT_dec(gp->gp_cv);
1316 if (gp->gp_form) SvREFCNT_dec(gp->gp_form);
748a9306 1317
79072805
LW
1318 Safefree(gp);
1319 GvGP(gv) = 0;
1320}
1321
d460ef45
NIS
1322int
1323Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg)
1324{
1325 AMT *amtp = (AMT*)mg->mg_ptr;
dd374669
AL
1326 (void)sv;
1327
d460ef45
NIS
1328 if (amtp && AMT_AMAGIC(amtp)) {
1329 int i;
1330 for (i = 1; i < NofAMmeth; i++) {
1331 CV *cv = amtp->table[i];
1332 if (cv != Nullcv) {
1333 SvREFCNT_dec((SV *) cv);
1334 amtp->table[i] = Nullcv;
1335 }
1336 }
1337 }
1338 return 0;
1339}
1340
a0d0e21e
LW
1341/* Updates and caches the CV's */
1342
1343bool
864dbfa3 1344Perl_Gv_AMupdate(pTHX_ HV *stash)
a0d0e21e 1345{
a0d0e21e
LW
1346 GV* gv;
1347 CV* cv;
14befaf4 1348 MAGIC* mg=mg_find((SV*)stash, PERL_MAGIC_overload_table);
8ac85365 1349 AMT *amtp = (mg) ? (AMT*)mg->mg_ptr: (AMT *) NULL;
a6006777 1350 AMT amt;
a0d0e21e 1351
3280af22
NIS
1352 if (mg && amtp->was_ok_am == PL_amagic_generation
1353 && amtp->was_ok_sub == PL_sub_generation)
eb160463 1354 return (bool)AMT_OVERLOADED(amtp);
14befaf4 1355 sv_unmagic((SV*)stash, PERL_MAGIC_overload_table);
a0d0e21e 1356
cea2e8a9 1357 DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME(stash)) );
a0d0e21e 1358
d460ef45 1359 Zero(&amt,1,AMT);
3280af22
NIS
1360 amt.was_ok_am = PL_amagic_generation;
1361 amt.was_ok_sub = PL_sub_generation;
a6006777
PP
1362 amt.fallback = AMGfallNO;
1363 amt.flags = 0;
1364
a6006777 1365 {
32251b26
IZ
1366 int filled = 0, have_ovl = 0;
1367 int i, lim = 1;
a6006777 1368 SV* sv = NULL;
a6006777 1369
22c35a8c 1370 /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
a6006777 1371
89ffc314
IZ
1372 /* Try to find via inheritance. */
1373 gv = gv_fetchmeth(stash, PL_AMG_names[0], 2, -1);
1374 if (gv)
1375 sv = GvSV(gv);
1376
1377 if (!gv)
32251b26 1378 lim = DESTROY_amg; /* Skip overloading entries. */
89ffc314
IZ
1379 else if (SvTRUE(sv))
1380 amt.fallback=AMGfallYES;
1381 else if (SvOK(sv))
1382 amt.fallback=AMGfallNEVER;
a6006777 1383
32251b26
IZ
1384 for (i = 1; i < lim; i++)
1385 amt.table[i] = Nullcv;
1386 for (; i < NofAMmeth; i++) {
e1ec3a88 1387 const char *cooky = PL_AMG_names[i];
32251b26 1388 /* Human-readable form, for debugging: */
e1ec3a88
AL
1389 const char *cp = (i >= DESTROY_amg ? cooky : AMG_id2name(i));
1390 const STRLEN l = strlen(cooky);
89ffc314 1391
cea2e8a9 1392 DEBUG_o( Perl_deb(aTHX_ "Checking overloading of `%s' in package `%.256s'\n",
44a8e56a 1393 cp, HvNAME(stash)) );
611c1e95
IZ
1394 /* don't fill the cache while looking up!
1395 Creation of inheritance stubs in intermediate packages may
1396 conflict with the logic of runtime method substitution.
1397 Indeed, for inheritance A -> B -> C, if C overloads "+0",
1398 then we could have created stubs for "(+0" in A and C too.
1399 But if B overloads "bool", we may want to use it for
1400 numifying instead of C's "+0". */
1401 if (i >= DESTROY_amg)
1402 gv = Perl_gv_fetchmeth_autoload(aTHX_ stash, cooky, l, 0);
1403 else /* Autoload taken care of below */
1404 gv = Perl_gv_fetchmeth(aTHX_ stash, cooky, l, -1);
46fc3d4c 1405 cv = 0;
89ffc314 1406 if (gv && (cv = GvCV(gv))) {
44a8e56a
PP
1407 if (GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")
1408 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "overload")) {
611c1e95
IZ
1409 /* This is a hack to support autoloading..., while
1410 knowing *which* methods were declared as overloaded. */
44a8e56a 1411 /* GvSV contains the name of the method. */
4ea42e7f 1412 GV *ngv = Nullgv;
44a8e56a 1413
84c133a0
RB
1414 DEBUG_o( Perl_deb(aTHX_ "Resolving method `%"SVf256\
1415 "' for overloaded `%s' in package `%.256s'\n",
35c1215d 1416 GvSV(gv), cp, HvNAME(stash)) );
b267980d 1417 if (!SvPOK(GvSV(gv))
dc848c6f
PP
1418 || !(ngv = gv_fetchmethod_autoload(stash, SvPVX(GvSV(gv)),
1419 FALSE)))
1420 {
44a8e56a 1421 /* Can be an import stub (created by `can'). */
35c1215d
NC
1422 SV *gvsv = GvSV(gv);
1423 const char *name = SvPOK(gvsv) ? SvPVX(gvsv) : "???";
84c133a0
RB
1424 Perl_croak(aTHX_ "%s method `%.256s' overloading `%s' "\
1425 "in package `%.256s'",
35c1215d
NC
1426 (GvCVGEN(gv) ? "Stub found while resolving"
1427 : "Can't resolve"),
1428 name, cp, HvNAME(stash));
44a8e56a 1429 }
dc848c6f 1430 cv = GvCV(gv = ngv);
44a8e56a 1431 }
cea2e8a9 1432 DEBUG_o( Perl_deb(aTHX_ "Overloading `%s' in package `%.256s' via `%.256s::%.256s' \n",
44a8e56a
PP
1433 cp, HvNAME(stash), HvNAME(GvSTASH(CvGV(cv))),
1434 GvNAME(CvGV(cv))) );
1435 filled = 1;
32251b26
IZ
1436 if (i < DESTROY_amg)
1437 have_ovl = 1;
611c1e95
IZ
1438 } else if (gv) { /* Autoloaded... */
1439 cv = (CV*)gv;
1440 filled = 1;
44a8e56a 1441 }
a6006777 1442 amt.table[i]=(CV*)SvREFCNT_inc(cv);
a0d0e21e 1443 }
a0d0e21e 1444 if (filled) {
a6006777 1445 AMT_AMAGIC_on(&amt);
32251b26
IZ
1446 if (have_ovl)
1447 AMT_OVERLOADED_on(&amt);
14befaf4
DM
1448 sv_magic((SV*)stash, 0, PERL_MAGIC_overload_table,
1449 (char*)&amt, sizeof(AMT));
32251b26 1450 return have_ovl;
a0d0e21e
LW
1451 }
1452 }
a6006777 1453 /* Here we have no table: */
9cbac4c7 1454 /* no_table: */
a6006777 1455 AMT_AMAGIC_off(&amt);
14befaf4
DM
1456 sv_magic((SV*)stash, 0, PERL_MAGIC_overload_table,
1457 (char*)&amt, sizeof(AMTS));
a0d0e21e
LW
1458 return FALSE;
1459}
1460
32251b26
IZ
1461
1462CV*
1463Perl_gv_handler(pTHX_ HV *stash, I32 id)
1464{
3f8f4626 1465 MAGIC *mg;
32251b26 1466 AMT *amtp;
3ad83ce7 1467 CV *ret;
32251b26 1468
e27ad1f2 1469 if (!stash || !HvNAME(stash))
3f8f4626 1470 return Nullcv;
14befaf4 1471 mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
32251b26
IZ
1472 if (!mg) {
1473 do_update:
1474 Gv_AMupdate(stash);
14befaf4 1475 mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
32251b26
IZ
1476 }
1477 amtp = (AMT*)mg->mg_ptr;
1478 if ( amtp->was_ok_am != PL_amagic_generation
1479 || amtp->was_ok_sub != PL_sub_generation )
1480 goto do_update;
3ad83ce7
AMS
1481 if (AMT_AMAGIC(amtp)) {
1482 ret = amtp->table[id];
1483 if (ret && isGV(ret)) { /* Autoloading stab */
1484 /* Passing it through may have resulted in a warning
1485 "Inherited AUTOLOAD for a non-method deprecated", since
1486 our caller is going through a function call, not a method call.
1487 So return the CV for AUTOLOAD, setting $AUTOLOAD. */
e1ec3a88 1488 GV *gv = gv_fetchmethod(stash, PL_AMG_names[id]);
3ad83ce7
AMS
1489
1490 if (gv && GvCV(gv))
1491 return GvCV(gv);
1492 }
1493 return ret;
1494 }
1495
32251b26
IZ
1496 return Nullcv;
1497}
1498
1499
a0d0e21e 1500SV*
864dbfa3 1501Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
a0d0e21e 1502{
27da23d5 1503 dVAR;
b267980d 1504 MAGIC *mg;
9c5ffd7c 1505 CV *cv=NULL;
a0d0e21e 1506 CV **cvp=NULL, **ocvp=NULL;
9c5ffd7c 1507 AMT *amtp=NULL, *oamtp=NULL;
497b47a8 1508 int off=0, off1, lr=0, assign=AMGf_assign & flags, notfound=0;
ee239bfe 1509 int postpr = 0, force_cpy = 0, assignshift = assign ? 1 : 0;
497b47a8
JH
1510#ifdef DEBUGGING
1511 int fl=0;
497b47a8 1512#endif
25716404 1513 HV* stash=NULL;
a0d0e21e 1514 if (!(AMGf_noleft & flags) && SvAMAGIC(left)
25716404
GS
1515 && (stash = SvSTASH(SvRV(left)))
1516 && (mg = mg_find((SV*)stash, PERL_MAGIC_overload_table))
b267980d 1517 && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
a6006777 1518 ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
8ac85365 1519 : (CV **) NULL))
b267980d 1520 && ((cv = cvp[off=method+assignshift])
748a9306
LW
1521 || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
1522 * usual method */
497b47a8
JH
1523 (
1524#ifdef DEBUGGING
1525 fl = 1,
1526#endif
1527 cv = cvp[off=method])))) {
a0d0e21e
LW
1528 lr = -1; /* Call method for left argument */
1529 } else {
1530 if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) {
1531 int logic;
1532
1533 /* look for substituted methods */
ee239bfe 1534 /* In all the covered cases we should be called with assign==0. */
a0d0e21e
LW
1535 switch (method) {
1536 case inc_amg:
ee239bfe
IZ
1537 force_cpy = 1;
1538 if ((cv = cvp[off=add_ass_amg])
1539 || ((cv = cvp[off = add_amg]) && (force_cpy = 0, postpr = 1))) {
3280af22 1540 right = &PL_sv_yes; lr = -1; assign = 1;
a0d0e21e
LW
1541 }
1542 break;
1543 case dec_amg:
ee239bfe
IZ
1544 force_cpy = 1;
1545 if ((cv = cvp[off = subtr_ass_amg])
1546 || ((cv = cvp[off = subtr_amg]) && (force_cpy = 0, postpr=1))) {
3280af22 1547 right = &PL_sv_yes; lr = -1; assign = 1;
a0d0e21e
LW
1548 }
1549 break;
1550 case bool__amg:
1551 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg]));
1552 break;
1553 case numer_amg:
1554 (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg]));
1555 break;
1556 case string_amg:
1557 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg]));
1558 break;
dc437b57 1559 case not_amg:
b267980d 1560 (void)((cv = cvp[off=bool__amg])
dc437b57
PP
1561 || (cv = cvp[off=numer_amg])
1562 || (cv = cvp[off=string_amg]));
1563 postpr = 1;
1564 break;
748a9306
LW
1565 case copy_amg:
1566 {
76e3520e
GS
1567 /*
1568 * SV* ref causes confusion with the interpreter variable of
1569 * the same name
1570 */
1571 SV* tmpRef=SvRV(left);
1572 if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) {
fc36a67e
PP
1573 /*
1574 * Just to be extra cautious. Maybe in some
1575 * additional cases sv_setsv is safe, too.
1576 */
76e3520e 1577 SV* newref = newSVsv(tmpRef);
748a9306 1578 SvOBJECT_on(newref);
b162af07 1579 SvSTASH_set(newref, (HV*)SvREFCNT_inc(SvSTASH(tmpRef)));
748a9306
LW
1580 return newref;
1581 }
1582 }
1583 break;
a0d0e21e 1584 case abs_amg:
b267980d 1585 if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg])
a0d0e21e 1586 && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) {
748a9306 1587 SV* nullsv=sv_2mortal(newSViv(0));
a0d0e21e 1588 if (off1==lt_amg) {
748a9306 1589 SV* lessp = amagic_call(left,nullsv,
a0d0e21e
LW
1590 lt_amg,AMGf_noright);
1591 logic = SvTRUE(lessp);
1592 } else {
748a9306 1593 SV* lessp = amagic_call(left,nullsv,
a0d0e21e
LW
1594 ncmp_amg,AMGf_noright);
1595 logic = (SvNV(lessp) < 0);
1596 }
1597 if (logic) {
1598 if (off==subtr_amg) {
1599 right = left;
748a9306 1600 left = nullsv;
a0d0e21e
LW
1601 lr = 1;
1602 }
1603 } else {
1604 return left;
1605 }
1606 }
1607 break;
1608 case neg_amg:
155aba94 1609 if ((cv = cvp[off=subtr_amg])) {
a0d0e21e
LW
1610 right = left;
1611 left = sv_2mortal(newSViv(0));
1612 lr = 1;
1613 }
1614 break;
f216259d 1615 case int_amg:
f5284f61 1616 case iter_amg: /* XXXX Eventually should do to_gv. */
b267980d
NIS
1617 /* FAIL safe */
1618 return NULL; /* Delegate operation to standard mechanisms. */
1619 break;
f5284f61
IZ
1620 case to_sv_amg:
1621 case to_av_amg:
1622 case to_hv_amg:
1623 case to_gv_amg:
1624 case to_cv_amg:
1625 /* FAIL safe */
b267980d 1626 return left; /* Delegate operation to standard mechanisms. */
f5284f61 1627 break;
a0d0e21e
LW
1628 default:
1629 goto not_found;
1630 }
1631 if (!cv) goto not_found;
1632 } else if (!(AMGf_noright & flags) && SvAMAGIC(right)
25716404
GS
1633 && (stash = SvSTASH(SvRV(right)))
1634 && (mg = mg_find((SV*)stash, PERL_MAGIC_overload_table))
b267980d 1635 && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
a6006777 1636 ? (amtp = (AMT*)mg->mg_ptr)->table
8ac85365 1637 : (CV **) NULL))
a0d0e21e
LW
1638 && (cv = cvp[off=method])) { /* Method for right
1639 * argument found */
1640 lr=1;
b267980d
NIS
1641 } else if (((ocvp && oamtp->fallback > AMGfallNEVER
1642 && (cvp=ocvp) && (lr = -1))
a0d0e21e
LW
1643 || (cvp && amtp->fallback > AMGfallNEVER && (lr=1)))
1644 && !(flags & AMGf_unary)) {
1645 /* We look for substitution for
1646 * comparison operations and
fc36a67e 1647 * concatenation */
a0d0e21e
LW
1648 if (method==concat_amg || method==concat_ass_amg
1649 || method==repeat_amg || method==repeat_ass_amg) {
1650 return NULL; /* Delegate operation to string conversion */
1651 }
1652 off = -1;
1653 switch (method) {
1654 case lt_amg:
1655 case le_amg:
1656 case gt_amg:
1657 case ge_amg:
1658 case eq_amg:
1659 case ne_amg:
1660 postpr = 1; off=ncmp_amg; break;
1661 case slt_amg:
1662 case sle_amg:
1663 case sgt_amg:
1664 case sge_amg:
1665 case seq_amg:
1666 case sne_amg:
1667 postpr = 1; off=scmp_amg; break;
1668 }
1669 if (off != -1) cv = cvp[off];
1670 if (!cv) {
1671 goto not_found;
1672 }
1673 } else {
a6006777 1674 not_found: /* No method found, either report or croak */
b267980d
NIS
1675 switch (method) {
1676 case to_sv_amg:
1677 case to_av_amg:
1678 case to_hv_amg:
1679 case to_gv_amg:
1680 case to_cv_amg:
1681 /* FAIL safe */
1682 return left; /* Delegate operation to standard mechanisms. */
1683 break;
1684 }
a0d0e21e
LW
1685 if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */
1686 notfound = 1; lr = -1;
1687 } else if (cvp && (cv=cvp[nomethod_amg])) {
1688 notfound = 1; lr = 1;
1689 } else {
46fc3d4c 1690 SV *msg;
774d564b 1691 if (off==-1) off=method;
b267980d 1692 msg = sv_2mortal(Perl_newSVpvf(aTHX_
46fc3d4c 1693 "Operation `%s': no method found,%sargument %s%s%s%s",
89ffc314 1694 AMG_id2name(method + assignshift),
e7ea3e70 1695 (flags & AMGf_unary ? " " : "\n\tleft "),
b267980d 1696 SvAMAGIC(left)?
a0d0e21e
LW
1697 "in overloaded package ":
1698 "has no overloaded magic",
b267980d 1699 SvAMAGIC(left)?
a0d0e21e
LW
1700 HvNAME(SvSTASH(SvRV(left))):
1701 "",
b267980d 1702 SvAMAGIC(right)?
e7ea3e70 1703 ",\n\tright argument in overloaded package ":
b267980d 1704 (flags & AMGf_unary
e7ea3e70
IZ
1705 ? ""
1706 : ",\n\tright argument has no overloaded magic"),
b267980d 1707 SvAMAGIC(right)?
a0d0e21e 1708 HvNAME(SvSTASH(SvRV(right))):
46fc3d4c 1709 ""));
a0d0e21e 1710 if (amtp && amtp->fallback >= AMGfallYES) {
cea2e8a9 1711 DEBUG_o( Perl_deb(aTHX_ "%s", SvPVX(msg)) );
a0d0e21e 1712 } else {
894356b3 1713 Perl_croak(aTHX_ "%"SVf, msg);
a0d0e21e
LW
1714 }
1715 return NULL;
1716 }
ee239bfe 1717 force_cpy = force_cpy || assign;
a0d0e21e
LW
1718 }
1719 }
497b47a8 1720#ifdef DEBUGGING
a0d0e21e 1721 if (!notfound) {
497b47a8
JH
1722 DEBUG_o(Perl_deb(aTHX_
1723 "Overloaded operator `%s'%s%s%s:\n\tmethod%s found%s in package %s%s\n",
1724 AMG_id2name(off),
1725 method+assignshift==off? "" :
1726 " (initially `",
1727 method+assignshift==off? "" :
1728 AMG_id2name(method+assignshift),
1729 method+assignshift==off? "" : "')",
1730 flags & AMGf_unary? "" :
1731 lr==1 ? " for right argument": " for left argument",
1732 flags & AMGf_unary? " for argument" : "",
25716404 1733 stash ? HvNAME(stash) : "null",
497b47a8 1734 fl? ",\n\tassignment variant used": "") );
ee239bfe 1735 }
497b47a8 1736#endif
748a9306
LW
1737 /* Since we use shallow copy during assignment, we need
1738 * to dublicate the contents, probably calling user-supplied
1739 * version of copy operator
1740 */
ee239bfe
IZ
1741 /* We need to copy in following cases:
1742 * a) Assignment form was called.
1743 * assignshift==1, assign==T, method + 1 == off
1744 * b) Increment or decrement, called directly.
1745 * assignshift==0, assign==0, method + 0 == off
1746 * c) Increment or decrement, translated to assignment add/subtr.
b267980d 1747 * assignshift==0, assign==T,
ee239bfe
IZ
1748 * force_cpy == T
1749 * d) Increment or decrement, translated to nomethod.
b267980d 1750 * assignshift==0, assign==0,
ee239bfe
IZ
1751 * force_cpy == T
1752 * e) Assignment form translated to nomethod.
1753 * assignshift==1, assign==T, method + 1 != off
1754 * force_cpy == T
1755 */
1756 /* off is method, method+assignshift, or a result of opcode substitution.
1757 * In the latter case assignshift==0, so only notfound case is important.
1758 */
1759 if (( (method + assignshift == off)
1760 && (assign || (method == inc_amg) || (method == dec_amg)))
1761 || force_cpy)
1762 RvDEEPCP(left);
a0d0e21e
LW
1763 {
1764 dSP;
1765 BINOP myop;
1766 SV* res;
54310121 1767 bool oldcatch = CATCH_GET;
a0d0e21e 1768
54310121 1769 CATCH_SET(TRUE);
a0d0e21e
LW
1770 Zero(&myop, 1, BINOP);
1771 myop.op_last = (OP *) &myop;
1772 myop.op_next = Nullop;
54310121 1773 myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
a0d0e21e 1774
e788e7d3 1775 PUSHSTACKi(PERLSI_OVERLOAD);
a0d0e21e 1776 ENTER;
462e5cf6 1777 SAVEOP();
533c011a 1778 PL_op = (OP *) &myop;
3280af22 1779 if (PERLDB_SUB && PL_curstash != PL_debstash)
533c011a 1780 PL_op->op_private |= OPpENTERSUB_DB;
a0d0e21e 1781 PUTBACK;
cea2e8a9 1782 pp_pushmark();
a0d0e21e 1783
924508f0 1784 EXTEND(SP, notfound + 5);
a0d0e21e
LW
1785 PUSHs(lr>0? right: left);
1786 PUSHs(lr>0? left: right);
3280af22 1787 PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no ));
a0d0e21e 1788 if (notfound) {
89ffc314 1789 PUSHs( sv_2mortal(newSVpv(AMG_id2name(method + assignshift),0)));
a0d0e21e
LW
1790 }
1791 PUSHs((SV*)cv);
1792 PUTBACK;
1793
155aba94 1794 if ((PL_op = Perl_pp_entersub(aTHX)))
cea2e8a9 1795 CALLRUNOPS(aTHX);
a0d0e21e
LW
1796 LEAVE;
1797 SPAGAIN;
1798
1799 res=POPs;
ebafeae7 1800 PUTBACK;
d3acc0f7 1801 POPSTACK;
54310121 1802 CATCH_SET(oldcatch);
a0d0e21e 1803
a0d0e21e 1804 if (postpr) {
9c5ffd7c 1805 int ans=0;
a0d0e21e
LW
1806 switch (method) {
1807 case le_amg:
1808 case sle_amg:
1809 ans=SvIV(res)<=0; break;
1810 case lt_amg:
1811 case slt_amg:
1812 ans=SvIV(res)<0; break;
1813 case ge_amg:
1814 case sge_amg:
1815 ans=SvIV(res)>=0; break;
1816 case gt_amg:
1817 case sgt_amg:
1818 ans=SvIV(res)>0; break;
1819 case eq_amg:
1820 case seq_amg:
1821 ans=SvIV(res)==0; break;
1822 case ne_amg:
1823 case sne_amg:
1824 ans=SvIV(res)!=0; break;
1825 case inc_amg:
1826 case dec_amg:
bbce6d69 1827 SvSetSV(left,res); return left;
dc437b57 1828 case not_amg:
fe7ac86a 1829 ans=!SvTRUE(res); break;
a0d0e21e 1830 }
54310121 1831 return boolSV(ans);
748a9306
LW
1832 } else if (method==copy_amg) {
1833 if (!SvROK(res)) {
cea2e8a9 1834 Perl_croak(aTHX_ "Copy method did not return a reference");
748a9306
LW
1835 }
1836 return SvREFCNT_inc(SvRV(res));
a0d0e21e
LW
1837 } else {
1838 return res;
1839 }
1840 }
1841}
c9d5ac95
GS
1842
1843/*
7fc63493 1844=for apidoc is_gv_magical_sv
c9d5ac95 1845
7a5fd60d
NC
1846Returns C<TRUE> if given the name of a magical GV. Calls is_gv_magical.
1847
1848=cut
1849*/
1850
1851bool
1852Perl_is_gv_magical_sv(pTHX_ SV *name, U32 flags)
1853{
1854 STRLEN len;
e1ec3a88 1855 const char *temp = SvPV(name, len);
7a5fd60d
NC
1856 return is_gv_magical(temp, len, flags);
1857}
1858
1859/*
1860=for apidoc is_gv_magical
1861
c9d5ac95
GS
1862Returns C<TRUE> if given the name of a magical GV.
1863
1864Currently only useful internally when determining if a GV should be
1865created even in rvalue contexts.
1866
1867C<flags> is not used at present but available for future extension to
1868allow selecting particular classes of magical variable.
1869
b9b0e72c
NC
1870Currently assumes that C<name> is NUL terminated (as well as len being valid).
1871This assumption is met by all callers within the perl core, which all pass
1872pointers returned by SvPV.
1873
c9d5ac95
GS
1874=cut
1875*/
1876bool
7fc63493 1877Perl_is_gv_magical(pTHX_ const char *name, STRLEN len, U32 flags)
c9d5ac95 1878{
dd374669 1879 (void)flags;
b9b0e72c 1880 if (len > 1) {
9431620d 1881 const char *name1 = name + 1;
b9b0e72c
NC
1882 switch (*name) {
1883 case 'I':
9431620d 1884 if (len == 3 && name1[1] == 'S' && name[2] == 'A')
b9b0e72c
NC
1885 goto yes;
1886 break;
1887 case 'O':
9431620d 1888 if (len == 8 && strEQ(name1, "VERLOAD"))
b9b0e72c
NC
1889 goto yes;
1890 break;
1891 case 'S':
9431620d 1892 if (len == 3 && name[1] == 'I' && name[2] == 'G')
b9b0e72c
NC
1893 goto yes;
1894 break;
1895 /* Using ${^...} variables is likely to be sufficiently rare that
1896 it seems sensible to avoid the space hit of also checking the
1897 length. */
1898 case '\017': /* ${^OPEN} */
9431620d 1899 if (strEQ(name1, "PEN"))
b9b0e72c
NC
1900 goto yes;
1901 break;
1902 case '\024': /* ${^TAINT} */
9431620d 1903 if (strEQ(name1, "AINT"))
b9b0e72c
NC
1904 goto yes;
1905 break;
1906 case '\025': /* ${^UNICODE} */
9431620d 1907 if (strEQ(name1, "NICODE"))
b9b0e72c 1908 goto yes;
7cebcbc0
NC
1909 if (strEQ(name1, "TF8LOCALE"))
1910 goto yes;
b9b0e72c
NC
1911 break;
1912 case '\027': /* ${^WARNING_BITS} */
9431620d 1913 if (strEQ(name1, "ARNING_BITS"))
b9b0e72c
NC
1914 goto yes;
1915 break;
1916 case '1':
1917 case '2':
1918 case '3':
1919 case '4':
1920 case '5':
1921 case '6':
1922 case '7':
1923 case '8':
1924 case '9':
c9d5ac95 1925 {
7fc63493 1926 const char *end = name + len;
c9d5ac95
GS
1927 while (--end > name) {
1928 if (!isDIGIT(*end))
1929 return FALSE;
1930 }
b9b0e72c
NC
1931 goto yes;
1932 }
1933 }
1934 } else {
1935 /* Because we're already assuming that name is NUL terminated
1936 below, we can treat an empty name as "\0" */
1937 switch (*name) {
1938 case '&':
1939 case '`':
1940 case '\'':
1941 case ':':
1942 case '?':
1943 case '!':
1944 case '-':
1945 case '#':
1946 case '[':
1947 case '^':
1948 case '~':
1949 case '=':
1950 case '%':
1951 case '.':
1952 case '(':
1953 case ')':
1954 case '<':
1955 case '>':
1956 case ',':
1957 case '\\':
1958 case '/':
1959 case '|':
1960 case '+':
1961 case ';':
1962 case ']':
1963 case '\001': /* $^A */
1964 case '\003': /* $^C */
1965 case '\004': /* $^D */
1966 case '\005': /* $^E */
1967 case '\006': /* $^F */
1968 case '\010': /* $^H */
1969 case '\011': /* $^I, NOT \t in EBCDIC */
1970 case '\014': /* $^L */
1971 case '\016': /* $^N */
1972 case '\017': /* $^O */
1973 case '\020': /* $^P */
1974 case '\023': /* $^S */
1975 case '\024': /* $^T */
1976 case '\026': /* $^V */
1977 case '\027': /* $^W */
1978 case '1':
1979 case '2':
1980 case '3':
1981 case '4':
1982 case '5':
1983 case '6':
1984 case '7':
1985 case '8':
1986 case '9':
1987 yes:
1988 return TRUE;
1989 default:
1990 break;
c9d5ac95 1991 }
c9d5ac95
GS
1992 }
1993 return FALSE;
1994}