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