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