1 /* $RCSfile: stab.c,v $$Revision: 4.0.1.3 $$Date: 91/11/05 18:35:33 $
3 * Copyright (c) 1991, Larry Wall
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.
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
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
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
29 * Revision 4.0 91/03/20 01:39:41 lwall
37 #if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX)
41 static char *sig_name[] = {
46 #define handlertype void
48 #define handlertype int
51 static handlertype sighandler();
53 static int origalen = 0;
59 STAB *stab = str->str_u.str_stab;
65 return stab_val(stab);
67 switch (*stab->str_magic->str_ptr) {
70 str_numset(stab_val(stab),(double)(debug & 32767));
74 str_numset(stab_val(stab),(double)maxsysfd);
78 str_set(stab_val(stab), inplace);
80 str_sset(stab_val(stab),&str_undef);
83 str_numset(stab_val(stab),(double)perldb);
86 str_numset(stab_val(stab),(double)basetime);
89 str_numset(stab_val(stab),(double)dowarn);
91 case '1': case '2': case '3': case '4':
92 case '5': case '6': case '7': case '8': case '9': case '&':
94 paren = atoi(stab_name(stab));
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;
101 str_nset(stab_val(stab),s,i);
103 str_sset(stab_val(stab),&str_undef);
106 str_sset(stab_val(stab),&str_undef);
111 paren = curspat->spat_regexp->lastparen;
117 if (curspat->spat_regexp &&
118 (s = curspat->spat_regexp->subbeg) ) {
119 i = curspat->spat_regexp->startp[0] - s;
121 str_nset(stab_val(stab),s,i);
123 str_nset(stab_val(stab),"",0);
126 str_nset(stab_val(stab),"",0);
131 if (curspat->spat_regexp &&
132 (s = curspat->spat_regexp->endp[0]) ) {
133 str_nset(stab_val(stab),s, curspat->spat_regexp->subend - s);
136 str_nset(stab_val(stab),"",0);
142 str_numset(stab_val(stab),(double)stab_io(last_in_stab)->lines);
147 str_numset(stab_val(stab),(double)statusvalue);
150 s = stab_io(curoutstab)->top_name;
152 str_set(stab_val(stab),s);
154 str_set(stab_val(stab),stab_name(curoutstab));
155 str_cat(stab_val(stab),"_TOP");
159 s = stab_io(curoutstab)->fmt_name;
161 s = stab_name(curoutstab);
162 str_set(stab_val(stab),s);
166 str_numset(stab_val(stab),(double)stab_io(curoutstab)->page_len);
169 str_numset(stab_val(stab),(double)stab_io(curoutstab)->lines_left);
172 str_numset(stab_val(stab),(double)stab_io(curoutstab)->page);
178 str_numset(stab_val(stab),(double)arybase);
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) );
187 str_nset(stab_val(stab),ofs,ofslen);
190 str_nset(stab_val(stab),ors,orslen);
193 str_set(stab_val(stab),ofmt);
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! */
201 str_numset(stab_val(stab),(double)uid);
204 str_numset(stab_val(stab),(double)euid);
208 (void)sprintf(s,"%d",(int)gid);
212 (void)sprintf(s,"%d",(int)egid);
220 GROUPSTYPE gary[NGROUPS];
222 i = getgroups(NGROUPS,gary);
224 (void)sprintf(s," %ld", (long)gary[i]);
229 str_set(stab_val(stab),buf);
237 struct ufuncs *uf = (struct ufuncs *)str->str_ptr;
239 if (uf && uf->uf_val)
240 (*uf->uf_val)(uf->uf_index, stab_val(stab));
244 return stab_val(stab);
251 STAB *stab = str->str_u.str_stab;
257 return str_len(stab_val(stab));
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 '&':
263 paren = atoi(stab_name(stab));
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;
280 paren = curspat->spat_regexp->lastparen;
286 if (curspat->spat_regexp &&
287 (s = curspat->spat_regexp->subbeg) ) {
288 i = curspat->spat_regexp->startp[0] - s;
300 if (curspat->spat_regexp &&
301 (s = curspat->spat_regexp->endp[0]) ) {
302 return (STRLEN) (curspat->spat_regexp->subend - s);
309 return (STRLEN)ofslen;
311 return (STRLEN)orslen;
313 return str_len(stab_str(str));
325 switch (mstr->str_rare) {
327 setenv(mstr->str_ptr,str_get(str));
328 /* And you'll never guess what the dog had */
329 /* in its mouth... */
331 if (strEQ(mstr->str_ptr,"PATH")) {
332 char *strend = str->str_ptr + str->str_cur;
336 s = cpytill(tokenbuf,s,strend,':',&i);
339 || (stat(tokenbuf,&statbuf) && (statbuf.st_mode & 2)) )
340 str->str_tainted = 2;
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"))
352 (void)signal(i,SIG_IGN);
356 else if (strEQ(s,"DEFAULT") || !*s)
357 (void)signal(i,SIG_DFL);
359 (void)signal(i,sighandler);
360 if (!index(s,'\'')) {
361 sprintf(tokenbuf, "main'%s",s);
362 str_set(str,tokenbuf);
368 stab = mstr->str_u.str_stab;
369 hdbmstore(stab_hash(stab),mstr->str_ptr,mstr->str_cur,str);
376 stab = mstr->str_u.str_stab;
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;
385 stab = mstr->str_u.str_stab;
386 afill(stab_array(stab), (int)str_gnum(str) - arybase);
388 case 'X': /* merely a copy of a * string */
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;
398 (void)savenostab(stab); /* schedule a free of this stab */
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);
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;
411 stab = stabent(s,TRUE);
412 if (!stab_xarray(stab))
414 if (!stab_xhash(stab))
417 stab_io(stab) = stio_new();
419 str_sset(str, (STR*) stab);
423 struct lstring *lstr = (struct lstring*)str;
427 str->str_magic = Nullstr;
429 str_insert(mstr,lstr->lstr_offset,lstr->lstr_len,
440 if (!(stab = mstr->str_u.str_stab))
442 switch (*stab->str_magic->str_ptr) {
443 case '\004': /* ^D */
445 debug = (int)(str_gnum(str)) | 32768;
450 case '\006': /* ^F */
451 maxsysfd = (int)str_gnum(str);
456 if (str->str_pok || str->str_nok)
457 inplace = savestr(str_get(str));
461 case '\020': /* ^P */
462 perldb = (int)str_gnum(str);
464 case '\024': /* ^T */
465 basetime = (long)str_gnum(str);
467 case '\027': /* ^W */
468 dowarn = (bool)str_gnum(str);
472 savesptr((STR**)&last_in_stab);
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);
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);
485 stab_io(curoutstab)->page_len = (long)str_gnum(str);
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;
493 stab_io(curoutstab)->page = (long)str_gnum(str);
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;
504 i = (int)str_gnum(str);
505 multiline = (i != 0);
510 rslen = str->str_cur;
515 rschar = rs[rslen - 1];
518 rschar = 0777; /* fake a non-existent char */
525 ors = savestr(str_get(str));
526 orslen = str->str_cur;
531 ofs = savestr(str_get(str));
532 ofslen = str->str_cur;
537 ofmt = savestr(str_get(str));
540 arybase = (int)str_gnum(str);
543 statusvalue = U_S(str_gnum(str));
546 errno = (int)str_gnum(str); /* will anyone ever use this? */
549 uid = (int)str_gnum(str);
550 #if defined(HAS_SETREUID) || !defined(HAS_SETRUID)
552 delaymagic |= DM_REUID;
553 break; /* don't do magic till later */
555 #endif /* HAS_SETREUID or not HASSETRUID */
557 if (setruid((UIDTYPE)uid) < 0)
561 if (setreuid((UIDTYPE)uid, (UIDTYPE)-1) < 0)
564 if (uid == euid) /* special case $< = $> */
567 fatal("setruid() not implemented");
572 euid = (int)str_gnum(str);
573 #if defined(HAS_SETREUID) || !defined(HAS_SETEUID)
575 delaymagic |= DM_REUID;
576 break; /* don't do magic till later */
578 #endif /* HAS_SETREUID or not HAS_SETEUID */
580 if (seteuid((UIDTYPE)euid) < 0)
581 euid = (int)geteuid();
584 if (setreuid((UIDTYPE)-1, (UIDTYPE)euid) < 0)
585 euid = (int)geteuid();
587 if (euid == uid) /* special case $> = $< */
590 fatal("seteuid() not implemented");
595 gid = (int)str_gnum(str);
596 #if defined(HAS_SETREGID) || !defined(HAS_SETRGID)
598 delaymagic |= DM_REGID;
599 break; /* don't do magic till later */
601 #endif /* HAS_SETREGID or not HAS_SETRGID */
603 (void)setrgid((GIDTYPE)gid);
606 (void)setregid((GIDTYPE)gid, (GIDTYPE)-1);
608 fatal("setrgid() not implemented");
613 egid = (int)str_gnum(str);
614 #if defined(HAS_SETREGID) || !defined(HAS_SETEGID)
616 delaymagic |= DM_REGID;
617 break; /* don't do magic till later */
619 #endif /* HAS_SETREGID or not HAS_SETEGID */
621 (void)setegid((GIDTYPE)egid);
624 (void)setregid((GIDTYPE)-1, (GIDTYPE)egid);
626 fatal("setegid() not implemented");
631 chopset = str_get(str);
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 */
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)
648 origalen = s - origargv[0];
655 str->str_ptr[i] = '\0';
656 bcopy(s, origargv[0], i);
659 bcopy(s, origargv[0], i);
662 while (++i < origalen)
668 struct ufuncs *uf = (struct ufuncs *)str->str_magic->str_ptr;
670 if (uf && uf->uf_set)
671 (*uf->uf_set)(uf->uf_index, str);
682 register char **sigv;
684 for (sigv = sig_name+1; *sigv; sigv++)
685 if (strEQ(sig,*sigv))
686 return sigv - sig_name;
688 if (strEQ(sig,"CHLD"))
692 if (strEQ(sig,"CLD"))
704 int oldsave = savestack->ary_fill;
705 int oldtmps_base = tmps_base;
709 #ifdef OS2 /* or anybody else who requires SIG_ACK */
710 signal(sig, SIG_ACK);
713 str_get(hfetch(stab_hash(sigstab),sig_name[sig],strlen(sig_name[sig]),
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)),
721 stab = stabent(str_get(hfetch(stab_hash(sigstab),"CHLD",4,TRUE)),
723 sub = stab_sub(stab); /* gag */
727 warn("SIG%s handler \"%s\" not defined.\n",
728 sig_name[sig], stab_name(stab) );
733 str = Str_new(15, sizeof(CSV));
734 str->str_state = SS_SCSV;
735 (void)apush(savestack,str);
736 csv = (CSV*)str->str_ptr;
739 csv->curcsv = curcsv;
740 csv->curcmd = curcmd;
741 csv->depth = sub->depth;
742 csv->wantarray = G_SCALAR;
744 csv->savearray = stab_xarray(defstab);
745 csv->argarray = stab_xarray(defstab) = stack = anew(defstab);
746 stack->ary_flags = 0;
748 str = str_mortal(&str_undef);
749 str_set(str,sig_name[sig]);
750 (void)apush(stab_xarray(defstab),str);
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);
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;
762 restorelist(oldsave); /* put everything back */
769 if (!stab_xarray(stab))
770 stab_xarray(stab) = anew(stab);
778 if (!stab_xhash(stab))
779 stab_xhash(stab) = hnew(COEFFSIZE);
790 sprintf(tmpbuf,"'_<%s", name);
791 stab = stabent(tmpbuf, TRUE);
792 str_set(stab_val(stab), name);
794 (void)hadd(aadd(stab));
806 register char *namend;
808 char *sawquote = Nullch;
809 char *prevquote = Nullch;
812 if (isUPPER(*name)) {
814 if (*name == 'S' && (
815 strEQ(name, "SIG") ||
816 strEQ(name, "STDIN") ||
817 strEQ(name, "STDOUT") ||
818 strEQ(name, "STDERR") ))
821 else if (*name > 'E') {
822 if (*name == 'I' && strEQ(name, "INC"))
825 else if (*name > 'A') {
826 if (*name == 'E' && strEQ(name, "ENV"))
829 else if (*name == 'A' && (
830 strEQ(name, "ARGV") ||
831 strEQ(name, "ARGVOUT") ))
834 for (namend = name; *namend; namend++) {
835 if (*namend == '\'' && namend[1])
836 prevquote = sawquote, sawquote = namend;
838 if (sawquote == name && name[1]) {
843 else if (!isALPHA(*name) || global)
845 else if ((CMD*)curcmd == &compiling)
848 stash = curcmd->c_stash;
856 strncpy(tmpbuf,name,s-name+1);
857 d = tmpbuf+(s-name+1);
863 strcpy(tmpbuf+1,name);
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);
874 stab = (STAB*)hfetch(stash,name,len,add);
875 if (stab == (STAB*)&str_undef)
878 stab->str_pok |= SP_MULTI;
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);
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);
898 stab->str_pok |= SP_MULTI;
903 stab_fullname(str,stab)
907 HASH *tb = stab_stash(stab);
911 str_set(str,tb->tbl_name);
912 str_ncat(str,"'", 1);
913 str_scat(str,stab->str_magic);
921 Newz(603,stio,1,STIO);
930 register HENT *entry;
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)
939 curcmd->c_line = stab_line(stab);
940 warn("Possible typo: \"%s\"", stab_name(stab));
945 static int gensym = 0;
950 (void)sprintf(tokenbuf,"_GEN_%d",gensym++);
951 return stabent(tokenbuf,TRUE);
954 /* hopefully this is only called on local symbol table entries */
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;
970 if (stio = stab_io(stab)) {
971 do_close(stab,FALSE);
972 Safefree(stio->top_name);
973 Safefree(stio->fmt_name);
977 if (sub = stab_sub(stab)) {
981 Safefree(stab->str_ptr);
982 stab->str_ptr = Null(STBP*);
987 #if defined(CRIPPLED_CC) && (defined(iAPX286) || defined(M_I286) || defined(I80286))
991 #ifdef MICROPORT /* Microport 2.4 hack */
992 ARRAY *stab_array(stab)
995 if (((STBP*)(stab->str_ptr))->stbp_array)
996 return ((STBP*)(stab->str_ptr))->stbp_array;
998 return ((STBP*)(aadd(stab)->str_ptr))->stbp_array;
1001 HASH *stab_hash(stab)
1002 register STAB *stab;
1004 if (((STBP*)(stab->str_ptr))->stbp_hash)
1005 return ((STBP*)(stab->str_ptr))->stbp_hash;
1007 return ((STBP*)(hadd(stab)->str_ptr))->stbp_hash;
1009 #endif /* Microport 2.4 hack */