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
1 /* $Header: stab.c,v 3.0.1.1 89/11/11 04:55:07 lwall Locked $
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.
7  *
8  * $Log:        stab.c,v $
9  * Revision 3.0.1.1  89/11/11  04:55:07  lwall
10  * patch2: sys_errlist[sys_nerr] is illegal
11  * 
12  * Revision 3.0  89/10/18  15:23:23  lwall
13  * 3.0 baseline
14  * 
15  */
16
17 #include "EXTERN.h"
18 #include "perl.h"
19
20 #include <signal.h>
21
22 /* This oughta be generated by Configure. */
23
24 static char *sig_name[] = {
25     SIG_NAME,0
26 };
27
28 extern int errno;
29 extern int sys_nerr;
30 extern char *sys_errlist[];
31
32 STR *
33 stab_str(str)
34 STR *str;
35 {
36     STAB *stab = str->str_u.str_stab;
37     register int paren;
38     register char *s;
39     register int i;
40
41     if (str->str_rare)
42         return stab_val(stab);
43
44     switch (*stab->str_magic->str_ptr) {
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) {
48             paren = atoi(stab_name(stab));
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)
55                     str_nset(stab_val(stab),s,i);
56                 else
57                     str_sset(stab_val(stab),&str_undef);
58             }
59             else
60                 str_sset(stab_val(stab),&str_undef);
61         }
62         break;
63     case '+':
64         if (curspat) {
65             paren = curspat->spat_regexp->lastparen;
66             goto getparen;
67         }
68         break;
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;
93     case '.':
94 #ifndef lint
95         if (last_in_stab) {
96             str_numset(stab_val(stab),(double)stab_io(last_in_stab)->lines);
97         }
98 #endif
99         break;
100     case '?':
101         str_numset(stab_val(stab),(double)statusvalue);
102         break;
103     case '^':
104         s = stab_io(curoutstab)->top_name;
105         str_set(stab_val(stab),s);
106         break;
107     case '~':
108         s = stab_io(curoutstab)->fmt_name;
109         str_set(stab_val(stab),s);
110         break;
111 #ifndef lint
112     case '=':
113         str_numset(stab_val(stab),(double)stab_io(curoutstab)->page_len);
114         break;
115     case '-':
116         str_numset(stab_val(stab),(double)stab_io(curoutstab)->lines_left);
117         break;
118     case '%':
119         str_numset(stab_val(stab),(double)stab_io(curoutstab)->page);
120         break;
121 #endif
122     case '/':
123         *tokenbuf = record_separator;
124         tokenbuf[1] = '\0';
125         str_nset(stab_val(stab),tokenbuf,rslen);
126         break;
127     case '[':
128         str_numset(stab_val(stab),(double)arybase);
129         break;
130     case '|':
131         str_numset(stab_val(stab),
132            (double)((stab_io(curoutstab)->flags & IOF_FLUSH) != 0) );
133         break;
134     case ',':
135         str_nset(stab_val(stab),ofs,ofslen);
136         break;
137     case '\\':
138         str_nset(stab_val(stab),ors,orslen);
139         break;
140     case '#':
141         str_set(stab_val(stab),ofmt);
142         break;
143     case '!':
144         str_numset(stab_val(stab), (double)errno);
145         str_set(stab_val(stab),
146           errno < 0 || errno >= sys_nerr ? "(unknown)" : sys_errlist[errno]);
147         stab_val(stab)->str_nok = 1;    /* what a wonderful hack! */
148         break;
149     case '<':
150         str_numset(stab_val(stab),(double)uid);
151         break;
152     case '>':
153         str_numset(stab_val(stab),(double)euid);
154         break;
155     case '(':
156         s = buf;
157         (void)sprintf(s,"%d",(int)gid);
158         goto add_groups;
159     case ')':
160         s = buf;
161         (void)sprintf(s,"%d",(int)egid);
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) {
173                 (void)sprintf(s," %ld", (long)gary[i]);
174                 while (*s) s++;
175             }
176         }
177 #endif
178         str_set(stab_val(stab),buf);
179         break;
180     }
181     return stab_val(stab);
182 }
183
184 stabset(mstr,str)
185 register STR *mstr;
186 STR *str;
187 {
188     STAB *stab = mstr->str_u.str_stab;
189     char *s;
190     int i;
191     int sighandler();
192
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) {
260         case '^':
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);
264             break;
265         case '~':
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);
269             break;
270         case '=':
271             stab_io(curoutstab)->page_len = (long)str_gnum(str);
272             break;
273         case '-':
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;
277             break;
278         case '%':
279             stab_io(curoutstab)->page = (long)str_gnum(str);
280             break;
281         case '|':
282             stab_io(curoutstab)->flags &= ~IOF_FLUSH;
283             if (str_gnum(str) != 0.0) {
284                 stab_io(curoutstab)->flags |= IOF_FLUSH;
285             }
286             break;
287         case '*':
288             i = (int)str_gnum(str);
289             multiline = (i != 0);
290             break;
291         case '/':
292             record_separator = *str_get(str);
293             rslen = str->str_cur;
294             break;
295         case '\\':
296             if (ors)
297                 Safefree(ors);
298             ors = savestr(str_get(str));
299             orslen = str->str_cur;
300             break;
301         case ',':
302             if (ofs)
303                 Safefree(ofs);
304             ofs = savestr(str_get(str));
305             ofslen = str->str_cur;
306             break;
307         case '#':
308             if (ofmt)
309                 Safefree(ofmt);
310             ofmt = savestr(str_get(str));
311             break;
312         case '[':
313             arybase = (int)str_gnum(str);
314             break;
315         case '?':
316             statusvalue = (unsigned short)str_gnum(str);
317             break;
318         case '!':
319             errno = (int)str_gnum(str);         /* will anyone ever use this? */
320             break;
321         case '<':
322             uid = (int)str_gnum(str);
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)
335                 uid = (int)getuid();
336 #else
337             fatal("setruid() not implemented");
338 #endif
339 #endif
340             break;
341         case '>':
342             euid = (int)str_gnum(str);
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)
355                 euid = (int)geteuid();
356 #else
357             fatal("seteuid() not implemented");
358 #endif
359 #endif
360             break;
361         case '(':
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 */
369 #ifdef SETRGID
370             (void)setrgid((GIDTYPE)gid);
371 #else
372 #ifdef SETREGID
373             (void)setregid((GIDTYPE)gid, (GIDTYPE)-1);
374 #else
375             fatal("setrgid() not implemented");
376 #endif
377 #endif
378             break;
379         case ')':
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 */
387 #ifdef SETEGID
388             (void)setegid((GIDTYPE)egid);
389 #else
390 #ifdef SETREGID
391             (void)setregid((GIDTYPE)-1, (GIDTYPE)egid);
392 #else
393             fatal("setegid() not implemented");
394 #endif
395 #endif
396             break;
397         case ':':
398             chopset = str_get(str);
399             break;
400         }
401         break;
402     }
403 }
404
405 whichsig(sig)
406 char *sig;
407 {
408     register char **sigv;
409
410     for (sigv = sig_name+1; *sigv; sigv++)
411         if (strEQ(sig,*sigv))
412             return sigv - sig_name;
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
421     return 0;
422 }
423
424 sighandler(sig)
425 int sig;
426 {
427     STAB *stab;
428     ARRAY *savearray;
429     STR *str;
430     char *oldfile = filename;
431     int oldsave = savestack->ary_fill;
432     ARRAY *oldstack = stack;
433     SUBR *sub;
434
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     }
448     if (!sub) {
449         if (dowarn)
450             warn("SIG%s handler \"%s\" not defined.\n",
451                 sig_name[sig], stab_name(stab) );
452         return;
453     }
454     savearray = stab_xarray(defstab);
455     stab_xarray(defstab) = stack = anew(defstab);
456     stack->ary_flags = 0;
457     str = Str_new(71,0);
458     str_set(str,sig_name[sig]);
459     (void)apush(stab_xarray(defstab),str);
460     sub->depth++;
461     if (sub->depth >= 2) {      /* save temporaries on recursion? */
462         if (sub->depth == 100 && dowarn)
463             warn("Deep recursion on subroutine \"%s\"",stab_name(stab));
464         savelist(sub->tosave->ary_array,sub->tosave->ary_fill);
465     }
466     filename = sub->filename;
467
468     (void)cmd_exec(sub->cmd,G_SCALAR,1);                /* so do it already */
469
470     sub->depth--;       /* assuming no longjumps out of here */
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;
475     filename = oldfile;
476     if (savestack->ary_fill > oldsave)
477         restorelist(oldsave);
478 }
479
480 STAB *
481 aadd(stab)
482 register STAB *stab;
483 {
484     if (!stab_xarray(stab))
485         stab_xarray(stab) = anew(stab);
486     return stab;
487 }
488
489 STAB *
490 hadd(stab)
491 register STAB *stab;
492 {
493     if (!stab_xhash(stab))
494         stab_xhash(stab) = hnew(COEFFSIZE);
495     return stab;
496 }
497
498 STAB *
499 stabent(name,add)
500 register char *name;
501 int add;
502 {
503     register STAB *stab;
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;
511
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;
520         }
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 = '\'';
567     }
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);
587         return stab;
588     }
589 }
590
591 STIO *
592 stio_new()
593 {
594     STIO *stio;
595
596     Newz(603,stio,1,STIO);
597     stio->page_len = 60;
598     return stio;
599 }
600
601 stab_check(min,max)
602 int min;
603 register int max;
604 {
605     register HENT *entry;
606     register int i;
607     register STAB *stab;
608
609     for (i = min; i <= max; i++) {
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)
613                 continue;
614             line = stab_line(stab);
615             warn("Possible typo: \"%s\"", stab_name(stab));
616         }
617     }
618 }
619
620 static int gensym = 0;
621
622 STAB *
623 genstab()
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
631 void
632 stab_clear(stab)
633 register 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