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