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