Context Navigation

source: trunk/third/perl/stab.c @ 9009

Visit:

Revision 9009, 23.2 KB checked in by ghudson, 28 years ago (diff)
This commit was generated by cvs2svn to compensate for changes in r9008, which included commits to RCS files with non-trunk default branches.

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

Note: See TracBrowser for help on using the repository browser.

Download in other formats: