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