This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
perl 5.0 alpha 2
[perl5.git] / gv.c
CommitLineData
79072805
LW
1/* $RCSfile: gv.c,v $$Revision: 4.1 $$Date: 92/08/07 18:26:39 $
2 *
3 * Copyright (c) 1991, Larry Wall
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 *
8 * $Log: gv.c,v $
9 * Revision 4.1 92/08/07 18:26:39 lwall
10 *
11 * Revision 4.0.1.4 92/06/08 15:32:19 lwall
12 * patch20: fixed confusion between a *var's real name and its effective name
13 * patch20: the debugger now warns you on lines that can't set a breakpoint
14 * patch20: the debugger made perl forget the last pattern used by //
15 * patch20: paragraph mode now skips extra newlines automatically
16 * patch20: ($<,$>) = ... didn't work on some architectures
17 *
18 * Revision 4.0.1.3 91/11/05 18:35:33 lwall
19 * patch11: length($x) was sometimes wrong for numeric $x
20 * patch11: perl now issues warning if $SIG{'ALARM'} is referenced
21 * patch11: *foo = undef coredumped
22 * patch11: solitary subroutine references no longer trigger typo warnings
23 * patch11: local(*FILEHANDLE) had a memory leak
24 *
25 * Revision 4.0.1.2 91/06/07 11:55:53 lwall
26 * patch4: new copyright notice
27 * patch4: added $^P variable to control calling of perldb routines
28 * patch4: added $^F variable to specify maximum system fd, default 2
29 * patch4: $` was busted inside s///
30 * patch4: default top-of-form run_format is now FILEHANDLE_TOP
31 * patch4: length($`), length($&), length($') now optimized to avoid string copy
32 * patch4: $^D |= 1024 now does syntax tree dump at run-time
33 *
34 * Revision 4.0.1.1 91/04/12 09:10:24 lwall
35 * patch1: Configure now differentiates getgroups() type from getgid() type
36 * patch1: you may now use "die" and "caller" in a signal handler
37 *
38 * Revision 4.0 91/03/20 01:39:41 lwall
39 * 4.0 baseline.
40 *
41 */
42
43#include "EXTERN.h"
44#include "perl.h"
45
46GV *
47gv_AVadd(gv)
48register GV *gv;
49{
50 if (!GvAV(gv))
51 GvAV(gv) = newAV();
52 return gv;
53}
54
55GV *
56gv_HVadd(gv)
57register GV *gv;
58{
59 if (!GvHV(gv))
60 GvHV(gv) = newHV(COEFFSIZE);
61 return gv;
62}
63
64GV *
65gv_fetchfile(name)
66char *name;
67{
68 char tmpbuf[1200];
69 GV *gv;
70
71 sprintf(tmpbuf,"'_<%s", name);
72 gv = gv_fetchpv(tmpbuf, TRUE);
73 sv_setpv(GvSV(gv), name);
74 if (perldb)
75 (void)gv_HVadd(gv_AVadd(gv));
76 return gv;
77}
78
79GV *
80gv_fetchmethod(stash, name)
81HV* stash;
82char* name;
83{
84 AV* av;
85 GV* gv;
86 GV** gvp = (GV**)hv_fetch(stash,name,strlen(name),FALSE);
87 if (gvp && (gv = *gvp) != (GV*)&sv_undef && GvCV(gv))
88 return gv;
89
90 gvp = (GV**)hv_fetch(stash,"ISA",3,FALSE);
91 if (gvp && (gv = *gvp) != (GV*)&sv_undef && (av = GvAV(gv))) {
92 SV** svp = AvARRAY(av);
93 I32 items = AvFILL(av) + 1;
94 while (items--) {
95 char tmpbuf[512];
96 SV* sv = *svp++;
97 *tmpbuf = '_';
98 SvUPGRADE(sv, SVt_PV);
99 strcpy(tmpbuf+1,SvPVn(sv));
100 gv = gv_fetchpv(tmpbuf,FALSE);
101 if (!gv || !(stash = GvHV(gv))) {
102 if (dowarn)
103 warn("Can't locate package %s for @%s'ISA",
104 SvPV(sv), HvNAME(stash));
105 continue;
106 }
107 gv = gv_fetchmethod(stash, name);
108 if (gv)
109 return gv;
110 }
111 }
112 return 0;
113}
114
115GV *
116gv_fetchpv(name,add)
117register char *name;
118I32 add;
119{
120 register GV *gv;
121 GV**gvp;
122 register GP *gp;
123 I32 len;
124 register char *namend;
125 HV *stash;
126 char *sawquote = Nullch;
127 char *prevquote = Nullch;
128 bool global = FALSE;
129
130 if (isUPPER(*name)) {
131 if (*name > 'I') {
132 if (*name == 'S' && (
133 strEQ(name, "SIG") ||
134 strEQ(name, "STDIN") ||
135 strEQ(name, "STDOUT") ||
136 strEQ(name, "STDERR") ))
137 global = TRUE;
138 }
139 else if (*name > 'E') {
140 if (*name == 'I' && strEQ(name, "INC"))
141 global = TRUE;
142 }
143 else if (*name > 'A') {
144 if (*name == 'E' && strEQ(name, "ENV"))
145 global = TRUE;
146 }
147 else if (*name == 'A' && (
148 strEQ(name, "ARGV") ||
149 strEQ(name, "ARGVOUT") ))
150 global = TRUE;
151 }
152 for (namend = name; *namend; namend++) {
153 if (*namend == '\'' && namend[1])
154 prevquote = sawquote, sawquote = namend;
155 }
156 if (sawquote == name && name[1]) {
157 stash = defstash;
158 sawquote = Nullch;
159 name++;
160 }
161 else if (!isALPHA(*name) || global)
162 stash = defstash;
163 else if ((COP*)curcop == &compiling)
164 stash = curstash;
165 else
166 stash = curcop->cop_stash;
167 if (sawquote) {
168 char tmpbuf[256];
169 char *s, *d;
170
171 *sawquote = '\0';
172 /*SUPPRESS 560*/
173 if (s = prevquote) {
174 strncpy(tmpbuf,name,s-name+1);
175 d = tmpbuf+(s-name+1);
176 *d++ = '_';
177 strcpy(d,s+1);
178 }
179 else {
180 *tmpbuf = '_';
181 strcpy(tmpbuf+1,name);
182 }
183 gv = gv_fetchpv(tmpbuf,TRUE);
184 if (!(stash = GvHV(gv)))
185 stash = GvHV(gv) = newHV(0);
186 if (!HvNAME(stash))
187 HvNAME(stash) = savestr(name);
188 name = sawquote+1;
189 *sawquote = '\'';
190 }
191 len = namend - name;
192 gvp = (GV**)hv_fetch(stash,name,len,add);
193 if (!gvp || *gvp == (GV*)&sv_undef)
194 return Nullgv;
195 gv = *gvp;
196 if (SvTYPE(gv) == SVt_PVGV) {
197 SvMULTI_on(gv);
198 return gv;
199 }
200 else {
201 sv_upgrade(gv, SVt_PVGV);
202 if (SvLEN(gv))
203 Safefree(SvPV(gv));
204 Newz(602,gp, 1, GP);
205 GvGP(gv) = gp;
206 GvREFCNT(gv) = 1;
207 GvSV(gv) = NEWSV(72,0);
208 GvLINE(gv) = curcop->cop_line;
209 GvEGV(gv) = gv;
210 sv_magic((SV*)gv, (SV*)gv, '*', name, len);
211 GvSTASH(gv) = stash;
212 GvNAME(gv) = nsavestr(name, len);
213 GvNAMELEN(gv) = len;
214 if (isDIGIT(*name) && *name != '0')
215 sv_magic(GvSV(gv), (SV*)gv, 0, name, len);
216 if (add & 2)
217 SvMULTI_on(gv);
218 return gv;
219 }
220}
221
222void
223gv_fullname(sv,gv)
224SV *sv;
225GV *gv;
226{
227 HV *hv = GvSTASH(gv);
228
229 if (!hv)
230 return;
231 sv_setpv(sv, sv == (SV*)gv ? "*" : "");
232 sv_catpv(sv,HvNAME(hv));
233 sv_catpvn(sv,"'", 1);
234 sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv));
235}
236
237void
238gv_efullname(sv,gv)
239SV *sv;
240GV *gv;
241{
242 GV* egv = GvEGV(gv);
243 HV *hv = GvSTASH(egv);
244
245 if (!hv)
246 return;
247 sv_setpv(sv, sv == (SV*)gv ? "*" : "");
248 sv_catpv(sv,HvNAME(hv));
249 sv_catpvn(sv,"'", 1);
250 sv_catpvn(sv,GvNAME(egv),GvNAMELEN(egv));
251}
252
253IO *
254newIO()
255{
256 IO *io;
257
258 Newz(603,io,1,IO);
259 io->page_len = 60;
260 return io;
261}
262
263void
264gv_check(min,max)
265I32 min;
266register I32 max;
267{
268 register HE *entry;
269 register I32 i;
270 register GV *gv;
271
272 for (i = min; i <= max; i++) {
273 for (entry = HvARRAY(defstash)[i]; entry; entry = entry->hent_next) {
274 gv = (GV*)entry->hent_val;
275 if (SvMULTI(gv))
276 continue;
277 curcop->cop_line = GvLINE(gv);
278 warn("Possible typo: \"%s\"", GvNAME(gv));
279 }
280 }
281}
282
283GV *
284newGVgen()
285{
286 (void)sprintf(tokenbuf,"_GEN_%d",gensym++);
287 return gv_fetchpv(tokenbuf,TRUE);
288}
289
290/* hopefully this is only called on local symbol table entries */
291
292GP*
293gp_ref(gp)
294GP* gp;
295{
296 gp->gp_refcnt++;
297 return gp;
298
299}
300
301void
302gp_free(gv)
303GV* gv;
304{
305 IO *io;
306 CV *cv;
307 GP* gp;
308
309 if (!gv || !(gp = GvGP(gv)))
310 return;
311 if (gp->gp_refcnt == 0) {
312 warn("Attempt to free unreferenced glob pointers");
313 return;
314 }
315 if (--gp->gp_refcnt > 0)
316 return;
317
318 sv_free(gp->gp_sv);
319 sv_free(gp->gp_av);
320 sv_free(gp->gp_hv);
321 if (io = gp->gp_io) {
322 do_close(gv,FALSE);
323 Safefree(io->top_name);
324 Safefree(io->fmt_name);
325 Safefree(io);
326 }
327 if (cv = gp->gp_cv)
328 sv_free(cv);
329 Safefree(gp);
330 GvGP(gv) = 0;
331}
332
333#if defined(CRIPPLED_CC) && (defined(iAPX286) || defined(M_I286) || defined(I80286))
334#define MICROPORT
335#endif
336
337#ifdef MICROPORT /* Microport 2.4 hack */
338AV *GvAVn(gv)
339register GV *gv;
340{
341 if (GvGP(gv)->gp_av)
342 return GvGP(gv)->gp_av;
343 else
344 return GvGP(gv_AVadd(gv))->gp_av;
345}
346
347HV *GvHVn(gv)
348register GV *gv;
349{
350 if (GvGP(gv)->gp_hv)
351 return GvGP(gv)->gp_hv;
352 else
353 return GvGP(gv_HVadd(gv))->gp_hv;
354}
355#endif /* Microport 2.4 hack */
356
357GV *
358fetch_gv(op,num)
359OP *op;
360I32 num;
361{
362 if (op->op_private < num)
363 return 0;
364 if (op->op_flags & OPf_STACKED)
365 return gv_fetchpv(SvPVnx(*(stack_sp--)),TRUE);
366 else
367 return cGVOP->op_gv;
368}
369
370IO *
371fetch_io(op,num)
372OP *op;
373I32 num;
374{
375 GV *gv;
376
377 if (op->op_private < num)
378 return 0;
379 if (op->op_flags & OPf_STACKED)
380 gv = gv_fetchpv(SvPVnx(*(stack_sp--)),TRUE);
381 else
382 gv = cGVOP->op_gv;
383
384 if (!gv)
385 return 0;
386
387 return GvIOn(gv);
388}