perl 4.0 patch 10: (combined patch)
[perl.git] / stab.c
1 /* $RCSfile: stab.c,v $$Revision: 4.0.1.2 $$Date: 91/06/07 11:55:53 $
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:        stab.c,v $
9  * Revision 4.0.1.2  91/06/07  11:55:53  lwall
10  * patch4: new copyright notice
11  * patch4: added $^P variable to control calling of perldb routines
12  * patch4: added $^F variable to specify maximum system fd, default 2
13  * patch4: $` was busted inside s///
14  * patch4: default top-of-form format is now FILEHANDLE_TOP
15  * patch4: length($`), length($&), length($') now optimized to avoid string copy
16  * patch4: $^D |= 1024 now does syntax tree dump at run-time
17  * 
18  * Revision 4.0.1.1  91/04/12  09:10:24  lwall
19  * patch1: Configure now differentiates getgroups() type from getgid() type
20  * patch1: you may now use "die" and "caller" in a signal handler
21  * 
22  * Revision 4.0  91/03/20  01:39:41  lwall
23  * 4.0 baseline.
24  * 
25  */
26
27 #include "EXTERN.h"
28 #include "perl.h"
29
30 #if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX)
31 #include <signal.h>
32 #endif
33
34 static char *sig_name[] = {
35     SIG_NAME,0
36 };
37
38 #ifdef VOIDSIG
39 #define handlertype void
40 #else
41 #define handlertype int
42 #endif
43
44 static handlertype sighandler();
45
46 static int origalen = 0;
47
48 STR *
49 stab_str(str)
50 STR *str;
51 {
52     STAB *stab = str->str_u.str_stab;
53     register int paren;
54     register char *s;
55     register int i;
56
57     if (str->str_rare)
58         return stab_val(stab);
59
60     switch (*stab->str_magic->str_ptr) {
61     case '\004':                /* ^D */
62 #ifdef DEBUGGING
63         str_numset(stab_val(stab),(double)(debug & 32767));
64 #endif
65         break;
66     case '\006':                /* ^F */
67         str_numset(stab_val(stab),(double)maxsysfd);
68         break;
69     case '\t':                  /* ^I */
70         if (inplace)
71             str_set(stab_val(stab), inplace);
72         else
73             str_sset(stab_val(stab),&str_undef);
74         break;
75     case '\020':                /* ^P */
76         str_numset(stab_val(stab),(double)perldb);
77         break;
78     case '\024':                /* ^T */
79         str_numset(stab_val(stab),(double)basetime);
80         break;
81     case '\027':                /* ^W */
82         str_numset(stab_val(stab),(double)dowarn);
83         break;
84     case '1': case '2': case '3': case '4':
85     case '5': case '6': case '7': case '8': case '9': case '&':
86         if (curspat) {
87             paren = atoi(stab_name(stab));
88           getparen:
89             if (curspat->spat_regexp &&
90               paren <= curspat->spat_regexp->nparens &&
91               (s = curspat->spat_regexp->startp[paren]) ) {
92                 i = curspat->spat_regexp->endp[paren] - s;
93                 if (i >= 0)
94                     str_nset(stab_val(stab),s,i);
95                 else
96                     str_sset(stab_val(stab),&str_undef);
97             }
98             else
99                 str_sset(stab_val(stab),&str_undef);
100         }
101         break;
102     case '+':
103         if (curspat) {
104             paren = curspat->spat_regexp->lastparen;
105             goto getparen;
106         }
107         break;
108     case '`':
109         if (curspat) {
110             if (curspat->spat_regexp &&
111               (s = curspat->spat_regexp->subbeg) ) {
112                 i = curspat->spat_regexp->startp[0] - s;
113                 if (i >= 0)
114                     str_nset(stab_val(stab),s,i);
115                 else
116                     str_nset(stab_val(stab),"",0);
117             }
118             else
119                 str_nset(stab_val(stab),"",0);
120         }
121         break;
122     case '\'':
123         if (curspat) {
124             if (curspat->spat_regexp &&
125               (s = curspat->spat_regexp->endp[0]) ) {
126                 str_nset(stab_val(stab),s, curspat->spat_regexp->subend - s);
127             }
128             else
129                 str_nset(stab_val(stab),"",0);
130         }
131         break;
132     case '.':
133 #ifndef lint
134         if (last_in_stab) {
135             str_numset(stab_val(stab),(double)stab_io(last_in_stab)->lines);
136         }
137 #endif
138         break;
139     case '?':
140         str_numset(stab_val(stab),(double)statusvalue);
141         break;
142     case '^':
143         s = stab_io(curoutstab)->top_name;
144         if (s)
145             str_set(stab_val(stab),s);
146         else {
147             str_set(stab_val(stab),stab_name(curoutstab));
148             str_cat(stab_val(stab),"_TOP");
149         }
150         break;
151     case '~':
152         s = stab_io(curoutstab)->fmt_name;
153         if (!s)
154             s = stab_name(curoutstab);
155         str_set(stab_val(stab),s);
156         break;
157 #ifndef lint
158     case '=':
159         str_numset(stab_val(stab),(double)stab_io(curoutstab)->page_len);
160         break;
161     case '-':
162         str_numset(stab_val(stab),(double)stab_io(curoutstab)->lines_left);
163         break;
164     case '%':
165         str_numset(stab_val(stab),(double)stab_io(curoutstab)->page);
166         break;
167 #endif
168     case '/':
169         break;
170     case '[':
171         str_numset(stab_val(stab),(double)arybase);
172         break;
173     case '|':
174         if (!stab_io(curoutstab))
175             stab_io(curoutstab) = stio_new();
176         str_numset(stab_val(stab),
177            (double)((stab_io(curoutstab)->flags & IOF_FLUSH) != 0) );
178         break;
179     case ',':
180         str_nset(stab_val(stab),ofs,ofslen);
181         break;
182     case '\\':
183         str_nset(stab_val(stab),ors,orslen);
184         break;
185     case '#':
186         str_set(stab_val(stab),ofmt);
187         break;
188     case '!':
189         str_numset(stab_val(stab), (double)errno);
190         str_set(stab_val(stab), errno ? strerror(errno) : "");
191         stab_val(stab)->str_nok = 1;    /* what a wonderful hack! */
192         break;
193     case '<':
194         str_numset(stab_val(stab),(double)uid);
195         break;
196     case '>':
197         str_numset(stab_val(stab),(double)euid);
198         break;
199     case '(':
200         s = buf;
201         (void)sprintf(s,"%d",(int)gid);
202         goto add_groups;
203     case ')':
204         s = buf;
205         (void)sprintf(s,"%d",(int)egid);
206       add_groups:
207         while (*s) s++;
208 #ifdef HAS_GETGROUPS
209 #ifndef NGROUPS
210 #define NGROUPS 32
211 #endif
212         {
213             GROUPSTYPE gary[NGROUPS];
214
215             i = getgroups(NGROUPS,gary);
216             while (--i >= 0) {
217                 (void)sprintf(s," %ld", (long)gary[i]);
218                 while (*s) s++;
219             }
220         }
221 #endif
222         str_set(stab_val(stab),buf);
223         break;
224     case '*':
225         break;
226     case '0':
227         break;
228     default:
229         {
230             struct ufuncs *uf = (struct ufuncs *)str->str_ptr;
231
232             if (uf && uf->uf_val)
233                 (*uf->uf_val)(uf->uf_index, stab_val(stab));
234         }
235         break;
236     }
237     return stab_val(stab);
238 }
239
240 STRLEN
241 stab_len(str)
242 STR *str;
243 {
244     STAB *stab = str->str_u.str_stab;
245     int paren;
246     int i;
247     char *s;
248
249     if (str->str_rare)
250         return stab_val(stab)->str_cur;
251
252     switch (*stab->str_magic->str_ptr) {
253     case '1': case '2': case '3': case '4':
254     case '5': case '6': case '7': case '8': case '9': case '&':
255         if (curspat) {
256             paren = atoi(stab_name(stab));
257           getparen:
258             if (curspat->spat_regexp &&
259               paren <= curspat->spat_regexp->nparens &&
260               (s = curspat->spat_regexp->startp[paren]) ) {
261                 i = curspat->spat_regexp->endp[paren] - s;
262                 if (i >= 0)
263                     return i;
264                 else
265                     return 0;
266             }
267             else
268                 return 0;
269         }
270         break;
271     case '+':
272         if (curspat) {
273             paren = curspat->spat_regexp->lastparen;
274             goto getparen;
275         }
276         break;
277     case '`':
278         if (curspat) {
279             if (curspat->spat_regexp &&
280               (s = curspat->spat_regexp->subbeg) ) {
281                 i = curspat->spat_regexp->startp[0] - s;
282                 if (i >= 0)
283                     return i;
284                 else
285                     return 0;
286             }
287             else
288                 return 0;
289         }
290         break;
291     case '\'':
292         if (curspat) {
293             if (curspat->spat_regexp &&
294               (s = curspat->spat_regexp->endp[0]) ) {
295                 return (STRLEN) (curspat->spat_regexp->subend - s);
296             }
297             else
298                 return 0;
299         }
300         break;
301     case ',':
302         return (STRLEN)ofslen;
303     case '\\':
304         return (STRLEN)orslen;
305     default:
306         return stab_str(str)->str_cur;
307     }
308 }
309
310 stabset(mstr,str)
311 register STR *mstr;
312 STR *str;
313 {
314     STAB *stab = mstr->str_u.str_stab;
315     register char *s;
316     int i;
317
318     switch (mstr->str_rare) {
319     case 'E':
320         setenv(mstr->str_ptr,str_get(str));
321                                 /* And you'll never guess what the dog had */
322                                 /*   in its mouth... */
323 #ifdef TAINT
324         if (strEQ(mstr->str_ptr,"PATH")) {
325             char *strend = str->str_ptr + str->str_cur;
326
327             s = str->str_ptr;
328             while (s < strend) {
329                 s = cpytill(tokenbuf,s,strend,':',&i);
330                 s++;
331                 if (*tokenbuf != '/'
332                   || (stat(tokenbuf,&statbuf) && (statbuf.st_mode & 2)) )
333                     str->str_tainted = 2;
334             }
335         }
336 #endif
337         break;
338     case 'S':
339         s = str_get(str);
340         i = whichsig(mstr->str_ptr);    /* ...no, a brick */
341         if (strEQ(s,"IGNORE"))
342 #ifndef lint
343             (void)signal(i,SIG_IGN);
344 #else
345             ;
346 #endif
347         else if (strEQ(s,"DEFAULT") || !*s)
348             (void)signal(i,SIG_DFL);
349         else {
350             (void)signal(i,sighandler);
351             if (!index(s,'\'')) {
352                 sprintf(tokenbuf, "main'%s",s);
353                 str_set(str,tokenbuf);
354             }
355         }
356         break;
357 #ifdef SOME_DBM
358     case 'D':
359         hdbmstore(stab_hash(stab),mstr->str_ptr,mstr->str_cur,str);
360         break;
361 #endif
362     case 'L':
363         {
364             CMD *cmd;
365
366             i = str_true(str);
367             str = afetch(stab_xarray(stab),atoi(mstr->str_ptr), FALSE);
368             cmd = str->str_magic->str_u.str_cmd;
369             cmd->c_flags &= ~CF_OPTIMIZE;
370             cmd->c_flags |= i? CFT_D1 : CFT_D0;
371         }
372         break;
373     case '#':
374         afill(stab_array(stab), (int)str_gnum(str) - arybase);
375         break;
376     case 'X':   /* merely a copy of a * string */
377         break;
378     case '*':
379         s = str_get(str);
380         if (strNE(s,"StB") || str->str_cur != sizeof(STBP)) {
381             if (!*s) {
382                 STBP *stbp;
383
384                 (void)savenostab(stab); /* schedule a free of this stab */
385                 if (stab->str_len)
386                     Safefree(stab->str_ptr);
387                 Newz(601,stbp, 1, STBP);
388                 stab->str_ptr = stbp;
389                 stab->str_len = stab->str_cur = sizeof(STBP);
390                 stab->str_pok = 1;
391                 strcpy(stab_magic(stab),"StB");
392                 stab_val(stab) = Str_new(70,0);
393                 stab_line(stab) = curcmd->c_line;
394                 stab_stash(stab) = curcmd->c_stash;
395             }
396             else {
397                 stab = stabent(s,TRUE);
398                 if (!stab_xarray(stab))
399                     aadd(stab);
400                 if (!stab_xhash(stab))
401                     hadd(stab);
402                 if (!stab_io(stab))
403                     stab_io(stab) = stio_new();
404             }
405             str_sset(str,stab);
406         }
407         break;
408     case 's': {
409             struct lstring *lstr = (struct lstring*)str;
410             char *tmps;
411
412             mstr->str_rare = 0;
413             str->str_magic = Nullstr;
414             tmps = str_get(str);
415             str_insert(mstr,lstr->lstr_offset,lstr->lstr_len,
416               tmps,str->str_cur);
417         }
418         break;
419
420     case 'v':
421         do_vecset(mstr,str);
422         break;
423
424     case 0:
425         switch (*stab->str_magic->str_ptr) {
426         case '\004':    /* ^D */
427 #ifdef DEBUGGING
428             debug = (int)(str_gnum(str)) | 32768;
429             if (debug & 1024)
430                 dump_all();
431 #endif
432             break;
433         case '\006':    /* ^F */
434             maxsysfd = (int)str_gnum(str);
435             break;
436         case '\t':      /* ^I */
437             if (inplace)
438                 Safefree(inplace);
439             if (str->str_pok || str->str_nok)
440                 inplace = savestr(str_get(str));
441             else
442                 inplace = Nullch;
443             break;
444         case '\020':    /* ^P */
445             perldb = (int)str_gnum(str);
446             break;
447         case '\024':    /* ^T */
448             basetime = (long)str_gnum(str);
449             break;
450         case '\027':    /* ^W */
451             dowarn = (bool)str_gnum(str);
452             break;
453         case '.':
454             if (localizing)
455                 savesptr((STR**)&last_in_stab);
456             break;
457         case '^':
458             Safefree(stab_io(curoutstab)->top_name);
459             stab_io(curoutstab)->top_name = s = savestr(str_get(str));
460             stab_io(curoutstab)->top_stab = stabent(s,TRUE);
461             break;
462         case '~':
463             Safefree(stab_io(curoutstab)->fmt_name);
464             stab_io(curoutstab)->fmt_name = s = savestr(str_get(str));
465             stab_io(curoutstab)->fmt_stab = stabent(s,TRUE);
466             break;
467         case '=':
468             stab_io(curoutstab)->page_len = (long)str_gnum(str);
469             break;
470         case '-':
471             stab_io(curoutstab)->lines_left = (long)str_gnum(str);
472             if (stab_io(curoutstab)->lines_left < 0L)
473                 stab_io(curoutstab)->lines_left = 0L;
474             break;
475         case '%':
476             stab_io(curoutstab)->page = (long)str_gnum(str);
477             break;
478         case '|':
479             if (!stab_io(curoutstab))
480                 stab_io(curoutstab) = stio_new();
481             stab_io(curoutstab)->flags &= ~IOF_FLUSH;
482             if (str_gnum(str) != 0.0) {
483                 stab_io(curoutstab)->flags |= IOF_FLUSH;
484             }
485             break;
486         case '*':
487             i = (int)str_gnum(str);
488             multiline = (i != 0);
489             break;
490         case '/':
491             if (str->str_pok) {
492                 rs = str_get(str);
493                 rslen = str->str_cur;
494                 if (!rslen) {
495                     rs = "\n\n";
496                     rslen = 2;
497                 }
498                 rschar = rs[rslen - 1];
499             }
500             else {
501                 rschar = 0777;  /* fake a non-existent char */
502                 rslen = 1;
503             }
504             break;
505         case '\\':
506             if (ors)
507                 Safefree(ors);
508             ors = savestr(str_get(str));
509             orslen = str->str_cur;
510             break;
511         case ',':
512             if (ofs)
513                 Safefree(ofs);
514             ofs = savestr(str_get(str));
515             ofslen = str->str_cur;
516             break;
517         case '#':
518             if (ofmt)
519                 Safefree(ofmt);
520             ofmt = savestr(str_get(str));
521             break;
522         case '[':
523             arybase = (int)str_gnum(str);
524             break;
525         case '?':
526             statusvalue = U_S(str_gnum(str));
527             break;
528         case '!':
529             errno = (int)str_gnum(str);         /* will anyone ever use this? */
530             break;
531         case '<':
532             uid = (int)str_gnum(str);
533 #if defined(HAS_SETREUID) || !defined(HAS_SETRUID)
534             if (delaymagic) {
535                 delaymagic |= DM_REUID;
536                 break;                          /* don't do magic till later */
537             }
538 #endif /* HAS_SETREUID or not HASSETRUID */
539 #ifdef HAS_SETRUID
540             if (setruid((UIDTYPE)uid) < 0)
541                 uid = (int)getuid();
542 #else
543 #ifdef HAS_SETREUID
544             if (setreuid((UIDTYPE)uid, (UIDTYPE)-1) < 0)
545                 uid = (int)getuid();
546 #else
547             if (uid == euid)            /* special case $< = $> */
548                 setuid(uid);
549             else
550                 fatal("setruid() not implemented");
551 #endif
552 #endif
553             break;
554         case '>':
555             euid = (int)str_gnum(str);
556 #if defined(HAS_SETREUID) || !defined(HAS_SETEUID)
557             if (delaymagic) {
558                 delaymagic |= DM_REUID;
559                 break;                          /* don't do magic till later */
560             }
561 #endif /* HAS_SETREUID or not HAS_SETEUID */
562 #ifdef HAS_SETEUID
563             if (seteuid((UIDTYPE)euid) < 0)
564                 euid = (int)geteuid();
565 #else
566 #ifdef HAS_SETREUID
567             if (setreuid((UIDTYPE)-1, (UIDTYPE)euid) < 0)
568                 euid = (int)geteuid();
569 #else
570             if (euid == uid)            /* special case $> = $< */
571                 setuid(euid);
572             else
573                 fatal("seteuid() not implemented");
574 #endif
575 #endif
576             break;
577         case '(':
578             gid = (int)str_gnum(str);
579 #if defined(HAS_SETREGID) || !defined(HAS_SETRGID)
580             if (delaymagic) {
581                 delaymagic |= DM_REGID;
582                 break;                          /* don't do magic till later */
583             }
584 #endif /* HAS_SETREGID or not HAS_SETRGID */
585 #ifdef HAS_SETRGID
586             (void)setrgid((GIDTYPE)gid);
587 #else
588 #ifdef HAS_SETREGID
589             (void)setregid((GIDTYPE)gid, (GIDTYPE)-1);
590 #else
591             fatal("setrgid() not implemented");
592 #endif
593 #endif
594             break;
595         case ')':
596             egid = (int)str_gnum(str);
597 #if defined(HAS_SETREGID) || !defined(HAS_SETEGID)
598             if (delaymagic) {
599                 delaymagic |= DM_REGID;
600                 break;                          /* don't do magic till later */
601             }
602 #endif /* HAS_SETREGID or not HAS_SETEGID */
603 #ifdef HAS_SETEGID
604             (void)setegid((GIDTYPE)egid);
605 #else
606 #ifdef HAS_SETREGID
607             (void)setregid((GIDTYPE)-1, (GIDTYPE)egid);
608 #else
609             fatal("setegid() not implemented");
610 #endif
611 #endif
612             break;
613         case ':':
614             chopset = str_get(str);
615             break;
616         case '0':
617             if (!origalen) {
618                 s = origargv[0];
619                 s += strlen(s);
620                 /* See if all the arguments are contiguous in memory */
621                 for (i = 1; i < origargc; i++) {
622                     if (origargv[i] == s + 1)
623                         s += strlen(++s);       /* this one is ok too */
624                 }
625                 if (origenviron[0] == s + 1) {  /* can grab env area too? */
626                     setenv("NoNeSuCh", Nullch); /* force copy of environment */
627                     for (i = 0; origenviron[i]; i++)
628                         if (origenviron[i] == s + 1)
629                             s += strlen(++s);
630                 }
631                 origalen = s - origargv[0];
632             }
633             s = str_get(str);
634             i = str->str_cur;
635             if (i >= origalen) {
636                 i = origalen;
637                 str->str_cur = i;
638                 str->str_ptr[i] = '\0';
639                 bcopy(s, origargv[0], i);
640             }
641             else {
642                 bcopy(s, origargv[0], i);
643                 s = origargv[0]+i;
644                 *s++ = '\0';
645                 while (++i < origalen)
646                     *s++ = ' ';
647             }
648             break;
649         default:
650             {
651                 struct ufuncs *uf = (struct ufuncs *)str->str_magic->str_ptr;
652
653                 if (uf && uf->uf_set)
654                     (*uf->uf_set)(uf->uf_index, str);
655             }
656             break;
657         }
658         break;
659     }
660 }
661
662 whichsig(sig)
663 char *sig;
664 {
665     register char **sigv;
666
667     for (sigv = sig_name+1; *sigv; sigv++)
668         if (strEQ(sig,*sigv))
669             return sigv - sig_name;
670 #ifdef SIGCLD
671     if (strEQ(sig,"CHLD"))
672         return SIGCLD;
673 #endif
674 #ifdef SIGCHLD
675     if (strEQ(sig,"CLD"))
676         return SIGCHLD;
677 #endif
678     return 0;
679 }
680
681 static handlertype
682 sighandler(sig)
683 int sig;
684 {
685     STAB *stab;
686     STR *str;
687     int oldsave = savestack->ary_fill;
688     int oldtmps_base = tmps_base;
689     register CSV *csv;
690     SUBR *sub;
691
692 #ifdef OS2              /* or anybody else who requires SIG_ACK */
693     signal(sig, SIG_ACK);
694 #endif
695     stab = stabent(
696         str_get(hfetch(stab_hash(sigstab),sig_name[sig],strlen(sig_name[sig]),
697           TRUE)), TRUE);
698     sub = stab_sub(stab);
699     if (!sub && *sig_name[sig] == 'C' && instr(sig_name[sig],"LD")) {
700         if (sig_name[sig][1] == 'H')
701             stab = stabent(str_get(hfetch(stab_hash(sigstab),"CLD",3,TRUE)),
702               TRUE);
703         else
704             stab = stabent(str_get(hfetch(stab_hash(sigstab),"CHLD",4,TRUE)),
705               TRUE);
706         sub = stab_sub(stab);   /* gag */
707     }
708     if (!sub) {
709         if (dowarn)
710             warn("SIG%s handler \"%s\" not defined.\n",
711                 sig_name[sig], stab_name(stab) );
712         return;
713     }
714     saveaptr(&stack);
715     str = Str_new(15, sizeof(CSV));
716     str->str_state = SS_SCSV;
717     (void)apush(savestack,str);
718     csv = (CSV*)str->str_ptr;
719     csv->sub = sub;
720     csv->stab = stab;
721     csv->curcsv = curcsv;
722     csv->curcmd = curcmd;
723     csv->depth = sub->depth;
724     csv->wantarray = G_SCALAR;
725     csv->hasargs = TRUE;
726     csv->savearray = stab_xarray(defstab);
727     csv->argarray = stab_xarray(defstab) = stack = anew(defstab);
728     stack->ary_flags = 0;
729     curcsv = csv;
730     str = str_mortal(&str_undef);
731     str_set(str,sig_name[sig]);
732     (void)apush(stab_xarray(defstab),str);
733     sub->depth++;
734     if (sub->depth >= 2) {      /* save temporaries on recursion? */
735         if (sub->depth == 100 && dowarn)
736             warn("Deep recursion on subroutine \"%s\"",stab_name(stab));
737         savelist(sub->tosave->ary_array,sub->tosave->ary_fill);
738     }
739
740     tmps_base = tmps_max;               /* protect our mortal string */
741     (void)cmd_exec(sub->cmd,G_SCALAR,0);                /* so do it already */
742     tmps_base = oldtmps_base;
743
744     restorelist(oldsave);               /* put everything back */
745 }
746
747 STAB *
748 aadd(stab)
749 register STAB *stab;
750 {
751     if (!stab_xarray(stab))
752         stab_xarray(stab) = anew(stab);
753     return stab;
754 }
755
756 STAB *
757 hadd(stab)
758 register STAB *stab;
759 {
760     if (!stab_xhash(stab))
761         stab_xhash(stab) = hnew(COEFFSIZE);
762     return stab;
763 }
764
765 STAB *
766 fstab(name)
767 char *name;
768 {
769     char tmpbuf[1200];
770     STAB *stab;
771
772     sprintf(tmpbuf,"'_<%s", name);
773     stab = stabent(tmpbuf, TRUE);
774     str_set(stab_val(stab), name);
775     if (perldb)
776         (void)hadd(aadd(stab));
777     return stab;
778 }
779
780 STAB *
781 stabent(name,add)
782 register char *name;
783 int add;
784 {
785     register STAB *stab;
786     register STBP *stbp;
787     int len;
788     register char *namend;
789     HASH *stash;
790     char *sawquote = Nullch;
791     char *prevquote = Nullch;
792     bool global = FALSE;
793
794     if (isascii(*name) && isupper(*name)) {
795         if (*name > 'I') {
796             if (*name == 'S' && (
797               strEQ(name, "SIG") ||
798               strEQ(name, "STDIN") ||
799               strEQ(name, "STDOUT") ||
800               strEQ(name, "STDERR") ))
801                 global = TRUE;
802         }
803         else if (*name > 'E') {
804             if (*name == 'I' && strEQ(name, "INC"))
805                 global = TRUE;
806         }
807         else if (*name > 'A') {
808             if (*name == 'E' && strEQ(name, "ENV"))
809                 global = TRUE;
810         }
811         else if (*name == 'A' && (
812           strEQ(name, "ARGV") ||
813           strEQ(name, "ARGVOUT") ))
814             global = TRUE;
815     }
816     for (namend = name; *namend; namend++) {
817         if (*namend == '\'' && namend[1])
818             prevquote = sawquote, sawquote = namend;
819     }
820     if (sawquote == name && name[1]) {
821         stash = defstash;
822         sawquote = Nullch;
823         name++;
824     }
825     else if (!isalpha(*name) || global)
826         stash = defstash;
827     else if (curcmd == &compiling)
828         stash = curstash;
829     else
830         stash = curcmd->c_stash;
831     if (sawquote) {
832         char tmpbuf[256];
833         char *s, *d;
834
835         *sawquote = '\0';
836         if (s = prevquote) {
837             strncpy(tmpbuf,name,s-name+1);
838             d = tmpbuf+(s-name+1);
839             *d++ = '_';
840             strcpy(d,s+1);
841         }
842         else {
843             *tmpbuf = '_';
844             strcpy(tmpbuf+1,name);
845         }
846         stab = stabent(tmpbuf,TRUE);
847         if (!(stash = stab_xhash(stab)))
848             stash = stab_xhash(stab) = hnew(0);
849         if (!stash->tbl_name)
850             stash->tbl_name = savestr(name);
851         name = sawquote+1;
852         *sawquote = '\'';
853     }
854     len = namend - name;
855     stab = (STAB*)hfetch(stash,name,len,add);
856     if (stab == (STAB*)&str_undef)
857         return Nullstab;
858     if (stab->str_pok) {
859         stab->str_pok |= SP_MULTI;
860         return stab;
861     }
862     else {
863         if (stab->str_len)
864             Safefree(stab->str_ptr);
865         Newz(602,stbp, 1, STBP);
866         stab->str_ptr = stbp;
867         stab->str_len = stab->str_cur = sizeof(STBP);
868         stab->str_pok = 1;
869         strcpy(stab_magic(stab),"StB");
870         stab_val(stab) = Str_new(72,0);
871         stab_line(stab) = curcmd->c_line;
872         str_magic(stab,stab,'*',name,len);
873         stab_stash(stab) = stash;
874         if (isdigit(*name) && *name != '0') {
875             stab_flags(stab) = SF_VMAGIC;
876             str_magic(stab_val(stab), stab, 0, Nullch, 0);
877         }
878         return stab;
879     }
880 }
881
882 stab_fullname(str,stab)
883 STR *str;
884 STAB *stab;
885 {
886     HASH *tb = stab_stash(stab);
887
888     if (!tb)
889         return;
890     str_set(str,tb->tbl_name);
891     str_ncat(str,"'", 1);
892     str_scat(str,stab->str_magic);
893 }
894
895 STIO *
896 stio_new()
897 {
898     STIO *stio;
899
900     Newz(603,stio,1,STIO);
901     stio->page_len = 60;
902     return stio;
903 }
904
905 stab_check(min,max)
906 int min;
907 register int max;
908 {
909     register HENT *entry;
910     register int i;
911     register STAB *stab;
912
913     for (i = min; i <= max; i++) {
914         for (entry = defstash->tbl_array[i]; entry; entry = entry->hent_next) {
915             stab = (STAB*)entry->hent_val;
916             if (stab->str_pok & SP_MULTI)
917                 continue;
918             curcmd->c_line = stab_line(stab);
919             warn("Possible typo: \"%s\"", stab_name(stab));
920         }
921     }
922 }
923
924 static int gensym = 0;
925
926 STAB *
927 genstab()
928 {
929     (void)sprintf(tokenbuf,"_GEN_%d",gensym++);
930     return stabent(tokenbuf,TRUE);
931 }
932
933 /* hopefully this is only called on local symbol table entries */
934
935 void
936 stab_clear(stab)
937 register STAB *stab;
938 {
939     STIO *stio;
940     SUBR *sub;
941
942     afree(stab_xarray(stab));
943     stab_xarray(stab) = Null(ARRAY*);
944     (void)hfree(stab_xhash(stab), FALSE);
945     stab_xhash(stab) = Null(HASH*);
946     str_free(stab_val(stab));
947     stab_val(stab) = Nullstr;
948     if (stio = stab_io(stab)) {
949         do_close(stab,FALSE);
950         Safefree(stio->top_name);
951         Safefree(stio->fmt_name);
952     }
953     if (sub = stab_sub(stab)) {
954         afree(sub->tosave);
955         cmd_free(sub->cmd);
956     }
957     Safefree(stab->str_ptr);
958     stab->str_ptr = Null(STBP*);
959     stab->str_len = 0;
960     stab->str_cur = 0;
961 }
962
963 #if defined(CRIPPLED_CC) && (defined(iAPX286) || defined(M_I286) || defined(I80286))
964 #define MICROPORT
965 #endif
966
967 #ifdef  MICROPORT       /* Microport 2.4 hack */
968 ARRAY *stab_array(stab)
969 register STAB *stab;
970 {
971     if (((STBP*)(stab->str_ptr))->stbp_array) 
972         return ((STBP*)(stab->str_ptr))->stbp_array;
973     else
974         return ((STBP*)(aadd(stab)->str_ptr))->stbp_array;
975 }
976
977 HASH *stab_hash(stab)
978 register STAB *stab;
979 {
980     if (((STBP*)(stab->str_ptr))->stbp_hash)
981         return ((STBP*)(stab->str_ptr))->stbp_hash;
982     else
983         return ((STBP*)(hadd(stab)->str_ptr))->stbp_hash;
984 }
985 #endif                  /* Microport 2.4 hack */