This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
perl 3.0 patch #4 Patch #2 continued
[perl5.git] / stab.c
CommitLineData
ae986130 1/* $Header: stab.c,v 3.0.1.1 89/11/11 04:55:07 lwall Locked $
a687059c
LW
2 *
3 * Copyright (c) 1989, Larry Wall
4 *
5 * You may distribute under the terms of the GNU General Public License
6 * as specified in the README file that comes with the perl 3.0 kit.
8d063cd8
LW
7 *
8 * $Log: stab.c,v $
ae986130
LW
9 * Revision 3.0.1.1 89/11/11 04:55:07 lwall
10 * patch2: sys_errlist[sys_nerr] is illegal
11 *
a687059c
LW
12 * Revision 3.0 89/10/18 15:23:23 lwall
13 * 3.0 baseline
8d063cd8
LW
14 *
15 */
16
8d063cd8 17#include "EXTERN.h"
8d063cd8
LW
18#include "perl.h"
19
378cc40b
LW
20#include <signal.h>
21
a687059c
LW
22/* This oughta be generated by Configure. */
23
8d063cd8 24static char *sig_name[] = {
a687059c
LW
25 SIG_NAME,0
26};
8d063cd8 27
2e1b3b7e 28extern int errno;
378cc40b
LW
29extern int sys_nerr;
30extern char *sys_errlist[];
2e1b3b7e 31
8d063cd8 32STR *
a687059c
LW
33stab_str(str)
34STR *str;
8d063cd8 35{
a687059c 36 STAB *stab = str->str_u.str_stab;
8d063cd8
LW
37 register int paren;
38 register char *s;
378cc40b 39 register int i;
8d063cd8 40
a687059c
LW
41 if (str->str_rare)
42 return stab_val(stab);
43
44 switch (*stab->str_magic->str_ptr) {
8d063cd8
LW
45 case '0': case '1': case '2': case '3': case '4':
46 case '5': case '6': case '7': case '8': case '9': case '&':
47 if (curspat) {
a687059c 48 paren = atoi(stab_name(stab));
378cc40b
LW
49 getparen:
50 if (curspat->spat_regexp &&
51 paren <= curspat->spat_regexp->nparens &&
52 (s = curspat->spat_regexp->startp[paren]) ) {
53 i = curspat->spat_regexp->endp[paren] - s;
54 if (i >= 0)
a687059c 55 str_nset(stab_val(stab),s,i);
378cc40b 56 else
a687059c 57 str_sset(stab_val(stab),&str_undef);
8d063cd8 58 }
378cc40b 59 else
a687059c 60 str_sset(stab_val(stab),&str_undef);
8d063cd8
LW
61 }
62 break;
63 case '+':
64 if (curspat) {
378cc40b
LW
65 paren = curspat->spat_regexp->lastparen;
66 goto getparen;
8d063cd8
LW
67 }
68 break;
a687059c
LW
69 case '`':
70 if (curspat) {
71 if (curspat->spat_regexp &&
72 (s = curspat->spat_regexp->subbase) ) {
73 i = curspat->spat_regexp->startp[0] - s;
74 if (i >= 0)
75 str_nset(stab_val(stab),s,i);
76 else
77 str_nset(stab_val(stab),"",0);
78 }
79 else
80 str_nset(stab_val(stab),"",0);
81 }
82 break;
83 case '\'':
84 if (curspat) {
85 if (curspat->spat_regexp &&
86 (s = curspat->spat_regexp->endp[0]) ) {
87 str_set(stab_val(stab),s);
88 }
89 else
90 str_nset(stab_val(stab),"",0);
91 }
92 break;
8d063cd8 93 case '.':
a687059c 94#ifndef lint
8d063cd8 95 if (last_in_stab) {
a687059c 96 str_numset(stab_val(stab),(double)stab_io(last_in_stab)->lines);
8d063cd8 97 }
a687059c 98#endif
8d063cd8
LW
99 break;
100 case '?':
a687059c 101 str_numset(stab_val(stab),(double)statusvalue);
8d063cd8
LW
102 break;
103 case '^':
a687059c
LW
104 s = stab_io(curoutstab)->top_name;
105 str_set(stab_val(stab),s);
8d063cd8
LW
106 break;
107 case '~':
a687059c
LW
108 s = stab_io(curoutstab)->fmt_name;
109 str_set(stab_val(stab),s);
8d063cd8 110 break;
a687059c 111#ifndef lint
8d063cd8 112 case '=':
a687059c 113 str_numset(stab_val(stab),(double)stab_io(curoutstab)->page_len);
8d063cd8
LW
114 break;
115 case '-':
a687059c 116 str_numset(stab_val(stab),(double)stab_io(curoutstab)->lines_left);
8d063cd8
LW
117 break;
118 case '%':
a687059c 119 str_numset(stab_val(stab),(double)stab_io(curoutstab)->page);
8d063cd8 120 break;
a687059c 121#endif
8d063cd8
LW
122 case '/':
123 *tokenbuf = record_separator;
124 tokenbuf[1] = '\0';
a687059c 125 str_nset(stab_val(stab),tokenbuf,rslen);
8d063cd8
LW
126 break;
127 case '[':
a687059c 128 str_numset(stab_val(stab),(double)arybase);
8d063cd8
LW
129 break;
130 case '|':
a687059c
LW
131 str_numset(stab_val(stab),
132 (double)((stab_io(curoutstab)->flags & IOF_FLUSH) != 0) );
8d063cd8
LW
133 break;
134 case ',':
a687059c 135 str_nset(stab_val(stab),ofs,ofslen);
8d063cd8
LW
136 break;
137 case '\\':
a687059c 138 str_nset(stab_val(stab),ors,orslen);
8d063cd8
LW
139 break;
140 case '#':
a687059c 141 str_set(stab_val(stab),ofmt);
8d063cd8
LW
142 break;
143 case '!':
a687059c
LW
144 str_numset(stab_val(stab), (double)errno);
145 str_set(stab_val(stab),
ae986130 146 errno < 0 || errno >= sys_nerr ? "(unknown)" : sys_errlist[errno]);
a687059c 147 stab_val(stab)->str_nok = 1; /* what a wonderful hack! */
378cc40b
LW
148 break;
149 case '<':
a687059c 150 str_numset(stab_val(stab),(double)uid);
378cc40b
LW
151 break;
152 case '>':
a687059c 153 str_numset(stab_val(stab),(double)euid);
378cc40b
LW
154 break;
155 case '(':
a687059c
LW
156 s = buf;
157 (void)sprintf(s,"%d",(int)gid);
378cc40b
LW
158 goto add_groups;
159 case ')':
a687059c
LW
160 s = buf;
161 (void)sprintf(s,"%d",(int)egid);
378cc40b
LW
162 add_groups:
163 while (*s) s++;
164#ifdef GETGROUPS
165#ifndef NGROUPS
166#define NGROUPS 32
167#endif
168 {
169 GIDTYPE gary[NGROUPS];
170
171 i = getgroups(NGROUPS,gary);
172 while (--i >= 0) {
a687059c 173 (void)sprintf(s," %ld", (long)gary[i]);
378cc40b
LW
174 while (*s) s++;
175 }
176 }
177#endif
a687059c 178 str_set(stab_val(stab),buf);
8d063cd8
LW
179 break;
180 }
a687059c 181 return stab_val(stab);
8d063cd8
LW
182}
183
a687059c
LW
184stabset(mstr,str)
185register STR *mstr;
8d063cd8
LW
186STR *str;
187{
a687059c 188 STAB *stab = mstr->str_u.str_stab;
8d063cd8
LW
189 char *s;
190 int i;
191 int sighandler();
192
a687059c
LW
193 switch (mstr->str_rare) {
194 case 'E':
195 setenv(mstr->str_ptr,str_get(str));
196 /* And you'll never guess what the dog had */
197 break; /* in its mouth... */
198 case 'S':
199 s = str_get(str);
200 i = whichsig(mstr->str_ptr); /* ...no, a brick */
201 if (strEQ(s,"IGNORE"))
202#ifndef lint
203 (void)signal(i,SIG_IGN);
204#else
205 ;
206#endif
207 else if (strEQ(s,"DEFAULT") || !*s)
208 (void)signal(i,SIG_DFL);
209 else
210 (void)signal(i,sighandler);
211 break;
212#ifdef SOME_DBM
213 case 'D':
214 hdbmstore(stab_hash(stab),mstr->str_ptr,mstr->str_cur,str);
215 break;
216#endif
217 case '#':
218 afill(stab_array(stab), (int)str_gnum(str) - arybase);
219 break;
220 case 'X': /* merely a copy of a * string */
221 break;
222 case '*':
223 s = str_get(str);
224 if (strnNE(s,"Stab",4) || str->str_cur != sizeof(STBP)) {
225 if (!*s) {
226 STBP *stbp;
227
228 (void)savenostab(stab); /* schedule a free of this stab */
229 if (stab->str_len)
230 Safefree(stab->str_ptr);
231 Newz(601,stbp, 1, STBP);
232 stab->str_ptr = stbp;
233 stab->str_len = stab->str_cur = sizeof(STBP);
234 stab->str_pok = 1;
235 strncpy(stab_magic(stab),"Stab",4);
236 stab_val(stab) = Str_new(70,0);
237 stab_line(stab) = line;
238 }
239 else
240 stab = stabent(s,TRUE);
241 str_sset(str,stab);
242 }
243 break;
244 case 's': {
245 struct lstring *lstr = (struct lstring*)str;
246
247 mstr->str_rare = 0;
248 str->str_magic = Nullstr;
249 str_insert(mstr,lstr->lstr_offset,lstr->lstr_len,
250 str->str_ptr,str->str_cur);
251 }
252 break;
253
254 case 'v':
255 do_vecset(mstr,str);
256 break;
257
258 case 0:
259 switch (*stab->str_magic->str_ptr) {
8d063cd8 260 case '^':
a687059c
LW
261 Safefree(stab_io(curoutstab)->top_name);
262 stab_io(curoutstab)->top_name = s = savestr(str_get(str));
263 stab_io(curoutstab)->top_stab = stabent(s,TRUE);
8d063cd8
LW
264 break;
265 case '~':
a687059c
LW
266 Safefree(stab_io(curoutstab)->fmt_name);
267 stab_io(curoutstab)->fmt_name = s = savestr(str_get(str));
268 stab_io(curoutstab)->fmt_stab = stabent(s,TRUE);
8d063cd8
LW
269 break;
270 case '=':
a687059c 271 stab_io(curoutstab)->page_len = (long)str_gnum(str);
8d063cd8
LW
272 break;
273 case '-':
a687059c
LW
274 stab_io(curoutstab)->lines_left = (long)str_gnum(str);
275 if (stab_io(curoutstab)->lines_left < 0L)
276 stab_io(curoutstab)->lines_left = 0L;
8d063cd8
LW
277 break;
278 case '%':
a687059c 279 stab_io(curoutstab)->page = (long)str_gnum(str);
8d063cd8
LW
280 break;
281 case '|':
a687059c 282 stab_io(curoutstab)->flags &= ~IOF_FLUSH;
8d063cd8 283 if (str_gnum(str) != 0.0) {
a687059c 284 stab_io(curoutstab)->flags |= IOF_FLUSH;
8d063cd8
LW
285 }
286 break;
287 case '*':
a687059c
LW
288 i = (int)str_gnum(str);
289 multiline = (i != 0);
8d063cd8
LW
290 break;
291 case '/':
292 record_separator = *str_get(str);
a687059c 293 rslen = str->str_cur;
8d063cd8
LW
294 break;
295 case '\\':
296 if (ors)
a687059c 297 Safefree(ors);
8d063cd8 298 ors = savestr(str_get(str));
a687059c 299 orslen = str->str_cur;
8d063cd8
LW
300 break;
301 case ',':
302 if (ofs)
a687059c 303 Safefree(ofs);
8d063cd8 304 ofs = savestr(str_get(str));
a687059c 305 ofslen = str->str_cur;
8d063cd8
LW
306 break;
307 case '#':
308 if (ofmt)
a687059c 309 Safefree(ofmt);
8d063cd8
LW
310 ofmt = savestr(str_get(str));
311 break;
312 case '[':
313 arybase = (int)str_gnum(str);
314 break;
378cc40b
LW
315 case '?':
316 statusvalue = (unsigned short)str_gnum(str);
317 break;
8d063cd8
LW
318 case '!':
319 errno = (int)str_gnum(str); /* will anyone ever use this? */
320 break;
378cc40b 321 case '<':
378cc40b 322 uid = (int)str_gnum(str);
a687059c
LW
323#ifdef SETREUID
324 if (delaymagic) {
325 delaymagic |= DM_REUID;
326 break; /* don't do magic till later */
327 }
328#endif /* SETREUID */
329#ifdef SETRUID
330 if (setruid((UIDTYPE)uid) < 0)
331 uid = (int)getuid();
332#else
333#ifdef SETREUID
334 if (setreuid((UIDTYPE)uid, (UIDTYPE)-1) < 0)
378cc40b
LW
335 uid = (int)getuid();
336#else
337 fatal("setruid() not implemented");
338#endif
a687059c 339#endif
378cc40b
LW
340 break;
341 case '>':
378cc40b 342 euid = (int)str_gnum(str);
a687059c
LW
343#ifdef SETREUID
344 if (delaymagic) {
345 delaymagic |= DM_REUID;
346 break; /* don't do magic till later */
347 }
348#endif /* SETREUID */
349#ifdef SETEUID
350 if (seteuid((UIDTYPE)euid) < 0)
351 euid = (int)geteuid();
352#else
353#ifdef SETREUID
354 if (setreuid((UIDTYPE)-1, (UIDTYPE)euid) < 0)
378cc40b
LW
355 euid = (int)geteuid();
356#else
357 fatal("seteuid() not implemented");
358#endif
a687059c 359#endif
378cc40b
LW
360 break;
361 case '(':
a687059c
LW
362 gid = (int)str_gnum(str);
363#ifdef SETREGID
364 if (delaymagic) {
365 delaymagic |= DM_REGID;
366 break; /* don't do magic till later */
367 }
368#endif /* SETREGID */
378cc40b 369#ifdef SETRGID
a687059c
LW
370 (void)setrgid((GIDTYPE)gid);
371#else
372#ifdef SETREGID
373 (void)setregid((GIDTYPE)gid, (GIDTYPE)-1);
378cc40b
LW
374#else
375 fatal("setrgid() not implemented");
376#endif
a687059c 377#endif
378cc40b
LW
378 break;
379 case ')':
a687059c
LW
380 egid = (int)str_gnum(str);
381#ifdef SETREGID
382 if (delaymagic) {
383 delaymagic |= DM_REGID;
384 break; /* don't do magic till later */
385 }
386#endif /* SETREGID */
378cc40b 387#ifdef SETEGID
a687059c
LW
388 (void)setegid((GIDTYPE)egid);
389#else
390#ifdef SETREGID
391 (void)setregid((GIDTYPE)-1, (GIDTYPE)egid);
378cc40b
LW
392#else
393 fatal("setegid() not implemented");
394#endif
a687059c
LW
395#endif
396 break;
397 case ':':
398 chopset = str_get(str);
378cc40b 399 break;
8d063cd8 400 }
a687059c 401 break;
378cc40b 402 }
8d063cd8
LW
403}
404
378cc40b
LW
405whichsig(sig)
406char *sig;
8d063cd8
LW
407{
408 register char **sigv;
409
410 for (sigv = sig_name+1; *sigv; sigv++)
378cc40b 411 if (strEQ(sig,*sigv))
8d063cd8 412 return sigv - sig_name;
a687059c
LW
413#ifdef SIGCLD
414 if (strEQ(sig,"CHLD"))
415 return SIGCLD;
416#endif
417#ifdef SIGCHLD
418 if (strEQ(sig,"CLD"))
419 return SIGCHLD;
420#endif
8d063cd8
LW
421 return 0;
422}
423
424sighandler(sig)
425int sig;
426{
427 STAB *stab;
428 ARRAY *savearray;
429 STR *str;
378cc40b
LW
430 char *oldfile = filename;
431 int oldsave = savestack->ary_fill;
a687059c 432 ARRAY *oldstack = stack;
378cc40b 433 SUBR *sub;
8d063cd8 434
a687059c
LW
435 stab = stabent(
436 str_get(hfetch(stab_hash(sigstab),sig_name[sig],strlen(sig_name[sig]),
437 TRUE)), TRUE);
438 sub = stab_sub(stab);
439 if (!sub && *sig_name[sig] == 'C' && instr(sig_name[sig],"LD")) {
440 if (sig_name[sig][1] == 'H')
441 stab = stabent(str_get(hfetch(stab_hash(sigstab),"CLD",3,TRUE)),
442 TRUE);
443 else
444 stab = stabent(str_get(hfetch(stab_hash(sigstab),"CHLD",4,TRUE)),
445 TRUE);
446 sub = stab_sub(stab); /* gag */
447 }
378cc40b
LW
448 if (!sub) {
449 if (dowarn)
450 warn("SIG%s handler \"%s\" not defined.\n",
a687059c 451 sig_name[sig], stab_name(stab) );
378cc40b
LW
452 return;
453 }
a687059c
LW
454 savearray = stab_xarray(defstab);
455 stab_xarray(defstab) = stack = anew(defstab);
456 stack->ary_flags = 0;
457 str = Str_new(71,0);
8d063cd8 458 str_set(str,sig_name[sig]);
a687059c 459 (void)apush(stab_xarray(defstab),str);
378cc40b
LW
460 sub->depth++;
461 if (sub->depth >= 2) { /* save temporaries on recursion? */
462 if (sub->depth == 100 && dowarn)
a687059c 463 warn("Deep recursion on subroutine \"%s\"",stab_name(stab));
378cc40b
LW
464 savelist(sub->tosave->ary_array,sub->tosave->ary_fill);
465 }
466 filename = sub->filename;
467
a687059c 468 (void)cmd_exec(sub->cmd,G_SCALAR,1); /* so do it already */
378cc40b
LW
469
470 sub->depth--; /* assuming no longjumps out of here */
a687059c
LW
471 str_free(stack->ary_array[0]); /* free the one real string */
472 afree(stab_xarray(defstab)); /* put back old $_[] */
473 stab_xarray(defstab) = savearray;
474 stack = oldstack;
378cc40b
LW
475 filename = oldfile;
476 if (savestack->ary_fill > oldsave)
477 restorelist(oldsave);
8d063cd8
LW
478}
479
8d063cd8
LW
480STAB *
481aadd(stab)
482register STAB *stab;
483{
a687059c
LW
484 if (!stab_xarray(stab))
485 stab_xarray(stab) = anew(stab);
8d063cd8
LW
486 return stab;
487}
488
489STAB *
490hadd(stab)
491register STAB *stab;
492{
a687059c
LW
493 if (!stab_xhash(stab))
494 stab_xhash(stab) = hnew(COEFFSIZE);
8d063cd8
LW
495 return stab;
496}
378cc40b
LW
497
498STAB *
499stabent(name,add)
500register char *name;
501int add;
502{
503 register STAB *stab;
a687059c
LW
504 register STBP *stbp;
505 int len;
506 register char *namend;
507 HASH *stash;
508 char *sawquote = Nullch;
509 char *prevquote = Nullch;
510 bool global = FALSE;
378cc40b 511
a687059c
LW
512 if (isascii(*name) && isupper(*name)) {
513 if (*name > 'I') {
514 if (*name == 'S' && (
515 strEQ(name, "SIG") ||
516 strEQ(name, "STDIN") ||
517 strEQ(name, "STDOUT") ||
518 strEQ(name, "STDERR") ))
519 global = TRUE;
378cc40b 520 }
a687059c
LW
521 else if (*name > 'E') {
522 if (*name == 'I' && strEQ(name, "INC"))
523 global = TRUE;
524 }
525 else if (*name >= 'A') {
526 if (*name == 'E' && strEQ(name, "ENV"))
527 global = TRUE;
528 }
529 else if (*name == 'A' && (
530 strEQ(name, "ARGV") ||
531 strEQ(name, "ARGVOUT") ))
532 global = TRUE;
533 }
534 for (namend = name; *namend; namend++) {
535 if (*namend == '\'' && namend[1])
536 prevquote = sawquote, sawquote = namend;
537 }
538 if (sawquote == name && name[1]) {
539 stash = defstash;
540 sawquote = Nullch;
541 name++;
542 }
543 else if (!isalpha(*name) || global)
544 stash = defstash;
545 else
546 stash = curstash;
547 if (sawquote) {
548 char tmpbuf[256];
549 char *s, *d;
550
551 *sawquote = '\0';
552 if (s = prevquote) {
553 strncpy(tmpbuf,name,s-name+1);
554 d = tmpbuf+(s-name+1);
555 *d++ = '_';
556 strcpy(d,s+1);
557 }
558 else {
559 *tmpbuf = '_';
560 strcpy(tmpbuf+1,name);
561 }
562 stab = stabent(tmpbuf,TRUE);
563 if (!(stash = stab_xhash(stab)))
564 stash = stab_xhash(stab) = hnew(0);
565 name = sawquote+1;
566 *sawquote = '\'';
378cc40b 567 }
a687059c
LW
568 len = namend - name;
569 stab = (STAB*)hfetch(stash,name,len,add);
570 if (!stab)
571 return Nullstab;
572 if (stab->str_pok) {
573 stab->str_pok |= SP_MULTI;
574 return stab;
575 }
576 else {
577 if (stab->str_len)
578 Safefree(stab->str_ptr);
579 Newz(602,stbp, 1, STBP);
580 stab->str_ptr = stbp;
581 stab->str_len = stab->str_cur = sizeof(STBP);
582 stab->str_pok = 1;
583 strncpy(stab_magic(stab),"Stab",4);
584 stab_val(stab) = Str_new(72,0);
585 stab_line(stab) = line;
586 str_magic(stab,stab,'*',name,len);
378cc40b
LW
587 return stab;
588 }
378cc40b
LW
589}
590
591STIO *
592stio_new()
593{
a687059c 594 STIO *stio;
378cc40b 595
a687059c 596 Newz(603,stio,1,STIO);
378cc40b
LW
597 stio->page_len = 60;
598 return stio;
599}
600
601stab_check(min,max)
602int min;
603register int max;
604{
a687059c 605 register HENT *entry;
378cc40b
LW
606 register int i;
607 register STAB *stab;
608
609 for (i = min; i <= max; i++) {
a687059c
LW
610 for (entry = defstash->tbl_array[i]; entry; entry = entry->hent_next) {
611 stab = (STAB*)entry->hent_val;
612 if (stab->str_pok & SP_MULTI)
378cc40b 613 continue;
a687059c
LW
614 line = stab_line(stab);
615 warn("Possible typo: \"%s\"", stab_name(stab));
378cc40b
LW
616 }
617 }
618}
a687059c
LW
619
620static int gensym = 0;
621
622STAB *
623genstab()
624{
625 (void)sprintf(tokenbuf,"_GEN_%d",gensym++);
626 return stabent(tokenbuf,TRUE);
627}
628
629/* hopefully this is only called on local symbol table entries */
630
631void
632stab_clear(stab)
633register STAB *stab;
634{
635 STIO *stio;
636 SUBR *sub;
637
638 afree(stab_xarray(stab));
639 (void)hfree(stab_xhash(stab));
640 str_free(stab_val(stab));
641 if (stio = stab_io(stab)) {
642 do_close(stab,FALSE);
643 Safefree(stio->top_name);
644 Safefree(stio->fmt_name);
645 }
646 if (sub = stab_sub(stab)) {
647 afree(sub->tosave);
648 cmd_free(sub->cmd);
649 }
650 Safefree(stab->str_ptr);
651 stab->str_ptr = Null(STBP*);
652 stab->str_len = 0;
653 stab->str_cur = 0;
654}
655