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