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