This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
perl 3.0 patch #11 patch #9, continued
[perl5.git] / perly.c
1 char rcsid[] = "$Header: perly.c,v 3.0.1.4 90/02/28 18:06: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.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  * 
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  * 
19  * Revision 3.0.1.2  89/11/17  15:34:42  lwall
20  * patch5: fixed possible confusion about current effective gid
21  * 
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  * 
25  * Revision 3.0  89/10/18  15:22:21  lwall
26  * 3.0 baseline
27  * 
28  */
29
30 #include "EXTERN.h"
31 #include "perl.h"
32 #include "perly.h"
33 #include "patchlevel.h"
34
35 #ifdef IAMSUID
36 #ifndef DOSUID
37 #define DOSUID
38 #endif
39 #endif
40
41 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
42 #ifdef DOSUID
43 #undef DOSUID
44 #endif
45 #endif
46
47 main(argc,argv,env)
48 register int argc;
49 register char **argv;
50 register char **env;
51 {
52     register STR *str;
53     register char *s;
54     char *index(), *strcpy(), *getenv();
55     bool dosearch = FALSE;
56 #ifdef DOSUID
57     char *validarg = "";
58 #endif
59
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\
64 setuid perl scripts securely.\n");
65 #endif
66 #endif
67
68     origargv = argv;
69     origargc = argc;
70     uid = (int)getuid();
71     euid = (int)geteuid();
72     gid = (int)getgid();
73     egid = (int)getegid();
74     if (do_undump) {
75         do_undump = 0;
76         loop_ptr = -1;          /* start label stack again */
77         goto just_doit;
78     }
79     (void)sprintf(index(rcsid,'#'), "%d\n", PATCHLEVEL);
80     linestr = Str_new(65,80);
81     str_nset(linestr,"",0);
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;
86     incstab = aadd(stabent("INC",TRUE));
87     incstab->str_pok |= SP_MULTI;
88     for (argc--,argv++; argc; argc--,argv++) {
89         if (argv[0][0] != '-' || !argv[0][1])
90             break;
91 #ifdef DOSUID
92     if (*validarg)
93         validarg = " PHOOEY ";
94     else
95         validarg = argv[0];
96 #endif
97         s = argv[0]+1;
98       reswitch:
99         switch (*s) {
100         case 'a':
101             minus_a = TRUE;
102             s++;
103             goto reswitch;
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;
112         case 'D':
113 #ifdef DEBUGGING
114 #ifdef TAINT
115             if (euid != uid || egid != gid)
116                 fatal("No -D allowed in setuid scripts");
117 #endif
118             debug = atoi(s+1);
119 #else
120             warn("Recompile perl with -DDEBUGGING to use -D switch\n");
121 #endif
122             break;
123         case 'e':
124 #ifdef TAINT
125             if (euid != uid || egid != gid)
126                 fatal("No -e allowed in setuid scripts");
127 #endif
128             if (!e_fp) {
129                 e_tmpname = savestr(TMPPATH);
130                 (void)mktemp(e_tmpname);
131                 e_fp = fopen(e_tmpname,"w");
132             }
133             if (argv[1])
134                 fputs(argv[1],e_fp);
135             (void)putc('\n', e_fp);
136             argc--,argv++;
137             break;
138         case 'i':
139             inplace = savestr(s+1);
140             argvoutstab = stabent("ARGVOUT",TRUE);
141             break;
142         case 'I':
143 #ifdef TAINT
144             if (euid != uid || egid != gid)
145                 fatal("No -I allowed in setuid scripts");
146 #endif
147             str_cat(str,"-");
148             str_cat(str,s);
149             str_cat(str," ");
150             if (*++s) {
151                 (void)apush(stab_array(incstab),str_make(s,0));
152             }
153             else {
154                 (void)apush(stab_array(incstab),str_make(argv[1],0));
155                 str_cat(str,argv[1]);
156                 argc--,argv++;
157                 str_cat(str," ");
158             }
159             break;
160         case 'n':
161             minus_n = TRUE;
162             s++;
163             goto reswitch;
164         case 'p':
165             minus_p = TRUE;
166             s++;
167             goto reswitch;
168         case 'P':
169 #ifdef TAINT
170             if (euid != uid || egid != gid)
171                 fatal("No -P allowed in setuid scripts");
172 #endif
173             preprocess = TRUE;
174             s++;
175             goto reswitch;
176         case 's':
177 #ifdef TAINT
178             if (euid != uid || egid != gid)
179                 fatal("No -s allowed in setuid scripts");
180 #endif
181             doswitches = TRUE;
182             s++;
183             goto reswitch;
184         case 'S':
185             dosearch = TRUE;
186             s++;
187             goto reswitch;
188         case 'u':
189             do_undump = TRUE;
190             s++;
191             goto reswitch;
192         case 'U':
193             unsafe = TRUE;
194             s++;
195             goto reswitch;
196         case 'v':
197             fputs(rcsid,stdout);
198             fputs("\nCopyright (c) 1989, Larry Wall\n\n\
199 Perl may be copied only under the terms of the GNU General Public License,\n\
200 a copy of which can be found with the Perl 3.0 distribution kit.\n",stdout);
201             exit(0);
202         case 'w':
203             dowarn = TRUE;
204             s++;
205             goto reswitch;
206         case '-':
207             argc--,argv++;
208             goto switch_end;
209         case 0:
210             break;
211         default:
212             fatal("Unrecognized switch: -%s",s);
213         }
214     }
215   switch_end:
216     if (e_fp) {
217         (void)fclose(e_fp);
218         argc++,argv--;
219         argv[0] = e_tmpname;
220     }
221 #ifndef PRIVLIB
222 #define PRIVLIB "/usr/local/lib/perl"
223 #endif
224     (void)apush(stab_array(incstab),str_make(PRIVLIB,0));
225
226     str_set(&str_no,No);
227     str_set(&str_yes,Yes);
228
229     /* open script */
230
231     if (argv[0] == Nullch)
232         argv[0] = "-";
233     if (dosearch && !index(argv[0], '/') && (s = getenv("PATH"))) {
234         char *xfound = Nullch, *xfailed = Nullch;
235         int len;
236
237         bufend = s + strlen(s);
238         while (*s) {
239             s = cpytill(tokenbuf,s,bufend,':',&len);
240             if (*s)
241                 s++;
242             if (len)
243                 (void)strcat(tokenbuf+len,"/");
244             (void)strcat(tokenbuf+len,argv[0]);
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
252              && cando(S_IREAD,TRUE,&statbuf) && cando(S_IEXEC,TRUE,&statbuf)) {
253                 xfound = tokenbuf;              /* bingo! */
254                 break;
255             }
256             if (!xfailed)
257                 xfailed = savestr(tokenbuf);
258         }
259         if (!xfound)
260             fatal("Can't execute %s", xfailed ? xfailed : argv[0] );
261         if (xfailed)
262             Safefree(xfailed);
263         argv[0] = savestr(xfound);
264     }
265
266     pidstatary = anew(Nullstab);        /* for remembering popen pids, status */
267
268     filename = savestr(argv[0]);
269     origfilename = savestr(filename);
270     if (strEQ(filename,"-"))
271         argv[0] = "";
272     if (preprocess) {
273         str_cat(str,"-I");
274         str_cat(str,PRIVLIB);
275         (void)sprintf(buf, "\
276 /bin/sed -e '/^[^#]/b' \
277  -e '/^#[       ]*include[      ]/b' \
278  -e '/^#[       ]*define[       ]/b' \
279  -e '/^#[       ]*if[   ]/b' \
280  -e '/^#[       ]*ifdef[        ]/b' \
281  -e '/^#[       ]*ifndef[       ]/b' \
282  -e '/^#[       ]*else/b' \
283  -e '/^#[       ]*endif/b' \
284  -e 's/^#.*//' \
285  %s | %s -C %s %s",
286           argv[0], CPPSTDIN, str_get(str), CPPMINUS);
287 #ifdef IAMSUID                          /* actually, this is caught earlier */
288         if (euid != uid && !euid)       /* if running suidperl */
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
297 #endif
298 #endif /* IAMSUID */
299         rsfp = mypopen(buf,"r");
300     }
301     else if (!*argv[0])
302         rsfp = stdin;
303     else
304         rsfp = fopen(argv[0],"r");
305     if (rsfp == Nullfp) {
306 #ifdef DOSUID
307 #ifndef IAMSUID         /* in case script is not readable before setuid */
308         if (euid && stat(filename,&statbuf) >= 0 &&
309           statbuf.st_mode & (S_ISUID|S_ISGID)) {
310             (void)sprintf(buf, "%s/%s", BIN, "suidperl");
311             execv(buf, origargv);       /* try again */
312             fatal("Can't do setuid\n");
313         }
314 #endif
315 #endif
316         fatal("Can't open perl script \"%s\": %s\n",
317           filename, strerror(errno));
318     }
319     str_free(str);              /* free -I directories */
320
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.
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.
345      */
346
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
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          */
363         if (access(filename,1))         /* as a double check */
364             fatal("Permission denied");
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
400         if ((statbuf.st_mode & S_IFMT) != S_IFREG)
401             fatal("Permission denied");
402         if ((statbuf.st_mode >> 6) & S_IWRITE)
403             fatal("Setuid/gid script is writable by world");
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");
409         s = tokenbuf+2;
410         if (*s == ' ') s++;
411         while (!isspace(*s)) s++;
412         if (strnNE(s-4,"perl",4))       /* sanity check */
413             fatal("Not a perl script");
414         while (*s == ' ' || *s == '\t') s++;
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]))
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\
430 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
431 #endif /* IAMSUID */
432
433         if (euid) {     /* oops, we're not the setuid root perl */
434             (void)fclose(rsfp);
435 #ifndef IAMSUID
436             (void)sprintf(buf, "%s/%s", BIN, "suidperl");
437             execv(buf, origargv);       /* try again */
438 #endif
439             fatal("Can't do setuid\n");
440         }
441
442         if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid)
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
474         uid = (int)getuid();
475         euid = (int)geteuid();
476         gid = (int)getgid();
477         egid = (int)getegid();
478         if (!cando(S_IEXEC,TRUE,&statbuf))
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");
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 */
496 #endif /* IAMSUID */
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\
508 FIX 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 */
517 #endif /* DOSUID */
518
519     defstab = stabent("_",TRUE);
520
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
537     /* init tokener */
538
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 */
544
545     /* now parse the script */
546
547     error_count = 0;
548     if (yyparse() || error_count)
549         fatal("Execution aborted due to compilation errors.\n");
550
551     New(50,loop_stack,128,struct loop);
552 #ifdef DEBUGGING
553     if (debug) {
554         New(51,debname,128,char);
555         New(52,debdelim,128,char);
556     }
557 #endif
558     curstash = defstash;
559
560     preprocess = FALSE;
561     if (e_fp) {
562         e_fp = Nullfp;
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');
630     }
631
632     if (do_undump)
633         abort();
634
635   just_doit:            /* come here if running an undumped a.out */
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             }
643             str_numset(stab_val(stabent(argv[0]+1,TRUE)),(double)1.0);
644         }
645     }
646 #ifdef TAINT
647     tainted = 1;
648 #endif
649     if (argvstab = stabent("ARGV",allstabs)) {
650         argvstab->str_pok |= SP_MULTI;
651         (void)aadd(argvstab);
652         for (; argc > 0; argc--,argv++) {
653             (void)apush(stab_array(argvstab),str_make(argv[0],0));
654         }
655     }
656 #ifdef TAINT
657     (void) stabent("ENV",TRUE);         /* must test PATH and IFS */
658 #endif
659     if (envstab = stabent("ENV",allstabs)) {
660         envstab->str_pok |= SP_MULTI;
661         (void)hadd(envstab);
662         for (; *env; env++) {
663             if (!(s = index(*env,'=')))
664                 continue;
665             *s++ = '\0';
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 = '=';
670         }
671     }
672 #ifdef TAINT
673     tainted = 0;
674 #endif
675     if (tmpstab = stabent("$",allstabs))
676         str_numset(STAB_STR(tmpstab),(double)getpid());
677
678     if (setjmp(top_env))        /* sets goto_targ on longjump */
679         loop_ptr = -1;          /* start label stack again */
680
681 #ifdef DEBUGGING
682     if (debug & 1024)
683         dump_all();
684     if (debug)
685         fprintf(stderr,"\nEXECUTING...\n\n");
686 #endif
687
688     /* do it */
689
690     (void) cmd_exec(main_root,G_SCALAR,-1);
691
692     if (goto_targ)
693         fatal("Can't find label \"%s\"--aborting",goto_targ);
694     exit(0);
695     /* NOTREACHED */
696 }
697
698 magicalize(list)
699 register char *list;
700 {
701     register STAB *stab;
702     char sym[2];
703
704     sym[1] = '\0';
705     while (*sym = *list++) {
706         if (stab = stabent(sym,allstabs)) {
707             stab_flags(stab) = SF_VMAGIC;
708             str_magic(stab_val(stab), stab, 0, Nullch, 0);
709         }
710     }
711 }
712
713 /* this routine is in perly.c by virtue of being sort of an alternate main() */
714
715 int
716 do_eval(str,optype,stash,gimme,arglast)
717 STR *str;
718 int optype;
719 HASH *stash;
720 int gimme;
721 int *arglast;
722 {
723     STR **st = stack->ary_array;
724     int retval;
725     CMD *myroot;
726     ARRAY *ar;
727     int i;
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;
733     static char *last_eval = Nullch;
734     static CMD *last_root = Nullcmd;
735     VOLATILE int sp = arglast[0];
736     char *tmps;
737
738     tmps_base = tmps_max;
739     if (curstash != stash) {
740         (void)savehptr(&curstash);
741         curstash = stash;
742     }
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 */
749     }
750     else {
751         if (last_root) {
752             Safefree(last_eval);
753             cmd_free(last_root);
754             last_root = Nullcmd;
755         }
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);
766                     break;
767                 }
768             }
769         }
770         if (!rsfp) {
771             filename = oldfile;
772             tmps_base = oldtmps_base;
773             if (gimme != G_ARRAY)
774                 st[++sp] = &str_undef;
775             return sp;
776         }
777         line = 0;
778     }
779     in_eval++;
780     oldoldbufptr = oldbufptr = bufptr = str_get(linestr);
781     bufend = bufptr + linestr->str_cur;
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)) {
794         retval = 1;
795         last_root = Nullcmd;
796     }
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);
809             }
810             last_eval = savestr(bufptr);
811             last_root = Nullcmd;
812             retval = yyparse();
813             if (!retval)
814                 last_root = eval_root;
815         }
816         else
817             retval = yyparse();
818     }
819     myroot = eval_root;         /* in case cmd_exec does another eval! */
820     if (retval || error_count) {
821         st = stack->ary_array;
822         sp = arglast[0];
823         if (gimme != G_ARRAY)
824             st[++sp] = &str_undef;
825         last_root = Nullcmd;    /* can't free on error, for some reason */
826         if (rsfp) {
827             fclose(rsfp);
828             rsfp = 0;
829         }
830     }
831     else {
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);
839     }
840     in_eval--;
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--;
849     filename = oldfile;
850     line = oldline;
851     tmps_base = oldtmps_base;
852     curspat = oldspat;
853     if (savestack->ary_fill > oldsave)  /* let them use local() */
854         restorelist(oldsave);
855     return sp;
856 }