Context Navigation

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

Visit:

Revision 10730, 64.3 KB checked in by ghudson, 27 years ago (diff)
Merge with perl 5.004_04. Previous local modifications are no longer necessary; will revert RCS file to vendor branch after this commit.

Line
1	/* perl.c
2	*
3	* Copyright (c) 1987-1997 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	*/
9
10	/*
11	* "A ship then new they built for him/of mithril and of elven glass" --Bilbo
12	*/
13
14	#include "EXTERN.h"
15	#include "perl.h"
16	#include "patchlevel.h"
17
18	/* XXX If this causes problems, set i_unistd=undef in the hint file. */
19	#ifdef I_UNISTD
20	#include <unistd.h>
21	#endif
22
23	#if !defined(STANDARD_C) && !defined(HAS_GETENV_PROTOTYPE)
24	char getenv _((char )); /* Usually in <stdlib.h> */
25	#endif
26
27	dEXTCONST char rcsid[] = "perl.c\nPatch level: ###\n";
28
29	#ifdef IAMSUID
30	#ifndef DOSUID
31	#define DOSUID
32	#endif
33	#endif
34
35	#ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
36	#ifdef DOSUID
37	#undef DOSUID
38	#endif
39	#endif
40
41	#define I_REINIT \
42	STMT_START { \
43	chopset = " \n-"; \
44	copline = NOLINE; \
45	curcop = &compiling; \
46	curcopdb = NULL; \
47	cxstack_ix = -1; \
48	cxstack_max = 128; \
49	dbargs = 0; \
50	dlmax = 128; \
51	laststatval = -1; \
52	laststype = OP_STAT; \
53	maxscream = -1; \
54	maxsysfd = MAXSYSFD; \
55	statname = Nullsv; \
56	tmps_floor = -1; \
57	tmps_ix = -1; \
58	op_mask = NULL; \
59	dlmax = 128; \
60	laststatval = -1; \
61	laststype = OP_STAT; \
62	mess_sv = Nullsv; \
63	} STMT_END
64
65	static void find_beginning _((void));
66	static void forbid_setid _((char *));
67	static void incpush _((char *, int));
68	static void init_ids _((void));
69	static void init_debugger _((void));
70	static void init_lexer _((void));
71	static void init_main_stash _((void));
72	static void init_perllib _((void));
73	static void init_postdump_symbols _((int, char , char ));
74	static void init_predump_symbols _((void));
75	static void init_stacks _((void));
76	static void my_exit_jump _((void)) __attribute__((noreturn));
77	static void nuke_stacks _((void));
78	static void open_script _((char , bool, SV ));
79	static void usage _((char *));
80	static void validate_suid _((char , char));
81
82	static int fdscript = -1;
83
84	PerlInterpreter *
85	perl_alloc()
86	{
87	PerlInterpreter *sv_interp;
88
89	curinterp = 0;
90	New(53, sv_interp, 1, PerlInterpreter);
91	return sv_interp;
92	}
93
94	void
95	perl_construct( sv_interp )
96	register PerlInterpreter *sv_interp;
97	{
98	if (!(curinterp = sv_interp))
99	return;
100
101	#ifdef MULTIPLICITY
102	Zero(sv_interp, 1, PerlInterpreter);
103	#endif
104
105	/* Init the real globals? */
106	if (!linestr) {
107	linestr = NEWSV(65,80);
108	sv_upgrade(linestr,SVt_PVIV);
109
110	if (!SvREADONLY(&sv_undef)) {
111	SvREADONLY_on(&sv_undef);
112
113	sv_setpv(&sv_no,No);
114	SvNV(&sv_no);
115	SvREADONLY_on(&sv_no);
116
117	sv_setpv(&sv_yes,Yes);
118	SvNV(&sv_yes);
119	SvREADONLY_on(&sv_yes);
120	}
121
122	nrs = newSVpv("\n", 1);
123	rs = SvREFCNT_inc(nrs);
124
125	pidstatus = newHV();
126
127	#ifdef MSDOS
128	/*
129	* There is no way we can refer to them from Perl so close them to save
130	* space. The other alternative would be to provide STDAUX and STDPRN
131	* filehandles.
132	*/
133	(void)fclose(stdaux);
134	(void)fclose(stdprn);
135	#endif
136	}
137
138	#ifdef MULTIPLICITY
139	I_REINIT;
140	perl_destruct_level = 1;
141	#else
142	if(perl_destruct_level > 0)
143	I_REINIT;
144	#endif
145
146	init_ids();
147	lex_state = LEX_NOTPARSING;
148
149	start_env.je_prev = NULL;
150	start_env.je_ret = -1;
151	start_env.je_mustcatch = TRUE;
152	top_env = &start_env;
153	STATUS_ALL_SUCCESS;
154
155	SET_NUMERIC_STANDARD();
156	#if defined(SUBVERSION) && SUBVERSION > 0
157	sprintf(patchlevel, "%7.5f", (double) 5
158	+ ((double) PATCHLEVEL / (double) 1000)
159	+ ((double) SUBVERSION / (double) 100000));
160	#else
161	sprintf(patchlevel, "%5.3f", (double) 5 +
162	((double) PATCHLEVEL / (double) 1000));
163	#endif
164
165	#if defined(LOCAL_PATCH_COUNT)
166	localpatches = local_patches; /* For possible -v */
167	#endif
168
169	PerlIO_init(); /* Hook to IO system */
170
171	fdpid = newAV(); /* for remembering popen pids by fd */
172
173	init_stacks();
174	ENTER;
175	}
176
177	void
178	perl_destruct(sv_interp)
179	register PerlInterpreter *sv_interp;
180	{
181	int destruct_level; /* 0=none, 1=full, 2=full with checks */
182	I32 last_sv_count;
183	HV *hv;
184
185	if (!(curinterp = sv_interp))
186	return;
187
188	destruct_level = perl_destruct_level;
189	#ifdef DEBUGGING
190	{
191	char *s;
192	if (s = getenv("PERL_DESTRUCT_LEVEL")) {
193	int i = atoi(s);
194	if (destruct_level < i)
195	destruct_level = i;
196	}
197	}
198	#endif
199
200	LEAVE;
201	FREETMPS;
202
203	/* We must account for everything. */
204
205	/* Destroy the main CV and syntax tree */
206	if (main_root) {
207	curpad = AvARRAY(comppad);
208	op_free(main_root);
209	main_root = Nullop;
210	}
211	main_start = Nullop;
212	SvREFCNT_dec(main_cv);
213	main_cv = Nullcv;
214
215	if (sv_objcount) {
216	/*
217	* Try to destruct global references. We do this first so that the
218	* destructors and destructees still exist. Some sv's might remain.
219	* Non-referenced objects are on their own.
220	*/
221
222	dirty = TRUE;
223	sv_clean_objs();
224	}
225
226	/* unhook hooks which will soon be, or use, destroyed data */
227	SvREFCNT_dec(warnhook);
228	warnhook = Nullsv;
229	SvREFCNT_dec(diehook);
230	diehook = Nullsv;
231	SvREFCNT_dec(parsehook);
232	parsehook = Nullsv;
233
234	if (destruct_level == 0){
235
236	DEBUG_P(debprofdump());
237
238	/* The exit() function will do everything that needs doing. */
239	return;
240	}
241
242	/* loosen bonds of global variables */
243
244	if(rsfp) {
245	(void)PerlIO_close(rsfp);
246	rsfp = Nullfp;
247	}
248
249	/* Filters for program text */
250	SvREFCNT_dec(rsfp_filters);
251	rsfp_filters = Nullav;
252
253	/* switches */
254	preprocess = FALSE;
255	minus_n = FALSE;
256	minus_p = FALSE;
257	minus_l = FALSE;
258	minus_a = FALSE;
259	minus_F = FALSE;
260	doswitches = FALSE;
261	dowarn = FALSE;
262	doextract = FALSE;
263	sawampersand = FALSE; /* must save all match strings */
264	sawstudy = FALSE; /* do fbm_instr on all strings */
265	sawvec = FALSE;
266	unsafe = FALSE;
267
268	Safefree(inplace);
269	inplace = Nullch;
270
271	Safefree(e_tmpname);
272	e_tmpname = Nullch;
273
274	if (e_fp) {
275	PerlIO_close(e_fp);
276	e_fp = Nullfp;
277	}
278
279	/* magical thingies */
280
281	Safefree(ofs); /* $, */
282	ofs = Nullch;
283
284	Safefree(ors); /* $\ */
285	ors = Nullch;
286
287	SvREFCNT_dec(nrs); /* $\ helper */
288	nrs = Nullsv;
289
290	multiline = 0; /* $* */
291
292	SvREFCNT_dec(statname);
293	statname = Nullsv;
294	statgv = Nullgv;
295
296	/* defgv, aka _ should be taken care of elsewhere /
297
298	#if 0 /* just about all regexp stuff, seems to be ok */
299
300	/* shortcuts to regexp stuff */
301	leftgv = Nullgv;
302	ampergv = Nullgv;
303
304	SAVEFREEOP(curpm);
305	SAVEFREEOP(oldlastpm); /* for saving regexp context during debugger */
306
307	regprecomp = NULL; /* uncompiled string. */
308	regparse = NULL; /* Input-scan pointer. */
309	regxend = NULL; /* End of input for compile */
310	regnpar = 0; /* () count. */
311	regcode = NULL; /* Code-emit pointer; &regdummy = don't. */
312	regsize = 0; /* Code size. */
313	regnaughty = 0; /* How bad is this pattern? */
314	regsawback = 0; /* Did we see \1, ...? */
315
316	reginput = NULL; /* String-input pointer. */
317	regbol = NULL; /* Beginning of input, for ^ check. */
318	regeol = NULL; /* End of input, for $ check. */
319	regstartp = (char *)NULL; / Pointer to startp array. */
320	regendp = (char *)NULL; / Ditto for endp. */
321	reglastparen = 0; /* Similarly for lastparen. */
322	regtill = NULL; /* How far we are required to go. */
323	regflags = 0; /* are we folding, multilining? */
324	regprev = (char)NULL; /* char before regbol, \n if none */
325
326	#endif /* if 0 */
327
328	/* clean up after study() */
329	SvREFCNT_dec(lastscream);
330	lastscream = Nullsv;
331	Safefree(screamfirst);
332	screamfirst = 0;
333	Safefree(screamnext);
334	screamnext = 0;
335
336	/* startup and shutdown function lists */
337	SvREFCNT_dec(beginav);
338	SvREFCNT_dec(endav);
339	beginav = Nullav;
340	endav = Nullav;
341
342	/* temp stack during pp_sort() */
343	SvREFCNT_dec(sortstack);
344	sortstack = Nullav;
345
346	/* shortcuts just get cleared */
347	envgv = Nullgv;
348	siggv = Nullgv;
349	incgv = Nullgv;
350	errgv = Nullgv;
351	argvgv = Nullgv;
352	argvoutgv = Nullgv;
353	stdingv = Nullgv;
354	last_in_gv = Nullgv;
355
356	/* reset so print() ends up where we expect */
357	setdefout(Nullgv);
358
359	/* Prepare to destruct main symbol table. */
360
361	hv = defstash;
362	defstash = 0;
363	SvREFCNT_dec(hv);
364
365	FREETMPS;
366	if (destruct_level >= 2) {
367	if (scopestack_ix != 0)
368	warn("Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
369	(long)scopestack_ix);
370	if (savestack_ix != 0)
371	warn("Unbalanced saves: %ld more saves than restores\n",
372	(long)savestack_ix);
373	if (tmps_floor != -1)
374	warn("Unbalanced tmps: %ld more allocs than frees\n",
375	(long)tmps_floor + 1);
376	if (cxstack_ix != -1)
377	warn("Unbalanced context: %ld more PUSHes than POPs\n",
378	(long)cxstack_ix + 1);
379	}
380
381	/* Now absolutely destruct everything, somehow or other, loops or no. */
382	last_sv_count = 0;
383	SvFLAGS(strtab) \|= SVTYPEMASK; /* don't clean out strtab now */
384	while (sv_count != 0 && sv_count != last_sv_count) {
385	last_sv_count = sv_count;
386	sv_clean_all();
387	}
388	SvFLAGS(strtab) &= ~SVTYPEMASK;
389	SvFLAGS(strtab) \|= SVt_PVHV;
390
391	/* Destruct the global string table. */
392	{
393	/* Yell and reset the HeVAL() slots that are still holding refcounts,
394	* so that sv_free() won't fail on them.
395	*/
396	I32 riter;
397	I32 max;
398	HE *hent;
399	HE **array;
400
401	riter = 0;
402	max = HvMAX(strtab);
403	array = HvARRAY(strtab);
404	hent = array[0];
405	for (;;) {
406	if (hent) {
407	warn("Unbalanced string table refcount: (%d) for \"%s\"",
408	HeVAL(hent) - Nullsv, HeKEY(hent));
409	HeVAL(hent) = Nullsv;
410	hent = HeNEXT(hent);
411	}
412	if (!hent) {
413	if (++riter > max)
414	break;
415	hent = array[riter];
416	}
417	}
418	}
419	SvREFCNT_dec(strtab);
420
421	if (sv_count != 0)
422	warn("Scalars leaked: %ld\n", (long)sv_count);
423
424	sv_free_arenas();
425
426	/* No SVs have survived, need to clean out */
427	linestr = NULL;
428	pidstatus = Nullhv;
429	if (origfilename)
430	Safefree(origfilename);
431	nuke_stacks();
432	hints = 0; /* Reset hints. Should hints be per-interpreter ? */
433
434	DEBUG_P(debprofdump());
435
436	/* As the absolutely last thing, free the non-arena SV for mess() */
437
438	if (mess_sv) {
439	/* we know that type >= SVt_PV */
440	SvOOK_off(mess_sv);
441	Safefree(SvPVX(mess_sv));
442	Safefree(SvANY(mess_sv));
443	Safefree(mess_sv);
444	mess_sv = Nullsv;
445	}
446	}
447
448	void
449	perl_free(sv_interp)
450	PerlInterpreter *sv_interp;
451	{
452	if (!(curinterp = sv_interp))
453	return;
454	Safefree(sv_interp);
455	}
456
457	int
458	perl_parse(sv_interp, xsinit, argc, argv, env)
459	PerlInterpreter *sv_interp;
460	void (*xsinit)_((void));
461	int argc;
462	char **argv;
463	char **env;
464	{
465	register SV *sv;
466	register char *s;
467	char *scriptname = NULL;
468	VOL bool dosearch = FALSE;
469	char *validarg = "";
470	I32 oldscope;
471	AV* comppadlist;
472	dJMPENV;
473	int ret;
474
475	#ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
476	#ifdef IAMSUID
477	#undef IAMSUID
478	croak("suidperl is no longer needed since the kernel can now execute\n\
479	setuid perl scripts securely.\n");
480	#endif
481	#endif
482
483	if (!(curinterp = sv_interp))
484	return 255;
485
486	#if defined(NeXT) && defined(__DYNAMIC__)
487	_dyld_lookup_and_bind
488	("__environ", (unsigned long *) &environ_pointer, NULL);
489	#endif /* environ */
490
491	origargv = argv;
492	origargc = argc;
493	#ifndef VMS /* VMS doesn't have environ array */
494	origenviron = environ;
495	#endif
496	e_tmpname = Nullch;
497
498	if (do_undump) {
499
500	/* Come here if running an undumped a.out. */
501
502	origfilename = savepv(argv[0]);
503	do_undump = FALSE;
504	cxstack_ix = -1; /* start label stack again */
505	init_ids();
506	init_postdump_symbols(argc,argv,env);
507	return 0;
508	}
509
510	if (main_root) {
511	curpad = AvARRAY(comppad);
512	op_free(main_root);
513	main_root = Nullop;
514	}
515	main_start = Nullop;
516	SvREFCNT_dec(main_cv);
517	main_cv = Nullcv;
518
519	time(&basetime);
520	oldscope = scopestack_ix;
521
522	JMPENV_PUSH(ret);
523	switch (ret) {
524	case 1:
525	STATUS_ALL_FAILURE;
526	/* FALL THROUGH */
527	case 2:
528	/* my_exit() was called */
529	while (scopestack_ix > oldscope)
530	LEAVE;
531	FREETMPS;
532	curstash = defstash;
533	if (endav)
534	call_list(oldscope, endav);
535	JMPENV_POP;
536	return STATUS_NATIVE_EXPORT;
537	case 3:
538	JMPENV_POP;
539	PerlIO_printf(PerlIO_stderr(), "panic: top_env\n");
540	return 1;
541	}
542
543	sv_setpvn(linestr,"",0);
544	sv = newSVpv("",0); /* first used for -I flags */
545	SAVEFREESV(sv);
546	init_main_stash();
547
548	for (argc--,argv++; argc > 0; argc--,argv++) {
549	if (argv[0][0] != '-' \|\| !argv[0][1])
550	break;
551	#ifdef DOSUID
552	if (*validarg)
553	validarg = " PHOOEY ";
554	else
555	validarg = argv[0];
556	#endif
557	s = argv[0]+1;
558	reswitch:
559	switch (*s) {
560	case '0':
561	case 'F':
562	case 'a':
563	case 'c':
564	case 'd':
565	case 'D':
566	case 'h':
567	case 'i':
568	case 'l':
569	case 'M':
570	case 'm':
571	case 'n':
572	case 'p':
573	case 's':
574	case 'u':
575	case 'U':
576	case 'v':
577	case 'w':
578	if (s = moreswitches(s))
579	goto reswitch;
580	break;
581
582	case 'T':
583	tainting = TRUE;
584	s++;
585	goto reswitch;
586
587	case 'e':
588	if (euid != uid \|\| egid != gid)
589	croak("No -e allowed in setuid scripts");
590	if (!e_fp) {
591	e_tmpname = savepv(TMPPATH);
592	(void)mktemp(e_tmpname);
593	if (!*e_tmpname)
594	croak("Can't mktemp()");
595	e_fp = PerlIO_open(e_tmpname,"w");
596	if (!e_fp)
597	croak("Cannot open temporary file");
598	}
599	if (*++s)
600	PerlIO_puts(e_fp,s);
601	else if (argv[1]) {
602	PerlIO_puts(e_fp,argv[1]);
603	argc--,argv++;
604	}
605	else
606	croak("No code specified for -e");
607	(void)PerlIO_putc(e_fp,'\n');
608	break;
609	case 'I': /* -I handled both here and in moreswitches() */
610	forbid_setid("-I");
611	if (!*++s && (s=argv[1]) != Nullch) {
612	argc--,argv++;
613	}
614	while (s && isSPACE(*s))
615	++s;
616	if (s && *s) {
617	char e, p;
618	for (e = s; e && !isSPACE(e); e++) ;
619	p = savepvn(s, e-s);
620	incpush(p, TRUE);
621	sv_catpv(sv,"-I");
622	sv_catpv(sv,p);
623	sv_catpv(sv," ");
624	Safefree(p);
625	} /* XXX else croak? */
626	break;
627	case 'P':
628	forbid_setid("-P");
629	preprocess = TRUE;
630	s++;
631	goto reswitch;
632	case 'S':
633	forbid_setid("-S");
634	dosearch = TRUE;
635	s++;
636	goto reswitch;
637	case 'V':
638	if (!preambleav)
639	preambleav = newAV();
640	av_push(preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
641	if (*++s != ':') {
642	Sv = newSVpv("print myconfig();",0);
643	#ifdef VMS
644	sv_catpv(Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
645	#else
646	sv_catpv(Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
647	#endif
648	#if defined(DEBUGGING) \|\| defined(NO_EMBED) \|\| defined(MULTIPLICITY)
649	sv_catpv(Sv,"\" Compile-time options:");
650	# ifdef DEBUGGING
651	sv_catpv(Sv," DEBUGGING");
652	# endif
653	# ifdef NO_EMBED
654	sv_catpv(Sv," NO_EMBED");
655	# endif
656	# ifdef MULTIPLICITY
657	sv_catpv(Sv," MULTIPLICITY");
658	# endif
659	sv_catpv(Sv,"\\n\",");
660	#endif
661	#if defined(LOCAL_PATCH_COUNT)
662	if (LOCAL_PATCH_COUNT > 0) {
663	int i;
664	sv_catpv(Sv,"\" Locally applied patches:\\n\",");
665	for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
666	if (localpatches[i])
667	sv_catpvf(Sv,"\" \\t%s\\n\",",localpatches[i]);
668	}
669	}
670	#endif
671	sv_catpvf(Sv,"\" Built under %s\\n\"",OSNAME);
672	#ifdef __DATE__
673	# ifdef __TIME__
674	sv_catpvf(Sv,",\" Compiled at %s %s\\n\"",__DATE__,__TIME__);
675	# else
676	sv_catpvf(Sv,",\" Compiled on %s\\n\"",__DATE__);
677	# endif
678	#endif
679	sv_catpv(Sv, "; \
680	$\"=\"\\n \"; \
681	@env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; \
682	print \" \\%ENV:\\n @env\\n\" if @env; \
683	print \" \\@INC:\\n @INC\\n\";");
684	}
685	else {
686	Sv = newSVpv("config_vars(qw(",0);
687	sv_catpv(Sv, ++s);
688	sv_catpv(Sv, "))");
689	s += strlen(s);
690	}
691	av_push(preambleav, Sv);
692	scriptname = BIT_BUCKET; /* don't look for script or read stdin */
693	goto reswitch;
694	case 'x':
695	doextract = TRUE;
696	s++;
697	if (*s)
698	cddir = savepv(s);
699	break;
700	case 0:
701	break;
702	case '-':
703	if (!++s \|\| isSPACE(s)) {
704	argc--,argv++;
705	goto switch_end;
706	}
707	/* catch use of gnu style long options */
708	if (strEQ(s, "version")) {
709	s = "v";
710	goto reswitch;
711	}
712	if (strEQ(s, "help")) {
713	s = "h";
714	goto reswitch;
715	}
716	s--;
717	/* FALL THROUGH */
718	default:
719	croak("Unrecognized switch: -%s (-h will show valid options)",s);
720	}
721	}
722	switch_end:
723
724	if (!tainting && (s = getenv("PERL5OPT"))) {
725	while (s && *s) {
726	while (isSPACE(*s))
727	s++;
728	if (*s == '-') {
729	s++;
730	if (isSPACE(*s))
731	continue;
732	}
733	if (!*s)
734	break;
735	if (!strchr("DIMUdmw", *s))
736	croak("Illegal switch in PERL5OPT: -%c", *s);
737	s = moreswitches(s);
738	}
739	}
740
741	if (!scriptname)
742	scriptname = argv[0];
743	if (e_fp) {
744	if (PerlIO_flush(e_fp) \|\| PerlIO_error(e_fp) \|\| PerlIO_close(e_fp)) {
745	#ifndef MULTIPLICITY
746	warn("Did you forget to compile with -DMULTIPLICITY?");
747	#endif
748	croak("Can't write to temp file for -e: %s", Strerror(errno));
749	}
750	e_fp = Nullfp;
751	argc++,argv--;
752	scriptname = e_tmpname;
753	}
754	else if (scriptname == Nullch) {
755	#ifdef MSDOS
756	if ( isatty(PerlIO_fileno(PerlIO_stdin())) )
757	moreswitches("h");
758	#endif
759	scriptname = "-";
760	}
761
762	init_perllib();
763
764	open_script(scriptname,dosearch,sv);
765
766	validate_suid(validarg, scriptname);
767
768	if (doextract)
769	find_beginning();
770
771	main_cv = compcv = (CV*)NEWSV(1104,0);
772	sv_upgrade((SV *)compcv, SVt_PVCV);
773	CvUNIQUE_on(compcv);
774
775	comppad = newAV();
776	av_push(comppad, Nullsv);
777	curpad = AvARRAY(comppad);
778	comppad_name = newAV();
779	comppad_name_fill = 0;
780	min_intro_pending = 0;
781	padix = 0;
782
783	comppadlist = newAV();
784	AvREAL_off(comppadlist);
785	av_store(comppadlist, 0, (SV*)comppad_name);
786	av_store(comppadlist, 1, (SV*)comppad);
787	CvPADLIST(compcv) = comppadlist;
788
789	boot_core_UNIVERSAL();
790	if (xsinit)
791	(xsinit)(); / in case linked C routines want magical variables */
792	#if defined(VMS) \|\| defined(WIN32)
793	init_os_extras();
794	#endif
795
796	init_predump_symbols();
797	if (!do_undump)
798	init_postdump_symbols(argc,argv,env);
799
800	init_lexer();
801
802	/* now parse the script */
803
804	error_count = 0;
805	if (yyparse() \|\| error_count) {
806	if (minus_c)
807	croak("%s had compilation errors.\n", origfilename);
808	else {
809	croak("Execution of %s aborted due to compilation errors.\n",
810	origfilename);
811	}
812	}
813	curcop->cop_line = 0;
814	curstash = defstash;
815	preprocess = FALSE;
816	if (e_tmpname) {
817	(void)UNLINK(e_tmpname);
818	Safefree(e_tmpname);
819	e_tmpname = Nullch;
820	}
821
822	/* now that script is parsed, we can modify record separator */
823	SvREFCNT_dec(rs);
824	rs = SvREFCNT_inc(nrs);
825	sv_setsv(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), rs);
826
827	if (do_undump)
828	my_unexec();
829
830	if (dowarn)
831	gv_check(defstash);
832
833	LEAVE;
834	FREETMPS;
835
836	#ifdef MYMALLOC
837	if ((s=getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
838	dump_mstats("after compilation:");
839	#endif
840
841	ENTER;
842	restartop = 0;
843	JMPENV_POP;
844	return 0;
845	}
846
847	int
848	perl_run(sv_interp)
849	PerlInterpreter *sv_interp;
850	{
851	I32 oldscope;
852	dJMPENV;
853	int ret;
854
855	if (!(curinterp = sv_interp))
856	return 255;
857
858	oldscope = scopestack_ix;
859
860	JMPENV_PUSH(ret);
861	switch (ret) {
862	case 1:
863	cxstack_ix = -1; /* start context stack again */
864	break;
865	case 2:
866	/* my_exit() was called */
867	while (scopestack_ix > oldscope)
868	LEAVE;
869	FREETMPS;
870	curstash = defstash;
871	if (endav)
872	call_list(oldscope, endav);
873	#ifdef MYMALLOC
874	if (getenv("PERL_DEBUG_MSTATS"))
875	dump_mstats("after execution: ");
876	#endif
877	JMPENV_POP;
878	return STATUS_NATIVE_EXPORT;
879	case 3:
880	if (!restartop) {
881	PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
882	FREETMPS;
883	JMPENV_POP;
884	return 1;
885	}
886	if (curstack != mainstack) {
887	dSP;
888	SWITCHSTACK(curstack, mainstack);
889	}
890	break;
891	}
892
893	DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
894	sawampersand ? "Enabling" : "Omitting"));
895
896	if (!restartop) {
897	DEBUG_x(dump_all());
898	DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
899
900	if (minus_c) {
901	PerlIO_printf(PerlIO_stderr(), "%s syntax OK\n", origfilename);
902	my_exit(0);
903	}
904	if (PERLDB_SINGLE && DBsingle)
905	sv_setiv(DBsingle, 1);
906	}
907
908	/* do it */
909
910	if (restartop) {
911	op = restartop;
912	restartop = 0;
913	runops();
914	}
915	else if (main_start) {
916	CvDEPTH(main_cv) = 1;
917	op = main_start;
918	runops();
919	}
920
921	my_exit(0);
922	/* NOTREACHED */
923	return 0;
924	}
925
926	SV*
927	perl_get_sv(name, create)
928	char* name;
929	I32 create;
930	{
931	GV* gv = gv_fetchpv(name, create, SVt_PV);
932	if (gv)
933	return GvSV(gv);
934	return Nullsv;
935	}
936
937	AV*
938	perl_get_av(name, create)
939	char* name;
940	I32 create;
941	{
942	GV* gv = gv_fetchpv(name, create, SVt_PVAV);
943	if (create)
944	return GvAVn(gv);
945	if (gv)
946	return GvAV(gv);
947	return Nullav;
948	}
949
950	HV*
951	perl_get_hv(name, create)
952	char* name;
953	I32 create;
954	{
955	GV* gv = gv_fetchpv(name, create, SVt_PVHV);
956	if (create)
957	return GvHVn(gv);
958	if (gv)
959	return GvHV(gv);
960	return Nullhv;
961	}
962
963	CV*
964	perl_get_cv(name, create)
965	char* name;
966	I32 create;
967	{
968	GV* gv = gv_fetchpv(name, create, SVt_PVCV);
969	if (create && !GvCVu(gv))
970	return newSUB(start_subparse(FALSE, 0),
971	newSVOP(OP_CONST, 0, newSVpv(name,0)),
972	Nullop,
973	Nullop);
974	if (gv)
975	return GvCVu(gv);
976	return Nullcv;
977	}
978
979	/* Be sure to refetch the stack pointer after calling these routines. */
980
981	I32
982	perl_call_argv(subname, flags, argv)
983	char *subname;
984	I32 flags; /* See G_* flags in cop.h */
985	register char *argv; / null terminated arg list */
986	{
987	dSP;
988
989	PUSHMARK(sp);
990	if (argv) {
991	while (*argv) {
992	XPUSHs(sv_2mortal(newSVpv(*argv,0)));
993	argv++;
994	}
995	PUTBACK;
996	}
997	return perl_call_pv(subname, flags);
998	}
999
1000	I32
1001	perl_call_pv(subname, flags)
1002	char subname; / name of the subroutine */
1003	I32 flags; /* See G_* flags in cop.h */
1004	{
1005	return perl_call_sv((SV*)perl_get_cv(subname, TRUE), flags);
1006	}
1007
1008	I32
1009	perl_call_method(methname, flags)
1010	char methname; / name of the subroutine */
1011	I32 flags; /* See G_* flags in cop.h */
1012	{
1013	dSP;
1014	OP myop;
1015	if (!op)
1016	op = &myop;
1017	XPUSHs(sv_2mortal(newSVpv(methname,0)));
1018	PUTBACK;
1019	pp_method();
1020	return perl_call_sv(*stack_sp--, flags);
1021	}
1022
1023	/* May be called with any of a CV, a GV, or an SV containing the name. */
1024	I32
1025	perl_call_sv(sv, flags)
1026	SV* sv;
1027	I32 flags; /* See G_* flags in cop.h */
1028	{
1029	LOGOP myop; /* fake syntax tree node */
1030	SV** sp = stack_sp;
1031	I32 oldmark;
1032	I32 retval;
1033	I32 oldscope;
1034	static CV *DBcv;
1035	bool oldcatch = CATCH_GET;
1036	dJMPENV;
1037	int ret;
1038	OP* oldop = op;
1039
1040	if (flags & G_DISCARD) {
1041	ENTER;
1042	SAVETMPS;
1043	}
1044
1045	Zero(&myop, 1, LOGOP);
1046	myop.op_next = Nullop;
1047	if (!(flags & G_NOARGS))
1048	myop.op_flags \|= OPf_STACKED;
1049	myop.op_flags \|= ((flags & G_VOID) ? OPf_WANT_VOID :
1050	(flags & G_ARRAY) ? OPf_WANT_LIST :
1051	OPf_WANT_SCALAR);
1052	SAVESPTR(op);
1053	op = (OP*)&myop;
1054
1055	EXTEND(stack_sp, 1);
1056	*++stack_sp = sv;
1057	oldmark = TOPMARK;
1058	oldscope = scopestack_ix;
1059
1060	if (PERLDB_SUB && curstash != debstash
1061	/* Handle first BEGIN of -d. */
1062	&& (DBcv \|\| (DBcv = GvCV(DBsub)))
1063	/* Try harder, since this may have been a sighandler, thus
1064	* curstash may be meaningless. */
1065	&& (SvTYPE(sv) != SVt_PVCV \|\| CvSTASH((CV*)sv) != debstash))
1066	op->op_private \|= OPpENTERSUB_DB;
1067
1068	if (flags & G_EVAL) {
1069	cLOGOP->op_other = op;
1070	markstack_ptr--;
1071	/* we're trying to emulate pp_entertry() here */
1072	{
1073	register CONTEXT *cx;
1074	I32 gimme = GIMME_V;
1075
1076	ENTER;
1077	SAVETMPS;
1078
1079	push_return(op->op_next);
1080	PUSHBLOCK(cx, CXt_EVAL, stack_sp);
1081	PUSHEVAL(cx, 0, 0);
1082	eval_root = op; /* Only needed so that goto works right. */
1083
1084	in_eval = 1;
1085	if (flags & G_KEEPERR)
1086	in_eval \|= 4;
1087	else
1088	sv_setpv(GvSV(errgv),"");
1089	}
1090	markstack_ptr++;
1091
1092	JMPENV_PUSH(ret);
1093	switch (ret) {
1094	case 0:
1095	break;
1096	case 1:
1097	STATUS_ALL_FAILURE;
1098	/* FALL THROUGH */
1099	case 2:
1100	/* my_exit() was called */
1101	curstash = defstash;
1102	FREETMPS;
1103	JMPENV_POP;
1104	if (statusvalue)
1105	croak("Callback called exit");
1106	my_exit_jump();
1107	/* NOTREACHED */
1108	case 3:
1109	if (restartop) {
1110	op = restartop;
1111	restartop = 0;
1112	break;
1113	}
1114	stack_sp = stack_base + oldmark;
1115	if (flags & G_ARRAY)
1116	retval = 0;
1117	else {
1118	retval = 1;
1119	*++stack_sp = &sv_undef;
1120	}
1121	goto cleanup;
1122	}
1123	}
1124	else
1125	CATCH_SET(TRUE);
1126
1127	if (op == (OP*)&myop)
1128	op = pp_entersub();
1129	if (op)
1130	runops();
1131	retval = stack_sp - (stack_base + oldmark);
1132	if ((flags & G_EVAL) && !(flags & G_KEEPERR))
1133	sv_setpv(GvSV(errgv),"");
1134
1135	cleanup:
1136	if (flags & G_EVAL) {
1137	if (scopestack_ix > oldscope) {
1138	SV **newsp;
1139	PMOP *newpm;
1140	I32 gimme;
1141	register CONTEXT *cx;
1142	I32 optype;
1143
1144	POPBLOCK(cx,newpm);
1145	POPEVAL(cx);
1146	pop_return();
1147	curpm = newpm;
1148	LEAVE;
1149	}
1150	JMPENV_POP;
1151	}
1152	else
1153	CATCH_SET(oldcatch);
1154
1155	if (flags & G_DISCARD) {
1156	stack_sp = stack_base + oldmark;
1157	retval = 0;
1158	FREETMPS;
1159	LEAVE;
1160	}
1161	op = oldop;
1162	return retval;
1163	}
1164
1165	/* Eval a string. The G_EVAL flag is always assumed. */
1166
1167	I32
1168	perl_eval_sv(sv, flags)
1169	SV* sv;
1170	I32 flags; /* See G_* flags in cop.h */
1171	{
1172	UNOP myop; /* fake syntax tree node */
1173	SV** sp = stack_sp;
1174	I32 oldmark = sp - stack_base;
1175	I32 retval;
1176	I32 oldscope;
1177	dJMPENV;
1178	int ret;
1179	OP* oldop = op;
1180
1181	if (flags & G_DISCARD) {
1182	ENTER;
1183	SAVETMPS;
1184	}
1185
1186	SAVESPTR(op);
1187	op = (OP*)&myop;
1188	Zero(op, 1, UNOP);
1189	EXTEND(stack_sp, 1);
1190	*++stack_sp = sv;
1191	oldscope = scopestack_ix;
1192
1193	if (!(flags & G_NOARGS))
1194	myop.op_flags = OPf_STACKED;
1195	myop.op_next = Nullop;
1196	myop.op_type = OP_ENTEREVAL;
1197	myop.op_flags \|= ((flags & G_VOID) ? OPf_WANT_VOID :
1198	(flags & G_ARRAY) ? OPf_WANT_LIST :
1199	OPf_WANT_SCALAR);
1200	if (flags & G_KEEPERR)
1201	myop.op_flags \|= OPf_SPECIAL;
1202
1203	JMPENV_PUSH(ret);
1204	switch (ret) {
1205	case 0:
1206	break;
1207	case 1:
1208	STATUS_ALL_FAILURE;
1209	/* FALL THROUGH */
1210	case 2:
1211	/* my_exit() was called */
1212	curstash = defstash;
1213	FREETMPS;
1214	JMPENV_POP;
1215	if (statusvalue)
1216	croak("Callback called exit");
1217	my_exit_jump();
1218	/* NOTREACHED */
1219	case 3:
1220	if (restartop) {
1221	op = restartop;
1222	restartop = 0;
1223	break;
1224	}
1225	stack_sp = stack_base + oldmark;
1226	if (flags & G_ARRAY)
1227	retval = 0;
1228	else {
1229	retval = 1;
1230	*++stack_sp = &sv_undef;
1231	}
1232	goto cleanup;
1233	}
1234
1235	if (op == (OP*)&myop)
1236	op = pp_entereval();
1237	if (op)
1238	runops();
1239	retval = stack_sp - (stack_base + oldmark);
1240	if (!(flags & G_KEEPERR))
1241	sv_setpv(GvSV(errgv),"");
1242
1243	cleanup:
1244	JMPENV_POP;
1245	if (flags & G_DISCARD) {
1246	stack_sp = stack_base + oldmark;
1247	retval = 0;
1248	FREETMPS;
1249	LEAVE;
1250	}
1251	op = oldop;
1252	return retval;
1253	}
1254
1255	SV*
1256	perl_eval_pv(p, croak_on_error)
1257	char* p;
1258	I32 croak_on_error;
1259	{
1260	dSP;
1261	SV* sv = newSVpv(p, 0);
1262
1263	PUSHMARK(sp);
1264	perl_eval_sv(sv, G_SCALAR);
1265	SvREFCNT_dec(sv);
1266
1267	SPAGAIN;
1268	sv = POPs;
1269	PUTBACK;
1270
1271	if (croak_on_error && SvTRUE(GvSV(errgv)))
1272	croak(SvPVx(GvSV(errgv), na));
1273
1274	return sv;
1275	}
1276
1277	/* Require a module. */
1278
1279	void
1280	perl_require_pv(pv)
1281	char* pv;
1282	{
1283	SV* sv = sv_newmortal();
1284	sv_setpv(sv, "require '");
1285	sv_catpv(sv, pv);
1286	sv_catpv(sv, "'");
1287	perl_eval_sv(sv, G_DISCARD);
1288	}
1289
1290	void
1291	magicname(sym,name,namlen)
1292	char *sym;
1293	char *name;
1294	I32 namlen;
1295	{
1296	register GV *gv;
1297
1298	if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
1299	sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
1300	}
1301
1302	static void
1303	usage(name) /* XXX move this out into a module ? */
1304	char *name;
1305	{
1306	/* This message really ought to be max 23 lines.
1307	* Removed -h because the user already knows that opton. Others? */
1308
1309	static char *usage[] = {
1310	"-0[octal] specify record separator (\\0, if no argument)",
1311	"-a autosplit mode with -n or -p (splits $_ into @F)",
1312	"-c check syntax only (runs BEGIN and END blocks)",
1313	"-d[:debugger] run scripts under debugger",
1314	"-D[number/list] set debugging flags (argument is a bit mask or flags)",
1315	"-e 'command' one line of script. Several -e's allowed. Omit [programfile].",
1316	"-F/pattern/ split() pattern for autosplit (-a). The //'s are optional.",
1317	"-i[extension] edit <> files in place (make backup if extension supplied)",
1318	"-Idirectory specify @INC/#include directory (may be used more than once)",
1319	"-l[octal] enable line ending processing, specifies line terminator",
1320	"-[mM][-]module.. executes `use/no module...' before executing your script.",
1321	"-n assume 'while (<>) { ... }' loop around your script",
1322	"-p assume loop like -n but print line also like sed",
1323	"-P run script through C preprocessor before compilation",
1324	"-s enable some switch parsing for switches after script name",
1325	"-S look for the script using PATH environment variable",
1326	"-T turn on tainting checks",
1327	"-u dump core after parsing script",
1328	"-U allow unsafe operations",
1329	"-v print version number and patchlevel of perl",
1330	"-V[:variable] print perl configuration information",
1331	"-w TURN WARNINGS ON FOR COMPILATION OF YOUR SCRIPT. Recommended.",
1332	"-x[directory] strip off text before #!perl line and perhaps cd to directory",
1333	"\n",
1334	NULL
1335	};
1336	char **p = usage;
1337
1338	printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
1339	while (*p)
1340	printf("\n %s", *p++);
1341	}
1342
1343	/* This routine handles any switches that can be given during run */
1344
1345	char *
1346	moreswitches(s)
1347	char *s;
1348	{
1349	I32 numlen;
1350	U32 rschar;
1351
1352	switch (*s) {
1353	case '0':
1354	rschar = scan_oct(s, 4, &numlen);
1355	SvREFCNT_dec(nrs);
1356	if (rschar & ~((U8)~0))
1357	nrs = &sv_undef;
1358	else if (!rschar && numlen >= 2)
1359	nrs = newSVpv("", 0);
1360	else {
1361	char ch = rschar;
1362	nrs = newSVpv(&ch, 1);
1363	}
1364	return s + numlen;
1365	case 'F':
1366	minus_F = TRUE;
1367	splitstr = savepv(s + 1);
1368	s += strlen(s);
1369	return s;
1370	case 'a':
1371	minus_a = TRUE;
1372	s++;
1373	return s;
1374	case 'c':
1375	minus_c = TRUE;
1376	s++;
1377	return s;
1378	case 'd':
1379	forbid_setid("-d");
1380	s++;
1381	if (s == ':' \|\| s == '=') {
1382	my_setenv("PERL5DB", form("use Devel::%s;", ++s));
1383	s += strlen(s);
1384	}
1385	if (!perldb) {
1386	perldb = PERLDB_ALL;
1387	init_debugger();
1388	}
1389	return s;
1390	case 'D':
1391	#ifdef DEBUGGING
1392	forbid_setid("-D");
1393	if (isALPHA(s[1])) {
1394	static char debopts[] = "psltocPmfrxuLHXD";
1395	char *d;
1396
1397	for (s++; s && (d = strchr(debopts,s)); s++)
1398	debug \|= 1 << (d - debopts);
1399	}
1400	else {
1401	debug = atoi(s+1);
1402	for (s++; isDIGIT(*s); s++) ;
1403	}
1404	debug \|= 0x80000000;
1405	#else
1406	warn("Recompile perl with -DDEBUGGING to use -D switch\n");
1407	for (s++; isALNUM(*s); s++) ;
1408	#endif
1409	/SUPPRESS 530/
1410	return s;
1411	case 'h':
1412	usage(origargv[0]);
1413	exit(0);
1414	case 'i':
1415	if (inplace)
1416	Safefree(inplace);
1417	inplace = savepv(s+1);
1418	/SUPPRESS 530/
1419	for (s = inplace; s && !isSPACE(s); s++) ;
1420	if (*s)
1421	*s++ = '\0';
1422	return s;
1423	case 'I': /* -I handled both here and in parse_perl() */
1424	forbid_setid("-I");
1425	++s;
1426	while (s && isSPACE(s))
1427	++s;
1428	if (*s) {
1429	char e, p;
1430	for (e = s; e && !isSPACE(e); e++) ;
1431	p = savepvn(s, e-s);
1432	incpush(p, TRUE);
1433	Safefree(p);
1434	s = e;
1435	}
1436	else
1437	croak("No space allowed after -I");
1438	return s;
1439	case 'l':
1440	minus_l = TRUE;
1441	s++;
1442	if (ors)
1443	Safefree(ors);
1444	if (isDIGIT(*s)) {
1445	ors = savepv("\n");
1446	orslen = 1;
1447	ors = scan_oct(s, 3 + (s == '0'), &numlen);
1448	s += numlen;
1449	}
1450	else {
1451	if (RsPARA(nrs)) {
1452	ors = "\n\n";
1453	orslen = 2;
1454	}
1455	else
1456	ors = SvPV(nrs, orslen);
1457	ors = savepvn(ors, orslen);
1458	}
1459	return s;
1460	case 'M':
1461	forbid_setid("-M"); /* XXX ? */
1462	/* FALL THROUGH */
1463	case 'm':
1464	forbid_setid("-m"); /* XXX ? */
1465	if (*++s) {
1466	char *start;
1467	char *use = "use ";
1468	/* -M-foo == 'no foo' */
1469	if (*s == '-') { use = "no "; ++s; }
1470	Sv = newSVpv(use,0);
1471	start = s;
1472	/* We allow -M'Module qw(Foo Bar)' */
1473	while(isALNUM(s) \|\| s==':') ++s;
1474	if (*s != '=') {
1475	sv_catpv(Sv, start);
1476	if (*(start-1) == 'm') {
1477	if (*s != '\0')
1478	croak("Can't use '%c' after -mname", *s);
1479	sv_catpv( Sv, " ()");
1480	}
1481	} else {
1482	sv_catpvn(Sv, start, s-start);
1483	sv_catpv(Sv, " split(/,/,q{");
1484	sv_catpv(Sv, ++s);
1485	sv_catpv(Sv, "})");
1486	}
1487	s += strlen(s);
1488	if (preambleav == NULL)
1489	preambleav = newAV();
1490	av_push(preambleav, Sv);
1491	}
1492	else
1493	croak("No space allowed after -%c", *(s-1));
1494	return s;
1495	case 'n':
1496	minus_n = TRUE;
1497	s++;
1498	return s;
1499	case 'p':
1500	minus_p = TRUE;
1501	s++;
1502	return s;
1503	case 's':
1504	forbid_setid("-s");
1505	doswitches = TRUE;
1506	s++;
1507	return s;
1508	case 'T':
1509	if (!tainting)
1510	croak("Too late for \"-T\" option");
1511	s++;
1512	return s;
1513	case 'u':
1514	do_undump = TRUE;
1515	s++;
1516	return s;
1517	case 'U':
1518	unsafe = TRUE;
1519	s++;
1520	return s;
1521	case 'v':
1522	#if defined(SUBVERSION) && SUBVERSION > 0
1523	printf("\nThis is perl, version 5.%03d_%02d built for %s",
1524	PATCHLEVEL, SUBVERSION, ARCHNAME);
1525	#else
1526	printf("\nThis is perl, version %s built for %s",
1527	patchlevel, ARCHNAME);
1528	#endif
1529	#if defined(LOCAL_PATCH_COUNT)
1530	if (LOCAL_PATCH_COUNT > 0)
1531	printf("\n(with %d registered patch%s, see perl -V for more detail)",
1532	LOCAL_PATCH_COUNT, (LOCAL_PATCH_COUNT!=1) ? "es" : "");
1533	#endif
1534
1535	printf("\n\nCopyright 1987-1997, Larry Wall\n");
1536	#ifdef MSDOS
1537	printf("\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
1538	#endif
1539	#ifdef DJGPP
1540	printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n");
1541	#endif
1542	#ifdef OS2
1543	printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
1544	"Version 5 port Copyright (c) 1994-1997, Andreas Kaiser, Ilya Zakharevich\n");
1545	#endif
1546	#ifdef atarist
1547	printf("atariST series port, ++jrb bammi@cadence.com\n");
1548	#endif
1549	printf("\n\
1550	Perl may be copied only under the terms of either the Artistic License or the\n\
1551	GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n");
1552	exit(0);
1553	case 'w':
1554	dowarn = TRUE;
1555	s++;
1556	return s;
1557	case '*':
1558	case ' ':
1559	if (s[1] == '-') /* Additional switches on #! line. */
1560	return s+2;
1561	break;
1562	case '-':
1563	case 0:
1564	case '\n':
1565	case '\t':
1566	break;
1567	#ifdef ALTERNATE_SHEBANG
1568	case 'S': /* OS/2 needs -S on "extproc" line. */
1569	break;
1570	#endif
1571	case 'P':
1572	if (preprocess)
1573	return s+1;
1574	/* FALL THROUGH */
1575	default:
1576	croak("Can't emulate -%.1s on #! line",s);
1577	}
1578	return Nullch;
1579	}
1580
1581	/* compliments of Tom Christiansen */
1582
1583	/* unexec() can be found in the Gnu emacs distribution */
1584
1585	void
1586	my_unexec()
1587	{
1588	#ifdef UNEXEC
1589	SV* prog;
1590	SV* file;
1591	int status;
1592	extern int etext;
1593
1594	prog = newSVpv(BIN_EXP);
1595	sv_catpv(prog, "/perl");
1596	file = newSVpv(origfilename);
1597	sv_catpv(file, ".perldump");
1598
1599	status = unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
1600	if (status)
1601	PerlIO_printf(PerlIO_stderr(), "unexec of %s into %s failed!\n",
1602	SvPVX(prog), SvPVX(file));
1603	exit(status);
1604	#else
1605	# ifdef VMS
1606	# include <lib$routines.h>
1607	lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
1608	# else
1609	ABORT(); /* for use with undump */
1610	# endif
1611	#endif
1612	}
1613
1614	static void
1615	init_main_stash()
1616	{
1617	GV *gv;
1618
1619	/* Note that strtab is a rather special HV. Assumptions are made
1620	about not iterating on it, and not adding tie magic to it.
1621	It is properly deallocated in perl_destruct() */
1622	strtab = newHV();
1623	HvSHAREKEYS_off(strtab); /* mandatory */
1624	Newz(506,((XPVHV*)SvANY(strtab))->xhv_array,
1625	sizeof(HE) (((XPVHV*)SvANY(strtab))->xhv_max + 1), char);
1626
1627	curstash = defstash = newHV();
1628	curstname = newSVpv("main",4);
1629	gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
1630	SvREFCNT_dec(GvHV(gv));
1631	GvHV(gv) = (HV*)SvREFCNT_inc(defstash);
1632	SvREADONLY_on(gv);
1633	HvNAME(defstash) = savepv("main");
1634	incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
1635	GvMULTI_on(incgv);
1636	defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
1637	errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
1638	GvMULTI_on(errgv);
1639	(void)form("%240s",""); /* Preallocate temp - for immediate signals. */
1640	sv_grow(GvSV(errgv), 240); /* Preallocate - for immediate signals. */
1641	sv_setpvn(GvSV(errgv), "", 0);
1642	curstash = defstash;
1643	compiling.cop_stash = defstash;
1644	debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
1645	/* We must init $/ before switches are processed. */
1646	sv_setpvn(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), "\n", 1);
1647	}
1648
1649	#ifdef CAN_PROTOTYPE
1650	static void
1651	open_script(char scriptname, bool dosearch, SV sv)
1652	#else
1653	static void
1654	open_script(scriptname,dosearch,sv)
1655	char *scriptname;
1656	bool dosearch;
1657	SV *sv;
1658	#endif
1659	{
1660	char *xfound = Nullch;
1661	char *xfailed = Nullch;
1662	register char *s;
1663	I32 len;
1664	int retval;
1665	#if defined(DOSISH) && !defined(OS2) && !defined(atarist)
1666	# define SEARCH_EXTS ".bat", ".cmd", NULL
1667	# define MAX_EXT_LEN 4
1668	#endif
1669	#ifdef OS2
1670	# define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL
1671	# define MAX_EXT_LEN 4
1672	#endif
1673	#ifdef VMS
1674	# define SEARCH_EXTS ".pl", ".com", NULL
1675	# define MAX_EXT_LEN 4
1676	#endif
1677	/* additional extensions to try in each dir if scriptname not found */
1678	#ifdef SEARCH_EXTS
1679	char *ext[] = { SEARCH_EXTS };
1680	int extidx = 0, i = 0;
1681	char *curext = Nullch;
1682	#else
1683	# define MAX_EXT_LEN 0
1684	#endif
1685
1686	/*
1687	* If dosearch is true and if scriptname does not contain path
1688	* delimiters, search the PATH for scriptname.
1689	*
1690	* If SEARCH_EXTS is also defined, will look for each
1691	* scriptname{SEARCH_EXTS} whenever scriptname is not found
1692	* while searching the PATH.
1693	*
1694	* Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
1695	* proceeds as follows:
1696	* If DOSISH:
1697	* + look for ./scriptname{,.foo,.bar}
1698	* + search the PATH for scriptname{,.foo,.bar}
1699	*
1700	* If !DOSISH:
1701	* + look only in the PATH for scriptname{,.foo,.bar} (note
1702	* this will not look in '.' if it's not in the PATH)
1703	*/
1704
1705	#ifdef VMS
1706	if (dosearch) {
1707	int hasdir, idx = 0, deftypes = 1;
1708	bool seen_dot = 1;
1709
1710	hasdir = (strpbrk(scriptname,":[</") != Nullch) ;
1711	/* The first time through, just add SEARCH_EXTS to whatever we
1712	* already have, so we can check for default file types. */
1713	while (deftypes \|\|
1714	(!hasdir && my_trnlnm("DCL$PATH",tokenbuf,idx++)) )
1715	{
1716	if (deftypes) {
1717	deftypes = 0;
1718	*tokenbuf = '\0';
1719	}
1720	if ((strlen(tokenbuf) + strlen(scriptname)
1721	+ MAX_EXT_LEN) >= sizeof tokenbuf)
1722	continue; /* don't search dir with too-long name */
1723	strcat(tokenbuf, scriptname);
1724	#else /* !VMS */
1725
1726	#ifdef DOSISH
1727	if (strEQ(scriptname, "-"))
1728	dosearch = 0;
1729	if (dosearch) { /* Look in '.' first. */
1730	char *cur = scriptname;
1731	#ifdef SEARCH_EXTS
1732	if ((curext = strrchr(scriptname,'.'))) /* possible current ext */
1733	while (ext[i])
1734	if (strEQ(ext[i++],curext)) {
1735	extidx = -1; /* already has an ext */
1736	break;
1737	}
1738	do {
1739	#endif
1740	DEBUG_p(PerlIO_printf(Perl_debug_log,
1741	"Looking for %s\n",cur));
1742	if (Stat(cur,&statbuf) >= 0) {
1743	dosearch = 0;
1744	scriptname = cur;
1745	#ifdef SEARCH_EXTS
1746	break;
1747	#endif
1748	}
1749	#ifdef SEARCH_EXTS
1750	if (cur == scriptname) {
1751	len = strlen(scriptname);
1752	if (len+MAX_EXT_LEN+1 >= sizeof(tokenbuf))
1753	break;
1754	cur = strcpy(tokenbuf, scriptname);
1755	}
1756	} while (extidx >= 0 && ext[extidx] /* try an extension? */
1757	&& strcpy(tokenbuf+len, ext[extidx++]));
1758	#endif
1759	}
1760	#endif
1761
1762	if (dosearch && !strchr(scriptname, '/')
1763	#ifdef DOSISH
1764	&& !strchr(scriptname, '\\')
1765	#endif
1766	&& (s = getenv("PATH"))) {
1767	bool seen_dot = 0;
1768
1769	bufend = s + strlen(s);
1770	while (s < bufend) {
1771	#if defined(atarist) \|\| defined(DOSISH)
1772	for (len = 0; *s
1773	# ifdef atarist
1774	&& *s != ','
1775	# endif
1776	&& *s != ';'; len++, s++) {
1777	if (len < sizeof tokenbuf)
1778	tokenbuf[len] = *s;
1779	}
1780	if (len < sizeof tokenbuf)
1781	tokenbuf[len] = '\0';
1782	#else /* ! (atarist \|\| DOSISH) */
1783	s = delimcpy(tokenbuf, tokenbuf + sizeof tokenbuf, s, bufend,
1784	':',
1785	&len);
1786	#endif /* ! (atarist \|\| DOSISH) */
1787	if (s < bufend)
1788	s++;
1789	if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tokenbuf)
1790	continue; /* don't search dir with too-long name */
1791	if (len
1792	#if defined(atarist) \|\| defined(DOSISH)
1793	&& tokenbuf[len - 1] != '/'
1794	&& tokenbuf[len - 1] != '\\'
1795	#endif
1796	)
1797	tokenbuf[len++] = '/';
1798	if (len == 2 && tokenbuf[0] == '.')
1799	seen_dot = 1;
1800	(void)strcpy(tokenbuf + len, scriptname);
1801	#endif /* !VMS */
1802
1803	#ifdef SEARCH_EXTS
1804	len = strlen(tokenbuf);
1805	if (extidx > 0) /* reset after previous loop */
1806	extidx = 0;
1807	do {
1808	#endif
1809	DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tokenbuf));
1810	retval = Stat(tokenbuf,&statbuf);
1811	#ifdef SEARCH_EXTS
1812	} while ( retval < 0 /* not there */
1813	&& extidx>=0 && ext[extidx] /* try an extension? */
1814	&& strcpy(tokenbuf+len, ext[extidx++])
1815	);
1816	#endif
1817	if (retval < 0)
1818	continue;
1819	if (S_ISREG(statbuf.st_mode)
1820	&& cando(S_IRUSR,TRUE,&statbuf)
1821	#ifndef DOSISH
1822	&& cando(S_IXUSR,TRUE,&statbuf)
1823	#endif
1824	)
1825	{
1826	xfound = tokenbuf; /* bingo! */
1827	break;
1828	}
1829	if (!xfailed)
1830	xfailed = savepv(tokenbuf);
1831	}
1832	#ifndef DOSISH
1833	if (!xfound && !seen_dot && !xfailed && (Stat(scriptname,&statbuf) < 0))
1834	#endif
1835	seen_dot = 1; /* Disable message. */
1836	if (!xfound)
1837	croak("Can't %s %s%s%s",
1838	(xfailed ? "execute" : "find"),
1839	(xfailed ? xfailed : scriptname),
1840	(xfailed ? "" : " on PATH"),
1841	(xfailed \|\| seen_dot) ? "" : ", '.' not in PATH");
1842	if (xfailed)
1843	Safefree(xfailed);
1844	scriptname = xfound;
1845	}
1846
1847	if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
1848	char *s = scriptname + 8;
1849	fdscript = atoi(s);
1850	while (isDIGIT(*s))
1851	s++;
1852	if (*s)
1853	scriptname = s + 1;
1854	}
1855	else
1856	fdscript = -1;
1857	origfilename = savepv(e_tmpname ? "-e" : scriptname);
1858	curcop->cop_filegv = gv_fetchfile(origfilename);
1859	if (strEQ(origfilename,"-"))
1860	scriptname = "";
1861	if (fdscript >= 0) {
1862	rsfp = PerlIO_fdopen(fdscript,"r");
1863	#if defined(HAS_FCNTL) && defined(F_SETFD)
1864	if (rsfp)
1865	fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
1866	#endif
1867	}
1868	else if (preprocess) {
1869	char *cpp_cfg = CPPSTDIN;
1870	SV *cpp = NEWSV(0,0);
1871	SV *cmd = NEWSV(0,0);
1872
1873	if (strEQ(cpp_cfg, "cppstdin"))
1874	sv_catpvf(cpp, "%s/", BIN_EXP);
1875	sv_catpv(cpp, cpp_cfg);
1876
1877	sv_catpv(sv,"-I");
1878	sv_catpv(sv,PRIVLIB_EXP);
1879
1880	#ifdef MSDOS
1881	sv_setpvf(cmd, "\
1882	sed %s -e \"/^[^#]/b\" \
1883	-e \"/^#[ ]*include[ ]/b\" \
1884	-e \"/^#[ ]*define[ ]/b\" \
1885	-e \"/^#[ ]*if[ ]/b\" \
1886	-e \"/^#[ ]*ifdef[ ]/b\" \
1887	-e \"/^#[ ]*ifndef[ ]/b\" \
1888	-e \"/^#[ ]*else/b\" \
1889	-e \"/^#[ ]*elif[ ]/b\" \
1890	-e \"/^#[ ]*undef[ ]/b\" \
1891	-e \"/^#[ ]*endif/b\" \
1892	-e \"s/^#.*//\" \
1893	%s \| %_ -C %_ %s",
1894	(doextract ? "-e \"1,/^#/d\n\"" : ""),
1895	#else
1896	sv_setpvf(cmd, "\
1897	%s %s -e '/^[^#]/b' \
1898	-e '/^#[ ]*include[ ]/b' \
1899	-e '/^#[ ]*define[ ]/b' \
1900	-e '/^#[ ]*if[ ]/b' \
1901	-e '/^#[ ]*ifdef[ ]/b' \
1902	-e '/^#[ ]*ifndef[ ]/b' \
1903	-e '/^#[ ]*else/b' \
1904	-e '/^#[ ]*elif[ ]/b' \
1905	-e '/^#[ ]*undef[ ]/b' \
1906	-e '/^#[ ]*endif/b' \
1907	-e 's/^[ ]#.//' \
1908	%s \| %_ -C %_ %s",
1909	#ifdef LOC_SED
1910	LOC_SED,
1911	#else
1912	"sed",
1913	#endif
1914	(doextract ? "-e '1,/^#/d\n'" : ""),
1915	#endif
1916	scriptname, cpp, sv, CPPMINUS);
1917	doextract = FALSE;
1918	#ifdef IAMSUID /* actually, this is caught earlier */
1919	if (euid != uid && !euid) { /* if running suidperl */
1920	#ifdef HAS_SETEUID
1921	(void)seteuid(uid); /* musn't stay setuid root */
1922	#else
1923	#ifdef HAS_SETREUID
1924	(void)setreuid((Uid_t)-1, uid);
1925	#else
1926	#ifdef HAS_SETRESUID
1927	(void)setresuid((Uid_t)-1, uid, (Uid_t)-1);
1928	#else
1929	setuid(uid);
1930	#endif
1931	#endif
1932	#endif
1933	if (geteuid() != uid)
1934	croak("Can't do seteuid!\n");
1935	}
1936	#endif /* IAMSUID */
1937	rsfp = my_popen(SvPVX(cmd), "r");
1938	SvREFCNT_dec(cmd);
1939	SvREFCNT_dec(cpp);
1940	}
1941	else if (!*scriptname) {
1942	forbid_setid("program input from stdin");
1943	rsfp = PerlIO_stdin();
1944	}
1945	else {
1946	rsfp = PerlIO_open(scriptname,"r");
1947	#if defined(HAS_FCNTL) && defined(F_SETFD)
1948	if (rsfp)
1949	fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
1950	#endif
1951	}
1952	if (e_tmpname) {
1953	e_fp = rsfp;
1954	}
1955	if (!rsfp) {
1956	#ifdef DOSUID
1957	#ifndef IAMSUID /* in case script is not readable before setuid */
1958	if (euid && Stat(SvPVX(GvSV(curcop->cop_filegv)),&statbuf) >= 0 &&
1959	statbuf.st_mode & (S_ISUID\|S_ISGID)) {
1960	/* try again */
1961	execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
1962	croak("Can't do setuid\n");
1963	}
1964	#endif
1965	#endif
1966	croak("Can't open perl script \"%s\": %s\n",
1967	SvPVX(GvSV(curcop->cop_filegv)), Strerror(errno));
1968	}
1969	}
1970
1971	static void
1972	validate_suid(validarg, scriptname)
1973	char *validarg;
1974	char *scriptname;
1975	{
1976	int which;
1977
1978	/* do we need to emulate setuid on scripts? */
1979
1980	/* This code is for those BSD systems that have setuid #! scripts disabled
1981	* in the kernel because of a security problem. Merely defining DOSUID
1982	* in perl will not fix that problem, but if you have disabled setuid
1983	* scripts in the kernel, this will attempt to emulate setuid and setgid
1984	* on scripts that have those now-otherwise-useless bits set. The setuid
1985	* root version must be called suidperl or sperlN.NNN. If regular perl
1986	* discovers that it has opened a setuid script, it calls suidperl with
1987	* the same argv that it had. If suidperl finds that the script it has
1988	* just opened is NOT setuid root, it sets the effective uid back to the
1989	* uid. We don't just make perl setuid root because that loses the
1990	* effective uid we had before invoking perl, if it was different from the
1991	* uid.
1992	*
1993	* DOSUID must be defined in both perl and suidperl, and IAMSUID must
1994	* be defined in suidperl only. suidperl must be setuid root. The
1995	* Configure script will set this up for you if you want it.
1996	*/
1997
1998	#ifdef DOSUID
1999	char s, s2;
2000
2001	if (Fstat(PerlIO_fileno(rsfp),&statbuf) < 0) /* normal stat is insecure */
2002	croak("Can't stat script \"%s\"",origfilename);
2003	if (fdscript < 0 && statbuf.st_mode & (S_ISUID\|S_ISGID)) {
2004	I32 len;
2005
2006	#ifdef IAMSUID
2007	#ifndef HAS_SETREUID
2008	/* On this access check to make sure the directories are readable,
2009	* there is actually a small window that the user could use to make
2010	* filename point to an accessible directory. So there is a faint
2011	* chance that someone could execute a setuid script down in a
2012	* non-accessible directory. I don't know what to do about that.
2013	* But I don't think it's too important. The manual lies when
2014	* it says access() is useful in setuid programs.
2015	*/
2016	if (access(SvPVX(GvSV(curcop->cop_filegv)),1)) /double check/
2017	croak("Permission denied");
2018	#else
2019	/* If we can swap euid and uid, then we can determine access rights
2020	* with a simple stat of the file, and then compare device and
2021	* inode to make sure we did stat() on the same file we opened.
2022	* Then we just have to make sure he or she can execute it.
2023	*/
2024	{
2025	struct stat tmpstatbuf;
2026
2027	if (
2028	#ifdef HAS_SETREUID
2029	setreuid(euid,uid) < 0
2030	#else
2031	# if HAS_SETRESUID
2032	setresuid(euid,uid,(Uid_t)-1) < 0
2033	# endif
2034	#endif
2035	\|\| getuid() != euid \|\| geteuid() != uid)
2036	croak("Can't swap uid and euid"); /* really paranoid */
2037	if (Stat(SvPVX(GvSV(curcop->cop_filegv)),&tmpstatbuf) < 0)
2038	croak("Permission denied"); /* testing full pathname here */
2039	if (tmpstatbuf.st_dev != statbuf.st_dev \|\|
2040	tmpstatbuf.st_ino != statbuf.st_ino) {
2041	(void)PerlIO_close(rsfp);
2042	if (rsfp = my_popen("/bin/mail root","w")) { /* heh, heh */
2043	PerlIO_printf(rsfp,
2044	"User %ld tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
2045	(Filename of set-id script was %s, uid %ld gid %ld.)\n\nSincerely,\nperl\n",
2046	(long)uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
2047	(long)statbuf.st_dev, (long)statbuf.st_ino,
2048	SvPVX(GvSV(curcop->cop_filegv)),
2049	(long)statbuf.st_uid, (long)statbuf.st_gid);
2050	(void)my_pclose(rsfp);
2051	}
2052	croak("Permission denied\n");
2053	}
2054	if (
2055	#ifdef HAS_SETREUID
2056	setreuid(uid,euid) < 0
2057	#else
2058	# if defined(HAS_SETRESUID)
2059	setresuid(uid,euid,(Uid_t)-1) < 0
2060	# endif
2061	#endif
2062	\|\| getuid() != uid \|\| geteuid() != euid)
2063	croak("Can't reswap uid and euid");
2064	if (!cando(S_IXUSR,FALSE,&statbuf)) /* can real uid exec? */
2065	croak("Permission denied\n");
2066	}
2067	#endif /* HAS_SETREUID */
2068	#endif /* IAMSUID */
2069
2070	if (!S_ISREG(statbuf.st_mode))
2071	croak("Permission denied");
2072	if (statbuf.st_mode & S_IWOTH)
2073	croak("Setuid/gid script is writable by world");
2074	doswitches = FALSE; /* -s is insecure in suid */
2075	curcop->cop_line++;
2076	if (sv_gets(linestr, rsfp, 0) == Nullch \|\|
2077	strnNE(SvPV(linestr,na),"#!",2) ) /* required even on Sys V */
2078	croak("No #! line");
2079	s = SvPV(linestr,na)+2;
2080	if (*s == ' ') s++;
2081	while (!isSPACE(*s)) s++;
2082	for (s2 = s; (s2 > SvPV(linestr,na)+2 &&
2083	(isDIGIT(s2[-1]) \|\| strchr("._-", s2[-1]))); s2--) ;
2084	if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
2085	croak("Not a perl script");
2086	while (s == ' ' \|\| s == '\t') s++;
2087	/*
2088	* #! arg must be what we saw above. They can invoke it by
2089	* mentioning suidperl explicitly, but they may not add any strange
2090	* arguments beyond what #! says if they do invoke suidperl that way.
2091	*/
2092	len = strlen(validarg);
2093	if (strEQ(validarg," PHOOEY ") \|\|
2094	strnNE(s,validarg,len) \|\| !isSPACE(s[len]))
2095	croak("Args must match #! line");
2096
2097	#ifndef IAMSUID
2098	if (euid != uid && (statbuf.st_mode & S_ISUID) &&
2099	euid == statbuf.st_uid)
2100	if (!do_undump)
2101	croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2102	FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2103	#endif /* IAMSUID */
2104
2105	if (euid) { /* oops, we're not the setuid root perl */
2106	(void)PerlIO_close(rsfp);
2107	#ifndef IAMSUID
2108	/* try again */
2109	execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
2110	#endif
2111	croak("Can't do setuid\n");
2112	}
2113
2114	if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid) {
2115	#ifdef HAS_SETEGID
2116	(void)setegid(statbuf.st_gid);
2117	#else
2118	#ifdef HAS_SETREGID
2119	(void)setregid((Gid_t)-1,statbuf.st_gid);
2120	#else
2121	#ifdef HAS_SETRESGID
2122	(void)setresgid((Gid_t)-1,statbuf.st_gid,(Gid_t)-1);
2123	#else
2124	setgid(statbuf.st_gid);
2125	#endif
2126	#endif
2127	#endif
2128	if (getegid() != statbuf.st_gid)
2129	croak("Can't do setegid!\n");
2130	}
2131	if (statbuf.st_mode & S_ISUID) {
2132	if (statbuf.st_uid != euid)
2133	#ifdef HAS_SETEUID
2134	(void)seteuid(statbuf.st_uid); /* all that for this */
2135	#else
2136	#ifdef HAS_SETREUID
2137	(void)setreuid((Uid_t)-1,statbuf.st_uid);
2138	#else
2139	#ifdef HAS_SETRESUID
2140	(void)setresuid((Uid_t)-1,statbuf.st_uid,(Uid_t)-1);
2141	#else
2142	setuid(statbuf.st_uid);
2143	#endif
2144	#endif
2145	#endif
2146	if (geteuid() != statbuf.st_uid)
2147	croak("Can't do seteuid!\n");
2148	}
2149	else if (uid) { /* oops, mustn't run as root */
2150	#ifdef HAS_SETEUID
2151	(void)seteuid((Uid_t)uid);
2152	#else
2153	#ifdef HAS_SETREUID
2154	(void)setreuid((Uid_t)-1,(Uid_t)uid);
2155	#else
2156	#ifdef HAS_SETRESUID
2157	(void)setresuid((Uid_t)-1,(Uid_t)uid,(Uid_t)-1);
2158	#else
2159	setuid((Uid_t)uid);
2160	#endif
2161	#endif
2162	#endif
2163	if (geteuid() != uid)
2164	croak("Can't do seteuid!\n");
2165	}
2166	init_ids();
2167	if (!cando(S_IXUSR,TRUE,&statbuf))
2168	croak("Permission denied\n"); /* they can't do this */
2169	}
2170	#ifdef IAMSUID
2171	else if (preprocess)
2172	croak("-P not allowed for setuid/setgid script\n");
2173	else if (fdscript >= 0)
2174	croak("fd script not allowed in suidperl\n");
2175	else
2176	croak("Script is not setuid/setgid in suidperl\n");
2177
2178	/* We absolutely must clear out any saved ids here, so we */
2179	/* exec the real perl, substituting fd script for scriptname. */
2180	/* (We pass script name as "subdir" of fd, which perl will grok.) */
2181	PerlIO_rewind(rsfp);
2182	lseek(PerlIO_fileno(rsfp),(Off_t)0,0); /* just in case rewind didn't */
2183	for (which = 1; origargv[which] && origargv[which] != scriptname; which++) ;
2184	if (!origargv[which])
2185	croak("Permission denied");
2186	origargv[which] = savepv(form("/dev/fd/%d/%s",
2187	PerlIO_fileno(rsfp), origargv[which]));
2188	#if defined(HAS_FCNTL) && defined(F_SETFD)
2189	fcntl(PerlIO_fileno(rsfp),F_SETFD,0); /* ensure no close-on-exec */
2190	#endif
2191	execv(form("%s/perl%s", BIN_EXP, patchlevel), origargv); /* try again */
2192	croak("Can't do setuid\n");
2193	#endif /* IAMSUID */
2194	#else /* !DOSUID */
2195	if (euid != uid \|\| egid != gid) { /* (suidperl doesn't exist, in fact) */
2196	#ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
2197	Fstat(PerlIO_fileno(rsfp),&statbuf); /* may be either wrapped or real suid */
2198	if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
2199	\|\|
2200	(egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
2201	)
2202	if (!do_undump)
2203	croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2204	FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2205	#endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
2206	/* not set-id, must be wrapped */
2207	}
2208	#endif /* DOSUID */
2209	}
2210
2211	static void
2212	find_beginning()
2213	{
2214	register char s, s2;
2215
2216	/* skip forward in input to the real script? */
2217
2218	forbid_setid("-x");
2219	while (doextract) {
2220	if ((s = sv_gets(linestr, rsfp, 0)) == Nullch)
2221	croak("No Perl script found in input\n");
2222	if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
2223	PerlIO_ungetc(rsfp, '\n'); /* to keep line count right */
2224	doextract = FALSE;
2225	while (s && !(isSPACE (s) \|\| *s == '#')) s++;
2226	s2 = s;
2227	while (s == ' ' \|\| s == '\t') s++;
2228	if (*s++ == '-') {
2229	while (isDIGIT(s2[-1]) \|\| strchr("-._", s2[-1])) s2--;
2230	if (strnEQ(s2-4,"perl",4))
2231	/SUPPRESS 530/
2232	while (s = moreswitches(s)) ;
2233	}
2234	if (cddir && chdir(cddir) < 0)
2235	croak("Can't chdir to %s",cddir);
2236	}
2237	}
2238	}
2239
2240	static void
2241	init_ids()
2242	{
2243	uid = (int)getuid();
2244	euid = (int)geteuid();
2245	gid = (int)getgid();
2246	egid = (int)getegid();
2247	#ifdef VMS
2248	uid \|= gid << 16;
2249	euid \|= egid << 16;
2250	#endif
2251	tainting \|= (uid && (euid != uid \|\| egid != gid));
2252	}
2253
2254	static void
2255	forbid_setid(s)
2256	char *s;
2257	{
2258	if (euid != uid)
2259	croak("No %s allowed while running setuid", s);
2260	if (egid != gid)
2261	croak("No %s allowed while running setgid", s);
2262	}
2263
2264	static void
2265	init_debugger()
2266	{
2267	curstash = debstash;
2268	dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
2269	AvREAL_off(dbargs);
2270	DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
2271	DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
2272	DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
2273	DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
2274	sv_setiv(DBsingle, 0);
2275	DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
2276	sv_setiv(DBtrace, 0);
2277	DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
2278	sv_setiv(DBsignal, 0);
2279	curstash = defstash;
2280	}
2281
2282	static void
2283	init_stacks()
2284	{
2285	curstack = newAV();
2286	mainstack = curstack; /* remember in case we switch stacks */
2287	AvREAL_off(curstack); /* not a real array */
2288	av_extend(curstack,127);
2289
2290	stack_base = AvARRAY(curstack);
2291	stack_sp = stack_base;
2292	stack_max = stack_base + 127;
2293
2294	cxstack_max = 8192 / sizeof(CONTEXT) - 2; /* Use most of 8K. */
2295	New(50,cxstack,cxstack_max + 1,CONTEXT);
2296	cxstack_ix = -1;
2297
2298	New(50,tmps_stack,128,SV*);
2299	tmps_ix = -1;
2300	tmps_max = 128;
2301
2302	DEBUG( {
2303	New(51,debname,128,char);
2304	New(52,debdelim,128,char);
2305	} )
2306
2307	/*
2308	* The following stacks almost certainly should be per-interpreter,
2309	* but for now they're not. XXX
2310	*/
2311
2312	if (markstack) {
2313	markstack_ptr = markstack;
2314	} else {
2315	New(54,markstack,64,I32);
2316	markstack_ptr = markstack;
2317	markstack_max = markstack + 64;
2318	}
2319
2320	if (scopestack) {
2321	scopestack_ix = 0;
2322	} else {
2323	New(54,scopestack,32,I32);
2324	scopestack_ix = 0;
2325	scopestack_max = 32;
2326	}
2327
2328	if (savestack) {
2329	savestack_ix = 0;
2330	} else {
2331	New(54,savestack,128,ANY);
2332	savestack_ix = 0;
2333	savestack_max = 128;
2334	}
2335
2336	if (retstack) {
2337	retstack_ix = 0;
2338	} else {
2339	New(54,retstack,16,OP*);
2340	retstack_ix = 0;
2341	retstack_max = 16;
2342	}
2343	}
2344
2345	static void
2346	nuke_stacks()
2347	{
2348	Safefree(cxstack);
2349	Safefree(tmps_stack);
2350	DEBUG( {
2351	Safefree(debname);
2352	Safefree(debdelim);
2353	} )
2354	}
2355
2356	static PerlIO tmpfp; / moved outside init_lexer() because of UNICOS bug */
2357
2358	static void
2359	init_lexer()
2360	{
2361	tmpfp = rsfp;
2362	rsfp = Nullfp;
2363	lex_start(linestr);
2364	rsfp = tmpfp;
2365	subname = newSVpv("main",4);
2366	}
2367
2368	static void
2369	init_predump_symbols()
2370	{
2371	GV *tmpgv;
2372	GV *othergv;
2373
2374	sv_setpvn(GvSV(gv_fetchpv("\"", TRUE, SVt_PV)), " ", 1);
2375
2376	stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
2377	GvMULTI_on(stdingv);
2378	IoIFP(GvIOp(stdingv)) = PerlIO_stdin();
2379	tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
2380	GvMULTI_on(tmpgv);
2381	GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(stdingv));
2382
2383	tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
2384	GvMULTI_on(tmpgv);
2385	IoOFP(GvIOp(tmpgv)) = IoIFP(GvIOp(tmpgv)) = PerlIO_stdout();
2386	setdefout(tmpgv);
2387	tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
2388	GvMULTI_on(tmpgv);
2389	GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(defoutgv));
2390
2391	othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
2392	GvMULTI_on(othergv);
2393	IoOFP(GvIOp(othergv)) = IoIFP(GvIOp(othergv)) = PerlIO_stderr();
2394	tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
2395	GvMULTI_on(tmpgv);
2396	GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(othergv));
2397
2398	statname = NEWSV(66,0); /* last filename we did stat on */
2399
2400	if (!osname)
2401	osname = savepv(OSNAME);
2402	}
2403
2404	static void
2405	init_postdump_symbols(argc,argv,env)
2406	register int argc;
2407	register char **argv;
2408	register char **env;
2409	{
2410	char *s;
2411	SV *sv;
2412	GV* tmpgv;
2413
2414	argc--,argv++; /* skip name of script */
2415	if (doswitches) {
2416	for (; argc > 0 && **argv == '-'; argc--,argv++) {
2417	if (!argv[0][1])
2418	break;
2419	if (argv[0][1] == '-') {
2420	argc--,argv++;
2421	break;
2422	}
2423	if (s = strchr(argv[0], '=')) {
2424	*s++ = '\0';
2425	sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
2426	}
2427	else
2428	sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
2429	}
2430	}
2431	toptarget = NEWSV(0,0);
2432	sv_upgrade(toptarget, SVt_PVFM);
2433	sv_setpvn(toptarget, "", 0);
2434	bodytarget = NEWSV(0,0);
2435	sv_upgrade(bodytarget, SVt_PVFM);
2436	sv_setpvn(bodytarget, "", 0);
2437	formtarget = bodytarget;
2438
2439	TAINT;
2440	if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
2441	sv_setpv(GvSV(tmpgv),origfilename);
2442	magicname("0", "0", 1);
2443	}
2444	if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
2445	sv_setpv(GvSV(tmpgv),origargv[0]);
2446	if (argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
2447	GvMULTI_on(argvgv);
2448	(void)gv_AVadd(argvgv);
2449	av_clear(GvAVn(argvgv));
2450	for (; argc > 0; argc--,argv++) {
2451	av_push(GvAVn(argvgv),newSVpv(argv[0],0));
2452	}
2453	}
2454	if (envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
2455	HV *hv;
2456	GvMULTI_on(envgv);
2457	hv = GvHVn(envgv);
2458	hv_magic(hv, envgv, 'E');
2459	#ifndef VMS /* VMS doesn't have environ array */
2460	/* Note that if the supplied env parameter is actually a copy
2461	of the global environ then it may now point to free'd memory
2462	if the environment has been modified since. To avoid this
2463	problem we treat env==NULL as meaning 'use the default'
2464	*/
2465	if (!env)
2466	env = environ;
2467	if (env != environ)
2468	environ[0] = Nullch;
2469	for (; *env; env++) {
2470	if (!(s = strchr(*env,'=')))
2471	continue;
2472	*s++ = '\0';
2473	#ifdef WIN32
2474	(void)strupr(*env);
2475	#endif
2476	sv = newSVpv(s--,0);
2477	(void)hv_store(hv, env, s - env, sv, 0);
2478	*s = '=';
2479	#if defined(__BORLANDC__) && defined(USE_WIN32_RTL_ENV)
2480	/* Sins of the RTL. See note in my_setenv(). */
2481	(void)putenv(savepv(*env));
2482	#endif
2483	}
2484	#endif
2485	#ifdef DYNAMIC_ENV_FETCH
2486	HvNAME(hv) = savepv(ENV_HV_NAME);
2487	#endif
2488	}
2489	TAINT_NOT;
2490	if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
2491	sv_setiv(GvSV(tmpgv), (IV)getpid());
2492	}
2493
2494	static void
2495	init_perllib()
2496	{
2497	char *s;
2498	if (!tainting) {
2499	#ifndef VMS
2500	s = getenv("PERL5LIB");
2501	if (s)
2502	incpush(s, TRUE);
2503	else
2504	incpush(getenv("PERLLIB"), FALSE);
2505	#else /* VMS */
2506	/* Treat PERL5?LIB as a possible search list logical name -- the
2507	* "natural" VMS idiom for a Unix path string. We allow each
2508	* element to be a set of \|-separated directories for compatibility.
2509	*/
2510	char buf[256];
2511	int idx = 0;
2512	if (my_trnlnm("PERL5LIB",buf,0))
2513	do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
2514	else
2515	while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE);
2516	#endif /* VMS */
2517	}
2518
2519	/* Use the ~-expanded versions of APPLLIB (undocumented),
2520	ARCHLIB PRIVLIB SITEARCH SITELIB and OLDARCHLIB
2521	*/
2522	#ifdef APPLLIB_EXP
2523	incpush(APPLLIB_EXP, FALSE);
2524	#endif
2525
2526	#ifdef ARCHLIB_EXP
2527	incpush(ARCHLIB_EXP, FALSE);
2528	#endif
2529	#ifndef PRIVLIB_EXP
2530	#define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
2531	#endif
2532	incpush(PRIVLIB_EXP, FALSE);
2533
2534	#ifdef SITEARCH_EXP
2535	incpush(SITEARCH_EXP, FALSE);
2536	#endif
2537	#ifdef SITELIB_EXP
2538	incpush(SITELIB_EXP, FALSE);
2539	#endif
2540	#ifdef OLDARCHLIB_EXP /* 5.00[01] compatibility */
2541	incpush(OLDARCHLIB_EXP, FALSE);
2542	#endif
2543
2544	if (!tainting)
2545	incpush(".", FALSE);
2546	}
2547
2548	#if defined(DOSISH)
2549	# define PERLLIB_SEP ';'
2550	#else
2551	# if defined(VMS)
2552	# define PERLLIB_SEP '\|'
2553	# else
2554	# define PERLLIB_SEP ':'
2555	# endif
2556	#endif
2557	#ifndef PERLLIB_MANGLE
2558	# define PERLLIB_MANGLE(s,n) (s)
2559	#endif
2560
2561	static void
2562	incpush(p, addsubdirs)
2563	char *p;
2564	int addsubdirs;
2565	{
2566	SV *subdir = Nullsv;
2567	static char *archpat_auto;
2568
2569	if (!p)
2570	return;
2571
2572	if (addsubdirs) {
2573	subdir = newSV(0);
2574	if (!archpat_auto) {
2575	STRLEN len = (sizeof(ARCHNAME) + strlen(patchlevel)
2576	+ sizeof("//auto"));
2577	New(55, archpat_auto, len, char);
2578	sprintf(archpat_auto, "/%s/%s/auto", ARCHNAME, patchlevel);
2579	#ifdef VMS
2580	for (len = sizeof(ARCHNAME) + 2;
2581	archpat_auto[len] != '\0' && archpat_auto[len] != '/'; len++)
2582	if (archpat_auto[len] == '.') archpat_auto[len] = '_';
2583	#endif
2584	}
2585	}
2586
2587	/* Break at all separators */
2588	while (p && *p) {
2589	SV *libdir = newSV(0);
2590	char *s;
2591
2592	/* skip any consecutive separators */
2593	while ( *p == PERLLIB_SEP ) {
2594	/* Uncomment the next line for PATH semantics */
2595	/* av_push(GvAVn(incgv), newSVpv(".", 1)); */
2596	p++;
2597	}
2598
2599	if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
2600	sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
2601	(STRLEN)(s - p));
2602	p = s + 1;
2603	}
2604	else {
2605	sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
2606	p = Nullch; /* break out */
2607	}
2608
2609	/*
2610	* BEFORE pushing libdir onto @INC we may first push version- and
2611	* archname-specific sub-directories.
2612	*/
2613	if (addsubdirs) {
2614	struct stat tmpstatbuf;
2615	#ifdef VMS
2616	char *unix;
2617	STRLEN len;
2618
2619	if ((unix = tounixspec_ts(SvPV(libdir,na),Nullch)) != Nullch) {
2620	len = strlen(unix);
2621	while (unix[len-1] == '/') len--; /* Cosmetic */
2622	sv_usepvn(libdir,unix,len);
2623	}
2624	else
2625	PerlIO_printf(PerlIO_stderr(),
2626	"Failed to unixify @INC element \"%s\"\n",
2627	SvPV(libdir,na));
2628	#endif
2629	/* .../archname/version if -d .../archname/version/auto */
2630	sv_setsv(subdir, libdir);
2631	sv_catpv(subdir, archpat_auto);
2632	if (Stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2633	S_ISDIR(tmpstatbuf.st_mode))
2634	av_push(GvAVn(incgv),
2635	newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2636
2637	/* .../archname if -d .../archname/auto */
2638	sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME),
2639	strlen(patchlevel) + 1, "", 0);
2640	if (Stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2641	S_ISDIR(tmpstatbuf.st_mode))
2642	av_push(GvAVn(incgv),
2643	newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2644	}
2645
2646	/* finally push this lib directory on the end of @INC */
2647	av_push(GvAVn(incgv), libdir);
2648	}
2649
2650	SvREFCNT_dec(subdir);
2651	}
2652
2653	void
2654	call_list(oldscope, list)
2655	I32 oldscope;
2656	AV* list;
2657	{
2658	line_t oldline = curcop->cop_line;
2659	STRLEN len;
2660	dJMPENV;
2661	int ret;
2662
2663	while (AvFILL(list) >= 0) {
2664	CV cv = (CV)av_shift(list);
2665
2666	SAVEFREESV(cv);
2667
2668	JMPENV_PUSH(ret);
2669	switch (ret) {
2670	case 0: {
2671	SV* atsv = GvSV(errgv);
2672	PUSHMARK(stack_sp);
2673	perl_call_sv((SV*)cv, G_EVAL\|G_DISCARD);
2674	(void)SvPV(atsv, len);
2675	if (len) {
2676	JMPENV_POP;
2677	curcop = &compiling;
2678	curcop->cop_line = oldline;
2679	if (list == beginav)
2680	sv_catpv(atsv, "BEGIN failed--compilation aborted");
2681	else
2682	sv_catpv(atsv, "END failed--cleanup aborted");
2683	while (scopestack_ix > oldscope)
2684	LEAVE;
2685	croak("%s", SvPVX(atsv));
2686	}
2687	}
2688	break;
2689	case 1:
2690	STATUS_ALL_FAILURE;
2691	/* FALL THROUGH */
2692	case 2:
2693	/* my_exit() was called */
2694	while (scopestack_ix > oldscope)
2695	LEAVE;
2696	FREETMPS;
2697	curstash = defstash;
2698	if (endav)
2699	call_list(oldscope, endav);
2700	JMPENV_POP;
2701	curcop = &compiling;
2702	curcop->cop_line = oldline;
2703	if (statusvalue) {
2704	if (list == beginav)
2705	croak("BEGIN failed--compilation aborted");
2706	else
2707	croak("END failed--cleanup aborted");
2708	}
2709	my_exit_jump();
2710	/* NOTREACHED */
2711	case 3:
2712	if (!restartop) {
2713	PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
2714	FREETMPS;
2715	break;
2716	}
2717	JMPENV_POP;
2718	curcop = &compiling;
2719	curcop->cop_line = oldline;
2720	JMPENV_JUMP(3);
2721	}
2722	JMPENV_POP;
2723	}
2724	}
2725
2726	void
2727	my_exit(status)
2728	U32 status;
2729	{
2730	switch (status) {
2731	case 0:
2732	STATUS_ALL_SUCCESS;
2733	break;
2734	case 1:
2735	STATUS_ALL_FAILURE;
2736	break;
2737	default:
2738	STATUS_NATIVE_SET(status);
2739	break;
2740	}
2741	my_exit_jump();
2742	}
2743
2744	void
2745	my_failure_exit()
2746	{
2747	#ifdef VMS
2748	if (vaxc$errno & 1) {
2749	if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
2750	STATUS_NATIVE_SET(44);
2751	}
2752	else {
2753	if (!vaxc$errno && errno) /* unlikely */
2754	STATUS_NATIVE_SET(44);
2755	else
2756	STATUS_NATIVE_SET(vaxc$errno);
2757	}
2758	#else
2759	if (errno & 255)
2760	STATUS_POSIX_SET(errno);
2761	else if (STATUS_POSIX == 0)
2762	STATUS_POSIX_SET(255);
2763	#endif
2764	my_exit_jump();
2765	}
2766
2767	static void
2768	my_exit_jump()
2769	{
2770	register CONTEXT *cx;
2771	I32 gimme;
2772	SV **newsp;
2773
2774	if (e_tmpname) {
2775	if (e_fp) {
2776	PerlIO_close(e_fp);
2777	e_fp = Nullfp;
2778	}
2779	(void)UNLINK(e_tmpname);
2780	Safefree(e_tmpname);
2781	e_tmpname = Nullch;
2782	}
2783
2784	if (cxstack_ix >= 0) {
2785	if (cxstack_ix > 0)
2786	dounwind(0);
2787	POPBLOCK(cx,curpm);
2788	LEAVE;
2789	}
2790
2791	JMPENV_JUMP(2);
2792	}

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

Download in other formats: