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