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