projects / p5sagit/p5-mst-13.2.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | history | HEAD
perl 4.0 patch 36: (combined patch)
[p5sagit/p5-mst-13.2.git] / perl.c.orig
CommitLineData
e334a159 1char 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
60char *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
74static char* moreswitches();
75static void incpush();
76static char* cddir;
77static bool minus_c;
78static char patchlevel[6];
79static char *nrs = "\n";
80static int nrschar = '\n'; /* final char of rs, or 0777 if none */
81static int nrslen = 1;
82
83main(argc,argv,env)
84register int argc;
85register char **argv;
86register 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\
101setuid 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, "\
358sed %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\
554FIX 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\
640FIX 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
898void
899magicalize(list)
900register char *list;
901{
902 char sym[2];
903
904 sym[1] = '\0';
905 while (*sym = *list++)
906 magicname(sym, Nullch, 0);
907}
908
909void
910magicname(sym,name,namlen)
911char *sym;
912char *name;
913int 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
923static void
924incpush(p)
925char *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
950void
951savelines(array, str)
952ARRAY *array;
953STR *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
977int
978do_eval(str,optype,stash,savecmd,gimme,arglast)
979STR *str;
980int optype;
981HASH *stash;
982int savecmd;
983int gimme;
984int *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
1209int
1210do_try(cmd,gimme,arglast)
1211CMD *cmd;
1212int gimme;
1213int *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
1273static char *
1274moreswitches(s)
1275char *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\
1386Perl may be copied only under the terms of either the Artistic License or the\n\
1387GNU 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
1410void
1411my_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
Unnamed repository; edit this file to name it for gitweb.