This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
New HW model; more on threads for 10.20
[perl5.git] / gv.c
1 /*    gv.c
2  *
3  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4  *    2000, 2001, 2002, 2003, 2004, 2005, by Larry Wall and others
5  *
6  *    You may distribute under the terms of either the GNU General Public
7  *    License or the Artistic License, as specified in the README file.
8  *
9  */
10
11 /*
12  *   'Mercy!' cried Gandalf.  'If the giving of information is to be the cure
13  * of your inquisitiveness, I shall spend all the rest of my days answering
14  * you.  What more do you want to know?'
15  *   'The names of all the stars, and of all living things, and the whole
16  * history of Middle-earth and Over-heaven and of the Sundering Seas,'
17  * laughed Pippin.
18  */
19
20 /*
21 =head1 GV Functions
22
23 A GV is a structure which corresponds to to a Perl typeglob, ie *foo.
24 It is a structure that holds a pointer to a scalar, an array, a hash etc,
25 corresponding to $foo, @foo, %foo.
26
27 GVs are usually found as values in stashes (symbol table hashes) where
28 Perl stores its global variables.
29
30 =cut
31 */
32
33 #include "EXTERN.h"
34 #define PERL_IN_GV_C
35 #include "perl.h"
36
37 static const char S_autoload[] = "AUTOLOAD";
38 static const STRLEN S_autolen = sizeof(S_autoload)-1;
39
40 GV *
41 Perl_gv_AVadd(pTHX_ register GV *gv)
42 {
43     if (!gv || SvTYPE((SV*)gv) != SVt_PVGV)
44         Perl_croak(aTHX_ "Bad symbol for array");
45     if (!GvAV(gv))
46         GvAV(gv) = newAV();
47     return gv;
48 }
49
50 GV *
51 Perl_gv_HVadd(pTHX_ register GV *gv)
52 {
53     if (!gv || SvTYPE((SV*)gv) != SVt_PVGV)
54         Perl_croak(aTHX_ "Bad symbol for hash");
55     if (!GvHV(gv))
56         GvHV(gv) = newHV();
57     return gv;
58 }
59
60 GV *
61 Perl_gv_IOadd(pTHX_ register GV *gv)
62 {
63     if (!gv || SvTYPE((SV*)gv) != SVt_PVGV)
64         Perl_croak(aTHX_ "Bad symbol for filehandle");
65     if (!GvIOp(gv)) {
66 #ifdef GV_UNIQUE_CHECK
67         if (GvUNIQUE(gv)) {
68             Perl_croak(aTHX_ "Bad symbol for filehandle (GV is unique)");
69         }
70 #endif
71         GvIOp(gv) = newIO();
72     }
73     return gv;
74 }
75
76 GV *
77 Perl_gv_fetchfile(pTHX_ const char *name)
78 {
79     char smallbuf[256];
80     char *tmpbuf;
81     STRLEN tmplen;
82     GV *gv;
83
84     if (!PL_defstash)
85         return Nullgv;
86
87     tmplen = strlen(name) + 2;
88     if (tmplen < sizeof smallbuf)
89         tmpbuf = smallbuf;
90     else
91         New(603, tmpbuf, tmplen + 1, char);
92     /* This is where the debugger's %{"::_<$filename"} hash is created */
93     tmpbuf[0] = '_';
94     tmpbuf[1] = '<';
95     strcpy(tmpbuf + 2, name);
96     gv = *(GV**)hv_fetch(PL_defstash, tmpbuf, tmplen, TRUE);
97     if (!isGV(gv)) {
98         gv_init(gv, PL_defstash, tmpbuf, tmplen, FALSE);
99         sv_setpv(GvSV(gv), name);
100         if (PERLDB_LINE)
101             hv_magic(GvHVn(gv_AVadd(gv)), Nullgv, PERL_MAGIC_dbfile);
102     }
103     if (tmpbuf != smallbuf)
104         Safefree(tmpbuf);
105     return gv;
106 }
107
108 void
109 Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi)
110 {
111     dVAR;
112     register GP *gp;
113     const bool doproto = SvTYPE(gv) > SVt_NULL;
114     const char * const proto = (doproto && SvPOK(gv)) ? SvPVX_const(gv) : NULL;
115
116     sv_upgrade((SV*)gv, SVt_PVGV);
117     if (SvLEN(gv)) {
118         if (proto) {
119             SvPV_set(gv, NULL);
120             SvLEN_set(gv, 0);
121             SvPOK_off(gv);
122         } else
123             Safefree(SvPVX_const(gv));
124     }
125     Newz(602, gp, 1, GP);
126     GvGP(gv) = gp_ref(gp);
127     GvSV(gv) = NEWSV(72,0);
128     GvLINE(gv) = CopLINE(PL_curcop);
129     /* XXX Ideally this cast would be replaced with a change to const char*
130        in the struct.  */
131     GvFILE(gv) = CopFILE(PL_curcop) ? CopFILE(PL_curcop) : (char *) "";
132     GvCVGEN(gv) = 0;
133     GvEGV(gv) = gv;
134     sv_magic((SV*)gv, (SV*)gv, PERL_MAGIC_glob, Nullch, 0);
135     GvSTASH(gv) = (HV*)SvREFCNT_inc(stash);
136     GvNAME(gv) = savepvn(name, len);
137     GvNAMELEN(gv) = len;
138     if (multi || doproto)              /* doproto means it _was_ mentioned */
139         GvMULTI_on(gv);
140     if (doproto) {                      /* Replicate part of newSUB here. */
141         SvIOK_off(gv);
142         ENTER;
143         /* XXX unsafe for threads if eval_owner isn't held */
144         start_subparse(0,0);            /* Create CV in compcv. */
145         GvCV(gv) = PL_compcv;
146         LEAVE;
147
148         PL_sub_generation++;
149         CvGV(GvCV(gv)) = gv;
150         CvFILE_set_from_cop(GvCV(gv), PL_curcop);
151         CvSTASH(GvCV(gv)) = PL_curstash;
152         if (proto) {
153             sv_setpv((SV*)GvCV(gv), proto);
154             Safefree(proto);
155         }
156     }
157 }
158
159 STATIC void
160 S_gv_init_sv(pTHX_ GV *gv, I32 sv_type)
161 {
162     switch (sv_type) {
163     case SVt_PVIO:
164         (void)GvIOn(gv);
165         break;
166     case SVt_PVAV:
167         (void)GvAVn(gv);
168         break;
169     case SVt_PVHV:
170         (void)GvHVn(gv);
171         break;
172     }
173 }
174
175 /*
176 =for apidoc gv_fetchmeth
177
178 Returns the glob with the given C<name> and a defined subroutine or
179 C<NULL>.  The glob lives in the given C<stash>, or in the stashes
180 accessible via @ISA and UNIVERSAL::.
181
182 The argument C<level> should be either 0 or -1.  If C<level==0>, as a
183 side-effect creates a glob with the given C<name> in the given C<stash>
184 which in the case of success contains an alias for the subroutine, and sets
185 up caching info for this glob.  Similarly for all the searched stashes.
186
187 This function grants C<"SUPER"> token as a postfix of the stash name. The
188 GV returned from C<gv_fetchmeth> may be a method cache entry, which is not
189 visible to Perl code.  So when calling C<call_sv>, you should not use
190 the GV directly; instead, you should use the method's CV, which can be
191 obtained from the GV with the C<GvCV> macro.
192
193 =cut
194 */
195
196 GV *
197 Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level)
198 {
199     AV* av;
200     GV* topgv;
201     GV* gv;
202     GV** gvp;
203     CV* cv;
204     const char *hvname;
205
206     /* UNIVERSAL methods should be callable without a stash */
207     if (!stash) {
208         level = -1;  /* probably appropriate */
209         if(!(stash = gv_stashpvn("UNIVERSAL", 9, FALSE)))
210             return 0;
211     }
212
213     hvname = HvNAME_get(stash);
214     if (!hvname)
215       Perl_croak(aTHX_
216                  "Can't use anonymous symbol table for method lookup");
217
218     if ((level > 100) || (level < -100))
219         Perl_croak(aTHX_ "Recursive inheritance detected while looking for method '%s' in package '%s'",
220               name, hvname);
221
222     DEBUG_o( Perl_deb(aTHX_ "Looking for method %s in package %s\n",name,hvname) );
223
224     gvp = (GV**)hv_fetch(stash, name, len, (level >= 0));
225     if (!gvp)
226         topgv = Nullgv;
227     else {
228         topgv = *gvp;
229         if (SvTYPE(topgv) != SVt_PVGV)
230             gv_init(topgv, stash, name, len, TRUE);
231         if ((cv = GvCV(topgv))) {
232             /* If genuine method or valid cache entry, use it */
233             if (!GvCVGEN(topgv) || GvCVGEN(topgv) == PL_sub_generation)
234                 return topgv;
235             /* Stale cached entry: junk it */
236             SvREFCNT_dec(cv);
237             GvCV(topgv) = cv = Nullcv;
238             GvCVGEN(topgv) = 0;
239         }
240         else if (GvCVGEN(topgv) == PL_sub_generation)
241             return 0;  /* cache indicates sub doesn't exist */
242     }
243
244     gvp = (GV**)hv_fetch(stash, "ISA", 3, FALSE);
245     av = (gvp && (gv = *gvp) && gv != (GV*)&PL_sv_undef) ? GvAV(gv) : Nullav;
246
247     /* create and re-create @.*::SUPER::ISA on demand */
248     if (!av || !SvMAGIC(av)) {
249         STRLEN packlen = HvNAMELEN_get(stash);
250
251         if (packlen >= 7 && strEQ(hvname + packlen - 7, "::SUPER")) {
252             HV* basestash;
253
254             packlen -= 7;
255             basestash = gv_stashpvn(hvname, packlen, TRUE);
256             gvp = (GV**)hv_fetch(basestash, "ISA", 3, FALSE);
257             if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (av = GvAV(gv))) {
258                 gvp = (GV**)hv_fetch(stash, "ISA", 3, TRUE);
259                 if (!gvp || !(gv = *gvp))
260                     Perl_croak(aTHX_ "Cannot create %s::ISA", hvname);
261                 if (SvTYPE(gv) != SVt_PVGV)
262                     gv_init(gv, stash, "ISA", 3, TRUE);
263                 SvREFCNT_dec(GvAV(gv));
264                 GvAV(gv) = (AV*)SvREFCNT_inc(av);
265             }
266         }
267     }
268
269     if (av) {
270         SV** svp = AvARRAY(av);
271         /* NOTE: No support for tied ISA */
272         I32 items = AvFILLp(av) + 1;
273         while (items--) {
274             SV* sv = *svp++;
275             HV* basestash = gv_stashsv(sv, FALSE);
276             if (!basestash) {
277                 if (ckWARN(WARN_MISC))
278                     Perl_warner(aTHX_ packWARN(WARN_MISC), "Can't locate package %"SVf" for @%s::ISA",
279                         sv, hvname);
280                 continue;
281             }
282             gv = gv_fetchmeth(basestash, name, len,
283                               (level >= 0) ? level + 1 : level - 1);
284             if (gv)
285                 goto gotcha;
286         }
287     }
288
289     /* if at top level, try UNIVERSAL */
290
291     if (level == 0 || level == -1) {
292         HV* lastchance;
293
294         if ((lastchance = gv_stashpvn("UNIVERSAL", 9, FALSE))) {
295             if ((gv = gv_fetchmeth(lastchance, name, len,
296                                   (level >= 0) ? level + 1 : level - 1)))
297             {
298           gotcha:
299                 /*
300                  * Cache method in topgv if:
301                  *  1. topgv has no synonyms (else inheritance crosses wires)
302                  *  2. method isn't a stub (else AUTOLOAD fails spectacularly)
303                  */
304                 if (topgv &&
305                     GvREFCNT(topgv) == 1 &&
306                     (cv = GvCV(gv)) &&
307                     (CvROOT(cv) || CvXSUB(cv)))
308                 {
309                     if ((cv = GvCV(topgv)))
310                         SvREFCNT_dec(cv);
311                     GvCV(topgv) = (CV*)SvREFCNT_inc(GvCV(gv));
312                     GvCVGEN(topgv) = PL_sub_generation;
313                 }
314                 return gv;
315             }
316             else if (topgv && GvREFCNT(topgv) == 1) {
317                 /* cache the fact that the method is not defined */
318                 GvCVGEN(topgv) = PL_sub_generation;
319             }
320         }
321     }
322
323     return 0;
324 }
325
326 /*
327 =for apidoc gv_fetchmeth_autoload
328
329 Same as gv_fetchmeth(), but looks for autoloaded subroutines too.
330 Returns a glob for the subroutine.
331
332 For an autoloaded subroutine without a GV, will create a GV even
333 if C<level < 0>.  For an autoloaded subroutine without a stub, GvCV()
334 of the result may be zero.
335
336 =cut
337 */
338
339 GV *
340 Perl_gv_fetchmeth_autoload(pTHX_ HV *stash, const char *name, STRLEN len, I32 level)
341 {
342     GV *gv = gv_fetchmeth(stash, name, len, level);
343
344     if (!gv) {
345         CV *cv;
346         GV **gvp;
347
348         if (!stash)
349             return Nullgv;      /* UNIVERSAL::AUTOLOAD could cause trouble */
350         if (len == S_autolen && strnEQ(name, S_autoload, S_autolen))
351             return Nullgv;
352         if (!(gv = gv_fetchmeth(stash, S_autoload, S_autolen, FALSE)))
353             return Nullgv;
354         cv = GvCV(gv);
355         if (!(CvROOT(cv) || CvXSUB(cv)))
356             return Nullgv;
357         /* Have an autoload */
358         if (level < 0)  /* Cannot do without a stub */
359             gv_fetchmeth(stash, name, len, 0);
360         gvp = (GV**)hv_fetch(stash, name, len, (level >= 0));
361         if (!gvp)
362             return Nullgv;
363         return *gvp;
364     }
365     return gv;
366 }
367
368 /*
369 =for apidoc gv_fetchmethod
370
371 See L<gv_fetchmethod_autoload>.
372
373 =cut
374 */
375
376 GV *
377 Perl_gv_fetchmethod(pTHX_ HV *stash, const char *name)
378 {
379     return gv_fetchmethod_autoload(stash, name, TRUE);
380 }
381
382 /*
383 =for apidoc gv_fetchmethod_autoload
384
385 Returns the glob which contains the subroutine to call to invoke the method
386 on the C<stash>.  In fact in the presence of autoloading this may be the
387 glob for "AUTOLOAD".  In this case the corresponding variable $AUTOLOAD is
388 already setup.
389
390 The third parameter of C<gv_fetchmethod_autoload> determines whether
391 AUTOLOAD lookup is performed if the given method is not present: non-zero
392 means yes, look for AUTOLOAD; zero means no, don't look for AUTOLOAD.
393 Calling C<gv_fetchmethod> is equivalent to calling C<gv_fetchmethod_autoload>
394 with a non-zero C<autoload> parameter.
395
396 These functions grant C<"SUPER"> token as a prefix of the method name. Note
397 that if you want to keep the returned glob for a long time, you need to
398 check for it being "AUTOLOAD", since at the later time the call may load a
399 different subroutine due to $AUTOLOAD changing its value. Use the glob
400 created via a side effect to do this.
401
402 These functions have the same side-effects and as C<gv_fetchmeth> with
403 C<level==0>.  C<name> should be writable if contains C<':'> or C<'
404 ''>. The warning against passing the GV returned by C<gv_fetchmeth> to
405 C<call_sv> apply equally to these functions.
406
407 =cut
408 */
409
410 GV *
411 Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload)
412 {
413     register const char *nend;
414     const char *nsplit = 0;
415     GV* gv;
416     HV* ostash = stash;
417
418     if (stash && SvTYPE(stash) < SVt_PVHV)
419         stash = Nullhv;
420
421     for (nend = name; *nend; nend++) {
422         if (*nend == '\'')
423             nsplit = nend;
424         else if (*nend == ':' && *(nend + 1) == ':')
425             nsplit = ++nend;
426     }
427     if (nsplit) {
428         const char *origname = name;
429         name = nsplit + 1;
430         if (*nsplit == ':')
431             --nsplit;
432         if ((nsplit - origname) == 5 && strnEQ(origname, "SUPER", 5)) {
433             /* ->SUPER::method should really be looked up in original stash */
434             SV *tmpstr = sv_2mortal(Perl_newSVpvf(aTHX_ "%s::SUPER",
435                                                   CopSTASHPV(PL_curcop)));
436             /* __PACKAGE__::SUPER stash should be autovivified */
437             stash = gv_stashpvn(SvPVX_const(tmpstr), SvCUR(tmpstr), TRUE);
438             DEBUG_o( Perl_deb(aTHX_ "Treating %s as %s::%s\n",
439                          origname, HvNAME_get(stash), name) );
440         }
441         else {
442             /* don't autovifify if ->NoSuchStash::method */
443             stash = gv_stashpvn(origname, nsplit - origname, FALSE);
444
445             /* however, explicit calls to Pkg::SUPER::method may
446                happen, and may require autovivification to work */
447             if (!stash && (nsplit - origname) >= 7 &&
448                 strnEQ(nsplit - 7, "::SUPER", 7) &&
449                 gv_stashpvn(origname, nsplit - origname - 7, FALSE))
450               stash = gv_stashpvn(origname, nsplit - origname, TRUE);
451         }
452         ostash = stash;
453     }
454
455     gv = gv_fetchmeth(stash, name, nend - name, 0);
456     if (!gv) {
457         if (strEQ(name,"import") || strEQ(name,"unimport"))
458             gv = (GV*)&PL_sv_yes;
459         else if (autoload)
460             gv = gv_autoload4(ostash, name, nend - name, TRUE);
461     }
462     else if (autoload) {
463         CV* cv = GvCV(gv);
464         if (!CvROOT(cv) && !CvXSUB(cv)) {
465             GV* stubgv;
466             GV* autogv;
467
468             if (CvANON(cv))
469                 stubgv = gv;
470             else {
471                 stubgv = CvGV(cv);
472                 if (GvCV(stubgv) != cv)         /* orphaned import */
473                     stubgv = gv;
474             }
475             autogv = gv_autoload4(GvSTASH(stubgv),
476                                   GvNAME(stubgv), GvNAMELEN(stubgv), TRUE);
477             if (autogv)
478                 gv = autogv;
479         }
480     }
481
482     return gv;
483 }
484
485 GV*
486 Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method)
487 {
488     dVAR;
489     GV* gv;
490     CV* cv;
491     HV* varstash;
492     GV* vargv;
493     SV* varsv;
494     const char *packname = "";
495     STRLEN packname_len;
496
497     if (len == S_autolen && strnEQ(name, S_autoload, S_autolen))
498         return Nullgv;
499     if (stash) {
500         if (SvTYPE(stash) < SVt_PVHV) {
501             packname = SvPV((SV*)stash, packname_len);
502             stash = Nullhv;
503         }
504         else {
505             packname = HvNAME_get(stash);
506             packname_len = HvNAMELEN_get(stash);
507         }
508     }
509     if (!(gv = gv_fetchmeth(stash, S_autoload, S_autolen, FALSE)))
510         return Nullgv;
511     cv = GvCV(gv);
512
513     if (!(CvROOT(cv) || CvXSUB(cv)))
514         return Nullgv;
515
516     /*
517      * Inheriting AUTOLOAD for non-methods works ... for now.
518      */
519     if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX) && !method &&
520         (GvCVGEN(gv) || GvSTASH(gv) != stash))
521         Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
522           "Use of inherited AUTOLOAD for non-method %s::%.*s() is deprecated",
523              packname, (int)len, name);
524
525     if (CvXSUB(cv)) {
526         /* rather than lookup/init $AUTOLOAD here
527          * only to have the XSUB do another lookup for $AUTOLOAD
528          * and split that value on the last '::',
529          * pass along the same data via some unused fields in the CV
530          */
531         CvSTASH(cv) = stash;
532         SvPV_set(cv, (char *)name); /* cast to lose constness warning */
533         SvCUR_set(cv, len);
534         return gv;
535     }
536
537     /*
538      * Given &FOO::AUTOLOAD, set $FOO::AUTOLOAD to desired function name.
539      * The subroutine's original name may not be "AUTOLOAD", so we don't
540      * use that, but for lack of anything better we will use the sub's
541      * original package to look up $AUTOLOAD.
542      */
543     varstash = GvSTASH(CvGV(cv));
544     vargv = *(GV**)hv_fetch(varstash, S_autoload, S_autolen, TRUE);
545     ENTER;
546
547     if (!isGV(vargv))
548         gv_init(vargv, varstash, S_autoload, S_autolen, FALSE);
549     LEAVE;
550     varsv = GvSV(vargv);
551     sv_setpvn(varsv, packname, packname_len);
552     sv_catpvn(varsv, "::", 2);
553     sv_catpvn(varsv, name, len);
554     SvTAINTED_off(varsv);
555     return gv;
556 }
557
558 /* The "gv" parameter should be the glob known to Perl code as *!
559  * The scalar must already have been magicalized.
560  */
561 STATIC void
562 S_require_errno(pTHX_ GV *gv)
563 {
564     dVAR;
565     HV* stash = gv_stashpvn("Errno",5,FALSE);
566
567     if (!stash || !(gv_fetchmethod(stash, "TIEHASH"))) {
568         dSP;
569         PUTBACK;
570         ENTER;
571         save_scalar(gv); /* keep the value of $! */
572         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
573                          newSVpvn("Errno",5), Nullsv);
574         LEAVE;
575         SPAGAIN;
576         stash = gv_stashpvn("Errno",5,FALSE);
577         if (!stash || !(gv_fetchmethod(stash, "TIEHASH")))
578             Perl_croak(aTHX_ "Can't use %%! because Errno.pm is not available");
579     }
580 }
581
582 /*
583 =for apidoc gv_stashpv
584
585 Returns a pointer to the stash for a specified package.  C<name> should
586 be a valid UTF-8 string and must be null-terminated.  If C<create> is set
587 then the package will be created if it does not already exist.  If C<create>
588 is not set and the package does not exist then NULL is returned.
589
590 =cut
591 */
592
593 HV*
594 Perl_gv_stashpv(pTHX_ const char *name, I32 create)
595 {
596     return gv_stashpvn(name, strlen(name), create);
597 }
598
599 /*
600 =for apidoc gv_stashpvn
601
602 Returns a pointer to the stash for a specified package.  C<name> should
603 be a valid UTF-8 string.  The C<namelen> parameter indicates the length of
604 the C<name>, in bytes.  If C<create> is set then the package will be
605 created if it does not already exist.  If C<create> is not set and the
606 package does not exist then NULL is returned.
607
608 =cut
609 */
610
611 HV*
612 Perl_gv_stashpvn(pTHX_ const char *name, U32 namelen, I32 create)
613 {
614     char smallbuf[256];
615     char *tmpbuf;
616     HV *stash;
617     GV *tmpgv;
618
619     if (namelen + 3 < sizeof smallbuf)
620         tmpbuf = smallbuf;
621     else
622         New(606, tmpbuf, namelen + 3, char);
623     Copy(name,tmpbuf,namelen,char);
624     tmpbuf[namelen++] = ':';
625     tmpbuf[namelen++] = ':';
626     tmpbuf[namelen] = '\0';
627     tmpgv = gv_fetchpv(tmpbuf, create, SVt_PVHV);
628     if (tmpbuf != smallbuf)
629         Safefree(tmpbuf);
630     if (!tmpgv)
631         return 0;
632     if (!GvHV(tmpgv))
633         GvHV(tmpgv) = newHV();
634     stash = GvHV(tmpgv);
635     if (!HvNAME_get(stash))
636         Perl_hv_name_set(aTHX_ stash, name, namelen, 0);
637     return stash;
638 }
639
640 /*
641 =for apidoc gv_stashsv
642
643 Returns a pointer to the stash for a specified package, which must be a
644 valid UTF-8 string.  See C<gv_stashpv>.
645
646 =cut
647 */
648
649 HV*
650 Perl_gv_stashsv(pTHX_ SV *sv, I32 create)
651 {
652     STRLEN len;
653     const char *ptr = SvPV(sv,len);
654     return gv_stashpvn(ptr, len, create);
655 }
656
657
658 GV *
659 Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type) {
660     return gv_fetchpvn_flags(nambeg, strlen(nambeg), add, sv_type);
661 }
662
663 GV *
664 Perl_gv_fetchsv(pTHX_ SV *name, I32 flags, I32 sv_type) {
665     STRLEN len;
666     const char *nambeg = SvPV(name, len);
667     return gv_fetchpvn_flags(nambeg, len, flags | SvUTF8(name), sv_type);
668 }
669
670 GV *
671 Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
672                        I32 sv_type)
673 {
674     register const char *name = nambeg;
675     register GV *gv = 0;
676     GV**gvp;
677     I32 len;
678     register const char *namend;
679     HV *stash = 0;
680     const I32 add = flags & ~SVf_UTF8;
681     (void)full_len;
682
683     if (*name == '*' && isALPHA(name[1])) /* accidental stringify on a GV? */
684         name++;
685
686     for (namend = name; *namend; namend++) {
687         if ((*namend == ':' && namend[1] == ':')
688             || (*namend == '\'' && namend[1]))
689         {
690             if (!stash)
691                 stash = PL_defstash;
692             if (!stash || !SvREFCNT(stash)) /* symbol table under destruction */
693                 return Nullgv;
694
695             len = namend - name;
696             if (len > 0) {
697                 char smallbuf[256];
698                 char *tmpbuf;
699
700                 if (len + 3 < sizeof (smallbuf))
701                     tmpbuf = smallbuf;
702                 else
703                     New(601, tmpbuf, len+3, char);
704                 Copy(name, tmpbuf, len, char);
705                 tmpbuf[len++] = ':';
706                 tmpbuf[len++] = ':';
707                 tmpbuf[len] = '\0';
708                 gvp = (GV**)hv_fetch(stash,tmpbuf,len,add);
709                 gv = gvp ? *gvp : Nullgv;
710                 if (gv && gv != (GV*)&PL_sv_undef) {
711                     if (SvTYPE(gv) != SVt_PVGV)
712                         gv_init(gv, stash, tmpbuf, len, (add & GV_ADDMULTI));
713                     else
714                         GvMULTI_on(gv);
715                 }
716                 if (tmpbuf != smallbuf)
717                     Safefree(tmpbuf);
718                 if (!gv || gv == (GV*)&PL_sv_undef)
719                     return Nullgv;
720
721                 if (!(stash = GvHV(gv)))
722                     stash = GvHV(gv) = newHV();
723
724                 if (!HvNAME_get(stash))
725                     Perl_hv_name_set(aTHX_ stash, nambeg, namend - nambeg, 0);
726             }
727
728             if (*namend == ':')
729                 namend++;
730             namend++;
731             name = namend;
732             if (!*name)
733                 return gv ? gv : (GV*)*hv_fetch(PL_defstash, "main::", 6, TRUE);
734         }
735     }
736     len = namend - name;
737
738     /* No stash in name, so see how we can default */
739
740     if (!stash) {
741         if (isIDFIRST_lazy(name)) {
742             bool global = FALSE;
743
744             /* name is always \0 terminated, and initial \0 wouldn't return
745                true from isIDFIRST_lazy, so we know that name[1] is defined  */
746             switch (name[1]) {
747             case '\0':
748                 if (*name == '_')
749                     global = TRUE;
750                 break;
751             case 'N':
752                 if (strEQ(name, "INC") || strEQ(name, "ENV"))
753                     global = TRUE;
754                 break;
755             case 'I':
756                 if (strEQ(name, "SIG"))
757                     global = TRUE;
758                 break;
759             case 'T':
760                 if (strEQ(name, "STDIN") || strEQ(name, "STDOUT") ||
761                     strEQ(name, "STDERR"))
762                     global = TRUE;
763                 break;
764             case 'R':
765                 if (strEQ(name, "ARGV") || strEQ(name, "ARGVOUT"))
766                     global = TRUE;
767                 break;
768             }
769
770             if (global)
771                 stash = PL_defstash;
772             else if (IN_PERL_COMPILETIME) {
773                 stash = PL_curstash;
774                 if (add && (PL_hints & HINT_STRICT_VARS) &&
775                     sv_type != SVt_PVCV &&
776                     sv_type != SVt_PVGV &&
777                     sv_type != SVt_PVFM &&
778                     sv_type != SVt_PVIO &&
779                     !(len == 1 && sv_type == SVt_PV &&
780                       (*name == 'a' || *name == 'b')) )
781                 {
782                     gvp = (GV**)hv_fetch(stash,name,len,0);
783                     if (!gvp ||
784                         *gvp == (GV*)&PL_sv_undef ||
785                         SvTYPE(*gvp) != SVt_PVGV)
786                     {
787                         stash = 0;
788                     }
789                     else if ((sv_type == SVt_PV   && !GvIMPORTED_SV(*gvp)) ||
790                              (sv_type == SVt_PVAV && !GvIMPORTED_AV(*gvp)) ||
791                              (sv_type == SVt_PVHV && !GvIMPORTED_HV(*gvp)) )
792                     {
793                         Perl_warn(aTHX_ "Variable \"%c%s\" is not imported",
794                             sv_type == SVt_PVAV ? '@' :
795                             sv_type == SVt_PVHV ? '%' : '$',
796                             name);
797                         if (GvCVu(*gvp))
798                             Perl_warn(aTHX_ "\t(Did you mean &%s instead?)\n", name);
799                         stash = 0;
800                     }
801                 }
802             }
803             else
804                 stash = CopSTASH(PL_curcop);
805         }
806         else
807             stash = PL_defstash;
808     }
809
810     /* By this point we should have a stash and a name */
811
812     if (!stash) {
813         if (add) {
814             register SV *err = Perl_mess(aTHX_
815                  "Global symbol \"%s%s\" requires explicit package name",
816                  (sv_type == SVt_PV ? "$"
817                   : sv_type == SVt_PVAV ? "@"
818                   : sv_type == SVt_PVHV ? "%"
819                   : ""), name);
820             if (USE_UTF8_IN_NAMES)
821                 SvUTF8_on(err);
822             qerror(err);
823             stash = GvHV(gv_fetchpv("<none>::", GV_ADDMULTI, SVt_PVHV));
824         }
825         else
826             return Nullgv;
827     }
828
829     if (!SvREFCNT(stash))       /* symbol table under destruction */
830         return Nullgv;
831
832     gvp = (GV**)hv_fetch(stash,name,len,add);
833     if (!gvp || *gvp == (GV*)&PL_sv_undef)
834         return Nullgv;
835     gv = *gvp;
836     if (SvTYPE(gv) == SVt_PVGV) {
837         if (add) {
838             GvMULTI_on(gv);
839             gv_init_sv(gv, sv_type);
840             if (*name=='!' && sv_type == SVt_PVHV && len==1)
841                 require_errno(gv);
842         }
843         return gv;
844     } else if (add & GV_NOINIT) {
845         return gv;
846     }
847
848     /* Adding a new symbol */
849
850     if (add & GV_ADDWARN && ckWARN_d(WARN_INTERNAL))
851         Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "Had to create %s unexpectedly", nambeg);
852     gv_init(gv, stash, name, len, add & GV_ADDMULTI);
853     gv_init_sv(gv, sv_type);
854
855     if (isALPHA(name[0]) && ! (isLEXWARN_on ? ckWARN(WARN_ONCE)
856                                             : (PL_dowarn & G_WARN_ON ) ) )
857         GvMULTI_on(gv) ;
858
859     /* set up magic where warranted */
860     if (len > 1) {
861 #ifndef EBCDIC
862         if (*name > 'V' ) {
863             /* Nothing else to do.
864                The compiler will probably turn the switch statement into a
865                branch table. Make sure we avoid even that small overhead for
866                the common case of lower case variable names.  */
867         } else
868 #endif
869         {
870             const char *name2 = name + 1;
871             switch (*name) {
872             case 'A':
873                 if (strEQ(name2, "RGV")) {
874                     IoFLAGS(GvIOn(gv)) |= IOf_ARGV|IOf_START;
875                 }
876                 break;
877             case 'E':
878                 if (strnEQ(name2, "XPORT", 5))
879                     GvMULTI_on(gv);
880                 break;
881             case 'I':
882                 if (strEQ(name2, "SA")) {
883                     AV* av = GvAVn(gv);
884                     GvMULTI_on(gv);
885                     sv_magic((SV*)av, (SV*)gv, PERL_MAGIC_isa, Nullch, 0);
886                     /* NOTE: No support for tied ISA */
887                     if ((add & GV_ADDMULTI) && strEQ(nambeg,"AnyDBM_File::ISA")
888                         && AvFILLp(av) == -1)
889                         {
890                             const char *pname;
891                             av_push(av, newSVpvn(pname = "NDBM_File",9));
892                             gv_stashpvn(pname, 9, TRUE);
893                             av_push(av, newSVpvn(pname = "DB_File",7));
894                             gv_stashpvn(pname, 7, TRUE);
895                             av_push(av, newSVpvn(pname = "GDBM_File",9));
896                             gv_stashpvn(pname, 9, TRUE);
897                             av_push(av, newSVpvn(pname = "SDBM_File",9));
898                             gv_stashpvn(pname, 9, TRUE);
899                             av_push(av, newSVpvn(pname = "ODBM_File",9));
900                             gv_stashpvn(pname, 9, TRUE);
901                         }
902                 }
903                 break;
904             case 'O':
905                 if (strEQ(name2, "VERLOAD")) {
906                     HV* hv = GvHVn(gv);
907                     GvMULTI_on(gv);
908                     hv_magic(hv, Nullgv, PERL_MAGIC_overload);
909                 }
910                 break;
911             case 'S':
912                 if (strEQ(name2, "IG")) {
913                     HV *hv;
914                     I32 i;
915                     if (!PL_psig_ptr) {
916                         Newz(73, PL_psig_ptr,  SIG_SIZE, SV*);
917                         Newz(73, PL_psig_name, SIG_SIZE, SV*);
918                         Newz(73, PL_psig_pend, SIG_SIZE, int);
919                     }
920                     GvMULTI_on(gv);
921                     hv = GvHVn(gv);
922                     hv_magic(hv, Nullgv, PERL_MAGIC_sig);
923                     for (i = 1; i < SIG_SIZE; i++) {
924                         SV ** init;
925                         init = hv_fetch(hv, PL_sig_name[i], strlen(PL_sig_name[i]), 1);
926                         if (init)
927                             sv_setsv(*init, &PL_sv_undef);
928                         PL_psig_ptr[i] = 0;
929                         PL_psig_name[i] = 0;
930                         PL_psig_pend[i] = 0;
931                     }
932                 }
933                 break;
934             case 'V':
935                 if (strEQ(name2, "ERSION"))
936                     GvMULTI_on(gv);
937                 break;
938             case '\003':        /* $^CHILD_ERROR_NATIVE */
939                 if (strEQ(name2, "HILD_ERROR_NATIVE"))
940                     goto magicalize;
941                 break;
942             case '\005':        /* $^ENCODING */
943                 if (strEQ(name2, "NCODING"))
944                     goto magicalize;
945                 break;
946             case '\017':        /* $^OPEN */
947                 if (strEQ(name2, "PEN"))
948                     goto magicalize;
949                 break;
950             case '\024':        /* ${^TAINT} */
951                 if (strEQ(name2, "AINT"))
952                     goto ro_magicalize;
953                 break;
954             case '\025':        /* ${^UNICODE}, ${^UTF8LOCALE} */
955                 if (strEQ(name2, "NICODE"))
956                     goto ro_magicalize;
957                 if (strEQ(name2, "TF8LOCALE"))
958                     goto ro_magicalize;
959                 break;
960             case '\027':        /* $^WARNING_BITS */
961                 if (strEQ(name2, "ARNING_BITS"))
962                     goto magicalize;
963                 break;
964             case '1':
965             case '2':
966             case '3':
967             case '4':
968             case '5':
969             case '6':
970             case '7':
971             case '8':
972             case '9':
973             {
974                 /* ensures variable is only digits */
975                 /* ${"1foo"} fails this test (and is thus writeable) */
976                 /* added by japhy, but borrowed from is_gv_magical */
977                 const char *end = name + len;
978                 while (--end > name) {
979                     if (!isDIGIT(*end)) return gv;
980                 }
981                 goto ro_magicalize;
982             }
983             }
984         }
985     } else {
986         /* Names of length 1.  (Or 0. But name is NUL terminated, so that will
987            be case '\0' in this switch statement (ie a default case)  */
988         switch (*name) {
989         case '&':
990         case '`':
991         case '\'':
992             if (
993                 sv_type == SVt_PVAV ||
994                 sv_type == SVt_PVHV ||
995                 sv_type == SVt_PVCV ||
996                 sv_type == SVt_PVFM ||
997                 sv_type == SVt_PVIO
998                 ) { break; }
999             PL_sawampersand = TRUE;
1000             goto ro_magicalize;
1001
1002         case ':':
1003             sv_setpv(GvSV(gv),PL_chopset);
1004             goto magicalize;
1005
1006         case '?':
1007 #ifdef COMPLEX_STATUS
1008             (void)SvUPGRADE(GvSV(gv), SVt_PVLV);
1009 #endif
1010             goto magicalize;
1011
1012         case '!':
1013
1014             /* If %! has been used, automatically load Errno.pm.
1015                The require will itself set errno, so in order to
1016                preserve its value we have to set up the magic
1017                now (rather than going to magicalize)
1018             */
1019
1020             sv_magic(GvSV(gv), (SV*)gv, PERL_MAGIC_sv, name, len);
1021
1022             if (sv_type == SVt_PVHV)
1023                 require_errno(gv);
1024
1025             break;
1026         case '-':
1027         {
1028             AV* av = GvAVn(gv);
1029             sv_magic((SV*)av, Nullsv, PERL_MAGIC_regdata, Nullch, 0);
1030             SvREADONLY_on(av);
1031             goto magicalize;
1032         }
1033         case '*':
1034             if (sv_type == SVt_PV && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
1035                 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
1036                             "$* is no longer supported");
1037             break;
1038         case '#':
1039             if (sv_type == SVt_PV && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
1040                 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
1041                             "Use of $# is deprecated");
1042             goto magicalize;
1043         case '|':
1044             sv_setiv(GvSV(gv), (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0);
1045             goto magicalize;
1046
1047         case '+':
1048         {
1049             AV* av = GvAVn(gv);
1050             sv_magic((SV*)av, (SV*)av, PERL_MAGIC_regdata, Nullch, 0);
1051             SvREADONLY_on(av);
1052             /* FALL THROUGH */
1053         }
1054         case '\023':    /* $^S */
1055         case '1':
1056         case '2':
1057         case '3':
1058         case '4':
1059         case '5':
1060         case '6':
1061         case '7':
1062         case '8':
1063         case '9':
1064         ro_magicalize:
1065             SvREADONLY_on(GvSV(gv));
1066             /* FALL THROUGH */
1067         case '[':
1068         case '^':
1069         case '~':
1070         case '=':
1071         case '%':
1072         case '.':
1073         case '(':
1074         case ')':
1075         case '<':
1076         case '>':
1077         case ',':
1078         case '\\':
1079         case '/':
1080         case '\001':    /* $^A */
1081         case '\003':    /* $^C */
1082         case '\004':    /* $^D */
1083         case '\005':    /* $^E */
1084         case '\006':    /* $^F */
1085         case '\010':    /* $^H */
1086         case '\011':    /* $^I, NOT \t in EBCDIC */
1087         case '\016':    /* $^N */
1088         case '\017':    /* $^O */
1089         case '\020':    /* $^P */
1090         case '\024':    /* $^T */
1091         case '\027':    /* $^W */
1092         magicalize:
1093             sv_magic(GvSV(gv), (SV*)gv, PERL_MAGIC_sv, name, len);
1094             break;
1095
1096         case '\014':    /* $^L */
1097             sv_setpv(GvSV(gv),"\f");
1098             PL_formfeed = GvSV(gv);
1099             break;
1100         case ';':
1101             sv_setpv(GvSV(gv),"\034");
1102             break;
1103         case ']':
1104         {
1105             SV *sv = GvSV(gv);
1106             if (!sv_derived_from(PL_patchlevel, "version"))
1107                 (void *)upg_version(PL_patchlevel);
1108             GvSV(gv) = vnumify(PL_patchlevel);
1109             SvREADONLY_on(GvSV(gv));
1110             SvREFCNT_dec(sv);
1111         }
1112         break;
1113         case '\026':    /* $^V */
1114         {
1115             SV * const sv = GvSV(gv);
1116             GvSV(gv) = new_version(PL_patchlevel);
1117             SvREADONLY_on(GvSV(gv));
1118             SvREFCNT_dec(sv);
1119         }
1120         break;
1121         }
1122     }
1123     return gv;
1124 }
1125
1126 void
1127 Perl_gv_fullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
1128 {
1129     const char *name;
1130     STRLEN namelen;
1131     const HV * const hv = GvSTASH(gv);
1132     if (!hv) {
1133         SvOK_off(sv);
1134         return;
1135     }
1136     sv_setpv(sv, prefix ? prefix : "");
1137
1138     name = HvNAME_get(hv);
1139     if (name) {
1140         namelen = HvNAMELEN_get(hv);
1141     } else {
1142         name = "__ANON__";
1143         namelen = 8;
1144     }
1145
1146     if (keepmain || strNE(name, "main")) {
1147         sv_catpvn(sv,name,namelen);
1148         sv_catpvn(sv,"::", 2);
1149     }
1150     sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv));
1151 }
1152
1153 void
1154 Perl_gv_fullname3(pTHX_ SV *sv, const GV *gv, const char *prefix)
1155 {
1156     gv_fullname4(sv, gv, prefix, TRUE);
1157 }
1158
1159 void
1160 Perl_gv_efullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
1161 {
1162     const GV *egv = GvEGV(gv);
1163     if (!egv)
1164         egv = gv;
1165     gv_fullname4(sv, egv, prefix, keepmain);
1166 }
1167
1168 void
1169 Perl_gv_efullname3(pTHX_ SV *sv, const GV *gv, const char *prefix)
1170 {
1171     gv_efullname4(sv, gv, prefix, TRUE);
1172 }
1173
1174 /* compatibility with versions <= 5.003. */
1175 void
1176 Perl_gv_fullname(pTHX_ SV *sv, const GV *gv)
1177 {
1178     gv_fullname3(sv, gv, sv == (const SV*)gv ? "*" : "");
1179 }
1180
1181 /* compatibility with versions <= 5.003. */
1182 void
1183 Perl_gv_efullname(pTHX_ SV *sv, const GV *gv)
1184 {
1185     gv_efullname3(sv, gv, sv == (const SV*)gv ? "*" : "");
1186 }
1187
1188 IO *
1189 Perl_newIO(pTHX)
1190 {
1191     GV *iogv;
1192     IO * const io = (IO*)NEWSV(0,0);
1193
1194     sv_upgrade((SV *)io,SVt_PVIO);
1195     SvREFCNT(io) = 1;
1196     SvOBJECT_on(io);
1197     /* Clear the stashcache because a new IO could overrule a
1198        package name */
1199     hv_clear(PL_stashcache);
1200     iogv = gv_fetchpv("FileHandle::", FALSE, SVt_PVHV);
1201     /* unless exists($main::{FileHandle}) and defined(%main::FileHandle::) */
1202     if (!(iogv && GvHV(iogv) && HvARRAY(GvHV(iogv))))
1203       iogv = gv_fetchpv("IO::Handle::", TRUE, SVt_PVHV);
1204     SvSTASH_set(io, (HV*)SvREFCNT_inc(GvHV(iogv)));
1205     return io;
1206 }
1207
1208 void
1209 Perl_gv_check(pTHX_ HV *stash)
1210 {
1211     register I32 i;
1212
1213     if (!HvARRAY(stash))
1214         return;
1215     for (i = 0; i <= (I32) HvMAX(stash); i++) {
1216         const HE *entry;
1217         for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
1218             register GV *gv;
1219             HV *hv;
1220             if (HeKEY(entry)[HeKLEN(entry)-1] == ':' &&
1221                 (gv = (GV*)HeVAL(entry)) && isGV(gv) && (hv = GvHV(gv)))
1222             {
1223                 if (hv != PL_defstash && hv != stash)
1224                      gv_check(hv);              /* nested package */
1225             }
1226             else if (isALPHA(*HeKEY(entry))) {
1227                 const char *file;
1228                 gv = (GV*)HeVAL(entry);
1229                 if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv))
1230                     continue;
1231                 file = GvFILE(gv);
1232                 /* performance hack: if filename is absolute and it's a standard
1233                  * module, don't bother warning */
1234                 if (file
1235                     && PERL_FILE_IS_ABSOLUTE(file)
1236 #ifdef MACOS_TRADITIONAL
1237                     && (instr(file, ":lib:")
1238 #else
1239                     && (instr(file, "/lib/")
1240 #endif
1241                     || instr(file, ".pm")))
1242                 {
1243                     continue;
1244                 }
1245                 CopLINE_set(PL_curcop, GvLINE(gv));
1246 #ifdef USE_ITHREADS
1247                 CopFILE(PL_curcop) = (char *)file;      /* set for warning */
1248 #else
1249                 CopFILEGV(PL_curcop) = gv_fetchfile(file);
1250 #endif
1251                 Perl_warner(aTHX_ packWARN(WARN_ONCE),
1252                         "Name \"%s::%s\" used only once: possible typo",
1253                         HvNAME_get(stash), GvNAME(gv));
1254             }
1255         }
1256     }
1257 }
1258
1259 GV *
1260 Perl_newGVgen(pTHX_ const char *pack)
1261 {
1262     return gv_fetchpv(Perl_form(aTHX_ "%s::_GEN_%ld", pack, (long)PL_gensym++),
1263                       TRUE, SVt_PVGV);
1264 }
1265
1266 /* hopefully this is only called on local symbol table entries */
1267
1268 GP*
1269 Perl_gp_ref(pTHX_ GP *gp)
1270 {
1271     if (!gp)
1272         return (GP*)NULL;
1273     gp->gp_refcnt++;
1274     if (gp->gp_cv) {
1275         if (gp->gp_cvgen) {
1276             /* multi-named GPs cannot be used for method cache */
1277             SvREFCNT_dec(gp->gp_cv);
1278             gp->gp_cv = Nullcv;
1279             gp->gp_cvgen = 0;
1280         }
1281         else {
1282             /* Adding a new name to a subroutine invalidates method cache */
1283             PL_sub_generation++;
1284         }
1285     }
1286     return gp;
1287 }
1288
1289 void
1290 Perl_gp_free(pTHX_ GV *gv)
1291 {
1292     GP* gp;
1293
1294     if (!gv || !(gp = GvGP(gv)))
1295         return;
1296     if (gp->gp_refcnt == 0) {
1297         if (ckWARN_d(WARN_INTERNAL))
1298             Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
1299                         "Attempt to free unreferenced glob pointers"
1300                         pTHX__FORMAT pTHX__VALUE);
1301         return;
1302     }
1303     if (gp->gp_cv) {
1304         /* Deleting the name of a subroutine invalidates method cache */
1305         PL_sub_generation++;
1306     }
1307     if (--gp->gp_refcnt > 0) {
1308         if (gp->gp_egv == gv)
1309             gp->gp_egv = 0;
1310         return;
1311     }
1312
1313     if (gp->gp_sv) SvREFCNT_dec(gp->gp_sv);
1314     if (gp->gp_av) SvREFCNT_dec(gp->gp_av);
1315     /* FIXME - another reference loop GV -> symtab -> GV ?
1316        Somehow gp->gp_hv can end up pointing at freed garbage.  */
1317     if (gp->gp_hv && SvTYPE(gp->gp_hv) == SVt_PVHV) {
1318         const char *hvname = HvNAME_get(gp->gp_hv);
1319         if (PL_stashcache && hvname)
1320             hv_delete(PL_stashcache, hvname, HvNAMELEN_get(gp->gp_hv),
1321                       G_DISCARD);
1322         SvREFCNT_dec(gp->gp_hv);
1323     }
1324     if (gp->gp_io)   SvREFCNT_dec(gp->gp_io);
1325     if (gp->gp_cv)   SvREFCNT_dec(gp->gp_cv);
1326     if (gp->gp_form) SvREFCNT_dec(gp->gp_form);
1327
1328     Safefree(gp);
1329     GvGP(gv) = 0;
1330 }
1331
1332 int
1333 Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg)
1334 {
1335     AMT *amtp = (AMT*)mg->mg_ptr;
1336     (void)sv;
1337
1338     if (amtp && AMT_AMAGIC(amtp)) {
1339         int i;
1340         for (i = 1; i < NofAMmeth; i++) {
1341             CV *cv = amtp->table[i];
1342             if (cv != Nullcv) {
1343                 SvREFCNT_dec((SV *) cv);
1344                 amtp->table[i] = Nullcv;
1345             }
1346         }
1347     }
1348  return 0;
1349 }
1350
1351 /* Updates and caches the CV's */
1352
1353 bool
1354 Perl_Gv_AMupdate(pTHX_ HV *stash)
1355 {
1356   GV* gv;
1357   CV* cv;
1358   MAGIC* mg=mg_find((SV*)stash, PERL_MAGIC_overload_table);
1359   AMT *amtp = (mg) ? (AMT*)mg->mg_ptr: (AMT *) NULL;
1360   AMT amt;
1361
1362   if (mg && amtp->was_ok_am == PL_amagic_generation
1363       && amtp->was_ok_sub == PL_sub_generation)
1364       return (bool)AMT_OVERLOADED(amtp);
1365   sv_unmagic((SV*)stash, PERL_MAGIC_overload_table);
1366
1367   DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME_get(stash)) );
1368
1369   Zero(&amt,1,AMT);
1370   amt.was_ok_am = PL_amagic_generation;
1371   amt.was_ok_sub = PL_sub_generation;
1372   amt.fallback = AMGfallNO;
1373   amt.flags = 0;
1374
1375   {
1376     int filled = 0, have_ovl = 0;
1377     int i, lim = 1;
1378     SV* sv = NULL;
1379
1380     /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
1381
1382     /* Try to find via inheritance. */
1383     gv = gv_fetchmeth(stash, PL_AMG_names[0], 2, -1);
1384     if (gv)
1385         sv = GvSV(gv);
1386
1387     if (!gv)
1388         lim = DESTROY_amg;              /* Skip overloading entries. */
1389     else if (SvTRUE(sv))
1390         amt.fallback=AMGfallYES;
1391     else if (SvOK(sv))
1392         amt.fallback=AMGfallNEVER;
1393
1394     for (i = 1; i < lim; i++)
1395         amt.table[i] = Nullcv;
1396     for (; i < NofAMmeth; i++) {
1397         const char *cooky = PL_AMG_names[i];
1398         /* Human-readable form, for debugging: */
1399         const char *cp = (i >= DESTROY_amg ? cooky : AMG_id2name(i));
1400         const STRLEN l = strlen(cooky);
1401
1402         DEBUG_o( Perl_deb(aTHX_ "Checking overloading of \"%s\" in package \"%.256s\"\n",
1403                      cp, HvNAME_get(stash)) );
1404         /* don't fill the cache while looking up!
1405            Creation of inheritance stubs in intermediate packages may
1406            conflict with the logic of runtime method substitution.
1407            Indeed, for inheritance A -> B -> C, if C overloads "+0",
1408            then we could have created stubs for "(+0" in A and C too.
1409            But if B overloads "bool", we may want to use it for
1410            numifying instead of C's "+0". */
1411         if (i >= DESTROY_amg)
1412             gv = Perl_gv_fetchmeth_autoload(aTHX_ stash, cooky, l, 0);
1413         else                            /* Autoload taken care of below */
1414             gv = Perl_gv_fetchmeth(aTHX_ stash, cooky, l, -1);
1415         cv = 0;
1416         if (gv && (cv = GvCV(gv))) {
1417             const char *hvname;
1418             if (GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")
1419                 && strEQ(hvname = HvNAME_get(GvSTASH(CvGV(cv))), "overload")) {
1420                 /* This is a hack to support autoloading..., while
1421                    knowing *which* methods were declared as overloaded. */
1422                 /* GvSV contains the name of the method. */
1423                 GV *ngv = Nullgv;
1424
1425                 DEBUG_o( Perl_deb(aTHX_ "Resolving method \"%"SVf256\
1426                         "\" for overloaded \"%s\" in package \"%.256s\"\n",
1427                              GvSV(gv), cp, hvname) );
1428                 if (!SvPOK(GvSV(gv))
1429                     || !(ngv = gv_fetchmethod_autoload(stash, SvPVX_const(GvSV(gv)),
1430                                                        FALSE)))
1431                 {
1432                     /* Can be an import stub (created by "can"). */
1433                     SV *gvsv = GvSV(gv);
1434                     const char *name = SvPOK(gvsv) ?  SvPVX_const(gvsv) : "???";
1435                     Perl_croak(aTHX_ "%s method \"%.256s\" overloading \"%s\" "\
1436                                 "in package \"%.256s\"",
1437                                (GvCVGEN(gv) ? "Stub found while resolving"
1438                                 : "Can't resolve"),
1439                                name, cp, hvname);
1440                 }
1441                 cv = GvCV(gv = ngv);
1442             }
1443             DEBUG_o( Perl_deb(aTHX_ "Overloading \"%s\" in package \"%.256s\" "\
1444                                     "via \"%.256s::%.256s\"\n",
1445                          cp, HvNAME_get(stash), HvNAME_get(GvSTASH(CvGV(cv))),
1446                          GvNAME(CvGV(cv))) );
1447             filled = 1;
1448             if (i < DESTROY_amg)
1449                 have_ovl = 1;
1450         } else if (gv) {                /* Autoloaded... */
1451             cv = (CV*)gv;
1452             filled = 1;
1453         }
1454         amt.table[i]=(CV*)SvREFCNT_inc(cv);
1455     }
1456     if (filled) {
1457       AMT_AMAGIC_on(&amt);
1458       if (have_ovl)
1459           AMT_OVERLOADED_on(&amt);
1460       sv_magic((SV*)stash, 0, PERL_MAGIC_overload_table,
1461                                                 (char*)&amt, sizeof(AMT));
1462       return have_ovl;
1463     }
1464   }
1465   /* Here we have no table: */
1466   /* no_table: */
1467   AMT_AMAGIC_off(&amt);
1468   sv_magic((SV*)stash, 0, PERL_MAGIC_overload_table,
1469                                                 (char*)&amt, sizeof(AMTS));
1470   return FALSE;
1471 }
1472
1473
1474 CV*
1475 Perl_gv_handler(pTHX_ HV *stash, I32 id)
1476 {
1477     MAGIC *mg;
1478     AMT *amtp;
1479
1480     if (!stash || !HvNAME_get(stash))
1481         return Nullcv;
1482     mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
1483     if (!mg) {
1484       do_update:
1485         Gv_AMupdate(stash);
1486         mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
1487     }
1488     amtp = (AMT*)mg->mg_ptr;
1489     if ( amtp->was_ok_am != PL_amagic_generation
1490          || amtp->was_ok_sub != PL_sub_generation )
1491         goto do_update;
1492     if (AMT_AMAGIC(amtp)) {
1493         CV * const ret = amtp->table[id];
1494         if (ret && isGV(ret)) {         /* Autoloading stab */
1495             /* Passing it through may have resulted in a warning
1496                "Inherited AUTOLOAD for a non-method deprecated", since
1497                our caller is going through a function call, not a method call.
1498                So return the CV for AUTOLOAD, setting $AUTOLOAD. */
1499             GV *gv = gv_fetchmethod(stash, PL_AMG_names[id]);
1500
1501             if (gv && GvCV(gv))
1502                 return GvCV(gv);
1503         }
1504         return ret;
1505     }
1506
1507     return Nullcv;
1508 }
1509
1510
1511 SV*
1512 Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
1513 {
1514   dVAR;
1515   MAGIC *mg;
1516   CV *cv=NULL;
1517   CV **cvp=NULL, **ocvp=NULL;
1518   AMT *amtp=NULL, *oamtp=NULL;
1519   int off=0, off1, lr=0, assign=AMGf_assign & flags, notfound=0;
1520   int postpr = 0, force_cpy = 0, assignshift = assign ? 1 : 0;
1521 #ifdef DEBUGGING
1522   int fl=0;
1523 #endif
1524   HV* stash=NULL;
1525   if (!(AMGf_noleft & flags) && SvAMAGIC(left)
1526       && (stash = SvSTASH(SvRV(left)))
1527       && (mg = mg_find((SV*)stash, PERL_MAGIC_overload_table))
1528       && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
1529                         ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
1530                         : (CV **) NULL))
1531       && ((cv = cvp[off=method+assignshift])
1532           || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
1533                                                           * usual method */
1534                   (
1535 #ifdef DEBUGGING
1536                    fl = 1,
1537 #endif
1538                    cv = cvp[off=method])))) {
1539     lr = -1;                    /* Call method for left argument */
1540   } else {
1541     if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) {
1542       int logic;
1543
1544       /* look for substituted methods */
1545       /* In all the covered cases we should be called with assign==0. */
1546          switch (method) {
1547          case inc_amg:
1548            force_cpy = 1;
1549            if ((cv = cvp[off=add_ass_amg])
1550                || ((cv = cvp[off = add_amg]) && (force_cpy = 0, postpr = 1))) {
1551              right = &PL_sv_yes; lr = -1; assign = 1;
1552            }
1553            break;
1554          case dec_amg:
1555            force_cpy = 1;
1556            if ((cv = cvp[off = subtr_ass_amg])
1557                || ((cv = cvp[off = subtr_amg]) && (force_cpy = 0, postpr=1))) {
1558              right = &PL_sv_yes; lr = -1; assign = 1;
1559            }
1560            break;
1561          case bool__amg:
1562            (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg]));
1563            break;
1564          case numer_amg:
1565            (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg]));
1566            break;
1567          case string_amg:
1568            (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg]));
1569            break;
1570          case not_amg:
1571            (void)((cv = cvp[off=bool__amg])
1572                   || (cv = cvp[off=numer_amg])
1573                   || (cv = cvp[off=string_amg]));
1574            postpr = 1;
1575            break;
1576          case copy_amg:
1577            {
1578              /*
1579                   * SV* ref causes confusion with the interpreter variable of
1580                   * the same name
1581                   */
1582              SV* tmpRef=SvRV(left);
1583              if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) {
1584                 /*
1585                  * Just to be extra cautious.  Maybe in some
1586                  * additional cases sv_setsv is safe, too.
1587                  */
1588                 SV* newref = newSVsv(tmpRef);
1589                 SvOBJECT_on(newref);
1590                 SvSTASH_set(newref, (HV*)SvREFCNT_inc(SvSTASH(tmpRef)));
1591                 return newref;
1592              }
1593            }
1594            break;
1595          case abs_amg:
1596            if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg])
1597                && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) {
1598              SV* nullsv=sv_2mortal(newSViv(0));
1599              if (off1==lt_amg) {
1600                SV* lessp = amagic_call(left,nullsv,
1601                                        lt_amg,AMGf_noright);
1602                logic = SvTRUE(lessp);
1603              } else {
1604                SV* lessp = amagic_call(left,nullsv,
1605                                        ncmp_amg,AMGf_noright);
1606                logic = (SvNV(lessp) < 0);
1607              }
1608              if (logic) {
1609                if (off==subtr_amg) {
1610                  right = left;
1611                  left = nullsv;
1612                  lr = 1;
1613                }
1614              } else {
1615                return left;
1616              }
1617            }
1618            break;
1619          case neg_amg:
1620            if ((cv = cvp[off=subtr_amg])) {
1621              right = left;
1622              left = sv_2mortal(newSViv(0));
1623              lr = 1;
1624            }
1625            break;
1626          case int_amg:
1627          case iter_amg:                 /* XXXX Eventually should do to_gv. */
1628              /* FAIL safe */
1629              return NULL;       /* Delegate operation to standard mechanisms. */
1630              break;
1631          case to_sv_amg:
1632          case to_av_amg:
1633          case to_hv_amg:
1634          case to_gv_amg:
1635          case to_cv_amg:
1636              /* FAIL safe */
1637              return left;       /* Delegate operation to standard mechanisms. */
1638              break;
1639          default:
1640            goto not_found;
1641          }
1642          if (!cv) goto not_found;
1643     } else if (!(AMGf_noright & flags) && SvAMAGIC(right)
1644                && (stash = SvSTASH(SvRV(right)))
1645                && (mg = mg_find((SV*)stash, PERL_MAGIC_overload_table))
1646                && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
1647                           ? (amtp = (AMT*)mg->mg_ptr)->table
1648                           : (CV **) NULL))
1649                && (cv = cvp[off=method])) { /* Method for right
1650                                              * argument found */
1651       lr=1;
1652     } else if (((ocvp && oamtp->fallback > AMGfallNEVER
1653                  && (cvp=ocvp) && (lr = -1))
1654                 || (cvp && amtp->fallback > AMGfallNEVER && (lr=1)))
1655                && !(flags & AMGf_unary)) {
1656                                 /* We look for substitution for
1657                                  * comparison operations and
1658                                  * concatenation */
1659       if (method==concat_amg || method==concat_ass_amg
1660           || method==repeat_amg || method==repeat_ass_amg) {
1661         return NULL;            /* Delegate operation to string conversion */
1662       }
1663       off = -1;
1664       switch (method) {
1665          case lt_amg:
1666          case le_amg:
1667          case gt_amg:
1668          case ge_amg:
1669          case eq_amg:
1670          case ne_amg:
1671            postpr = 1; off=ncmp_amg; break;
1672          case slt_amg:
1673          case sle_amg:
1674          case sgt_amg:
1675          case sge_amg:
1676          case seq_amg:
1677          case sne_amg:
1678            postpr = 1; off=scmp_amg; break;
1679          }
1680       if (off != -1) cv = cvp[off];
1681       if (!cv) {
1682         goto not_found;
1683       }
1684     } else {
1685     not_found:                  /* No method found, either report or croak */
1686       switch (method) {
1687          case to_sv_amg:
1688          case to_av_amg:
1689          case to_hv_amg:
1690          case to_gv_amg:
1691          case to_cv_amg:
1692              /* FAIL safe */
1693              return left;       /* Delegate operation to standard mechanisms. */
1694              break;
1695       }
1696       if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */
1697         notfound = 1; lr = -1;
1698       } else if (cvp && (cv=cvp[nomethod_amg])) {
1699         notfound = 1; lr = 1;
1700       } else {
1701         SV *msg;
1702         if (off==-1) off=method;
1703         msg = sv_2mortal(Perl_newSVpvf(aTHX_
1704                       "Operation \"%s\": no method found,%sargument %s%s%s%s",
1705                       AMG_id2name(method + assignshift),
1706                       (flags & AMGf_unary ? " " : "\n\tleft "),
1707                       SvAMAGIC(left)?
1708                         "in overloaded package ":
1709                         "has no overloaded magic",
1710                       SvAMAGIC(left)?
1711                         HvNAME_get(SvSTASH(SvRV(left))):
1712                         "",
1713                       SvAMAGIC(right)?
1714                         ",\n\tright argument in overloaded package ":
1715                         (flags & AMGf_unary
1716                          ? ""
1717                          : ",\n\tright argument has no overloaded magic"),
1718                       SvAMAGIC(right)?
1719                         HvNAME_get(SvSTASH(SvRV(right))):
1720                         ""));
1721         if (amtp && amtp->fallback >= AMGfallYES) {
1722           DEBUG_o( Perl_deb(aTHX_ "%s", SvPVX_const(msg)) );
1723         } else {
1724           Perl_croak(aTHX_ "%"SVf, msg);
1725         }
1726         return NULL;
1727       }
1728       force_cpy = force_cpy || assign;
1729     }
1730   }
1731 #ifdef DEBUGGING
1732   if (!notfound) {
1733     DEBUG_o(Perl_deb(aTHX_
1734                      "Overloaded operator \"%s\"%s%s%s:\n\tmethod%s found%s in package %s%s\n",
1735                      AMG_id2name(off),
1736                      method+assignshift==off? "" :
1737                      " (initially \"",
1738                      method+assignshift==off? "" :
1739                      AMG_id2name(method+assignshift),
1740                      method+assignshift==off? "" : "\")",
1741                      flags & AMGf_unary? "" :
1742                      lr==1 ? " for right argument": " for left argument",
1743                      flags & AMGf_unary? " for argument" : "",
1744                      stash ? HvNAME_get(stash) : "null",
1745                      fl? ",\n\tassignment variant used": "") );
1746   }
1747 #endif
1748     /* Since we use shallow copy during assignment, we need
1749      * to dublicate the contents, probably calling user-supplied
1750      * version of copy operator
1751      */
1752     /* We need to copy in following cases:
1753      * a) Assignment form was called.
1754      *          assignshift==1,  assign==T, method + 1 == off
1755      * b) Increment or decrement, called directly.
1756      *          assignshift==0,  assign==0, method + 0 == off
1757      * c) Increment or decrement, translated to assignment add/subtr.
1758      *          assignshift==0,  assign==T,
1759      *          force_cpy == T
1760      * d) Increment or decrement, translated to nomethod.
1761      *          assignshift==0,  assign==0,
1762      *          force_cpy == T
1763      * e) Assignment form translated to nomethod.
1764      *          assignshift==1,  assign==T, method + 1 != off
1765      *          force_cpy == T
1766      */
1767     /*  off is method, method+assignshift, or a result of opcode substitution.
1768      *  In the latter case assignshift==0, so only notfound case is important.
1769      */
1770   if (( (method + assignshift == off)
1771         && (assign || (method == inc_amg) || (method == dec_amg)))
1772       || force_cpy)
1773     RvDEEPCP(left);
1774   {
1775     dSP;
1776     BINOP myop;
1777     SV* res;
1778     const bool oldcatch = CATCH_GET;
1779
1780     CATCH_SET(TRUE);
1781     Zero(&myop, 1, BINOP);
1782     myop.op_last = (OP *) &myop;
1783     myop.op_next = Nullop;
1784     myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
1785
1786     PUSHSTACKi(PERLSI_OVERLOAD);
1787     ENTER;
1788     SAVEOP();
1789     PL_op = (OP *) &myop;
1790     if (PERLDB_SUB && PL_curstash != PL_debstash)
1791         PL_op->op_private |= OPpENTERSUB_DB;
1792     PUTBACK;
1793     pp_pushmark();
1794
1795     EXTEND(SP, notfound + 5);
1796     PUSHs(lr>0? right: left);
1797     PUSHs(lr>0? left: right);
1798     PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no ));
1799     if (notfound) {
1800       PUSHs( sv_2mortal(newSVpv(AMG_id2name(method + assignshift),0)));
1801     }
1802     PUSHs((SV*)cv);
1803     PUTBACK;
1804
1805     if ((PL_op = Perl_pp_entersub(aTHX)))
1806       CALLRUNOPS(aTHX);
1807     LEAVE;
1808     SPAGAIN;
1809
1810     res=POPs;
1811     PUTBACK;
1812     POPSTACK;
1813     CATCH_SET(oldcatch);
1814
1815     if (postpr) {
1816       int ans;
1817       switch (method) {
1818       case le_amg:
1819       case sle_amg:
1820         ans=SvIV(res)<=0; break;
1821       case lt_amg:
1822       case slt_amg:
1823         ans=SvIV(res)<0; break;
1824       case ge_amg:
1825       case sge_amg:
1826         ans=SvIV(res)>=0; break;
1827       case gt_amg:
1828       case sgt_amg:
1829         ans=SvIV(res)>0; break;
1830       case eq_amg:
1831       case seq_amg:
1832         ans=SvIV(res)==0; break;
1833       case ne_amg:
1834       case sne_amg:
1835         ans=SvIV(res)!=0; break;
1836       case inc_amg:
1837       case dec_amg:
1838         SvSetSV(left,res); return left;
1839       case not_amg:
1840         ans=!SvTRUE(res); break;
1841       default:
1842         ans=0; break;
1843       }
1844       return boolSV(ans);
1845     } else if (method==copy_amg) {
1846       if (!SvROK(res)) {
1847         Perl_croak(aTHX_ "Copy method did not return a reference");
1848       }
1849       return SvREFCNT_inc(SvRV(res));
1850     } else {
1851       return res;
1852     }
1853   }
1854 }
1855
1856 /*
1857 =for apidoc is_gv_magical_sv
1858
1859 Returns C<TRUE> if given the name of a magical GV. Calls is_gv_magical.
1860
1861 =cut
1862 */
1863
1864 bool
1865 Perl_is_gv_magical_sv(pTHX_ SV *name, U32 flags)
1866 {
1867     STRLEN len;
1868     const char *temp = SvPV(name, len);
1869     return is_gv_magical(temp, len, flags);
1870 }
1871
1872 /*
1873 =for apidoc is_gv_magical
1874
1875 Returns C<TRUE> if given the name of a magical GV.
1876
1877 Currently only useful internally when determining if a GV should be
1878 created even in rvalue contexts.
1879
1880 C<flags> is not used at present but available for future extension to
1881 allow selecting particular classes of magical variable.
1882
1883 Currently assumes that C<name> is NUL terminated (as well as len being valid).
1884 This assumption is met by all callers within the perl core, which all pass
1885 pointers returned by SvPV.
1886
1887 =cut
1888 */
1889 bool
1890 Perl_is_gv_magical(pTHX_ const char *name, STRLEN len, U32 flags)
1891 {
1892     (void)flags;
1893     if (len > 1) {
1894         const char *name1 = name + 1;
1895         switch (*name) {
1896         case 'I':
1897             if (len == 3 && name1[1] == 'S' && name[2] == 'A')
1898                 goto yes;
1899             break;
1900         case 'O':
1901             if (len == 8 && strEQ(name1, "VERLOAD"))
1902                 goto yes;
1903             break;
1904         case 'S':
1905             if (len == 3 && name[1] == 'I' && name[2] == 'G')
1906                 goto yes;
1907             break;
1908             /* Using ${^...} variables is likely to be sufficiently rare that
1909                it seems sensible to avoid the space hit of also checking the
1910                length.  */
1911         case '\017':   /* ${^OPEN} */
1912             if (strEQ(name1, "PEN"))
1913                 goto yes;
1914             break;
1915         case '\024':   /* ${^TAINT} */
1916             if (strEQ(name1, "AINT"))
1917                 goto yes;
1918             break;
1919         case '\025':    /* ${^UNICODE} */
1920             if (strEQ(name1, "NICODE"))
1921                 goto yes;
1922             if (strEQ(name1, "TF8LOCALE"))
1923                 goto yes;
1924             break;
1925         case '\027':   /* ${^WARNING_BITS} */
1926             if (strEQ(name1, "ARNING_BITS"))
1927                 goto yes;
1928             break;
1929         case '1':
1930         case '2':
1931         case '3':
1932         case '4':
1933         case '5':
1934         case '6':
1935         case '7':
1936         case '8':
1937         case '9':
1938         {
1939             const char *end = name + len;
1940             while (--end > name) {
1941                 if (!isDIGIT(*end))
1942                     return FALSE;
1943             }
1944             goto yes;
1945         }
1946         }
1947     } else {
1948         /* Because we're already assuming that name is NUL terminated
1949            below, we can treat an empty name as "\0"  */
1950         switch (*name) {
1951         case '&':
1952         case '`':
1953         case '\'':
1954         case ':':
1955         case '?':
1956         case '!':
1957         case '-':
1958         case '#':
1959         case '[':
1960         case '^':
1961         case '~':
1962         case '=':
1963         case '%':
1964         case '.':
1965         case '(':
1966         case ')':
1967         case '<':
1968         case '>':
1969         case ',':
1970         case '\\':
1971         case '/':
1972         case '|':
1973         case '+':
1974         case ';':
1975         case ']':
1976         case '\001':   /* $^A */
1977         case '\003':   /* $^C */
1978         case '\004':   /* $^D */
1979         case '\005':   /* $^E */
1980         case '\006':   /* $^F */
1981         case '\010':   /* $^H */
1982         case '\011':   /* $^I, NOT \t in EBCDIC */
1983         case '\014':   /* $^L */
1984         case '\016':   /* $^N */
1985         case '\017':   /* $^O */
1986         case '\020':   /* $^P */
1987         case '\023':   /* $^S */
1988         case '\024':   /* $^T */
1989         case '\026':   /* $^V */
1990         case '\027':   /* $^W */
1991         case '1':
1992         case '2':
1993         case '3':
1994         case '4':
1995         case '5':
1996         case '6':
1997         case '7':
1998         case '8':
1999         case '9':
2000         yes:
2001             return TRUE;
2002         default:
2003             break;
2004         }
2005     }
2006     return FALSE;
2007 }
2008
2009 /*
2010  * Local variables:
2011  * c-indentation-style: bsd
2012  * c-basic-offset: 4
2013  * indent-tabs-mode: t
2014  * End:
2015  *
2016  * ex: set ts=8 sts=4 sw=4 noet:
2017  */