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