2 * Copyright (c) 1991, 1992, 1993, 1994 Larry Wall
4 * You may distribute under the terms of either the GNU General Public
5 * License or the Artistic License, as specified in the README file.
8 * Revision 4.1 92/08/07 18:25:50 lwall
10 * Revision 4.0.1.7 92/06/08 14:50:39 lwall
11 * patch20: PERLLIB now supports multiple directories
12 * patch20: running taintperl explicitly now does checks even if $< == $>
13 * patch20: -e 'cmd' no longer fails silently if /tmp runs out of space
14 * patch20: perl -P now uses location of sed determined by Configure
15 * patch20: form feed for formats is now specifiable via $^L
16 * patch20: paragraph mode now skips extra newlines automatically
17 * patch20: oldeval "1 #comment" didn't work
18 * patch20: couldn't require . files
19 * patch20: semantic compilation errors didn't abort execution
21 * Revision 4.0.1.6 91/11/11 16:38:45 lwall
22 * patch19: default arg for shift was wrong after first subroutine definition
23 * patch19: op/regexp.t failed from missing arg to bcmp()
25 * Revision 4.0.1.5 91/11/05 18:03:32 lwall
26 * patch11: random cleanup
27 * patch11: $0 was being truncated at times
28 * patch11: cppstdin now installed outside of source directory
29 * patch11: -P didn't allow use of #elif or #undef
30 * patch11: prepared for ctype implementations that don't define isascii()
31 * patch11: added oldeval {}
32 * patch11: oldeval confused by string containing null
34 * Revision 4.0.1.4 91/06/10 01:23:07 lwall
35 * patch10: perl -v printed incorrect copyright notice
37 * Revision 4.0.1.3 91/06/07 11:40:18 lwall
38 * patch4: changed old $^P to $^X
40 * Revision 4.0.1.2 91/06/07 11:26:16 lwall
41 * patch4: new copyright notice
42 * patch4: added $^P variable to control calling of perldb routines
43 * patch4: added $^F variable to specify maximum system fd, default 2
44 * patch4: debugger lost track of lines in oldeval
46 * Revision 4.0.1.1 91/04/11 17:49:05 lwall
47 * patch1: fixed undefined environ problem
49 * Revision 4.0 91/03/20 01:37:44 lwall
59 #include "patchlevel.h"
61 char rcsid[] = "$RCSfile: perl.c,v $$Revision: 5.0 $$Date: 92/08/07 18:25:50 $\nPatch level: ###\n";
69 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
75 static void incpush();
76 static void validate_suid();
77 static void find_beginning();
78 static void init_main_stash();
79 static void open_script();
80 static void init_debugger();
81 static void init_stacks();
82 static void init_lexer();
83 static void init_predump_symbols();
84 static void init_postdump_symbols();
85 static void init_perllib();
90 PerlInterpreter *sv_interp;
94 /* Zero(&junk, 1, PerlInterpreter); */
95 New(53, sv_interp, 1, PerlInterpreter);
100 perl_construct( sv_interp )
101 register PerlInterpreter *sv_interp;
105 if (!(curinterp = sv_interp))
109 Zero(sv_interp, 1, PerlInterpreter);
112 /* Init the real globals? */
114 linestr = NEWSV(65,80);
115 sv_upgrade(linestr,SVt_PVIV);
117 SvREADONLY_on(&sv_undef);
121 SvREADONLY_on(&sv_no);
123 sv_setpv(&sv_yes,Yes);
125 SvREADONLY_on(&sv_yes);
129 * There is no way we can refer to them from Perl so close them to save
130 * space. The other alternative would be to provide STDAUX and STDPRN
133 (void)fclose(stdaux);
134 (void)fclose(stdprn);
159 euid = (int)geteuid();
161 egid = (int)getegid();
162 tainting = (euid != uid || egid != gid);
163 if (s = strchr(rcsid,'#')) {
164 (void)sprintf(s, "%d\n", PATCHLEVEL);
165 sprintf(patchlevel,"%3.3s%2.2d", strchr(rcsid,'5'), PATCHLEVEL);
168 fdpid = newAV(); /* for remembering popen pids by fd */
169 pidstatus = newHV();/* for remembering status of dead pids */
176 perl_destruct(sv_interp)
177 register PerlInterpreter *sv_interp;
181 if (!(curinterp = sv_interp))
187 /* The exit() function may do everything that needs doing. */
192 /* Not so lucky. We must account for everything. First the syntax tree. */
194 curpad = AvARRAY(comppad);
200 * Try to destruct global references. We do this first so that the
201 * destructors and destructees still exist. This code currently
202 * will break simple reference loops but may fail on more complicated
203 * ones. If so, the code below will clean up, but any destructors
204 * may fail to find what they're looking for.
210 /* Delete self-reference from main symbol table */
211 GvHV(gv_fetchpv("::_main",TRUE)) = 0;
212 --SvREFCNT(defstash);
214 /* Try to destruct main symbol table. May fail on reference loops. */
215 SvREFCNT_dec(defstash);
219 if (scopestack_ix != 0)
220 warn("Unbalanced scopes: %d more ENTERs than LEAVEs\n", scopestack_ix);
221 if (savestack_ix != 0)
222 warn("Unbalanced saves: %d more saves than restores\n", savestack_ix);
223 if (tmps_floor != -1)
224 warn("Unbalanced tmps: %d more allocs than frees\n", tmps_floor + 1);
225 if (cxstack_ix != -1)
226 warn("Unbalanced context: %d more PUSHes than POPs\n", cxstack_ix + 1);
229 /* Now absolutely destruct everything, somehow or other, loops or no. */
231 while (sv_count != 0 && sv_count != last_sv_count) {
232 last_sv_count = sv_count;
236 warn("Scalars leaked: %d\n", sv_count);
241 PerlInterpreter *sv_interp;
243 if (!(curinterp = sv_interp))
249 perl_parse(sv_interp, argc, argv, env)
250 PerlInterpreter *sv_interp;
252 register char **argv;
259 bool dosearch = FALSE;
262 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
265 croak("suidperl is no longer needed since the kernel can now execute\n\
266 setuid perl scripts securely.\n");
270 if (!(curinterp = sv_interp))
279 origenviron = environ;
281 switch (setjmp(top_env)) {
288 return(statusvalue); /* my_exit() was called */
290 fprintf(stderr, "panic: top_env\n");
296 /* Come here if running an undumped a.out. */
298 origfilename = savestr(argv[0]);
300 cxstack_ix = -1; /* start label stack again */
301 init_postdump_symbols(argc,argv,env);
305 sv_setpvn(linestr,"",0);
306 sv = newSVpv("",0); /* first used for -I flags */
309 for (argc--,argv++; argc > 0; argc--,argv++) {
310 if (argv[0][0] != '-' || !argv[0][1])
314 validarg = " PHOOEY ";
337 if (s = moreswitches(s))
342 if (euid != uid || egid != gid)
343 croak("No -e allowed in setuid scripts");
345 e_tmpname = savestr(TMPPATH);
346 (void)mktemp(e_tmpname);
348 croak("Can't mktemp()");
349 e_fp = fopen(e_tmpname,"w");
351 croak("Cannot open temporary file");
357 (void)putc('\n', e_fp);
365 (void)av_push(GvAVn(incgv),newSVpv(s,0));
368 (void)av_push(GvAVn(incgv),newSVpv(argv[1],0));
369 sv_catpv(sv,argv[1]);
396 croak("Unrecognized switch: -%s",s);
400 scriptname = argv[0];
402 if (fflush(e_fp) || ferror(e_fp) || fclose(e_fp))
403 croak("Can't write to temp file for -e: %s", Strerror(errno));
405 scriptname = e_tmpname;
407 else if (scriptname == Nullch) {
409 if ( isatty(fileno(stdin)) )
417 open_script(scriptname,dosearch,sv);
419 validate_suid(validarg);
429 av_push(comppad, Nullsv);
430 curpad = AvARRAY(comppad);
432 comppad_name = padname;
433 comppad_name_fill = 0;
434 min_intro_pending = 0;
437 perl_init_ext(); /* in case linked C routines want magical variables */
439 init_predump_symbols();
441 init_postdump_symbols(argc,argv,env);
445 /* now parse the script */
448 if (yyparse() || error_count) {
450 croak("%s had compilation errors.\n", origfilename);
452 croak("Execution of %s aborted due to compilation errors.\n",
456 curcop->cop_line = 0;
461 (void)UNLINK(e_tmpname);
464 /* now that script is parsed, we can modify record separator */
469 rspara = (nrslen == 2);
470 sv_setpvn(GvSV(gv_fetchpv("/", TRUE)), rs, rslen);
483 PerlInterpreter *sv_interp;
485 if (!(curinterp = sv_interp))
487 switch (setjmp(top_env)) {
489 cxstack_ix = -1; /* start context stack again */
496 return(statusvalue); /* my_exit() was called */
499 fprintf(stderr, "panic: restartop\n");
503 if (stack != mainstack) {
505 SWITCHSTACK(stack, mainstack);
512 DEBUG(fprintf(stderr,"\nEXECUTING...\n\n"));
515 fprintf(stderr,"%s syntax OK\n", origfilename);
527 else if (main_start) {
539 statusvalue = (unsigned short)(status & 0xffff);
543 /* Be sure to refetch the stack pointer after calling these routines. */
546 perl_callargv(subname, sp, gimme, argv)
548 register I32 sp; /* current stack pointer */
549 I32 gimme; /* TRUE if called in list context */
550 register char **argv; /* null terminated arg list, NULL for no arglist */
552 register I32 items = 0;
553 I32 hasargs = (argv != 0);
555 av_store(stack, ++sp, Nullsv); /* reserve spot for sub reference */
558 av_store(stack, ++sp, sv_2mortal(newSVpv(*argv,0)));
563 return perl_callpv(subname, sp, gimme, hasargs, items);
567 perl_callpv(subname, sp, gimme, hasargs, numargs)
569 I32 sp; /* stack pointer after args are pushed */
570 I32 gimme; /* TRUE if called in list context */
571 I32 hasargs; /* whether to create a @_ array for routine */
572 I32 numargs; /* how many args are pushed on the stack */
574 return perl_callsv((SV*)gv_fetchpv(subname, TRUE),
575 sp, gimme, hasargs, numargs);
578 /* May be called with any of a CV, a GV, or an SV containing the name. */
580 perl_callsv(sv, sp, gimme, hasargs, numargs)
582 I32 sp; /* stack pointer after args are pushed */
583 I32 gimme; /* TRUE if called in list context */
584 I32 hasargs; /* whether to create a @_ array for routine */
585 I32 numargs; /* how many args are pushed on the stack */
587 BINOP myop; /* fake syntax tree node */
592 stack_base = AvARRAY(stack);
593 stack_sp = stack_base + sp - numargs - 1;
596 pp_pushmark(); /* doesn't look at op, actually, except to return */
601 myop.op_flags = OPf_STACKED;
602 myop.op_last = (OP*)&myop;
604 myop.op_next = Nullop;
606 if (op = pp_entersubr())
610 return stack_sp - stack_base;
614 magicname(sym,name,namlen)
621 if (gv = gv_fetchpv(sym,TRUE))
622 sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
626 #define PERLLIB_SEP ';'
628 #define PERLLIB_SEP ':'
640 /* Break at all separators */
642 /* First, skip any consecutive separators */
643 while ( *p == PERLLIB_SEP ) {
644 /* Uncomment the next line for PATH semantics */
645 /* (void)av_push(GvAVn(incgv), newSVpv(".", 1)); */
648 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
649 (void)av_push(GvAVn(incgv), newSVpv(p, (I32)(s - p)));
652 (void)av_push(GvAVn(incgv), newSVpv(p, 0));
658 /* This routine handles any switches that can be given during run */
668 nrschar = scan_oct(s, 4, &numlen);
669 nrs = nsavestr("\n",1);
671 if (nrschar > 0377) {
675 else if (!nrschar && numlen >= 2) {
683 splitstr = savestr(s + 1);
703 static char debopts[] = "psltocPmfrxuLHXD";
706 for (s++; *s && (d = strchr(debopts,*s)); s++)
707 debug |= 1 << (d - debopts);
711 for (s++; isDIGIT(*s); s++) ;
715 warn("Recompile perl with -DDEBUGGING to use -D switch\n");
716 for (s++; isDIGIT(*s); s++) ;
723 inplace = savestr(s+1);
725 for (s = inplace; *s && !isSPACE(*s); s++) ;
731 (void)av_push(GvAVn(incgv),newSVpv(s,0));
734 croak("No space allowed after -I");
742 *ors = scan_oct(s, 3 + (*s == '0'), &numlen);
746 ors = nsavestr(nrs,nrslen);
776 fputs("\nThis is perl, version 5.0, Alpha 8 (unsupported)\n\n",stdout);
778 fputs("\nCopyright (c) 1989, 1990, 1991, 1992, 1993, 1994 Larry Wall\n",stdout);
780 fputs("MS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n",
783 fputs("OS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n",
788 fputs("atariST series port, ++jrb bammi@cadence.com\n", stdout);
791 Perl may be copied only under the terms of either the Artistic License or the\n\
792 GNU General Public License, which may be found in the Perl 5.0 source kit.\n",stdout);
802 if (s[1] == '-') /* Additional switches on #! line. */
810 croak("Switch meaningless after -x: -%s",s);
815 /* compliments of Tom Christiansen */
817 /* unexec() can be found in the Gnu emacs distribution */
826 sprintf (buf, "%s.perldump", origfilename);
827 sprintf (tokenbuf, "%s/perl", BIN);
829 status = unexec(buf, tokenbuf, &etext, sbrk(0), 0);
831 fprintf(stderr, "unexec of %s into %s failed!\n", tokenbuf, buf);
834 ABORT(); /* for use with undump */
842 curstash = defstash = newHV();
843 curstname = newSVpv("main",4);
844 GvHV(gv = gv_fetchpv("_main",TRUE)) = (HV*)SvREFCNT_inc(defstash);
846 HvNAME(defstash) = "main";
847 incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE)));
849 defgv = gv_fetchpv("_",TRUE);
851 compiling.cop_stash = defstash;
855 open_script(scriptname,dosearch,sv)
860 char *xfound = Nullch;
861 char *xfailed = Nullch;
865 if (dosearch && !strchr(scriptname, '/') && (s = getenv("PATH"))) {
867 bufend = s + strlen(s);
870 s = cpytill(tokenbuf,s,bufend,':',&len);
873 for (len = 0; *s && *s != ',' && *s != ';'; tokenbuf[len++] = *s++);
874 tokenbuf[len] = '\0';
876 for (len = 0; *s && *s != ';'; tokenbuf[len++] = *s++);
877 tokenbuf[len] = '\0';
883 if (len && tokenbuf[len-1] != '/')
886 if (len && ((tokenbuf[len-1] != '\\') && (tokenbuf[len-1] != '/')))
888 if (len && tokenbuf[len-1] != '\\')
891 (void)strcat(tokenbuf+len,"/");
892 (void)strcat(tokenbuf+len,scriptname);
893 DEBUG_p(fprintf(stderr,"Looking for %s\n",tokenbuf));
894 if (stat(tokenbuf,&statbuf) < 0) /* not there? */
896 if (S_ISREG(statbuf.st_mode)
897 && cando(S_IRUSR,TRUE,&statbuf) && cando(S_IXUSR,TRUE,&statbuf)) {
898 xfound = tokenbuf; /* bingo! */
902 xfailed = savestr(tokenbuf);
905 croak("Can't execute %s", xfailed ? xfailed : scriptname );
911 origfilename = savestr(e_fp ? "-e" : scriptname);
912 curcop->cop_filegv = gv_fetchfile(origfilename);
913 if (strEQ(origfilename,"-"))
916 char *cpp = CPPSTDIN;
918 if (strEQ(cpp,"cppstdin"))
919 sprintf(tokenbuf, "%s/%s", SCRIPTDIR, cpp);
921 sprintf(tokenbuf, "%s", cpp);
923 sv_catpv(sv,PRIVLIB);
925 (void)sprintf(buf, "\
926 sed %s -e \"/^[^#]/b\" \
927 -e \"/^#[ ]*include[ ]/b\" \
928 -e \"/^#[ ]*define[ ]/b\" \
929 -e \"/^#[ ]*if[ ]/b\" \
930 -e \"/^#[ ]*ifdef[ ]/b\" \
931 -e \"/^#[ ]*ifndef[ ]/b\" \
932 -e \"/^#[ ]*else/b\" \
933 -e \"/^#[ ]*elif[ ]/b\" \
934 -e \"/^#[ ]*undef[ ]/b\" \
935 -e \"/^#[ ]*endif/b\" \
938 (doextract ? "-e \"1,/^#/d\n\"" : ""),
940 (void)sprintf(buf, "\
941 %s %s -e '/^[^#]/b' \
942 -e '/^#[ ]*include[ ]/b' \
943 -e '/^#[ ]*define[ ]/b' \
944 -e '/^#[ ]*if[ ]/b' \
945 -e '/^#[ ]*ifdef[ ]/b' \
946 -e '/^#[ ]*ifndef[ ]/b' \
948 -e '/^#[ ]*elif[ ]/b' \
949 -e '/^#[ ]*undef[ ]/b' \
950 -e '/^#[ ]*endif/b' \
958 (doextract ? "-e '1,/^#/d\n'" : ""),
960 scriptname, tokenbuf, SvPV(sv, na), CPPMINUS);
961 DEBUG_P(fprintf(stderr, "%s\n", buf));
963 #ifdef IAMSUID /* actually, this is caught earlier */
964 if (euid != uid && !euid) { /* if running suidperl */
966 (void)seteuid(uid); /* musn't stay setuid root */
969 (void)setreuid(-1, uid);
974 if (geteuid() != uid)
975 croak("Can't do seteuid!\n");
978 rsfp = my_popen(buf,"r");
980 else if (!*scriptname) {
981 taint_not("program input from stdin");
985 rsfp = fopen(scriptname,"r");
986 if ((FILE*)rsfp == Nullfp) {
988 #ifndef IAMSUID /* in case script is not readable before setuid */
989 if (euid && stat(SvPVX(GvSV(curcop->cop_filegv)),&statbuf) >= 0 &&
990 statbuf.st_mode & (S_ISUID|S_ISGID)) {
991 (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel);
992 execv(buf, origargv); /* try again */
993 croak("Can't do setuid\n");
997 croak("Can't open perl script \"%s\": %s\n",
998 SvPVX(GvSV(curcop->cop_filegv)), Strerror(errno));
1003 validate_suid(validarg)
1007 /* do we need to emulate setuid on scripts? */
1009 /* This code is for those BSD systems that have setuid #! scripts disabled
1010 * in the kernel because of a security problem. Merely defining DOSUID
1011 * in perl will not fix that problem, but if you have disabled setuid
1012 * scripts in the kernel, this will attempt to emulate setuid and setgid
1013 * on scripts that have those now-otherwise-useless bits set. The setuid
1014 * root version must be called suidperl or sperlN.NNN. If regular perl
1015 * discovers that it has opened a setuid script, it calls suidperl with
1016 * the same argv that it had. If suidperl finds that the script it has
1017 * just opened is NOT setuid root, it sets the effective uid back to the
1018 * uid. We don't just make perl setuid root because that loses the
1019 * effective uid we had before invoking perl, if it was different from the
1022 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
1023 * be defined in suidperl only. suidperl must be setuid root. The
1024 * Configure script will set this up for you if you want it.
1028 if (fstat(fileno(rsfp),&statbuf) < 0) /* normal stat is insecure */
1029 croak("Can't stat script \"%s\"",origfilename);
1030 if (statbuf.st_mode & (S_ISUID|S_ISGID)) {
1034 #ifndef HAS_SETREUID
1035 /* On this access check to make sure the directories are readable,
1036 * there is actually a small window that the user could use to make
1037 * filename point to an accessible directory. So there is a faint
1038 * chance that someone could execute a setuid script down in a
1039 * non-accessible directory. I don't know what to do about that.
1040 * But I don't think it's too important. The manual lies when
1041 * it says access() is useful in setuid programs.
1043 if (access(SvPVX(GvSV(curcop->cop_filegv)),1)) /*double check*/
1044 croak("Permission denied");
1046 /* If we can swap euid and uid, then we can determine access rights
1047 * with a simple stat of the file, and then compare device and
1048 * inode to make sure we did stat() on the same file we opened.
1049 * Then we just have to make sure he or she can execute it.
1052 struct stat tmpstatbuf;
1054 if (setreuid(euid,uid) < 0 || getuid() != euid || geteuid() != uid)
1055 croak("Can't swap uid and euid"); /* really paranoid */
1056 if (stat(SvPVX(GvSV(curcop->cop_filegv)),&tmpstatbuf) < 0)
1057 croak("Permission denied"); /* testing full pathname here */
1058 if (tmpstatbuf.st_dev != statbuf.st_dev ||
1059 tmpstatbuf.st_ino != statbuf.st_ino) {
1061 if (rsfp = my_popen("/bin/mail root","w")) { /* heh, heh */
1063 "User %d tried to run dev %d ino %d in place of dev %d ino %d!\n\
1064 (Filename of set-id script was %s, uid %d gid %d.)\n\nSincerely,\nperl\n",
1065 uid,tmpstatbuf.st_dev, tmpstatbuf.st_ino,
1066 statbuf.st_dev, statbuf.st_ino,
1067 SvPVX(GvSV(curcop->cop_filegv)),
1068 statbuf.st_uid, statbuf.st_gid);
1069 (void)my_pclose(rsfp);
1071 croak("Permission denied\n");
1073 if (setreuid(uid,euid) < 0 || getuid() != uid || geteuid() != euid)
1074 croak("Can't reswap uid and euid");
1075 if (!cando(S_IXUSR,FALSE,&statbuf)) /* can real uid exec? */
1076 croak("Permission denied\n");
1078 #endif /* HAS_SETREUID */
1079 #endif /* IAMSUID */
1081 if (!S_ISREG(statbuf.st_mode))
1082 croak("Permission denied");
1083 if (statbuf.st_mode & S_IWOTH)
1084 croak("Setuid/gid script is writable by world");
1085 doswitches = FALSE; /* -s is insecure in suid */
1087 if (fgets(tokenbuf,sizeof tokenbuf, rsfp) == Nullch ||
1088 strnNE(tokenbuf,"#!",2) ) /* required even on Sys V */
1089 croak("No #! line");
1092 while (!isSPACE(*s)) s++;
1093 if (strnNE(s-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
1094 croak("Not a perl script");
1095 while (*s == ' ' || *s == '\t') s++;
1097 * #! arg must be what we saw above. They can invoke it by
1098 * mentioning suidperl explicitly, but they may not add any strange
1099 * arguments beyond what #! says if they do invoke suidperl that way.
1101 len = strlen(validarg);
1102 if (strEQ(validarg," PHOOEY ") ||
1103 strnNE(s,validarg,len) || !isSPACE(s[len]))
1104 croak("Args must match #! line");
1107 if (euid != uid && (statbuf.st_mode & S_ISUID) &&
1108 euid == statbuf.st_uid)
1110 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
1111 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
1112 #endif /* IAMSUID */
1114 if (euid) { /* oops, we're not the setuid root perl */
1117 (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel);
1118 execv(buf, origargv); /* try again */
1120 croak("Can't do setuid\n");
1123 if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid) {
1125 (void)setegid(statbuf.st_gid);
1128 (void)setregid((GIDTYPE)-1,statbuf.st_gid);
1130 setgid(statbuf.st_gid);
1133 if (getegid() != statbuf.st_gid)
1134 croak("Can't do setegid!\n");
1136 if (statbuf.st_mode & S_ISUID) {
1137 if (statbuf.st_uid != euid)
1139 (void)seteuid(statbuf.st_uid); /* all that for this */
1142 (void)setreuid((UIDTYPE)-1,statbuf.st_uid);
1144 setuid(statbuf.st_uid);
1147 if (geteuid() != statbuf.st_uid)
1148 croak("Can't do seteuid!\n");
1150 else if (uid) { /* oops, mustn't run as root */
1152 (void)seteuid((UIDTYPE)uid);
1155 (void)setreuid((UIDTYPE)-1,(UIDTYPE)uid);
1157 setuid((UIDTYPE)uid);
1160 if (geteuid() != uid)
1161 croak("Can't do seteuid!\n");
1163 uid = (int)getuid();
1164 euid = (int)geteuid();
1165 gid = (int)getgid();
1166 egid = (int)getegid();
1167 tainting |= (euid != uid || egid != gid);
1168 if (!cando(S_IXUSR,TRUE,&statbuf))
1169 croak("Permission denied\n"); /* they can't do this */
1172 else if (preprocess)
1173 croak("-P not allowed for setuid/setgid script\n");
1175 croak("Script is not setuid/setgid in suidperl\n");
1176 #endif /* IAMSUID */
1178 if (euid != uid || egid != gid) { /* (suidperl doesn't exist, in fact) */
1179 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
1180 fstat(fileno(rsfp),&statbuf); /* may be either wrapped or real suid */
1181 if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
1183 (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
1186 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
1187 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
1188 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
1189 /* not set-id, must be wrapped */
1199 /* skip forward in input to the real script? */
1203 if ((s = sv_gets(linestr, rsfp, 0)) == Nullch)
1204 croak("No Perl script found in input\n");
1205 if (*s == '#' && s[1] == '!' && instr(s,"perl")) {
1206 ungetc('\n',rsfp); /* to keep line count right */
1208 if (s = instr(s,"perl -")) {
1211 while (s = moreswitches(s)) ;
1213 if (cddir && chdir(cddir) < 0)
1214 croak("Can't chdir to %s",cddir);
1225 GvHV(gv_fetchpv("::_DB",TRUE)) = debstash;
1226 curstash = debstash;
1227 dbargs = GvAV(gv_AVadd((tmpgv = gv_fetchpv("args",TRUE))));
1230 DBgv = gv_fetchpv("DB",TRUE);
1232 DBline = gv_fetchpv("dbline",TRUE);
1234 DBsub = gv_HVadd(tmpgv = gv_fetchpv("sub",TRUE));
1236 DBsingle = GvSV((tmpgv = gv_fetchpv("single",TRUE)));
1238 DBtrace = GvSV((tmpgv = gv_fetchpv("trace",TRUE)));
1240 DBsignal = GvSV((tmpgv = gv_fetchpv("signal",TRUE)));
1242 curstash = defstash;
1249 mainstack = stack; /* remember in case we switch stacks */
1250 AvREAL_off(stack); /* not a real array */
1251 av_fill(stack,127); av_fill(stack,-1); /* preextend stack */
1253 stack_base = AvARRAY(stack);
1254 stack_sp = stack_base;
1255 stack_max = stack_base + 127;
1257 New(54,markstack,64,int);
1258 markstack_ptr = markstack;
1259 markstack_max = markstack + 64;
1261 New(54,scopestack,32,int);
1263 scopestack_max = 32;
1265 New(54,savestack,128,ANY);
1267 savestack_max = 128;
1269 New(54,retstack,16,OP*);
1273 New(50,cxstack,128,CONTEXT);
1277 New(50,tmps_stack,128,SV*);
1282 New(51,debname,128,char);
1283 New(52,debdelim,128,char);
1294 subname = newSVpv("main",4);
1298 init_predump_symbols()
1302 sv_setpvn(GvSV(gv_fetchpv("\"", TRUE)), " ", 1);
1304 stdingv = gv_fetchpv("STDIN",TRUE);
1305 SvMULTI_on(stdingv);
1307 GvIO(stdingv) = newIO();
1308 IoIFP(GvIO(stdingv)) = stdin;
1309 tmpgv = gv_fetchpv("stdin",TRUE);
1310 GvIO(tmpgv) = (IO*)SvREFCNT_inc(GvIO(stdingv));
1313 tmpgv = gv_fetchpv("STDOUT",TRUE);
1316 GvIO(tmpgv) = newIO();
1317 IoOFP(GvIO(tmpgv)) = IoIFP(GvIO(tmpgv)) = stdout;
1319 tmpgv = gv_fetchpv("stdout",TRUE);
1320 GvIO(tmpgv) = (IO*)SvREFCNT_inc(GvIO(defoutgv));
1323 curoutgv = gv_fetchpv("STDERR",TRUE);
1324 SvMULTI_on(curoutgv);
1325 if (!GvIO(curoutgv))
1326 GvIO(curoutgv) = newIO();
1327 IoOFP(GvIO(curoutgv)) = IoIFP(GvIO(curoutgv)) = stderr;
1328 tmpgv = gv_fetchpv("stderr",TRUE);
1329 GvIO(tmpgv) = (IO*)SvREFCNT_inc(GvIO(curoutgv));
1331 curoutgv = defoutgv; /* switch back to STDOUT */
1333 statname = NEWSV(66,0); /* last filename we did stat on */
1337 init_postdump_symbols(argc,argv,env)
1339 register char **argv;
1340 register char **env;
1346 argc--,argv++; /* skip name of script */
1348 for (; argc > 0 && **argv == '-'; argc--,argv++) {
1351 if (argv[0][1] == '-') {
1355 if (s = strchr(argv[0], '=')) {
1357 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE)),s);
1360 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE)),1);
1363 toptarget = NEWSV(0,0);
1364 sv_upgrade(toptarget, SVt_PVFM);
1365 sv_setpvn(toptarget, "", 0);
1366 bodytarget = NEWSV(0,0);
1367 sv_upgrade(bodytarget, SVt_PVFM);
1368 sv_setpvn(bodytarget, "", 0);
1369 formtarget = bodytarget;
1372 if (tmpgv = gv_fetchpv("0",TRUE)) {
1373 sv_setpv(GvSV(tmpgv),origfilename);
1374 magicname("0", "0", 1);
1376 if (tmpgv = gv_fetchpv("\024",TRUE))
1378 if (tmpgv = gv_fetchpv("\030",TRUE))
1379 sv_setpv(GvSV(tmpgv),origargv[0]);
1380 if (argvgv = gv_fetchpv("ARGV",TRUE)) {
1382 (void)gv_AVadd(argvgv);
1383 av_clear(GvAVn(argvgv));
1384 for (; argc > 0; argc--,argv++) {
1385 (void)av_push(GvAVn(argvgv),newSVpv(argv[0],0));
1388 if (envgv = gv_fetchpv("ENV",TRUE)) {
1393 if (env != environ) {
1394 environ[0] = Nullch;
1395 hv_magic(hv, envgv, 'E');
1397 for (; *env; env++) {
1398 if (!(s = strchr(*env,'=')))
1401 sv = newSVpv(s--,0);
1402 (void)hv_store(hv, *env, s - *env, sv, 0);
1405 hv_magic(hv, envgv, 'E');
1408 if (tmpgv = gv_fetchpv("$",TRUE))
1409 sv_setiv(GvSV(tmpgv),(I32)getpid());
1417 incpush(getenv("PERLLIB"));
1420 #define PRIVLIB "/usr/local/lib/perl"
1423 (void)av_push(GvAVn(incgv),newSVpv(".",1));
1431 I32 sp = stack_sp - stack_base;
1433 av_store(stack, ++sp, Nullsv); /* reserve spot for sub reference */
1434 Copy(top_env, oldtop, 1, jmp_buf);
1436 while (AvFILL(list) >= 0) {
1437 CV *cv = (CV*)av_shift(list);
1440 if (setjmp(top_env)) {
1441 if (list == beginav) {
1442 warn("BEGIN failed--execution aborted");
1443 Copy(oldtop, top_env, 1, jmp_buf);
1448 perl_callsv((SV*)cv, sp, G_SCALAR, 0, 0);
1452 Copy(oldtop, top_env, 1, jmp_buf);