3 * Copyright (c) 1987-1994 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.
11 * "A ship then new they built for him/of mithril and of elven glass" --Bilbo
16 #include "patchlevel.h"
18 /* Omit -- it causes too much grief on mixed systems.
24 char rcsid[] = "perl.c\nPatch level: ###\n";
32 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
38 static void find_beginning _((void));
39 static void incpush _((char *));
40 static void init_debugger _((void));
41 static void init_lexer _((void));
42 static void init_main_stash _((void));
43 static void init_perllib _((void));
44 static void init_postdump_symbols _((int, char **, char **));
45 static void init_predump_symbols _((void));
46 static void init_stacks _((void));
47 static void open_script _((char *, bool, SV *));
48 static void validate_suid _((char *));
53 PerlInterpreter *sv_interp;
56 New(53, sv_interp, 1, PerlInterpreter);
61 perl_construct( sv_interp )
62 register PerlInterpreter *sv_interp;
66 if (!(curinterp = sv_interp))
70 Zero(sv_interp, 1, PerlInterpreter);
73 /* Init the real globals? */
75 linestr = NEWSV(65,80);
76 sv_upgrade(linestr,SVt_PVIV);
78 SvREADONLY_on(&sv_undef);
82 SvREADONLY_on(&sv_no);
84 sv_setpv(&sv_yes,Yes);
86 SvREADONLY_on(&sv_yes);
90 * There is no way we can refer to them from Perl so close them to save
91 * space. The other alternative would be to provide STDAUX and STDPRN
120 euid = (int)geteuid();
122 egid = (int)getegid();
127 tainting = (euid != uid || egid != gid);
128 sprintf(patchlevel, "%5.3f", 5.0 + (PATCHLEVEL / 1000.0));
130 fdpid = newAV(); /* for remembering popen pids by fd */
131 pidstatus = newHV();/* for remembering status of dead pids */
138 perl_destruct(sv_interp, destruct_level)
139 register PerlInterpreter *sv_interp;
140 int destruct_level; /* 0=none, 1=full, 2=full with checks */
145 if (!(curinterp = sv_interp))
151 /* We must account for everything. First the syntax tree. */
153 curpad = AvARRAY(comppad);
160 * Try to destruct global references. We do this first so that the
161 * destructors and destructees still exist. Some sv's might remain.
162 * Non-referenced objects are on their own.
169 if (destruct_level == 0){
171 DEBUG_P(debprofdump());
173 /* The exit() function will do everything that needs doing. */
177 /* Prepare to destruct main symbol table. */
183 if (destruct_level >= 2) {
184 if (scopestack_ix != 0)
185 warn("Unbalanced scopes: %d more ENTERs than LEAVEs\n", scopestack_ix);
186 if (savestack_ix != 0)
187 warn("Unbalanced saves: %d more saves than restores\n", savestack_ix);
188 if (tmps_floor != -1)
189 warn("Unbalanced tmps: %d more allocs than frees\n", tmps_floor + 1);
190 if (cxstack_ix != -1)
191 warn("Unbalanced context: %d more PUSHes than POPs\n", cxstack_ix + 1);
194 /* Now absolutely destruct everything, somehow or other, loops or no. */
196 while (sv_count != 0 && sv_count != last_sv_count) {
197 last_sv_count = sv_count;
201 warn("Scalars leaked: %d\n", sv_count);
203 DEBUG_P(debprofdump());
208 PerlInterpreter *sv_interp;
210 if (!(curinterp = sv_interp))
214 #if !defined(STANDARD_C) && !defined(HAS_GETENV_PROTOTYPE)
215 char *getenv _((char *)); /* Usually in <stdlib.h> */
219 perl_parse(sv_interp, xsinit, argc, argv, env)
220 PerlInterpreter *sv_interp;
221 void (*xsinit)_((void));
229 VOL bool dosearch = FALSE;
232 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
235 croak("suidperl is no longer needed since the kernel can now execute\n\
236 setuid perl scripts securely.\n");
240 if (!(curinterp = sv_interp))
245 #ifndef VMS /* VMS doesn't have environ array */
246 origenviron = environ;
251 /* Come here if running an undumped a.out. */
253 origfilename = savepv(argv[0]);
255 cxstack_ix = -1; /* start label stack again */
256 init_postdump_symbols(argc,argv,env);
264 switch (setjmp(top_env)) {
271 return(statusvalue); /* my_exit() was called */
273 fprintf(stderr, "panic: top_env\n");
277 sv_setpvn(linestr,"",0);
278 sv = newSVpv("",0); /* first used for -I flags */
281 for (argc--,argv++; argc > 0; argc--,argv++) {
282 if (argv[0][0] != '-' || !argv[0][1])
286 validarg = " PHOOEY ";
309 if (s = moreswitches(s))
314 if (euid != uid || egid != gid)
315 croak("No -e allowed in setuid scripts");
317 e_tmpname = savepv(TMPPATH);
318 (void)mktemp(e_tmpname);
320 croak("Can't mktemp()");
321 e_fp = fopen(e_tmpname,"w");
323 croak("Cannot open temporary file");
329 (void)putc('\n', e_fp);
337 av_push(GvAVn(incgv),newSVpv(s,0));
340 av_push(GvAVn(incgv),newSVpv(argv[1],0));
341 sv_catpv(sv,argv[1]);
368 croak("Unrecognized switch: -%s",s);
372 scriptname = argv[0];
374 if (fflush(e_fp) || ferror(e_fp) || fclose(e_fp))
375 croak("Can't write to temp file for -e: %s", Strerror(errno));
377 scriptname = e_tmpname;
379 else if (scriptname == Nullch) {
381 if ( isatty(fileno(stdin)) )
389 open_script(scriptname,dosearch,sv);
391 validate_suid(validarg);
398 av_push(comppad, Nullsv);
399 curpad = AvARRAY(comppad);
401 comppad_name = padname;
402 comppad_name_fill = 0;
403 min_intro_pending = 0;
407 (*xsinit)(); /* in case linked C routines want magical variables */
409 init_predump_symbols();
411 init_postdump_symbols(argc,argv,env);
415 /* now parse the script */
418 if (yyparse() || error_count) {
420 croak("%s had compilation errors.\n", origfilename);
422 croak("Execution of %s aborted due to compilation errors.\n",
426 curcop->cop_line = 0;
431 (void)UNLINK(e_tmpname);
434 /* now that script is parsed, we can modify record separator */
439 rspara = (nrslen == 2);
440 sv_setpvn(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), rs, rslen);
457 PerlInterpreter *sv_interp;
459 if (!(curinterp = sv_interp))
461 switch (setjmp(top_env)) {
463 cxstack_ix = -1; /* start context stack again */
470 return(statusvalue); /* my_exit() was called */
473 fprintf(stderr, "panic: restartop\n");
477 if (stack != mainstack) {
479 SWITCHSTACK(stack, mainstack);
486 DEBUG(fprintf(stderr,"\nEXECUTING...\n\n"));
489 fprintf(stderr,"%s syntax OK\n", origfilename);
492 if (perldb && DBsingle)
493 sv_setiv(DBsingle, 1);
503 else if (main_start) {
516 register CONTEXT *cx;
520 statusvalue = (unsigned short)(status & 0xffff);
521 if (cxstack_ix >= 0) {
531 perl_get_sv(name, create)
535 GV* gv = gv_fetchpv(name, create, SVt_PV);
542 perl_get_av(name, create)
546 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
555 perl_get_hv(name, create)
559 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
568 perl_get_cv(name, create)
572 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
573 if (create && !GvCV(gv))
574 return newSUB(start_subparse(),
575 newSVOP(OP_CONST, 0, newSVpv(name,0)),
582 /* Be sure to refetch the stack pointer after calling these routines. */
585 perl_call_argv(subname, flags, argv)
587 I32 flags; /* See G_* flags in cop.h */
588 register char **argv; /* null terminated arg list */
595 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
600 return perl_call_pv(subname, flags);
604 perl_call_pv(subname, flags)
605 char *subname; /* name of the subroutine */
606 I32 flags; /* See G_* flags in cop.h */
608 return perl_call_sv((SV*)perl_get_cv(subname, TRUE), flags);
612 perl_call_method(methname, flags)
613 char *methname; /* name of the subroutine */
614 I32 flags; /* See G_* flags in cop.h */
620 XPUSHs(sv_2mortal(newSVpv(methname,0)));
623 return perl_call_sv(*stack_sp--, flags);
626 /* May be called with any of a CV, a GV, or an SV containing the name. */
628 perl_call_sv(sv, flags)
630 I32 flags; /* See G_* flags in cop.h */
632 LOGOP myop; /* fake syntax tree node */
634 I32 oldmark = TOPMARK;
639 if (flags & G_DISCARD) {
649 oldscope = scopestack_ix;
651 if (!(flags & G_NOARGS))
652 myop.op_flags = OPf_STACKED;
653 myop.op_next = Nullop;
654 myop.op_flags |= OPf_KNOW;
656 myop.op_flags |= OPf_LIST;
658 if (flags & G_EVAL) {
659 Copy(top_env, oldtop, 1, jmp_buf);
661 cLOGOP->op_other = op;
667 switch (setjmp(top_env)) {
671 statusvalue = 255; /* XXX I don't think we use 1 anymore. */
674 /* my_exit() was called */
677 Copy(oldtop, top_env, 1, jmp_buf);
679 croak("Callback called exit");
680 my_exit(statusvalue);
688 stack_sp = stack_base + oldmark;
693 *++stack_sp = &sv_undef;
699 if (op == (OP*)&myop)
703 retval = stack_sp - (stack_base + oldmark);
705 sv_setpv(GvSV(gv_fetchpv("@",TRUE, SVt_PV)),"");
708 if (flags & G_EVAL) {
709 if (scopestack_ix > oldscope) {
713 register CONTEXT *cx;
722 Copy(oldtop, top_env, 1, jmp_buf);
724 if (flags & G_DISCARD) {
725 stack_sp = stack_base + oldmark;
733 /* Older forms, here grandfathered. */
737 perl_callargv(subname, spix, gimme, argv)
739 register I32 spix; /* current stack pointer index */
740 I32 gimme; /* See G_* flags in cop.h */
741 register char **argv; /* null terminated arg list, NULL for no arglist */
743 stack_sp = stack_base + spix;
744 return spix + perl_call_argv(subname, gimme, argv);
748 perl_callpv(subname, spix, gimme, hasargs, numargs)
750 I32 spix; /* stack pointer index after args are pushed */
751 I32 gimme; /* See G_* flags in cop.h */
752 I32 hasargs; /* whether to create a @_ array for routine */
753 I32 numargs; /* how many args are pushed on the stack */
755 stack_sp = stack_base + spix;
756 PUSHMARK(stack_sp - numargs);
757 return spix - numargs + perl_call_sv((SV*)perl_get_cv(subname, TRUE),
758 gimme, hasargs, numargs);
762 perl_callsv(sv, spix, gimme, hasargs, numargs)
764 I32 spix; /* stack pointer index after args are pushed */
765 I32 gimme; /* See G_* flags in cop.h */
766 I32 hasargs; /* whether to create a @_ array for routine */
767 I32 numargs; /* how many args are pushed on the stack */
769 stack_sp = stack_base + spix;
770 PUSHMARK(stack_sp - numargs);
771 return spix - numargs + perl_call_sv(sv, gimme, hasargs, numargs);
775 /* Require a module. */
781 UNOP myop; /* fake syntax tree node */
794 myop.op_type = OP_REQUIRE;
795 myop.op_next = Nullop;
797 myop.op_flags = OPf_KNOW;
800 if (op = pp_require())
808 magicname(sym,name,namlen)
815 if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
816 sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
820 #define PERLLIB_SEP ';'
822 #define PERLLIB_SEP ':'
834 /* Break at all separators */
836 /* First, skip any consecutive separators */
837 while ( *p == PERLLIB_SEP ) {
838 /* Uncomment the next line for PATH semantics */
839 /* av_push(GvAVn(incgv), newSVpv(".", 1)); */
842 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
843 av_push(GvAVn(incgv), newSVpv(p, (STRLEN)(s - p)));
846 av_push(GvAVn(incgv), newSVpv(p, 0));
852 /* This routine handles any switches that can be given during run */
862 nrschar = scan_oct(s, 4, &numlen);
863 nrs = savepvn("\n",1);
865 if (nrschar > 0377) {
869 else if (!nrschar && numlen >= 2) {
877 splitstr = savepv(s + 1);
900 static char debopts[] = "psltocPmfrxuLHXD";
903 for (s++; *s && (d = strchr(debopts,*s)); s++)
904 debug |= 1 << (d - debopts);
908 for (s++; isDIGIT(*s); s++) ;
912 warn("Recompile perl with -DDEBUGGING to use -D switch\n");
913 for (s++; isALNUM(*s); s++) ;
920 inplace = savepv(s+1);
922 for (s = inplace; *s && !isSPACE(*s); s++) ;
928 av_push(GvAVn(incgv),newSVpv(s,0));
931 croak("No space allowed after -I");
941 *ors = scan_oct(s, 3 + (*s == '0'), &numlen);
945 ors = savepvn(nrs,nrslen);
975 printf("\nThis is perl, version %s\n\n",patchlevel);
976 fputs("\nCopyright 1987-1994, Larry Wall\n",stdout);
978 fputs("MS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n",
981 fputs("OS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n",
986 fputs("atariST series port, ++jrb bammi@cadence.com\n", stdout);
989 Perl may be copied only under the terms of either the Artistic License or the\n\
990 GNU General Public License, which may be found in the Perl 5.0 source kit.\n",stdout);
1001 if (s[1] == '-') /* Additional switches on #! line. */
1014 croak("Can't emulate -%.1s on #! line",s);
1019 /* compliments of Tom Christiansen */
1021 /* unexec() can be found in the Gnu emacs distribution */
1030 sprintf (buf, "%s.perldump", origfilename);
1031 sprintf (tokenbuf, "%s/perl", BIN);
1033 status = unexec(buf, tokenbuf, &etext, sbrk(0), 0);
1035 fprintf(stderr, "unexec of %s into %s failed!\n", tokenbuf, buf);
1038 ABORT(); /* for use with undump */
1046 curstash = defstash = newHV();
1047 curstname = newSVpv("main",4);
1048 GvHV(gv = gv_fetchpv("main::",TRUE, SVt_PVHV)) =
1049 (HV*)SvREFCNT_inc(defstash);
1051 HvNAME(defstash) = savepv("main");
1052 incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
1054 defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
1055 curstash = defstash;
1056 compiling.cop_stash = defstash;
1058 GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV)) = debstash;
1061 #ifdef CAN_PROTOTYPE
1063 open_script(char *scriptname, bool dosearch, SV *sv)
1066 open_script(scriptname,dosearch,sv)
1072 char *xfound = Nullch;
1073 char *xfailed = Nullch;
1077 if (dosearch && !strchr(scriptname, '/') && (s = getenv("PATH"))) {
1079 bufend = s + strlen(s);
1082 s = cpytill(tokenbuf,s,bufend,':',&len);
1085 for (len = 0; *s && *s != ',' && *s != ';'; tokenbuf[len++] = *s++);
1086 tokenbuf[len] = '\0';
1088 for (len = 0; *s && *s != ';'; tokenbuf[len++] = *s++);
1089 tokenbuf[len] = '\0';
1095 if (len && tokenbuf[len-1] != '/')
1098 if (len && ((tokenbuf[len-1] != '\\') && (tokenbuf[len-1] != '/')))
1100 if (len && tokenbuf[len-1] != '\\')
1103 (void)strcat(tokenbuf+len,"/");
1104 (void)strcat(tokenbuf+len,scriptname);
1105 DEBUG_p(fprintf(stderr,"Looking for %s\n",tokenbuf));
1106 if (Stat(tokenbuf,&statbuf) < 0) /* not there? */
1108 if (S_ISREG(statbuf.st_mode)
1109 && cando(S_IRUSR,TRUE,&statbuf) && cando(S_IXUSR,TRUE,&statbuf)) {
1110 xfound = tokenbuf; /* bingo! */
1114 xfailed = savepv(tokenbuf);
1117 croak("Can't execute %s", xfailed ? xfailed : scriptname );
1120 scriptname = xfound;
1123 origfilename = savepv(e_fp ? "-e" : scriptname);
1124 curcop->cop_filegv = gv_fetchfile(origfilename);
1125 if (strEQ(origfilename,"-"))
1128 char *cpp = CPPSTDIN;
1130 if (strEQ(cpp,"cppstdin"))
1131 sprintf(tokenbuf, "%s/%s", SCRIPTDIR, cpp);
1133 sprintf(tokenbuf, "%s", cpp);
1135 sv_catpv(sv,PRIVLIB);
1137 (void)sprintf(buf, "\
1138 sed %s -e \"/^[^#]/b\" \
1139 -e \"/^#[ ]*include[ ]/b\" \
1140 -e \"/^#[ ]*define[ ]/b\" \
1141 -e \"/^#[ ]*if[ ]/b\" \
1142 -e \"/^#[ ]*ifdef[ ]/b\" \
1143 -e \"/^#[ ]*ifndef[ ]/b\" \
1144 -e \"/^#[ ]*else/b\" \
1145 -e \"/^#[ ]*elif[ ]/b\" \
1146 -e \"/^#[ ]*undef[ ]/b\" \
1147 -e \"/^#[ ]*endif/b\" \
1150 (doextract ? "-e \"1,/^#/d\n\"" : ""),
1152 (void)sprintf(buf, "\
1153 %s %s -e '/^[^#]/b' \
1154 -e '/^#[ ]*include[ ]/b' \
1155 -e '/^#[ ]*define[ ]/b' \
1156 -e '/^#[ ]*if[ ]/b' \
1157 -e '/^#[ ]*ifdef[ ]/b' \
1158 -e '/^#[ ]*ifndef[ ]/b' \
1159 -e '/^#[ ]*else/b' \
1160 -e '/^#[ ]*elif[ ]/b' \
1161 -e '/^#[ ]*undef[ ]/b' \
1162 -e '/^#[ ]*endif/b' \
1170 (doextract ? "-e '1,/^#/d\n'" : ""),
1172 scriptname, tokenbuf, SvPV(sv, na), CPPMINUS);
1174 #ifdef IAMSUID /* actually, this is caught earlier */
1175 if (euid != uid && !euid) { /* if running suidperl */
1177 (void)seteuid(uid); /* musn't stay setuid root */
1180 (void)setreuid((Uid_t)-1, uid);
1182 #ifdef HAS_SETRESUID
1183 (void)setresuid((Uid_t)-1, uid, (Uid_t)-1);
1189 if (geteuid() != uid)
1190 croak("Can't do seteuid!\n");
1192 #endif /* IAMSUID */
1193 rsfp = my_popen(buf,"r");
1195 else if (!*scriptname) {
1196 taint_not("program input from stdin");
1200 rsfp = fopen(scriptname,"r");
1201 if ((FILE*)rsfp == Nullfp) {
1203 #ifndef IAMSUID /* in case script is not readable before setuid */
1204 if (euid && Stat(SvPVX(GvSV(curcop->cop_filegv)),&statbuf) >= 0 &&
1205 statbuf.st_mode & (S_ISUID|S_ISGID)) {
1206 (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel);
1207 execv(buf, origargv); /* try again */
1208 croak("Can't do setuid\n");
1212 croak("Can't open perl script \"%s\": %s\n",
1213 SvPVX(GvSV(curcop->cop_filegv)), Strerror(errno));
1218 validate_suid(validarg)
1221 /* do we need to emulate setuid on scripts? */
1223 /* This code is for those BSD systems that have setuid #! scripts disabled
1224 * in the kernel because of a security problem. Merely defining DOSUID
1225 * in perl will not fix that problem, but if you have disabled setuid
1226 * scripts in the kernel, this will attempt to emulate setuid and setgid
1227 * on scripts that have those now-otherwise-useless bits set. The setuid
1228 * root version must be called suidperl or sperlN.NNN. If regular perl
1229 * discovers that it has opened a setuid script, it calls suidperl with
1230 * the same argv that it had. If suidperl finds that the script it has
1231 * just opened is NOT setuid root, it sets the effective uid back to the
1232 * uid. We don't just make perl setuid root because that loses the
1233 * effective uid we had before invoking perl, if it was different from the
1236 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
1237 * be defined in suidperl only. suidperl must be setuid root. The
1238 * Configure script will set this up for you if you want it.
1244 if (Fstat(fileno(rsfp),&statbuf) < 0) /* normal stat is insecure */
1245 croak("Can't stat script \"%s\"",origfilename);
1246 if (statbuf.st_mode & (S_ISUID|S_ISGID)) {
1250 #ifndef HAS_SETREUID
1251 /* On this access check to make sure the directories are readable,
1252 * there is actually a small window that the user could use to make
1253 * filename point to an accessible directory. So there is a faint
1254 * chance that someone could execute a setuid script down in a
1255 * non-accessible directory. I don't know what to do about that.
1256 * But I don't think it's too important. The manual lies when
1257 * it says access() is useful in setuid programs.
1259 if (access(SvPVX(GvSV(curcop->cop_filegv)),1)) /*double check*/
1260 croak("Permission denied");
1262 /* If we can swap euid and uid, then we can determine access rights
1263 * with a simple stat of the file, and then compare device and
1264 * inode to make sure we did stat() on the same file we opened.
1265 * Then we just have to make sure he or she can execute it.
1268 struct stat tmpstatbuf;
1272 setreuid(euid,uid) < 0
1275 setresuid(euid,uid,(Uid_t)-1) < 0
1278 || getuid() != euid || geteuid() != uid)
1279 croak("Can't swap uid and euid"); /* really paranoid */
1280 if (Stat(SvPVX(GvSV(curcop->cop_filegv)),&tmpstatbuf) < 0)
1281 croak("Permission denied"); /* testing full pathname here */
1282 if (tmpstatbuf.st_dev != statbuf.st_dev ||
1283 tmpstatbuf.st_ino != statbuf.st_ino) {
1285 if (rsfp = my_popen("/bin/mail root","w")) { /* heh, heh */
1287 "User %d tried to run dev %d ino %d in place of dev %d ino %d!\n\
1288 (Filename of set-id script was %s, uid %d gid %d.)\n\nSincerely,\nperl\n",
1289 uid,tmpstatbuf.st_dev, tmpstatbuf.st_ino,
1290 statbuf.st_dev, statbuf.st_ino,
1291 SvPVX(GvSV(curcop->cop_filegv)),
1292 statbuf.st_uid, statbuf.st_gid);
1293 (void)my_pclose(rsfp);
1295 croak("Permission denied\n");
1299 setreuid(uid,euid) < 0
1301 # if defined(HAS_SETRESUID)
1302 setresuid(uid,euid,(Uid_t)-1) < 0
1305 || getuid() != uid || geteuid() != euid)
1306 croak("Can't reswap uid and euid");
1307 if (!cando(S_IXUSR,FALSE,&statbuf)) /* can real uid exec? */
1308 croak("Permission denied\n");
1310 #endif /* HAS_SETREUID */
1311 #endif /* IAMSUID */
1313 if (!S_ISREG(statbuf.st_mode))
1314 croak("Permission denied");
1315 if (statbuf.st_mode & S_IWOTH)
1316 croak("Setuid/gid script is writable by world");
1317 doswitches = FALSE; /* -s is insecure in suid */
1319 if (fgets(tokenbuf,sizeof tokenbuf, rsfp) == Nullch ||
1320 strnNE(tokenbuf,"#!",2) ) /* required even on Sys V */
1321 croak("No #! line");
1324 while (!isSPACE(*s)) s++;
1325 if (strnNE(s-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
1326 croak("Not a perl script");
1327 while (*s == ' ' || *s == '\t') s++;
1329 * #! arg must be what we saw above. They can invoke it by
1330 * mentioning suidperl explicitly, but they may not add any strange
1331 * arguments beyond what #! says if they do invoke suidperl that way.
1333 len = strlen(validarg);
1334 if (strEQ(validarg," PHOOEY ") ||
1335 strnNE(s,validarg,len) || !isSPACE(s[len]))
1336 croak("Args must match #! line");
1339 if (euid != uid && (statbuf.st_mode & S_ISUID) &&
1340 euid == statbuf.st_uid)
1342 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
1343 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
1344 #endif /* IAMSUID */
1346 if (euid) { /* oops, we're not the setuid root perl */
1349 (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel);
1350 execv(buf, origargv); /* try again */
1352 croak("Can't do setuid\n");
1355 if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid) {
1357 (void)setegid(statbuf.st_gid);
1360 (void)setregid((Gid_t)-1,statbuf.st_gid);
1362 #ifdef HAS_SETRESGID
1363 (void)setresgid((Gid_t)-1,statbuf.st_gid,(Gid_t)-1);
1365 setgid(statbuf.st_gid);
1369 if (getegid() != statbuf.st_gid)
1370 croak("Can't do setegid!\n");
1372 if (statbuf.st_mode & S_ISUID) {
1373 if (statbuf.st_uid != euid)
1375 (void)seteuid(statbuf.st_uid); /* all that for this */
1378 (void)setreuid((Uid_t)-1,statbuf.st_uid);
1380 #ifdef HAS_SETRESUID
1381 (void)setresuid((Uid_t)-1,statbuf.st_uid,(Uid_t)-1);
1383 setuid(statbuf.st_uid);
1387 if (geteuid() != statbuf.st_uid)
1388 croak("Can't do seteuid!\n");
1390 else if (uid) { /* oops, mustn't run as root */
1392 (void)seteuid((Uid_t)uid);
1395 (void)setreuid((Uid_t)-1,(Uid_t)uid);
1397 #ifdef HAS_SETRESUID
1398 (void)setresuid((Uid_t)-1,(Uid_t)uid,(Uid_t)-1);
1404 if (geteuid() != uid)
1405 croak("Can't do seteuid!\n");
1407 uid = (int)getuid();
1408 euid = (int)geteuid();
1409 gid = (int)getgid();
1410 egid = (int)getegid();
1411 tainting |= (euid != uid || egid != gid);
1412 if (!cando(S_IXUSR,TRUE,&statbuf))
1413 croak("Permission denied\n"); /* they can't do this */
1416 else if (preprocess)
1417 croak("-P not allowed for setuid/setgid script\n");
1419 croak("Script is not setuid/setgid in suidperl\n");
1420 #endif /* IAMSUID */
1422 if (euid != uid || egid != gid) { /* (suidperl doesn't exist, in fact) */
1423 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
1424 Fstat(fileno(rsfp),&statbuf); /* may be either wrapped or real suid */
1425 if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
1427 (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
1430 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
1431 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
1432 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
1433 /* not set-id, must be wrapped */
1443 /* skip forward in input to the real script? */
1447 if ((s = sv_gets(linestr, rsfp, 0)) == Nullch)
1448 croak("No Perl script found in input\n");
1449 if (*s == '#' && s[1] == '!' && instr(s,"perl")) {
1450 ungetc('\n',rsfp); /* to keep line count right */
1452 if (s = instr(s,"perl -")) {
1455 while (s = moreswitches(s)) ;
1457 if (cddir && chdir(cddir) < 0)
1458 croak("Can't chdir to %s",cddir);
1468 curstash = debstash;
1469 dbargs = GvAV(gv_AVadd((tmpgv = gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
1471 DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
1472 DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
1473 DBsub = gv_HVadd(tmpgv = gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
1474 DBsingle = GvSV((tmpgv = gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
1475 DBtrace = GvSV((tmpgv = gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
1476 DBsignal = GvSV((tmpgv = gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
1477 curstash = defstash;
1484 mainstack = stack; /* remember in case we switch stacks */
1485 AvREAL_off(stack); /* not a real array */
1486 av_extend(stack,127);
1488 stack_base = AvARRAY(stack);
1489 stack_sp = stack_base;
1490 stack_max = stack_base + 127;
1492 New(54,markstack,64,I32);
1493 markstack_ptr = markstack;
1494 markstack_max = markstack + 64;
1496 New(54,scopestack,32,I32);
1498 scopestack_max = 32;
1500 New(54,savestack,128,ANY);
1502 savestack_max = 128;
1504 New(54,retstack,16,OP*);
1508 New(50,cxstack,128,CONTEXT);
1512 New(50,tmps_stack,128,SV*);
1517 New(51,debname,128,char);
1518 New(52,debdelim,128,char);
1522 static FILE *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
1530 subname = newSVpv("main",4);
1534 init_predump_symbols()
1539 sv_setpvn(GvSV(gv_fetchpv("\"", TRUE, SVt_PV)), " ", 1);
1541 stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
1542 SvMULTI_on(stdingv);
1543 IoIFP(GvIOp(stdingv)) = stdin;
1544 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PVIO);
1545 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(stdingv));
1548 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
1550 IoOFP(GvIOp(tmpgv)) = IoIFP(GvIOp(tmpgv)) = stdout;
1552 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PVIO);
1553 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(defoutgv));
1556 othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
1557 SvMULTI_on(othergv);
1558 IoOFP(GvIOp(othergv)) = IoIFP(GvIOp(othergv)) = stderr;
1559 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PVIO);
1560 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(othergv));
1563 statname = NEWSV(66,0); /* last filename we did stat on */
1567 init_postdump_symbols(argc,argv,env)
1569 register char **argv;
1570 register char **env;
1576 argc--,argv++; /* skip name of script */
1578 for (; argc > 0 && **argv == '-'; argc--,argv++) {
1581 if (argv[0][1] == '-') {
1585 if (s = strchr(argv[0], '=')) {
1587 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
1590 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
1593 toptarget = NEWSV(0,0);
1594 sv_upgrade(toptarget, SVt_PVFM);
1595 sv_setpvn(toptarget, "", 0);
1596 tmpgv = gv_fetchpv("\001",TRUE, SVt_PV);
1597 bodytarget = GvSV(tmpgv);
1598 sv_upgrade(bodytarget, SVt_PVFM);
1599 sv_setpvn(bodytarget, "", 0);
1600 formtarget = bodytarget;
1603 if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
1604 sv_setpv(GvSV(tmpgv),origfilename);
1605 magicname("0", "0", 1);
1607 if (tmpgv = gv_fetchpv("\024",TRUE, SVt_PV))
1609 if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
1610 sv_setpv(GvSV(tmpgv),origargv[0]);
1611 if (argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
1613 (void)gv_AVadd(argvgv);
1614 av_clear(GvAVn(argvgv));
1615 for (; argc > 0; argc--,argv++) {
1616 av_push(GvAVn(argvgv),newSVpv(argv[0],0));
1619 if (envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
1624 #ifndef VMS /* VMS doesn't have environ array */
1625 if (env != environ) {
1626 environ[0] = Nullch;
1627 hv_magic(hv, envgv, 'E');
1630 #ifdef DYNAMIC_ENV_FETCH
1631 HvNAME(hv) = savepv(ENV_HV_NAME);
1633 for (; *env; env++) {
1634 if (!(s = strchr(*env,'=')))
1637 sv = newSVpv(s--,0);
1638 sv_magic(sv, sv, 'e', *env, s - *env);
1639 (void)hv_store(hv, *env, s - *env, sv, 0);
1642 hv_magic(hv, envgv, 'E');
1645 if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
1646 sv_setiv(GvSV(tmpgv),(I32)getpid());
1655 s = getenv("PERL5LIB");
1659 incpush(getenv("PERLLIB"));
1666 #define PRIVLIB "/usr/local/lib/perl5:/usr/local/lib/perl"
1670 av_push(GvAVn(incgv),newSVpv(".",1));
1680 line_t oldline = curcop->cop_line;
1682 Copy(top_env, oldtop, 1, jmp_buf);
1684 while (AvFILL(list) >= 0) {
1685 CV *cv = (CV*)av_shift(list);
1689 switch (setjmp(top_env)) {
1692 perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
1693 mess = SvPVx(GvSV(gv_fetchpv("@",TRUE, SVt_PV)), len);
1695 Copy(oldtop, top_env, 1, jmp_buf);
1696 curcop = &compiling;
1697 curcop->cop_line = oldline;
1698 if (list == beginav)
1699 croak("%sBEGIN failed--compilation aborted", mess);
1701 croak("%sEND failed--cleanup aborted", mess);
1705 statusvalue = 255; /* XXX I don't think we use 1 anymore. */
1708 /* my_exit() was called */
1709 curstash = defstash;
1713 Copy(oldtop, top_env, 1, jmp_buf);
1714 curcop = &compiling;
1715 curcop->cop_line = oldline;
1717 if (list == beginav)
1718 croak("BEGIN failed--compilation aborted");
1720 croak("END failed--cleanup aborted");
1722 my_exit(statusvalue);
1727 fprintf(stderr, "panic: restartop\n");
1731 Copy(oldtop, top_env, 1, jmp_buf);
1732 curcop = &compiling;
1733 curcop->cop_line = oldline;
1734 longjmp(top_env, 3);
1738 Copy(oldtop, top_env, 1, jmp_buf);