Commit | Line | Data |
---|---|---|
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 | ||
46 | GV * | |
47 | gv_AVadd(gv) | |
48 | register GV *gv; | |
49 | { | |
50 | if (!GvAV(gv)) | |
51 | GvAV(gv) = newAV(); | |
52 | return gv; | |
53 | } | |
54 | ||
55 | GV * | |
56 | gv_HVadd(gv) | |
57 | register GV *gv; | |
58 | { | |
59 | if (!GvHV(gv)) | |
60 | GvHV(gv) = newHV(COEFFSIZE); | |
61 | return gv; | |
62 | } | |
63 | ||
64 | GV * | |
65 | gv_fetchfile(name) | |
66 | char *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 | ||
79 | GV * | |
80 | gv_fetchmethod(stash, name) | |
81 | HV* stash; | |
82 | char* 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 | ||
115 | GV * | |
116 | gv_fetchpv(name,add) | |
117 | register char *name; | |
118 | I32 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 | ||
222 | void | |
223 | gv_fullname(sv,gv) | |
224 | SV *sv; | |
225 | GV *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 | ||
237 | void | |
238 | gv_efullname(sv,gv) | |
239 | SV *sv; | |
240 | GV *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 | ||
253 | IO * | |
254 | newIO() | |
255 | { | |
256 | IO *io; | |
257 | ||
258 | Newz(603,io,1,IO); | |
259 | io->page_len = 60; | |
260 | return io; | |
261 | } | |
262 | ||
263 | void | |
264 | gv_check(min,max) | |
265 | I32 min; | |
266 | register 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 | ||
283 | GV * | |
284 | newGVgen() | |
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 | ||
292 | GP* | |
293 | gp_ref(gp) | |
294 | GP* gp; | |
295 | { | |
296 | gp->gp_refcnt++; | |
297 | return gp; | |
298 | ||
299 | } | |
300 | ||
301 | void | |
302 | gp_free(gv) | |
303 | GV* 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 */ | |
338 | AV *GvAVn(gv) | |
339 | register 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 | ||
347 | HV *GvHVn(gv) | |
348 | register 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 | ||
357 | GV * | |
358 | fetch_gv(op,num) | |
359 | OP *op; | |
360 | I32 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 | ||
370 | IO * | |
371 | fetch_io(op,num) | |
372 | OP *op; | |
373 | I32 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 | } |