Context Navigation

source: trunk/third/perl/perl.c @ 9059

Visit:

Revision 9059, 36.9 KB checked in by ghudson, 28 years ago (diff)
Don't rely on RCS IDs.

Line
1	char rcsid[] = "$RCSfile: perl.c,v $$Revision: 1.2 $$Date: 1996-10-05 18:34:24 $\nPatch level: ###\n";
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 1.1.1.1 1996/10/02 06:39:56 ghudson
10	* Import of perl 4.036
11	*
12	* Revision 4.0.1.8 1993/02/05 19:39:30 lwall
13	* patch36: the taintanyway code wasn't tainting anyway
14	* patch36: Malformed cmd links core dump apparently fixed
15	*
16	* Revision 4.0.1.7 92/06/08 14:50:39 lwall
17	* patch20: PERLLIB now supports multiple directories
18	* patch20: running taintperl explicitly now does checks even if $< == $>
19	* patch20: -e 'cmd' no longer fails silently if /tmp runs out of space
20	* patch20: perl -P now uses location of sed determined by Configure
21	* patch20: form feed for formats is now specifiable via $^L
22	* patch20: paragraph mode now skips extra newlines automatically
23	* patch20: eval "1 #comment" didn't work
24	* patch20: couldn't require . files
25	* patch20: semantic compilation errors didn't abort execution
26	*
27	* Revision 4.0.1.6 91/11/11 16:38:45 lwall
28	* patch19: default arg for shift was wrong after first subroutine definition
29	* patch19: op/regexp.t failed from missing arg to bcmp()
30	*
31	* Revision 4.0.1.5 91/11/05 18:03:32 lwall
32	* patch11: random cleanup
33	* patch11: $0 was being truncated at times
34	* patch11: cppstdin now installed outside of source directory
35	* patch11: -P didn't allow use of #elif or #undef
36	* patch11: prepared for ctype implementations that don't define isascii()
37	* patch11: added eval {}
38	* patch11: eval confused by string containing null
39	*
40	* Revision 4.0.1.4 91/06/10 01:23:07 lwall
41	* patch10: perl -v printed incorrect copyright notice
42	*
43	* Revision 4.0.1.3 91/06/07 11:40:18 lwall
44	* patch4: changed old $^P to $^X
45	*
46	* Revision 4.0.1.2 91/06/07 11:26:16 lwall
47	* patch4: new copyright notice
48	* patch4: added $^P variable to control calling of perldb routines
49	* patch4: added $^F variable to specify maximum system fd, default 2
50	* patch4: debugger lost track of lines in eval
51	*
52	* Revision 4.0.1.1 91/04/11 17:49:05 lwall
53	* patch1: fixed undefined environ problem
54	*
55	* Revision 4.0 91/03/20 01:37:44 lwall
56	* 4.0 baseline.
57	*
58	*/
59
60	/SUPPRESS 560/
61
62	#include "EXTERN.h"
63	#include "perl.h"
64	#include "perly.h"
65	#include "patchlevel.h"
66
67	char *getenv();
68
69	#ifdef IAMSUID
70	#ifndef DOSUID
71	#define DOSUID
72	#endif
73	#endif
74
75	#ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
76	#ifdef DOSUID
77	#undef DOSUID
78	#endif
79	#endif
80
81	static char* moreswitches();
82	static void incpush();
83	static char* cddir;
84	static bool minus_c;
85	static char patchlevel[6];
86	static char *nrs = "\n";
87	static int nrschar = '\n'; /* final char of rs, or 0777 if none */
88	static int nrslen = 1;
89
90	main(argc,argv,env)
91	register int argc;
92	register char **argv;
93	register char **env;
94	{
95	register STR *str;
96	register char *s;
97	char *scriptname;
98	char *getenv();
99	bool dosearch = FALSE;
100	#ifdef DOSUID
101	char *validarg = "";
102	#endif
103
104	#ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
105	#ifdef IAMSUID
106	#undef IAMSUID
107	fatal("suidperl is no longer needed since the kernel can now execute\n\
108	setuid perl scripts securely.\n");
109	#endif
110	#endif
111
112	origargv = argv;
113	origargc = argc;
114	origenviron = environ;
115	uid = (int)getuid();
116	euid = (int)geteuid();
117	gid = (int)getgid();
118	egid = (int)getegid();
119	sprintf(patchlevel,"4.0%2.2d", PATCHLEVEL);
120	#ifdef MSDOS
121	/*
122	* There is no way we can refer to them from Perl so close them to save
123	* space. The other alternative would be to provide STDAUX and STDPRN
124	* filehandles.
125	*/
126	(void)fclose(stdaux);
127	(void)fclose(stdprn);
128	#endif
129	if (do_undump) {
130	origfilename = savestr(argv[0]);
131	do_undump = 0;
132	loop_ptr = -1; /* start label stack again */
133	goto just_doit;
134	}
135	#ifdef TAINT
136	#ifndef DOSUID
137	if (uid == euid && gid == egid)
138	taintanyway = TRUE; /* running taintperl explicitly */
139	#endif
140	#endif
141	(void)sprintf(index(rcsid,'#'), "%d\n", PATCHLEVEL);
142	linestr = Str_new(65,80);
143	str_nset(linestr,"",0);
144	str = str_make("",0); /* first used for -I flags */
145	curstash = defstash = hnew(0);
146	curstname = str_make("main",4);
147	stab_xhash(stabent("_main",TRUE)) = defstash;
148	defstash->tbl_name = "main";
149	incstab = hadd(aadd(stabent("INC",TRUE)));
150	incstab->str_pok \|= SP_MULTI;
151	for (argc--,argv++; argc > 0; argc--,argv++) {
152	if (argv[0][0] != '-' \|\| !argv[0][1])
153	break;
154	#ifdef DOSUID
155	if (*validarg)
156	validarg = " PHOOEY ";
157	else
158	validarg = argv[0];
159	#endif
160	s = argv[0]+1;
161	reswitch:
162	switch (*s) {
163	case '0':
164	case 'a':
165	case 'c':
166	case 'd':
167	case 'D':
168	case 'i':
169	case 'l':
170	case 'n':
171	case 'p':
172	case 'u':
173	case 'U':
174	case 'v':
175	case 'w':
176	if (s = moreswitches(s))
177	goto reswitch;
178	break;
179
180	case 'e':
181	#ifdef TAINT
182	if (euid != uid \|\| egid != gid)
183	fatal("No -e allowed in setuid scripts");
184	#endif
185	if (!e_fp) {
186	e_tmpname = savestr(TMPPATH);
187	(void)mktemp(e_tmpname);
188	if (!*e_tmpname)
189	fatal("Can't mktemp()");
190	e_fp = fopen(e_tmpname,"w");
191	if (!e_fp)
192	fatal("Cannot open temporary file");
193	}
194	if (argv[1]) {
195	fputs(argv[1],e_fp);
196	argc--,argv++;
197	}
198	(void)putc('\n', e_fp);
199	break;
200	case 'I':
201	#ifdef TAINT
202	if (euid != uid \|\| egid != gid)
203	fatal("No -I allowed in setuid scripts");
204	#endif
205	str_cat(str,"-");
206	str_cat(str,s);
207	str_cat(str," ");
208	if (*++s) {
209	(void)apush(stab_array(incstab),str_make(s,0));
210	}
211	else if (argv[1]) {
212	(void)apush(stab_array(incstab),str_make(argv[1],0));
213	str_cat(str,argv[1]);
214	argc--,argv++;
215	str_cat(str," ");
216	}
217	break;
218	case 'P':
219	#ifdef TAINT
220	if (euid != uid \|\| egid != gid)
221	fatal("No -P allowed in setuid scripts");
222	#endif
223	preprocess = TRUE;
224	s++;
225	goto reswitch;
226	case 's':
227	#ifdef TAINT
228	if (euid != uid \|\| egid != gid)
229	fatal("No -s allowed in setuid scripts");
230	#endif
231	doswitches = TRUE;
232	s++;
233	goto reswitch;
234	case 'S':
235	#ifdef TAINT
236	if (euid != uid \|\| egid != gid)
237	fatal("No -S allowed in setuid scripts");
238	#endif
239	dosearch = TRUE;
240	s++;
241	goto reswitch;
242	case 'x':
243	doextract = TRUE;
244	s++;
245	if (*s)
246	cddir = savestr(s);
247	break;
248	case '-':
249	argc--,argv++;
250	goto switch_end;
251	case 0:
252	break;
253	default:
254	fatal("Unrecognized switch: -%s",s);
255	}
256	}
257	switch_end:
258	scriptname = argv[0];
259	if (e_fp) {
260	if (fflush(e_fp) \|\| ferror(e_fp) \|\| fclose(e_fp))
261	fatal("Can't write to temp file for -e: %s", strerror(errno));
262	argc++,argv--;
263	scriptname = e_tmpname;
264	}
265
266	#ifdef DOSISH
267	#define PERLLIB_SEP ';'
268	#else
269	#define PERLLIB_SEP ':'
270	#endif
271	#ifndef TAINT /* Can't allow arbitrary PERLLIB in setuid script */
272	incpush(getenv("PERLLIB"));
273	#endif /* TAINT */
274
275	#ifndef PRIVLIB
276	#define PRIVLIB "/usr/local/lib/perl"
277	#endif
278	incpush(PRIVLIB);
279	(void)apush(stab_array(incstab),str_make(".",1));
280
281	str_set(&str_no,No);
282	str_set(&str_yes,Yes);
283
284	/* open script */
285
286	if (scriptname == Nullch)
287	#ifdef MSDOS
288	{
289	if ( isatty(fileno(stdin)) )
290	moreswitches("v");
291	scriptname = "-";
292	}
293	#else
294	scriptname = "-";
295	#endif
296	if (dosearch && !index(scriptname, '/') && (s = getenv("PATH"))) {
297	char xfound = Nullch, xfailed = Nullch;
298	int len;
299
300	bufend = s + strlen(s);
301	while (*s) {
302	#ifndef DOSISH
303	s = cpytill(tokenbuf,s,bufend,':',&len);
304	#else
305	#ifdef atarist
306	for (len = 0; s && s != ',' && s != ';'; tokenbuf[len++] = s++);
307	tokenbuf[len] = '\0';
308	#else
309	for (len = 0; s && s != ';'; tokenbuf[len++] = *s++);
310	tokenbuf[len] = '\0';
311	#endif
312	#endif
313	if (*s)
314	s++;
315	#ifndef DOSISH
316	if (len && tokenbuf[len-1] != '/')
317	#else
318	#ifdef atarist
319	if (len && ((tokenbuf[len-1] != '\\') && (tokenbuf[len-1] != '/')))
320	#else
321	if (len && tokenbuf[len-1] != '\\')
322	#endif
323	#endif
324	(void)strcat(tokenbuf+len,"/");
325	(void)strcat(tokenbuf+len,scriptname);
326	#ifdef DEBUGGING
327	if (debug & 1)
328	fprintf(stderr,"Looking for %s\n",tokenbuf);
329	#endif
330	if (stat(tokenbuf,&statbuf) < 0) /* not there? */
331	continue;
332	if (S_ISREG(statbuf.st_mode)
333	&& cando(S_IRUSR,TRUE,&statbuf) && cando(S_IXUSR,TRUE,&statbuf)) {
334	xfound = tokenbuf; /* bingo! */
335	break;
336	}
337	if (!xfailed)
338	xfailed = savestr(tokenbuf);
339	}
340	if (!xfound)
341	fatal("Can't execute %s", xfailed ? xfailed : scriptname );
342	if (xfailed)
343	Safefree(xfailed);
344	scriptname = savestr(xfound);
345	}
346
347	fdpid = anew(Nullstab); /* for remembering popen pids by fd */
348	pidstatus = hnew(COEFFSIZE);/* for remembering status of dead pids */
349
350	origfilename = savestr(scriptname);
351	curcmd->c_filestab = fstab(origfilename);
352	if (strEQ(origfilename,"-"))
353	scriptname = "";
354	if (preprocess) {
355	char *cpp = CPPSTDIN;
356
357	if (strEQ(cpp,"cppstdin"))
358	sprintf(tokenbuf, "%s/%s", SCRIPTDIR, cpp);
359	else
360	sprintf(tokenbuf, "%s", cpp);
361	str_cat(str,"-I");
362	str_cat(str,PRIVLIB);
363	#ifdef MSDOS
364	(void)sprintf(buf, "\
365	sed %s -e \"/^[^#]/b\" \
366	-e \"/^#[ ]*include[ ]/b\" \
367	-e \"/^#[ ]*define[ ]/b\" \
368	-e \"/^#[ ]*if[ ]/b\" \
369	-e \"/^#[ ]*ifdef[ ]/b\" \
370	-e \"/^#[ ]*ifndef[ ]/b\" \
371	-e \"/^#[ ]*else/b\" \
372	-e \"/^#[ ]*elif[ ]/b\" \
373	-e \"/^#[ ]*undef[ ]/b\" \
374	-e \"/^#[ ]*endif/b\" \
375	-e \"s/^#.*//\" \
376	%s \| %s -C %s %s",
377	(doextract ? "-e \"1,/^#/d\n\"" : ""),
378	#else
379	(void)sprintf(buf, "\
380	%s %s -e '/^[^#]/b' \
381	-e '/^#[ ]*include[ ]/b' \
382	-e '/^#[ ]*define[ ]/b' \
383	-e '/^#[ ]*if[ ]/b' \
384	-e '/^#[ ]*ifdef[ ]/b' \
385	-e '/^#[ ]*ifndef[ ]/b' \
386	-e '/^#[ ]*else/b' \
387	-e '/^#[ ]*elif[ ]/b' \
388	-e '/^#[ ]*undef[ ]/b' \
389	-e '/^#[ ]*endif/b' \
390	-e 's/^[ ]#.//' \
391	%s \| %s -C %s %s",
392	#ifdef LOC_SED
393	LOC_SED,
394	#else
395	"sed",
396	#endif
397	(doextract ? "-e '1,/^#/d\n'" : ""),
398	#endif
399	scriptname, tokenbuf, str_get(str), CPPMINUS);
400	#ifdef DEBUGGING
401	if (debug & 64) {
402	fputs(buf,stderr);
403	fputs("\n",stderr);
404	}
405	#endif
406	doextract = FALSE;
407	#ifdef IAMSUID /* actually, this is caught earlier */
408	if (euid != uid && !euid) { /* if running suidperl */
409	#ifdef HAS_SETEUID
410	(void)seteuid(uid); /* musn't stay setuid root */
411	#else
412	#ifdef HAS_SETREUID
413	(void)setreuid(-1, uid);
414	#else
415	setuid(uid);
416	#endif
417	#endif
418	if (geteuid() != uid)
419	fatal("Can't do seteuid!\n");
420	}
421	#endif /* IAMSUID */
422	rsfp = mypopen(buf,"r");
423	}
424	else if (!*scriptname) {
425	#ifdef TAINT
426	if (euid != uid \|\| egid != gid)
427	fatal("Can't take set-id script from stdin");
428	#endif
429	rsfp = stdin;
430	}
431	else
432	rsfp = fopen(scriptname,"r");
433	if ((FILE*)rsfp == Nullfp) {
434	#ifdef DOSUID
435	#ifndef IAMSUID /* in case script is not readable before setuid */
436	if (euid && stat(stab_val(curcmd->c_filestab)->str_ptr,&statbuf) >= 0 &&
437	statbuf.st_mode & (S_ISUID\|S_ISGID)) {
438	(void)sprintf(buf, "%s/sperl%s", BIN, patchlevel);
439	execv(buf, origargv); /* try again */
440	fatal("Can't do setuid\n");
441	}
442	#endif
443	#endif
444	fatal("Can't open perl script \"%s\": %s\n",
445	stab_val(curcmd->c_filestab)->str_ptr, strerror(errno));
446	}
447	str_free(str); /* free -I directories */
448	str = Nullstr;
449
450	/* do we need to emulate setuid on scripts? */
451
452	/* This code is for those BSD systems that have setuid #! scripts disabled
453	* in the kernel because of a security problem. Merely defining DOSUID
454	* in perl will not fix that problem, but if you have disabled setuid
455	* scripts in the kernel, this will attempt to emulate setuid and setgid
456	* on scripts that have those now-otherwise-useless bits set. The setuid
457	* root version must be called suidperl or sperlN.NNN. If regular perl
458	* discovers that it has opened a setuid script, it calls suidperl with
459	* the same argv that it had. If suidperl finds that the script it has
460	* just opened is NOT setuid root, it sets the effective uid back to the
461	* uid. We don't just make perl setuid root because that loses the
462	* effective uid we had before invoking perl, if it was different from the
463	* uid.
464	*
465	* DOSUID must be defined in both perl and suidperl, and IAMSUID must
466	* be defined in suidperl only. suidperl must be setuid root. The
467	* Configure script will set this up for you if you want it.
468	*
469	* There is also the possibility of have a script which is running
470	* set-id due to a C wrapper. We want to do the TAINT checks
471	* on these set-id scripts, but don't want to have the overhead of
472	* them in normal perl, and can't use suidperl because it will lose
473	* the effective uid info, so we have an additional non-setuid root
474	* version called taintperl or tperlN.NNN that just does the TAINT checks.
475	*/
476
477	#ifdef DOSUID
478	if (fstat(fileno(rsfp),&statbuf) < 0) /* normal stat is insecure */
479	fatal("Can't stat script \"%s\"",origfilename);
480	if (statbuf.st_mode & (S_ISUID\|S_ISGID)) {
481	int len;
482
483	#ifdef IAMSUID
484	#ifndef HAS_SETREUID
485	/* On this access check to make sure the directories are readable,
486	* there is actually a small window that the user could use to make
487	* filename point to an accessible directory. So there is a faint
488	* chance that someone could execute a setuid script down in a
489	* non-accessible directory. I don't know what to do about that.
490	* But I don't think it's too important. The manual lies when
491	* it says access() is useful in setuid programs.
492	*/
493	if (access(stab_val(curcmd->c_filestab)->str_ptr,1)) /double check/
494	fatal("Permission denied");
495	#else
496	/* If we can swap euid and uid, then we can determine access rights
497	* with a simple stat of the file, and then compare device and
498	* inode to make sure we did stat() on the same file we opened.
499	* Then we just have to make sure he or she can execute it.
500	*/
501	{
502	struct stat tmpstatbuf;
503
504	if (setreuid(euid,uid) < 0 \|\| getuid() != euid \|\| geteuid() != uid)
505	fatal("Can't swap uid and euid"); /* really paranoid */
506	if (stat(stab_val(curcmd->c_filestab)->str_ptr,&tmpstatbuf) < 0)
507	fatal("Permission denied"); /* testing full pathname here */
508	if (tmpstatbuf.st_dev != statbuf.st_dev \|\|
509	tmpstatbuf.st_ino != statbuf.st_ino) {
510	(void)fclose(rsfp);
511	if (rsfp = mypopen("/bin/mail root","w")) { /* heh, heh */
512	fprintf(rsfp,
513	"User %d tried to run dev %d ino %d in place of dev %d ino %d!\n\
514	(Filename of set-id script was %s, uid %d gid %d.)\n\nSincerely,\nperl\n",
515	uid,tmpstatbuf.st_dev, tmpstatbuf.st_ino,
516	statbuf.st_dev, statbuf.st_ino,
517	stab_val(curcmd->c_filestab)->str_ptr,
518	statbuf.st_uid, statbuf.st_gid);
519	(void)mypclose(rsfp);
520	}
521	fatal("Permission denied\n");
522	}
523	if (setreuid(uid,euid) < 0 \|\| getuid() != uid \|\| geteuid() != euid)
524	fatal("Can't reswap uid and euid");
525	if (!cando(S_IXUSR,FALSE,&statbuf)) /* can real uid exec? */
526	fatal("Permission denied\n");
527	}
528	#endif /* HAS_SETREUID */
529	#endif /* IAMSUID */
530
531	if (!S_ISREG(statbuf.st_mode))
532	fatal("Permission denied");
533	if (statbuf.st_mode & S_IWOTH)
534	fatal("Setuid/gid script is writable by world");
535	doswitches = FALSE; /* -s is insecure in suid */
536	curcmd->c_line++;
537	if (fgets(tokenbuf,sizeof tokenbuf, rsfp) == Nullch \|\|
538	strnNE(tokenbuf,"#!",2) ) /* required even on Sys V */
539	fatal("No #! line");
540	s = tokenbuf+2;
541	if (*s == ' ') s++;
542	while (!isSPACE(*s)) s++;
543	if (strnNE(s-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
544	fatal("Not a perl script");
545	while (s == ' ' \|\| s == '\t') s++;
546	/*
547	* #! arg must be what we saw above. They can invoke it by
548	* mentioning suidperl explicitly, but they may not add any strange
549	* arguments beyond what #! says if they do invoke suidperl that way.
550	*/
551	len = strlen(validarg);
552	if (strEQ(validarg," PHOOEY ") \|\|
553	strnNE(s,validarg,len) \|\| !isSPACE(s[len]))
554	fatal("Args must match #! line");
555
556	#ifndef IAMSUID
557	if (euid != uid && (statbuf.st_mode & S_ISUID) &&
558	euid == statbuf.st_uid)
559	if (!do_undump)
560	fatal("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
561	FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
562	#endif /* IAMSUID */
563
564	if (euid) { /* oops, we're not the setuid root perl */
565	(void)fclose(rsfp);
566	#ifndef IAMSUID
567	(void)sprintf(buf, "%s/sperl%s", BIN, patchlevel);
568	execv(buf, origargv); /* try again */
569	#endif
570	fatal("Can't do setuid\n");
571	}
572
573	if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid) {
574	#ifdef HAS_SETEGID
575	(void)setegid(statbuf.st_gid);
576	#else
577	#ifdef HAS_SETREGID
578	(void)setregid((GIDTYPE)-1,statbuf.st_gid);
579	#else
580	setgid(statbuf.st_gid);
581	#endif
582	#endif
583	if (getegid() != statbuf.st_gid)
584	fatal("Can't do setegid!\n");
585	}
586	if (statbuf.st_mode & S_ISUID) {
587	if (statbuf.st_uid != euid)
588	#ifdef HAS_SETEUID
589	(void)seteuid(statbuf.st_uid); /* all that for this */
590	#else
591	#ifdef HAS_SETREUID
592	(void)setreuid((UIDTYPE)-1,statbuf.st_uid);
593	#else
594	setuid(statbuf.st_uid);
595	#endif
596	#endif
597	if (geteuid() != statbuf.st_uid)
598	fatal("Can't do seteuid!\n");
599	}
600	else if (uid) { /* oops, mustn't run as root */
601	#ifdef HAS_SETEUID
602	(void)seteuid((UIDTYPE)uid);
603	#else
604	#ifdef HAS_SETREUID
605	(void)setreuid((UIDTYPE)-1,(UIDTYPE)uid);
606	#else
607	setuid((UIDTYPE)uid);
608	#endif
609	#endif
610	if (geteuid() != uid)
611	fatal("Can't do seteuid!\n");
612	}
613	uid = (int)getuid();
614	euid = (int)geteuid();
615	gid = (int)getgid();
616	egid = (int)getegid();
617	if (!cando(S_IXUSR,TRUE,&statbuf))
618	fatal("Permission denied\n"); /* they can't do this */
619	}
620	#ifdef IAMSUID
621	else if (preprocess)
622	fatal("-P not allowed for setuid/setgid script\n");
623	else
624	fatal("Script is not setuid/setgid in suidperl\n");
625	#else
626	#ifndef TAINT /* we aren't taintperl or suidperl */
627	/* script has a wrapper--can't run suidperl or we lose euid */
628	else if (euid != uid \|\| egid != gid) {
629	(void)fclose(rsfp);
630	(void)sprintf(buf, "%s/tperl%s", BIN, patchlevel);
631	execv(buf, origargv); /* try again */
632	fatal("Can't run setuid script with taint checks");
633	}
634	#endif /* TAINT */
635	#endif /* IAMSUID */
636	#else /* !DOSUID */
637	#ifndef TAINT /* we aren't taintperl or suidperl */
638	if (euid != uid \|\| egid != gid) { /* (suidperl doesn't exist, in fact) */
639	#ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
640	fstat(fileno(rsfp),&statbuf); /* may be either wrapped or real suid */
641	if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
642	\|\|
643	(egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
644	)
645	if (!do_undump)
646	fatal("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
647	FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
648	#endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
649	/* not set-id, must be wrapped */
650	(void)fclose(rsfp);
651	(void)sprintf(buf, "%s/tperl%s", BIN, patchlevel);
652	execv(buf, origargv); /* try again */
653	fatal("Can't run setuid script with taint checks");
654	}
655	#endif /* TAINT */
656	#endif /* DOSUID */
657
658	#if !defined(IAMSUID) && !defined(TAINT)
659
660	/* skip forward in input to the real script? */
661
662	while (doextract) {
663	if ((s = str_gets(linestr, rsfp, 0)) == Nullch)
664	fatal("No Perl script found in input\n");
665	if (*s == '#' && s[1] == '!' && instr(s,"perl")) {
666	ungetc('\n',rsfp); /* to keep line count right */
667	doextract = FALSE;
668	if (s = instr(s,"perl -")) {
669	s += 6;
670	/SUPPRESS 530/
671	while (s = moreswitches(s)) ;
672	}
673	if (cddir && chdir(cddir) < 0)
674	fatal("Can't chdir to %s",cddir);
675	}
676	}
677	#endif /* !defined(IAMSUID) && !defined(TAINT) */
678
679	defstab = stabent("_",TRUE);
680
681	subname = str_make("main",4);
682	if (perldb) {
683	debstash = hnew(0);
684	stab_xhash(stabent("_DB",TRUE)) = debstash;
685	curstash = debstash;
686	dbargs = stab_xarray(aadd((tmpstab = stabent("args",TRUE))));
687	tmpstab->str_pok \|= SP_MULTI;
688	dbargs->ary_flags = 0;
689	DBstab = stabent("DB",TRUE);
690	DBstab->str_pok \|= SP_MULTI;
691	DBline = stabent("dbline",TRUE);
692	DBline->str_pok \|= SP_MULTI;
693	DBsub = hadd(tmpstab = stabent("sub",TRUE));
694	tmpstab->str_pok \|= SP_MULTI;
695	DBsingle = stab_val((tmpstab = stabent("single",TRUE)));
696	tmpstab->str_pok \|= SP_MULTI;
697	DBtrace = stab_val((tmpstab = stabent("trace",TRUE)));
698	tmpstab->str_pok \|= SP_MULTI;
699	DBsignal = stab_val((tmpstab = stabent("signal",TRUE)));
700	tmpstab->str_pok \|= SP_MULTI;
701	curstash = defstash;
702	}
703
704	/* init tokener */
705
706	bufend = bufptr = str_get(linestr);
707
708	savestack = anew(Nullstab); /* for saving non-local values */
709	stack = anew(Nullstab); /* for saving non-local values */
710	stack->ary_flags = 0; /* not a real array */
711	afill(stack,63); afill(stack,-1); /* preextend stack */
712	afill(savestack,63); afill(savestack,-1);
713
714	/* now parse the script */
715
716	error_count = 0;
717	if (yyparse() \|\| error_count) {
718	if (minus_c)
719	fatal("%s had compilation errors.\n", origfilename);
720	else {
721	fatal("Execution of %s aborted due to compilation errors.\n",
722	origfilename);
723	}
724	}
725
726	New(50,loop_stack,128,struct loop);
727	#ifdef DEBUGGING
728	if (debug) {
729	New(51,debname,128,char);
730	New(52,debdelim,128,char);
731	}
732	#endif
733	curstash = defstash;
734
735	preprocess = FALSE;
736	if (e_fp) {
737	e_fp = Nullfp;
738	(void)UNLINK(e_tmpname);
739	}
740
741	/* initialize everything that won't change if we undump */
742
743	if (sigstab = stabent("SIG",allstabs)) {
744	sigstab->str_pok \|= SP_MULTI;
745	(void)hadd(sigstab);
746	}
747
748	magicalize("!#?^~=-%.+&*()<>,\\/[\|`':\004\t\020\024\027\006");
749	userinit(); /* in case linked C routines want magical variables */
750
751	amperstab = stabent("&",allstabs);
752	leftstab = stabent("`",allstabs);
753	rightstab = stabent("'",allstabs);
754	sawampersand = (amperstab \|\| leftstab \|\| rightstab);
755	if (tmpstab = stabent(":",allstabs))
756	str_set(stab_val(tmpstab),chopset);
757	if (tmpstab = stabent("\024",allstabs))
758	time(&basetime);
759
760	/* these aren't necessarily magical */
761	if (tmpstab = stabent("\014",allstabs)) {
762	str_set(stab_val(tmpstab),"\f");
763	formfeed = stab_val(tmpstab);
764	}
765	if (tmpstab = stabent(";",allstabs))
766	str_set(STAB_STR(tmpstab),"\034");
767	if (tmpstab = stabent("]",allstabs)) {
768	str = STAB_STR(tmpstab);
769	str_set(str,rcsid);
770	str->str_u.str_nval = atof(patchlevel);
771	str->str_nok = 1;
772	}
773	str_nset(stab_val(stabent("\"", TRUE)), " ", 1);
774
775	stdinstab = stabent("STDIN",TRUE);
776	stdinstab->str_pok \|= SP_MULTI;
777	if (!stab_io(stdinstab))
778	stab_io(stdinstab) = stio_new();
779	stab_io(stdinstab)->ifp = stdin;
780	tmpstab = stabent("stdin",TRUE);
781	stab_io(tmpstab) = stab_io(stdinstab);
782	tmpstab->str_pok \|= SP_MULTI;
783
784	tmpstab = stabent("STDOUT",TRUE);
785	tmpstab->str_pok \|= SP_MULTI;
786	if (!stab_io(tmpstab))
787	stab_io(tmpstab) = stio_new();
788	stab_io(tmpstab)->ofp = stab_io(tmpstab)->ifp = stdout;
789	defoutstab = tmpstab;
790	tmpstab = stabent("stdout",TRUE);
791	stab_io(tmpstab) = stab_io(defoutstab);
792	tmpstab->str_pok \|= SP_MULTI;
793
794	curoutstab = stabent("STDERR",TRUE);
795	curoutstab->str_pok \|= SP_MULTI;
796	if (!stab_io(curoutstab))
797	stab_io(curoutstab) = stio_new();
798	stab_io(curoutstab)->ofp = stab_io(curoutstab)->ifp = stderr;
799	tmpstab = stabent("stderr",TRUE);
800	stab_io(tmpstab) = stab_io(curoutstab);
801	tmpstab->str_pok \|= SP_MULTI;
802	curoutstab = defoutstab; /* switch back to STDOUT */
803
804	statname = Str_new(66,0); /* last filename we did stat on */
805
806	/* now that script is parsed, we can modify record separator */
807
808	rs = nrs;
809	rslen = nrslen;
810	rschar = nrschar;
811	rspara = (nrslen == 2);
812	str_nset(stab_val(stabent("/", TRUE)), rs, rslen);
813
814	if (do_undump)
815	my_unexec();
816
817	just_doit: /* come here if running an undumped a.out */
818	argc--,argv++; /* skip name of script */
819	if (doswitches) {
820	for (; argc > 0 && **argv == '-'; argc--,argv++) {
821	if (argv[0][1] == '-') {
822	argc--,argv++;
823	break;
824	}
825	if (s = index(argv[0], '=')) {
826	*s++ = '\0';
827	str_set(stab_val(stabent(argv[0]+1,TRUE)),s);
828	}
829	else
830	str_numset(stab_val(stabent(argv[0]+1,TRUE)),(double)1.0);
831	}
832	}
833	#ifdef TAINT
834	tainted = 1;
835	#endif
836	if (tmpstab = stabent("0",allstabs)) {
837	str_set(stab_val(tmpstab),origfilename);
838	magicname("0", Nullch, 0);
839	}
840	if (tmpstab = stabent("\030",allstabs))
841	str_set(stab_val(tmpstab),origargv[0]);
842	if (argvstab = stabent("ARGV",allstabs)) {
843	argvstab->str_pok \|= SP_MULTI;
844	(void)aadd(argvstab);
845	aclear(stab_array(argvstab));
846	for (; argc > 0; argc--,argv++) {
847	(void)apush(stab_array(argvstab),str_make(argv[0],0));
848	}
849	}
850	#ifdef TAINT
851	(void) stabent("ENV",TRUE); /* must test PATH and IFS */
852	#endif
853	if (envstab = stabent("ENV",allstabs)) {
854	envstab->str_pok \|= SP_MULTI;
855	(void)hadd(envstab);
856	hclear(stab_hash(envstab), FALSE);
857	if (env != environ)
858	environ[0] = Nullch;
859	for (; *env; env++) {
860	if (!(s = index(*env,'=')))
861	continue;
862	*s++ = '\0';
863	str = str_make(s--,0);
864	str_magic(str, envstab, 'E', env, s - env);
865	(void)hstore(stab_hash(envstab), env, s - env, str, 0);
866	*s = '=';
867	}
868	}
869	#ifdef TAINT
870	tainted = 0;
871	#endif
872	if (tmpstab = stabent("$",allstabs))
873	str_numset(STAB_STR(tmpstab),(double)getpid());
874
875	if (dowarn) {
876	stab_check('A','Z');
877	stab_check('a','z');
878	}
879
880	if (setjmp(top_env)) /* sets goto_targ on longjump */
881	loop_ptr = -1; /* start label stack again */
882
883	#ifdef DEBUGGING
884	if (debug & 1024)
885	dump_all();
886	if (debug)
887	fprintf(stderr,"\nEXECUTING...\n\n");
888	#endif
889
890	if (minus_c) {
891	fprintf(stderr,"%s syntax OK\n", origfilename);
892	exit(0);
893	}
894
895	/* do it */
896
897	(void) cmd_exec(main_root,G_SCALAR,-1);
898
899	if (goto_targ)
900	fatal("Can't find label \"%s\"--aborting",goto_targ);
901	exit(0);
902	/* NOTREACHED */
903	}
904
905	void
906	magicalize(list)
907	register char *list;
908	{
909	char sym[2];
910
911	sym[1] = '\0';
912	while (sym = list++)
913	magicname(sym, Nullch, 0);
914	}
915
916	void
917	magicname(sym,name,namlen)
918	char *sym;
919	char *name;
920	int namlen;
921	{
922	register STAB *stab;
923
924	if (stab = stabent(sym,allstabs)) {
925	stab_flags(stab) = SF_VMAGIC;
926	str_magic(stab_val(stab), stab, 0, name, namlen);
927	}
928	}
929
930	static void
931	incpush(p)
932	char *p;
933	{
934	char *s;
935
936	if (!p)
937	return;
938
939	/* Break at all separators */
940	while (*p) {
941	/* First, skip any consecutive separators */
942	while ( *p == PERLLIB_SEP ) {
943	/* Uncomment the next line for PATH semantics */
944	/* (void)apush(stab_array(incstab), str_make(".", 1)); */
945	p++;
946	}
947	if ( (s = index(p, PERLLIB_SEP)) != Nullch ) {
948	(void)apush(stab_array(incstab), str_make(p, (int)(s - p)));
949	p = s + 1;
950	} else {
951	(void)apush(stab_array(incstab), str_make(p, 0));
952	break;
953	}
954	}
955	}
956
957	void
958	savelines(array, str)
959	ARRAY *array;
960	STR *str;
961	{
962	register char *s = str->str_ptr;
963	register char *send = str->str_ptr + str->str_cur;
964	register char *t;
965	register int line = 1;
966
967	while (s && s < send) {
968	STR *tmpstr = Str_new(85,0);
969
970	t = index(s, '\n');
971	if (t)
972	t++;
973	else
974	t = send;
975
976	str_nset(tmpstr, s, t - s);
977	astore(array, line++, tmpstr);
978	s = t;
979	}
980	}
981
982	/* this routine is in perl.c by virtue of being sort of an alternate main() */
983
984	int
985	do_eval(str,optype,stash,savecmd,gimme,arglast)
986	STR *str;
987	int optype;
988	HASH *stash;
989	int savecmd;
990	int gimme;
991	int *arglast;
992	{
993	STR **st = stack->ary_array;
994	int retval;
995	CMD *myroot = Nullcmd;
996	ARRAY *ar;
997	int i;
998	CMD * VOLATILE oldcurcmd = curcmd;
999	VOLATILE int oldtmps_base = tmps_base;
1000	VOLATILE int oldsave = savestack->ary_fill;
1001	VOLATILE int oldperldb = perldb;
1002	SPAT * VOLATILE oldspat = curspat;
1003	SPAT * VOLATILE oldlspat = lastspat;
1004	static char *last_eval = Nullch;
1005	static long last_elen = 0;
1006	static CMD *last_root = Nullcmd;
1007	VOLATILE int sp = arglast[0];
1008	char *specfilename;
1009	char *tmpfilename;
1010	int parsing = 1;
1011
1012	tmps_base = tmps_max;
1013	if (curstash != stash) {
1014	(void)savehptr(&curstash);
1015	curstash = stash;
1016	}
1017	str_set(stab_val(stabent("@",TRUE)),"");
1018	if (curcmd->c_line == 0) /* don't debug debugger... */
1019	perldb = FALSE;
1020	curcmd = &compiling;
1021	if (optype == O_EVAL) { /* normal eval */
1022	curcmd->c_filestab = fstab("(eval)");
1023	curcmd->c_line = 1;
1024	str_sset(linestr,str);
1025	str_cat(linestr,";\n;\n"); /* be kind to them */
1026	if (perldb)
1027	savelines(stab_xarray(curcmd->c_filestab), linestr);
1028	}
1029	else {
1030	if (last_root && !in_eval) {
1031	Safefree(last_eval);
1032	last_eval = Nullch;
1033	cmd_free(last_root);
1034	last_root = Nullcmd;
1035	}
1036	specfilename = str_get(str);
1037	str_set(linestr,"");
1038	if (optype == O_REQUIRE && &str_undef !=
1039	hfetch(stab_hash(incstab), specfilename, strlen(specfilename), 0)) {
1040	curcmd = oldcurcmd;
1041	tmps_base = oldtmps_base;
1042	st[++sp] = &str_yes;
1043	perldb = oldperldb;
1044	return sp;
1045	}
1046	tmpfilename = savestr(specfilename);
1047	if (*tmpfilename == '/' \|\|
1048	(*tmpfilename == '.' &&
1049	(tmpfilename[1] == '/' \|\|
1050	(tmpfilename[1] == '.' && tmpfilename[2] == '/'))))
1051	{
1052	rsfp = fopen(tmpfilename,"r");
1053	}
1054	else {
1055	ar = stab_array(incstab);
1056	for (i = 0; i <= ar->ary_fill; i++) {
1057	(void)sprintf(buf, "%s/%s",
1058	str_get(afetch(ar,i,TRUE)), specfilename);
1059	rsfp = fopen(buf,"r");
1060	if (rsfp) {
1061	char *s = buf;
1062
1063	if (*s == '.' && s[1] == '/')
1064	s += 2;
1065	Safefree(tmpfilename);
1066	tmpfilename = savestr(s);
1067	break;
1068	}
1069	}
1070	}
1071	curcmd->c_filestab = fstab(tmpfilename);
1072	Safefree(tmpfilename);
1073	tmpfilename = Nullch;
1074	if (!rsfp) {
1075	curcmd = oldcurcmd;
1076	tmps_base = oldtmps_base;
1077	if (optype == O_REQUIRE) {
1078	sprintf(tokenbuf,"Can't locate %s in @INC", specfilename);
1079	if (instr(tokenbuf,".h "))
1080	strcat(tokenbuf," (change .h to .ph maybe?)");
1081	if (instr(tokenbuf,".ph "))
1082	strcat(tokenbuf," (did you run h2ph?)");
1083	fatal("%s",tokenbuf);
1084	}
1085	if (gimme != G_ARRAY)
1086	st[++sp] = &str_undef;
1087	perldb = oldperldb;
1088	return sp;
1089	}
1090	curcmd->c_line = 0;
1091	}
1092	in_eval++;
1093	oldoldbufptr = oldbufptr = bufptr = str_get(linestr);
1094	bufend = bufptr + linestr->str_cur;
1095	if (++loop_ptr >= loop_max) {
1096	loop_max += 128;
1097	Renew(loop_stack, loop_max, struct loop);
1098	}
1099	loop_stack[loop_ptr].loop_label = "_EVAL_";
1100	loop_stack[loop_ptr].loop_sp = sp;
1101	#ifdef DEBUGGING
1102	if (debug & 4) {
1103	deb("(Pushing label #%d _EVAL_)\n", loop_ptr);
1104	}
1105	#endif
1106	eval_root = Nullcmd;
1107	if (setjmp(loop_stack[loop_ptr].loop_env)) {
1108	retval = 1;
1109	}
1110	else {
1111	error_count = 0;
1112	if (rsfp) {
1113	retval = yyparse();
1114	retval \|= error_count;
1115	}
1116	else if (last_root && last_elen == bufend - bufptr
1117	&& bufptr == last_eval && !bcmp(bufptr,last_eval,last_elen)){
1118	retval = 0;
1119	eval_root = last_root; /* no point in reparsing */
1120	}
1121	else if (in_eval == 1 && !savecmd) {
1122	if (last_root) {
1123	Safefree(last_eval);
1124	last_eval = Nullch;
1125	cmd_free(last_root);
1126	}
1127	last_root = Nullcmd;
1128	last_elen = bufend - bufptr;
1129	last_eval = nsavestr(bufptr, last_elen);
1130	retval = yyparse();
1131	retval \|= error_count;
1132	if (!retval)
1133	last_root = eval_root;
1134	if (!last_root) {
1135	Safefree(last_eval);
1136	last_eval = Nullch;
1137	}
1138	}
1139	else
1140	retval = yyparse();
1141	}
1142	myroot = eval_root; /* in case cmd_exec does another eval! */
1143
1144	if (retval \|\| error_count) {
1145	st = stack->ary_array;
1146	sp = arglast[0];
1147	if (gimme != G_ARRAY)
1148	st[++sp] = &str_undef;
1149	if (parsing) {
1150	#ifndef MANGLEDPARSE
1151	#ifdef DEBUGGING
1152	if (debug & 128)
1153	fprintf(stderr,"Freeing eval_root %lx\n",(long)eval_root);
1154	#endif
1155	cmd_free(eval_root);
1156	#endif
1157	/SUPPRESS 29/ /SUPPRESS 30/
1158	if ((CMD*)eval_root == last_root)
1159	last_root = Nullcmd;
1160	eval_root = myroot = Nullcmd;
1161	}
1162	if (rsfp) {
1163	fclose(rsfp);
1164	rsfp = 0;
1165	}
1166	}
1167	else {
1168	parsing = 0;
1169	sp = cmd_exec(eval_root,gimme,sp);
1170	st = stack->ary_array;
1171	for (i = arglast[0] + 1; i <= sp; i++)
1172	st[i] = str_mortal(st[i]);
1173	/* if we don't save result, free zaps it */
1174	if (savecmd)
1175	eval_root = myroot;
1176	else if (in_eval != 1 && myroot != last_root)
1177	cmd_free(myroot);
1178	if (eval_root == myroot)
1179	eval_root = Nullcmd;
1180	}
1181
1182	perldb = oldperldb;
1183	in_eval--;
1184	#ifdef DEBUGGING
1185	if (debug & 4) {
1186	char *tmps = loop_stack[loop_ptr].loop_label;
1187	deb("(Popping label #%d %s)\n",loop_ptr,
1188	tmps ? tmps : "" );
1189	}
1190	#endif
1191	loop_ptr--;
1192	tmps_base = oldtmps_base;
1193	curspat = oldspat;
1194	lastspat = oldlspat;
1195	if (savestack->ary_fill > oldsave) /* let them use local() */
1196	restorelist(oldsave);
1197
1198	if (optype != O_EVAL) {
1199	if (retval) {
1200	if (optype == O_REQUIRE)
1201	fatal("%s", str_get(stab_val(stabent("@",TRUE))));
1202	}
1203	else {
1204	curcmd = oldcurcmd;
1205	if (gimme == G_SCALAR ? str_true(st[sp]) : sp > arglast[0]) {
1206	(void)hstore(stab_hash(incstab), specfilename,
1207	strlen(specfilename), str_smake(stab_val(curcmd->c_filestab)),
1208	0 );
1209	}
1210	else if (optype == O_REQUIRE)
1211	fatal("%s did not return a true value", specfilename);
1212	}
1213	}
1214	curcmd = oldcurcmd;
1215	return sp;
1216	}
1217
1218	int
1219	do_try(cmd,gimme,arglast)
1220	CMD *cmd;
1221	int gimme;
1222	int *arglast;
1223	{
1224	STR **st = stack->ary_array;
1225
1226	CMD * VOLATILE oldcurcmd = curcmd;
1227	VOLATILE int oldtmps_base = tmps_base;
1228	VOLATILE int oldsave = savestack->ary_fill;
1229	SPAT * VOLATILE oldspat = curspat;
1230	SPAT * VOLATILE oldlspat = lastspat;
1231	VOLATILE int sp = arglast[0];
1232
1233	tmps_base = tmps_max;
1234	str_set(stab_val(stabent("@",TRUE)),"");
1235	in_eval++;
1236	if (++loop_ptr >= loop_max) {
1237	loop_max += 128;
1238	Renew(loop_stack, loop_max, struct loop);
1239	}
1240	loop_stack[loop_ptr].loop_label = "_EVAL_";
1241	loop_stack[loop_ptr].loop_sp = sp;
1242	#ifdef DEBUGGING
1243	if (debug & 4) {
1244	deb("(Pushing label #%d _EVAL_)\n", loop_ptr);
1245	}
1246	#endif
1247	if (setjmp(loop_stack[loop_ptr].loop_env)) {
1248	st = stack->ary_array;
1249	sp = arglast[0];
1250	if (gimme != G_ARRAY)
1251	st[++sp] = &str_undef;
1252	}
1253	else {
1254	sp = cmd_exec(cmd,gimme,sp);
1255	st = stack->ary_array;
1256	/* for (i = arglast[0] + 1; i <= sp; i++)
1257	st[i] = str_mortal(st[i]); not needed, I think */
1258	/* if we don't save result, free zaps it */
1259	}
1260
1261	in_eval--;
1262	#ifdef DEBUGGING
1263	if (debug & 4) {
1264	char *tmps = loop_stack[loop_ptr].loop_label;
1265	deb("(Popping label #%d %s)\n",loop_ptr,
1266	tmps ? tmps : "" );
1267	}
1268	#endif
1269	loop_ptr--;
1270	tmps_base = oldtmps_base;
1271	curspat = oldspat;
1272	lastspat = oldlspat;
1273	curcmd = oldcurcmd;
1274	if (savestack->ary_fill > oldsave) /* let them use local() */
1275	restorelist(oldsave);
1276
1277	return sp;
1278	}
1279
1280	/* This routine handles any switches that can be given during run */
1281
1282	static char *
1283	moreswitches(s)
1284	char *s;
1285	{
1286	int numlen;
1287
1288	switch (*s) {
1289	case '0':
1290	nrschar = scanoct(s, 4, &numlen);
1291	nrs = nsavestr("\n",1);
1292	*nrs = nrschar;
1293	if (nrschar > 0377) {
1294	nrslen = 0;
1295	nrs = "";
1296	}
1297	else if (!nrschar && numlen >= 2) {
1298	nrslen = 2;
1299	nrs = "\n\n";
1300	nrschar = '\n';
1301	}
1302	return s + numlen;
1303	case 'a':
1304	minus_a = TRUE;
1305	s++;
1306	return s;
1307	case 'c':
1308	minus_c = TRUE;
1309	s++;
1310	return s;
1311	case 'd':
1312	#ifdef TAINT
1313	if (euid != uid \|\| egid != gid)
1314	fatal("No -d allowed in setuid scripts");
1315	#endif
1316	perldb = TRUE;
1317	s++;
1318	return s;
1319	case 'D':
1320	#ifdef DEBUGGING
1321	#ifdef TAINT
1322	if (euid != uid \|\| egid != gid)
1323	fatal("No -D allowed in setuid scripts");
1324	#endif
1325	debug = atoi(s+1) \| 32768;
1326	#else
1327	warn("Recompile perl with -DDEBUGGING to use -D switch\n");
1328	#endif
1329	/SUPPRESS 530/
1330	for (s++; isDIGIT(*s); s++) ;
1331	return s;
1332	case 'i':
1333	inplace = savestr(s+1);
1334	/SUPPRESS 530/
1335	for (s = inplace; s && !isSPACE(s); s++) ;
1336	*s = '\0';
1337	break;
1338	case 'I':
1339	#ifdef TAINT
1340	if (euid != uid \|\| egid != gid)
1341	fatal("No -I allowed in setuid scripts");
1342	#endif
1343	if (*++s) {
1344	(void)apush(stab_array(incstab),str_make(s,0));
1345	}
1346	else
1347	fatal("No space allowed after -I");
1348	break;
1349	case 'l':
1350	minus_l = TRUE;
1351	s++;
1352	if (isDIGIT(*s)) {
1353	ors = savestr("\n");
1354	orslen = 1;
1355	ors = scanoct(s, 3 + (s == '0'), &numlen);
1356	s += numlen;
1357	}
1358	else {
1359	ors = nsavestr(nrs,nrslen);
1360	orslen = nrslen;
1361	}
1362	return s;
1363	case 'n':
1364	minus_n = TRUE;
1365	s++;
1366	return s;
1367	case 'p':
1368	minus_p = TRUE;
1369	s++;
1370	return s;
1371	case 'u':
1372	do_undump = TRUE;
1373	s++;
1374	return s;
1375	case 'U':
1376	unsafe = TRUE;
1377	s++;
1378	return s;
1379	case 'v':
1380	fputs("\nThis is perl, version 4.0\n\n",stdout);
1381	fputs(rcsid,stdout);
1382	fputs("\nCopyright (c) 1989, 1990, 1991, Larry Wall\n",stdout);
1383	#ifdef MSDOS
1384	fputs("MS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n",
1385	stdout);
1386	#ifdef OS2
1387	fputs("OS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n",
1388	stdout);
1389	#endif
1390	#endif
1391	#ifdef atarist
1392	fputs("atariST series port, ++jrb bammi@cadence.com\n", stdout);
1393	#endif
1394	fputs("\n\
1395	Perl may be copied only under the terms of either the Artistic License or the\n\
1396	GNU General Public License, which may be found in the Perl 4.0 source kit.\n",stdout);
1397	#ifdef MSDOS
1398	usage(origargv[0]);
1399	#endif
1400	exit(0);
1401	case 'w':
1402	dowarn = TRUE;
1403	s++;
1404	return s;
1405	case ' ':
1406	case '\n':
1407	case '\t':
1408	break;
1409	default:
1410	fatal("Switch meaningless after -x: -%s",s);
1411	}
1412	return Nullch;
1413	}
1414
1415	/* compliments of Tom Christiansen */
1416
1417	/* unexec() can be found in the Gnu emacs distribution */
1418
1419	void
1420	my_unexec()
1421	{
1422	#ifdef UNEXEC
1423	int status;
1424	extern int etext;
1425	static char dumpname[BUFSIZ];
1426	static char perlpath[256];
1427
1428	sprintf (dumpname, "%s.perldump", origfilename);
1429	sprintf (perlpath, "%s/perl", BIN);
1430
1431	status = unexec(dumpname, perlpath, &etext, sbrk(0), 0);
1432	if (status)
1433	fprintf(stderr, "unexec of %s into %s failed!\n", perlpath, dumpname);
1434	exit(status);
1435	#else
1436	#ifdef DOSISH
1437	abort(); /* nothing else to do */
1438	#else /* ! MSDOS */
1439	# ifndef SIGABRT
1440	# define SIGABRT SIGILL
1441	# endif
1442	# ifndef SIGILL
1443	# define SIGILL 6 /* blech */
1444	# endif
1445	kill(getpid(),SIGABRT); /* for use with undump */
1446	#endif /* ! MSDOS */
1447	#endif
1448	}
1449

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

Download in other formats: