1 char rcsid[] = "$RCSfile: perl.c,v $$Revision: 5.0 $$Date: 92/08/07 18:25:50 $\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.1 92/08/07 18:25:50 lwall
11 * Revision 4.0.1.7 92/06/08 14:50:39 lwall
12 * patch20: PERLLIB now supports multiple directories
13 * patch20: running taintperl explicitly now does checks even if $< == $>
14 * patch20: -e 'cmd' no longer fails silently if /tmp runs out of space
15 * patch20: perl -P now uses location of sed determined by Configure
16 * patch20: form feed for formats is now specifiable via $^L
17 * patch20: paragraph mode now skips extra newlines automatically
18 * patch20: oldeval "1 #comment" didn't work
19 * patch20: couldn't require . files
20 * patch20: semantic compilation errors didn't abort execution
22 * Revision 4.0.1.6 91/11/11 16:38:45 lwall
23 * patch19: default arg for shift was wrong after first subroutine definition
24 * patch19: op/regexp.t failed from missing arg to bcmp()
26 * Revision 4.0.1.5 91/11/05 18:03:32 lwall
27 * patch11: random cleanup
28 * patch11: $0 was being truncated at times
29 * patch11: cppstdin now installed outside of source directory
30 * patch11: -P didn't allow use of #elif or #undef
31 * patch11: prepared for ctype implementations that don't define isascii()
32 * patch11: added oldeval {}
33 * patch11: oldeval confused by string containing null
35 * Revision 4.0.1.4 91/06/10 01:23:07 lwall
36 * patch10: perl -v printed incorrect copyright notice
38 * Revision 4.0.1.3 91/06/07 11:40:18 lwall
39 * patch4: changed old $^P to $^X
41 * Revision 4.0.1.2 91/06/07 11:26:16 lwall
42 * patch4: new copyright notice
43 * patch4: added $^P variable to control calling of perldb routines
44 * patch4: added $^F variable to specify maximum system fd, default 2
45 * patch4: debugger lost track of lines in oldeval
47 * Revision 4.0.1.1 91/04/11 17:49:05 lwall
48 * patch1: fixed undefined environ problem
50 * Revision 4.0 91/03/20 01:37:44 lwall
60 #include "patchlevel.h"
68 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
74 static void incpush();
75 static void validate_suid();
76 static void find_beginning();
77 static void init_main_stash();
78 static void open_script();
79 static void init_debugger();
80 static void init_stack();
81 static void init_lexer();
82 static void init_context_stack();
83 static void init_predump_symbols();
84 static void init_postdump_symbols();
85 static void init_perllib();
90 Interpreter *sv_interp;
94 Zero(&junk, 1, Interpreter);
95 New(53, sv_interp, 1, Interpreter);
100 perl_construct( sv_interp )
101 register Interpreter *sv_interp;
103 if (!(curinterp = sv_interp))
106 Zero(sv_interp, 1, Interpreter);
108 /* Init the real globals? */
110 linestr = NEWSV(65,80);
112 SvREADONLY_on(&sv_undef);
116 SvREADONLY_on(&sv_no);
118 sv_setpv(&sv_yes,Yes);
120 SvREADONLY_on(&sv_yes);
124 * There is no way we can refer to them from Perl so close them to save
125 * space. The other alternative would be to provide STDAUX and STDPRN
128 (void)fclose(stdaux);
129 (void)fclose(stdprn);
158 euid = (int)geteuid();
160 egid = (int)getegid();
161 sprintf(patchlevel,"%3.3s%2.2d", index(rcsid,'4'), PATCHLEVEL);
163 (void)sprintf(index(rcsid,'#'), "%d\n", PATCHLEVEL);
165 fdpid = newAV(); /* for remembering popen pids by fd */
166 pidstatus = newHV(COEFFSIZE);/* for remembering status of dead pids */
170 if (uid == euid && gid == egid)
171 taintanyway = TRUE; /* running taintperl explicitly */
178 perl_destruct(sv_interp)
179 register Interpreter *sv_interp;
181 if (!(curinterp = sv_interp))
195 Interpreter *sv_interp;
197 if (!(curinterp = sv_interp))
203 perl_parse(sv_interp, argc, argv, env)
204 Interpreter *sv_interp;
206 register char **argv;
213 bool dosearch = FALSE;
216 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
219 fatal("suidperl is no longer needed since the kernel can now execute\n\
220 setuid perl scripts securely.\n");
224 if (!(curinterp = sv_interp))
236 origenviron = environ;
238 switch (setjmp(top_env)) {
242 return(statusvalue); /* my_exit() was called */
244 fprintf(stderr, "panic: top_env\n");
249 origfilename = savestr(argv[0]);
251 cxstack_ix = -1; /* start label stack again */
254 sv_setpvn(linestr,"",0);
255 sv = newSVpv("",0); /* first used for -I flags */
257 for (argc--,argv++; argc > 0; argc--,argv++) {
258 if (argv[0][0] != '-' || !argv[0][1])
262 validarg = " PHOOEY ";
283 if (s = moreswitches(s))
289 if (euid != uid || egid != gid)
290 fatal("No -e allowed in setuid scripts");
293 e_tmpname = savestr(TMPPATH);
294 (void)mktemp(e_tmpname);
296 fatal("Can't mktemp()");
297 e_fp = fopen(e_tmpname,"w");
299 fatal("Cannot open temporary file");
305 (void)putc('\n', e_fp);
309 if (euid != uid || egid != gid)
310 fatal("No -I allowed in setuid scripts");
316 (void)av_push(GvAVn(incgv),newSVpv(s,0));
319 (void)av_push(GvAVn(incgv),newSVpv(argv[1],0));
320 sv_catpv(sv,argv[1]);
327 if (euid != uid || egid != gid)
328 fatal("No -P allowed in setuid scripts");
335 if (euid != uid || egid != gid)
336 fatal("No -S allowed in setuid scripts");
353 fatal("Unrecognized switch: -%s",s);
357 scriptname = argv[0];
359 if (fflush(e_fp) || ferror(e_fp) || fclose(e_fp))
360 fatal("Can't write to temp file for -e: %s", strerror(errno));
362 scriptname = e_tmpname;
364 else if (scriptname == Nullch) {
366 if ( isatty(fileno(stdin)) )
374 open_script(scriptname,dosearch,sv);
376 sv_free(sv); /* free -I directories */
379 validate_suid(validarg);
389 av_push(comppad, Nullsv);
390 curpad = AvARRAY(comppad);
397 /* now parse the script */
400 if (yyparse() || error_count) {
402 fatal("%s had compilation errors.\n", origfilename);
404 fatal("Execution of %s aborted due to compilation errors.\n",
408 curcop->cop_line = 0;
413 (void)UNLINK(e_tmpname);
416 init_context_stack();
418 init_predump_symbols();
423 just_doit: /* come here if running an undumped a.out */
424 init_postdump_symbols(argc,argv,env);
430 Interpreter *sv_interp;
432 if (!(curinterp = sv_interp))
434 switch (setjmp(top_env)) {
436 cxstack_ix = -1; /* start context stack again */
441 GV *gv = gv_fetchpv("END", FALSE);
443 if (gv && GvCV(gv)) {
444 if (!setjmp(top_env))
445 perl_callback("END", 0, G_SCALAR, 0, 0);
447 return(statusvalue); /* my_exit() was called */
451 fprintf(stderr, "panic: restartop\n");
454 if (stack != mainstack) {
456 SWITCHSTACK(stack, mainstack);
463 DEBUG(fprintf(stderr,"\nEXECUTING...\n\n"));
466 fprintf(stderr,"%s syntax OK\n", origfilename);
478 else if (main_start) {
483 fatal("panic: perl_run");
492 statusvalue = (unsigned short)(status & 0xffff);
496 /* Be sure to refetch the stack pointer after calling these routines. */
499 perl_callback(subname, sp, gimme, hasargs, numargs)
501 I32 sp; /* stack pointer after args are pushed */
502 I32 gimme; /* called in array or scalar context */
503 I32 hasargs; /* whether to create a @_ array for routine */
504 I32 numargs; /* how many args are pushed on the stack */
506 BINOP myop; /* fake syntax tree node */
510 stack_base = AvARRAY(stack);
511 stack_sp = stack_base + sp - numargs;
513 pp_pushmark(); /* doesn't look at op, actually, except to return */
514 *stack_sp = (SV*)gv_fetchpv(subname, FALSE);
517 myop.op_last = hasargs ? (OP*)&myop : Nullop;
518 myop.op_next = Nullop;
523 return stack_sp - stack_base;
527 perl_callv(subname, sp, gimme, argv)
529 register I32 sp; /* current stack pointer */
530 I32 gimme; /* called in array or scalar context */
531 register char **argv; /* null terminated arg list, NULL for no arglist */
533 register I32 items = 0;
534 I32 hasargs = (argv != 0);
536 av_store(stack, ++sp, Nullsv); /* reserve spot for 1st return arg */
539 av_store(stack, ++sp, sv_2mortal(newSVpv(*argv,0)));
544 return perl_callback(subname, sp, gimme, hasargs, items);
554 while (*sym = *list++)
555 magicname(sym, sym, 1);
559 magicname(sym,name,namlen)
566 if (gv = gv_fetchpv(sym,allgvs))
567 sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
571 #define PERLLIB_SEP ';'
573 #define PERLLIB_SEP ':'
585 /* Break at all separators */
587 /* First, skip any consecutive separators */
588 while ( *p == PERLLIB_SEP ) {
589 /* Uncomment the next line for PATH semantics */
590 /* (void)av_push(GvAVn(incgv), newSVpv(".", 1)); */
593 if ( (s = index(p, PERLLIB_SEP)) != Nullch ) {
594 (void)av_push(GvAVn(incgv), newSVpv(p, (I32)(s - p)));
597 (void)av_push(GvAVn(incgv), newSVpv(p, 0));
603 /* This routine handles any switches that can be given during run */
613 nrschar = scan_oct(s, 4, &numlen);
614 nrs = nsavestr("\n",1);
616 if (nrschar > 0377) {
620 else if (!nrschar && numlen >= 2) {
636 if (euid != uid || egid != gid)
637 fatal("No -d allowed in setuid scripts");
645 if (euid != uid || egid != gid)
646 fatal("No -D allowed in setuid scripts");
649 static char debopts[] = "psltocPmfrxuLHX";
652 for (s++; *s && (d = index(debopts,*s)); s++)
653 debug |= 1 << (d - debopts);
657 for (s++; isDIGIT(*s); s++) ;
661 warn("Recompile perl with -DDEBUGGING to use -D switch\n");
662 for (s++; isDIGIT(*s); s++) ;
669 inplace = savestr(s+1);
671 for (s = inplace; *s && !isSPACE(*s); s++) ;
676 if (euid != uid || egid != gid)
677 fatal("No -I allowed in setuid scripts");
680 (void)av_push(GvAVn(incgv),newSVpv(s,0));
683 fatal("No space allowed after -I");
691 *ors = scan_oct(s, 3 + (*s == '0'), &numlen);
695 ors = nsavestr(nrs,nrslen);
709 if (euid != uid || egid != gid)
710 fatal("No -s allowed in setuid scripts");
724 fputs("\nThis is perl, version 5.0, Alpha 2 (unsupported)\n\n",stdout);
726 fputs("\nCopyright (c) 1989, 1990, 1991, 1992, 1993 Larry Wall\n",stdout);
728 fputs("MS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n",
731 fputs("OS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n",
736 fputs("atariST series port, ++jrb bammi@cadence.com\n", stdout);
739 Perl may be copied only under the terms of either the Artistic License or the\n\
740 GNU General Public License, which may be found in the Perl 5.0 source kit.\n",stdout);
750 if (s[1] == '-') /* Additional switches on #! line. */
758 fatal("Switch meaningless after -x: -%s",s);
763 /* compliments of Tom Christiansen */
765 /* unexec() can be found in the Gnu emacs distribution */
774 sprintf (buf, "%s.perldump", origfilename);
775 sprintf (tokenbuf, "%s/perl", BIN);
777 status = unexec(buf, tokenbuf, &etext, sbrk(0), 0);
779 fprintf(stderr, "unexec of %s into %s failed!\n", tokenbuf, buf);
782 ABORT(); /* for use with undump */
789 curstash = defstash = newHV(0);
790 curstname = newSVpv("main",4);
791 GvHV(gv_fetchpv("_main",TRUE)) = defstash;
792 HvNAME(defstash) = "main";
793 incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE)));
795 defgv = gv_fetchpv("_",TRUE);
799 open_script(scriptname,dosearch,sv)
804 char *xfound = Nullch;
805 char *xfailed = Nullch;
809 if (dosearch && !index(scriptname, '/') && (s = getenv("PATH"))) {
811 bufend = s + strlen(s);
814 s = cpytill(tokenbuf,s,bufend,':',&len);
817 for (len = 0; *s && *s != ',' && *s != ';'; tokenbuf[len++] = *s++);
818 tokenbuf[len] = '\0';
820 for (len = 0; *s && *s != ';'; tokenbuf[len++] = *s++);
821 tokenbuf[len] = '\0';
827 if (len && tokenbuf[len-1] != '/')
830 if (len && ((tokenbuf[len-1] != '\\') && (tokenbuf[len-1] != '/')))
832 if (len && tokenbuf[len-1] != '\\')
835 (void)strcat(tokenbuf+len,"/");
836 (void)strcat(tokenbuf+len,scriptname);
837 DEBUG_p(fprintf(stderr,"Looking for %s\n",tokenbuf));
838 if (stat(tokenbuf,&statbuf) < 0) /* not there? */
840 if (S_ISREG(statbuf.st_mode)
841 && cando(S_IRUSR,TRUE,&statbuf) && cando(S_IXUSR,TRUE,&statbuf)) {
842 xfound = tokenbuf; /* bingo! */
846 xfailed = savestr(tokenbuf);
849 fatal("Can't execute %s", xfailed ? xfailed : scriptname );
855 origfilename = savestr(scriptname);
856 curcop->cop_filegv = gv_fetchfile(origfilename);
857 if (strEQ(origfilename,"-"))
860 char *cpp = CPPSTDIN;
862 if (strEQ(cpp,"cppstdin"))
863 sprintf(tokenbuf, "%s/%s", SCRIPTDIR, cpp);
865 sprintf(tokenbuf, "%s", cpp);
867 sv_catpv(sv,PRIVLIB);
869 (void)sprintf(buf, "\
870 sed %s -e \"/^[^#]/b\" \
871 -e \"/^#[ ]*include[ ]/b\" \
872 -e \"/^#[ ]*define[ ]/b\" \
873 -e \"/^#[ ]*if[ ]/b\" \
874 -e \"/^#[ ]*ifdef[ ]/b\" \
875 -e \"/^#[ ]*ifndef[ ]/b\" \
876 -e \"/^#[ ]*else/b\" \
877 -e \"/^#[ ]*elif[ ]/b\" \
878 -e \"/^#[ ]*undef[ ]/b\" \
879 -e \"/^#[ ]*endif/b\" \
882 (doextract ? "-e \"1,/^#/d\n\"" : ""),
884 (void)sprintf(buf, "\
885 %s %s -e '/^[^#]/b' \
886 -e '/^#[ ]*include[ ]/b' \
887 -e '/^#[ ]*define[ ]/b' \
888 -e '/^#[ ]*if[ ]/b' \
889 -e '/^#[ ]*ifdef[ ]/b' \
890 -e '/^#[ ]*ifndef[ ]/b' \
892 -e '/^#[ ]*elif[ ]/b' \
893 -e '/^#[ ]*undef[ ]/b' \
894 -e '/^#[ ]*endif/b' \
902 (doextract ? "-e '1,/^#/d\n'" : ""),
904 scriptname, tokenbuf, SvPVn(sv), CPPMINUS);
905 DEBUG_P(fprintf(stderr, "%s\n", buf));
907 #ifdef IAMSUID /* actually, this is caught earlier */
908 if (euid != uid && !euid) { /* if running suidperl */
910 (void)seteuid(uid); /* musn't stay setuid root */
913 (void)setreuid(-1, uid);
918 if (geteuid() != uid)
919 fatal("Can't do seteuid!\n");
922 rsfp = my_popen(buf,"r");
924 else if (!*scriptname) {
926 if (euid != uid || egid != gid)
927 fatal("Can't take set-id script from stdin");
932 rsfp = fopen(scriptname,"r");
933 if ((FILE*)rsfp == Nullfp) {
935 #ifndef IAMSUID /* in case script is not readable before setuid */
936 if (euid && stat(SvPV(GvSV(curcop->cop_filegv)),&statbuf) >= 0 &&
937 statbuf.st_mode & (S_ISUID|S_ISGID)) {
938 (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel);
939 execv(buf, origargv); /* try again */
940 fatal("Can't do setuid\n");
944 fatal("Can't open perl script \"%s\": %s\n",
945 SvPV(GvSV(curcop->cop_filegv)), strerror(errno));
950 validate_suid(validarg)
953 /* do we need to emulate setuid on scripts? */
955 /* This code is for those BSD systems that have setuid #! scripts disabled
956 * in the kernel because of a security problem. Merely defining DOSUID
957 * in perl will not fix that problem, but if you have disabled setuid
958 * scripts in the kernel, this will attempt to emulate setuid and setgid
959 * on scripts that have those now-otherwise-useless bits set. The setuid
960 * root version must be called suidperl or sperlN.NNN. If regular perl
961 * discovers that it has opened a setuid script, it calls suidperl with
962 * the same argv that it had. If suidperl finds that the script it has
963 * just opened is NOT setuid root, it sets the effective uid back to the
964 * uid. We don't just make perl setuid root because that loses the
965 * effective uid we had before invoking perl, if it was different from the
968 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
969 * be defined in suidperl only. suidperl must be setuid root. The
970 * Configure script will set this up for you if you want it.
972 * There is also the possibility of have a script which is running
973 * set-id due to a C wrapper. We want to do the TAINT checks
974 * on these set-id scripts, but don't want to have the overhead of
975 * them in normal perl, and can't use suidperl because it will lose
976 * the effective uid info, so we have an additional non-setuid root
977 * version called taintperl or tperlN.NNN that just does the TAINT checks.
981 if (fstat(fileno(rsfp),&statbuf) < 0) /* normal stat is insecure */
982 fatal("Can't stat script \"%s\"",origfilename);
983 if (statbuf.st_mode & (S_ISUID|S_ISGID)) {
988 /* On this access check to make sure the directories are readable,
989 * there is actually a small window that the user could use to make
990 * filename point to an accessible directory. So there is a faint
991 * chance that someone could execute a setuid script down in a
992 * non-accessible directory. I don't know what to do about that.
993 * But I don't think it's too important. The manual lies when
994 * it says access() is useful in setuid programs.
996 if (access(SvPV(GvSV(curcop->cop_filegv)),1)) /*double check*/
997 fatal("Permission denied");
999 /* If we can swap euid and uid, then we can determine access rights
1000 * with a simple stat of the file, and then compare device and
1001 * inode to make sure we did stat() on the same file we opened.
1002 * Then we just have to make sure he or she can execute it.
1005 struct stat tmpstatbuf;
1007 if (setreuid(euid,uid) < 0 || getuid() != euid || geteuid() != uid)
1008 fatal("Can't swap uid and euid"); /* really paranoid */
1009 if (stat(SvPV(GvSV(curcop->cop_filegv)),&tmpstatbuf) < 0)
1010 fatal("Permission denied"); /* testing full pathname here */
1011 if (tmpstatbuf.st_dev != statbuf.st_dev ||
1012 tmpstatbuf.st_ino != statbuf.st_ino) {
1014 if (rsfp = my_popen("/bin/mail root","w")) { /* heh, heh */
1016 "User %d tried to run dev %d ino %d in place of dev %d ino %d!\n\
1017 (Filename of set-id script was %s, uid %d gid %d.)\n\nSincerely,\nperl\n",
1018 uid,tmpstatbuf.st_dev, tmpstatbuf.st_ino,
1019 statbuf.st_dev, statbuf.st_ino,
1020 SvPV(GvSV(curcop->cop_filegv)),
1021 statbuf.st_uid, statbuf.st_gid);
1022 (void)my_pclose(rsfp);
1024 fatal("Permission denied\n");
1026 if (setreuid(uid,euid) < 0 || getuid() != uid || geteuid() != euid)
1027 fatal("Can't reswap uid and euid");
1028 if (!cando(S_IXUSR,FALSE,&statbuf)) /* can real uid exec? */
1029 fatal("Permission denied\n");
1031 #endif /* HAS_SETREUID */
1032 #endif /* IAMSUID */
1034 if (!S_ISREG(statbuf.st_mode))
1035 fatal("Permission denied");
1036 if (statbuf.st_mode & S_IWOTH)
1037 fatal("Setuid/gid script is writable by world");
1038 doswitches = FALSE; /* -s is insecure in suid */
1040 if (fgets(tokenbuf,sizeof tokenbuf, rsfp) == Nullch ||
1041 strnNE(tokenbuf,"#!",2) ) /* required even on Sys V */
1042 fatal("No #! line");
1045 while (!isSPACE(*s)) s++;
1046 if (strnNE(s-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
1047 fatal("Not a perl script");
1048 while (*s == ' ' || *s == '\t') s++;
1050 * #! arg must be what we saw above. They can invoke it by
1051 * mentioning suidperl explicitly, but they may not add any strange
1052 * arguments beyond what #! says if they do invoke suidperl that way.
1054 len = strlen(validarg);
1055 if (strEQ(validarg," PHOOEY ") ||
1056 strnNE(s,validarg,len) || !isSPACE(s[len]))
1057 fatal("Args must match #! line");
1060 if (euid != uid && (statbuf.st_mode & S_ISUID) &&
1061 euid == statbuf.st_uid)
1063 fatal("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
1064 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
1065 #endif /* IAMSUID */
1067 if (euid) { /* oops, we're not the setuid root perl */
1070 (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel);
1071 execv(buf, origargv); /* try again */
1073 fatal("Can't do setuid\n");
1076 if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid) {
1078 (void)setegid(statbuf.st_gid);
1081 (void)setregid((GIDTYPE)-1,statbuf.st_gid);
1083 setgid(statbuf.st_gid);
1086 if (getegid() != statbuf.st_gid)
1087 fatal("Can't do setegid!\n");
1089 if (statbuf.st_mode & S_ISUID) {
1090 if (statbuf.st_uid != euid)
1092 (void)seteuid(statbuf.st_uid); /* all that for this */
1095 (void)setreuid((UIDTYPE)-1,statbuf.st_uid);
1097 setuid(statbuf.st_uid);
1100 if (geteuid() != statbuf.st_uid)
1101 fatal("Can't do seteuid!\n");
1103 else if (uid) { /* oops, mustn't run as root */
1105 (void)seteuid((UIDTYPE)uid);
1108 (void)setreuid((UIDTYPE)-1,(UIDTYPE)uid);
1110 setuid((UIDTYPE)uid);
1113 if (geteuid() != uid)
1114 fatal("Can't do seteuid!\n");
1116 uid = (int)getuid();
1117 euid = (int)geteuid();
1118 gid = (int)getgid();
1119 egid = (int)getegid();
1120 if (!cando(S_IXUSR,TRUE,&statbuf))
1121 fatal("Permission denied\n"); /* they can't do this */
1124 else if (preprocess)
1125 fatal("-P not allowed for setuid/setgid script\n");
1127 fatal("Script is not setuid/setgid in suidperl\n");
1129 #ifndef TAINT /* we aren't taintperl or suidperl */
1130 /* script has a wrapper--can't run suidperl or we lose euid */
1131 else if (euid != uid || egid != gid) {
1133 (void)sprintf(buf, "%s/tperl%s", BIN, patchlevel);
1134 execv(buf, origargv); /* try again */
1135 fatal("Can't run setuid script with taint checks");
1138 #endif /* IAMSUID */
1140 #ifndef TAINT /* we aren't taintperl or suidperl */
1141 if (euid != uid || egid != gid) { /* (suidperl doesn't exist, in fact) */
1142 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
1143 fstat(fileno(rsfp),&statbuf); /* may be either wrapped or real suid */
1144 if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
1146 (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
1149 fatal("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
1150 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
1151 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
1152 /* not set-id, must be wrapped */
1154 (void)sprintf(buf, "%s/tperl%s", BIN, patchlevel);
1155 execv(buf, origargv); /* try again */
1156 fatal("Can't run setuid script with taint checks");
1165 #if !defined(IAMSUID) && !defined(TAINT)
1168 /* skip forward in input to the real script? */
1171 if ((s = sv_gets(linestr, rsfp, 0)) == Nullch)
1172 fatal("No Perl script found in input\n");
1173 if (*s == '#' && s[1] == '!' && instr(s,"perl")) {
1174 ungetc('\n',rsfp); /* to keep line count right */
1176 if (s = instr(s,"perl -")) {
1179 while (s = moreswitches(s)) ;
1181 if (cddir && chdir(cddir) < 0)
1182 fatal("Can't chdir to %s",cddir);
1185 #endif /* !defined(IAMSUID) && !defined(TAINT) */
1193 debstash = newHV(0);
1194 GvHV(gv_fetchpv("_DB",TRUE)) = debstash;
1195 curstash = debstash;
1196 dbargs = GvAV(gv_AVadd((tmpgv = gv_fetchpv("args",TRUE))));
1199 DBgv = gv_fetchpv("DB",TRUE);
1201 DBline = gv_fetchpv("dbline",TRUE);
1203 DBsub = gv_HVadd(tmpgv = gv_fetchpv("sub",TRUE));
1205 DBsingle = GvSV((tmpgv = gv_fetchpv("single",TRUE)));
1207 DBtrace = GvSV((tmpgv = gv_fetchpv("trace",TRUE)));
1209 DBsignal = GvSV((tmpgv = gv_fetchpv("signal",TRUE)));
1211 curstash = defstash;
1218 mainstack = stack; /* remember in case we switch stacks */
1219 AvREAL_off(stack); /* not a real array */
1220 av_fill(stack,127); av_fill(stack,-1); /* preextend stack */
1222 stack_base = AvARRAY(stack);
1223 stack_sp = stack_base;
1224 stack_max = stack_base + 128;
1226 New(54,markstack,64,int);
1227 markstack_ptr = markstack;
1228 markstack_max = markstack + 64;
1230 New(54,scopestack,32,int);
1232 scopestack_max = 32;
1234 New(54,savestack,128,ANY);
1236 savestack_max = 128;
1238 New(54,retstack,16,OP*);
1246 bufend = bufptr = SvPVn(linestr);
1247 subname = newSVpv("main",4);
1251 init_context_stack()
1253 New(50,cxstack,128,CONTEXT);
1255 New(51,debname,128,char);
1256 New(52,debdelim,128,char);
1261 init_predump_symbols()
1266 /* initialize everything that won't change if we undump */
1268 if (siggv = gv_fetchpv("SIG",allgvs)) {
1272 hv_magic(hv, siggv, 'S');
1274 /* initialize signal stack */
1275 signalstack = newAV();
1276 av_store(signalstack, 32, Nullsv);
1277 av_clear(signalstack);
1278 AvREAL_off(signalstack);
1281 magicalize("!#?^~=-%.+&*()<>,\\/[|`':\004\t\020\024\027\006");
1282 userinit(); /* in case linked C routines want magical variables */
1284 ampergv = gv_fetchpv("&",allgvs);
1285 leftgv = gv_fetchpv("`",allgvs);
1286 rightgv = gv_fetchpv("'",allgvs);
1287 sawampersand = (ampergv || leftgv || rightgv);
1288 if (tmpgv = gv_fetchpv(":",allgvs))
1289 sv_setpv(GvSV(tmpgv),chopset);
1291 /* these aren't necessarily magical */
1292 if (tmpgv = gv_fetchpv("\014",allgvs)) {
1293 sv_setpv(GvSV(tmpgv),"\f");
1294 formfeed = GvSV(tmpgv);
1296 if (tmpgv = gv_fetchpv(";",allgvs))
1297 sv_setpv(GvSV(tmpgv),"\034");
1298 if (tmpgv = gv_fetchpv("]",allgvs)) {
1300 sv_upgrade(sv, SVt_PVNV);
1302 SvNV(sv) = atof(patchlevel);
1305 sv_setpvn(GvSV(gv_fetchpv("\"", TRUE)), " ", 1);
1307 stdingv = gv_fetchpv("STDIN",TRUE);
1308 SvMULTI_on(stdingv);
1310 GvIO(stdingv) = newIO();
1311 GvIO(stdingv)->ifp = stdin;
1312 tmpgv = gv_fetchpv("stdin",TRUE);
1313 GvIO(tmpgv) = GvIO(stdingv);
1316 tmpgv = gv_fetchpv("STDOUT",TRUE);
1319 GvIO(tmpgv) = newIO();
1320 GvIO(tmpgv)->ofp = GvIO(tmpgv)->ifp = stdout;
1322 tmpgv = gv_fetchpv("stdout",TRUE);
1323 GvIO(tmpgv) = GvIO(defoutgv);
1326 curoutgv = gv_fetchpv("STDERR",TRUE);
1327 SvMULTI_on(curoutgv);
1328 if (!GvIO(curoutgv))
1329 GvIO(curoutgv) = newIO();
1330 GvIO(curoutgv)->ofp = GvIO(curoutgv)->ifp = stderr;
1331 tmpgv = gv_fetchpv("stderr",TRUE);
1332 GvIO(tmpgv) = GvIO(curoutgv);
1334 curoutgv = defoutgv; /* switch back to STDOUT */
1336 statname = NEWSV(66,0); /* last filename we did stat on */
1338 /* now that script is parsed, we can modify record separator */
1343 rspara = (nrslen == 2);
1344 sv_setpvn(GvSV(gv_fetchpv("/", TRUE)), rs, rslen);
1348 init_postdump_symbols(argc,argv,env)
1350 register char **argv;
1351 register char **env;
1357 argc--,argv++; /* skip name of script */
1359 for (; argc > 0 && **argv == '-'; argc--,argv++) {
1362 if (argv[0][1] == '-') {
1366 if (s = index(argv[0], '=')) {
1368 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE)),s);
1371 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE)),1);
1374 toptarget = NEWSV(0,0);
1375 sv_upgrade(toptarget, SVt_PVFM);
1376 sv_setpvn(toptarget, "", 0);
1377 bodytarget = NEWSV(0,0);
1378 sv_upgrade(bodytarget, SVt_PVFM);
1379 sv_setpvn(bodytarget, "", 0);
1380 formtarget = bodytarget;
1385 if (tmpgv = gv_fetchpv("0",allgvs)) {
1386 sv_setpv(GvSV(tmpgv),origfilename);
1387 magicname("0", "0", 1);
1389 if (tmpgv = gv_fetchpv("\024",allgvs))
1391 if (tmpgv = gv_fetchpv("\030",allgvs))
1392 sv_setpv(GvSV(tmpgv),origargv[0]);
1393 if (argvgv = gv_fetchpv("ARGV",allgvs)) {
1395 (void)gv_AVadd(argvgv);
1396 av_clear(GvAVn(argvgv));
1397 for (; argc > 0; argc--,argv++) {
1398 (void)av_push(GvAVn(argvgv),newSVpv(argv[0],0));
1402 (void) gv_fetchpv("ENV",TRUE); /* must test PATH and IFS */
1404 if (envgv = gv_fetchpv("ENV",allgvs)) {
1408 hv_clear(hv, FALSE);
1409 hv_magic(hv, envgv, 'E');
1411 environ[0] = Nullch;
1412 for (; *env; env++) {
1413 if (!(s = index(*env,'=')))
1416 sv = newSVpv(s--,0);
1417 (void)hv_store(hv, *env, s - *env, sv, 0);
1424 if (tmpgv = gv_fetchpv("$",allgvs))
1425 sv_setiv(GvSV(tmpgv),(I32)getpid());
1436 #ifndef TAINT /* Can't allow arbitrary PERLLIB in setuid script */
1437 incpush(getenv("PERLLIB"));
1441 #define PRIVLIB "/usr/local/lib/perl"
1444 (void)av_push(GvAVn(incgv),newSVpv(".",1));