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