This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
memcpy has n o in it, as pinted ut by Sarathy.
[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)
78 hv_magic(GvHVn(gv_AVadd(gv)), gv, 'L');
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) {
702887b4 375 if (strEQ(name,"import"))
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);
ea0efc06 738 hv_magic(hv, gv, '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);
752 hv_magic(hv, gv, 'S');
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);
822 }
823 goto magicalize;
93a17b20 824 case '#':
a0d0e21e 825 case '*':
599cee73 826 if (ckWARN(WARN_DEPRECATED) && len == 1 && sv_type == SVt_PV)
cea2e8a9 827 Perl_warner(aTHX_ WARN_DEPRECATED, "Use of $%s is deprecated", name);
a0d0e21e
LW
828 /* FALL THROUGH */
829 case '[':
93a17b20
LW
830 case '^':
831 case '~':
832 case '=':
93a17b20
LW
833 case '%':
834 case '.':
93a17b20
LW
835 case '(':
836 case ')':
837 case '<':
838 case '>':
839 case ',':
840 case '\\':
841 case '/':
93a17b20 842 case '|':
16070b82
GS
843 case '\001': /* $^A */
844 case '\003': /* $^C */
845 case '\004': /* $^D */
846 case '\005': /* $^E */
847 case '\006': /* $^F */
848 case '\010': /* $^H */
849 case '\011': /* $^I, NOT \t in EBCDIC */
850 case '\017': /* $^O */
851 case '\020': /* $^P */
852 case '\024': /* $^T */
463ee0b2
LW
853 if (len > 1)
854 break;
855 goto magicalize;
16070b82 856 case '\023': /* $^S */
6cef1e77
IZ
857 if (len > 1)
858 break;
859 goto ro_magicalize;
6a818117 860 case '\027': /* $^W & $^WARNING_BITS */
a50e31ad
GS
861 if (len > 1 && strNE(name, "\027ARNING_BITS")
862 && strNE(name, "\027IDE_SYSTEM_CALLS"))
4438c4b7
JH
863 break;
864 goto magicalize;
463ee0b2 865
a0d0e21e 866 case '+':
6cef1e77
IZ
867 if (len > 1)
868 break;
869 else {
870 AV* av = GvAVn(gv);
871 sv_magic((SV*)av, (SV*)av, 'D', Nullch, 0);
872 }
873 /* FALL THROUGH */
463ee0b2
LW
874 case '1':
875 case '2':
876 case '3':
877 case '4':
878 case '5':
879 case '6':
880 case '7':
881 case '8':
882 case '9':
a0d0e21e
LW
883 ro_magicalize:
884 SvREADONLY_on(GvSV(gv));
93a17b20 885 magicalize:
463ee0b2 886 sv_magic(GvSV(gv), (SV*)gv, 0, name, len);
93a17b20
LW
887 break;
888
16070b82 889 case '\014': /* $^L */
463ee0b2
LW
890 if (len > 1)
891 break;
93a17b20 892 sv_setpv(GvSV(gv),"\f");
3280af22 893 PL_formfeed = GvSV(gv);
93a17b20
LW
894 break;
895 case ';':
463ee0b2
LW
896 if (len > 1)
897 break;
93a17b20
LW
898 sv_setpv(GvSV(gv),"\034");
899 break;
463ee0b2
LW
900 case ']':
901 if (len == 1) {
f86702cc 902 SV *sv = GvSV(gv);
5089c844
GS
903 (void)SvUPGRADE(sv, SVt_PVNV);
904 SvNVX(sv) = SvNVX(PL_patchlevel);
905 SvNOK_on(sv);
906 (void)SvPV_nolen(sv);
907 SvREADONLY_on(sv);
93a17b20
LW
908 }
909 break;
16070b82
GS
910 case '\026': /* $^V */
911 if (len == 1) {
912 SV *sv = GvSV(gv);
913 GvSV(gv) = SvREFCNT_inc(PL_patchlevel);
914 SvREFCNT_dec(sv);
915 }
916 break;
79072805 917 }
93a17b20 918 return gv;
79072805
LW
919}
920
921void
864dbfa3 922Perl_gv_fullname3(pTHX_ SV *sv, GV *gv, const char *prefix)
79072805
LW
923{
924 HV *hv = GvSTASH(gv);
f967eb5f 925 if (!hv) {
155aba94 926 (void)SvOK_off(sv);
79072805 927 return;
f967eb5f
PP
928 }
929 sv_setpv(sv, prefix ? prefix : "");
79072805 930 sv_catpv(sv,HvNAME(hv));
463ee0b2 931 sv_catpvn(sv,"::", 2);
79072805
LW
932 sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv));
933}
934
935void
864dbfa3 936Perl_gv_efullname3(pTHX_ SV *sv, GV *gv, const char *prefix)
79072805 937{
f967eb5f 938 GV *egv = GvEGV(gv);
748a9306
LW
939 if (!egv)
940 egv = gv;
f6aff53a
PP
941 gv_fullname3(sv, egv, prefix);
942}
943
944/* XXX compatibility with versions <= 5.003. */
945void
864dbfa3 946Perl_gv_fullname(pTHX_ SV *sv, GV *gv)
f6aff53a
PP
947{
948 gv_fullname3(sv, gv, sv == (SV*)gv ? "*" : "");
949}
950
951/* XXX compatibility with versions <= 5.003. */
952void
864dbfa3 953Perl_gv_efullname(pTHX_ SV *sv, GV *gv)
f6aff53a
PP
954{
955 gv_efullname3(sv, gv, sv == (SV*)gv ? "*" : "");
79072805
LW
956}
957
958IO *
864dbfa3 959Perl_newIO(pTHX)
79072805 960{
11343788 961 dTHR;
79072805 962 IO *io;
8990e307
LW
963 GV *iogv;
964
965 io = (IO*)NEWSV(0,0);
a0d0e21e 966 sv_upgrade((SV *)io,SVt_PVIO);
8990e307
LW
967 SvREFCNT(io) = 1;
968 SvOBJECT_on(io);
c9de509e 969 iogv = gv_fetchpv("FileHandle::", FALSE, SVt_PVHV);
5f2d631d
GS
970 /* unless exists($main::{FileHandle}) and defined(%main::FileHandle::) */
971 if (!(iogv && GvHV(iogv) && HvARRAY(GvHV(iogv))))
c9de509e 972 iogv = gv_fetchpv("IO::Handle::", TRUE, SVt_PVHV);
8990e307 973 SvSTASH(io) = (HV*)SvREFCNT_inc(GvHV(iogv));
79072805
LW
974 return io;
975}
976
977void
864dbfa3 978Perl_gv_check(pTHX_ HV *stash)
79072805 979{
11343788 980 dTHR;
79072805
LW
981 register HE *entry;
982 register I32 i;
983 register GV *gv;
463ee0b2
LW
984 HV *hv;
985
8990e307
LW
986 if (!HvARRAY(stash))
987 return;
a0d0e21e 988 for (i = 0; i <= (I32) HvMAX(stash); i++) {
dc437b57
PP
989 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
990 if (HeKEY(entry)[HeKLEN(entry)-1] == ':' &&
991 (gv = (GV*)HeVAL(entry)) && (hv = GvHV(gv)) && HvNAME(hv))
a0d0e21e 992 {
19b6c847 993 if (hv != PL_defstash && hv != stash)
a0d0e21e
LW
994 gv_check(hv); /* nested package */
995 }
dc437b57 996 else if (isALPHA(*HeKEY(entry))) {
1d7c1841 997 char *file;
dc437b57 998 gv = (GV*)HeVAL(entry);
55d729e4 999 if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv))
463ee0b2 1000 continue;
1d7c1841
GS
1001 file = GvFILE(gv);
1002 /* performance hack: if filename is absolute and it's a standard
1003 * module, don't bother warning */
1004 if (file
1005 && PERL_FILE_IS_ABSOLUTE(file)
1006 && (instr(file, "/lib/") || instr(file, ".pm")))
1007 {
8990e307 1008 continue;
1d7c1841
GS
1009 }
1010 CopLINE_set(PL_curcop, GvLINE(gv));
1011#ifdef USE_ITHREADS
1012 CopFILE(PL_curcop) = file; /* set for warning */
1013#else
1014 CopFILEGV(PL_curcop) = gv_fetchfile(file);
1015#endif
cea2e8a9 1016 Perl_warner(aTHX_ WARN_ONCE,
599cee73 1017 "Name \"%s::%s\" used only once: possible typo",
a0d0e21e 1018 HvNAME(stash), GvNAME(gv));
463ee0b2 1019 }
79072805
LW
1020 }
1021 }
1022}
1023
1024GV *
864dbfa3 1025Perl_newGVgen(pTHX_ char *pack)
79072805 1026{
cea2e8a9 1027 return gv_fetchpv(Perl_form(aTHX_ "%s::_GEN_%ld", pack, (long)PL_gensym++),
46fc3d4c 1028 TRUE, SVt_PVGV);
79072805
LW
1029}
1030
1031/* hopefully this is only called on local symbol table entries */
1032
1033GP*
864dbfa3 1034Perl_gp_ref(pTHX_ GP *gp)
79072805 1035{
1d7c1841
GS
1036 if (!gp)
1037 return (GP*)NULL;
79072805 1038 gp->gp_refcnt++;
44a8e56a
PP
1039 if (gp->gp_cv) {
1040 if (gp->gp_cvgen) {
1041 /* multi-named GPs cannot be used for method cache */
1042 SvREFCNT_dec(gp->gp_cv);
1043 gp->gp_cv = Nullcv;
1044 gp->gp_cvgen = 0;
1045 }
1046 else {
1047 /* Adding a new name to a subroutine invalidates method cache */
3280af22 1048 PL_sub_generation++;
44a8e56a
PP
1049 }
1050 }
79072805 1051 return gp;
79072805
LW
1052}
1053
1054void
864dbfa3 1055Perl_gp_free(pTHX_ GV *gv)
79072805 1056{
f248d071 1057 dTHR;
79072805
LW
1058 GP* gp;
1059
1060 if (!gv || !(gp = GvGP(gv)))
1061 return;
f248d071
GS
1062 if (gp->gp_refcnt == 0) {
1063 if (ckWARN_d(WARN_INTERNAL))
1064 Perl_warner(aTHX_ WARN_INTERNAL,
1065 "Attempt to free unreferenced glob pointers");
79072805
LW
1066 return;
1067 }
44a8e56a
PP
1068 if (gp->gp_cv) {
1069 /* Deleting the name of a subroutine invalidates method cache */
3280af22 1070 PL_sub_generation++;
44a8e56a 1071 }
748a9306
LW
1072 if (--gp->gp_refcnt > 0) {
1073 if (gp->gp_egv == gv)
1074 gp->gp_egv = 0;
79072805 1075 return;
748a9306 1076 }
79072805 1077
8990e307
LW
1078 SvREFCNT_dec(gp->gp_sv);
1079 SvREFCNT_dec(gp->gp_av);
1080 SvREFCNT_dec(gp->gp_hv);
377b8fbc 1081 SvREFCNT_dec(gp->gp_io);
a6006777 1082 SvREFCNT_dec(gp->gp_cv);
748a9306
LW
1083 SvREFCNT_dec(gp->gp_form);
1084
79072805
LW
1085 Safefree(gp);
1086 GvGP(gv) = 0;
1087}
1088
1089#if defined(CRIPPLED_CC) && (defined(iAPX286) || defined(M_I286) || defined(I80286))
1090#define MICROPORT
1091#endif
1092
1093#ifdef MICROPORT /* Microport 2.4 hack */
1094AV *GvAVn(gv)
1095register GV *gv;
1096{
1097 if (GvGP(gv)->gp_av)
1098 return GvGP(gv)->gp_av;
1099 else
1100 return GvGP(gv_AVadd(gv))->gp_av;
1101}
1102
1103HV *GvHVn(gv)
1104register GV *gv;
1105{
1106 if (GvGP(gv)->gp_hv)
1107 return GvGP(gv)->gp_hv;
1108 else
1109 return GvGP(gv_HVadd(gv))->gp_hv;
1110}
1111#endif /* Microport 2.4 hack */
a0d0e21e 1112
a0d0e21e
LW
1113/* Updates and caches the CV's */
1114
1115bool
864dbfa3 1116Perl_Gv_AMupdate(pTHX_ HV *stash)
a0d0e21e 1117{
155aba94 1118 dTHR;
a0d0e21e
LW
1119 GV* gv;
1120 CV* cv;
1121 MAGIC* mg=mg_find((SV*)stash,'c');
8ac85365 1122 AMT *amtp = (mg) ? (AMT*)mg->mg_ptr: (AMT *) NULL;
a6006777 1123 AMT amt;
2d8e6c8d 1124 STRLEN n_a;
155aba94
GS
1125#ifdef OVERLOAD_VIA_HASH
1126 GV** gvp;
1127 HV* hv;
1128#endif
a0d0e21e 1129
3280af22
NIS
1130 if (mg && amtp->was_ok_am == PL_amagic_generation
1131 && amtp->was_ok_sub == PL_sub_generation)
a6006777
PP
1132 return AMT_AMAGIC(amtp);
1133 if (amtp && AMT_AMAGIC(amtp)) { /* Have table. */
748a9306 1134 int i;
a6006777 1135 for (i=1; i<NofAMmeth; i++) {
748a9306
LW
1136 if (amtp->table[i]) {
1137 SvREFCNT_dec(amtp->table[i]);
1138 }
1139 }
1140 }
a0d0e21e
LW
1141 sv_unmagic((SV*)stash, 'c');
1142
cea2e8a9 1143 DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME(stash)) );
a0d0e21e 1144
3280af22
NIS
1145 amt.was_ok_am = PL_amagic_generation;
1146 amt.was_ok_sub = PL_sub_generation;
a6006777
PP
1147 amt.fallback = AMGfallNO;
1148 amt.flags = 0;
1149
1150#ifdef OVERLOAD_VIA_HASH
1151 gvp=(GV**)hv_fetch(stash,"OVERLOAD",8,FALSE); /* A shortcut */
3280af22 1152 if (gvp && ((gv = *gvp) != (GV*)&PL_sv_undef && (hv = GvHV(gv)))) {
a0d0e21e
LW
1153 int filled=0;
1154 int i;
1155 char *cp;
a0d0e21e
LW
1156 SV* sv;
1157 SV** svp;
a0d0e21e 1158
22c35a8c 1159 /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
a0d0e21e 1160
22c35a8c 1161 if (( cp = (char *)PL_AMG_names[0] ) &&
a6006777 1162 (svp = (SV**)hv_fetch(hv,cp,strlen(cp),FALSE)) && (sv = *svp)) {
a0d0e21e
LW
1163 if (SvTRUE(sv)) amt.fallback=AMGfallYES;
1164 else if (SvOK(sv)) amt.fallback=AMGfallNEVER;
1165 }
a6006777
PP
1166 for (i = 1; i < NofAMmeth; i++) {
1167 cv = 0;
22c35a8c 1168 cp = (char *)PL_AMG_names[i];
a6006777
PP
1169
1170 svp = (SV**)hv_fetch(hv, cp, strlen(cp), FALSE);
3280af22 1171 if (svp && ((sv = *svp) != &PL_sv_undef)) {
a0d0e21e
LW
1172 switch (SvTYPE(sv)) {
1173 default:
1174 if (!SvROK(sv)) {
1175 if (!SvOK(sv)) break;
2d8e6c8d 1176 gv = gv_fetchmethod(stash, SvPV(sv, n_a));
a0d0e21e
LW
1177 if (gv) cv = GvCV(gv);
1178 break;
1179 }
1180 cv = (CV*)SvRV(sv);
1181 if (SvTYPE(cv) == SVt_PVCV)
1182 break;
1183 /* FALL THROUGH */
1184 case SVt_PVHV:
1185 case SVt_PVAV:
cea2e8a9 1186 Perl_croak(aTHX_ "Not a subroutine reference in overload table");
a0d0e21e
LW
1187 return FALSE;
1188 case SVt_PVCV:
8ebc5c01
PP
1189 cv = (CV*)sv;
1190 break;
a0d0e21e 1191 case SVt_PVGV:
8ebc5c01 1192 if (!(cv = GvCVu((GV*)sv)))
f6ec51f7 1193 cv = sv_2cv(sv, &stash, &gv, FALSE);
8ebc5c01 1194 break;
a0d0e21e
LW
1195 }
1196 if (cv) filled=1;
1197 else {
cea2e8a9 1198 Perl_croak(aTHX_ "Method for operation %s not found in package %.256s during blessing\n",
a0d0e21e
LW
1199 cp,HvNAME(stash));
1200 return FALSE;
1201 }
1202 }
a6006777
PP
1203#else
1204 {
1205 int filled = 0;
1206 int i;
9607fc9c 1207 const char *cp;
a6006777 1208 SV* sv = NULL;
a6006777 1209
22c35a8c 1210 /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
a6006777 1211
155aba94 1212 if ((cp = PL_AMG_names[0])) {
a6006777 1213 /* Try to find via inheritance. */
774d564b 1214 gv = gv_fetchmeth(stash, "()", 2, -1); /* A cookie: "()". */
155aba94
GS
1215 if (gv)
1216 sv = GvSV(gv);
1217
1218 if (!gv)
1219 goto no_table;
1220 else if (SvTRUE(sv))
1221 amt.fallback=AMGfallYES;
1222 else if (SvOK(sv))
1223 amt.fallback=AMGfallNEVER;
a6006777
PP
1224 }
1225
1226 for (i = 1; i < NofAMmeth; i++) {
cea2e8a9
GS
1227 SV *cookie = sv_2mortal(Perl_newSVpvf(aTHX_ "(%s", cp = PL_AMG_names[i]));
1228 DEBUG_o( Perl_deb(aTHX_ "Checking overloading of `%s' in package `%.256s'\n",
44a8e56a 1229 cp, HvNAME(stash)) );
46fc3d4c
PP
1230 /* don't fill the cache while looking up! */
1231 gv = gv_fetchmeth(stash, SvPVX(cookie), SvCUR(cookie), -1);
1232 cv = 0;
44a8e56a 1233 if(gv && (cv = GvCV(gv))) {
44a8e56a
PP
1234 if (GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")
1235 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "overload")) {
1236 /* GvSV contains the name of the method. */
1237 GV *ngv;
1238
cea2e8a9 1239 DEBUG_o( Perl_deb(aTHX_ "Resolving method `%.256s' for overloaded `%s' in package `%.256s'\n",
2d8e6c8d 1240 SvPV(GvSV(gv), n_a), cp, HvNAME(stash)) );
dc848c6f
PP
1241 if (!SvPOK(GvSV(gv))
1242 || !(ngv = gv_fetchmethod_autoload(stash, SvPVX(GvSV(gv)),
1243 FALSE)))
1244 {
44a8e56a
PP
1245 /* Can be an import stub (created by `can'). */
1246 if (GvCVGEN(gv)) {
cea2e8a9 1247 Perl_croak(aTHX_ "Stub found while resolving method `%.256s' overloading `%s' in package `%.256s'",
44a8e56a
PP
1248 (SvPOK(GvSV(gv)) ? SvPVX(GvSV(gv)) : "???" ),
1249 cp, HvNAME(stash));
1250 } else
cea2e8a9 1251 Perl_croak(aTHX_ "Can't resolve method `%.256s' overloading `%s' in package `%.256s'",
44a8e56a
PP
1252 (SvPOK(GvSV(gv)) ? SvPVX(GvSV(gv)) : "???" ),
1253 cp, HvNAME(stash));
1254 }
dc848c6f 1255 cv = GvCV(gv = ngv);
44a8e56a 1256 }
cea2e8a9 1257 DEBUG_o( Perl_deb(aTHX_ "Overloading `%s' in package `%.256s' via `%.256s::%.256s' \n",
44a8e56a
PP
1258 cp, HvNAME(stash), HvNAME(GvSTASH(CvGV(cv))),
1259 GvNAME(CvGV(cv))) );
1260 filled = 1;
1261 }
a6006777
PP
1262#endif
1263 amt.table[i]=(CV*)SvREFCNT_inc(cv);
a0d0e21e 1264 }
a0d0e21e 1265 if (filled) {
a6006777
PP
1266 AMT_AMAGIC_on(&amt);
1267 sv_magic((SV*)stash, 0, 'c', (char*)&amt, sizeof(AMT));
a0d0e21e
LW
1268 return TRUE;
1269 }
1270 }
a6006777 1271 /* Here we have no table: */
774d564b 1272 no_table:
a6006777
PP
1273 AMT_AMAGIC_off(&amt);
1274 sv_magic((SV*)stash, 0, 'c', (char*)&amt, sizeof(AMTS));
a0d0e21e
LW
1275 return FALSE;
1276}
1277
a0d0e21e 1278SV*
864dbfa3 1279Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
a0d0e21e 1280{
11343788 1281 dTHR;
a0d0e21e
LW
1282 MAGIC *mg;
1283 CV *cv;
1284 CV **cvp=NULL, **ocvp=NULL;
1285 AMT *amtp, *oamtp;
1286 int fl=0, off, off1, lr=0, assign=AMGf_assign & flags, notfound=0;
ee239bfe 1287 int postpr = 0, force_cpy = 0, assignshift = assign ? 1 : 0;
a0d0e21e
LW
1288 HV* stash;
1289 if (!(AMGf_noleft & flags) && SvAMAGIC(left)
1290 && (mg = mg_find((SV*)(stash=SvSTASH(SvRV(left))),'c'))
a6006777
PP
1291 && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
1292 ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
8ac85365 1293 : (CV **) NULL))
748a9306
LW
1294 && ((cv = cvp[off=method+assignshift])
1295 || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
1296 * usual method */
1297 (fl = 1, cv = cvp[off=method])))) {
a0d0e21e
LW
1298 lr = -1; /* Call method for left argument */
1299 } else {
1300 if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) {
1301 int logic;
1302
1303 /* look for substituted methods */
ee239bfe 1304 /* In all the covered cases we should be called with assign==0. */
a0d0e21e
LW
1305 switch (method) {
1306 case inc_amg:
ee239bfe
IZ
1307 force_cpy = 1;
1308 if ((cv = cvp[off=add_ass_amg])
1309 || ((cv = cvp[off = add_amg]) && (force_cpy = 0, postpr = 1))) {
3280af22 1310 right = &PL_sv_yes; lr = -1; assign = 1;
a0d0e21e
LW
1311 }
1312 break;
1313 case dec_amg:
ee239bfe
IZ
1314 force_cpy = 1;
1315 if ((cv = cvp[off = subtr_ass_amg])
1316 || ((cv = cvp[off = subtr_amg]) && (force_cpy = 0, postpr=1))) {
3280af22 1317 right = &PL_sv_yes; lr = -1; assign = 1;
a0d0e21e
LW
1318 }
1319 break;
1320 case bool__amg:
1321 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg]));
1322 break;
1323 case numer_amg:
1324 (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg]));
1325 break;
1326 case string_amg:
1327 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg]));
1328 break;
dc437b57
PP
1329 case not_amg:
1330 (void)((cv = cvp[off=bool__amg])
1331 || (cv = cvp[off=numer_amg])
1332 || (cv = cvp[off=string_amg]));
1333 postpr = 1;
1334 break;
748a9306
LW
1335 case copy_amg:
1336 {
76e3520e
GS
1337 /*
1338 * SV* ref causes confusion with the interpreter variable of
1339 * the same name
1340 */
1341 SV* tmpRef=SvRV(left);
1342 if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) {
fc36a67e
PP
1343 /*
1344 * Just to be extra cautious. Maybe in some
1345 * additional cases sv_setsv is safe, too.
1346 */
76e3520e 1347 SV* newref = newSVsv(tmpRef);
748a9306 1348 SvOBJECT_on(newref);
76e3520e 1349 SvSTASH(newref) = (HV*)SvREFCNT_inc(SvSTASH(tmpRef));
748a9306
LW
1350 return newref;
1351 }
1352 }
1353 break;
a0d0e21e 1354 case abs_amg:
748a9306 1355 if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg])
a0d0e21e 1356 && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) {
748a9306 1357 SV* nullsv=sv_2mortal(newSViv(0));
a0d0e21e 1358 if (off1==lt_amg) {
748a9306 1359 SV* lessp = amagic_call(left,nullsv,
a0d0e21e
LW
1360 lt_amg,AMGf_noright);
1361 logic = SvTRUE(lessp);
1362 } else {
748a9306 1363 SV* lessp = amagic_call(left,nullsv,
a0d0e21e
LW
1364 ncmp_amg,AMGf_noright);
1365 logic = (SvNV(lessp) < 0);
1366 }
1367 if (logic) {
1368 if (off==subtr_amg) {
1369 right = left;
748a9306 1370 left = nullsv;
a0d0e21e
LW
1371 lr = 1;
1372 }
1373 } else {
1374 return left;
1375 }
1376 }
1377 break;
1378 case neg_amg:
155aba94 1379 if ((cv = cvp[off=subtr_amg])) {
a0d0e21e
LW
1380 right = left;
1381 left = sv_2mortal(newSViv(0));
1382 lr = 1;
1383 }
1384 break;
f5284f61
IZ
1385 case iter_amg: /* XXXX Eventually should do to_gv. */
1386 case to_sv_amg:
1387 case to_av_amg:
1388 case to_hv_amg:
1389 case to_gv_amg:
1390 case to_cv_amg:
1391 /* FAIL safe */
1392 return NULL; /* Delegate operation to standard mechanisms. */
1393 break;
a0d0e21e
LW
1394 default:
1395 goto not_found;
1396 }
1397 if (!cv) goto not_found;
1398 } else if (!(AMGf_noright & flags) && SvAMAGIC(right)
1399 && (mg = mg_find((SV*)(stash=SvSTASH(SvRV(right))),'c'))
a6006777
PP
1400 && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
1401 ? (amtp = (AMT*)mg->mg_ptr)->table
8ac85365 1402 : (CV **) NULL))
a0d0e21e
LW
1403 && (cv = cvp[off=method])) { /* Method for right
1404 * argument found */
1405 lr=1;
748a9306 1406 } else if (((ocvp && oamtp->fallback > AMGfallNEVER
4633a7c4 1407 && (cvp=ocvp) && (lr = -1))
a0d0e21e
LW
1408 || (cvp && amtp->fallback > AMGfallNEVER && (lr=1)))
1409 && !(flags & AMGf_unary)) {
1410 /* We look for substitution for
1411 * comparison operations and
fc36a67e 1412 * concatenation */
a0d0e21e
LW
1413 if (method==concat_amg || method==concat_ass_amg
1414 || method==repeat_amg || method==repeat_ass_amg) {
1415 return NULL; /* Delegate operation to string conversion */
1416 }
1417 off = -1;
1418 switch (method) {
1419 case lt_amg:
1420 case le_amg:
1421 case gt_amg:
1422 case ge_amg:
1423 case eq_amg:
1424 case ne_amg:
1425 postpr = 1; off=ncmp_amg; break;
1426 case slt_amg:
1427 case sle_amg:
1428 case sgt_amg:
1429 case sge_amg:
1430 case seq_amg:
1431 case sne_amg:
1432 postpr = 1; off=scmp_amg; break;
1433 }
1434 if (off != -1) cv = cvp[off];
1435 if (!cv) {
1436 goto not_found;
1437 }
1438 } else {
a6006777 1439 not_found: /* No method found, either report or croak */
a0d0e21e
LW
1440 if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */
1441 notfound = 1; lr = -1;
1442 } else if (cvp && (cv=cvp[nomethod_amg])) {
1443 notfound = 1; lr = 1;
1444 } else {
46fc3d4c 1445 SV *msg;
774d564b 1446 if (off==-1) off=method;
cea2e8a9 1447 msg = sv_2mortal(Perl_newSVpvf(aTHX_
46fc3d4c 1448 "Operation `%s': no method found,%sargument %s%s%s%s",
22c35a8c 1449 PL_AMG_names[method + assignshift],
e7ea3e70 1450 (flags & AMGf_unary ? " " : "\n\tleft "),
a0d0e21e
LW
1451 SvAMAGIC(left)?
1452 "in overloaded package ":
1453 "has no overloaded magic",
1454 SvAMAGIC(left)?
1455 HvNAME(SvSTASH(SvRV(left))):
1456 "",
1457 SvAMAGIC(right)?
e7ea3e70
IZ
1458 ",\n\tright argument in overloaded package ":
1459 (flags & AMGf_unary
1460 ? ""
1461 : ",\n\tright argument has no overloaded magic"),
a0d0e21e
LW
1462 SvAMAGIC(right)?
1463 HvNAME(SvSTASH(SvRV(right))):
46fc3d4c 1464 ""));
a0d0e21e 1465 if (amtp && amtp->fallback >= AMGfallYES) {
cea2e8a9 1466 DEBUG_o( Perl_deb(aTHX_ "%s", SvPVX(msg)) );
a0d0e21e 1467 } else {
894356b3 1468 Perl_croak(aTHX_ "%"SVf, msg);
a0d0e21e
LW
1469 }
1470 return NULL;
1471 }
ee239bfe 1472 force_cpy = force_cpy || assign;
a0d0e21e
LW
1473 }
1474 }
1475 if (!notfound) {
cea2e8a9 1476 DEBUG_o( Perl_deb(aTHX_
46fc3d4c 1477 "Overloaded operator `%s'%s%s%s:\n\tmethod%s found%s in package %s%s\n",
22c35a8c 1478 PL_AMG_names[off],
748a9306
LW
1479 method+assignshift==off? "" :
1480 " (initially `",
1481 method+assignshift==off? "" :
22c35a8c 1482 PL_AMG_names[method+assignshift],
748a9306
LW
1483 method+assignshift==off? "" : "')",
1484 flags & AMGf_unary? "" :
1485 lr==1 ? " for right argument": " for left argument",
1486 flags & AMGf_unary? " for argument" : "",
a0d0e21e
LW
1487 HvNAME(stash),
1488 fl? ",\n\tassignment variant used": "") );
ee239bfe 1489 }
748a9306
LW
1490 /* Since we use shallow copy during assignment, we need
1491 * to dublicate the contents, probably calling user-supplied
1492 * version of copy operator
1493 */
ee239bfe
IZ
1494 /* We need to copy in following cases:
1495 * a) Assignment form was called.
1496 * assignshift==1, assign==T, method + 1 == off
1497 * b) Increment or decrement, called directly.
1498 * assignshift==0, assign==0, method + 0 == off
1499 * c) Increment or decrement, translated to assignment add/subtr.
1500 * assignshift==0, assign==T,
1501 * force_cpy == T
1502 * d) Increment or decrement, translated to nomethod.
1503 * assignshift==0, assign==0,
1504 * force_cpy == T
1505 * e) Assignment form translated to nomethod.
1506 * assignshift==1, assign==T, method + 1 != off
1507 * force_cpy == T
1508 */
1509 /* off is method, method+assignshift, or a result of opcode substitution.
1510 * In the latter case assignshift==0, so only notfound case is important.
1511 */
1512 if (( (method + assignshift == off)
1513 && (assign || (method == inc_amg) || (method == dec_amg)))
1514 || force_cpy)
1515 RvDEEPCP(left);
a0d0e21e
LW
1516 {
1517 dSP;
1518 BINOP myop;
1519 SV* res;
54310121 1520 bool oldcatch = CATCH_GET;
a0d0e21e 1521
54310121 1522 CATCH_SET(TRUE);
a0d0e21e
LW
1523 Zero(&myop, 1, BINOP);
1524 myop.op_last = (OP *) &myop;
1525 myop.op_next = Nullop;
54310121 1526 myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
a0d0e21e 1527
e788e7d3 1528 PUSHSTACKi(PERLSI_OVERLOAD);
a0d0e21e 1529 ENTER;
462e5cf6 1530 SAVEOP();
533c011a 1531 PL_op = (OP *) &myop;
3280af22 1532 if (PERLDB_SUB && PL_curstash != PL_debstash)
533c011a 1533 PL_op->op_private |= OPpENTERSUB_DB;
a0d0e21e 1534 PUTBACK;
cea2e8a9 1535 pp_pushmark();
a0d0e21e 1536
924508f0 1537 EXTEND(SP, notfound + 5);
a0d0e21e
LW
1538 PUSHs(lr>0? right: left);
1539 PUSHs(lr>0? left: right);
3280af22 1540 PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no ));
a0d0e21e 1541 if (notfound) {
22c35a8c 1542 PUSHs( sv_2mortal(newSVpv((char *)PL_AMG_names[method + assignshift],0)));
a0d0e21e
LW
1543 }
1544 PUSHs((SV*)cv);
1545 PUTBACK;
1546
155aba94 1547 if ((PL_op = Perl_pp_entersub(aTHX)))
cea2e8a9 1548 CALLRUNOPS(aTHX);
a0d0e21e
LW
1549 LEAVE;
1550 SPAGAIN;
1551
1552 res=POPs;
ebafeae7 1553 PUTBACK;
d3acc0f7 1554 POPSTACK;
54310121 1555 CATCH_SET(oldcatch);
a0d0e21e 1556
a0d0e21e
LW
1557 if (postpr) {
1558 int ans;
1559 switch (method) {
1560 case le_amg:
1561 case sle_amg:
1562 ans=SvIV(res)<=0; break;
1563 case lt_amg:
1564 case slt_amg:
1565 ans=SvIV(res)<0; break;
1566 case ge_amg:
1567 case sge_amg:
1568 ans=SvIV(res)>=0; break;
1569 case gt_amg:
1570 case sgt_amg:
1571 ans=SvIV(res)>0; break;
1572 case eq_amg:
1573 case seq_amg:
1574 ans=SvIV(res)==0; break;
1575 case ne_amg:
1576 case sne_amg:
1577 ans=SvIV(res)!=0; break;
1578 case inc_amg:
1579 case dec_amg:
bbce6d69 1580 SvSetSV(left,res); return left;
dc437b57 1581 case not_amg:
fe7ac86a 1582 ans=!SvTRUE(res); break;
a0d0e21e 1583 }
54310121 1584 return boolSV(ans);
748a9306
LW
1585 } else if (method==copy_amg) {
1586 if (!SvROK(res)) {
cea2e8a9 1587 Perl_croak(aTHX_ "Copy method did not return a reference");
748a9306
LW
1588 }
1589 return SvREFCNT_inc(SvRV(res));
a0d0e21e
LW
1590 } else {
1591 return res;
1592 }
1593 }
1594}
c9d5ac95
GS
1595
1596/*
1597=for apidoc is_gv_magical
1598
1599Returns C<TRUE> if given the name of a magical GV.
1600
1601Currently only useful internally when determining if a GV should be
1602created even in rvalue contexts.
1603
1604C<flags> is not used at present but available for future extension to
1605allow selecting particular classes of magical variable.
1606
1607=cut
1608*/
1609bool
1610Perl_is_gv_magical(pTHX_ char *name, STRLEN len, U32 flags)
1611{
1612 if (!len)
1613 return FALSE;
1614
1615 switch (*name) {
1616 case 'I':
1617 if (len == 3 && strEQ(name, "ISA"))
1618 goto yes;
1619 break;
1620 case 'O':
1621 if (len == 8 && strEQ(name, "OVERLOAD"))
1622 goto yes;
1623 break;
1624 case 'S':
1625 if (len == 3 && strEQ(name, "SIG"))
1626 goto yes;
1627 break;
1628 case '\027': /* $^W & $^WARNING_BITS */
1629 if (len == 1
1630 || (len == 12 && strEQ(name, "\027ARNING_BITS"))
1631 || (len == 17 && strEQ(name, "\027IDE_SYSTEM_CALLS")))
1632 {
1633 goto yes;
1634 }
1635 break;
1636
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 '<':
1655 case '>':
1656 case ',':
1657 case '\\':
1658 case '/':
1659 case '|':
1660 case '+':
1661 case ';':
1662 case ']':
1663 case '\001': /* $^A */
1664 case '\003': /* $^C */
1665 case '\004': /* $^D */
1666 case '\005': /* $^E */
1667 case '\006': /* $^F */
1668 case '\010': /* $^H */
1669 case '\011': /* $^I, NOT \t in EBCDIC */
1670 case '\014': /* $^L */
1671 case '\017': /* $^O */
1672 case '\020': /* $^P */
1673 case '\023': /* $^S */
1674 case '\024': /* $^T */
1675 case '\026': /* $^V */
1676 if (len == 1)
1677 goto yes;
1678 break;
1679 case '1':
1680 case '2':
1681 case '3':
1682 case '4':
1683 case '5':
1684 case '6':
1685 case '7':
1686 case '8':
1687 case '9':
1688 if (len > 1) {
1689 char *end = name + len;
1690 while (--end > name) {
1691 if (!isDIGIT(*end))
1692 return FALSE;
1693 }
1694 }
1695 yes:
1696 return TRUE;
1697 default:
1698 break;
1699 }
1700 return FALSE;
1701}