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, SVt_PVHV)) = 0;
212 --SvREFCNT(defstash);
214 /* Try to destruct main symbol table. May fail on reference loops. */
215 SvREFCNT_dec(defstash);
220 if (scopestack_ix != 0)
221 warn("Unbalanced scopes: %d more ENTERs than LEAVEs\n", scopestack_ix);
222 if (savestack_ix != 0)
223 warn("Unbalanced saves: %d more saves than restores\n", savestack_ix);
224 if (tmps_floor != -1)
225 warn("Unbalanced tmps: %d more allocs than frees\n", tmps_floor + 1);
226 if (cxstack_ix != -1)
227 warn("Unbalanced context: %d more PUSHes than POPs\n", cxstack_ix + 1);
230 /* Now absolutely destruct everything, somehow or other, loops or no. */
232 while (sv_count != 0 && sv_count != last_sv_count) {
233 last_sv_count = sv_count;
237 warn("Scalars leaked: %d\n", sv_count);
242 PerlInterpreter *sv_interp;
244 if (!(curinterp = sv_interp))
250 perl_parse(sv_interp, argc, argv, env)
251 PerlInterpreter *sv_interp;
253 register char **argv;
260 bool dosearch = FALSE;
263 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
266 croak("suidperl is no longer needed since the kernel can now execute\n\
267 setuid perl scripts securely.\n");
271 if (!(curinterp = sv_interp))
280 origenviron = environ;
282 switch (setjmp(top_env)) {
289 return(statusvalue); /* my_exit() was called */
291 fprintf(stderr, "panic: top_env\n");
297 /* Come here if running an undumped a.out. */
299 origfilename = savestr(argv[0]);
301 cxstack_ix = -1; /* start label stack again */
302 init_postdump_symbols(argc,argv,env);
306 sv_setpvn(linestr,"",0);
307 sv = newSVpv("",0); /* first used for -I flags */
310 for (argc--,argv++; argc > 0; argc--,argv++) {
311 if (argv[0][0] != '-' || !argv[0][1])
315 validarg = " PHOOEY ";
338 if (s = moreswitches(s))
343 if (euid != uid || egid != gid)
344 croak("No -e allowed in setuid scripts");
346 e_tmpname = savestr(TMPPATH);
347 (void)mktemp(e_tmpname);
349 croak("Can't mktemp()");
350 e_fp = fopen(e_tmpname,"w");
352 croak("Cannot open temporary file");
358 (void)putc('\n', e_fp);
366 (void)av_push(GvAVn(incgv),newSVpv(s,0));
369 (void)av_push(GvAVn(incgv),newSVpv(argv[1],0));
370 sv_catpv(sv,argv[1]);
397 croak("Unrecognized switch: -%s",s);
401 scriptname = argv[0];
403 if (fflush(e_fp) || ferror(e_fp) || fclose(e_fp))
404 croak("Can't write to temp file for -e: %s", Strerror(errno));
406 scriptname = e_tmpname;
408 else if (scriptname == Nullch) {
410 if ( isatty(fileno(stdin)) )
418 open_script(scriptname,dosearch,sv);
420 validate_suid(validarg);
430 av_push(comppad, Nullsv);
431 curpad = AvARRAY(comppad);
433 comppad_name = padname;
434 comppad_name_fill = 0;
435 min_intro_pending = 0;
438 perl_init_ext(); /* in case linked C routines want magical variables */
440 init_predump_symbols();
442 init_postdump_symbols(argc,argv,env);
446 /* now parse the script */
449 if (yyparse() || error_count) {
451 croak("%s had compilation errors.\n", origfilename);
453 croak("Execution of %s aborted due to compilation errors.\n",
457 curcop->cop_line = 0;
462 (void)UNLINK(e_tmpname);
465 /* now that script is parsed, we can modify record separator */
470 rspara = (nrslen == 2);
471 sv_setpvn(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), rs, rslen);
484 PerlInterpreter *sv_interp;
486 if (!(curinterp = sv_interp))
488 switch (setjmp(top_env)) {
490 cxstack_ix = -1; /* start context stack again */
497 return(statusvalue); /* my_exit() was called */
500 fprintf(stderr, "panic: restartop\n");
504 if (stack != mainstack) {
506 SWITCHSTACK(stack, mainstack);
513 DEBUG(fprintf(stderr,"\nEXECUTING...\n\n"));
516 fprintf(stderr,"%s syntax OK\n", origfilename);
528 else if (main_start) {
540 statusvalue = (unsigned short)(status & 0xffff);
544 /* Be sure to refetch the stack pointer after calling these routines. */
547 perl_callargv(subname, sp, gimme, argv)
549 register I32 sp; /* current stack pointer */
550 I32 gimme; /* TRUE if called in list context */
551 register char **argv; /* null terminated arg list, NULL for no arglist */
553 register I32 items = 0;
554 I32 hasargs = (argv != 0);
556 av_store(stack, ++sp, Nullsv); /* reserve spot for sub reference */
559 av_store(stack, ++sp, sv_2mortal(newSVpv(*argv,0)));
564 return perl_callpv(subname, sp, gimme, hasargs, items);
568 perl_callpv(subname, sp, gimme, hasargs, numargs)
570 I32 sp; /* stack pointer after args are pushed */
571 I32 gimme; /* TRUE if called in list context */
572 I32 hasargs; /* whether to create a @_ array for routine */
573 I32 numargs; /* how many args are pushed on the stack */
575 return perl_callsv((SV*)gv_fetchpv(subname, TRUE, SVt_PVCV),
576 sp, gimme, hasargs, numargs);
579 /* May be called with any of a CV, a GV, or an SV containing the name. */
581 perl_callsv(sv, sp, gimme, hasargs, numargs)
583 I32 sp; /* stack pointer after args are pushed */
584 I32 gimme; /* TRUE if called in list context */
585 I32 hasargs; /* whether to create a @_ array for routine */
586 I32 numargs; /* how many args are pushed on the stack */
588 BINOP myop; /* fake syntax tree node */
593 stack_base = AvARRAY(stack);
594 stack_sp = stack_base + sp - numargs - 1;
597 pp_pushmark(); /* doesn't look at op, actually, except to return */
602 myop.op_flags = OPf_STACKED;
603 myop.op_last = (OP*)&myop;
605 myop.op_next = Nullop;
607 if (op = pp_entersubr())
611 return stack_sp - stack_base;
615 magicname(sym,name,namlen)
622 if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
623 sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
627 #define PERLLIB_SEP ';'
629 #define PERLLIB_SEP ':'
641 /* Break at all separators */
643 /* First, skip any consecutive separators */
644 while ( *p == PERLLIB_SEP ) {
645 /* Uncomment the next line for PATH semantics */
646 /* (void)av_push(GvAVn(incgv), newSVpv(".", 1)); */
649 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
650 (void)av_push(GvAVn(incgv), newSVpv(p, (I32)(s - p)));
653 (void)av_push(GvAVn(incgv), newSVpv(p, 0));
659 /* This routine handles any switches that can be given during run */
669 nrschar = scan_oct(s, 4, &numlen);
670 nrs = nsavestr("\n",1);
672 if (nrschar > 0377) {
676 else if (!nrschar && numlen >= 2) {
684 splitstr = savestr(s + 1);
704 static char debopts[] = "psltocPmfrxuLHXD";
707 for (s++; *s && (d = strchr(debopts,*s)); s++)
708 debug |= 1 << (d - debopts);
712 for (s++; isDIGIT(*s); s++) ;
716 warn("Recompile perl with -DDEBUGGING to use -D switch\n");
717 for (s++; isDIGIT(*s); s++) ;
724 inplace = savestr(s+1);
726 for (s = inplace; *s && !isSPACE(*s); s++) ;
732 (void)av_push(GvAVn(incgv),newSVpv(s,0));
735 croak("No space allowed after -I");
743 *ors = scan_oct(s, 3 + (*s == '0'), &numlen);
747 ors = nsavestr(nrs,nrslen);
777 fputs("\nThis is perl, version 5.0, Alpha 9 (unsupported)\n\n",stdout);
779 fputs("\nCopyright (c) 1989, 1990, 1991, 1992, 1993, 1994 Larry Wall\n",stdout);
781 fputs("MS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n",
784 fputs("OS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n",
789 fputs("atariST series port, ++jrb bammi@cadence.com\n", stdout);
792 Perl may be copied only under the terms of either the Artistic License or the\n\
793 GNU General Public License, which may be found in the Perl 5.0 source kit.\n",stdout);
803 if (s[1] == '-') /* Additional switches on #! line. */
811 croak("Switch meaningless after -x: -%s",s);
816 /* compliments of Tom Christiansen */
818 /* unexec() can be found in the Gnu emacs distribution */
827 sprintf (buf, "%s.perldump", origfilename);
828 sprintf (tokenbuf, "%s/perl", BIN);
830 status = unexec(buf, tokenbuf, &etext, sbrk(0), 0);
832 fprintf(stderr, "unexec of %s into %s failed!\n", tokenbuf, buf);
835 ABORT(); /* for use with undump */
843 curstash = defstash = newHV();
844 curstname = newSVpv("main",4);
845 GvHV(gv = gv_fetchpv("_main",TRUE, SVt_PVHV)) = (HV*)SvREFCNT_inc(defstash);
847 HvNAME(defstash) = savestr("main");
848 incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
850 defgv = gv_fetchpv("_",TRUE, SVt_PV);
852 compiling.cop_stash = defstash;
856 open_script(scriptname,dosearch,sv)
861 char *xfound = Nullch;
862 char *xfailed = Nullch;
866 if (dosearch && !strchr(scriptname, '/') && (s = getenv("PATH"))) {
868 bufend = s + strlen(s);
871 s = cpytill(tokenbuf,s,bufend,':',&len);
874 for (len = 0; *s && *s != ',' && *s != ';'; tokenbuf[len++] = *s++);
875 tokenbuf[len] = '\0';
877 for (len = 0; *s && *s != ';'; tokenbuf[len++] = *s++);
878 tokenbuf[len] = '\0';
884 if (len && tokenbuf[len-1] != '/')
887 if (len && ((tokenbuf[len-1] != '\\') && (tokenbuf[len-1] != '/')))
889 if (len && tokenbuf[len-1] != '\\')
892 (void)strcat(tokenbuf+len,"/");
893 (void)strcat(tokenbuf+len,scriptname);
894 DEBUG_p(fprintf(stderr,"Looking for %s\n",tokenbuf));
895 if (stat(tokenbuf,&statbuf) < 0) /* not there? */
897 if (S_ISREG(statbuf.st_mode)
898 && cando(S_IRUSR,TRUE,&statbuf) && cando(S_IXUSR,TRUE,&statbuf)) {
899 xfound = tokenbuf; /* bingo! */
903 xfailed = savestr(tokenbuf);
906 croak("Can't execute %s", xfailed ? xfailed : scriptname );
912 origfilename = savestr(e_fp ? "-e" : scriptname);
913 curcop->cop_filegv = gv_fetchfile(origfilename);
914 if (strEQ(origfilename,"-"))
917 char *cpp = CPPSTDIN;
919 if (strEQ(cpp,"cppstdin"))
920 sprintf(tokenbuf, "%s/%s", SCRIPTDIR, cpp);
922 sprintf(tokenbuf, "%s", cpp);
924 sv_catpv(sv,PRIVLIB);
926 (void)sprintf(buf, "\
927 sed %s -e \"/^[^#]/b\" \
928 -e \"/^#[ ]*include[ ]/b\" \
929 -e \"/^#[ ]*define[ ]/b\" \
930 -e \"/^#[ ]*if[ ]/b\" \
931 -e \"/^#[ ]*ifdef[ ]/b\" \
932 -e \"/^#[ ]*ifndef[ ]/b\" \
933 -e \"/^#[ ]*else/b\" \
934 -e \"/^#[ ]*elif[ ]/b\" \
935 -e \"/^#[ ]*undef[ ]/b\" \
936 -e \"/^#[ ]*endif/b\" \
939 (doextract ? "-e \"1,/^#/d\n\"" : ""),
941 (void)sprintf(buf, "\
942 %s %s -e '/^[^#]/b' \
943 -e '/^#[ ]*include[ ]/b' \
944 -e '/^#[ ]*define[ ]/b' \
945 -e '/^#[ ]*if[ ]/b' \
946 -e '/^#[ ]*ifdef[ ]/b' \
947 -e '/^#[ ]*ifndef[ ]/b' \
949 -e '/^#[ ]*elif[ ]/b' \
950 -e '/^#[ ]*undef[ ]/b' \
951 -e '/^#[ ]*endif/b' \
959 (doextract ? "-e '1,/^#/d\n'" : ""),
961 scriptname, tokenbuf, SvPV(sv, na), CPPMINUS);
962 DEBUG_P(fprintf(stderr, "%s\n", buf));
964 #ifdef IAMSUID /* actually, this is caught earlier */
965 if (euid != uid && !euid) { /* if running suidperl */
967 (void)seteuid(uid); /* musn't stay setuid root */
970 (void)setreuid((Uid_t)-1, uid);
973 (void)setresuid((Uid_t)-1, uid, (Uid_t)-1);
979 if (geteuid() != uid)
980 croak("Can't do seteuid!\n");
983 rsfp = my_popen(buf,"r");
985 else if (!*scriptname) {
986 taint_not("program input from stdin");
990 rsfp = fopen(scriptname,"r");
991 if ((FILE*)rsfp == Nullfp) {
993 #ifndef IAMSUID /* in case script is not readable before setuid */
994 if (euid && stat(SvPVX(GvSV(curcop->cop_filegv)),&statbuf) >= 0 &&
995 statbuf.st_mode & (S_ISUID|S_ISGID)) {
996 (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel);
997 execv(buf, origargv); /* try again */
998 croak("Can't do setuid\n");
1002 croak("Can't open perl script \"%s\": %s\n",
1003 SvPVX(GvSV(curcop->cop_filegv)), Strerror(errno));
1008 validate_suid(validarg)
1012 /* do we need to emulate setuid on scripts? */
1014 /* This code is for those BSD systems that have setuid #! scripts disabled
1015 * in the kernel because of a security problem. Merely defining DOSUID
1016 * in perl will not fix that problem, but if you have disabled setuid
1017 * scripts in the kernel, this will attempt to emulate setuid and setgid
1018 * on scripts that have those now-otherwise-useless bits set. The setuid
1019 * root version must be called suidperl or sperlN.NNN. If regular perl
1020 * discovers that it has opened a setuid script, it calls suidperl with
1021 * the same argv that it had. If suidperl finds that the script it has
1022 * just opened is NOT setuid root, it sets the effective uid back to the
1023 * uid. We don't just make perl setuid root because that loses the
1024 * effective uid we had before invoking perl, if it was different from the
1027 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
1028 * be defined in suidperl only. suidperl must be setuid root. The
1029 * Configure script will set this up for you if you want it.
1033 if (fstat(fileno(rsfp),&statbuf) < 0) /* normal stat is insecure */
1034 croak("Can't stat script \"%s\"",origfilename);
1035 if (statbuf.st_mode & (S_ISUID|S_ISGID)) {
1039 #ifndef HAS_SETREUID
1040 /* On this access check to make sure the directories are readable,
1041 * there is actually a small window that the user could use to make
1042 * filename point to an accessible directory. So there is a faint
1043 * chance that someone could execute a setuid script down in a
1044 * non-accessible directory. I don't know what to do about that.
1045 * But I don't think it's too important. The manual lies when
1046 * it says access() is useful in setuid programs.
1048 if (access(SvPVX(GvSV(curcop->cop_filegv)),1)) /*double check*/
1049 croak("Permission denied");
1051 /* If we can swap euid and uid, then we can determine access rights
1052 * with a simple stat of the file, and then compare device and
1053 * inode to make sure we did stat() on the same file we opened.
1054 * Then we just have to make sure he or she can execute it.
1057 struct stat tmpstatbuf;
1061 setreuid(euid,uid) < 0
1063 setresuid(euid,uid,(Uid_t)-1) < 0
1065 || getuid() != euid || geteuid() != uid)
1066 croak("Can't swap uid and euid"); /* really paranoid */
1067 if (stat(SvPVX(GvSV(curcop->cop_filegv)),&tmpstatbuf) < 0)
1068 croak("Permission denied"); /* testing full pathname here */
1069 if (tmpstatbuf.st_dev != statbuf.st_dev ||
1070 tmpstatbuf.st_ino != statbuf.st_ino) {
1072 if (rsfp = my_popen("/bin/mail root","w")) { /* heh, heh */
1074 "User %d tried to run dev %d ino %d in place of dev %d ino %d!\n\
1075 (Filename of set-id script was %s, uid %d gid %d.)\n\nSincerely,\nperl\n",
1076 uid,tmpstatbuf.st_dev, tmpstatbuf.st_ino,
1077 statbuf.st_dev, statbuf.st_ino,
1078 SvPVX(GvSV(curcop->cop_filegv)),
1079 statbuf.st_uid, statbuf.st_gid);
1080 (void)my_pclose(rsfp);
1082 croak("Permission denied\n");
1086 setreuid(uid,euid) < 0
1087 #elif defined(HAS_SETRESUID)
1088 setresuid(uid,euid,(Uid_t)-1) < 0
1090 || getuid() != uid || geteuid() != euid)
1091 croak("Can't reswap uid and euid");
1092 if (!cando(S_IXUSR,FALSE,&statbuf)) /* can real uid exec? */
1093 croak("Permission denied\n");
1095 #endif /* HAS_SETREUID */
1096 #endif /* IAMSUID */
1098 if (!S_ISREG(statbuf.st_mode))
1099 croak("Permission denied");
1100 if (statbuf.st_mode & S_IWOTH)
1101 croak("Setuid/gid script is writable by world");
1102 doswitches = FALSE; /* -s is insecure in suid */
1104 if (fgets(tokenbuf,sizeof tokenbuf, rsfp) == Nullch ||
1105 strnNE(tokenbuf,"#!",2) ) /* required even on Sys V */
1106 croak("No #! line");
1109 while (!isSPACE(*s)) s++;
1110 if (strnNE(s-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
1111 croak("Not a perl script");
1112 while (*s == ' ' || *s == '\t') s++;
1114 * #! arg must be what we saw above. They can invoke it by
1115 * mentioning suidperl explicitly, but they may not add any strange
1116 * arguments beyond what #! says if they do invoke suidperl that way.
1118 len = strlen(validarg);
1119 if (strEQ(validarg," PHOOEY ") ||
1120 strnNE(s,validarg,len) || !isSPACE(s[len]))
1121 croak("Args must match #! line");
1124 if (euid != uid && (statbuf.st_mode & S_ISUID) &&
1125 euid == statbuf.st_uid)
1127 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
1128 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
1129 #endif /* IAMSUID */
1131 if (euid) { /* oops, we're not the setuid root perl */
1134 (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel);
1135 execv(buf, origargv); /* try again */
1137 croak("Can't do setuid\n");
1140 if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid) {
1142 (void)setegid(statbuf.st_gid);
1145 (void)setregid((Gid_t)-1,statbuf.st_gid);
1147 #ifdef HAS_SETRESGID
1148 (void)setresgid((Gid_t)-1,statbuf.st_gid,(Gid_t)-1);
1150 setgid(statbuf.st_gid);
1154 if (getegid() != statbuf.st_gid)
1155 croak("Can't do setegid!\n");
1157 if (statbuf.st_mode & S_ISUID) {
1158 if (statbuf.st_uid != euid)
1160 (void)seteuid(statbuf.st_uid); /* all that for this */
1163 (void)setreuid((Uid_t)-1,statbuf.st_uid);
1165 #ifdef HAS_SETRESUID
1166 (void)setresuid((Uid_t)-1,statbuf.st_uid,(Uid_t)-1);
1168 setuid(statbuf.st_uid);
1172 if (geteuid() != statbuf.st_uid)
1173 croak("Can't do seteuid!\n");
1175 else if (uid) { /* oops, mustn't run as root */
1177 (void)seteuid((Uid_t)uid);
1180 (void)setreuid((Uid_t)-1,(Uid_t)uid);
1182 #ifdef HAS_SETRESUID
1183 (void)setresuid((Uid_t)-1,(Uid_t)uid,(Uid_t)-1);
1189 if (geteuid() != uid)
1190 croak("Can't do seteuid!\n");
1192 uid = (int)getuid();
1193 euid = (int)geteuid();
1194 gid = (int)getgid();
1195 egid = (int)getegid();
1196 tainting |= (euid != uid || egid != gid);
1197 if (!cando(S_IXUSR,TRUE,&statbuf))
1198 croak("Permission denied\n"); /* they can't do this */
1201 else if (preprocess)
1202 croak("-P not allowed for setuid/setgid script\n");
1204 croak("Script is not setuid/setgid in suidperl\n");
1205 #endif /* IAMSUID */
1207 if (euid != uid || egid != gid) { /* (suidperl doesn't exist, in fact) */
1208 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
1209 fstat(fileno(rsfp),&statbuf); /* may be either wrapped or real suid */
1210 if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
1212 (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
1215 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
1216 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
1217 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
1218 /* not set-id, must be wrapped */
1228 /* skip forward in input to the real script? */
1232 if ((s = sv_gets(linestr, rsfp, 0)) == Nullch)
1233 croak("No Perl script found in input\n");
1234 if (*s == '#' && s[1] == '!' && instr(s,"perl")) {
1235 ungetc('\n',rsfp); /* to keep line count right */
1237 if (s = instr(s,"perl -")) {
1240 while (s = moreswitches(s)) ;
1242 if (cddir && chdir(cddir) < 0)
1243 croak("Can't chdir to %s",cddir);
1254 GvHV(gv_fetchpv("::_DB",TRUE, SVt_PVHV)) = debstash;
1255 curstash = debstash;
1256 dbargs = GvAV(gv_AVadd((tmpgv = gv_fetchpv("args",TRUE, SVt_PVAV))));
1259 DBgv = gv_fetchpv("DB",TRUE, SVt_PVGV);
1261 DBline = gv_fetchpv("dbline",TRUE, SVt_PVAV);
1263 DBsub = gv_HVadd(tmpgv = gv_fetchpv("sub",TRUE, SVt_PVHV));
1265 DBsingle = GvSV((tmpgv = gv_fetchpv("single",TRUE, SVt_PV)));
1267 DBtrace = GvSV((tmpgv = gv_fetchpv("trace",TRUE, SVt_PV)));
1269 DBsignal = GvSV((tmpgv = gv_fetchpv("signal",TRUE, SVt_PV)));
1271 curstash = defstash;
1278 mainstack = stack; /* remember in case we switch stacks */
1279 AvREAL_off(stack); /* not a real array */
1280 av_fill(stack,127); av_fill(stack,-1); /* preextend stack */
1282 stack_base = AvARRAY(stack);
1283 stack_sp = stack_base;
1284 stack_max = stack_base + 127;
1286 New(54,markstack,64,int);
1287 markstack_ptr = markstack;
1288 markstack_max = markstack + 64;
1290 New(54,scopestack,32,int);
1292 scopestack_max = 32;
1294 New(54,savestack,128,ANY);
1296 savestack_max = 128;
1298 New(54,retstack,16,OP*);
1302 New(50,cxstack,128,CONTEXT);
1306 New(50,tmps_stack,128,SV*);
1311 New(51,debname,128,char);
1312 New(52,debdelim,128,char);
1323 subname = newSVpv("main",4);
1327 init_predump_symbols()
1331 sv_setpvn(GvSV(gv_fetchpv("\"", TRUE, SVt_PV)), " ", 1);
1333 stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
1334 SvMULTI_on(stdingv);
1336 GvIO(stdingv) = newIO();
1337 IoIFP(GvIO(stdingv)) = stdin;
1338 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PVIO);
1339 GvIO(tmpgv) = (IO*)SvREFCNT_inc(GvIO(stdingv));
1342 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
1345 GvIO(tmpgv) = newIO();
1346 IoOFP(GvIO(tmpgv)) = IoIFP(GvIO(tmpgv)) = stdout;
1348 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PVIO);
1349 GvIO(tmpgv) = (IO*)SvREFCNT_inc(GvIO(defoutgv));
1352 curoutgv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
1353 SvMULTI_on(curoutgv);
1354 if (!GvIO(curoutgv))
1355 GvIO(curoutgv) = newIO();
1356 IoOFP(GvIO(curoutgv)) = IoIFP(GvIO(curoutgv)) = stderr;
1357 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PVIO);
1358 GvIO(tmpgv) = (IO*)SvREFCNT_inc(GvIO(curoutgv));
1360 curoutgv = defoutgv; /* switch back to STDOUT */
1362 statname = NEWSV(66,0); /* last filename we did stat on */
1366 init_postdump_symbols(argc,argv,env)
1368 register char **argv;
1369 register char **env;
1375 argc--,argv++; /* skip name of script */
1377 for (; argc > 0 && **argv == '-'; argc--,argv++) {
1380 if (argv[0][1] == '-') {
1384 if (s = strchr(argv[0], '=')) {
1386 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
1389 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
1392 toptarget = NEWSV(0,0);
1393 sv_upgrade(toptarget, SVt_PVFM);
1394 sv_setpvn(toptarget, "", 0);
1395 tmpgv = gv_fetchpv("\001",TRUE, SVt_PV);
1396 bodytarget = GvSV(tmpgv);
1397 sv_upgrade(bodytarget, SVt_PVFM);
1398 sv_setpvn(bodytarget, "", 0);
1399 formtarget = bodytarget;
1402 if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
1403 sv_setpv(GvSV(tmpgv),origfilename);
1404 magicname("0", "0", 1);
1406 if (tmpgv = gv_fetchpv("\024",TRUE, SVt_PV))
1408 if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
1409 sv_setpv(GvSV(tmpgv),origargv[0]);
1410 if (argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
1412 (void)gv_AVadd(argvgv);
1413 av_clear(GvAVn(argvgv));
1414 for (; argc > 0; argc--,argv++) {
1415 (void)av_push(GvAVn(argvgv),newSVpv(argv[0],0));
1418 if (envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
1423 if (env != environ) {
1424 environ[0] = Nullch;
1425 hv_magic(hv, envgv, 'E');
1427 for (; *env; env++) {
1428 if (!(s = strchr(*env,'=')))
1431 sv = newSVpv(s--,0);
1432 sv_magic(sv, sv, 'e', *env, s - *env);
1433 (void)hv_store(hv, *env, s - *env, sv, 0);
1436 hv_magic(hv, envgv, 'E');
1439 if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
1440 sv_setiv(GvSV(tmpgv),(I32)getpid());
1449 s = getenv("PERL5LIB");
1453 incpush(getenv("PERLLIB"));
1457 #define PRIVLIB "/usr/local/lib/perl5:/usr/local/lib/perl"
1460 (void)av_push(GvAVn(incgv),newSVpv(".",1));
1468 I32 sp = stack_sp - stack_base;
1470 av_store(stack, ++sp, Nullsv); /* reserve spot for sub reference */
1471 Copy(top_env, oldtop, 1, jmp_buf);
1473 while (AvFILL(list) >= 0) {
1474 CV *cv = (CV*)av_shift(list);
1477 switch (setjmp(top_env)) {
1479 perl_callsv((SV*)cv, sp, G_SCALAR, 0, 0);
1482 statusvalue = 255; /* XXX I don't think we use 1 anymore. */
1485 /* my_exit() was called */
1486 curstash = defstash;
1491 if (list == beginav)
1492 warn("BEGIN failed--execution aborted");
1494 warn("END failed--execution aborted");
1496 Copy(oldtop, top_env, 1, jmp_buf);
1497 my_exit(statusvalue);
1502 fprintf(stderr, "panic: restartop\n");
1506 if (stack != mainstack) {
1508 SWITCHSTACK(stack, mainstack);
1517 Copy(oldtop, top_env, 1, jmp_buf);