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