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_ids _((void));
41 static void init_debugger _((void));
42 static void init_lexer _((void));
43 static void init_main_stash _((void));
44 static void init_perllib _((void));
45 static void init_postdump_symbols _((int, char **, char **));
46 static void init_predump_symbols _((void));
47 static void init_stacks _((void));
48 static void open_script _((char *, bool, SV *));
49 static void validate_suid _((char *));
54 PerlInterpreter *sv_interp;
57 New(53, sv_interp, 1, PerlInterpreter);
62 perl_construct( sv_interp )
63 register PerlInterpreter *sv_interp;
65 if (!(curinterp = sv_interp))
69 Zero(sv_interp, 1, PerlInterpreter);
72 /* Init the real globals? */
74 linestr = NEWSV(65,80);
75 sv_upgrade(linestr,SVt_PVIV);
77 SvREADONLY_on(&sv_undef);
81 SvREADONLY_on(&sv_no);
83 sv_setpv(&sv_yes,Yes);
85 SvREADONLY_on(&sv_yes);
89 * There is no way we can refer to them from Perl so close them to save
90 * space. The other alternative would be to provide STDAUX and STDPRN
119 sprintf(patchlevel, "%5.3f", 5.0 + (PATCHLEVEL / 1000.0));
121 fdpid = newAV(); /* for remembering popen pids by fd */
122 pidstatus = newHV();/* for remembering status of dead pids */
129 perl_destruct(sv_interp)
130 register PerlInterpreter *sv_interp;
132 int destruct_level; /* 0=none, 1=full, 2=full with checks */
136 if (!(curinterp = sv_interp))
139 destruct_level = perl_destruct_level;
144 /* We must account for everything. First the syntax tree. */
146 curpad = AvARRAY(comppad);
153 * Try to destruct global references. We do this first so that the
154 * destructors and destructees still exist. Some sv's might remain.
155 * Non-referenced objects are on their own.
162 if (destruct_level == 0){
164 DEBUG_P(debprofdump());
166 /* The exit() function will do everything that needs doing. */
170 /* Prepare to destruct main symbol table. */
176 if (destruct_level >= 2) {
177 if (scopestack_ix != 0)
178 warn("Unbalanced scopes: %d more ENTERs than LEAVEs\n", scopestack_ix);
179 if (savestack_ix != 0)
180 warn("Unbalanced saves: %d more saves than restores\n", savestack_ix);
181 if (tmps_floor != -1)
182 warn("Unbalanced tmps: %d more allocs than frees\n", tmps_floor + 1);
183 if (cxstack_ix != -1)
184 warn("Unbalanced context: %d more PUSHes than POPs\n", cxstack_ix + 1);
187 /* Now absolutely destruct everything, somehow or other, loops or no. */
189 while (sv_count != 0 && sv_count != last_sv_count) {
190 last_sv_count = sv_count;
194 warn("Scalars leaked: %d\n", sv_count);
196 DEBUG_P(debprofdump());
201 PerlInterpreter *sv_interp;
203 if (!(curinterp = sv_interp))
207 #if !defined(STANDARD_C) && !defined(HAS_GETENV_PROTOTYPE)
208 char *getenv _((char *)); /* Usually in <stdlib.h> */
212 perl_parse(sv_interp, xsinit, argc, argv, env)
213 PerlInterpreter *sv_interp;
214 void (*xsinit)_((void));
222 VOL bool dosearch = FALSE;
226 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
229 croak("suidperl is no longer needed since the kernel can now execute\n\
230 setuid perl scripts securely.\n");
234 if (!(curinterp = sv_interp))
239 #ifndef VMS /* VMS doesn't have environ array */
240 origenviron = environ;
245 /* Come here if running an undumped a.out. */
247 origfilename = savepv(argv[0]);
249 cxstack_ix = -1; /* start label stack again */
251 init_postdump_symbols(argc,argv,env);
259 switch (setjmp(top_env)) {
270 return(statusvalue); /* my_exit() was called */
272 fprintf(stderr, "panic: top_env\n");
276 sv_setpvn(linestr,"",0);
277 sv = newSVpv("",0); /* first used for -I flags */
280 for (argc--,argv++; argc > 0; argc--,argv++) {
281 if (argv[0][0] != '-' || !argv[0][1])
285 validarg = " PHOOEY ";
308 if (s = moreswitches(s))
313 if (euid != uid || egid != gid)
314 croak("No -e allowed in setuid scripts");
316 e_tmpname = savepv(TMPPATH);
317 (void)mktemp(e_tmpname);
319 croak("Can't mktemp()");
320 e_fp = fopen(e_tmpname,"w");
322 croak("Cannot open temporary file");
328 (void)putc('\n', e_fp);
336 av_push(GvAVn(incgv),newSVpv(s,0));
339 av_push(GvAVn(incgv),newSVpv(argv[1],0));
340 sv_catpv(sv,argv[1]);
367 croak("Unrecognized switch: -%s",s);
371 scriptname = argv[0];
373 if (fflush(e_fp) || ferror(e_fp) || fclose(e_fp))
374 croak("Can't write to temp file for -e: %s", Strerror(errno));
376 scriptname = e_tmpname;
378 else if (scriptname == Nullch) {
380 if ( isatty(fileno(stdin)) )
388 open_script(scriptname,dosearch,sv);
390 validate_suid(validarg);
395 compcv = (CV*)NEWSV(1104,0);
396 sv_upgrade((SV *)compcv, SVt_PVCV);
400 av_push(comppad, Nullsv);
401 curpad = AvARRAY(comppad);
403 comppad_name = padname;
404 comppad_name_fill = 0;
405 min_intro_pending = 0;
408 comppadlist = newAV();
409 AvREAL_off(comppadlist);
410 av_store(comppadlist, 0, SvREFCNT_inc((SV*)comppad_name));
411 av_store(comppadlist, 1, SvREFCNT_inc((SV*)comppad));
412 CvPADLIST(compcv) = comppadlist;
415 (*xsinit)(); /* in case linked C routines want magical variables */
420 init_predump_symbols();
422 init_postdump_symbols(argc,argv,env);
426 /* now parse the script */
429 if (yyparse() || error_count) {
431 croak("%s had compilation errors.\n", origfilename);
433 croak("Execution of %s aborted due to compilation errors.\n",
437 curcop->cop_line = 0;
442 (void)UNLINK(e_tmpname);
445 /* now that script is parsed, we can modify record separator */
450 rspara = (nrslen == 2);
451 sv_setpvn(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), rs, rslen);
468 PerlInterpreter *sv_interp;
470 if (!(curinterp = sv_interp))
472 switch (setjmp(top_env)) {
474 cxstack_ix = -1; /* start context stack again */
481 return(statusvalue); /* my_exit() was called */
484 fprintf(stderr, "panic: restartop\n");
488 if (stack != mainstack) {
490 SWITCHSTACK(stack, mainstack);
497 DEBUG(fprintf(stderr,"\nEXECUTING...\n\n"));
500 fprintf(stderr,"%s syntax OK\n", origfilename);
503 if (perldb && DBsingle)
504 sv_setiv(DBsingle, 1);
514 else if (main_start) {
527 register CONTEXT *cx;
531 statusvalue = FIXSTATUS(status);
532 if (cxstack_ix >= 0) {
542 perl_get_sv(name, create)
546 GV* gv = gv_fetchpv(name, create, SVt_PV);
553 perl_get_av(name, create)
557 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
566 perl_get_hv(name, create)
570 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
579 perl_get_cv(name, create)
583 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
584 if (create && !GvCV(gv))
585 return newSUB(start_subparse(),
586 newSVOP(OP_CONST, 0, newSVpv(name,0)),
593 /* Be sure to refetch the stack pointer after calling these routines. */
596 perl_call_argv(subname, flags, argv)
598 I32 flags; /* See G_* flags in cop.h */
599 register char **argv; /* null terminated arg list */
606 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
611 return perl_call_pv(subname, flags);
615 perl_call_pv(subname, flags)
616 char *subname; /* name of the subroutine */
617 I32 flags; /* See G_* flags in cop.h */
619 return perl_call_sv((SV*)perl_get_cv(subname, TRUE), flags);
623 perl_call_method(methname, flags)
624 char *methname; /* name of the subroutine */
625 I32 flags; /* See G_* flags in cop.h */
631 XPUSHs(sv_2mortal(newSVpv(methname,0)));
634 return perl_call_sv(*stack_sp--, flags);
637 /* May be called with any of a CV, a GV, or an SV containing the name. */
639 perl_call_sv(sv, flags)
641 I32 flags; /* See G_* flags in cop.h */
643 LOGOP myop; /* fake syntax tree node */
645 I32 oldmark = TOPMARK;
650 if (flags & G_DISCARD) {
660 oldscope = scopestack_ix;
662 if (!(flags & G_NOARGS))
663 myop.op_flags = OPf_STACKED;
664 myop.op_next = Nullop;
665 myop.op_flags |= OPf_KNOW;
667 myop.op_flags |= OPf_LIST;
669 if (flags & G_EVAL) {
670 Copy(top_env, oldtop, 1, jmp_buf);
672 cLOGOP->op_other = op;
678 switch (setjmp(top_env)) {
683 statusvalue = 255; /* XXX I don't think we use 1 anymore. */
689 /* my_exit() was called */
692 Copy(oldtop, top_env, 1, jmp_buf);
694 croak("Callback called exit");
695 my_exit(statusvalue);
703 stack_sp = stack_base + oldmark;
708 *++stack_sp = &sv_undef;
714 if (op == (OP*)&myop)
718 retval = stack_sp - (stack_base + oldmark);
720 sv_setpv(GvSV(gv_fetchpv("@",TRUE, SVt_PV)),"");
723 if (flags & G_EVAL) {
724 if (scopestack_ix > oldscope) {
728 register CONTEXT *cx;
737 Copy(oldtop, top_env, 1, jmp_buf);
739 if (flags & G_DISCARD) {
740 stack_sp = stack_base + oldmark;
748 /* Older forms, here grandfathered. */
752 perl_callargv(subname, spix, gimme, argv)
754 register I32 spix; /* current stack pointer index */
755 I32 gimme; /* See G_* flags in cop.h */
756 register char **argv; /* null terminated arg list, NULL for no arglist */
758 stack_sp = stack_base + spix;
759 return spix + perl_call_argv(subname, gimme, argv);
763 perl_callpv(subname, spix, gimme, hasargs, numargs)
765 I32 spix; /* stack pointer index after args are pushed */
766 I32 gimme; /* See G_* flags in cop.h */
767 I32 hasargs; /* whether to create a @_ array for routine */
768 I32 numargs; /* how many args are pushed on the stack */
770 stack_sp = stack_base + spix;
771 PUSHMARK(stack_sp - numargs);
772 return spix - numargs + perl_call_sv((SV*)perl_get_cv(subname, TRUE),
773 gimme, hasargs, numargs);
777 perl_callsv(sv, spix, gimme, hasargs, numargs)
779 I32 spix; /* stack pointer index after args are pushed */
780 I32 gimme; /* See G_* flags in cop.h */
781 I32 hasargs; /* whether to create a @_ array for routine */
782 I32 numargs; /* how many args are pushed on the stack */
784 stack_sp = stack_base + spix;
785 PUSHMARK(stack_sp - numargs);
786 return spix - numargs + perl_call_sv(sv, gimme, hasargs, numargs);
790 /* Require a module. */
796 UNOP myop; /* fake syntax tree node */
809 myop.op_type = OP_REQUIRE;
810 myop.op_next = Nullop;
812 myop.op_flags = OPf_KNOW;
815 if (op = pp_require())
823 magicname(sym,name,namlen)
830 if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
831 sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
835 # define PERLLIB_SEP ';'
838 # define PERLLIB_SEP '|'
840 # define PERLLIB_SEP ':'
853 /* Break at all separators */
855 /* First, skip any consecutive separators */
856 while ( *p == PERLLIB_SEP ) {
857 /* Uncomment the next line for PATH semantics */
858 /* av_push(GvAVn(incgv), newSVpv(".", 1)); */
861 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
862 av_push(GvAVn(incgv), newSVpv(p, (STRLEN)(s - p)));
865 av_push(GvAVn(incgv), newSVpv(p, 0));
871 /* This routine handles any switches that can be given during run */
881 nrschar = scan_oct(s, 4, &numlen);
882 nrs = savepvn("\n",1);
884 if (nrschar > 0377) {
888 else if (!nrschar && numlen >= 2) {
896 splitstr = savepv(s + 1);
919 static char debopts[] = "psltocPmfrxuLHXD";
922 for (s++; *s && (d = strchr(debopts,*s)); s++)
923 debug |= 1 << (d - debopts);
927 for (s++; isDIGIT(*s); s++) ;
931 warn("Recompile perl with -DDEBUGGING to use -D switch\n");
932 for (s++; isALNUM(*s); s++) ;
939 inplace = savepv(s+1);
941 for (s = inplace; *s && !isSPACE(*s); s++) ;
948 for (e = s; *e && !isSPACE(*e); e++) ;
949 av_push(GvAVn(incgv),newSVpv(s,e-s));
954 croak("No space allowed after -I");
964 *ors = scan_oct(s, 3 + (*s == '0'), &numlen);
968 ors = savepvn(nrs,nrslen);
998 printf("\nThis is perl, version %s\n\n",patchlevel);
999 fputs("\tUnofficial patchlevel 1j.\n",stdout);
1000 fputs("\nCopyright 1987-1994, Larry Wall\n",stdout);
1002 fputs("MS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n",
1005 fputs("OS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n",
1010 fputs("atariST series port, ++jrb bammi@cadence.com\n", stdout);
1013 Perl may be copied only under the terms of either the Artistic License or the\n\
1014 GNU General Public License, which may be found in the Perl 5.0 source kit.\n",stdout);
1025 if (s[1] == '-') /* Additional switches on #! line. */
1038 croak("Can't emulate -%.1s on #! line",s);
1043 /* compliments of Tom Christiansen */
1045 /* unexec() can be found in the Gnu emacs distribution */
1054 sprintf (buf, "%s.perldump", origfilename);
1055 sprintf (tokenbuf, "%s/perl", BIN);
1057 status = unexec(buf, tokenbuf, &etext, sbrk(0), 0);
1059 fprintf(stderr, "unexec of %s into %s failed!\n", tokenbuf, buf);
1062 ABORT(); /* for use with undump */
1070 curstash = defstash = newHV();
1071 curstname = newSVpv("main",4);
1072 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
1073 SvREFCNT_dec(GvHV(gv));
1074 GvHV(gv) = (HV*)SvREFCNT_inc(defstash);
1076 HvNAME(defstash) = savepv("main");
1077 incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
1079 defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
1080 curstash = defstash;
1081 compiling.cop_stash = defstash;
1082 debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
1085 #ifdef CAN_PROTOTYPE
1087 open_script(char *scriptname, bool dosearch, SV *sv)
1090 open_script(scriptname,dosearch,sv)
1096 char *xfound = Nullch;
1097 char *xfailed = Nullch;
1101 if (dosearch && !strchr(scriptname, '/') && (s = getenv("PATH"))) {
1103 bufend = s + strlen(s);
1106 s = cpytill(tokenbuf,s,bufend,':',&len);
1109 for (len = 0; *s && *s != ',' && *s != ';'; tokenbuf[len++] = *s++);
1110 tokenbuf[len] = '\0';
1112 for (len = 0; *s && *s != ';'; tokenbuf[len++] = *s++);
1113 tokenbuf[len] = '\0';
1119 if (len && tokenbuf[len-1] != '/')
1122 if (len && ((tokenbuf[len-1] != '\\') && (tokenbuf[len-1] != '/')))
1124 if (len && tokenbuf[len-1] != '\\')
1127 (void)strcat(tokenbuf+len,"/");
1128 (void)strcat(tokenbuf+len,scriptname);
1129 DEBUG_p(fprintf(stderr,"Looking for %s\n",tokenbuf));
1130 if (Stat(tokenbuf,&statbuf) < 0) /* not there? */
1132 if (S_ISREG(statbuf.st_mode)
1133 && cando(S_IRUSR,TRUE,&statbuf) && cando(S_IXUSR,TRUE,&statbuf)) {
1134 xfound = tokenbuf; /* bingo! */
1138 xfailed = savepv(tokenbuf);
1141 croak("Can't execute %s", xfailed ? xfailed : scriptname );
1144 scriptname = xfound;
1147 origfilename = savepv(e_fp ? "-e" : scriptname);
1148 curcop->cop_filegv = gv_fetchfile(origfilename);
1149 if (strEQ(origfilename,"-"))
1152 char *cpp = CPPSTDIN;
1154 if (strEQ(cpp,"cppstdin"))
1155 sprintf(tokenbuf, "%s/%s", SCRIPTDIR, cpp);
1157 sprintf(tokenbuf, "%s", cpp);
1159 sv_catpv(sv,PRIVLIB_EXP);
1161 (void)sprintf(buf, "\
1162 sed %s -e \"/^[^#]/b\" \
1163 -e \"/^#[ ]*include[ ]/b\" \
1164 -e \"/^#[ ]*define[ ]/b\" \
1165 -e \"/^#[ ]*if[ ]/b\" \
1166 -e \"/^#[ ]*ifdef[ ]/b\" \
1167 -e \"/^#[ ]*ifndef[ ]/b\" \
1168 -e \"/^#[ ]*else/b\" \
1169 -e \"/^#[ ]*elif[ ]/b\" \
1170 -e \"/^#[ ]*undef[ ]/b\" \
1171 -e \"/^#[ ]*endif/b\" \
1174 (doextract ? "-e \"1,/^#/d\n\"" : ""),
1176 (void)sprintf(buf, "\
1177 %s %s -e '/^[^#]/b' \
1178 -e '/^#[ ]*include[ ]/b' \
1179 -e '/^#[ ]*define[ ]/b' \
1180 -e '/^#[ ]*if[ ]/b' \
1181 -e '/^#[ ]*ifdef[ ]/b' \
1182 -e '/^#[ ]*ifndef[ ]/b' \
1183 -e '/^#[ ]*else/b' \
1184 -e '/^#[ ]*elif[ ]/b' \
1185 -e '/^#[ ]*undef[ ]/b' \
1186 -e '/^#[ ]*endif/b' \
1194 (doextract ? "-e '1,/^#/d\n'" : ""),
1196 scriptname, tokenbuf, SvPV(sv, na), CPPMINUS);
1198 #ifdef IAMSUID /* actually, this is caught earlier */
1199 if (euid != uid && !euid) { /* if running suidperl */
1201 (void)seteuid(uid); /* musn't stay setuid root */
1204 (void)setreuid((Uid_t)-1, uid);
1206 #ifdef HAS_SETRESUID
1207 (void)setresuid((Uid_t)-1, uid, (Uid_t)-1);
1213 if (geteuid() != uid)
1214 croak("Can't do seteuid!\n");
1216 #endif /* IAMSUID */
1217 rsfp = my_popen(buf,"r");
1219 else if (!*scriptname) {
1220 taint_not("program input from stdin");
1224 rsfp = fopen(scriptname,"r");
1225 if ((FILE*)rsfp == Nullfp) {
1227 #ifndef IAMSUID /* in case script is not readable before setuid */
1228 if (euid && Stat(SvPVX(GvSV(curcop->cop_filegv)),&statbuf) >= 0 &&
1229 statbuf.st_mode & (S_ISUID|S_ISGID)) {
1230 (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel);
1231 execv(buf, origargv); /* try again */
1232 croak("Can't do setuid\n");
1236 croak("Can't open perl script \"%s\": %s\n",
1237 SvPVX(GvSV(curcop->cop_filegv)), Strerror(errno));
1242 validate_suid(validarg)
1245 /* do we need to emulate setuid on scripts? */
1247 /* This code is for those BSD systems that have setuid #! scripts disabled
1248 * in the kernel because of a security problem. Merely defining DOSUID
1249 * in perl will not fix that problem, but if you have disabled setuid
1250 * scripts in the kernel, this will attempt to emulate setuid and setgid
1251 * on scripts that have those now-otherwise-useless bits set. The setuid
1252 * root version must be called suidperl or sperlN.NNN. If regular perl
1253 * discovers that it has opened a setuid script, it calls suidperl with
1254 * the same argv that it had. If suidperl finds that the script it has
1255 * just opened is NOT setuid root, it sets the effective uid back to the
1256 * uid. We don't just make perl setuid root because that loses the
1257 * effective uid we had before invoking perl, if it was different from the
1260 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
1261 * be defined in suidperl only. suidperl must be setuid root. The
1262 * Configure script will set this up for you if you want it.
1268 if (Fstat(fileno(rsfp),&statbuf) < 0) /* normal stat is insecure */
1269 croak("Can't stat script \"%s\"",origfilename);
1270 if (statbuf.st_mode & (S_ISUID|S_ISGID)) {
1274 #ifndef HAS_SETREUID
1275 /* On this access check to make sure the directories are readable,
1276 * there is actually a small window that the user could use to make
1277 * filename point to an accessible directory. So there is a faint
1278 * chance that someone could execute a setuid script down in a
1279 * non-accessible directory. I don't know what to do about that.
1280 * But I don't think it's too important. The manual lies when
1281 * it says access() is useful in setuid programs.
1283 if (access(SvPVX(GvSV(curcop->cop_filegv)),1)) /*double check*/
1284 croak("Permission denied");
1286 /* If we can swap euid and uid, then we can determine access rights
1287 * with a simple stat of the file, and then compare device and
1288 * inode to make sure we did stat() on the same file we opened.
1289 * Then we just have to make sure he or she can execute it.
1292 struct stat tmpstatbuf;
1296 setreuid(euid,uid) < 0
1299 setresuid(euid,uid,(Uid_t)-1) < 0
1302 || getuid() != euid || geteuid() != uid)
1303 croak("Can't swap uid and euid"); /* really paranoid */
1304 if (Stat(SvPVX(GvSV(curcop->cop_filegv)),&tmpstatbuf) < 0)
1305 croak("Permission denied"); /* testing full pathname here */
1306 if (tmpstatbuf.st_dev != statbuf.st_dev ||
1307 tmpstatbuf.st_ino != statbuf.st_ino) {
1309 if (rsfp = my_popen("/bin/mail root","w")) { /* heh, heh */
1311 "User %d tried to run dev %d ino %d in place of dev %d ino %d!\n\
1312 (Filename of set-id script was %s, uid %d gid %d.)\n\nSincerely,\nperl\n",
1313 uid,tmpstatbuf.st_dev, tmpstatbuf.st_ino,
1314 statbuf.st_dev, statbuf.st_ino,
1315 SvPVX(GvSV(curcop->cop_filegv)),
1316 statbuf.st_uid, statbuf.st_gid);
1317 (void)my_pclose(rsfp);
1319 croak("Permission denied\n");
1323 setreuid(uid,euid) < 0
1325 # if defined(HAS_SETRESUID)
1326 setresuid(uid,euid,(Uid_t)-1) < 0
1329 || getuid() != uid || geteuid() != euid)
1330 croak("Can't reswap uid and euid");
1331 if (!cando(S_IXUSR,FALSE,&statbuf)) /* can real uid exec? */
1332 croak("Permission denied\n");
1334 #endif /* HAS_SETREUID */
1335 #endif /* IAMSUID */
1337 if (!S_ISREG(statbuf.st_mode))
1338 croak("Permission denied");
1339 if (statbuf.st_mode & S_IWOTH)
1340 croak("Setuid/gid script is writable by world");
1341 doswitches = FALSE; /* -s is insecure in suid */
1343 if (fgets(tokenbuf,sizeof tokenbuf, rsfp) == Nullch ||
1344 strnNE(tokenbuf,"#!",2) ) /* required even on Sys V */
1345 croak("No #! line");
1348 while (!isSPACE(*s)) s++;
1349 if (strnNE(s-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
1350 croak("Not a perl script");
1351 while (*s == ' ' || *s == '\t') s++;
1353 * #! arg must be what we saw above. They can invoke it by
1354 * mentioning suidperl explicitly, but they may not add any strange
1355 * arguments beyond what #! says if they do invoke suidperl that way.
1357 len = strlen(validarg);
1358 if (strEQ(validarg," PHOOEY ") ||
1359 strnNE(s,validarg,len) || !isSPACE(s[len]))
1360 croak("Args must match #! line");
1363 if (euid != uid && (statbuf.st_mode & S_ISUID) &&
1364 euid == statbuf.st_uid)
1366 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
1367 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
1368 #endif /* IAMSUID */
1370 if (euid) { /* oops, we're not the setuid root perl */
1373 (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel);
1374 execv(buf, origargv); /* try again */
1376 croak("Can't do setuid\n");
1379 if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid) {
1381 (void)setegid(statbuf.st_gid);
1384 (void)setregid((Gid_t)-1,statbuf.st_gid);
1386 #ifdef HAS_SETRESGID
1387 (void)setresgid((Gid_t)-1,statbuf.st_gid,(Gid_t)-1);
1389 setgid(statbuf.st_gid);
1393 if (getegid() != statbuf.st_gid)
1394 croak("Can't do setegid!\n");
1396 if (statbuf.st_mode & S_ISUID) {
1397 if (statbuf.st_uid != euid)
1399 (void)seteuid(statbuf.st_uid); /* all that for this */
1402 (void)setreuid((Uid_t)-1,statbuf.st_uid);
1404 #ifdef HAS_SETRESUID
1405 (void)setresuid((Uid_t)-1,statbuf.st_uid,(Uid_t)-1);
1407 setuid(statbuf.st_uid);
1411 if (geteuid() != statbuf.st_uid)
1412 croak("Can't do seteuid!\n");
1414 else if (uid) { /* oops, mustn't run as root */
1416 (void)seteuid((Uid_t)uid);
1419 (void)setreuid((Uid_t)-1,(Uid_t)uid);
1421 #ifdef HAS_SETRESUID
1422 (void)setresuid((Uid_t)-1,(Uid_t)uid,(Uid_t)-1);
1428 if (geteuid() != uid)
1429 croak("Can't do seteuid!\n");
1432 if (!cando(S_IXUSR,TRUE,&statbuf))
1433 croak("Permission denied\n"); /* they can't do this */
1436 else if (preprocess)
1437 croak("-P not allowed for setuid/setgid script\n");
1439 croak("Script is not setuid/setgid in suidperl\n");
1440 #endif /* IAMSUID */
1442 if (euid != uid || egid != gid) { /* (suidperl doesn't exist, in fact) */
1443 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
1444 Fstat(fileno(rsfp),&statbuf); /* may be either wrapped or real suid */
1445 if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
1447 (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
1450 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
1451 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
1452 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
1453 /* not set-id, must be wrapped */
1463 /* skip forward in input to the real script? */
1467 if ((s = sv_gets(linestr, rsfp, 0)) == Nullch)
1468 croak("No Perl script found in input\n");
1469 if (*s == '#' && s[1] == '!' && instr(s,"perl")) {
1470 ungetc('\n',rsfp); /* to keep line count right */
1472 if (s = instr(s,"perl -")) {
1475 while (s = moreswitches(s)) ;
1477 if (cddir && chdir(cddir) < 0)
1478 croak("Can't chdir to %s",cddir);
1486 uid = (int)getuid();
1487 euid = (int)geteuid();
1488 gid = (int)getgid();
1489 egid = (int)getegid();
1494 tainting |= (euid != uid || egid != gid);
1500 curstash = debstash;
1501 dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
1503 DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
1504 DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
1505 DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
1506 DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
1507 DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
1508 DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
1509 curstash = defstash;
1516 mainstack = stack; /* remember in case we switch stacks */
1517 AvREAL_off(stack); /* not a real array */
1518 av_extend(stack,127);
1520 stack_base = AvARRAY(stack);
1521 stack_sp = stack_base;
1522 stack_max = stack_base + 127;
1524 New(54,markstack,64,I32);
1525 markstack_ptr = markstack;
1526 markstack_max = markstack + 64;
1528 New(54,scopestack,32,I32);
1530 scopestack_max = 32;
1532 New(54,savestack,128,ANY);
1534 savestack_max = 128;
1536 New(54,retstack,16,OP*);
1540 New(50,cxstack,128,CONTEXT);
1544 New(50,tmps_stack,128,SV*);
1549 New(51,debname,128,char);
1550 New(52,debdelim,128,char);
1554 static FILE *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
1562 subname = newSVpv("main",4);
1566 init_predump_symbols()
1571 sv_setpvn(GvSV(gv_fetchpv("\"", TRUE, SVt_PV)), " ", 1);
1573 stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
1574 SvMULTI_on(stdingv);
1575 IoIFP(GvIOp(stdingv)) = stdin;
1576 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
1577 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(stdingv));
1580 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
1582 IoOFP(GvIOp(tmpgv)) = IoIFP(GvIOp(tmpgv)) = stdout;
1584 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
1585 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(defoutgv));
1588 othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
1589 SvMULTI_on(othergv);
1590 IoOFP(GvIOp(othergv)) = IoIFP(GvIOp(othergv)) = stderr;
1591 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
1592 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(othergv));
1595 statname = NEWSV(66,0); /* last filename we did stat on */
1599 init_postdump_symbols(argc,argv,env)
1601 register char **argv;
1602 register char **env;
1608 argc--,argv++; /* skip name of script */
1610 for (; argc > 0 && **argv == '-'; argc--,argv++) {
1613 if (argv[0][1] == '-') {
1617 if (s = strchr(argv[0], '=')) {
1619 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
1622 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
1625 toptarget = NEWSV(0,0);
1626 sv_upgrade(toptarget, SVt_PVFM);
1627 sv_setpvn(toptarget, "", 0);
1628 bodytarget = NEWSV(0,0);
1629 sv_upgrade(bodytarget, SVt_PVFM);
1630 sv_setpvn(bodytarget, "", 0);
1631 formtarget = bodytarget;
1634 if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
1635 sv_setpv(GvSV(tmpgv),origfilename);
1636 magicname("0", "0", 1);
1638 if (tmpgv = gv_fetchpv("\024",TRUE, SVt_PV))
1640 if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
1641 sv_setpv(GvSV(tmpgv),origargv[0]);
1642 if (argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
1644 (void)gv_AVadd(argvgv);
1645 av_clear(GvAVn(argvgv));
1646 for (; argc > 0; argc--,argv++) {
1647 av_push(GvAVn(argvgv),newSVpv(argv[0],0));
1650 if (envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
1655 #ifndef VMS /* VMS doesn't have environ array */
1656 if (env != environ) {
1657 environ[0] = Nullch;
1658 hv_magic(hv, envgv, 'E');
1661 #ifdef DYNAMIC_ENV_FETCH
1662 HvNAME(hv) = savepv(ENV_HV_NAME);
1664 for (; *env; env++) {
1665 if (!(s = strchr(*env,'=')))
1668 sv = newSVpv(s--,0);
1669 sv_magic(sv, sv, 'e', *env, s - *env);
1670 (void)hv_store(hv, *env, s - *env, sv, 0);
1673 hv_magic(hv, envgv, 'E');
1676 if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
1677 sv_setiv(GvSV(tmpgv),(I32)getpid());
1686 s = getenv("PERL5LIB");
1690 incpush(getenv("PERLLIB"));
1694 incpush(SITELIB_EXP);
1697 incpush(ARCHLIB_EXP);
1700 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
1702 incpush(PRIVLIB_EXP);
1704 av_push(GvAVn(incgv),newSVpv(".",1));
1713 line_t oldline = curcop->cop_line;
1715 Copy(top_env, oldtop, 1, jmp_buf);
1717 while (AvFILL(list) >= 0) {
1718 CV *cv = (CV*)av_shift(list);
1722 switch (setjmp(top_env)) {
1724 SV* atsv = GvSV(gv_fetchpv("@",TRUE, SVt_PV));
1726 perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
1727 (void)SvPV(atsv, len);
1729 Copy(oldtop, top_env, 1, jmp_buf);
1730 curcop = &compiling;
1731 curcop->cop_line = oldline;
1732 if (list == beginav)
1733 sv_catpv(atsv, "BEGIN failed--compilation aborted");
1735 sv_catpv(atsv, "END failed--cleanup aborted");
1736 croak("%s", SvPVX(atsv));
1742 statusvalue = 255; /* XXX I don't think we use 1 anymore. */
1748 /* my_exit() was called */
1749 curstash = defstash;
1753 Copy(oldtop, top_env, 1, jmp_buf);
1754 curcop = &compiling;
1755 curcop->cop_line = oldline;
1757 if (list == beginav)
1758 croak("BEGIN failed--compilation aborted");
1760 croak("END failed--cleanup aborted");
1762 my_exit(statusvalue);
1767 fprintf(stderr, "panic: restartop\n");
1771 Copy(oldtop, top_env, 1, jmp_buf);
1772 curcop = &compiling;
1773 curcop->cop_line = oldline;
1774 longjmp(top_env, 3);
1778 Copy(oldtop, top_env, 1, jmp_buf);