This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
perl 4.0 patch 10: (combined patch)
[perl5.git] / perl.c
1 char rcsid[] = "$RCSfile: perl.c,v $$Revision: 4.0.1.4 $$Date: 91/06/10 01:23:07 $\nPatch level: ###\n";
2 /*
3  *    Copyright (c) 1991, Larry Wall
4  *
5  *    You may distribute under the terms of either the GNU General Public
6  *    License or the Artistic License, as specified in the README file.
7  *
8  * $Log:        perl.c,v $
9  * Revision 4.0.1.4  91/06/10  01:23:07  lwall
10  * patch10: perl -v printed incorrect copyright notice
11  * 
12  * Revision 4.0.1.3  91/06/07  11:40:18  lwall
13  * patch4: changed old $^P to $^X
14  * 
15  * Revision 4.0.1.2  91/06/07  11:26:16  lwall
16  * patch4: new copyright notice
17  * patch4: added $^P variable to control calling of perldb routines
18  * patch4: added $^F variable to specify maximum system fd, default 2
19  * patch4: debugger lost track of lines in eval
20  * 
21  * Revision 4.0.1.1  91/04/11  17:49:05  lwall
22  * patch1: fixed undefined environ problem
23  * 
24  * Revision 4.0  91/03/20  01:37:44  lwall
25  * 4.0 baseline.
26  * 
27  */
28
29 #include "EXTERN.h"
30 #include "perl.h"
31 #include "perly.h"
32 #ifdef MSDOS
33 #include "patchlev.h"
34 #else
35 #include "patchlevel.h"
36 #endif
37
38 char *getenv();
39
40 #ifdef IAMSUID
41 #ifndef DOSUID
42 #define DOSUID
43 #endif
44 #endif
45
46 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
47 #ifdef DOSUID
48 #undef DOSUID
49 #endif
50 #endif
51
52 static char* moreswitches();
53 static char* cddir;
54 static bool minus_c;
55 static char patchlevel[6];
56 static char *nrs = "\n";
57 static int nrschar = '\n';      /* final char of rs, or 0777 if none */
58 static int nrslen = 1;
59
60 main(argc,argv,env)
61 register int argc;
62 register char **argv;
63 register char **env;
64 {
65     register STR *str;
66     register char *s;
67     char *getenv();
68     bool dosearch = FALSE;
69 #ifdef DOSUID
70     char *validarg = "";
71 #endif
72
73 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
74 #ifdef IAMSUID
75 #undef IAMSUID
76     fatal("suidperl is no longer needed since the kernel can now execute\n\
77 setuid perl scripts securely.\n");
78 #endif
79 #endif
80
81     origargv = argv;
82     origargc = argc;
83     origenviron = environ;
84     uid = (int)getuid();
85     euid = (int)geteuid();
86     gid = (int)getgid();
87     egid = (int)getegid();
88     sprintf(patchlevel,"%3.3s%2.2d", index(rcsid,'4'), PATCHLEVEL);
89 #ifdef MSDOS
90     /*
91      * There is no way we can refer to them from Perl so close them to save
92      * space.  The other alternative would be to provide STDAUX and STDPRN
93      * filehandles.
94      */
95     (void)fclose(stdaux);
96     (void)fclose(stdprn);
97 #endif
98     if (do_undump) {
99         origfilename = savestr(argv[0]);
100         do_undump = 0;
101         loop_ptr = -1;          /* start label stack again */
102         goto just_doit;
103     }
104     (void)sprintf(index(rcsid,'#'), "%d\n", PATCHLEVEL);
105     linestr = Str_new(65,80);
106     str_nset(linestr,"",0);
107     str = str_make("",0);               /* first used for -I flags */
108     curstash = defstash = hnew(0);
109     curstname = str_make("main",4);
110     stab_xhash(stabent("_main",TRUE)) = defstash;
111     defstash->tbl_name = "main";
112     incstab = hadd(aadd(stabent("INC",TRUE)));
113     incstab->str_pok |= SP_MULTI;
114     for (argc--,argv++; argc > 0; argc--,argv++) {
115         if (argv[0][0] != '-' || !argv[0][1])
116             break;
117 #ifdef DOSUID
118     if (*validarg)
119         validarg = " PHOOEY ";
120     else
121         validarg = argv[0];
122 #endif
123         s = argv[0]+1;
124       reswitch:
125         switch (*s) {
126         case '0':
127         case 'a':
128         case 'c':
129         case 'd':
130         case 'D':
131         case 'i':
132         case 'l':
133         case 'n':
134         case 'p':
135         case 'u':
136         case 'U':
137         case 'v':
138         case 'w':
139             if (s = moreswitches(s))
140                 goto reswitch;
141             break;
142
143         case 'e':
144 #ifdef TAINT
145             if (euid != uid || egid != gid)
146                 fatal("No -e allowed in setuid scripts");
147 #endif
148             if (!e_fp) {
149                 e_tmpname = savestr(TMPPATH);
150                 (void)mktemp(e_tmpname);
151                 e_fp = fopen(e_tmpname,"w");
152                 if (!e_fp)
153                     fatal("Cannot open temporary file");
154             }
155             if (argv[1]) {
156                 fputs(argv[1],e_fp);
157                 argc--,argv++;
158             }
159             (void)putc('\n', e_fp);
160             break;
161         case 'I':
162 #ifdef TAINT
163             if (euid != uid || egid != gid)
164                 fatal("No -I allowed in setuid scripts");
165 #endif
166             str_cat(str,"-");
167             str_cat(str,s);
168             str_cat(str," ");
169             if (*++s) {
170                 (void)apush(stab_array(incstab),str_make(s,0));
171             }
172             else if (argv[1]) {
173                 (void)apush(stab_array(incstab),str_make(argv[1],0));
174                 str_cat(str,argv[1]);
175                 argc--,argv++;
176                 str_cat(str," ");
177             }
178             break;
179         case 'P':
180 #ifdef TAINT
181             if (euid != uid || egid != gid)
182                 fatal("No -P allowed in setuid scripts");
183 #endif
184             preprocess = TRUE;
185             s++;
186             goto reswitch;
187         case 's':
188 #ifdef TAINT
189             if (euid != uid || egid != gid)
190                 fatal("No -s allowed in setuid scripts");
191 #endif
192             doswitches = TRUE;
193             s++;
194             goto reswitch;
195         case 'S':
196             dosearch = TRUE;
197             s++;
198             goto reswitch;
199         case 'x':
200             doextract = TRUE;
201             s++;
202             if (*s)
203                 cddir = savestr(s);
204             break;
205         case '-':
206             argc--,argv++;
207             goto switch_end;
208         case 0:
209             break;
210         default:
211             fatal("Unrecognized switch: -%s",s);
212         }
213     }
214   switch_end:
215     if (e_fp) {
216         (void)fclose(e_fp);
217         argc++,argv--;
218         argv[0] = e_tmpname;
219     }
220
221 #ifdef MSDOS
222 #define PERLLIB_SEP ';'
223 #else
224 #define PERLLIB_SEP ':'
225 #endif
226 #ifndef TAINT           /* Can't allow arbitrary PERLLIB in setuid script */
227     {
228         char * s2 = getenv("PERLLIB");
229
230         if ( s2 ) {
231             /* Break at all separators */
232             while ( *s2 ) {
233                 /* First, skip any consecutive separators */
234                 while ( *s2 == PERLLIB_SEP ) {
235                     /* Uncomment the next line for PATH semantics */
236                     /* (void)apush(stab_array(incstab),str_make(".",1)); */
237                     s2++;
238                 }
239                 if ( (s = index(s2,PERLLIB_SEP)) != Nullch ) {
240                     (void)apush(stab_array(incstab),str_make(s2,(int)(s-s2)));
241                     s2 = s+1;
242                 } else {
243                     (void)apush(stab_array(incstab),str_make(s2,0));
244                     break;
245                 }
246             }
247         }
248     }
249 #endif /* TAINT */
250
251 #ifndef PRIVLIB
252 #define PRIVLIB "/usr/local/lib/perl"
253 #endif
254     (void)apush(stab_array(incstab),str_make(PRIVLIB,0));
255     (void)apush(stab_array(incstab),str_make(".",1));
256
257     str_set(&str_no,No);
258     str_set(&str_yes,Yes);
259
260     /* open script */
261
262     if (argv[0] == Nullch)
263 #ifdef MSDOS
264     {
265         if ( isatty(fileno(stdin)) )
266           moreswitches("v");
267         argv[0] = "-";
268     }
269 #else
270         argv[0] = "-";
271 #endif
272     if (dosearch && !index(argv[0], '/') && (s = getenv("PATH"))) {
273         char *xfound = Nullch, *xfailed = Nullch;
274         int len;
275
276         bufend = s + strlen(s);
277         while (*s) {
278 #ifndef MSDOS
279             s = cpytill(tokenbuf,s,bufend,':',&len);
280 #else
281             for (len = 0; *s && *s != ';'; tokenbuf[len++] = *s++);
282             tokenbuf[len] = '\0';
283 #endif
284             if (*s)
285                 s++;
286 #ifndef MSDOS
287             if (len && tokenbuf[len-1] != '/')
288 #else
289             if (len && tokenbuf[len-1] != '\\')
290 #endif
291                 (void)strcat(tokenbuf+len,"/");
292             (void)strcat(tokenbuf+len,argv[0]);
293 #ifdef DEBUGGING
294             if (debug & 1)
295                 fprintf(stderr,"Looking for %s\n",tokenbuf);
296 #endif
297             if (stat(tokenbuf,&statbuf) < 0)            /* not there? */
298                 continue;
299             if (S_ISREG(statbuf.st_mode)
300              && cando(S_IRUSR,TRUE,&statbuf) && cando(S_IXUSR,TRUE,&statbuf)) {
301                 xfound = tokenbuf;              /* bingo! */
302                 break;
303             }
304             if (!xfailed)
305                 xfailed = savestr(tokenbuf);
306         }
307         if (!xfound)
308             fatal("Can't execute %s", xfailed ? xfailed : argv[0] );
309         if (xfailed)
310             Safefree(xfailed);
311         argv[0] = savestr(xfound);
312     }
313
314     fdpid = anew(Nullstab);     /* for remembering popen pids by fd */
315     pidstatus = hnew(COEFFSIZE);/* for remembering status of dead pids */
316
317     origfilename = savestr(argv[0]);
318     curcmd->c_filestab = fstab(origfilename);
319     if (strEQ(origfilename,"-"))
320         argv[0] = "";
321     if (preprocess) {
322         str_cat(str,"-I");
323         str_cat(str,PRIVLIB);
324         (void)sprintf(buf, "\
325 %ssed %s -e '/^[^#]/b' \
326  -e '/^#[       ]*include[      ]/b' \
327  -e '/^#[       ]*define[       ]/b' \
328  -e '/^#[       ]*if[   ]/b' \
329  -e '/^#[       ]*ifdef[        ]/b' \
330  -e '/^#[       ]*ifndef[       ]/b' \
331  -e '/^#[       ]*else/b' \
332  -e '/^#[       ]*endif/b' \
333  -e 's/^#.*//' \
334  %s | %s -C %s %s",
335 #ifdef MSDOS
336           "",
337 #else
338           "/bin/",
339 #endif
340           (doextract ? "-e '1,/^#/d\n'" : ""),
341           argv[0], CPPSTDIN, str_get(str), CPPMINUS);
342 #ifdef DEBUGGING
343         if (debug & 64) {
344             fputs(buf,stderr);
345             fputs("\n",stderr);
346         }
347 #endif
348         doextract = FALSE;
349 #ifdef IAMSUID                          /* actually, this is caught earlier */
350         if (euid != uid && !euid)       /* if running suidperl */
351 #ifdef HAS_SETEUID
352             (void)seteuid(uid);         /* musn't stay setuid root */
353 #else
354 #ifdef HAS_SETREUID
355             (void)setreuid(-1, uid);
356 #else
357             setuid(uid);
358 #endif
359 #endif
360 #endif /* IAMSUID */
361         rsfp = mypopen(buf,"r");
362     }
363     else if (!*argv[0])
364         rsfp = stdin;
365     else
366         rsfp = fopen(argv[0],"r");
367     if (rsfp == Nullfp) {
368 #ifdef DOSUID
369 #ifndef IAMSUID         /* in case script is not readable before setuid */
370         if (euid && stat(stab_val(curcmd->c_filestab)->str_ptr,&statbuf) >= 0 &&
371           statbuf.st_mode & (S_ISUID|S_ISGID)) {
372             (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel);
373             execv(buf, origargv);       /* try again */
374             fatal("Can't do setuid\n");
375         }
376 #endif
377 #endif
378         fatal("Can't open perl script \"%s\": %s\n",
379           stab_val(curcmd->c_filestab)->str_ptr, strerror(errno));
380     }
381     str_free(str);              /* free -I directories */
382     str = Nullstr;
383
384     /* do we need to emulate setuid on scripts? */
385
386     /* This code is for those BSD systems that have setuid #! scripts disabled
387      * in the kernel because of a security problem.  Merely defining DOSUID
388      * in perl will not fix that problem, but if you have disabled setuid
389      * scripts in the kernel, this will attempt to emulate setuid and setgid
390      * on scripts that have those now-otherwise-useless bits set.  The setuid
391      * root version must be called suidperl or sperlN.NNN.  If regular perl
392      * discovers that it has opened a setuid script, it calls suidperl with
393      * the same argv that it had.  If suidperl finds that the script it has
394      * just opened is NOT setuid root, it sets the effective uid back to the
395      * uid.  We don't just make perl setuid root because that loses the
396      * effective uid we had before invoking perl, if it was different from the
397      * uid.
398      *
399      * DOSUID must be defined in both perl and suidperl, and IAMSUID must
400      * be defined in suidperl only.  suidperl must be setuid root.  The
401      * Configure script will set this up for you if you want it.
402      *
403      * There is also the possibility of have a script which is running
404      * set-id due to a C wrapper.  We want to do the TAINT checks
405      * on these set-id scripts, but don't want to have the overhead of
406      * them in normal perl, and can't use suidperl because it will lose
407      * the effective uid info, so we have an additional non-setuid root
408      * version called taintperl or tperlN.NNN that just does the TAINT checks.
409      */
410
411 #ifdef DOSUID
412     if (fstat(fileno(rsfp),&statbuf) < 0)       /* normal stat is insecure */
413         fatal("Can't stat script \"%s\"",origfilename);
414     if (statbuf.st_mode & (S_ISUID|S_ISGID)) {
415         int len;
416
417 #ifdef IAMSUID
418 #ifndef HAS_SETREUID
419         /* On this access check to make sure the directories are readable,
420          * there is actually a small window that the user could use to make
421          * filename point to an accessible directory.  So there is a faint
422          * chance that someone could execute a setuid script down in a
423          * non-accessible directory.  I don't know what to do about that.
424          * But I don't think it's too important.  The manual lies when
425          * it says access() is useful in setuid programs.
426          */
427         if (access(stab_val(curcmd->c_filestab)->str_ptr,1))    /*double check*/
428             fatal("Permission denied");
429 #else
430         /* If we can swap euid and uid, then we can determine access rights
431          * with a simple stat of the file, and then compare device and
432          * inode to make sure we did stat() on the same file we opened.
433          * Then we just have to make sure he or she can execute it.
434          */
435         {
436             struct stat tmpstatbuf;
437
438             if (setreuid(euid,uid) < 0 || getuid() != euid || geteuid() != uid)
439                 fatal("Can't swap uid and euid");       /* really paranoid */
440             if (stat(stab_val(curcmd->c_filestab)->str_ptr,&tmpstatbuf) < 0)
441                 fatal("Permission denied");     /* testing full pathname here */
442             if (tmpstatbuf.st_dev != statbuf.st_dev ||
443                 tmpstatbuf.st_ino != statbuf.st_ino) {
444                 (void)fclose(rsfp);
445                 if (rsfp = mypopen("/bin/mail root","w")) {     /* heh, heh */
446                     fprintf(rsfp,
447 "User %d tried to run dev %d ino %d in place of dev %d ino %d!\n\
448 (Filename of set-id script was %s, uid %d gid %d.)\n\nSincerely,\nperl\n",
449                         uid,tmpstatbuf.st_dev, tmpstatbuf.st_ino,
450                         statbuf.st_dev, statbuf.st_ino,
451                         stab_val(curcmd->c_filestab)->str_ptr,
452                         statbuf.st_uid, statbuf.st_gid);
453                     (void)mypclose(rsfp);
454                 }
455                 fatal("Permission denied\n");
456             }
457             if (setreuid(uid,euid) < 0 || getuid() != uid || geteuid() != euid)
458                 fatal("Can't reswap uid and euid");
459             if (!cando(S_IXUSR,FALSE,&statbuf))         /* can real uid exec? */
460                 fatal("Permission denied\n");
461         }
462 #endif /* HAS_SETREUID */
463 #endif /* IAMSUID */
464
465         if (!S_ISREG(statbuf.st_mode))
466             fatal("Permission denied");
467         if (statbuf.st_mode & S_IWOTH)
468             fatal("Setuid/gid script is writable by world");
469         doswitches = FALSE;             /* -s is insecure in suid */
470         curcmd->c_line++;
471         if (fgets(tokenbuf,sizeof tokenbuf, rsfp) == Nullch ||
472           strnNE(tokenbuf,"#!",2) )     /* required even on Sys V */
473             fatal("No #! line");
474         s = tokenbuf+2;
475         if (*s == ' ') s++;
476         while (!isspace(*s)) s++;
477         if (strnNE(s-4,"perl",4) && strnNE(s-9,"perl",4))  /* sanity check */
478             fatal("Not a perl script");
479         while (*s == ' ' || *s == '\t') s++;
480         /*
481          * #! arg must be what we saw above.  They can invoke it by
482          * mentioning suidperl explicitly, but they may not add any strange
483          * arguments beyond what #! says if they do invoke suidperl that way.
484          */
485         len = strlen(validarg);
486         if (strEQ(validarg," PHOOEY ") ||
487             strnNE(s,validarg,len) || !isspace(s[len]))
488             fatal("Args must match #! line");
489
490 #ifndef IAMSUID
491         if (euid != uid && (statbuf.st_mode & S_ISUID) &&
492             euid == statbuf.st_uid)
493             if (!do_undump)
494                 fatal("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
495 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
496 #endif /* IAMSUID */
497
498         if (euid) {     /* oops, we're not the setuid root perl */
499             (void)fclose(rsfp);
500 #ifndef IAMSUID
501             (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel);
502             execv(buf, origargv);       /* try again */
503 #endif
504             fatal("Can't do setuid\n");
505         }
506
507         if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid)
508 #ifdef HAS_SETEGID
509             (void)setegid(statbuf.st_gid);
510 #else
511 #ifdef HAS_SETREGID
512             (void)setregid((GIDTYPE)-1,statbuf.st_gid);
513 #else
514             setgid(statbuf.st_gid);
515 #endif
516 #endif
517         if (statbuf.st_mode & S_ISUID) {
518             if (statbuf.st_uid != euid)
519 #ifdef HAS_SETEUID
520                 (void)seteuid(statbuf.st_uid);  /* all that for this */
521 #else
522 #ifdef HAS_SETREUID
523                 (void)setreuid((UIDTYPE)-1,statbuf.st_uid);
524 #else
525                 setuid(statbuf.st_uid);
526 #endif
527 #endif
528         }
529         else if (uid)                   /* oops, mustn't run as root */
530 #ifdef HAS_SETEUID
531             (void)seteuid((UIDTYPE)uid);
532 #else
533 #ifdef HAS_SETREUID
534             (void)setreuid((UIDTYPE)-1,(UIDTYPE)uid);
535 #else
536             setuid((UIDTYPE)uid);
537 #endif
538 #endif
539         uid = (int)getuid();
540         euid = (int)geteuid();
541         gid = (int)getgid();
542         egid = (int)getegid();
543         if (!cando(S_IXUSR,TRUE,&statbuf))
544             fatal("Permission denied\n");       /* they can't do this */
545     }
546 #ifdef IAMSUID
547     else if (preprocess)
548         fatal("-P not allowed for setuid/setgid script\n");
549     else
550         fatal("Script is not setuid/setgid in suidperl\n");
551 #else
552 #ifndef TAINT           /* we aren't taintperl or suidperl */
553     /* script has a wrapper--can't run suidperl or we lose euid */
554     else if (euid != uid || egid != gid) {
555         (void)fclose(rsfp);
556         (void)sprintf(buf, "%s/tperl%s", BIN, patchlevel);
557         execv(buf, origargv);   /* try again */
558         fatal("Can't run setuid script with taint checks");
559     }
560 #endif /* TAINT */
561 #endif /* IAMSUID */
562 #else /* !DOSUID */
563 #ifndef TAINT           /* we aren't taintperl or suidperl */
564     if (euid != uid || egid != gid) {   /* (suidperl doesn't exist, in fact) */
565 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
566         fstat(fileno(rsfp),&statbuf);   /* may be either wrapped or real suid */
567         if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
568             ||
569             (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
570            )
571             if (!do_undump)
572                 fatal("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
573 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
574 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
575         /* not set-id, must be wrapped */
576         (void)fclose(rsfp);
577         (void)sprintf(buf, "%s/tperl%s", BIN, patchlevel);
578         execv(buf, origargv);   /* try again */
579         fatal("Can't run setuid script with taint checks");
580     }
581 #endif /* TAINT */
582 #endif /* DOSUID */
583
584 #if !defined(IAMSUID) && !defined(TAINT)
585
586     /* skip forward in input to the real script? */
587
588     while (doextract) {
589         if ((s = str_gets(linestr, rsfp, 0)) == Nullch)
590             fatal("No Perl script found in input\n");
591         if (*s == '#' && s[1] == '!' && instr(s,"perl")) {
592             ungetc('\n',rsfp);          /* to keep line count right */
593             doextract = FALSE;
594             if (s = instr(s,"perl -")) {
595                 s += 6;
596                 while (s = moreswitches(s)) ;
597             }
598             if (cddir && chdir(cddir) < 0)
599                 fatal("Can't chdir to %s",cddir);
600         }
601     }
602 #endif /* !defined(IAMSUID) && !defined(TAINT) */
603
604     defstab = stabent("_",TRUE);
605
606     if (perldb) {
607         debstash = hnew(0);
608         stab_xhash(stabent("_DB",TRUE)) = debstash;
609         curstash = debstash;
610         dbargs = stab_xarray(aadd((tmpstab = stabent("args",TRUE))));
611         tmpstab->str_pok |= SP_MULTI;
612         dbargs->ary_flags = 0;
613         subname = str_make("main",4);
614         DBstab = stabent("DB",TRUE);
615         DBstab->str_pok |= SP_MULTI;
616         DBline = stabent("dbline",TRUE);
617         DBline->str_pok |= SP_MULTI;
618         DBsub = hadd(tmpstab = stabent("sub",TRUE));
619         tmpstab->str_pok |= SP_MULTI;
620         DBsingle = stab_val((tmpstab = stabent("single",TRUE)));
621         tmpstab->str_pok |= SP_MULTI;
622         DBtrace = stab_val((tmpstab = stabent("trace",TRUE)));
623         tmpstab->str_pok |= SP_MULTI;
624         DBsignal = stab_val((tmpstab = stabent("signal",TRUE)));
625         tmpstab->str_pok |= SP_MULTI;
626         curstash = defstash;
627     }
628
629     /* init tokener */
630
631     bufend = bufptr = str_get(linestr);
632
633     savestack = anew(Nullstab);         /* for saving non-local values */
634     stack = anew(Nullstab);             /* for saving non-local values */
635     stack->ary_flags = 0;               /* not a real array */
636     afill(stack,63); afill(stack,-1);   /* preextend stack */
637     afill(savestack,63); afill(savestack,-1);
638
639     /* now parse the script */
640
641     error_count = 0;
642     if (yyparse() || error_count) {
643         if (minus_c)
644             fatal("%s had compilation errors.\n", origfilename);
645         else {
646             fatal("Execution of %s aborted due to compilation errors.\n",
647                 origfilename);
648         }
649     }
650
651     New(50,loop_stack,128,struct loop);
652 #ifdef DEBUGGING
653     if (debug) {
654         New(51,debname,128,char);
655         New(52,debdelim,128,char);
656     }
657 #endif
658     curstash = defstash;
659
660     preprocess = FALSE;
661     if (e_fp) {
662         e_fp = Nullfp;
663         (void)UNLINK(e_tmpname);
664     }
665
666     /* initialize everything that won't change if we undump */
667
668     if (sigstab = stabent("SIG",allstabs)) {
669         sigstab->str_pok |= SP_MULTI;
670         (void)hadd(sigstab);
671     }
672
673     magicalize("!#?^~=-%.+&*()<>,\\/[|`':\004\t\020\024\027\006");
674     userinit();         /* in case linked C routines want magical variables */
675
676     amperstab = stabent("&",allstabs);
677     leftstab = stabent("`",allstabs);
678     rightstab = stabent("'",allstabs);
679     sawampersand = (amperstab || leftstab || rightstab);
680     if (tmpstab = stabent(":",allstabs))
681         str_set(STAB_STR(tmpstab),chopset);
682     if (tmpstab = stabent("\024",allstabs))
683         time(&basetime);
684
685     /* these aren't necessarily magical */
686     if (tmpstab = stabent(";",allstabs))
687         str_set(STAB_STR(tmpstab),"\034");
688     if (tmpstab = stabent("]",allstabs)) {
689         str = STAB_STR(tmpstab);
690         str_set(str,rcsid);
691         str->str_u.str_nval = atof(patchlevel);
692         str->str_nok = 1;
693     }
694     str_nset(stab_val(stabent("\"", TRUE)), " ", 1);
695
696     stdinstab = stabent("STDIN",TRUE);
697     stdinstab->str_pok |= SP_MULTI;
698     stab_io(stdinstab) = stio_new();
699     stab_io(stdinstab)->ifp = stdin;
700     tmpstab = stabent("stdin",TRUE);
701     stab_io(tmpstab) = stab_io(stdinstab);
702     tmpstab->str_pok |= SP_MULTI;
703
704     tmpstab = stabent("STDOUT",TRUE);
705     tmpstab->str_pok |= SP_MULTI;
706     stab_io(tmpstab) = stio_new();
707     stab_io(tmpstab)->ofp = stab_io(tmpstab)->ifp = stdout;
708     defoutstab = tmpstab;
709     tmpstab = stabent("stdout",TRUE);
710     stab_io(tmpstab) = stab_io(defoutstab);
711     tmpstab->str_pok |= SP_MULTI;
712
713     curoutstab = stabent("STDERR",TRUE);
714     curoutstab->str_pok |= SP_MULTI;
715     stab_io(curoutstab) = stio_new();
716     stab_io(curoutstab)->ofp = stab_io(curoutstab)->ifp = stderr;
717     tmpstab = stabent("stderr",TRUE);
718     stab_io(tmpstab) = stab_io(curoutstab);
719     tmpstab->str_pok |= SP_MULTI;
720     curoutstab = defoutstab;            /* switch back to STDOUT */
721
722     statname = Str_new(66,0);           /* last filename we did stat on */
723
724     /* now that script is parsed, we can modify record separator */
725
726     rs = nrs;
727     rslen = nrslen;
728     rschar = nrschar;
729     str_nset(stab_val(stabent("/", TRUE)), rs, rslen);
730
731     if (do_undump)
732         my_unexec();
733
734   just_doit:            /* come here if running an undumped a.out */
735     argc--,argv++;      /* skip name of script */
736     if (doswitches) {
737         for (; argc > 0 && **argv == '-'; argc--,argv++) {
738             if (argv[0][1] == '-') {
739                 argc--,argv++;
740                 break;
741             }
742             if (s = index(argv[0], '=')) {
743                 *s++ = '\0';
744                 str_set(stab_val(stabent(argv[0]+1,TRUE)),s);
745             }
746             else
747                 str_numset(stab_val(stabent(argv[0]+1,TRUE)),(double)1.0);
748         }
749     }
750 #ifdef TAINT
751     tainted = 1;
752 #endif
753     if (tmpstab = stabent("0",allstabs)) {
754         str_set(stab_val(tmpstab),origfilename);
755         magicname("0", Nullch, 0);
756     }
757     if (tmpstab = stabent("\030",allstabs))
758         str_set(stab_val(tmpstab),origargv[0]);
759     if (argvstab = stabent("ARGV",allstabs)) {
760         argvstab->str_pok |= SP_MULTI;
761         (void)aadd(argvstab);
762         aclear(stab_array(argvstab));
763         for (; argc > 0; argc--,argv++) {
764             (void)apush(stab_array(argvstab),str_make(argv[0],0));
765         }
766     }
767 #ifdef TAINT
768     (void) stabent("ENV",TRUE);         /* must test PATH and IFS */
769 #endif
770     if (envstab = stabent("ENV",allstabs)) {
771         envstab->str_pok |= SP_MULTI;
772         (void)hadd(envstab);
773         hclear(stab_hash(envstab), FALSE);
774         if (env != environ)
775             environ[0] = Nullch;
776         for (; *env; env++) {
777             if (!(s = index(*env,'=')))
778                 continue;
779             *s++ = '\0';
780             str = str_make(s--,0);
781             str_magic(str, envstab, 'E', *env, s - *env);
782             (void)hstore(stab_hash(envstab), *env, s - *env, str, 0);
783             *s = '=';
784         }
785     }
786 #ifdef TAINT
787     tainted = 0;
788 #endif
789     if (tmpstab = stabent("$",allstabs))
790         str_numset(STAB_STR(tmpstab),(double)getpid());
791
792     if (dowarn) {
793         stab_check('A','Z');
794         stab_check('a','z');
795     }
796
797     if (setjmp(top_env))        /* sets goto_targ on longjump */
798         loop_ptr = -1;          /* start label stack again */
799
800 #ifdef DEBUGGING
801     if (debug & 1024)
802         dump_all();
803     if (debug)
804         fprintf(stderr,"\nEXECUTING...\n\n");
805 #endif
806
807     if (minus_c) {
808         fprintf(stderr,"%s syntax OK\n", origfilename);
809         exit(0);
810     }
811
812     /* do it */
813
814     (void) cmd_exec(main_root,G_SCALAR,-1);
815
816     if (goto_targ)
817         fatal("Can't find label \"%s\"--aborting",goto_targ);
818     exit(0);
819     /* NOTREACHED */
820 }
821
822 void
823 magicalize(list)
824 register char *list;
825 {
826     char sym[2];
827
828     sym[1] = '\0';
829     while (*sym = *list++)
830         magicname(sym, Nullch, 0);
831 }
832
833 void
834 magicname(sym,name,namlen)
835 char *sym;
836 char *name;
837 int namlen;
838 {
839     register STAB *stab;
840
841     if (stab = stabent(sym,allstabs)) {
842         stab_flags(stab) = SF_VMAGIC;
843         str_magic(stab_val(stab), stab, 0, name, namlen);
844     }
845 }
846
847 void
848 savelines(array, str)
849 ARRAY *array;
850 STR *str;
851 {
852     register char *s = str->str_ptr;
853     register char *send = str->str_ptr + str->str_cur;
854     register char *t;
855     register int line = 1;
856
857     while (s && s < send) {
858         STR *tmpstr = Str_new(85,0);
859
860         t = index(s, '\n');
861         if (t)
862             t++;
863         else
864             t = send;
865
866         str_nset(tmpstr, s, t - s);
867         astore(array, line++, tmpstr);
868         s = t;
869     }
870 }
871
872 /* this routine is in perl.c by virtue of being sort of an alternate main() */
873
874 int
875 do_eval(str,optype,stash,gimme,arglast)
876 STR *str;
877 int optype;
878 HASH *stash;
879 int gimme;
880 int *arglast;
881 {
882     STR **st = stack->ary_array;
883     int retval;
884     CMD *myroot = Nullcmd;
885     ARRAY *ar;
886     int i;
887     CMD * VOLATILE oldcurcmd = curcmd;
888     VOLATILE int oldtmps_base = tmps_base;
889     VOLATILE int oldsave = savestack->ary_fill;
890     VOLATILE int oldperldb = perldb;
891     SPAT * VOLATILE oldspat = curspat;
892     SPAT * VOLATILE oldlspat = lastspat;
893     static char *last_eval = Nullch;
894     static CMD *last_root = Nullcmd;
895     VOLATILE int sp = arglast[0];
896     char *specfilename;
897     char *tmpfilename;
898     int parsing = 1;
899
900     tmps_base = tmps_max;
901     if (curstash != stash) {
902         (void)savehptr(&curstash);
903         curstash = stash;
904     }
905     str_set(stab_val(stabent("@",TRUE)),"");
906     if (curcmd->c_line == 0)            /* don't debug debugger... */
907         perldb = FALSE;
908     curcmd = &compiling;
909     if (optype == O_EVAL) {             /* normal eval */
910         curcmd->c_filestab = fstab("(eval)");
911         curcmd->c_line = 1;
912         str_sset(linestr,str);
913         str_cat(linestr,";\n");         /* be kind to them */
914         if (perldb)
915             savelines(stab_xarray(curcmd->c_filestab), linestr);
916     }
917     else {
918         if (last_root && !in_eval) {
919             Safefree(last_eval);
920             last_eval = Nullch;
921             cmd_free(last_root);
922             last_root = Nullcmd;
923         }
924         specfilename = str_get(str);
925         str_set(linestr,"");
926         if (optype == O_REQUIRE && &str_undef !=
927           hfetch(stab_hash(incstab), specfilename, strlen(specfilename), 0)) {
928             curcmd = oldcurcmd;
929             tmps_base = oldtmps_base;
930             st[++sp] = &str_yes;
931             perldb = oldperldb;
932             return sp;
933         }
934         tmpfilename = savestr(specfilename);
935         if (index("/.", *tmpfilename))
936             rsfp = fopen(tmpfilename,"r");
937         else {
938             ar = stab_array(incstab);
939             for (i = 0; i <= ar->ary_fill; i++) {
940                 (void)sprintf(buf, "%s/%s",
941                   str_get(afetch(ar,i,TRUE)), specfilename);
942                 rsfp = fopen(buf,"r");
943                 if (rsfp) {
944                     char *s = buf;
945
946                     if (*s == '.' && s[1] == '/')
947                         s += 2;
948                     Safefree(tmpfilename);
949                     tmpfilename = savestr(s);
950                     break;
951                 }
952             }
953         }
954         curcmd->c_filestab = fstab(tmpfilename);
955         Safefree(tmpfilename);
956         tmpfilename = Nullch;
957         if (!rsfp) {
958             curcmd = oldcurcmd;
959             tmps_base = oldtmps_base;
960             if (optype == O_REQUIRE) {
961                 sprintf(tokenbuf,"Can't locate %s in @INC", specfilename);
962                 if (instr(tokenbuf,".h "))
963                     strcat(tokenbuf," (change .h to .ph maybe?)");
964                 if (instr(tokenbuf,".ph "))
965                     strcat(tokenbuf," (did you run h2ph?)");
966                 fatal("%s",tokenbuf);
967             }
968             if (gimme != G_ARRAY)
969                 st[++sp] = &str_undef;
970             perldb = oldperldb;
971             return sp;
972         }
973         curcmd->c_line = 0;
974     }
975     in_eval++;
976     oldoldbufptr = oldbufptr = bufptr = str_get(linestr);
977     bufend = bufptr + linestr->str_cur;
978     if (++loop_ptr >= loop_max) {
979         loop_max += 128;
980         Renew(loop_stack, loop_max, struct loop);
981     }
982     loop_stack[loop_ptr].loop_label = "_EVAL_";
983     loop_stack[loop_ptr].loop_sp = sp;
984 #ifdef DEBUGGING
985     if (debug & 4) {
986         deb("(Pushing label #%d _EVAL_)\n", loop_ptr);
987     }
988 #endif
989     eval_root = Nullcmd;
990     if (setjmp(loop_stack[loop_ptr].loop_env)) {
991         retval = 1;
992     }
993     else {
994         error_count = 0;
995         if (rsfp) {
996             retval = yyparse();
997             retval |= error_count;
998         }
999         else if (last_root && *bufptr == *last_eval && strEQ(bufptr,last_eval)){
1000             retval = 0;
1001             eval_root = last_root;      /* no point in reparsing */
1002         }
1003         else if (in_eval == 1) {
1004             if (last_root) {
1005                 Safefree(last_eval);
1006                 last_eval = Nullch;
1007                 cmd_free(last_root);
1008             }
1009             last_root = Nullcmd;
1010             last_eval = savestr(bufptr);
1011             retval = yyparse();
1012             retval |= error_count;
1013             if (!retval)
1014                 last_root = eval_root;
1015             if (!last_root) {
1016                 Safefree(last_eval);
1017                 last_eval = Nullch;
1018             }
1019         }
1020         else
1021             retval = yyparse();
1022     }
1023     myroot = eval_root;         /* in case cmd_exec does another eval! */
1024
1025     if (retval) {
1026         st = stack->ary_array;
1027         sp = arglast[0];
1028         if (gimme != G_ARRAY)
1029             st[++sp] = &str_undef;
1030         if (parsing) {
1031 #ifndef MANGLEDPARSE
1032 #ifdef DEBUGGING
1033             if (debug & 128)
1034                 fprintf(stderr,"Freeing eval_root %lx\n",(long)eval_root);
1035 #endif
1036             cmd_free(eval_root);
1037 #endif
1038             if (eval_root == last_root)
1039                 last_root = Nullcmd;
1040             eval_root = myroot = Nullcmd;
1041         }
1042         if (rsfp) {
1043             fclose(rsfp);
1044             rsfp = 0;
1045         }
1046     }
1047     else {
1048         parsing = 0;
1049         sp = cmd_exec(eval_root,gimme,sp);
1050         st = stack->ary_array;
1051         for (i = arglast[0] + 1; i <= sp; i++)
1052             st[i] = str_mortal(st[i]);
1053                                 /* if we don't save result, free zaps it */
1054         if (in_eval != 1 && myroot != last_root)
1055             cmd_free(myroot);
1056     }
1057
1058     perldb = oldperldb;
1059     in_eval--;
1060 #ifdef DEBUGGING
1061     if (debug & 4) {
1062         char *tmps = loop_stack[loop_ptr].loop_label;
1063         deb("(Popping label #%d %s)\n",loop_ptr,
1064             tmps ? tmps : "" );
1065     }
1066 #endif
1067     loop_ptr--;
1068     tmps_base = oldtmps_base;
1069     curspat = oldspat;
1070     lastspat = oldlspat;
1071     if (savestack->ary_fill > oldsave)  /* let them use local() */
1072         restorelist(oldsave);
1073
1074     if (optype != O_EVAL) {
1075         if (retval) {
1076             if (optype == O_REQUIRE)
1077                 fatal("%s", str_get(stab_val(stabent("@",TRUE))));
1078         }
1079         else {
1080             curcmd = oldcurcmd;
1081             if (gimme == G_SCALAR ? str_true(st[sp]) : sp > arglast[0]) {
1082                 (void)hstore(stab_hash(incstab), specfilename,
1083                   strlen(specfilename), str_smake(stab_val(curcmd->c_filestab)),
1084                       0 );
1085             }
1086             else if (optype == O_REQUIRE)
1087                 fatal("%s did not return a true value", specfilename);
1088         }
1089     }
1090     curcmd = oldcurcmd;
1091     return sp;
1092 }
1093
1094 /* This routine handles any switches that can be given during run */
1095
1096 static char *
1097 moreswitches(s)
1098 char *s;
1099 {
1100     int numlen;
1101
1102   reswitch:
1103     switch (*s) {
1104     case '0':
1105         nrschar = scanoct(s, 4, &numlen);
1106         nrs = nsavestr("\n",1);
1107         *nrs = nrschar;
1108         if (nrschar > 0377) {
1109             nrslen = 0;
1110             nrs = "";
1111         }
1112         else if (!nrschar && numlen >= 2) {
1113             nrslen = 2;
1114             nrs = "\n\n";
1115             nrschar = '\n';
1116         }
1117         return s + numlen;
1118     case 'a':
1119         minus_a = TRUE;
1120         s++;
1121         return s;
1122     case 'c':
1123         minus_c = TRUE;
1124         s++;
1125         return s;
1126     case 'd':
1127 #ifdef TAINT
1128         if (euid != uid || egid != gid)
1129             fatal("No -d allowed in setuid scripts");
1130 #endif
1131         perldb = TRUE;
1132         s++;
1133         return s;
1134     case 'D':
1135 #ifdef DEBUGGING
1136 #ifdef TAINT
1137         if (euid != uid || egid != gid)
1138             fatal("No -D allowed in setuid scripts");
1139 #endif
1140         debug = atoi(s+1) | 32768;
1141 #else
1142         warn("Recompile perl with -DDEBUGGING to use -D switch\n");
1143 #endif
1144         for (s++; isdigit(*s); s++) ;
1145         return s;
1146     case 'i':
1147         inplace = savestr(s+1);
1148         for (s = inplace; *s && !isspace(*s); s++) ;
1149         *s = '\0';
1150         break;
1151     case 'I':
1152 #ifdef TAINT
1153         if (euid != uid || egid != gid)
1154             fatal("No -I allowed in setuid scripts");
1155 #endif
1156         if (*++s) {
1157             (void)apush(stab_array(incstab),str_make(s,0));
1158         }
1159         else
1160             fatal("No space allowed after -I");
1161         break;
1162     case 'l':
1163         minus_l = TRUE;
1164         s++;
1165         if (isdigit(*s)) {
1166             ors = savestr("\n");
1167             orslen = 1;
1168             *ors = scanoct(s, 3 + (*s == '0'), &numlen);
1169             s += numlen;
1170         }
1171         else {
1172             ors = nsavestr(nrs,nrslen);
1173             orslen = nrslen;
1174         }
1175         return s;
1176     case 'n':
1177         minus_n = TRUE;
1178         s++;
1179         return s;
1180     case 'p':
1181         minus_p = TRUE;
1182         s++;
1183         return s;
1184     case 'u':
1185         do_undump = TRUE;
1186         s++;
1187         return s;
1188     case 'U':
1189         unsafe = TRUE;
1190         s++;
1191         return s;
1192     case 'v':
1193         fputs("\nThis is perl, version 4.0\n\n",stdout);
1194         fputs(rcsid,stdout);
1195         fputs("\nCopyright (c) 1989, 1990, 1991, Larry Wall\n",stdout);
1196 #ifdef MSDOS
1197         fputs("MS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n",
1198         stdout);
1199 #ifdef OS2
1200         fputs("OS/2 port Copyright (c) 1990, Raymond Chen, Kai Uwe Rommel\n",
1201         stdout);
1202 #endif
1203 #endif
1204         fputs("\n\
1205 Perl may be copied only under the terms of either the Artistic License or the\n\
1206 GNU General Public License, which may be found in the Perl 4.0 source kit.\n",stdout);
1207 #ifdef MSDOS
1208         usage(origargv[0]);
1209 #endif
1210         exit(0);
1211     case 'w':
1212         dowarn = TRUE;
1213         s++;
1214         return s;
1215     case ' ':
1216     case '\n':
1217     case '\t':
1218         break;
1219     default:
1220         fatal("Switch meaningless after -x: -%s",s);
1221     }
1222     return Nullch;
1223 }
1224
1225 /* compliments of Tom Christiansen */
1226
1227 /* unexec() can be found in the Gnu emacs distribution */
1228
1229 my_unexec()
1230 {
1231 #ifdef UNEXEC
1232     int    status;
1233     extern int etext;
1234     static char dumpname[BUFSIZ];
1235     static char perlpath[256];
1236
1237     sprintf (dumpname, "%s.perldump", origfilename);
1238     sprintf (perlpath, "%s/perl", BIN);
1239
1240     status = unexec(dumpname, perlpath, &etext, sbrk(0), 0);
1241     if (status)
1242         fprintf(stderr, "unexec of %s into %s failed!\n", perlpath, dumpname);
1243     exit(status);
1244 #else
1245 #ifdef MSDOS
1246     abort();    /* nothing else to do */
1247 #else /* ! MSDOS */
1248 #   ifndef SIGABRT
1249 #       define SIGABRT SIGILL
1250 #   endif
1251 #   ifndef SIGILL
1252 #       define SIGILL 6         /* blech */
1253 #   endif
1254     kill(getpid(),SIGABRT);     /* for use with undump */
1255 #endif /* ! MSDOS */
1256 #endif
1257 }
1258