This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
backout change 22606 (make gv_fullname() include a literal '^')
[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 }
257984c0 1099 sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv));
43693395
GS
1100}
1101
1102void
864dbfa3 1103Perl_gv_fullname3(pTHX_ SV *sv, GV *gv, const char *prefix)
79072805 1104{
84e79d79 1105 gv_fullname4(sv, gv, prefix, TRUE);
79072805
LW
1106}
1107
1108void
43693395
GS
1109Perl_gv_efullname4(pTHX_ SV *sv, GV *gv, const char *prefix, bool keepmain)
1110{
1111 GV *egv = GvEGV(gv);
1112 if (!egv)
1113 egv = gv;
1114 gv_fullname4(sv, egv, prefix, keepmain);
1115}
1116
1117void
864dbfa3 1118Perl_gv_efullname3(pTHX_ SV *sv, GV *gv, const char *prefix)
79072805 1119{
84e79d79 1120 gv_efullname4(sv, gv, prefix, TRUE);
f6aff53a
PP
1121}
1122
1123/* XXX compatibility with versions <= 5.003. */
1124void
864dbfa3 1125Perl_gv_fullname(pTHX_ SV *sv, GV *gv)
f6aff53a
PP
1126{
1127 gv_fullname3(sv, gv, sv == (SV*)gv ? "*" : "");
1128}
1129
1130/* XXX compatibility with versions <= 5.003. */
1131void
864dbfa3 1132Perl_gv_efullname(pTHX_ SV *sv, GV *gv)
f6aff53a
PP
1133{
1134 gv_efullname3(sv, gv, sv == (SV*)gv ? "*" : "");
79072805
LW
1135}
1136
1137IO *
864dbfa3 1138Perl_newIO(pTHX)
79072805
LW
1139{
1140 IO *io;
8990e307
LW
1141 GV *iogv;
1142
1143 io = (IO*)NEWSV(0,0);
a0d0e21e 1144 sv_upgrade((SV *)io,SVt_PVIO);
8990e307
LW
1145 SvREFCNT(io) = 1;
1146 SvOBJECT_on(io);
081fc587
AB
1147 /* Clear the stashcache because a new IO could overrule a
1148 package name */
1149 hv_clear(PL_stashcache);
c9de509e 1150 iogv = gv_fetchpv("FileHandle::", FALSE, SVt_PVHV);
5f2d631d
GS
1151 /* unless exists($main::{FileHandle}) and defined(%main::FileHandle::) */
1152 if (!(iogv && GvHV(iogv) && HvARRAY(GvHV(iogv))))
c9de509e 1153 iogv = gv_fetchpv("IO::Handle::", TRUE, SVt_PVHV);
8990e307 1154 SvSTASH(io) = (HV*)SvREFCNT_inc(GvHV(iogv));
79072805
LW
1155 return io;
1156}
1157
1158void
864dbfa3 1159Perl_gv_check(pTHX_ HV *stash)
79072805
LW
1160{
1161 register HE *entry;
1162 register I32 i;
1163 register GV *gv;
463ee0b2
LW
1164 HV *hv;
1165
8990e307
LW
1166 if (!HvARRAY(stash))
1167 return;
a0d0e21e 1168 for (i = 0; i <= (I32) HvMAX(stash); i++) {
dc437b57
PP
1169 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
1170 if (HeKEY(entry)[HeKLEN(entry)-1] == ':' &&
b862623f 1171 (gv = (GV*)HeVAL(entry)) && isGV(gv) && (hv = GvHV(gv)))
a0d0e21e 1172 {
19b6c847 1173 if (hv != PL_defstash && hv != stash)
a0d0e21e
LW
1174 gv_check(hv); /* nested package */
1175 }
dc437b57 1176 else if (isALPHA(*HeKEY(entry))) {
1d7c1841 1177 char *file;
dc437b57 1178 gv = (GV*)HeVAL(entry);
55d729e4 1179 if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv))
463ee0b2 1180 continue;
1d7c1841
GS
1181 file = GvFILE(gv);
1182 /* performance hack: if filename is absolute and it's a standard
1183 * module, don't bother warning */
1184 if (file
1185 && PERL_FILE_IS_ABSOLUTE(file)
6eb630b7
CN
1186#ifdef MACOS_TRADITIONAL
1187 && (instr(file, ":lib:")
1188#else
1189 && (instr(file, "/lib/")
1190#endif
1191 || instr(file, ".pm")))
1d7c1841 1192 {
8990e307 1193 continue;
1d7c1841
GS
1194 }
1195 CopLINE_set(PL_curcop, GvLINE(gv));
1196#ifdef USE_ITHREADS
1197 CopFILE(PL_curcop) = file; /* set for warning */
1198#else
1199 CopFILEGV(PL_curcop) = gv_fetchfile(file);
1200#endif
9014280d 1201 Perl_warner(aTHX_ packWARN(WARN_ONCE),
599cee73 1202 "Name \"%s::%s\" used only once: possible typo",
a0d0e21e 1203 HvNAME(stash), GvNAME(gv));
463ee0b2 1204 }
79072805
LW
1205 }
1206 }
1207}
1208
1209GV *
864dbfa3 1210Perl_newGVgen(pTHX_ char *pack)
79072805 1211{
cea2e8a9 1212 return gv_fetchpv(Perl_form(aTHX_ "%s::_GEN_%ld", pack, (long)PL_gensym++),
46fc3d4c 1213 TRUE, SVt_PVGV);
79072805
LW
1214}
1215
1216/* hopefully this is only called on local symbol table entries */
1217
1218GP*
864dbfa3 1219Perl_gp_ref(pTHX_ GP *gp)
79072805 1220{
1d7c1841
GS
1221 if (!gp)
1222 return (GP*)NULL;
79072805 1223 gp->gp_refcnt++;
44a8e56a
PP
1224 if (gp->gp_cv) {
1225 if (gp->gp_cvgen) {
1226 /* multi-named GPs cannot be used for method cache */
1227 SvREFCNT_dec(gp->gp_cv);
1228 gp->gp_cv = Nullcv;
1229 gp->gp_cvgen = 0;
1230 }
1231 else {
1232 /* Adding a new name to a subroutine invalidates method cache */
3280af22 1233 PL_sub_generation++;
44a8e56a
PP
1234 }
1235 }
79072805 1236 return gp;
79072805
LW
1237}
1238
1239void
864dbfa3 1240Perl_gp_free(pTHX_ GV *gv)
79072805 1241{
79072805
LW
1242 GP* gp;
1243
1244 if (!gv || !(gp = GvGP(gv)))
1245 return;
f248d071
GS
1246 if (gp->gp_refcnt == 0) {
1247 if (ckWARN_d(WARN_INTERNAL))
9014280d 1248 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
f248d071 1249 "Attempt to free unreferenced glob pointers");
79072805
LW
1250 return;
1251 }
44a8e56a
PP
1252 if (gp->gp_cv) {
1253 /* Deleting the name of a subroutine invalidates method cache */
3280af22 1254 PL_sub_generation++;
44a8e56a 1255 }
748a9306
LW
1256 if (--gp->gp_refcnt > 0) {
1257 if (gp->gp_egv == gv)
1258 gp->gp_egv = 0;
79072805 1259 return;
748a9306 1260 }
79072805 1261
13207a71
JH
1262 if (gp->gp_sv) SvREFCNT_dec(gp->gp_sv);
1263 if (gp->gp_sv) SvREFCNT_dec(gp->gp_av);
1264 if (gp->gp_hv) {
1265 if (PL_stashcache && HvNAME(gp->gp_hv))
1266 hv_delete(PL_stashcache,
1267 HvNAME(gp->gp_hv), strlen(HvNAME(gp->gp_hv)),
1268 G_DISCARD);
1269 SvREFCNT_dec(gp->gp_hv);
1270 }
1271 if (gp->gp_io) SvREFCNT_dec(gp->gp_io);
1272 if (gp->gp_cv) SvREFCNT_dec(gp->gp_cv);
1273 if (gp->gp_form) SvREFCNT_dec(gp->gp_form);
748a9306 1274
79072805
LW
1275 Safefree(gp);
1276 GvGP(gv) = 0;
1277}
1278
d460ef45
NIS
1279int
1280Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg)
1281{
1282 AMT *amtp = (AMT*)mg->mg_ptr;
1283 if (amtp && AMT_AMAGIC(amtp)) {
1284 int i;
1285 for (i = 1; i < NofAMmeth; i++) {
1286 CV *cv = amtp->table[i];
1287 if (cv != Nullcv) {
1288 SvREFCNT_dec((SV *) cv);
1289 amtp->table[i] = Nullcv;
1290 }
1291 }
1292 }
1293 return 0;
1294}
1295
a0d0e21e
LW
1296/* Updates and caches the CV's */
1297
1298bool
864dbfa3 1299Perl_Gv_AMupdate(pTHX_ HV *stash)
a0d0e21e 1300{
a0d0e21e
LW
1301 GV* gv;
1302 CV* cv;
14befaf4 1303 MAGIC* mg=mg_find((SV*)stash, PERL_MAGIC_overload_table);
8ac85365 1304 AMT *amtp = (mg) ? (AMT*)mg->mg_ptr: (AMT *) NULL;
a6006777 1305 AMT amt;
a0d0e21e 1306
3280af22
NIS
1307 if (mg && amtp->was_ok_am == PL_amagic_generation
1308 && amtp->was_ok_sub == PL_sub_generation)
eb160463 1309 return (bool)AMT_OVERLOADED(amtp);
14befaf4 1310 sv_unmagic((SV*)stash, PERL_MAGIC_overload_table);
a0d0e21e 1311
cea2e8a9 1312 DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME(stash)) );
a0d0e21e 1313
d460ef45 1314 Zero(&amt,1,AMT);
3280af22
NIS
1315 amt.was_ok_am = PL_amagic_generation;
1316 amt.was_ok_sub = PL_sub_generation;
a6006777
PP
1317 amt.fallback = AMGfallNO;
1318 amt.flags = 0;
1319
a6006777 1320 {
32251b26
IZ
1321 int filled = 0, have_ovl = 0;
1322 int i, lim = 1;
a6006777 1323 SV* sv = NULL;
a6006777 1324
22c35a8c 1325 /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
a6006777 1326
89ffc314
IZ
1327 /* Try to find via inheritance. */
1328 gv = gv_fetchmeth(stash, PL_AMG_names[0], 2, -1);
1329 if (gv)
1330 sv = GvSV(gv);
1331
1332 if (!gv)
32251b26 1333 lim = DESTROY_amg; /* Skip overloading entries. */
89ffc314
IZ
1334 else if (SvTRUE(sv))
1335 amt.fallback=AMGfallYES;
1336 else if (SvOK(sv))
1337 amt.fallback=AMGfallNEVER;
a6006777 1338
32251b26
IZ
1339 for (i = 1; i < lim; i++)
1340 amt.table[i] = Nullcv;
1341 for (; i < NofAMmeth; i++) {
c8ce92fc 1342 char *cooky = (char*)PL_AMG_names[i];
32251b26
IZ
1343 /* Human-readable form, for debugging: */
1344 char *cp = (i >= DESTROY_amg ? cooky : AMG_id2name(i));
89ffc314
IZ
1345 STRLEN l = strlen(cooky);
1346
cea2e8a9 1347 DEBUG_o( Perl_deb(aTHX_ "Checking overloading of `%s' in package `%.256s'\n",
44a8e56a 1348 cp, HvNAME(stash)) );
611c1e95
IZ
1349 /* don't fill the cache while looking up!
1350 Creation of inheritance stubs in intermediate packages may
1351 conflict with the logic of runtime method substitution.
1352 Indeed, for inheritance A -> B -> C, if C overloads "+0",
1353 then we could have created stubs for "(+0" in A and C too.
1354 But if B overloads "bool", we may want to use it for
1355 numifying instead of C's "+0". */
1356 if (i >= DESTROY_amg)
1357 gv = Perl_gv_fetchmeth_autoload(aTHX_ stash, cooky, l, 0);
1358 else /* Autoload taken care of below */
1359 gv = Perl_gv_fetchmeth(aTHX_ stash, cooky, l, -1);
46fc3d4c 1360 cv = 0;
89ffc314 1361 if (gv && (cv = GvCV(gv))) {
44a8e56a
PP
1362 if (GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")
1363 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "overload")) {
611c1e95
IZ
1364 /* This is a hack to support autoloading..., while
1365 knowing *which* methods were declared as overloaded. */
44a8e56a 1366 /* GvSV contains the name of the method. */
4ea42e7f 1367 GV *ngv = Nullgv;
44a8e56a 1368
84c133a0
RB
1369 DEBUG_o( Perl_deb(aTHX_ "Resolving method `%"SVf256\
1370 "' for overloaded `%s' in package `%.256s'\n",
35c1215d 1371 GvSV(gv), cp, HvNAME(stash)) );
b267980d 1372 if (!SvPOK(GvSV(gv))
dc848c6f
PP
1373 || !(ngv = gv_fetchmethod_autoload(stash, SvPVX(GvSV(gv)),
1374 FALSE)))
1375 {
44a8e56a 1376 /* Can be an import stub (created by `can'). */
35c1215d
NC
1377 SV *gvsv = GvSV(gv);
1378 const char *name = SvPOK(gvsv) ? SvPVX(gvsv) : "???";
84c133a0
RB
1379 Perl_croak(aTHX_ "%s method `%.256s' overloading `%s' "\
1380 "in package `%.256s'",
35c1215d
NC
1381 (GvCVGEN(gv) ? "Stub found while resolving"
1382 : "Can't resolve"),
1383 name, cp, HvNAME(stash));
44a8e56a 1384 }
dc848c6f 1385 cv = GvCV(gv = ngv);
44a8e56a 1386 }
cea2e8a9 1387 DEBUG_o( Perl_deb(aTHX_ "Overloading `%s' in package `%.256s' via `%.256s::%.256s' \n",
44a8e56a
PP
1388 cp, HvNAME(stash), HvNAME(GvSTASH(CvGV(cv))),
1389 GvNAME(CvGV(cv))) );
1390 filled = 1;
32251b26
IZ
1391 if (i < DESTROY_amg)
1392 have_ovl = 1;
611c1e95
IZ
1393 } else if (gv) { /* Autoloaded... */
1394 cv = (CV*)gv;
1395 filled = 1;
44a8e56a 1396 }
a6006777 1397 amt.table[i]=(CV*)SvREFCNT_inc(cv);
a0d0e21e 1398 }
a0d0e21e 1399 if (filled) {
a6006777 1400 AMT_AMAGIC_on(&amt);
32251b26
IZ
1401 if (have_ovl)
1402 AMT_OVERLOADED_on(&amt);
14befaf4
DM
1403 sv_magic((SV*)stash, 0, PERL_MAGIC_overload_table,
1404 (char*)&amt, sizeof(AMT));
32251b26 1405 return have_ovl;
a0d0e21e
LW
1406 }
1407 }
a6006777 1408 /* Here we have no table: */
9cbac4c7 1409 /* no_table: */
a6006777 1410 AMT_AMAGIC_off(&amt);
14befaf4
DM
1411 sv_magic((SV*)stash, 0, PERL_MAGIC_overload_table,
1412 (char*)&amt, sizeof(AMTS));
a0d0e21e
LW
1413 return FALSE;
1414}
1415
32251b26
IZ
1416
1417CV*
1418Perl_gv_handler(pTHX_ HV *stash, I32 id)
1419{
3f8f4626 1420 MAGIC *mg;
32251b26 1421 AMT *amtp;
3ad83ce7 1422 CV *ret;
32251b26 1423
e27ad1f2 1424 if (!stash || !HvNAME(stash))
3f8f4626 1425 return Nullcv;
14befaf4 1426 mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
32251b26
IZ
1427 if (!mg) {
1428 do_update:
1429 Gv_AMupdate(stash);
14befaf4 1430 mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
32251b26
IZ
1431 }
1432 amtp = (AMT*)mg->mg_ptr;
1433 if ( amtp->was_ok_am != PL_amagic_generation
1434 || amtp->was_ok_sub != PL_sub_generation )
1435 goto do_update;
3ad83ce7
AMS
1436 if (AMT_AMAGIC(amtp)) {
1437 ret = amtp->table[id];
1438 if (ret && isGV(ret)) { /* Autoloading stab */
1439 /* Passing it through may have resulted in a warning
1440 "Inherited AUTOLOAD for a non-method deprecated", since
1441 our caller is going through a function call, not a method call.
1442 So return the CV for AUTOLOAD, setting $AUTOLOAD. */
1443 GV *gv = gv_fetchmethod(stash, (char*)PL_AMG_names[id]);
1444
1445 if (gv && GvCV(gv))
1446 return GvCV(gv);
1447 }
1448 return ret;
1449 }
1450
32251b26
IZ
1451 return Nullcv;
1452}
1453
1454
a0d0e21e 1455SV*
864dbfa3 1456Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
a0d0e21e 1457{
b267980d 1458 MAGIC *mg;
9c5ffd7c 1459 CV *cv=NULL;
a0d0e21e 1460 CV **cvp=NULL, **ocvp=NULL;
9c5ffd7c 1461 AMT *amtp=NULL, *oamtp=NULL;
497b47a8 1462 int off=0, off1, lr=0, assign=AMGf_assign & flags, notfound=0;
ee239bfe 1463 int postpr = 0, force_cpy = 0, assignshift = assign ? 1 : 0;
497b47a8
JH
1464#ifdef DEBUGGING
1465 int fl=0;
497b47a8 1466#endif
25716404 1467 HV* stash=NULL;
a0d0e21e 1468 if (!(AMGf_noleft & flags) && SvAMAGIC(left)
25716404
GS
1469 && (stash = SvSTASH(SvRV(left)))
1470 && (mg = mg_find((SV*)stash, PERL_MAGIC_overload_table))
b267980d 1471 && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
a6006777 1472 ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
8ac85365 1473 : (CV **) NULL))
b267980d 1474 && ((cv = cvp[off=method+assignshift])
748a9306
LW
1475 || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
1476 * usual method */
497b47a8
JH
1477 (
1478#ifdef DEBUGGING
1479 fl = 1,
1480#endif
1481 cv = cvp[off=method])))) {
a0d0e21e
LW
1482 lr = -1; /* Call method for left argument */
1483 } else {
1484 if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) {
1485 int logic;
1486
1487 /* look for substituted methods */
ee239bfe 1488 /* In all the covered cases we should be called with assign==0. */
a0d0e21e
LW
1489 switch (method) {
1490 case inc_amg:
ee239bfe
IZ
1491 force_cpy = 1;
1492 if ((cv = cvp[off=add_ass_amg])
1493 || ((cv = cvp[off = add_amg]) && (force_cpy = 0, postpr = 1))) {
3280af22 1494 right = &PL_sv_yes; lr = -1; assign = 1;
a0d0e21e
LW
1495 }
1496 break;
1497 case dec_amg:
ee239bfe
IZ
1498 force_cpy = 1;
1499 if ((cv = cvp[off = subtr_ass_amg])
1500 || ((cv = cvp[off = subtr_amg]) && (force_cpy = 0, postpr=1))) {
3280af22 1501 right = &PL_sv_yes; lr = -1; assign = 1;
a0d0e21e
LW
1502 }
1503 break;
1504 case bool__amg:
1505 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg]));
1506 break;
1507 case numer_amg:
1508 (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg]));
1509 break;
1510 case string_amg:
1511 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg]));
1512 break;
dc437b57 1513 case not_amg:
b267980d 1514 (void)((cv = cvp[off=bool__amg])
dc437b57
PP
1515 || (cv = cvp[off=numer_amg])
1516 || (cv = cvp[off=string_amg]));
1517 postpr = 1;
1518 break;
748a9306
LW
1519 case copy_amg:
1520 {
76e3520e
GS
1521 /*
1522 * SV* ref causes confusion with the interpreter variable of
1523 * the same name
1524 */
1525 SV* tmpRef=SvRV(left);
1526 if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) {
fc36a67e
PP
1527 /*
1528 * Just to be extra cautious. Maybe in some
1529 * additional cases sv_setsv is safe, too.
1530 */
76e3520e 1531 SV* newref = newSVsv(tmpRef);
748a9306 1532 SvOBJECT_on(newref);
76e3520e 1533 SvSTASH(newref) = (HV*)SvREFCNT_inc(SvSTASH(tmpRef));
748a9306
LW
1534 return newref;
1535 }
1536 }
1537 break;
a0d0e21e 1538 case abs_amg:
b267980d 1539 if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg])
a0d0e21e 1540 && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) {
748a9306 1541 SV* nullsv=sv_2mortal(newSViv(0));
a0d0e21e 1542 if (off1==lt_amg) {
748a9306 1543 SV* lessp = amagic_call(left,nullsv,
a0d0e21e
LW
1544 lt_amg,AMGf_noright);
1545 logic = SvTRUE(lessp);
1546 } else {
748a9306 1547 SV* lessp = amagic_call(left,nullsv,
a0d0e21e
LW
1548 ncmp_amg,AMGf_noright);
1549 logic = (SvNV(lessp) < 0);
1550 }
1551 if (logic) {
1552 if (off==subtr_amg) {
1553 right = left;
748a9306 1554 left = nullsv;
a0d0e21e
LW
1555 lr = 1;
1556 }
1557 } else {
1558 return left;
1559 }
1560 }
1561 break;
1562 case neg_amg:
155aba94 1563 if ((cv = cvp[off=subtr_amg])) {
a0d0e21e
LW
1564 right = left;
1565 left = sv_2mortal(newSViv(0));
1566 lr = 1;
1567 }
1568 break;
f216259d 1569 case int_amg:
f5284f61 1570 case iter_amg: /* XXXX Eventually should do to_gv. */
b267980d
NIS
1571 /* FAIL safe */
1572 return NULL; /* Delegate operation to standard mechanisms. */
1573 break;
f5284f61
IZ
1574 case to_sv_amg:
1575 case to_av_amg:
1576 case to_hv_amg:
1577 case to_gv_amg:
1578 case to_cv_amg:
1579 /* FAIL safe */
b267980d 1580 return left; /* Delegate operation to standard mechanisms. */
f5284f61 1581 break;
a0d0e21e
LW
1582 default:
1583 goto not_found;
1584 }
1585 if (!cv) goto not_found;
1586 } else if (!(AMGf_noright & flags) && SvAMAGIC(right)
25716404
GS
1587 && (stash = SvSTASH(SvRV(right)))
1588 && (mg = mg_find((SV*)stash, PERL_MAGIC_overload_table))
b267980d 1589 && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
a6006777 1590 ? (amtp = (AMT*)mg->mg_ptr)->table
8ac85365 1591 : (CV **) NULL))
a0d0e21e
LW
1592 && (cv = cvp[off=method])) { /* Method for right
1593 * argument found */
1594 lr=1;
b267980d
NIS
1595 } else if (((ocvp && oamtp->fallback > AMGfallNEVER
1596 && (cvp=ocvp) && (lr = -1))
a0d0e21e
LW
1597 || (cvp && amtp->fallback > AMGfallNEVER && (lr=1)))
1598 && !(flags & AMGf_unary)) {
1599 /* We look for substitution for
1600 * comparison operations and
fc36a67e 1601 * concatenation */
a0d0e21e
LW
1602 if (method==concat_amg || method==concat_ass_amg
1603 || method==repeat_amg || method==repeat_ass_amg) {
1604 return NULL; /* Delegate operation to string conversion */
1605 }
1606 off = -1;
1607 switch (method) {
1608 case lt_amg:
1609 case le_amg:
1610 case gt_amg:
1611 case ge_amg:
1612 case eq_amg:
1613 case ne_amg:
1614 postpr = 1; off=ncmp_amg; break;
1615 case slt_amg:
1616 case sle_amg:
1617 case sgt_amg:
1618 case sge_amg:
1619 case seq_amg:
1620 case sne_amg:
1621 postpr = 1; off=scmp_amg; break;
1622 }
1623 if (off != -1) cv = cvp[off];
1624 if (!cv) {
1625 goto not_found;
1626 }
1627 } else {
a6006777 1628 not_found: /* No method found, either report or croak */
b267980d
NIS
1629 switch (method) {
1630 case to_sv_amg:
1631 case to_av_amg:
1632 case to_hv_amg:
1633 case to_gv_amg:
1634 case to_cv_amg:
1635 /* FAIL safe */
1636 return left; /* Delegate operation to standard mechanisms. */
1637 break;
1638 }
a0d0e21e
LW
1639 if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */
1640 notfound = 1; lr = -1;
1641 } else if (cvp && (cv=cvp[nomethod_amg])) {
1642 notfound = 1; lr = 1;
1643 } else {
46fc3d4c 1644 SV *msg;
774d564b 1645 if (off==-1) off=method;
b267980d 1646 msg = sv_2mortal(Perl_newSVpvf(aTHX_
46fc3d4c 1647 "Operation `%s': no method found,%sargument %s%s%s%s",
89ffc314 1648 AMG_id2name(method + assignshift),
e7ea3e70 1649 (flags & AMGf_unary ? " " : "\n\tleft "),
b267980d 1650 SvAMAGIC(left)?
a0d0e21e
LW
1651 "in overloaded package ":
1652 "has no overloaded magic",
b267980d 1653 SvAMAGIC(left)?
a0d0e21e
LW
1654 HvNAME(SvSTASH(SvRV(left))):
1655 "",
b267980d 1656 SvAMAGIC(right)?
e7ea3e70 1657 ",\n\tright argument in overloaded package ":
b267980d 1658 (flags & AMGf_unary
e7ea3e70
IZ
1659 ? ""
1660 : ",\n\tright argument has no overloaded magic"),
b267980d 1661 SvAMAGIC(right)?
a0d0e21e 1662 HvNAME(SvSTASH(SvRV(right))):
46fc3d4c 1663 ""));
a0d0e21e 1664 if (amtp && amtp->fallback >= AMGfallYES) {
cea2e8a9 1665 DEBUG_o( Perl_deb(aTHX_ "%s", SvPVX(msg)) );
a0d0e21e 1666 } else {
894356b3 1667 Perl_croak(aTHX_ "%"SVf, msg);
a0d0e21e
LW
1668 }
1669 return NULL;
1670 }
ee239bfe 1671 force_cpy = force_cpy || assign;
a0d0e21e
LW
1672 }
1673 }
497b47a8 1674#ifdef DEBUGGING
a0d0e21e 1675 if (!notfound) {
497b47a8
JH
1676 DEBUG_o(Perl_deb(aTHX_
1677 "Overloaded operator `%s'%s%s%s:\n\tmethod%s found%s in package %s%s\n",
1678 AMG_id2name(off),
1679 method+assignshift==off? "" :
1680 " (initially `",
1681 method+assignshift==off? "" :
1682 AMG_id2name(method+assignshift),
1683 method+assignshift==off? "" : "')",
1684 flags & AMGf_unary? "" :
1685 lr==1 ? " for right argument": " for left argument",
1686 flags & AMGf_unary? " for argument" : "",
25716404 1687 stash ? HvNAME(stash) : "null",
497b47a8 1688 fl? ",\n\tassignment variant used": "") );
ee239bfe 1689 }
497b47a8 1690#endif
748a9306
LW
1691 /* Since we use shallow copy during assignment, we need
1692 * to dublicate the contents, probably calling user-supplied
1693 * version of copy operator
1694 */
ee239bfe
IZ
1695 /* We need to copy in following cases:
1696 * a) Assignment form was called.
1697 * assignshift==1, assign==T, method + 1 == off
1698 * b) Increment or decrement, called directly.
1699 * assignshift==0, assign==0, method + 0 == off
1700 * c) Increment or decrement, translated to assignment add/subtr.
b267980d 1701 * assignshift==0, assign==T,
ee239bfe
IZ
1702 * force_cpy == T
1703 * d) Increment or decrement, translated to nomethod.
b267980d 1704 * assignshift==0, assign==0,
ee239bfe
IZ
1705 * force_cpy == T
1706 * e) Assignment form translated to nomethod.
1707 * assignshift==1, assign==T, method + 1 != off
1708 * force_cpy == T
1709 */
1710 /* off is method, method+assignshift, or a result of opcode substitution.
1711 * In the latter case assignshift==0, so only notfound case is important.
1712 */
1713 if (( (method + assignshift == off)
1714 && (assign || (method == inc_amg) || (method == dec_amg)))
1715 || force_cpy)
1716 RvDEEPCP(left);
a0d0e21e
LW
1717 {
1718 dSP;
1719 BINOP myop;
1720 SV* res;
54310121 1721 bool oldcatch = CATCH_GET;
a0d0e21e 1722
54310121 1723 CATCH_SET(TRUE);
a0d0e21e
LW
1724 Zero(&myop, 1, BINOP);
1725 myop.op_last = (OP *) &myop;
1726 myop.op_next = Nullop;
54310121 1727 myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
a0d0e21e 1728
e788e7d3 1729 PUSHSTACKi(PERLSI_OVERLOAD);
a0d0e21e 1730 ENTER;
462e5cf6 1731 SAVEOP();
533c011a 1732 PL_op = (OP *) &myop;
3280af22 1733 if (PERLDB_SUB && PL_curstash != PL_debstash)
533c011a 1734 PL_op->op_private |= OPpENTERSUB_DB;
a0d0e21e 1735 PUTBACK;
cea2e8a9 1736 pp_pushmark();
a0d0e21e 1737
924508f0 1738 EXTEND(SP, notfound + 5);
a0d0e21e
LW
1739 PUSHs(lr>0? right: left);
1740 PUSHs(lr>0? left: right);
3280af22 1741 PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no ));
a0d0e21e 1742 if (notfound) {
89ffc314 1743 PUSHs( sv_2mortal(newSVpv(AMG_id2name(method + assignshift),0)));
a0d0e21e
LW
1744 }
1745 PUSHs((SV*)cv);
1746 PUTBACK;
1747
155aba94 1748 if ((PL_op = Perl_pp_entersub(aTHX)))
cea2e8a9 1749 CALLRUNOPS(aTHX);
a0d0e21e
LW
1750 LEAVE;
1751 SPAGAIN;
1752
1753 res=POPs;
ebafeae7 1754 PUTBACK;
d3acc0f7 1755 POPSTACK;
54310121 1756 CATCH_SET(oldcatch);
a0d0e21e 1757
a0d0e21e 1758 if (postpr) {
9c5ffd7c 1759 int ans=0;
a0d0e21e
LW
1760 switch (method) {
1761 case le_amg:
1762 case sle_amg:
1763 ans=SvIV(res)<=0; break;
1764 case lt_amg:
1765 case slt_amg:
1766 ans=SvIV(res)<0; break;
1767 case ge_amg:
1768 case sge_amg:
1769 ans=SvIV(res)>=0; break;
1770 case gt_amg:
1771 case sgt_amg:
1772 ans=SvIV(res)>0; break;
1773 case eq_amg:
1774 case seq_amg:
1775 ans=SvIV(res)==0; break;
1776 case ne_amg:
1777 case sne_amg:
1778 ans=SvIV(res)!=0; break;
1779 case inc_amg:
1780 case dec_amg:
bbce6d69 1781 SvSetSV(left,res); return left;
dc437b57 1782 case not_amg:
fe7ac86a 1783 ans=!SvTRUE(res); break;
a0d0e21e 1784 }
54310121 1785 return boolSV(ans);
748a9306
LW
1786 } else if (method==copy_amg) {
1787 if (!SvROK(res)) {
cea2e8a9 1788 Perl_croak(aTHX_ "Copy method did not return a reference");
748a9306
LW
1789 }
1790 return SvREFCNT_inc(SvRV(res));
a0d0e21e
LW
1791 } else {
1792 return res;
1793 }
1794 }
1795}
c9d5ac95
GS
1796
1797/*
1798=for apidoc is_gv_magical
1799
1800Returns C<TRUE> if given the name of a magical GV.
1801
1802Currently only useful internally when determining if a GV should be
1803created even in rvalue contexts.
1804
1805C<flags> is not used at present but available for future extension to
1806allow selecting particular classes of magical variable.
1807
1808=cut
1809*/
1810bool
1811Perl_is_gv_magical(pTHX_ char *name, STRLEN len, U32 flags)
1812{
1813 if (!len)
1814 return FALSE;
1815
1816 switch (*name) {
1817 case 'I':
1818 if (len == 3 && strEQ(name, "ISA"))
1819 goto yes;
1820 break;
1821 case 'O':
1822 if (len == 8 && strEQ(name, "OVERLOAD"))
1823 goto yes;
1824 break;
1825 case 'S':
1826 if (len == 3 && strEQ(name, "SIG"))
1827 goto yes;
1828 break;
ac27b0f5
NIS
1829 case '\017': /* $^O & $^OPEN */
1830 if (len == 1
563aca73 1831 || (len == 4 && strEQ(name, "\017PEN")))
ac27b0f5
NIS
1832 {
1833 goto yes;
1834 }
1835 break;
fde18df1 1836 case '\025':
a05d7ebb 1837 if (len > 1 && strEQ(name, "\025NICODE"))
fde18df1 1838 goto yes;
c9d5ac95
GS
1839 case '\027': /* $^W & $^WARNING_BITS */
1840 if (len == 1
1841 || (len == 12 && strEQ(name, "\027ARNING_BITS"))
fde18df1 1842 )
c9d5ac95
GS
1843 {
1844 goto yes;
1845 }
1846 break;
1847
1848 case '&':
1849 case '`':
1850 case '\'':
1851 case ':':
1852 case '?':
1853 case '!':
1854 case '-':
1855 case '#':
c9d5ac95
GS
1856 case '[':
1857 case '^':
1858 case '~':
1859 case '=':
1860 case '%':
1861 case '.':
1862 case '(':
1863 case ')':
1864 case '<':
1865 case '>':
1866 case ',':
1867 case '\\':
1868 case '/':
1869 case '|':
1870 case '+':
1871 case ';':
1872 case ']':
1873 case '\001': /* $^A */
1874 case '\003': /* $^C */
1875 case '\004': /* $^D */
1876 case '\005': /* $^E */
1877 case '\006': /* $^F */
1878 case '\010': /* $^H */
1879 case '\011': /* $^I, NOT \t in EBCDIC */
1880 case '\014': /* $^L */
a01268b5 1881 case '\016': /* $^N */
c9d5ac95
GS
1882 case '\020': /* $^P */
1883 case '\023': /* $^S */
c9d5ac95
GS
1884 case '\026': /* $^V */
1885 if (len == 1)
1886 goto yes;
1887 break;
eb27b65e
AMS
1888 case '\024': /* $^T, ${^TAINT} */
1889 if (len == 1 || strEQ(name, "\024AINT"))
1890 goto yes;
1891 break;
c9d5ac95
GS
1892 case '1':
1893 case '2':
1894 case '3':
1895 case '4':
1896 case '5':
1897 case '6':
1898 case '7':
1899 case '8':
1900 case '9':
1901 if (len > 1) {
1902 char *end = name + len;
1903 while (--end > name) {
1904 if (!isDIGIT(*end))
1905 return FALSE;
1906 }
1907 }
1908 yes:
1909 return TRUE;
1910 default:
1911 break;
1912 }
1913 return FALSE;
1914}