1 char rcsid[] = "$RCSfile: perl.c,v $$Revision: 4.0.1.7 $$Date: 92/06/08 14:50:39 $\nPatch level: ###\n";
3 * Copyright (c) 1991, Larry Wall
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.
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
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()
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
33 * Revision 4.0.1.4 91/06/10 01:23:07 lwall
34 * patch10: perl -v printed incorrect copyright notice
36 * Revision 4.0.1.3 91/06/07 11:40:18 lwall
37 * patch4: changed old $^P to $^X
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
45 * Revision 4.0.1.1 91/04/11 17:49:05 lwall
46 * patch1: fixed undefined environ problem
48 * Revision 4.0 91/03/20 01:37:44 lwall
58 #include "patchlevel.h"
68 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
74 static char* moreswitches();
75 static void incpush();
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;
92 bool dosearch = FALSE;
97 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
100 fatal("suidperl is no longer needed since the kernel can now execute\n\
101 setuid perl scripts securely.\n");
107 origenviron = environ;
109 euid = (int)geteuid();
111 egid = (int)getegid();
112 sprintf(patchlevel,"%3.3s%2.2d", index(rcsid,'4'), PATCHLEVEL);
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
119 (void)fclose(stdaux);
120 (void)fclose(stdprn);
123 origfilename = savestr(argv[0]);
125 loop_ptr = -1; /* start label stack again */
130 if (uid == euid && gid == egid)
131 taintanyway = TRUE; /* running taintperl explicitly */
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])
149 validarg = " PHOOEY ";
169 if (s = moreswitches(s))
175 if (euid != uid || egid != gid)
176 fatal("No -e allowed in setuid scripts");
179 e_tmpname = savestr(TMPPATH);
180 (void)mktemp(e_tmpname);
182 fatal("Can't mktemp()");
183 e_fp = fopen(e_tmpname,"w");
185 fatal("Cannot open temporary file");
191 (void)putc('\n', e_fp);
195 if (euid != uid || egid != gid)
196 fatal("No -I allowed in setuid scripts");
202 (void)apush(stab_array(incstab),str_make(s,0));
205 (void)apush(stab_array(incstab),str_make(argv[1],0));
206 str_cat(str,argv[1]);
213 if (euid != uid || egid != gid)
214 fatal("No -P allowed in setuid scripts");
221 if (euid != uid || egid != gid)
222 fatal("No -s allowed in setuid scripts");
229 if (euid != uid || egid != gid)
230 fatal("No -S allowed in setuid scripts");
247 fatal("Unrecognized switch: -%s",s);
251 scriptname = argv[0];
253 if (fflush(e_fp) || ferror(e_fp) || fclose(e_fp))
254 fatal("Can't write to temp file for -e: %s", strerror(errno));
256 scriptname = e_tmpname;
260 #define PERLLIB_SEP ';'
262 #define PERLLIB_SEP ':'
264 #ifndef TAINT /* Can't allow arbitrary PERLLIB in setuid script */
265 incpush(getenv("PERLLIB"));
269 #define PRIVLIB "/usr/local/lib/perl"
272 (void)apush(stab_array(incstab),str_make(".",1));
275 str_set(&str_yes,Yes);
279 if (scriptname == Nullch)
282 if ( isatty(fileno(stdin)) )
289 if (dosearch && !index(scriptname, '/') && (s = getenv("PATH"))) {
290 char *xfound = Nullch, *xfailed = Nullch;
293 bufend = s + strlen(s);
296 s = cpytill(tokenbuf,s,bufend,':',&len);
299 for (len = 0; *s && *s != ',' && *s != ';'; tokenbuf[len++] = *s++);
300 tokenbuf[len] = '\0';
302 for (len = 0; *s && *s != ';'; tokenbuf[len++] = *s++);
303 tokenbuf[len] = '\0';
309 if (len && tokenbuf[len-1] != '/')
312 if (len && ((tokenbuf[len-1] != '\\') && (tokenbuf[len-1] != '/')))
314 if (len && tokenbuf[len-1] != '\\')
317 (void)strcat(tokenbuf+len,"/");
318 (void)strcat(tokenbuf+len,scriptname);
321 fprintf(stderr,"Looking for %s\n",tokenbuf);
323 if (stat(tokenbuf,&statbuf) < 0) /* not there? */
325 if (S_ISREG(statbuf.st_mode)
326 && cando(S_IRUSR,TRUE,&statbuf) && cando(S_IXUSR,TRUE,&statbuf)) {
327 xfound = tokenbuf; /* bingo! */
331 xfailed = savestr(tokenbuf);
334 fatal("Can't execute %s", xfailed ? xfailed : scriptname );
337 scriptname = savestr(xfound);
340 fdpid = anew(Nullstab); /* for remembering popen pids by fd */
341 pidstatus = hnew(COEFFSIZE);/* for remembering status of dead pids */
343 origfilename = savestr(scriptname);
344 curcmd->c_filestab = fstab(origfilename);
345 if (strEQ(origfilename,"-"))
348 char *cpp = CPPSTDIN;
350 if (strEQ(cpp,"cppstdin"))
351 sprintf(tokenbuf, "%s/%s", SCRIPTDIR, cpp);
353 sprintf(tokenbuf, "%s", cpp);
355 str_cat(str,PRIVLIB);
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\" \
370 (doextract ? "-e \"1,/^#/d\n\"" : ""),
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' \
380 -e '/^#[ ]*elif[ ]/b' \
381 -e '/^#[ ]*undef[ ]/b' \
382 -e '/^#[ ]*endif/b' \
390 (doextract ? "-e '1,/^#/d\n'" : ""),
392 scriptname, tokenbuf, str_get(str), CPPMINUS);
400 #ifdef IAMSUID /* actually, this is caught earlier */
401 if (euid != uid && !euid) { /* if running suidperl */
403 (void)seteuid(uid); /* musn't stay setuid root */
406 (void)setreuid(-1, uid);
411 if (geteuid() != uid)
412 fatal("Can't do seteuid!\n");
415 rsfp = mypopen(buf,"r");
417 else if (!*scriptname) {
419 if (euid != uid || egid != gid)
420 fatal("Can't take set-id script from stdin");
425 rsfp = fopen(scriptname,"r");
426 if ((FILE*)rsfp == Nullfp) {
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");
437 fatal("Can't open perl script \"%s\": %s\n",
438 stab_val(curcmd->c_filestab)->str_ptr, strerror(errno));
440 str_free(str); /* free -I directories */
443 /* do we need to emulate setuid on scripts? */
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
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.
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.
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)) {
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.
486 if (access(stab_val(curcmd->c_filestab)->str_ptr,1)) /*double check*/
487 fatal("Permission denied");
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.
495 struct stat tmpstatbuf;
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) {
504 if (rsfp = mypopen("/bin/mail root","w")) { /* heh, heh */
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);
514 fatal("Permission denied\n");
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");
521 #endif /* HAS_SETREUID */
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 */
530 if (fgets(tokenbuf,sizeof tokenbuf, rsfp) == Nullch ||
531 strnNE(tokenbuf,"#!",2) ) /* required even on Sys V */
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++;
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.
544 len = strlen(validarg);
545 if (strEQ(validarg," PHOOEY ") ||
546 strnNE(s,validarg,len) || !isSPACE(s[len]))
547 fatal("Args must match #! line");
550 if (euid != uid && (statbuf.st_mode & S_ISUID) &&
551 euid == statbuf.st_uid)
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");
557 if (euid) { /* oops, we're not the setuid root perl */
560 (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel);
561 execv(buf, origargv); /* try again */
563 fatal("Can't do setuid\n");
566 if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid) {
568 (void)setegid(statbuf.st_gid);
571 (void)setregid((GIDTYPE)-1,statbuf.st_gid);
573 setgid(statbuf.st_gid);
576 if (getegid() != statbuf.st_gid)
577 fatal("Can't do setegid!\n");
579 if (statbuf.st_mode & S_ISUID) {
580 if (statbuf.st_uid != euid)
582 (void)seteuid(statbuf.st_uid); /* all that for this */
585 (void)setreuid((UIDTYPE)-1,statbuf.st_uid);
587 setuid(statbuf.st_uid);
590 if (geteuid() != statbuf.st_uid)
591 fatal("Can't do seteuid!\n");
593 else if (uid) { /* oops, mustn't run as root */
595 (void)seteuid((UIDTYPE)uid);
598 (void)setreuid((UIDTYPE)-1,(UIDTYPE)uid);
600 setuid((UIDTYPE)uid);
603 if (geteuid() != uid)
604 fatal("Can't do seteuid!\n");
607 euid = (int)geteuid();
609 egid = (int)getegid();
610 if (!cando(S_IXUSR,TRUE,&statbuf))
611 fatal("Permission denied\n"); /* they can't do this */
615 fatal("-P not allowed for setuid/setgid script\n");
617 fatal("Script is not setuid/setgid in suidperl\n");
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) {
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");
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)
636 (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
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 */
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");
651 #if !defined(IAMSUID) && !defined(TAINT)
653 /* skip forward in input to the real script? */
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 */
661 if (s = instr(s,"perl -")) {
664 while (s = moreswitches(s)) ;
666 if (cddir && chdir(cddir) < 0)
667 fatal("Can't chdir to %s",cddir);
670 #endif /* !defined(IAMSUID) && !defined(TAINT) */
672 defstab = stabent("_",TRUE);
674 subname = str_make("main",4);
677 stab_xhash(stabent("_DB",TRUE)) = 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;
699 bufend = bufptr = str_get(linestr);
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);
707 /* now parse the script */
710 if (yyparse() || error_count) {
712 fatal("%s had compilation errors.\n", origfilename);
714 fatal("Execution of %s aborted due to compilation errors.\n",
719 New(50,loop_stack,128,struct loop);
722 New(51,debname,128,char);
723 New(52,debdelim,128,char);
731 (void)UNLINK(e_tmpname);
734 /* initialize everything that won't change if we undump */
736 if (sigstab = stabent("SIG",allstabs)) {
737 sigstab->str_pok |= SP_MULTI;
741 magicalize("!#?^~=-%.+&*()<>,\\/[|`':\004\t\020\024\027\006");
742 userinit(); /* in case linked C routines want magical variables */
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))
753 /* these aren't necessarily magical */
754 if (tmpstab = stabent("\014",allstabs)) {
755 str_set(stab_val(tmpstab),"\f");
756 formfeed = stab_val(tmpstab);
758 if (tmpstab = stabent(";",allstabs))
759 str_set(STAB_STR(tmpstab),"\034");
760 if (tmpstab = stabent("]",allstabs)) {
761 str = STAB_STR(tmpstab);
763 str->str_u.str_nval = atof(patchlevel);
766 str_nset(stab_val(stabent("\"", TRUE)), " ", 1);
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;
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;
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 */
797 statname = Str_new(66,0); /* last filename we did stat on */
799 /* now that script is parsed, we can modify record separator */
804 rspara = (nrslen == 2);
805 str_nset(stab_val(stabent("/", TRUE)), rs, rslen);
810 just_doit: /* come here if running an undumped a.out */
811 argc--,argv++; /* skip name of script */
813 for (; argc > 0 && **argv == '-'; argc--,argv++) {
814 if (argv[0][1] == '-') {
818 if (s = index(argv[0], '=')) {
820 str_set(stab_val(stabent(argv[0]+1,TRUE)),s);
823 str_numset(stab_val(stabent(argv[0]+1,TRUE)),(double)1.0);
829 if (tmpstab = stabent("0",allstabs)) {
830 str_set(stab_val(tmpstab),origfilename);
831 magicname("0", Nullch, 0);
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));
844 (void) stabent("ENV",TRUE); /* must test PATH and IFS */
846 if (envstab = stabent("ENV",allstabs)) {
847 envstab->str_pok |= SP_MULTI;
849 hclear(stab_hash(envstab), FALSE);
852 for (; *env; env++) {
853 if (!(s = index(*env,'=')))
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);
865 if (tmpstab = stabent("$",allstabs))
866 str_numset(STAB_STR(tmpstab),(double)getpid());
873 if (setjmp(top_env)) /* sets goto_targ on longjump */
874 loop_ptr = -1; /* start label stack again */
880 fprintf(stderr,"\nEXECUTING...\n\n");
884 fprintf(stderr,"%s syntax OK\n", origfilename);
890 (void) cmd_exec(main_root,G_SCALAR,-1);
893 fatal("Can't find label \"%s\"--aborting",goto_targ);
905 while (*sym = *list++)
906 magicname(sym, Nullch, 0);
910 magicname(sym,name,namlen)
917 if (stab = stabent(sym,allstabs)) {
918 stab_flags(stab) = SF_VMAGIC;
919 str_magic(stab_val(stab), stab, 0, name, namlen);
932 /* Break at all separators */
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)); */
940 if ( (s = index(p, PERLLIB_SEP)) != Nullch ) {
941 (void)apush(stab_array(incstab), str_make(p, (int)(s - p)));
944 (void)apush(stab_array(incstab), str_make(p, 0));
951 savelines(array, str)
955 register char *s = str->str_ptr;
956 register char *send = str->str_ptr + str->str_cur;
958 register int line = 1;
960 while (s && s < send) {
961 STR *tmpstr = Str_new(85,0);
969 str_nset(tmpstr, s, t - s);
970 astore(array, line++, tmpstr);
975 /* this routine is in perl.c by virtue of being sort of an alternate main() */
978 do_eval(str,optype,stash,savecmd,gimme,arglast)
986 STR **st = stack->ary_array;
988 CMD *myroot = Nullcmd;
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];
1005 tmps_base = tmps_max;
1006 if (curstash != stash) {
1007 (void)savehptr(&curstash);
1010 str_set(stab_val(stabent("@",TRUE)),"");
1011 if (curcmd->c_line == 0) /* don't debug debugger... */
1013 curcmd = &compiling;
1014 if (optype == O_EVAL) { /* normal eval */
1015 curcmd->c_filestab = fstab("(eval)");
1017 str_sset(linestr,str);
1018 str_cat(linestr,";\n;\n"); /* be kind to them */
1020 savelines(stab_xarray(curcmd->c_filestab), linestr);
1023 if (last_root && !in_eval) {
1024 Safefree(last_eval);
1026 cmd_free(last_root);
1027 last_root = Nullcmd;
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)) {
1034 tmps_base = oldtmps_base;
1035 st[++sp] = &str_yes;
1039 tmpfilename = savestr(specfilename);
1040 if (*tmpfilename == '/' ||
1041 (*tmpfilename == '.' &&
1042 (tmpfilename[1] == '/' ||
1043 (tmpfilename[1] == '.' && tmpfilename[2] == '/'))))
1045 rsfp = fopen(tmpfilename,"r");
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");
1056 if (*s == '.' && s[1] == '/')
1058 Safefree(tmpfilename);
1059 tmpfilename = savestr(s);
1064 curcmd->c_filestab = fstab(tmpfilename);
1065 Safefree(tmpfilename);
1066 tmpfilename = Nullch;
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);
1078 if (gimme != G_ARRAY)
1079 st[++sp] = &str_undef;
1086 oldoldbufptr = oldbufptr = bufptr = str_get(linestr);
1087 bufend = bufptr + linestr->str_cur;
1088 if (++loop_ptr >= loop_max) {
1090 Renew(loop_stack, loop_max, struct loop);
1092 loop_stack[loop_ptr].loop_label = "_EVAL_";
1093 loop_stack[loop_ptr].loop_sp = sp;
1096 deb("(Pushing label #%d _EVAL_)\n", loop_ptr);
1099 eval_root = Nullcmd;
1100 if (setjmp(loop_stack[loop_ptr].loop_env)) {
1107 retval |= error_count;
1109 else if (last_root && last_elen == bufend - bufptr
1110 && *bufptr == *last_eval && !bcmp(bufptr,last_eval,last_elen)){
1112 eval_root = last_root; /* no point in reparsing */
1114 else if (in_eval == 1 && !savecmd) {
1116 Safefree(last_eval);
1118 cmd_free(last_root);
1120 last_root = Nullcmd;
1121 last_elen = bufend - bufptr;
1122 last_eval = nsavestr(bufptr, last_elen);
1124 retval |= error_count;
1126 last_root = eval_root;
1128 Safefree(last_eval);
1135 myroot = eval_root; /* in case cmd_exec does another eval! */
1137 if (retval || error_count) {
1138 st = stack->ary_array;
1140 if (gimme != G_ARRAY)
1141 st[++sp] = &str_undef;
1143 #ifndef MANGLEDPARSE
1146 fprintf(stderr,"Freeing eval_root %lx\n",(long)eval_root);
1148 cmd_free(eval_root);
1150 /*SUPPRESS 29*/ /*SUPPRESS 30*/
1151 if ((CMD*)eval_root == last_root)
1152 last_root = Nullcmd;
1153 eval_root = myroot = Nullcmd;
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 */
1169 else if (in_eval != 1 && myroot != last_root)
1171 if (eval_root == myroot)
1172 eval_root = Nullcmd;
1179 char *tmps = loop_stack[loop_ptr].loop_label;
1180 deb("(Popping label #%d %s)\n",loop_ptr,
1185 tmps_base = oldtmps_base;
1187 lastspat = oldlspat;
1188 if (savestack->ary_fill > oldsave) /* let them use local() */
1189 restorelist(oldsave);
1191 if (optype != O_EVAL) {
1193 if (optype == O_REQUIRE)
1194 fatal("%s", str_get(stab_val(stabent("@",TRUE))));
1198 if (gimme == G_SCALAR ? str_true(st[sp]) : sp > arglast[0]) {
1199 (void)hstore(stab_hash(incstab), specfilename,
1200 strlen(specfilename), str_smake(stab_val(curcmd->c_filestab)),
1203 else if (optype == O_REQUIRE)
1204 fatal("%s did not return a true value", specfilename);
1212 do_try(cmd,gimme,arglast)
1217 STR **st = stack->ary_array;
1219 CMD * VOLATILE oldcurcmd = curcmd;
1220 VOLATILE int oldtmps_base = tmps_base;
1221 VOLATILE int oldsave = savestack->ary_fill;
1222 SPAT * VOLATILE oldspat = curspat;
1223 SPAT * VOLATILE oldlspat = lastspat;
1224 VOLATILE int sp = arglast[0];
1226 tmps_base = tmps_max;
1227 str_set(stab_val(stabent("@",TRUE)),"");
1229 if (++loop_ptr >= loop_max) {
1231 Renew(loop_stack, loop_max, struct loop);
1233 loop_stack[loop_ptr].loop_label = "_EVAL_";
1234 loop_stack[loop_ptr].loop_sp = sp;
1237 deb("(Pushing label #%d _EVAL_)\n", loop_ptr);
1240 if (setjmp(loop_stack[loop_ptr].loop_env)) {
1241 st = stack->ary_array;
1243 if (gimme != G_ARRAY)
1244 st[++sp] = &str_undef;
1247 sp = cmd_exec(cmd,gimme,sp);
1248 st = stack->ary_array;
1249 /* for (i = arglast[0] + 1; i <= sp; i++)
1250 st[i] = str_mortal(st[i]); not needed, I think */
1251 /* if we don't save result, free zaps it */
1257 char *tmps = loop_stack[loop_ptr].loop_label;
1258 deb("(Popping label #%d %s)\n",loop_ptr,
1263 tmps_base = oldtmps_base;
1265 lastspat = oldlspat;
1267 if (savestack->ary_fill > oldsave) /* let them use local() */
1268 restorelist(oldsave);
1273 /* This routine handles any switches that can be given during run */
1283 nrschar = scanoct(s, 4, &numlen);
1284 nrs = nsavestr("\n",1);
1286 if (nrschar > 0377) {
1290 else if (!nrschar && numlen >= 2) {
1306 if (euid != uid || egid != gid)
1307 fatal("No -d allowed in setuid scripts");
1315 if (euid != uid || egid != gid)
1316 fatal("No -D allowed in setuid scripts");
1318 debug = atoi(s+1) | 32768;
1320 warn("Recompile perl with -DDEBUGGING to use -D switch\n");
1323 for (s++; isDIGIT(*s); s++) ;
1326 inplace = savestr(s+1);
1328 for (s = inplace; *s && !isSPACE(*s); s++) ;
1333 if (euid != uid || egid != gid)
1334 fatal("No -I allowed in setuid scripts");
1337 (void)apush(stab_array(incstab),str_make(s,0));
1340 fatal("No space allowed after -I");
1346 ors = savestr("\n");
1348 *ors = scanoct(s, 3 + (*s == '0'), &numlen);
1352 ors = nsavestr(nrs,nrslen);
1373 fputs("\nThis is perl, version 4.0\n\n",stdout);
1374 fputs(rcsid,stdout);
1375 fputs("\nCopyright (c) 1989, 1990, 1991, Larry Wall\n",stdout);
1377 fputs("MS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n",
1380 fputs("OS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n",
1385 fputs("atariST series port, ++jrb bammi@cadence.com\n", stdout);
1388 Perl may be copied only under the terms of either the Artistic License or the\n\
1389 GNU General Public License, which may be found in the Perl 4.0 source kit.\n",stdout);
1403 fatal("Switch meaningless after -x: -%s",s);
1408 /* compliments of Tom Christiansen */
1410 /* unexec() can be found in the Gnu emacs distribution */
1418 static char dumpname[BUFSIZ];
1419 static char perlpath[256];
1421 sprintf (dumpname, "%s.perldump", origfilename);
1422 sprintf (perlpath, "%s/perl", BIN);
1424 status = unexec(dumpname, perlpath, &etext, sbrk(0), 0);
1426 fprintf(stderr, "unexec of %s into %s failed!\n", perlpath, dumpname);
1430 abort(); /* nothing else to do */
1433 # define SIGABRT SIGILL
1436 # define SIGILL 6 /* blech */
1438 kill(getpid(),SIGABRT); /* for use with undump */
1439 #endif /* ! MSDOS */