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