1 /* $RCSfile: stab.c,v $$Revision: 4.0.1.4 $$Date: 92/06/08 15:32:19 $
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.4 92/06/08 15:32:19 lwall
10 * patch20: fixed confusion between a *var's real name and its effective name
11 * patch20: the debugger now warns you on lines that can't set a breakpoint
12 * patch20: the debugger made perl forget the last pattern used by //
13 * patch20: paragraph mode now skips extra newlines automatically
14 * patch20: ($<,$>) = ... didn't work on some architectures
16 * Revision 4.0.1.3 91/11/05 18:35:33 lwall
17 * patch11: length($x) was sometimes wrong for numeric $x
18 * patch11: perl now issues warning if $SIG{'ALARM'} is referenced
19 * patch11: *foo = undef coredumped
20 * patch11: solitary subroutine references no longer trigger typo warnings
21 * patch11: local(*FILEHANDLE) had a memory leak
23 * Revision 4.0.1.2 91/06/07 11:55:53 lwall
24 * patch4: new copyright notice
25 * patch4: added $^P variable to control calling of perldb routines
26 * patch4: added $^F variable to specify maximum system fd, default 2
27 * patch4: $` was busted inside s///
28 * patch4: default top-of-form format is now FILEHANDLE_TOP
29 * patch4: length($`), length($&), length($') now optimized to avoid string copy
30 * patch4: $^D |= 1024 now does syntax tree dump at run-time
32 * Revision 4.0.1.1 91/04/12 09:10:24 lwall
33 * patch1: Configure now differentiates getgroups() type from getgid() type
34 * patch1: you may now use "die" and "caller" in a signal handler
36 * Revision 4.0 91/03/20 01:39:41 lwall
44 #if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX)
48 static char *sig_name[] = {
53 #define handlertype void
55 #define handlertype int
58 static handlertype sighandler();
60 static int origalen = 0;
66 STAB *stab = str->str_u.str_stab;
72 return stab_val(stab);
74 switch (*stab->str_magic->str_ptr) {
77 str_numset(stab_val(stab),(double)(debug & 32767));
81 str_numset(stab_val(stab),(double)maxsysfd);
85 str_set(stab_val(stab), inplace);
87 str_sset(stab_val(stab),&str_undef);
90 str_numset(stab_val(stab),(double)perldb);
93 str_numset(stab_val(stab),(double)basetime);
96 str_numset(stab_val(stab),(double)dowarn);
98 case '1': case '2': case '3': case '4':
99 case '5': case '6': case '7': case '8': case '9': case '&':
101 paren = atoi(stab_ename(stab));
103 if (curspat->spat_regexp &&
104 paren <= curspat->spat_regexp->nparens &&
105 (s = curspat->spat_regexp->startp[paren]) ) {
106 i = curspat->spat_regexp->endp[paren] - s;
108 str_nset(stab_val(stab),s,i);
110 str_sset(stab_val(stab),&str_undef);
113 str_sset(stab_val(stab),&str_undef);
118 paren = curspat->spat_regexp->lastparen;
124 if (curspat->spat_regexp &&
125 (s = curspat->spat_regexp->subbeg) ) {
126 i = curspat->spat_regexp->startp[0] - s;
128 str_nset(stab_val(stab),s,i);
130 str_nset(stab_val(stab),"",0);
133 str_nset(stab_val(stab),"",0);
138 if (curspat->spat_regexp &&
139 (s = curspat->spat_regexp->endp[0]) ) {
140 str_nset(stab_val(stab),s, curspat->spat_regexp->subend - s);
143 str_nset(stab_val(stab),"",0);
148 if (last_in_stab && stab_io(last_in_stab)) {
149 str_numset(stab_val(stab),(double)stab_io(last_in_stab)->lines);
154 str_numset(stab_val(stab),(double)statusvalue);
157 s = stab_io(curoutstab)->top_name;
159 str_set(stab_val(stab),s);
161 str_set(stab_val(stab),stab_ename(curoutstab));
162 str_cat(stab_val(stab),"_TOP");
166 s = stab_io(curoutstab)->fmt_name;
168 s = stab_ename(curoutstab);
169 str_set(stab_val(stab),s);
173 str_numset(stab_val(stab),(double)stab_io(curoutstab)->page_len);
176 str_numset(stab_val(stab),(double)stab_io(curoutstab)->lines_left);
179 str_numset(stab_val(stab),(double)stab_io(curoutstab)->page);
187 str_numset(stab_val(stab),(double)arybase);
190 if (!stab_io(curoutstab))
191 stab_io(curoutstab) = stio_new();
192 str_numset(stab_val(stab),
193 (double)((stab_io(curoutstab)->flags & IOF_FLUSH) != 0) );
196 str_nset(stab_val(stab),ofs,ofslen);
199 str_nset(stab_val(stab),ors,orslen);
202 str_set(stab_val(stab),ofmt);
205 str_numset(stab_val(stab), (double)errno);
206 str_set(stab_val(stab), errno ? strerror(errno) : "");
207 stab_val(stab)->str_nok = 1; /* what a wonderful hack! */
210 str_numset(stab_val(stab),(double)uid);
213 str_numset(stab_val(stab),(double)euid);
217 (void)sprintf(s,"%d",(int)gid);
221 (void)sprintf(s,"%d",(int)egid);
229 GROUPSTYPE gary[NGROUPS];
231 i = getgroups(NGROUPS,gary);
233 (void)sprintf(s," %ld", (long)gary[i]);
238 str_set(stab_val(stab),buf);
246 struct ufuncs *uf = (struct ufuncs *)str->str_ptr;
248 if (uf && uf->uf_val)
249 (*uf->uf_val)(uf->uf_index, stab_val(stab));
253 return stab_val(stab);
260 STAB *stab = str->str_u.str_stab;
266 return str_len(stab_val(stab));
268 switch (*stab->str_magic->str_ptr) {
269 case '1': case '2': case '3': case '4':
270 case '5': case '6': case '7': case '8': case '9': case '&':
272 paren = atoi(stab_ename(stab));
274 if (curspat->spat_regexp &&
275 paren <= curspat->spat_regexp->nparens &&
276 (s = curspat->spat_regexp->startp[paren]) ) {
277 i = curspat->spat_regexp->endp[paren] - s;
289 paren = curspat->spat_regexp->lastparen;
295 if (curspat->spat_regexp &&
296 (s = curspat->spat_regexp->subbeg) ) {
297 i = curspat->spat_regexp->startp[0] - s;
309 if (curspat->spat_regexp &&
310 (s = curspat->spat_regexp->endp[0]) ) {
311 return (STRLEN) (curspat->spat_regexp->subend - s);
318 return (STRLEN)ofslen;
320 return (STRLEN)orslen;
322 return str_len(stab_str(str));
334 switch (mstr->str_rare) {
336 my_setenv(mstr->str_ptr,str_get(str));
337 /* And you'll never guess what the dog had */
338 /* in its mouth... */
340 if (strEQ(mstr->str_ptr,"PATH")) {
341 char *strend = str->str_ptr + str->str_cur;
345 s = cpytill(tokenbuf,s,strend,':',&i);
348 || (stat(tokenbuf,&statbuf) && (statbuf.st_mode & 2)) )
349 str->str_tainted = 2;
356 i = whichsig(mstr->str_ptr); /* ...no, a brick */
357 if (!i && (dowarn || strEQ(mstr->str_ptr,"ALARM")))
358 warn("No such signal: SIG%s", mstr->str_ptr);
359 if (strEQ(s,"IGNORE"))
361 (void)signal(i,SIG_IGN);
365 else if (strEQ(s,"DEFAULT") || !*s)
366 (void)signal(i,SIG_DFL);
368 (void)signal(i,sighandler);
369 if (!index(s,'\'')) {
370 sprintf(tokenbuf, "main'%s",s);
371 str_set(str,tokenbuf);
377 stab = mstr->str_u.str_stab;
378 hdbmstore(stab_hash(stab),mstr->str_ptr,mstr->str_cur,str);
385 stab = mstr->str_u.str_stab;
387 str = afetch(stab_xarray(stab),atoi(mstr->str_ptr), FALSE);
388 if (str->str_magic && (cmd = str->str_magic->str_u.str_cmd)) {
389 cmd->c_flags &= ~CF_OPTIMIZE;
390 cmd->c_flags |= i? CFT_D1 : CFT_D0;
393 warn("Can't break at that line\n");
397 stab = mstr->str_u.str_stab;
398 afill(stab_array(stab), (int)str_gnum(str) - arybase);
400 case 'X': /* merely a copy of a * string */
403 s = str->str_pok ? str_get(str) : "";
404 if (strNE(s,"StB") || str->str_cur != sizeof(STBP)) {
405 stab = mstr->str_u.str_stab;
410 (void)savenostab(stab); /* schedule a free of this stab */
412 Safefree(stab->str_ptr);
413 Newz(601,stbp, 1, STBP);
414 stab->str_ptr = stbp;
415 stab->str_len = stab->str_cur = sizeof(STBP);
417 strcpy(stab_magic(stab),"StB");
418 stab_val(stab) = Str_new(70,0);
419 stab_line(stab) = curcmd->c_line;
420 stab_estab(stab) = stab;
423 stab = stabent(s,TRUE);
424 if (!stab_xarray(stab))
426 if (!stab_xhash(stab))
429 stab_io(stab) = stio_new();
431 str_sset(str, (STR*) stab);
435 struct lstring *lstr = (struct lstring*)str;
439 str->str_magic = Nullstr;
441 str_insert(mstr,lstr->lstr_offset,lstr->lstr_len,
452 if (!(stab = mstr->str_u.str_stab))
454 switch (*stab->str_magic->str_ptr) {
455 case '\004': /* ^D */
457 debug = (int)(str_gnum(str)) | 32768;
462 case '\006': /* ^F */
463 maxsysfd = (int)str_gnum(str);
468 if (str->str_pok || str->str_nok)
469 inplace = savestr(str_get(str));
473 case '\020': /* ^P */
474 i = (int)str_gnum(str);
476 static SPAT *oldlastspat;
479 oldlastspat = lastspat;
481 lastspat = oldlastspat;
485 case '\024': /* ^T */
486 basetime = (time_t)str_gnum(str);
488 case '\027': /* ^W */
489 dowarn = (bool)str_gnum(str);
493 savesptr((STR**)&last_in_stab);
496 Safefree(stab_io(curoutstab)->top_name);
497 stab_io(curoutstab)->top_name = s = savestr(str_get(str));
498 stab_io(curoutstab)->top_stab = stabent(s,TRUE);
501 Safefree(stab_io(curoutstab)->fmt_name);
502 stab_io(curoutstab)->fmt_name = s = savestr(str_get(str));
503 stab_io(curoutstab)->fmt_stab = stabent(s,TRUE);
506 stab_io(curoutstab)->page_len = (long)str_gnum(str);
509 stab_io(curoutstab)->lines_left = (long)str_gnum(str);
510 if (stab_io(curoutstab)->lines_left < 0L)
511 stab_io(curoutstab)->lines_left = 0L;
514 stab_io(curoutstab)->page = (long)str_gnum(str);
517 if (!stab_io(curoutstab))
518 stab_io(curoutstab) = stio_new();
519 stab_io(curoutstab)->flags &= ~IOF_FLUSH;
520 if (str_gnum(str) != 0.0) {
521 stab_io(curoutstab)->flags |= IOF_FLUSH;
525 i = (int)str_gnum(str);
526 multiline = (i != 0);
531 rslen = str->str_cur;
532 if (rspara = !rslen) {
536 rschar = rs[rslen - 1];
539 rschar = 0777; /* fake a non-existent char */
546 ors = savestr(str_get(str));
547 orslen = str->str_cur;
552 ofs = savestr(str_get(str));
553 ofslen = str->str_cur;
558 ofmt = savestr(str_get(str));
561 arybase = (int)str_gnum(str);
564 statusvalue = U_S(str_gnum(str));
567 errno = (int)str_gnum(str); /* will anyone ever use this? */
570 uid = (int)str_gnum(str);
572 delaymagic |= DM_RUID;
573 break; /* don't do magic till later */
576 (void)setruid((UIDTYPE)uid);
579 (void)setreuid((UIDTYPE)uid, (UIDTYPE)-1);
581 if (uid == euid) /* special case $< = $> */
584 fatal("setruid() not implemented");
590 euid = (int)str_gnum(str);
592 delaymagic |= DM_EUID;
593 break; /* don't do magic till later */
596 (void)seteuid((UIDTYPE)euid);
599 (void)setreuid((UIDTYPE)-1, (UIDTYPE)euid);
601 if (euid == uid) /* special case $> = $< */
604 fatal("seteuid() not implemented");
607 euid = (int)geteuid();
610 gid = (int)str_gnum(str);
612 delaymagic |= DM_RGID;
613 break; /* don't do magic till later */
616 (void)setrgid((GIDTYPE)gid);
619 (void)setregid((GIDTYPE)gid, (GIDTYPE)-1);
621 if (gid == egid) /* special case $( = $) */
624 fatal("setrgid() not implemented");
630 egid = (int)str_gnum(str);
632 delaymagic |= DM_EGID;
633 break; /* don't do magic till later */
636 (void)setegid((GIDTYPE)egid);
639 (void)setregid((GIDTYPE)-1, (GIDTYPE)egid);
641 if (egid == gid) /* special case $) = $( */
644 fatal("setegid() not implemented");
647 egid = (int)getegid();
650 chopset = str_get(str);
656 /* See if all the arguments are contiguous in memory */
657 for (i = 1; i < origargc; i++) {
658 if (origargv[i] == s + 1)
659 s += strlen(++s); /* this one is ok too */
661 if (origenviron[0] == s + 1) { /* can grab env area too? */
662 my_setenv("NoNeSuCh", Nullch);
663 /* force copy of environment */
664 for (i = 0; origenviron[i]; i++)
665 if (origenviron[i] == s + 1)
668 origalen = s - origargv[0];
675 str->str_ptr[i] = '\0';
676 Copy(s, origargv[0], i, char);
679 Copy(s, origargv[0], i, char);
682 while (++i < origalen)
688 struct ufuncs *uf = (struct ufuncs *)str->str_magic->str_ptr;
690 if (uf && uf->uf_set)
691 (*uf->uf_set)(uf->uf_index, str);
703 register char **sigv;
705 for (sigv = sig_name+1; *sigv; sigv++)
706 if (strEQ(sig,*sigv))
707 return sigv - sig_name;
709 if (strEQ(sig,"CHLD"))
713 if (strEQ(sig,"CLD"))
725 int oldsave = savestack->ary_fill;
726 int oldtmps_base = tmps_base;
730 #ifdef OS2 /* or anybody else who requires SIG_ACK */
731 signal(sig, SIG_ACK);
734 str_get(hfetch(stab_hash(sigstab),sig_name[sig],strlen(sig_name[sig]),
736 sub = stab_sub(stab);
737 if (!sub && *sig_name[sig] == 'C' && instr(sig_name[sig],"LD")) {
738 if (sig_name[sig][1] == 'H')
739 stab = stabent(str_get(hfetch(stab_hash(sigstab),"CLD",3,TRUE)),
742 stab = stabent(str_get(hfetch(stab_hash(sigstab),"CHLD",4,TRUE)),
744 sub = stab_sub(stab); /* gag */
748 warn("SIG%s handler \"%s\" not defined.\n",
749 sig_name[sig], stab_ename(stab) );
754 str = Str_new(15, sizeof(CSV));
755 str->str_state = SS_SCSV;
756 (void)apush(savestack,str);
757 csv = (CSV*)str->str_ptr;
760 csv->curcsv = curcsv;
761 csv->curcmd = curcmd;
762 csv->depth = sub->depth;
763 csv->wantarray = G_SCALAR;
765 csv->savearray = stab_xarray(defstab);
766 csv->argarray = stab_xarray(defstab) = stack = anew(defstab);
767 stack->ary_flags = 0;
769 str = str_mortal(&str_undef);
770 str_set(str,sig_name[sig]);
771 (void)apush(stab_xarray(defstab),str);
773 if (sub->depth >= 2) { /* save temporaries on recursion? */
774 if (sub->depth == 100 && dowarn)
775 warn("Deep recursion on subroutine \"%s\"",stab_ename(stab));
776 savelist(sub->tosave->ary_array,sub->tosave->ary_fill);
779 tmps_base = tmps_max; /* protect our mortal string */
780 (void)cmd_exec(sub->cmd,G_SCALAR,0); /* so do it already */
781 tmps_base = oldtmps_base;
783 restorelist(oldsave); /* put everything back */
790 if (!stab_xarray(stab))
791 stab_xarray(stab) = anew(stab);
799 if (!stab_xhash(stab))
800 stab_xhash(stab) = hnew(COEFFSIZE);
811 sprintf(tmpbuf,"'_<%s", name);
812 stab = stabent(tmpbuf, TRUE);
813 str_set(stab_val(stab), name);
815 (void)hadd(aadd(stab));
827 register char *namend;
829 char *sawquote = Nullch;
830 char *prevquote = Nullch;
833 if (isUPPER(*name)) {
835 if (*name == 'S' && (
836 strEQ(name, "SIG") ||
837 strEQ(name, "STDIN") ||
838 strEQ(name, "STDOUT") ||
839 strEQ(name, "STDERR") ))
842 else if (*name > 'E') {
843 if (*name == 'I' && strEQ(name, "INC"))
846 else if (*name > 'A') {
847 if (*name == 'E' && strEQ(name, "ENV"))
850 else if (*name == 'A' && (
851 strEQ(name, "ARGV") ||
852 strEQ(name, "ARGVOUT") ))
855 for (namend = name; *namend; namend++) {
856 if (*namend == '\'' && namend[1])
857 prevquote = sawquote, sawquote = namend;
859 if (sawquote == name && name[1]) {
864 else if (!isALPHA(*name) || global)
866 else if ((CMD*)curcmd == &compiling)
869 stash = curcmd->c_stash;
877 strncpy(tmpbuf,name,s-name+1);
878 d = tmpbuf+(s-name+1);
884 strcpy(tmpbuf+1,name);
886 stab = stabent(tmpbuf,TRUE);
887 if (!(stash = stab_xhash(stab)))
888 stash = stab_xhash(stab) = hnew(0);
889 if (!stash->tbl_name)
890 stash->tbl_name = savestr(name);
895 stab = (STAB*)hfetch(stash,name,len,add);
896 if (stab == (STAB*)&str_undef)
899 stab->str_pok |= SP_MULTI;
904 Safefree(stab->str_ptr);
905 Newz(602,stbp, 1, STBP);
906 stab->str_ptr = stbp;
907 stab->str_len = stab->str_cur = sizeof(STBP);
909 strcpy(stab_magic(stab),"StB");
910 stab_val(stab) = Str_new(72,0);
911 stab_line(stab) = curcmd->c_line;
912 stab_estab(stab) = stab;
913 str_magic((STR*)stab, stab, '*', name, len);
914 stab_stash(stab) = stash;
915 if (isDIGIT(*name) && *name != '0') {
916 stab_flags(stab) = SF_VMAGIC;
917 str_magic(stab_val(stab), stab, 0, Nullch, 0);
920 stab->str_pok |= SP_MULTI;
926 stab_fullname(str,stab)
930 HASH *tb = stab_stash(stab);
934 str_set(str,tb->tbl_name);
935 str_ncat(str,"'", 1);
936 str_scat(str,stab->str_magic);
940 stab_efullname(str,stab)
944 HASH *tb = stab_estash(stab);
948 str_set(str,tb->tbl_name);
949 str_ncat(str,"'", 1);
950 str_scat(str,stab_estab(stab)->str_magic);
958 Newz(603,stio,1,STIO);
968 register HENT *entry;
972 for (i = min; i <= max; i++) {
973 for (entry = defstash->tbl_array[i]; entry; entry = entry->hent_next) {
974 stab = (STAB*)entry->hent_val;
975 if (stab->str_pok & SP_MULTI)
977 curcmd->c_line = stab_line(stab);
978 warn("Possible typo: \"%s\"", stab_name(stab));
983 static int gensym = 0;
988 (void)sprintf(tokenbuf,"_GEN_%d",gensym++);
989 return stabent(tokenbuf,TRUE);
992 /* hopefully this is only called on local symbol table entries */
1001 if (!stab || !stab->str_ptr)
1003 afree(stab_xarray(stab));
1004 stab_xarray(stab) = Null(ARRAY*);
1005 (void)hfree(stab_xhash(stab), FALSE);
1006 stab_xhash(stab) = Null(HASH*);
1007 str_free(stab_val(stab));
1008 stab_val(stab) = Nullstr;
1010 if (stio = stab_io(stab)) {
1011 do_close(stab,FALSE);
1012 Safefree(stio->top_name);
1013 Safefree(stio->fmt_name);
1017 if (sub = stab_sub(stab)) {
1021 Safefree(stab->str_ptr);
1022 stab->str_ptr = Null(STBP*);
1027 #if defined(CRIPPLED_CC) && (defined(iAPX286) || defined(M_I286) || defined(I80286))
1031 #ifdef MICROPORT /* Microport 2.4 hack */
1032 ARRAY *stab_array(stab)
1033 register STAB *stab;
1035 if (((STBP*)(stab->str_ptr))->stbp_array)
1036 return ((STBP*)(stab->str_ptr))->stbp_array;
1038 return ((STBP*)(aadd(stab)->str_ptr))->stbp_array;
1041 HASH *stab_hash(stab)
1042 register STAB *stab;
1044 if (((STBP*)(stab->str_ptr))->stbp_hash)
1045 return ((STBP*)(stab->str_ptr))->stbp_hash;
1047 return ((STBP*)(hadd(stab)->str_ptr))->stbp_hash;
1049 #endif /* Microport 2.4 hack */