This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
make gv_fullname() etc include a literal '^' for *^FOO style names
[perl5.git] / gv.c
CommitLineData
a0d0e21e 1/* gv.c
79072805 2 *
4bb101f2 3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
b5f8cc5c 4 * 2000, 2001, 2002, 2003, 2004, 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 695
59f00321
RGS
696 /* $_ should always be in main:: even when our'ed */
697 if (*name == '_' && !name[1])
698 stash = PL_defstash;
699
463ee0b2
LW
700 /* No stash in name, so see how we can default */
701
702 if (!stash) {
7e2040f0 703 if (isIDFIRST_lazy(name)) {
9607fc9c
PP
704 bool global = FALSE;
705
463ee0b2 706 if (isUPPER(*name)) {
9d116dd7
JH
707 if (*name == 'S' && (
708 strEQ(name, "SIG") ||
709 strEQ(name, "STDIN") ||
710 strEQ(name, "STDOUT") ||
711 strEQ(name, "STDERR")))
712 global = TRUE;
713 else if (*name == 'I' && strEQ(name, "INC"))
714 global = TRUE;
715 else if (*name == 'E' && strEQ(name, "ENV"))
716 global = TRUE;
463ee0b2
LW
717 else if (*name == 'A' && (
718 strEQ(name, "ARGV") ||
9d116dd7 719 strEQ(name, "ARGVOUT")))
463ee0b2
LW
720 global = TRUE;
721 }
c99da370 722 else if (*name == '_' && !name[1])
463ee0b2 723 global = TRUE;
9607fc9c 724
463ee0b2 725 if (global)
3280af22 726 stash = PL_defstash;
923e4eb5 727 else if (IN_PERL_COMPILETIME) {
3280af22
NIS
728 stash = PL_curstash;
729 if (add && (PL_hints & HINT_STRICT_VARS) &&
748a9306
LW
730 sv_type != SVt_PVCV &&
731 sv_type != SVt_PVGV &&
4633a7c4 732 sv_type != SVt_PVFM &&
c07a80fd 733 sv_type != SVt_PVIO &&
377b8fbc 734 !(len == 1 && sv_type == SVt_PV && strchr("ab",*name)) )
748a9306 735 {
4633a7c4
LW
736 gvp = (GV**)hv_fetch(stash,name,len,0);
737 if (!gvp ||
3280af22 738 *gvp == (GV*)&PL_sv_undef ||
a5f75d66
AD
739 SvTYPE(*gvp) != SVt_PVGV)
740 {
4633a7c4 741 stash = 0;
a5f75d66 742 }
155aba94
GS
743 else if ((sv_type == SVt_PV && !GvIMPORTED_SV(*gvp)) ||
744 (sv_type == SVt_PVAV && !GvIMPORTED_AV(*gvp)) ||
745 (sv_type == SVt_PVHV && !GvIMPORTED_HV(*gvp)) )
4633a7c4 746 {
cea2e8a9 747 Perl_warn(aTHX_ "Variable \"%c%s\" is not imported",
4633a7c4
LW
748 sv_type == SVt_PVAV ? '@' :
749 sv_type == SVt_PVHV ? '%' : '$',
750 name);
8ebc5c01 751 if (GvCVu(*gvp))
cc507455 752 Perl_warn(aTHX_ "\t(Did you mean &%s instead?)\n", name);
a0d0e21e 753 stash = 0;
4633a7c4 754 }
a0d0e21e 755 }
85e6fe83 756 }
463ee0b2 757 else
1d7c1841 758 stash = CopSTASH(PL_curcop);
463ee0b2
LW
759 }
760 else
3280af22 761 stash = PL_defstash;
463ee0b2
LW
762 }
763
764 /* By this point we should have a stash and a name */
765
a0d0e21e 766 if (!stash) {
5a844595 767 if (add) {
608b3986 768 register SV *err = Perl_mess(aTHX_
5a844595
GS
769 "Global symbol \"%s%s\" requires explicit package name",
770 (sv_type == SVt_PV ? "$"
771 : sv_type == SVt_PVAV ? "@"
772 : sv_type == SVt_PVHV ? "%"
608b3986
AE
773 : ""), name);
774 if (USE_UTF8_IN_NAMES)
775 SvUTF8_on(err);
776 qerror(err);
d7aacf4e 777 stash = GvHV(gv_fetchpv("<none>::", GV_ADDMULTI, SVt_PVHV));
a0d0e21e 778 }
d7aacf4e
RGS
779 else
780 return Nullgv;
a0d0e21e
LW
781 }
782
783 if (!SvREFCNT(stash)) /* symbol table under destruction */
784 return Nullgv;
785
79072805 786 gvp = (GV**)hv_fetch(stash,name,len,add);
3280af22 787 if (!gvp || *gvp == (GV*)&PL_sv_undef)
79072805
LW
788 return Nullgv;
789 gv = *gvp;
790 if (SvTYPE(gv) == SVt_PVGV) {
a0d0e21e 791 if (add) {
a5f75d66 792 GvMULTI_on(gv);
a0d0e21e 793 gv_init_sv(gv, sv_type);
d2c93421
RH
794 if (*name=='!' && sv_type == SVt_PVHV && len==1)
795 require_errno(gv);
a0d0e21e 796 }
79072805 797 return gv;
55d729e4
GS
798 } else if (add & GV_NOINIT) {
799 return gv;
79072805 800 }
93a17b20
LW
801
802 /* Adding a new symbol */
803
0453d815 804 if (add & GV_ADDWARN && ckWARN_d(WARN_INTERNAL))
9014280d 805 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "Had to create %s unexpectedly", nambeg);
55d729e4 806 gv_init(gv, stash, name, len, add & GV_ADDMULTI);
a0d0e21e 807 gv_init_sv(gv, sv_type);
93a17b20 808
7272584d
PM
809 if (isALPHA(name[0]) && ! (isLEXWARN_on ? ckWARN(WARN_ONCE)
810 : (PL_dowarn & G_WARN_ON ) ) )
0453d815
PM
811 GvMULTI_on(gv) ;
812
93a17b20
LW
813 /* set up magic where warranted */
814 switch (*name) {
a0d0e21e
LW
815 case 'A':
816 if (strEQ(name, "ARGV")) {
817 IoFLAGS(GvIOn(gv)) |= IOf_ARGV|IOf_START;
818 }
819 break;
a0d0e21e
LW
820 case 'E':
821 if (strnEQ(name, "EXPORT", 6))
a5f75d66 822 GvMULTI_on(gv);
a0d0e21e 823 break;
463ee0b2
LW
824 case 'I':
825 if (strEQ(name, "ISA")) {
826 AV* av = GvAVn(gv);
a5f75d66 827 GvMULTI_on(gv);
14befaf4 828 sv_magic((SV*)av, (SV*)gv, PERL_MAGIC_isa, Nullch, 0);
93965878 829 /* NOTE: No support for tied ISA */
55d729e4
GS
830 if ((add & GV_ADDMULTI) && strEQ(nambeg,"AnyDBM_File::ISA")
831 && AvFILLp(av) == -1)
85e6fe83 832 {
a0d0e21e 833 char *pname;
79cb57f6 834 av_push(av, newSVpvn(pname = "NDBM_File",9));
dc437b57 835 gv_stashpvn(pname, 9, TRUE);
79cb57f6 836 av_push(av, newSVpvn(pname = "DB_File",7));
dc437b57 837 gv_stashpvn(pname, 7, TRUE);
79cb57f6 838 av_push(av, newSVpvn(pname = "GDBM_File",9));
dc437b57 839 gv_stashpvn(pname, 9, TRUE);
79cb57f6 840 av_push(av, newSVpvn(pname = "SDBM_File",9));
dc437b57 841 gv_stashpvn(pname, 9, TRUE);
79cb57f6 842 av_push(av, newSVpvn(pname = "ODBM_File",9));
dc437b57 843 gv_stashpvn(pname, 9, TRUE);
85e6fe83 844 }
463ee0b2
LW
845 }
846 break;
a0d0e21e
LW
847 case 'O':
848 if (strEQ(name, "OVERLOAD")) {
849 HV* hv = GvHVn(gv);
a5f75d66 850 GvMULTI_on(gv);
14befaf4 851 hv_magic(hv, Nullgv, PERL_MAGIC_overload);
a0d0e21e
LW
852 }
853 break;
93a17b20
LW
854 case 'S':
855 if (strEQ(name, "SIG")) {
856 HV *hv;
dc437b57 857 I32 i;
1d7c1841 858 if (!PL_psig_ptr) {
0a8e0eff
NIS
859 Newz(73, PL_psig_ptr, SIG_SIZE, SV*);
860 Newz(73, PL_psig_name, SIG_SIZE, SV*);
861 Newz(73, PL_psig_pend, SIG_SIZE, int);
1d7c1841
GS
862 }
863 GvMULTI_on(gv);
864 hv = GvHVn(gv);
14befaf4 865 hv_magic(hv, Nullgv, PERL_MAGIC_sig);
76d3c696 866 for (i = 1; i < SIG_SIZE; i++) {
dc437b57 867 SV ** init;
1d7c1841
GS
868 init = hv_fetch(hv, PL_sig_name[i], strlen(PL_sig_name[i]), 1);
869 if (init)
870 sv_setsv(*init, &PL_sv_undef);
22c35a8c
GS
871 PL_psig_ptr[i] = 0;
872 PL_psig_name[i] = 0;
0a8e0eff 873 PL_psig_pend[i] = 0;
dc437b57 874 }
93a17b20
LW
875 }
876 break;
09bef843
SB
877 case 'V':
878 if (strEQ(name, "VERSION"))
879 GvMULTI_on(gv);
880 break;
93a17b20
LW
881
882 case '&':
93a17b20 883 case '`':
93a17b20 884 case '\'':
b4a9608f
JP
885 if (
886 len > 1 ||
887 sv_type == SVt_PVAV ||
888 sv_type == SVt_PVHV ||
889 sv_type == SVt_PVCV ||
b4a9608f
JP
890 sv_type == SVt_PVFM ||
891 sv_type == SVt_PVIO
892 ) { break; }
3280af22 893 PL_sawampersand = TRUE;
a0d0e21e 894 goto ro_magicalize;
93a17b20
LW
895
896 case ':':
463ee0b2
LW
897 if (len > 1)
898 break;
3280af22 899 sv_setpv(GvSV(gv),PL_chopset);
93a17b20
LW
900 goto magicalize;
901
ff0cee69
PP
902 case '?':
903 if (len > 1)
904 break;
905#ifdef COMPLEX_STATUS
07f14f54 906 (void)SvUPGRADE(GvSV(gv), SVt_PVLV);
ff0cee69
PP
907#endif
908 goto magicalize;
909
067391ea 910 case '!':
4318d5a0 911 if (len > 1)
067391ea 912 break;
d2c93421
RH
913
914 /* If %! has been used, automatically load Errno.pm.
915 The require will itself set errno, so in order to
916 preserve its value we have to set up the magic
917 now (rather than going to magicalize)
918 */
919
14befaf4 920 sv_magic(GvSV(gv), (SV*)gv, PERL_MAGIC_sv, name, len);
d2c93421
RH
921
922 if (sv_type == SVt_PVHV)
923 require_errno(gv);
924
925 break;
6cef1e77
IZ
926 case '-':
927 if (len > 1)
928 break;
929 else {
930 AV* av = GvAVn(gv);
14befaf4 931 sv_magic((SV*)av, Nullsv, PERL_MAGIC_regdata, Nullch, 0);
03a27ae7 932 SvREADONLY_on(av);
6cef1e77
IZ
933 }
934 goto magicalize;
a0d0e21e 935 case '*':
f02c194e
RGS
936 if (len == 1 && sv_type == SVt_PV && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
937 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
9b332a20 938 "$* is no longer supported");
f02c194e
RGS
939 break;
940 case '#':
941 if (len == 1 && sv_type == SVt_PV && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
942 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
943 "Use of $# is deprecated");
a0d0e21e
LW
944 /* FALL THROUGH */
945 case '[':
93a17b20
LW
946 case '^':
947 case '~':
948 case '=':
93a17b20
LW
949 case '%':
950 case '.':
93a17b20
LW
951 case '(':
952 case ')':
953 case '<':
954 case '>':
955 case ',':
956 case '\\':
957 case '/':
16070b82
GS
958 case '\001': /* $^A */
959 case '\003': /* $^C */
960 case '\004': /* $^D */
16070b82
GS
961 case '\006': /* $^F */
962 case '\010': /* $^H */
963 case '\011': /* $^I, NOT \t in EBCDIC */
a01268b5 964 case '\016': /* $^N */
16070b82 965 case '\020': /* $^P */
463ee0b2
LW
966 if (len > 1)
967 break;
968 goto magicalize;
d8ce0c9a
BH
969 case '|':
970 if (len > 1)
971 break;
972 sv_setiv(GvSV(gv), (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0);
973 goto magicalize;
0a378802
JH
974 case '\005': /* $^E && $^ENCODING */
975 if (len > 1 && strNE(name, "\005NCODING"))
976 break;
977 goto magicalize;
978
ac27b0f5
NIS
979 case '\017': /* $^O & $^OPEN */
980 if (len > 1 && strNE(name, "\017PEN"))
981 break;
982 goto magicalize;
16070b82 983 case '\023': /* $^S */
6cef1e77
IZ
984 if (len > 1)
985 break;
986 goto ro_magicalize;
eb27b65e 987 case '\024': /* $^T, ${^TAINT} */
7c36658b
MS
988 if (len == 1)
989 goto magicalize;
990 else if (strEQ(name, "\024AINT"))
991 goto ro_magicalize;
992 else
993 break;
fde18df1 994 case '\025':
a05d7ebb 995 if (len > 1 && strNE(name, "\025NICODE"))
fde18df1
JH
996 break;
997 goto ro_magicalize;
998
6a818117 999 case '\027': /* $^W & $^WARNING_BITS */
fde18df1
JH
1000 if (len > 1
1001 && strNE(name, "\027ARNING_BITS")
1002 )
4438c4b7
JH
1003 break;
1004 goto magicalize;
463ee0b2 1005
a0d0e21e 1006 case '+':
6cef1e77
IZ
1007 if (len > 1)
1008 break;
1009 else {
1010 AV* av = GvAVn(gv);
14befaf4 1011 sv_magic((SV*)av, (SV*)av, PERL_MAGIC_regdata, Nullch, 0);
03a27ae7 1012 SvREADONLY_on(av);
6cef1e77
IZ
1013 }
1014 /* FALL THROUGH */
463ee0b2
LW
1015 case '1':
1016 case '2':
1017 case '3':
1018 case '4':
1019 case '5':
1020 case '6':
1021 case '7':
1022 case '8':
1023 case '9':
e521374c
JP
1024 /* ensures variable is only digits */
1025 /* ${"1foo"} fails this test (and is thus writeable) */
1026 /* added by japhy, but borrowed from is_gv_magical */
1027
1028 if (len > 1) {
1029 const char *end = name + len;
1030 while (--end > name) {
1031 if (!isDIGIT(*end)) return gv;
1032 }
1033 }
1034
a0d0e21e
LW
1035 ro_magicalize:
1036 SvREADONLY_on(GvSV(gv));
93a17b20 1037 magicalize:
14befaf4 1038 sv_magic(GvSV(gv), (SV*)gv, PERL_MAGIC_sv, name, len);
93a17b20
LW
1039 break;
1040
16070b82 1041 case '\014': /* $^L */
463ee0b2
LW
1042 if (len > 1)
1043 break;
93a17b20 1044 sv_setpv(GvSV(gv),"\f");
3280af22 1045 PL_formfeed = GvSV(gv);
93a17b20
LW
1046 break;
1047 case ';':
463ee0b2
LW
1048 if (len > 1)
1049 break;
93a17b20
LW
1050 sv_setpv(GvSV(gv),"\034");
1051 break;
463ee0b2
LW
1052 case ']':
1053 if (len == 1) {
f86702cc 1054 SV *sv = GvSV(gv);
5089c844 1055 (void)SvUPGRADE(sv, SVt_PVNV);
6a6ba966
SB
1056 Perl_sv_setpvf(aTHX_ sv,
1057#if defined(PERL_SUBVERSION) && (PERL_SUBVERSION > 0)
1058 "%8.6"
1059#else
1060 "%5.3"
1061#endif
1062 NVff,
1063 SvNVX(PL_patchlevel));
5089c844
GS
1064 SvNVX(sv) = SvNVX(PL_patchlevel);
1065 SvNOK_on(sv);
5089c844 1066 SvREADONLY_on(sv);
93a17b20
LW
1067 }
1068 break;
16070b82
GS
1069 case '\026': /* $^V */
1070 if (len == 1) {
1071 SV *sv = GvSV(gv);
1072 GvSV(gv) = SvREFCNT_inc(PL_patchlevel);
1073 SvREFCNT_dec(sv);
1074 }
1075 break;
79072805 1076 }
93a17b20 1077 return gv;
79072805
LW
1078}
1079
1080void
43693395
GS
1081Perl_gv_fullname4(pTHX_ SV *sv, GV *gv, const char *prefix, bool keepmain)
1082{
e27ad1f2 1083 char *name;
43693395
GS
1084 HV *hv = GvSTASH(gv);
1085 if (!hv) {
1086 (void)SvOK_off(sv);
1087 return;
1088 }
1089 sv_setpv(sv, prefix ? prefix : "");
e27ad1f2
AV
1090
1091 if (!HvNAME(hv))
1092 name = "__ANON__";
1093 else
1094 name = HvNAME(hv);
1095 if (keepmain || strNE(name, "main")) {
1096 sv_catpv(sv,name);
43693395
GS
1097 sv_catpvn(sv,"::", 2);
1098 }
4ad16c23
DM
1099 if (((unsigned int)*GvNAME(gv)) <= 26) { /* handle $^FOO */
1100 Perl_sv_catpvf(aTHX_ sv,"^%c", *GvNAME(gv) + 'A' - 1);
1101 sv_catpvn(sv,GvNAME(gv)+1,GvNAMELEN(gv)-1);
1102 }
1103 else
1104 sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv));
1105
43693395
GS
1106}
1107
1108void
864dbfa3 1109Perl_gv_fullname3(pTHX_ SV *sv, GV *gv, const char *prefix)
79072805 1110{
84e79d79 1111 gv_fullname4(sv, gv, prefix, TRUE);
79072805
LW
1112}
1113
1114void
43693395
GS
1115Perl_gv_efullname4(pTHX_ SV *sv, GV *gv, const char *prefix, bool keepmain)
1116{
1117 GV *egv = GvEGV(gv);
1118 if (!egv)
1119 egv = gv;
1120 gv_fullname4(sv, egv, prefix, keepmain);
1121}
1122
1123void
864dbfa3 1124Perl_gv_efullname3(pTHX_ SV *sv, GV *gv, const char *prefix)
79072805 1125{
84e79d79 1126 gv_efullname4(sv, gv, prefix, TRUE);
f6aff53a
PP
1127}
1128
1129/* XXX compatibility with versions <= 5.003. */
1130void
864dbfa3 1131Perl_gv_fullname(pTHX_ SV *sv, GV *gv)
f6aff53a
PP
1132{
1133 gv_fullname3(sv, gv, sv == (SV*)gv ? "*" : "");
1134}
1135
1136/* XXX compatibility with versions <= 5.003. */
1137void
864dbfa3 1138Perl_gv_efullname(pTHX_ SV *sv, GV *gv)
f6aff53a
PP
1139{
1140 gv_efullname3(sv, gv, sv == (SV*)gv ? "*" : "");
79072805
LW
1141}
1142
1143IO *
864dbfa3 1144Perl_newIO(pTHX)
79072805
LW
1145{
1146 IO *io;
8990e307
LW
1147 GV *iogv;
1148
1149 io = (IO*)NEWSV(0,0);
a0d0e21e 1150 sv_upgrade((SV *)io,SVt_PVIO);
8990e307
LW
1151 SvREFCNT(io) = 1;
1152 SvOBJECT_on(io);
081fc587
AB
1153 /* Clear the stashcache because a new IO could overrule a
1154 package name */
1155 hv_clear(PL_stashcache);
c9de509e 1156 iogv = gv_fetchpv("FileHandle::", FALSE, SVt_PVHV);
5f2d631d
GS
1157 /* unless exists($main::{FileHandle}) and defined(%main::FileHandle::) */
1158 if (!(iogv && GvHV(iogv) && HvARRAY(GvHV(iogv))))
c9de509e 1159 iogv = gv_fetchpv("IO::Handle::", TRUE, SVt_PVHV);
8990e307 1160 SvSTASH(io) = (HV*)SvREFCNT_inc(GvHV(iogv));
79072805
LW
1161 return io;
1162}
1163
1164void
864dbfa3 1165Perl_gv_check(pTHX_ HV *stash)
79072805
LW
1166{
1167 register HE *entry;
1168 register I32 i;
1169 register GV *gv;
463ee0b2
LW
1170 HV *hv;
1171
8990e307
LW
1172 if (!HvARRAY(stash))
1173 return;
a0d0e21e 1174 for (i = 0; i <= (I32) HvMAX(stash); i++) {
dc437b57
PP
1175 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
1176 if (HeKEY(entry)[HeKLEN(entry)-1] == ':' &&
b862623f 1177 (gv = (GV*)HeVAL(entry)) && isGV(gv) && (hv = GvHV(gv)))
a0d0e21e 1178 {
19b6c847 1179 if (hv != PL_defstash && hv != stash)
a0d0e21e
LW
1180 gv_check(hv); /* nested package */
1181 }
dc437b57 1182 else if (isALPHA(*HeKEY(entry))) {
1d7c1841 1183 char *file;
dc437b57 1184 gv = (GV*)HeVAL(entry);
55d729e4 1185 if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv))
463ee0b2 1186 continue;
1d7c1841
GS
1187 file = GvFILE(gv);
1188 /* performance hack: if filename is absolute and it's a standard
1189 * module, don't bother warning */
1190 if (file
1191 && PERL_FILE_IS_ABSOLUTE(file)
6eb630b7
CN
1192#ifdef MACOS_TRADITIONAL
1193 && (instr(file, ":lib:")
1194#else
1195 && (instr(file, "/lib/")
1196#endif
1197 || instr(file, ".pm")))
1d7c1841 1198 {
8990e307 1199 continue;
1d7c1841
GS
1200 }
1201 CopLINE_set(PL_curcop, GvLINE(gv));
1202#ifdef USE_ITHREADS
1203 CopFILE(PL_curcop) = file; /* set for warning */
1204#else
1205 CopFILEGV(PL_curcop) = gv_fetchfile(file);
1206#endif
9014280d 1207 Perl_warner(aTHX_ packWARN(WARN_ONCE),
599cee73 1208 "Name \"%s::%s\" used only once: possible typo",
a0d0e21e 1209 HvNAME(stash), GvNAME(gv));
463ee0b2 1210 }
79072805
LW
1211 }
1212 }
1213}
1214
1215GV *
864dbfa3 1216Perl_newGVgen(pTHX_ char *pack)
79072805 1217{
cea2e8a9 1218 return gv_fetchpv(Perl_form(aTHX_ "%s::_GEN_%ld", pack, (long)PL_gensym++),
46fc3d4c 1219 TRUE, SVt_PVGV);
79072805
LW
1220}
1221
1222/* hopefully this is only called on local symbol table entries */
1223
1224GP*
864dbfa3 1225Perl_gp_ref(pTHX_ GP *gp)
79072805 1226{
1d7c1841
GS
1227 if (!gp)
1228 return (GP*)NULL;
79072805 1229 gp->gp_refcnt++;
44a8e56a
PP
1230 if (gp->gp_cv) {
1231 if (gp->gp_cvgen) {
1232 /* multi-named GPs cannot be used for method cache */
1233 SvREFCNT_dec(gp->gp_cv);
1234 gp->gp_cv = Nullcv;
1235 gp->gp_cvgen = 0;
1236 }
1237 else {
1238 /* Adding a new name to a subroutine invalidates method cache */
3280af22 1239 PL_sub_generation++;
44a8e56a
PP
1240 }
1241 }
79072805 1242 return gp;
79072805
LW
1243}
1244
1245void
864dbfa3 1246Perl_gp_free(pTHX_ GV *gv)
79072805 1247{
79072805
LW
1248 GP* gp;
1249
1250 if (!gv || !(gp = GvGP(gv)))
1251 return;
f248d071
GS
1252 if (gp->gp_refcnt == 0) {
1253 if (ckWARN_d(WARN_INTERNAL))
9014280d 1254 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
f248d071 1255 "Attempt to free unreferenced glob pointers");
79072805
LW
1256 return;
1257 }
44a8e56a
PP
1258 if (gp->gp_cv) {
1259 /* Deleting the name of a subroutine invalidates method cache */
3280af22 1260 PL_sub_generation++;
44a8e56a 1261 }
748a9306
LW
1262 if (--gp->gp_refcnt > 0) {
1263 if (gp->gp_egv == gv)
1264 gp->gp_egv = 0;
79072805 1265 return;
748a9306 1266 }
79072805 1267
13207a71
JH
1268 if (gp->gp_sv) SvREFCNT_dec(gp->gp_sv);
1269 if (gp->gp_sv) SvREFCNT_dec(gp->gp_av);
1270 if (gp->gp_hv) {
1271 if (PL_stashcache && HvNAME(gp->gp_hv))
1272 hv_delete(PL_stashcache,
1273 HvNAME(gp->gp_hv), strlen(HvNAME(gp->gp_hv)),
1274 G_DISCARD);
1275 SvREFCNT_dec(gp->gp_hv);
1276 }
1277 if (gp->gp_io) SvREFCNT_dec(gp->gp_io);
1278 if (gp->gp_cv) SvREFCNT_dec(gp->gp_cv);
1279 if (gp->gp_form) SvREFCNT_dec(gp->gp_form);
748a9306 1280
79072805
LW
1281 Safefree(gp);
1282 GvGP(gv) = 0;
1283}
1284
d460ef45
NIS
1285int
1286Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg)
1287{
1288 AMT *amtp = (AMT*)mg->mg_ptr;
1289 if (amtp && AMT_AMAGIC(amtp)) {
1290 int i;
1291 for (i = 1; i < NofAMmeth; i++) {
1292 CV *cv = amtp->table[i];
1293 if (cv != Nullcv) {
1294 SvREFCNT_dec((SV *) cv);
1295 amtp->table[i] = Nullcv;
1296 }
1297 }
1298 }
1299 return 0;
1300}
1301
a0d0e21e
LW
1302/* Updates and caches the CV's */
1303
1304bool
864dbfa3 1305Perl_Gv_AMupdate(pTHX_ HV *stash)
a0d0e21e 1306{
a0d0e21e
LW
1307 GV* gv;
1308 CV* cv;
14befaf4 1309 MAGIC* mg=mg_find((SV*)stash, PERL_MAGIC_overload_table);
8ac85365 1310 AMT *amtp = (mg) ? (AMT*)mg->mg_ptr: (AMT *) NULL;
a6006777 1311 AMT amt;
a0d0e21e 1312
3280af22
NIS
1313 if (mg && amtp->was_ok_am == PL_amagic_generation
1314 && amtp->was_ok_sub == PL_sub_generation)
eb160463 1315 return (bool)AMT_OVERLOADED(amtp);
14befaf4 1316 sv_unmagic((SV*)stash, PERL_MAGIC_overload_table);
a0d0e21e 1317
cea2e8a9 1318 DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME(stash)) );
a0d0e21e 1319
d460ef45 1320 Zero(&amt,1,AMT);
3280af22
NIS
1321 amt.was_ok_am = PL_amagic_generation;
1322 amt.was_ok_sub = PL_sub_generation;
a6006777
PP
1323 amt.fallback = AMGfallNO;
1324 amt.flags = 0;
1325
a6006777 1326 {
32251b26
IZ
1327 int filled = 0, have_ovl = 0;
1328 int i, lim = 1;
a6006777 1329 SV* sv = NULL;
a6006777 1330
22c35a8c 1331 /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
a6006777 1332
89ffc314
IZ
1333 /* Try to find via inheritance. */
1334 gv = gv_fetchmeth(stash, PL_AMG_names[0], 2, -1);
1335 if (gv)
1336 sv = GvSV(gv);
1337
1338 if (!gv)
32251b26 1339 lim = DESTROY_amg; /* Skip overloading entries. */
89ffc314
IZ
1340 else if (SvTRUE(sv))
1341 amt.fallback=AMGfallYES;
1342 else if (SvOK(sv))
1343 amt.fallback=AMGfallNEVER;
a6006777 1344
32251b26
IZ
1345 for (i = 1; i < lim; i++)
1346 amt.table[i] = Nullcv;
1347 for (; i < NofAMmeth; i++) {
c8ce92fc 1348 char *cooky = (char*)PL_AMG_names[i];
32251b26
IZ
1349 /* Human-readable form, for debugging: */
1350 char *cp = (i >= DESTROY_amg ? cooky : AMG_id2name(i));
89ffc314
IZ
1351 STRLEN l = strlen(cooky);
1352
cea2e8a9 1353 DEBUG_o( Perl_deb(aTHX_ "Checking overloading of `%s' in package `%.256s'\n",
44a8e56a 1354 cp, HvNAME(stash)) );
611c1e95
IZ
1355 /* don't fill the cache while looking up!
1356 Creation of inheritance stubs in intermediate packages may
1357 conflict with the logic of runtime method substitution.
1358 Indeed, for inheritance A -> B -> C, if C overloads "+0",
1359 then we could have created stubs for "(+0" in A and C too.
1360 But if B overloads "bool", we may want to use it for
1361 numifying instead of C's "+0". */
1362 if (i >= DESTROY_amg)
1363 gv = Perl_gv_fetchmeth_autoload(aTHX_ stash, cooky, l, 0);
1364 else /* Autoload taken care of below */
1365 gv = Perl_gv_fetchmeth(aTHX_ stash, cooky, l, -1);
46fc3d4c 1366 cv = 0;
89ffc314 1367 if (gv && (cv = GvCV(gv))) {
44a8e56a
PP
1368 if (GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")
1369 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "overload")) {
611c1e95
IZ
1370 /* This is a hack to support autoloading..., while
1371 knowing *which* methods were declared as overloaded. */
44a8e56a 1372 /* GvSV contains the name of the method. */
4ea42e7f 1373 GV *ngv = Nullgv;
44a8e56a 1374
84c133a0
RB
1375 DEBUG_o( Perl_deb(aTHX_ "Resolving method `%"SVf256\
1376 "' for overloaded `%s' in package `%.256s'\n",
35c1215d 1377 GvSV(gv), cp, HvNAME(stash)) );
b267980d 1378 if (!SvPOK(GvSV(gv))
dc848c6f
PP
1379 || !(ngv = gv_fetchmethod_autoload(stash, SvPVX(GvSV(gv)),
1380 FALSE)))
1381 {
44a8e56a 1382 /* Can be an import stub (created by `can'). */
35c1215d
NC
1383 SV *gvsv = GvSV(gv);
1384 const char *name = SvPOK(gvsv) ? SvPVX(gvsv) : "???";
84c133a0
RB
1385 Perl_croak(aTHX_ "%s method `%.256s' overloading `%s' "\
1386 "in package `%.256s'",
35c1215d
NC
1387 (GvCVGEN(gv) ? "Stub found while resolving"
1388 : "Can't resolve"),
1389 name, cp, HvNAME(stash));
44a8e56a 1390 }
dc848c6f 1391 cv = GvCV(gv = ngv);
44a8e56a 1392 }
cea2e8a9 1393 DEBUG_o( Perl_deb(aTHX_ "Overloading `%s' in package `%.256s' via `%.256s::%.256s' \n",
44a8e56a
PP
1394 cp, HvNAME(stash), HvNAME(GvSTASH(CvGV(cv))),
1395 GvNAME(CvGV(cv))) );
1396 filled = 1;
32251b26
IZ
1397 if (i < DESTROY_amg)
1398 have_ovl = 1;
611c1e95
IZ
1399 } else if (gv) { /* Autoloaded... */
1400 cv = (CV*)gv;
1401 filled = 1;
44a8e56a 1402 }
a6006777 1403 amt.table[i]=(CV*)SvREFCNT_inc(cv);
a0d0e21e 1404 }
a0d0e21e 1405 if (filled) {
a6006777 1406 AMT_AMAGIC_on(&amt);
32251b26
IZ
1407 if (have_ovl)
1408 AMT_OVERLOADED_on(&amt);
14befaf4
DM
1409 sv_magic((SV*)stash, 0, PERL_MAGIC_overload_table,
1410 (char*)&amt, sizeof(AMT));
32251b26 1411 return have_ovl;
a0d0e21e
LW
1412 }
1413 }
a6006777 1414 /* Here we have no table: */
9cbac4c7 1415 /* no_table: */
a6006777 1416 AMT_AMAGIC_off(&amt);
14befaf4
DM
1417 sv_magic((SV*)stash, 0, PERL_MAGIC_overload_table,
1418 (char*)&amt, sizeof(AMTS));
a0d0e21e
LW
1419 return FALSE;
1420}
1421
32251b26
IZ
1422
1423CV*
1424Perl_gv_handler(pTHX_ HV *stash, I32 id)
1425{
3f8f4626 1426 MAGIC *mg;
32251b26 1427 AMT *amtp;
3ad83ce7 1428 CV *ret;
32251b26 1429
e27ad1f2 1430 if (!stash || !HvNAME(stash))
3f8f4626 1431 return Nullcv;
14befaf4 1432 mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
32251b26
IZ
1433 if (!mg) {
1434 do_update:
1435 Gv_AMupdate(stash);
14befaf4 1436 mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
32251b26
IZ
1437 }
1438 amtp = (AMT*)mg->mg_ptr;
1439 if ( amtp->was_ok_am != PL_amagic_generation
1440 || amtp->was_ok_sub != PL_sub_generation )
1441 goto do_update;
3ad83ce7
AMS
1442 if (AMT_AMAGIC(amtp)) {
1443 ret = amtp->table[id];
1444 if (ret && isGV(ret)) { /* Autoloading stab */
1445 /* Passing it through may have resulted in a warning
1446 "Inherited AUTOLOAD for a non-method deprecated", since
1447 our caller is going through a function call, not a method call.
1448 So return the CV for AUTOLOAD, setting $AUTOLOAD. */
1449 GV *gv = gv_fetchmethod(stash, (char*)PL_AMG_names[id]);
1450
1451 if (gv && GvCV(gv))
1452 return GvCV(gv);
1453 }
1454 return ret;
1455 }
1456
32251b26
IZ
1457 return Nullcv;
1458}
1459
1460
a0d0e21e 1461SV*
864dbfa3 1462Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
a0d0e21e 1463{
b267980d 1464 MAGIC *mg;
9c5ffd7c 1465 CV *cv=NULL;
a0d0e21e 1466 CV **cvp=NULL, **ocvp=NULL;
9c5ffd7c 1467 AMT *amtp=NULL, *oamtp=NULL;
497b47a8 1468 int off=0, off1, lr=0, assign=AMGf_assign & flags, notfound=0;
ee239bfe 1469 int postpr = 0, force_cpy = 0, assignshift = assign ? 1 : 0;
497b47a8
JH
1470#ifdef DEBUGGING
1471 int fl=0;
497b47a8 1472#endif
25716404 1473 HV* stash=NULL;
a0d0e21e 1474 if (!(AMGf_noleft & flags) && SvAMAGIC(left)
25716404
GS
1475 && (stash = SvSTASH(SvRV(left)))
1476 && (mg = mg_find((SV*)stash, PERL_MAGIC_overload_table))
b267980d 1477 && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
a6006777 1478 ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
8ac85365 1479 : (CV **) NULL))
b267980d 1480 && ((cv = cvp[off=method+assignshift])
748a9306
LW
1481 || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
1482 * usual method */
497b47a8
JH
1483 (
1484#ifdef DEBUGGING
1485 fl = 1,
1486#endif
1487 cv = cvp[off=method])))) {
a0d0e21e
LW
1488 lr = -1; /* Call method for left argument */
1489 } else {
1490 if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) {
1491 int logic;
1492
1493 /* look for substituted methods */
ee239bfe 1494 /* In all the covered cases we should be called with assign==0. */
a0d0e21e
LW
1495 switch (method) {
1496 case inc_amg:
ee239bfe
IZ
1497 force_cpy = 1;
1498 if ((cv = cvp[off=add_ass_amg])
1499 || ((cv = cvp[off = add_amg]) && (force_cpy = 0, postpr = 1))) {
3280af22 1500 right = &PL_sv_yes; lr = -1; assign = 1;
a0d0e21e
LW
1501 }
1502 break;
1503 case dec_amg:
ee239bfe
IZ
1504 force_cpy = 1;
1505 if ((cv = cvp[off = subtr_ass_amg])
1506 || ((cv = cvp[off = subtr_amg]) && (force_cpy = 0, postpr=1))) {
3280af22 1507 right = &PL_sv_yes; lr = -1; assign = 1;
a0d0e21e
LW
1508 }
1509 break;
1510 case bool__amg:
1511 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg]));
1512 break;
1513 case numer_amg:
1514 (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg]));
1515 break;
1516 case string_amg:
1517 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg]));
1518 break;
dc437b57 1519 case not_amg:
b267980d 1520 (void)((cv = cvp[off=bool__amg])
dc437b57
PP
1521 || (cv = cvp[off=numer_amg])
1522 || (cv = cvp[off=string_amg]));
1523 postpr = 1;
1524 break;
748a9306
LW
1525 case copy_amg:
1526 {
76e3520e
GS
1527 /*
1528 * SV* ref causes confusion with the interpreter variable of
1529 * the same name
1530 */
1531 SV* tmpRef=SvRV(left);
1532 if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) {
fc36a67e
PP
1533 /*
1534 * Just to be extra cautious. Maybe in some
1535 * additional cases sv_setsv is safe, too.
1536 */
76e3520e 1537 SV* newref = newSVsv(tmpRef);
748a9306 1538 SvOBJECT_on(newref);
76e3520e 1539 SvSTASH(newref) = (HV*)SvREFCNT_inc(SvSTASH(tmpRef));
748a9306
LW
1540 return newref;
1541 }
1542 }
1543 break;
a0d0e21e 1544 case abs_amg:
b267980d 1545 if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg])
a0d0e21e 1546 && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) {
748a9306 1547 SV* nullsv=sv_2mortal(newSViv(0));
a0d0e21e 1548 if (off1==lt_amg) {
748a9306 1549 SV* lessp = amagic_call(left,nullsv,
a0d0e21e
LW
1550 lt_amg,AMGf_noright);
1551 logic = SvTRUE(lessp);
1552 } else {
748a9306 1553 SV* lessp = amagic_call(left,nullsv,
a0d0e21e
LW
1554 ncmp_amg,AMGf_noright);
1555 logic = (SvNV(lessp) < 0);
1556 }
1557 if (logic) {
1558 if (off==subtr_amg) {
1559 right = left;
748a9306 1560 left = nullsv;
a0d0e21e
LW
1561 lr = 1;
1562 }
1563 } else {
1564 return left;
1565 }
1566 }
1567 break;
1568 case neg_amg:
155aba94 1569 if ((cv = cvp[off=subtr_amg])) {
a0d0e21e
LW
1570 right = left;
1571 left = sv_2mortal(newSViv(0));
1572 lr = 1;
1573 }
1574 break;
f216259d 1575 case int_amg:
f5284f61 1576 case iter_amg: /* XXXX Eventually should do to_gv. */
b267980d
NIS
1577 /* FAIL safe */
1578 return NULL; /* Delegate operation to standard mechanisms. */
1579 break;
f5284f61
IZ
1580 case to_sv_amg:
1581 case to_av_amg:
1582 case to_hv_amg:
1583 case to_gv_amg:
1584 case to_cv_amg:
1585 /* FAIL safe */
b267980d 1586 return left; /* Delegate operation to standard mechanisms. */
f5284f61 1587 break;
a0d0e21e
LW
1588 default:
1589 goto not_found;
1590 }
1591 if (!cv) goto not_found;
1592 } else if (!(AMGf_noright & flags) && SvAMAGIC(right)
25716404
GS
1593 && (stash = SvSTASH(SvRV(right)))
1594 && (mg = mg_find((SV*)stash, PERL_MAGIC_overload_table))
b267980d 1595 && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
a6006777 1596 ? (amtp = (AMT*)mg->mg_ptr)->table
8ac85365 1597 : (CV **) NULL))
a0d0e21e
LW
1598 && (cv = cvp[off=method])) { /* Method for right
1599 * argument found */
1600 lr=1;
b267980d
NIS
1601 } else if (((ocvp && oamtp->fallback > AMGfallNEVER
1602 && (cvp=ocvp) && (lr = -1))
a0d0e21e
LW
1603 || (cvp && amtp->fallback > AMGfallNEVER && (lr=1)))
1604 && !(flags & AMGf_unary)) {
1605 /* We look for substitution for
1606 * comparison operations and
fc36a67e 1607 * concatenation */
a0d0e21e
LW
1608 if (method==concat_amg || method==concat_ass_amg
1609 || method==repeat_amg || method==repeat_ass_amg) {
1610 return NULL; /* Delegate operation to string conversion */
1611 }
1612 off = -1;
1613 switch (method) {
1614 case lt_amg:
1615 case le_amg:
1616 case gt_amg:
1617 case ge_amg:
1618 case eq_amg:
1619 case ne_amg:
1620 postpr = 1; off=ncmp_amg; break;
1621 case slt_amg:
1622 case sle_amg:
1623 case sgt_amg:
1624 case sge_amg:
1625 case seq_amg:
1626 case sne_amg:
1627 postpr = 1; off=scmp_amg; break;
1628 }
1629 if (off != -1) cv = cvp[off];
1630 if (!cv) {
1631 goto not_found;
1632 }
1633 } else {
a6006777 1634 not_found: /* No method found, either report or croak */
b267980d
NIS
1635 switch (method) {
1636 case to_sv_amg:
1637 case to_av_amg:
1638 case to_hv_amg:
1639 case to_gv_amg:
1640 case to_cv_amg:
1641 /* FAIL safe */
1642 return left; /* Delegate operation to standard mechanisms. */
1643 break;
1644 }
a0d0e21e
LW
1645 if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */
1646 notfound = 1; lr = -1;
1647 } else if (cvp && (cv=cvp[nomethod_amg])) {
1648 notfound = 1; lr = 1;
1649 } else {
46fc3d4c 1650 SV *msg;
774d564b 1651 if (off==-1) off=method;
b267980d 1652 msg = sv_2mortal(Perl_newSVpvf(aTHX_
46fc3d4c 1653 "Operation `%s': no method found,%sargument %s%s%s%s",
89ffc314 1654 AMG_id2name(method + assignshift),
e7ea3e70 1655 (flags & AMGf_unary ? " " : "\n\tleft "),
b267980d 1656 SvAMAGIC(left)?
a0d0e21e
LW
1657 "in overloaded package ":
1658 "has no overloaded magic",
b267980d 1659 SvAMAGIC(left)?
a0d0e21e
LW
1660 HvNAME(SvSTASH(SvRV(left))):
1661 "",
b267980d 1662 SvAMAGIC(right)?
e7ea3e70 1663 ",\n\tright argument in overloaded package ":
b267980d 1664 (flags & AMGf_unary
e7ea3e70
IZ
1665 ? ""
1666 : ",\n\tright argument has no overloaded magic"),
b267980d 1667 SvAMAGIC(right)?
a0d0e21e 1668 HvNAME(SvSTASH(SvRV(right))):
46fc3d4c 1669 ""));
a0d0e21e 1670 if (amtp && amtp->fallback >= AMGfallYES) {
cea2e8a9 1671 DEBUG_o( Perl_deb(aTHX_ "%s", SvPVX(msg)) );
a0d0e21e 1672 } else {
894356b3 1673 Perl_croak(aTHX_ "%"SVf, msg);
a0d0e21e
LW
1674 }
1675 return NULL;
1676 }
ee239bfe 1677 force_cpy = force_cpy || assign;
a0d0e21e
LW
1678 }
1679 }
497b47a8 1680#ifdef DEBUGGING
a0d0e21e 1681 if (!notfound) {
497b47a8
JH
1682 DEBUG_o(Perl_deb(aTHX_
1683 "Overloaded operator `%s'%s%s%s:\n\tmethod%s found%s in package %s%s\n",
1684 AMG_id2name(off),
1685 method+assignshift==off? "" :
1686 " (initially `",
1687 method+assignshift==off? "" :
1688 AMG_id2name(method+assignshift),
1689 method+assignshift==off? "" : "')",
1690 flags & AMGf_unary? "" :
1691 lr==1 ? " for right argument": " for left argument",
1692 flags & AMGf_unary? " for argument" : "",
25716404 1693 stash ? HvNAME(stash) : "null",
497b47a8 1694 fl? ",\n\tassignment variant used": "") );
ee239bfe 1695 }
497b47a8 1696#endif
748a9306
LW
1697 /* Since we use shallow copy during assignment, we need
1698 * to dublicate the contents, probably calling user-supplied
1699 * version of copy operator
1700 */
ee239bfe
IZ
1701 /* We need to copy in following cases:
1702 * a) Assignment form was called.
1703 * assignshift==1, assign==T, method + 1 == off
1704 * b) Increment or decrement, called directly.
1705 * assignshift==0, assign==0, method + 0 == off
1706 * c) Increment or decrement, translated to assignment add/subtr.
b267980d 1707 * assignshift==0, assign==T,
ee239bfe
IZ
1708 * force_cpy == T
1709 * d) Increment or decrement, translated to nomethod.
b267980d 1710 * assignshift==0, assign==0,
ee239bfe
IZ
1711 * force_cpy == T
1712 * e) Assignment form translated to nomethod.
1713 * assignshift==1, assign==T, method + 1 != off
1714 * force_cpy == T
1715 */
1716 /* off is method, method+assignshift, or a result of opcode substitution.
1717 * In the latter case assignshift==0, so only notfound case is important.
1718 */
1719 if (( (method + assignshift == off)
1720 && (assign || (method == inc_amg) || (method == dec_amg)))
1721 || force_cpy)
1722 RvDEEPCP(left);
a0d0e21e
LW
1723 {
1724 dSP;
1725 BINOP myop;
1726 SV* res;
54310121 1727 bool oldcatch = CATCH_GET;
a0d0e21e 1728
54310121 1729 CATCH_SET(TRUE);
a0d0e21e
LW
1730 Zero(&myop, 1, BINOP);
1731 myop.op_last = (OP *) &myop;
1732 myop.op_next = Nullop;
54310121 1733 myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
a0d0e21e 1734
e788e7d3 1735 PUSHSTACKi(PERLSI_OVERLOAD);
a0d0e21e 1736 ENTER;
462e5cf6 1737 SAVEOP();
533c011a 1738 PL_op = (OP *) &myop;
3280af22 1739 if (PERLDB_SUB && PL_curstash != PL_debstash)
533c011a 1740 PL_op->op_private |= OPpENTERSUB_DB;
a0d0e21e 1741 PUTBACK;
cea2e8a9 1742 pp_pushmark();
a0d0e21e 1743
924508f0 1744 EXTEND(SP, notfound + 5);
a0d0e21e
LW
1745 PUSHs(lr>0? right: left);
1746 PUSHs(lr>0? left: right);
3280af22 1747 PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no ));
a0d0e21e 1748 if (notfound) {
89ffc314 1749 PUSHs( sv_2mortal(newSVpv(AMG_id2name(method + assignshift),0)));
a0d0e21e
LW
1750 }
1751 PUSHs((SV*)cv);
1752 PUTBACK;
1753
155aba94 1754 if ((PL_op = Perl_pp_entersub(aTHX)))
cea2e8a9 1755 CALLRUNOPS(aTHX);
a0d0e21e
LW
1756 LEAVE;
1757 SPAGAIN;
1758
1759 res=POPs;
ebafeae7 1760 PUTBACK;
d3acc0f7 1761 POPSTACK;
54310121 1762 CATCH_SET(oldcatch);
a0d0e21e 1763
a0d0e21e 1764 if (postpr) {
9c5ffd7c 1765 int ans=0;
a0d0e21e
LW
1766 switch (method) {
1767 case le_amg:
1768 case sle_amg:
1769 ans=SvIV(res)<=0; break;
1770 case lt_amg:
1771 case slt_amg:
1772 ans=SvIV(res)<0; break;
1773 case ge_amg:
1774 case sge_amg:
1775 ans=SvIV(res)>=0; break;
1776 case gt_amg:
1777 case sgt_amg:
1778 ans=SvIV(res)>0; break;
1779 case eq_amg:
1780 case seq_amg:
1781 ans=SvIV(res)==0; break;
1782 case ne_amg:
1783 case sne_amg:
1784 ans=SvIV(res)!=0; break;
1785 case inc_amg:
1786 case dec_amg:
bbce6d69 1787 SvSetSV(left,res); return left;
dc437b57 1788 case not_amg:
fe7ac86a 1789 ans=!SvTRUE(res); break;
a0d0e21e 1790 }
54310121 1791 return boolSV(ans);
748a9306
LW
1792 } else if (method==copy_amg) {
1793 if (!SvROK(res)) {
cea2e8a9 1794 Perl_croak(aTHX_ "Copy method did not return a reference");
748a9306
LW
1795 }
1796 return SvREFCNT_inc(SvRV(res));
a0d0e21e
LW
1797 } else {
1798 return res;
1799 }
1800 }
1801}
c9d5ac95
GS
1802
1803/*
1804=for apidoc is_gv_magical
1805
1806Returns C<TRUE> if given the name of a magical GV.
1807
1808Currently only useful internally when determining if a GV should be
1809created even in rvalue contexts.
1810
1811C<flags> is not used at present but available for future extension to
1812allow selecting particular classes of magical variable.
1813
1814=cut
1815*/
1816bool
1817Perl_is_gv_magical(pTHX_ char *name, STRLEN len, U32 flags)
1818{
1819 if (!len)
1820 return FALSE;
1821
1822 switch (*name) {
1823 case 'I':
1824 if (len == 3 && strEQ(name, "ISA"))
1825 goto yes;
1826 break;
1827 case 'O':
1828 if (len == 8 && strEQ(name, "OVERLOAD"))
1829 goto yes;
1830 break;
1831 case 'S':
1832 if (len == 3 && strEQ(name, "SIG"))
1833 goto yes;
1834 break;
ac27b0f5
NIS
1835 case '\017': /* $^O & $^OPEN */
1836 if (len == 1
563aca73 1837 || (len == 4 && strEQ(name, "\017PEN")))
ac27b0f5
NIS
1838 {
1839 goto yes;
1840 }
1841 break;
fde18df1 1842 case '\025':
a05d7ebb 1843 if (len > 1 && strEQ(name, "\025NICODE"))
fde18df1 1844 goto yes;
c9d5ac95
GS
1845 case '\027': /* $^W & $^WARNING_BITS */
1846 if (len == 1
1847 || (len == 12 && strEQ(name, "\027ARNING_BITS"))
fde18df1 1848 )
c9d5ac95
GS
1849 {
1850 goto yes;
1851 }
1852 break;
1853
1854 case '&':
1855 case '`':
1856 case '\'':
1857 case ':':
1858 case '?':
1859 case '!':
1860 case '-':
1861 case '#':
c9d5ac95
GS
1862 case '[':
1863 case '^':
1864 case '~':
1865 case '=':
1866 case '%':
1867 case '.':
1868 case '(':
1869 case ')':
1870 case '<':
1871 case '>':
1872 case ',':
1873 case '\\':
1874 case '/':
1875 case '|':
1876 case '+':
1877 case ';':
1878 case ']':
1879 case '\001': /* $^A */
1880 case '\003': /* $^C */
1881 case '\004': /* $^D */
1882 case '\005': /* $^E */
1883 case '\006': /* $^F */
1884 case '\010': /* $^H */
1885 case '\011': /* $^I, NOT \t in EBCDIC */
1886 case '\014': /* $^L */
a01268b5 1887 case '\016': /* $^N */
c9d5ac95
GS
1888 case '\020': /* $^P */
1889 case '\023': /* $^S */
c9d5ac95
GS
1890 case '\026': /* $^V */
1891 if (len == 1)
1892 goto yes;
1893 break;
eb27b65e
AMS
1894 case '\024': /* $^T, ${^TAINT} */
1895 if (len == 1 || strEQ(name, "\024AINT"))
1896 goto yes;
1897 break;
c9d5ac95
GS
1898 case '1':
1899 case '2':
1900 case '3':
1901 case '4':
1902 case '5':
1903 case '6':
1904 case '7':
1905 case '8':
1906 case '9':
1907 if (len > 1) {
1908 char *end = name + len;
1909 while (--end > name) {
1910 if (!isDIGIT(*end))
1911 return FALSE;
1912 }
1913 }
1914 yes:
1915 return TRUE;
1916 default:
1917 break;
1918 }
1919 return FALSE;
1920}