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 | ||
463ee0b2 | 46 | extern char rcsid[]; |
93a17b20 | 47 | |
79072805 LW |
48 | GV * |
49 | gv_AVadd(gv) | |
50 | register GV *gv; | |
51 | { | |
52 | if (!GvAV(gv)) | |
53 | GvAV(gv) = newAV(); | |
54 | return gv; | |
55 | } | |
56 | ||
57 | GV * | |
58 | gv_HVadd(gv) | |
59 | register GV *gv; | |
60 | { | |
61 | if (!GvHV(gv)) | |
463ee0b2 | 62 | GvHV(gv) = newHV(); |
79072805 LW |
63 | return gv; |
64 | } | |
65 | ||
66 | GV * | |
67 | gv_fetchfile(name) | |
68 | char *name; | |
69 | { | |
70 | char tmpbuf[1200]; | |
71 | GV *gv; | |
72 | ||
73 | sprintf(tmpbuf,"'_<%s", name); | |
74 | gv = gv_fetchpv(tmpbuf, TRUE); | |
75 | sv_setpv(GvSV(gv), name); | |
76 | if (perldb) | |
93a17b20 | 77 | hv_magic(GvHVn(gv_AVadd(gv)), gv, 'L'); |
79072805 LW |
78 | return gv; |
79 | } | |
80 | ||
463ee0b2 LW |
81 | void |
82 | gv_init(gv, stash, name, len, multi) | |
83 | GV *gv; | |
84 | HV *stash; | |
85 | char *name; | |
86 | STRLEN len; | |
87 | int multi; | |
88 | { | |
89 | register GP *gp; | |
90 | ||
91 | sv_upgrade(gv, SVt_PVGV); | |
92 | if (SvLEN(gv)) | |
93 | Safefree(SvPVX(gv)); | |
94 | Newz(602,gp, 1, GP); | |
95 | GvGP(gv) = gp; | |
96 | GvREFCNT(gv) = 1; | |
97 | GvSV(gv) = NEWSV(72,0); | |
98 | GvLINE(gv) = curcop->cop_line; | |
99 | GvEGV(gv) = gv; | |
100 | sv_magic((SV*)gv, (SV*)gv, '*', name, len); | |
101 | GvSTASH(gv) = stash; | |
102 | GvNAME(gv) = nsavestr(name, len); | |
103 | GvNAMELEN(gv) = len; | |
104 | if (multi) | |
105 | SvMULTI_on(gv); | |
106 | } | |
107 | ||
79072805 | 108 | GV * |
463ee0b2 | 109 | gv_fetchmeth(stash, name, len) |
79072805 LW |
110 | HV* stash; |
111 | char* name; | |
463ee0b2 | 112 | STRLEN len; |
79072805 LW |
113 | { |
114 | AV* av; | |
463ee0b2 | 115 | GV* topgv; |
79072805 | 116 | GV* gv; |
463ee0b2 LW |
117 | GV** gvp; |
118 | ||
119 | gvp = (GV**)hv_fetch(stash, name, len, TRUE); | |
120 | ||
121 | DEBUG_o( deb("Looking for method %s in package %s\n",name,HvNAME(stash)) ); | |
122 | topgv = *gvp; | |
123 | if (SvTYPE(topgv) != SVt_PVGV) | |
124 | gv_init(topgv, stash, name, len, TRUE); | |
125 | ||
126 | if (GvCV(topgv)) { | |
127 | if (!GvCVGEN(topgv) || GvCVGEN(topgv) >= sub_generation) | |
128 | return topgv; | |
129 | } | |
79072805 LW |
130 | |
131 | gvp = (GV**)hv_fetch(stash,"ISA",3,FALSE); | |
132 | if (gvp && (gv = *gvp) != (GV*)&sv_undef && (av = GvAV(gv))) { | |
133 | SV** svp = AvARRAY(av); | |
134 | I32 items = AvFILL(av) + 1; | |
135 | while (items--) { | |
79072805 | 136 | SV* sv = *svp++; |
9bbf4081 LW |
137 | HV* basestash = fetch_stash(sv, FALSE); |
138 | if (!basestash) { | |
79072805 LW |
139 | if (dowarn) |
140 | warn("Can't locate package %s for @%s'ISA", | |
463ee0b2 | 141 | SvPVX(sv), HvNAME(stash)); |
79072805 LW |
142 | continue; |
143 | } | |
9bbf4081 | 144 | gv = gv_fetchmeth(basestash, name, len); |
463ee0b2 LW |
145 | if (gv) { |
146 | GvCV(topgv) = GvCV(gv); /* cache the CV */ | |
147 | GvCVGEN(topgv) = sub_generation; /* valid for now */ | |
79072805 | 148 | return gv; |
463ee0b2 | 149 | } |
79072805 LW |
150 | } |
151 | } | |
152 | return 0; | |
153 | } | |
154 | ||
155 | GV * | |
463ee0b2 LW |
156 | gv_fetchmethod(stash, name) |
157 | HV* stash; | |
158 | char* name; | |
159 | { | |
160 | register char *nend; | |
161 | ||
162 | for (nend = name; *nend; nend++) { | |
163 | if (*nend == ':' || *nend == '\'') { | |
164 | return gv_fetchpv(name, FALSE); | |
165 | } | |
166 | } | |
167 | return gv_fetchmeth(stash, name, nend - name); | |
168 | } | |
169 | ||
170 | GV * | |
171 | gv_fetchpv(nambeg,add) | |
172 | char *nambeg; | |
79072805 LW |
173 | I32 add; |
174 | { | |
463ee0b2 LW |
175 | register char *name = nambeg; |
176 | register GV *gv = 0; | |
79072805 | 177 | GV**gvp; |
79072805 LW |
178 | I32 len; |
179 | register char *namend; | |
463ee0b2 | 180 | HV *stash = 0; |
79072805 | 181 | bool global = FALSE; |
463ee0b2 | 182 | char tmpbuf[256]; |
79072805 | 183 | |
79072805 | 184 | for (namend = name; *namend; namend++) { |
463ee0b2 LW |
185 | if ((*namend == '\'' && namend[1]) || |
186 | (*namend == ':' && namend[1] == ':')) | |
187 | { | |
188 | len = namend - name; | |
79072805 | 189 | *tmpbuf = '_'; |
463ee0b2 LW |
190 | Copy(name, tmpbuf+1, len, char); |
191 | len++; | |
192 | tmpbuf[len] = '\0'; | |
193 | if (!stash) | |
194 | stash = defstash; | |
195 | ||
196 | if (len > 1) { | |
197 | gvp = (GV**)hv_fetch(stash,tmpbuf,len,add); | |
198 | if (!gvp || *gvp == (GV*)&sv_undef) | |
199 | return Nullgv; | |
200 | gv = *gvp; | |
201 | if (SvTYPE(gv) == SVt_PVGV) | |
202 | SvMULTI_on(gv); | |
203 | else | |
204 | gv_init(gv, stash, nambeg, namend - nambeg, (add & 2)); | |
205 | if (!(stash = GvHV(gv))) | |
206 | stash = GvHV(gv) = newHV(); | |
207 | if (!HvNAME(stash)) | |
208 | HvNAME(stash) = nsavestr(nambeg, namend - nambeg); | |
209 | } | |
210 | ||
211 | if (*namend == ':') | |
212 | namend++; | |
213 | namend++; | |
214 | name = namend; | |
215 | if (!*name) | |
216 | return gv ? gv : defgv; | |
79072805 | 217 | } |
79072805 | 218 | } |
463ee0b2 LW |
219 | |
220 | /* No stash in name, so see how we can default */ | |
221 | ||
222 | if (!stash) { | |
223 | if (isIDFIRST(*name)) { | |
224 | if (isUPPER(*name)) { | |
225 | if (*name > 'I') { | |
226 | if (*name == 'S' && ( | |
227 | strEQ(name, "SIG") || | |
228 | strEQ(name, "STDIN") || | |
229 | strEQ(name, "STDOUT") || | |
230 | strEQ(name, "STDERR") )) | |
231 | global = TRUE; | |
232 | } | |
233 | else if (*name > 'E') { | |
234 | if (*name == 'I' && strEQ(name, "INC")) | |
235 | global = TRUE; | |
236 | } | |
237 | else if (*name > 'A') { | |
238 | if (*name == 'E' && strEQ(name, "ENV")) | |
239 | global = TRUE; | |
240 | } | |
241 | else if (*name == 'A' && ( | |
242 | strEQ(name, "ARGV") || | |
243 | strEQ(name, "ARGVOUT") )) | |
244 | global = TRUE; | |
245 | } | |
246 | else if (*name == '_' && !name[1]) | |
247 | global = TRUE; | |
248 | if (global) | |
249 | stash = defstash; | |
250 | else if ((COP*)curcop == &compiling) | |
251 | stash = curstash; | |
252 | else | |
253 | stash = curcop->cop_stash; | |
254 | } | |
255 | else | |
256 | stash = defstash; | |
257 | } | |
258 | ||
259 | /* By this point we should have a stash and a name */ | |
260 | ||
93a17b20 | 261 | if (!stash) |
463ee0b2 | 262 | croak("Global symbol \"%s\" requires explicit package name", name); |
79072805 | 263 | len = namend - name; |
463ee0b2 LW |
264 | if (!len) |
265 | len = 1; | |
79072805 LW |
266 | gvp = (GV**)hv_fetch(stash,name,len,add); |
267 | if (!gvp || *gvp == (GV*)&sv_undef) | |
268 | return Nullgv; | |
269 | gv = *gvp; | |
270 | if (SvTYPE(gv) == SVt_PVGV) { | |
271 | SvMULTI_on(gv); | |
272 | return gv; | |
273 | } | |
93a17b20 LW |
274 | |
275 | /* Adding a new symbol */ | |
276 | ||
463ee0b2 | 277 | gv_init(gv, stash, name, len, add & 2); |
93a17b20 LW |
278 | |
279 | /* set up magic where warranted */ | |
280 | switch (*name) { | |
ed6116ce LW |
281 | case 'a': |
282 | case 'b': | |
283 | if (len == 1) | |
284 | SvMULTI_on(gv); | |
285 | break; | |
463ee0b2 LW |
286 | case 'I': |
287 | if (strEQ(name, "ISA")) { | |
288 | AV* av = GvAVn(gv); | |
289 | sv_magic((SV*)av, (SV*)gv, 'I', 0, 0); | |
290 | } | |
291 | break; | |
93a17b20 LW |
292 | case 'S': |
293 | if (strEQ(name, "SIG")) { | |
294 | HV *hv; | |
295 | siggv = gv; | |
296 | SvMULTI_on(siggv); | |
297 | hv = GvHVn(siggv); | |
298 | hv_magic(hv, siggv, 'S'); | |
299 | ||
300 | /* initialize signal stack */ | |
301 | signalstack = newAV(); | |
302 | av_store(signalstack, 32, Nullsv); | |
303 | av_clear(signalstack); | |
304 | AvREAL_off(signalstack); | |
305 | } | |
306 | break; | |
307 | ||
308 | case '&': | |
463ee0b2 LW |
309 | if (len > 1) |
310 | break; | |
93a17b20 LW |
311 | ampergv = gv; |
312 | sawampersand = TRUE; | |
313 | goto magicalize; | |
314 | ||
315 | case '`': | |
463ee0b2 LW |
316 | if (len > 1) |
317 | break; | |
93a17b20 LW |
318 | leftgv = gv; |
319 | sawampersand = TRUE; | |
320 | goto magicalize; | |
321 | ||
322 | case '\'': | |
463ee0b2 LW |
323 | if (len > 1) |
324 | break; | |
93a17b20 LW |
325 | rightgv = gv; |
326 | sawampersand = TRUE; | |
327 | goto magicalize; | |
328 | ||
329 | case ':': | |
463ee0b2 LW |
330 | if (len > 1) |
331 | break; | |
93a17b20 LW |
332 | sv_setpv(GvSV(gv),chopset); |
333 | goto magicalize; | |
334 | ||
335 | case '!': | |
336 | case '#': | |
337 | case '?': | |
338 | case '^': | |
339 | case '~': | |
340 | case '=': | |
341 | case '-': | |
342 | case '%': | |
343 | case '.': | |
344 | case '+': | |
345 | case '*': | |
346 | case '(': | |
347 | case ')': | |
348 | case '<': | |
349 | case '>': | |
350 | case ',': | |
351 | case '\\': | |
352 | case '/': | |
353 | case '[': | |
354 | case '|': | |
355 | case '\004': | |
356 | case '\t': | |
357 | case '\020': | |
358 | case '\024': | |
359 | case '\027': | |
360 | case '\006': | |
463ee0b2 LW |
361 | if (len > 1) |
362 | break; | |
363 | goto magicalize; | |
364 | ||
365 | case '1': | |
366 | case '2': | |
367 | case '3': | |
368 | case '4': | |
369 | case '5': | |
370 | case '6': | |
371 | case '7': | |
372 | case '8': | |
373 | case '9': | |
93a17b20 | 374 | magicalize: |
463ee0b2 | 375 | sv_magic(GvSV(gv), (SV*)gv, 0, name, len); |
93a17b20 LW |
376 | break; |
377 | ||
378 | case '\014': | |
463ee0b2 LW |
379 | if (len > 1) |
380 | break; | |
93a17b20 LW |
381 | sv_setpv(GvSV(gv),"\f"); |
382 | formfeed = GvSV(gv); | |
383 | break; | |
384 | case ';': | |
463ee0b2 LW |
385 | if (len > 1) |
386 | break; | |
93a17b20 LW |
387 | sv_setpv(GvSV(gv),"\034"); |
388 | break; | |
463ee0b2 LW |
389 | case ']': |
390 | if (len == 1) { | |
93a17b20 LW |
391 | SV *sv; |
392 | sv = GvSV(gv); | |
393 | sv_upgrade(sv, SVt_PVNV); | |
394 | sv_setpv(sv,rcsid); | |
463ee0b2 | 395 | SvNVX(sv) = atof(patchlevel); |
93a17b20 LW |
396 | SvNOK_on(sv); |
397 | } | |
398 | break; | |
79072805 | 399 | } |
93a17b20 | 400 | return gv; |
79072805 LW |
401 | } |
402 | ||
403 | void | |
404 | gv_fullname(sv,gv) | |
405 | SV *sv; | |
406 | GV *gv; | |
407 | { | |
408 | HV *hv = GvSTASH(gv); | |
409 | ||
410 | if (!hv) | |
411 | return; | |
412 | sv_setpv(sv, sv == (SV*)gv ? "*" : ""); | |
413 | sv_catpv(sv,HvNAME(hv)); | |
463ee0b2 | 414 | sv_catpvn(sv,"::", 2); |
79072805 LW |
415 | sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv)); |
416 | } | |
417 | ||
418 | void | |
419 | gv_efullname(sv,gv) | |
420 | SV *sv; | |
421 | GV *gv; | |
422 | { | |
423 | GV* egv = GvEGV(gv); | |
424 | HV *hv = GvSTASH(egv); | |
425 | ||
426 | if (!hv) | |
427 | return; | |
428 | sv_setpv(sv, sv == (SV*)gv ? "*" : ""); | |
429 | sv_catpv(sv,HvNAME(hv)); | |
463ee0b2 | 430 | sv_catpvn(sv,"::", 2); |
79072805 LW |
431 | sv_catpvn(sv,GvNAME(egv),GvNAMELEN(egv)); |
432 | } | |
433 | ||
434 | IO * | |
435 | newIO() | |
436 | { | |
437 | IO *io; | |
438 | ||
439 | Newz(603,io,1,IO); | |
440 | io->page_len = 60; | |
441 | return io; | |
442 | } | |
443 | ||
444 | void | |
463ee0b2 LW |
445 | gv_check(stash) |
446 | HV* stash; | |
79072805 LW |
447 | { |
448 | register HE *entry; | |
449 | register I32 i; | |
450 | register GV *gv; | |
463ee0b2 LW |
451 | HV *hv; |
452 | ||
453 | for (i = 0; i <= HvMAX(stash); i++) { | |
454 | for (entry = HvARRAY(stash)[i]; entry; entry = entry->hent_next) { | |
455 | if (isALPHA(*entry->hent_key)) { | |
456 | gv = (GV*)entry->hent_val; | |
457 | if (SvMULTI(gv)) | |
458 | continue; | |
459 | curcop->cop_line = GvLINE(gv); | |
460 | warn("Possible typo: \"%s::%s\"", HvNAME(stash), GvNAME(gv)); | |
461 | } | |
462 | else if (*entry->hent_key == '_' && | |
463 | (gv = (GV*)entry->hent_val) && | |
464 | (hv = GvHV(gv)) && HvNAME(hv) && hv != defstash) | |
465 | gv_check(hv); /* nested package */ | |
466 | ||
79072805 LW |
467 | } |
468 | } | |
469 | } | |
470 | ||
471 | GV * | |
472 | newGVgen() | |
473 | { | |
474 | (void)sprintf(tokenbuf,"_GEN_%d",gensym++); | |
475 | return gv_fetchpv(tokenbuf,TRUE); | |
476 | } | |
477 | ||
478 | /* hopefully this is only called on local symbol table entries */ | |
479 | ||
480 | GP* | |
481 | gp_ref(gp) | |
482 | GP* gp; | |
483 | { | |
484 | gp->gp_refcnt++; | |
485 | return gp; | |
486 | ||
487 | } | |
488 | ||
489 | void | |
490 | gp_free(gv) | |
491 | GV* gv; | |
492 | { | |
493 | IO *io; | |
494 | CV *cv; | |
495 | GP* gp; | |
496 | ||
497 | if (!gv || !(gp = GvGP(gv))) | |
498 | return; | |
499 | if (gp->gp_refcnt == 0) { | |
500 | warn("Attempt to free unreferenced glob pointers"); | |
501 | return; | |
502 | } | |
503 | if (--gp->gp_refcnt > 0) | |
504 | return; | |
505 | ||
463ee0b2 LW |
506 | sv_free((SV*)gp->gp_sv); |
507 | sv_free((SV*)gp->gp_av); | |
508 | sv_free((SV*)gp->gp_hv); | |
79072805 LW |
509 | if (io = gp->gp_io) { |
510 | do_close(gv,FALSE); | |
511 | Safefree(io->top_name); | |
512 | Safefree(io->fmt_name); | |
513 | Safefree(io); | |
514 | } | |
515 | if (cv = gp->gp_cv) | |
463ee0b2 | 516 | sv_free((SV*)cv); |
79072805 LW |
517 | Safefree(gp); |
518 | GvGP(gv) = 0; | |
519 | } | |
520 | ||
521 | #if defined(CRIPPLED_CC) && (defined(iAPX286) || defined(M_I286) || defined(I80286)) | |
522 | #define MICROPORT | |
523 | #endif | |
524 | ||
525 | #ifdef MICROPORT /* Microport 2.4 hack */ | |
526 | AV *GvAVn(gv) | |
527 | register GV *gv; | |
528 | { | |
529 | if (GvGP(gv)->gp_av) | |
530 | return GvGP(gv)->gp_av; | |
531 | else | |
532 | return GvGP(gv_AVadd(gv))->gp_av; | |
533 | } | |
534 | ||
535 | HV *GvHVn(gv) | |
536 | register GV *gv; | |
537 | { | |
538 | if (GvGP(gv)->gp_hv) | |
539 | return GvGP(gv)->gp_hv; | |
540 | else | |
541 | return GvGP(gv_HVadd(gv))->gp_hv; | |
542 | } | |
543 | #endif /* Microport 2.4 hack */ | |
544 | ||
545 | GV * | |
546 | fetch_gv(op,num) | |
547 | OP *op; | |
548 | I32 num; | |
549 | { | |
550 | if (op->op_private < num) | |
551 | return 0; | |
552 | if (op->op_flags & OPf_STACKED) | |
463ee0b2 | 553 | return gv_fetchpv(SvPVx(*(stack_sp--), na),TRUE); |
79072805 LW |
554 | else |
555 | return cGVOP->op_gv; | |
556 | } | |
557 | ||
558 | IO * | |
559 | fetch_io(op,num) | |
560 | OP *op; | |
561 | I32 num; | |
562 | { | |
563 | GV *gv; | |
564 | ||
565 | if (op->op_private < num) | |
566 | return 0; | |
567 | if (op->op_flags & OPf_STACKED) | |
463ee0b2 | 568 | gv = gv_fetchpv(SvPVx(*(stack_sp--), na),TRUE); |
79072805 LW |
569 | else |
570 | gv = cGVOP->op_gv; | |
571 | ||
572 | if (!gv) | |
573 | return 0; | |
574 | ||
575 | return GvIOn(gv); | |
576 | } |