This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
perl 3.0 patch #3 Patch #2 continued
[perl5.git] / perly.c
CommitLineData
a687059c 1char rcsid[] = "$Header: perly.c,v 3.0 89/10/18 15:22:21 lwall Locked $\nPatch level: ###\n";
8d063cd8 2/*
a687059c
LW
3 * Copyright (c) 1989, Larry Wall
4 *
5 * You may distribute under the terms of the GNU General Public License
6 * as specified in the README file that comes with the perl 3.0 kit.
7 *
8d063cd8 8 * $Log: perly.c,v $
a687059c
LW
9 * Revision 3.0 89/10/18 15:22:21 lwall
10 * 3.0 baseline
8d063cd8
LW
11 *
12 */
13
378cc40b
LW
14#include "EXTERN.h"
15#include "perl.h"
16#include "perly.h"
a687059c 17#include "patchlevel.h"
378cc40b 18
a687059c
LW
19#ifdef IAMSUID
20#ifndef DOSUID
21#define DOSUID
22#endif
23#endif
378cc40b 24
a687059c
LW
25#ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
26#ifdef DOSUID
27#undef DOSUID
28#endif
29#endif
8d063cd8
LW
30
31main(argc,argv,env)
32register int argc;
33register char **argv;
34register char **env;
35{
36 register STR *str;
37 register char *s;
378cc40b
LW
38 char *index(), *strcpy(), *getenv();
39 bool dosearch = FALSE;
13281fa4 40 char **origargv = argv;
a687059c 41#ifdef DOSUID
13281fa4
LW
42 char *validarg = "";
43#endif
8d063cd8 44
a687059c
LW
45#ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
46#ifdef IAMSUID
47#undef IAMSUID
48 fatal("suidperl is no longer needed since the kernel can now execute\n\
49setuid perl scripts securely.\n");
50#endif
51#endif
52
378cc40b
LW
53 uid = (int)getuid();
54 euid = (int)geteuid();
a687059c
LW
55 gid = (int)getgid();
56 egid = (int)getegid();
57 if (do_undump) {
58 do_undump = 0;
59 loop_ptr = 0; /* start label stack again */
60 goto just_doit;
61 }
62 (void)sprintf(index(rcsid,'#'), "%d\n", PATCHLEVEL);
63 linestr = Str_new(65,80);
378cc40b 64 str_nset(linestr,"",0);
a687059c
LW
65 str = str_make("",0); /* first used for -I flags */
66 curstash = defstash = hnew(0);
67 curstname = str_make("main",4);
68 stab_xhash(stabent("_main",TRUE)) = defstash;
378cc40b 69 incstab = aadd(stabent("INC",TRUE));
a687059c 70 incstab->str_pok |= SP_MULTI;
8d063cd8
LW
71 for (argc--,argv++; argc; argc--,argv++) {
72 if (argv[0][0] != '-' || !argv[0][1])
73 break;
13281fa4
LW
74#ifdef DOSUID
75 if (*validarg)
76 validarg = " PHOOEY ";
77 else
78 validarg = argv[0];
79#endif
80 s = argv[0]+1;
8d063cd8 81 reswitch:
13281fa4 82 switch (*s) {
378cc40b
LW
83 case 'a':
84 minus_a = TRUE;
13281fa4 85 s++;
378cc40b 86 goto reswitch;
a687059c
LW
87 case 'd':
88#ifdef TAINT
89 if (euid != uid || egid != gid)
90 fatal("No -d allowed in setuid scripts");
91#endif
92 perldb = TRUE;
93 s++;
94 goto reswitch;
8d063cd8
LW
95#ifdef DEBUGGING
96 case 'D':
a687059c
LW
97#ifdef TAINT
98 if (euid != uid || egid != gid)
99 fatal("No -D allowed in setuid scripts");
100#endif
13281fa4 101 debug = atoi(s+1);
8d063cd8
LW
102#ifdef YYDEBUG
103 yydebug = (debug & 1);
104#endif
105 break;
106#endif
107 case 'e':
a687059c
LW
108#ifdef TAINT
109 if (euid != uid || egid != gid)
110 fatal("No -e allowed in setuid scripts");
111#endif
8d063cd8 112 if (!e_fp) {
a687059c
LW
113 e_tmpname = savestr(TMPPATH);
114 (void)mktemp(e_tmpname);
8d063cd8
LW
115 e_fp = fopen(e_tmpname,"w");
116 }
117 if (argv[1])
118 fputs(argv[1],e_fp);
a687059c 119 (void)putc('\n', e_fp);
8d063cd8
LW
120 argc--,argv++;
121 break;
122 case 'i':
13281fa4 123 inplace = savestr(s+1);
8d063cd8
LW
124 argvoutstab = stabent("ARGVOUT",TRUE);
125 break;
126 case 'I':
a687059c
LW
127#ifdef TAINT
128 if (euid != uid || egid != gid)
129 fatal("No -I allowed in setuid scripts");
130#endif
13281fa4
LW
131 str_cat(str,"-");
132 str_cat(str,s);
8d063cd8 133 str_cat(str," ");
a687059c
LW
134 if (*++s) {
135 (void)apush(stab_array(incstab),str_make(s,0));
378cc40b
LW
136 }
137 else {
a687059c 138 (void)apush(stab_array(incstab),str_make(argv[1],0));
8d063cd8
LW
139 str_cat(str,argv[1]);
140 argc--,argv++;
141 str_cat(str," ");
142 }
143 break;
144 case 'n':
378cc40b 145 minus_n = TRUE;
13281fa4 146 s++;
8d063cd8
LW
147 goto reswitch;
148 case 'p':
378cc40b 149 minus_p = TRUE;
13281fa4 150 s++;
8d063cd8
LW
151 goto reswitch;
152 case 'P':
a687059c
LW
153#ifdef TAINT
154 if (euid != uid || egid != gid)
155 fatal("No -P allowed in setuid scripts");
156#endif
8d063cd8 157 preprocess = TRUE;
13281fa4 158 s++;
8d063cd8
LW
159 goto reswitch;
160 case 's':
a687059c
LW
161#ifdef TAINT
162 if (euid != uid || egid != gid)
163 fatal("No -s allowed in setuid scripts");
164#endif
8d063cd8 165 doswitches = TRUE;
13281fa4 166 s++;
8d063cd8 167 goto reswitch;
378cc40b
LW
168 case 'S':
169 dosearch = TRUE;
13281fa4 170 s++;
378cc40b 171 goto reswitch;
a687059c
LW
172 case 'u':
173 do_undump = TRUE;
174 s++;
175 goto reswitch;
378cc40b
LW
176 case 'U':
177 unsafe = TRUE;
13281fa4 178 s++;
378cc40b 179 goto reswitch;
8d063cd8 180 case 'v':
a687059c
LW
181 fputs(rcsid,stdout);
182 fputs("\nCopyright (c) 1989, Larry Wall\n\n\
183Perl may be copied only under the terms of the GNU General Public License,\n\
184a copy of which can be found with the Perl 3.0 distribution kit.\n",stdout);
8d063cd8 185 exit(0);
378cc40b
LW
186 case 'w':
187 dowarn = TRUE;
13281fa4 188 s++;
378cc40b 189 goto reswitch;
8d063cd8
LW
190 case '-':
191 argc--,argv++;
192 goto switch_end;
193 case 0:
194 break;
195 default:
13281fa4 196 fatal("Unrecognized switch: -%s",s);
8d063cd8
LW
197 }
198 }
199 switch_end:
200 if (e_fp) {
a687059c 201 (void)fclose(e_fp);
8d063cd8
LW
202 argc++,argv--;
203 argv[0] = e_tmpname;
204 }
378cc40b
LW
205#ifndef PRIVLIB
206#define PRIVLIB "/usr/local/lib/perl"
207#endif
a687059c 208 (void)apush(stab_array(incstab),str_make(PRIVLIB,0));
8d063cd8
LW
209
210 str_set(&str_no,No);
211 str_set(&str_yes,Yes);
8d063cd8
LW
212
213 /* open script */
214
215 if (argv[0] == Nullch)
216 argv[0] = "-";
a687059c 217 if (dosearch && !index(argv[0], '/') && (s = getenv("PATH"))) {
378cc40b 218 char *xfound = Nullch, *xfailed = Nullch;
a687059c 219 int len;
378cc40b 220
a687059c 221 bufend = s + strlen(s);
378cc40b 222 while (*s) {
a687059c 223 s = cpytill(tokenbuf,s,bufend,':',&len);
378cc40b
LW
224 if (*s)
225 s++;
a687059c
LW
226 if (len)
227 (void)strcat(tokenbuf+len,"/");
228 (void)strcat(tokenbuf+len,argv[0]);
378cc40b
LW
229#ifdef DEBUGGING
230 if (debug & 1)
231 fprintf(stderr,"Looking for %s\n",tokenbuf);
232#endif
233 if (stat(tokenbuf,&statbuf) < 0) /* not there? */
234 continue;
235 if ((statbuf.st_mode & S_IFMT) == S_IFREG
a687059c 236 && cando(S_IREAD,TRUE,&statbuf) && cando(S_IEXEC,TRUE,&statbuf)) {
378cc40b
LW
237 xfound = tokenbuf; /* bingo! */
238 break;
239 }
240 if (!xfailed)
241 xfailed = savestr(tokenbuf);
242 }
243 if (!xfound)
a687059c 244 fatal("Can't execute %s", xfailed ? xfailed : argv[0] );
378cc40b 245 if (xfailed)
a687059c 246 Safefree(xfailed);
378cc40b
LW
247 argv[0] = savestr(xfound);
248 }
a687059c
LW
249
250 pidstatary = anew(Nullstab); /* for remembering popen pids, status */
251
8d063cd8 252 filename = savestr(argv[0]);
378cc40b 253 origfilename = savestr(filename);
8d063cd8
LW
254 if (strEQ(filename,"-"))
255 argv[0] = "";
256 if (preprocess) {
378cc40b
LW
257 str_cat(str,"-I");
258 str_cat(str,PRIVLIB);
a687059c 259 (void)sprintf(buf, "\
8d063cd8
LW
260/bin/sed -e '/^[^#]/b' \
261 -e '/^#[ ]*include[ ]/b' \
262 -e '/^#[ ]*define[ ]/b' \
263 -e '/^#[ ]*if[ ]/b' \
264 -e '/^#[ ]*ifdef[ ]/b' \
378cc40b 265 -e '/^#[ ]*ifndef[ ]/b' \
8d063cd8
LW
266 -e '/^#[ ]*else/b' \
267 -e '/^#[ ]*endif/b' \
268 -e 's/^#.*//' \
378cc40b
LW
269 %s | %s -C %s %s",
270 argv[0], CPPSTDIN, str_get(str), CPPMINUS);
a687059c 271#ifdef IAMSUID /* actually, this is caught earlier */
13281fa4 272 if (euid != uid && !euid) /* if running suidperl */
a687059c
LW
273#ifdef SETEUID
274 (void)seteuid(uid); /* musn't stay setuid root */
275#else
276#ifdef SETREUID
277 (void)setreuid(-1, uid);
278#else
279 setuid(uid);
280#endif
13281fa4 281#endif
a687059c
LW
282#endif /* IAMSUID */
283 rsfp = mypopen(buf,"r");
8d063cd8
LW
284 }
285 else if (!*argv[0])
286 rsfp = stdin;
287 else
288 rsfp = fopen(argv[0],"r");
13281fa4 289 if (rsfp == Nullfp) {
a687059c
LW
290 extern char *sys_errlist[];
291 extern int errno;
292
13281fa4 293#ifdef DOSUID
a687059c 294#ifndef IAMSUID /* in case script is not readable before setuid */
13281fa4
LW
295 if (euid && stat(filename,&statbuf) >= 0 &&
296 statbuf.st_mode & (S_ISUID|S_ISGID)) {
a687059c
LW
297 (void)sprintf(buf, "%s/%s", BIN, "suidperl");
298 execv(buf, origargv); /* try again */
13281fa4
LW
299 fatal("Can't do setuid\n");
300 }
301#endif
302#endif
a687059c
LW
303 fatal("Can't open perl script \"%s\": %s\n",
304 filename, sys_errlist[errno]);
13281fa4 305 }
8d063cd8
LW
306 str_free(str); /* free -I directories */
307
13281fa4
LW
308 /* do we need to emulate setuid on scripts? */
309
310 /* This code is for those BSD systems that have setuid #! scripts disabled
311 * in the kernel because of a security problem. Merely defining DOSUID
312 * in perl will not fix that problem, but if you have disabled setuid
313 * scripts in the kernel, this will attempt to emulate setuid and setgid
314 * on scripts that have those now-otherwise-useless bits set. The setuid
315 * root version must be called suidperl. If regular perl discovers that
316 * it has opened a setuid script, it calls suidperl with the same argv
317 * that it had. If suidperl finds that the script it has just opened
318 * is NOT setuid root, it sets the effective uid back to the uid. We
319 * don't just make perl setuid root because that loses the effective
320 * uid we had before invoking perl, if it was different from the uid.
321 *
322 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
323 * be defined in suidperl only. suidperl must be setuid root. The
324 * Configure script will set this up for you if you want it.
a687059c
LW
325 *
326 * There is also the possibility of have a script which is running
327 * set-id due to a C wrapper. We want to do the TAINT checks
328 * on these set-id scripts, but don't want to have the overhead of
329 * them in normal perl, and can't use suidperl because it will lose
330 * the effective uid info, so we have an additional non-setuid root
331 * version called taintperl that just does the TAINT checks.
13281fa4 332 */
a687059c 333
13281fa4
LW
334#ifdef DOSUID
335 if (fstat(fileno(rsfp),&statbuf) < 0) /* normal stat is insecure */
336 fatal("Can't stat script \"%s\"",filename);
337 if (statbuf.st_mode & (S_ISUID|S_ISGID)) {
338 int len;
339
a687059c
LW
340#ifdef IAMSUID
341#ifndef SETREUID
342 /* On this access check to make sure the directories are readable,
343 * there is actually a small window that the user could use to make
344 * filename point to an accessible directory. So there is a faint
345 * chance that someone could execute a setuid script down in a
346 * non-accessible directory. I don't know what to do about that.
347 * But I don't think it's too important. The manual lies when
348 * it says access() is useful in setuid programs.
349 */
13281fa4
LW
350 if (access(filename,1)) /* as a double check */
351 fatal("Permission denied");
a687059c
LW
352#else
353 /* If we can swap euid and uid, then we can determine access rights
354 * with a simple stat of the file, and then compare device and
355 * inode to make sure we did stat() on the same file we opened.
356 * Then we just have to make sure he or she can execute it.
357 */
358 {
359 struct stat tmpstatbuf;
360
361 if (setreuid(euid,uid) < 0 || getuid() != euid || geteuid() != uid)
362 fatal("Can't swap uid and euid"); /* really paranoid */
363 if (stat(filename,&tmpstatbuf) < 0) /* testing full pathname here */
364 fatal("Permission denied");
365 if (tmpstatbuf.st_dev != statbuf.st_dev ||
366 tmpstatbuf.st_ino != statbuf.st_ino) {
367 (void)fclose(rsfp);
368 if (rsfp = mypopen("/bin/mail root","w")) { /* heh, heh */
369 fprintf(rsfp,
370"User %d tried to run dev %d ino %d in place of dev %d ino %d!\n\
371(Filename of set-id script was %s, uid %d gid %d.)\n\nSincerely,\nperl\n",
372 uid,tmpstatbuf.st_dev, tmpstatbuf.st_ino,
373 statbuf.st_dev, statbuf.st_ino,
374 filename, statbuf.st_uid, statbuf.st_gid);
375 (void)mypclose(rsfp);
376 }
377 fatal("Permission denied\n");
378 }
379 if (setreuid(uid,euid) < 0 || getuid() != uid || geteuid() != euid)
380 fatal("Can't reswap uid and euid");
381 if (!cando(S_IEXEC,FALSE,&statbuf)) /* can real uid exec? */
382 fatal("Permission denied\n");
383 }
384#endif /* SETREUID */
385#endif /* IAMSUID */
386
13281fa4
LW
387 if ((statbuf.st_mode & S_IFMT) != S_IFREG)
388 fatal("Permission denied");
a687059c
LW
389 if ((statbuf.st_mode >> 6) & S_IWRITE)
390 fatal("Setuid/gid script is writable by world");
13281fa4
LW
391 doswitches = FALSE; /* -s is insecure in suid */
392 line++;
393 if (fgets(tokenbuf,sizeof tokenbuf, rsfp) == Nullch ||
394 strnNE(tokenbuf,"#!",2) ) /* required even on Sys V */
395 fatal("No #! line");
396 for (s = tokenbuf+2; !isspace(*s); s++) ;
397 if (strnNE(s-4,"perl",4)) /* sanity check */
398 fatal("Not a perl script");
a687059c 399 while (*s == ' ' || *s == '\t') s++;
13281fa4
LW
400 /*
401 * #! arg must be what we saw above. They can invoke it by
402 * mentioning suidperl explicitly, but they may not add any strange
403 * arguments beyond what #! says if they do invoke suidperl that way.
404 */
405 len = strlen(validarg);
406 if (strEQ(validarg," PHOOEY ") ||
407 strnNE(s,validarg,len) || !isspace(s[len]))
a687059c
LW
408 fatal("Args must match #! line");
409
410#ifndef IAMSUID
411 if (euid != uid && (statbuf.st_mode & S_ISUID) &&
412 euid == statbuf.st_uid)
413 if (!do_undump)
414 fatal("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
415FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
416#endif /* IAMSUID */
13281fa4
LW
417
418 if (euid) { /* oops, we're not the setuid root perl */
a687059c 419 (void)fclose(rsfp);
13281fa4 420#ifndef IAMSUID
a687059c
LW
421 (void)sprintf(buf, "%s/%s", BIN, "suidperl");
422 execv(buf, origargv); /* try again */
13281fa4
LW
423#endif
424 fatal("Can't do setuid\n");
425 }
426
13281fa4 427 if (statbuf.st_mode & S_ISGID && statbuf.st_gid != getegid())
a687059c
LW
428#ifdef SETEGID
429 (void)setegid(statbuf.st_gid);
430#else
431#ifdef SETREGID
432 (void)setregid((GIDTYPE)-1,statbuf.st_gid);
433#else
434 setgid(statbuf.st_gid);
435#endif
436#endif
437 if (statbuf.st_mode & S_ISUID) {
438 if (statbuf.st_uid != euid)
439#ifdef SETEUID
440 (void)seteuid(statbuf.st_uid); /* all that for this */
441#else
442#ifdef SETREUID
443 (void)setreuid((UIDTYPE)-1,statbuf.st_uid);
444#else
445 setuid(statbuf.st_uid);
446#endif
447#endif
448 }
449 else if (uid) /* oops, mustn't run as root */
450#ifdef SETEUID
451 (void)seteuid((UIDTYPE)uid);
452#else
453#ifdef SETREUID
454 (void)setreuid((UIDTYPE)-1,(UIDTYPE)uid);
455#else
456 setuid((UIDTYPE)uid);
457#endif
458#endif
13281fa4 459 euid = (int)geteuid();
a687059c 460 if (!cando(S_IEXEC,TRUE,&statbuf))
13281fa4
LW
461 fatal("Permission denied\n"); /* they can't do this */
462 }
463#ifdef IAMSUID
464 else if (preprocess)
465 fatal("-P not allowed for setuid/setgid script\n");
466 else
467 fatal("Script is not setuid/setgid in suidperl\n");
a687059c
LW
468#else
469#ifndef TAINT /* we aren't taintperl or suidperl */
470 /* script has a wrapper--can't run suidperl or we lose euid */
471 else if (euid != uid || egid != gid) {
472 (void)fclose(rsfp);
473 (void)sprintf(buf, "%s/%s", BIN, "taintperl");
474 execv(buf, origargv); /* try again */
475 fatal("Can't run setuid script with taint checks");
476 }
477#endif /* TAINT */
13281fa4 478#endif /* IAMSUID */
a687059c
LW
479#else /* !DOSUID */
480#ifndef TAINT /* we aren't taintperl or suidperl */
481 if (euid != uid || egid != gid) { /* (suidperl doesn't exist, in fact) */
482#ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
483 fstat(fileno(rsfp),&statbuf); /* may be either wrapped or real suid */
484 if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
485 ||
486 (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
487 )
488 if (!do_undump)
489 fatal("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
490FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
491#endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
492 /* not set-id, must be wrapped */
493 (void)fclose(rsfp);
494 (void)sprintf(buf, "%s/%s", BIN, "taintperl");
495 execv(buf, origargv); /* try again */
496 fatal("Can't run setuid script with taint checks");
497 }
498#endif /* TAINT */
13281fa4
LW
499#endif /* DOSUID */
500
8d063cd8
LW
501 defstab = stabent("_",TRUE);
502
a687059c
LW
503 if (perldb) {
504 debstash = hnew(0);
505 stab_xhash(stabent("_DB",TRUE)) = debstash;
506 curstash = debstash;
507 lineary = stab_xarray(aadd((tmpstab = stabent("line",TRUE))));
508 tmpstab->str_pok |= SP_MULTI;
509 subname = str_make("main",4);
510 DBstab = stabent("DB",TRUE);
511 DBstab->str_pok |= SP_MULTI;
512 DBsub = hadd(tmpstab = stabent("sub",TRUE));
513 tmpstab->str_pok |= SP_MULTI;
514 DBsingle = stab_val((tmpstab = stabent("single",TRUE)));
515 tmpstab->str_pok |= SP_MULTI;
516 curstash = defstash;
517 }
518
8d063cd8
LW
519 /* init tokener */
520
a687059c
LW
521 bufend = bufptr = str_get(linestr);
522
523 savestack = anew(Nullstab); /* for saving non-local values */
524 stack = anew(Nullstab); /* for saving non-local values */
525 stack->ary_flags = 0; /* not a real array */
8d063cd8 526
a687059c 527 /* now parse the script */
8d063cd8 528
a687059c
LW
529 error_count = 0;
530 if (yyparse() || error_count)
8d063cd8
LW
531 fatal("Execution aborted due to compilation errors.\n");
532
a687059c
LW
533 New(50,loop_stack,128,struct loop);
534 New(51,debname,128,char);
535 New(52,debdelim,128,char);
536 curstash = defstash;
378cc40b
LW
537
538 preprocess = FALSE;
8d063cd8
LW
539 if (e_fp) {
540 e_fp = Nullfp;
a687059c
LW
541 (void)UNLINK(e_tmpname);
542 }
543
544 /* initialize everything that won't change if we undump */
545
546 if (sigstab = stabent("SIG",allstabs)) {
547 sigstab->str_pok |= SP_MULTI;
548 (void)hadd(sigstab);
549 }
550
551 magicalize("!#?^~=-%0123456789.+&*()<>,\\/[|`':");
552
553 amperstab = stabent("&",allstabs);
554 leftstab = stabent("`",allstabs);
555 rightstab = stabent("'",allstabs);
556 sawampersand = (amperstab || leftstab || rightstab);
557 if (tmpstab = stabent(":",allstabs))
558 str_set(STAB_STR(tmpstab),chopset);
559
560 /* these aren't necessarily magical */
561 if (tmpstab = stabent(";",allstabs))
562 str_set(STAB_STR(tmpstab),"\034");
563#ifdef TAINT
564 tainted = 1;
565#endif
566 if (tmpstab = stabent("0",allstabs))
567 str_set(STAB_STR(tmpstab),origfilename);
568#ifdef TAINT
569 tainted = 0;
570#endif
571 if (tmpstab = stabent("]",allstabs))
572 str_set(STAB_STR(tmpstab),rcsid);
573 str_nset(stab_val(stabent("\"", TRUE)), " ", 1);
574
575 stdinstab = stabent("STDIN",TRUE);
576 stdinstab->str_pok |= SP_MULTI;
577 stab_io(stdinstab) = stio_new();
578 stab_io(stdinstab)->ifp = stdin;
579 tmpstab = stabent("stdin",TRUE);
580 stab_io(tmpstab) = stab_io(stdinstab);
581 tmpstab->str_pok |= SP_MULTI;
582
583 tmpstab = stabent("STDOUT",TRUE);
584 tmpstab->str_pok |= SP_MULTI;
585 stab_io(tmpstab) = stio_new();
586 stab_io(tmpstab)->ofp = stab_io(tmpstab)->ifp = stdout;
587 defoutstab = tmpstab;
588 tmpstab = stabent("stdout",TRUE);
589 stab_io(tmpstab) = stab_io(defoutstab);
590 tmpstab->str_pok |= SP_MULTI;
591
592 curoutstab = stabent("STDERR",TRUE);
593 curoutstab->str_pok |= SP_MULTI;
594 stab_io(curoutstab) = stio_new();
595 stab_io(curoutstab)->ofp = stab_io(curoutstab)->ifp = stderr;
596 tmpstab = stabent("stderr",TRUE);
597 stab_io(tmpstab) = stab_io(curoutstab);
598 tmpstab->str_pok |= SP_MULTI;
599 curoutstab = defoutstab; /* switch back to STDOUT */
600
601 statname = Str_new(66,0); /* last filename we did stat on */
602
603 perldb = FALSE; /* don't try to instrument evals */
604
605 if (dowarn) {
606 stab_check('A','Z');
607 stab_check('a','z');
8d063cd8 608 }
a687059c
LW
609
610 if (do_undump)
611 abort();
612
613 just_doit: /* come here if running an undumped a.out */
8d063cd8
LW
614 argc--,argv++; /* skip name of script */
615 if (doswitches) {
616 for (; argc > 0 && **argv == '-'; argc--,argv++) {
617 if (argv[0][1] == '-') {
618 argc--,argv++;
619 break;
620 }
a687059c 621 str_numset(stab_val(stabent(argv[0]+1,TRUE)),(double)1.0);
8d063cd8
LW
622 }
623 }
a687059c
LW
624#ifdef TAINT
625 tainted = 1;
626#endif
a559c259 627 if (argvstab = stabent("ARGV",allstabs)) {
a687059c
LW
628 argvstab->str_pok |= SP_MULTI;
629 (void)aadd(argvstab);
8d063cd8 630 for (; argc > 0; argc--,argv++) {
a687059c 631 (void)apush(stab_array(argvstab),str_make(argv[0],0));
8d063cd8
LW
632 }
633 }
a687059c
LW
634#ifdef TAINT
635 (void) stabent("ENV",TRUE); /* must test PATH and IFS */
636#endif
a559c259 637 if (envstab = stabent("ENV",allstabs)) {
a687059c
LW
638 envstab->str_pok |= SP_MULTI;
639 (void)hadd(envstab);
8d063cd8
LW
640 for (; *env; env++) {
641 if (!(s = index(*env,'=')))
642 continue;
643 *s++ = '\0';
a687059c
LW
644 str = str_make(s--,0);
645 str_magic(str, envstab, 'E', *env, s - *env);
646 (void)hstore(stab_hash(envstab), *env, s - *env, str, 0);
647 *s = '=';
8d063cd8
LW
648 }
649 }
a687059c
LW
650#ifdef TAINT
651 tainted = 0;
652#endif
378cc40b 653 if (tmpstab = stabent("$",allstabs))
8d063cd8
LW
654 str_numset(STAB_STR(tmpstab),(double)getpid());
655
a687059c
LW
656 if (setjmp(top_env)) /* sets goto_targ on longjump */
657 loop_ptr = 0; /* start label stack again */
8d063cd8
LW
658
659#ifdef DEBUGGING
660 if (debug & 1024)
a687059c 661 dump_all();
8d063cd8
LW
662 if (debug)
663 fprintf(stderr,"\nEXECUTING...\n\n");
664#endif
665
666 /* do it */
667
a687059c 668 (void) cmd_exec(main_root,G_SCALAR,-1);
8d063cd8
LW
669
670 if (goto_targ)
378cc40b 671 fatal("Can't find label \"%s\"--aborting",goto_targ);
8d063cd8 672 exit(0);
378cc40b 673 /* NOTREACHED */
8d063cd8
LW
674}
675
676magicalize(list)
677register char *list;
678{
679 register STAB *stab;
680 char sym[2];
681
682 sym[1] = '\0';
683 while (*sym = *list++) {
a559c259 684 if (stab = stabent(sym,allstabs)) {
a687059c
LW
685 stab_flags(stab) = SF_VMAGIC;
686 str_magic(stab_val(stab), stab, 0, Nullch, 0);
378cc40b 687 }
378cc40b 688 }
8d063cd8
LW
689}
690
a687059c 691/* this routine is in perly.c by virtue of being sort of an alternate main() */
8d063cd8 692
a687059c
LW
693int
694do_eval(str,optype,stash,gimme,arglast)
695STR *str;
696int optype;
697HASH *stash;
698int gimme;
699int *arglast;
8d063cd8 700{
a687059c
LW
701 STR **st = stack->ary_array;
702 int retval;
703 CMD *myroot;
704 ARRAY *ar;
705 int i;
706 char *oldfile = filename;
707 line_t oldline = line;
708 int oldtmps_base = tmps_base;
709 int oldsave = savestack->ary_fill;
710 SPAT *oldspat = curspat;
711 static char *last_eval = Nullch;
712 static CMD *last_root = Nullcmd;
713 int sp = arglast[0];
8d063cd8 714
a687059c
LW
715 tmps_base = tmps_max;
716 if (curstash != stash) {
717 (void)savehptr(&curstash);
718 curstash = stash;
8d063cd8 719 }
a687059c
LW
720 str_set(stab_val(stabent("@",TRUE)),"");
721 if (optype != O_DOFILE) { /* normal eval */
722 filename = "(eval)";
723 line = 1;
724 str_sset(linestr,str);
725 str_cat(linestr,";"); /* be kind to them */
8d063cd8 726 }
a687059c
LW
727 else {
728 if (last_root) {
729 Safefree(last_eval);
730 cmd_free(last_root);
731 last_root = Nullcmd;
8d063cd8 732 }
a687059c
LW
733 filename = savestr(str_get(str)); /* can't free this easily */
734 str_set(linestr,"");
735 rsfp = fopen(filename,"r");
736 ar = stab_array(incstab);
737 if (!rsfp && *filename != '/') {
738 for (i = 0; i <= ar->ary_fill; i++) {
739 (void)sprintf(buf,"%s/%s",str_get(afetch(ar,i,TRUE)),filename);
740 rsfp = fopen(buf,"r");
741 if (rsfp) {
742 filename = savestr(buf);
8d063cd8
LW
743 break;
744 }
378cc40b
LW
745 }
746 }
a687059c
LW
747 if (!rsfp) {
748 filename = oldfile;
749 tmps_base = oldtmps_base;
750 if (gimme != G_ARRAY)
751 st[++sp] = &str_undef;
752 return sp;
8d063cd8 753 }
a687059c 754 line = 0;
8d063cd8 755 }
a687059c
LW
756 in_eval++;
757 oldoldbufptr = oldbufptr = bufptr = str_get(linestr);
758 bufend = bufptr + linestr->str_cur;
759 if (setjmp(eval_env)) {
760 retval = 1;
761 last_root = Nullcmd;
8d063cd8 762 }
a687059c
LW
763 else {
764 error_count = 0;
765 if (rsfp)
766 retval = yyparse();
767 else if (last_root && *bufptr == *last_eval && strEQ(bufptr,last_eval)){
768 retval = 0;
769 eval_root = last_root; /* no point in reparsing */
770 }
771 else if (in_eval == 1) {
772 if (last_root) {
773 Safefree(last_eval);
774 cmd_free(last_root);
8d063cd8 775 }
a687059c
LW
776 last_eval = savestr(bufptr);
777 last_root = Nullcmd;
778 retval = yyparse();
779 if (!retval)
780 last_root = eval_root;
8d063cd8 781 }
a687059c
LW
782 else
783 retval = yyparse();
8d063cd8 784 }
a687059c
LW
785 myroot = eval_root; /* in case cmd_exec does another eval! */
786 if (retval || error_count) {
787 str = &str_undef;
788 last_root = Nullcmd; /* can't free on error, for some reason */
789 if (rsfp) {
790 fclose(rsfp);
791 rsfp = 0;
792 }
8d063cd8 793 }
8d063cd8 794 else {
a687059c
LW
795 sp = cmd_exec(eval_root,gimme,sp);
796 st = stack->ary_array;
797 for (i = arglast[0] + 1; i <= sp; i++)
798 st[i] = str_static(st[i]);
799 /* if we don't save result, free zaps it */
800 if (in_eval != 1 && myroot != last_root)
801 cmd_free(myroot);
a559c259
LW
802 }
803 in_eval--;
378cc40b
LW
804 filename = oldfile;
805 line = oldline;
806 tmps_base = oldtmps_base;
a687059c 807 curspat = oldspat;
378cc40b
LW
808 if (savestack->ary_fill > oldsave) /* let them use local() */
809 restorelist(oldsave);
a687059c 810 return sp;
378cc40b 811}