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