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 Copy(oldtop, top_env, 1, jmp_buf);
715 if (flags & G_DISCARD) {
716 stack_sp = stack_base + oldmark;
724 /* Older forms, here grandfathered. */
728 perl_callargv(subname, spix, gimme, argv)
730 register I32 spix; /* current stack pointer index */
731 I32 gimme; /* See G_* flags in cop.h */
732 register char **argv; /* null terminated arg list, NULL for no arglist */
734 stack_sp = stack_base + spix;
735 return spix + perl_call_argv(subname, gimme, argv);
739 perl_callpv(subname, spix, gimme, hasargs, numargs)
741 I32 spix; /* stack pointer index after args are pushed */
742 I32 gimme; /* See G_* flags in cop.h */
743 I32 hasargs; /* whether to create a @_ array for routine */
744 I32 numargs; /* how many args are pushed on the stack */
746 stack_sp = stack_base + spix;
747 PUSHMARK(stack_sp - numargs);
748 return spix - numargs + perl_call_sv((SV*)perl_get_cv(subname, TRUE),
749 gimme, hasargs, numargs);
753 perl_callsv(sv, spix, gimme, hasargs, numargs)
755 I32 spix; /* stack pointer index after args are pushed */
756 I32 gimme; /* See G_* flags in cop.h */
757 I32 hasargs; /* whether to create a @_ array for routine */
758 I32 numargs; /* how many args are pushed on the stack */
760 stack_sp = stack_base + spix;
761 PUSHMARK(stack_sp - numargs);
762 return spix - numargs + perl_call_sv(sv, gimme, hasargs, numargs);
766 /* Require a module. */
772 UNOP myop; /* fake syntax tree node */
785 myop.op_type = OP_REQUIRE;
786 myop.op_next = Nullop;
788 myop.op_flags = OPf_KNOW;
791 if (op = pp_require())
799 magicname(sym,name,namlen)
806 if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
807 sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
811 #define PERLLIB_SEP ';'
813 #define PERLLIB_SEP ':'
825 /* Break at all separators */
827 /* First, skip any consecutive separators */
828 while ( *p == PERLLIB_SEP ) {
829 /* Uncomment the next line for PATH semantics */
830 /* av_push(GvAVn(incgv), newSVpv(".", 1)); */
833 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
834 av_push(GvAVn(incgv), newSVpv(p, (STRLEN)(s - p)));
837 av_push(GvAVn(incgv), newSVpv(p, 0));
843 /* This routine handles any switches that can be given during run */
853 nrschar = scan_oct(s, 4, &numlen);
854 nrs = savepvn("\n",1);
856 if (nrschar > 0377) {
860 else if (!nrschar && numlen >= 2) {
868 splitstr = savepv(s + 1);
891 static char debopts[] = "psltocPmfrxuLHXD";
894 for (s++; *s && (d = strchr(debopts,*s)); s++)
895 debug |= 1 << (d - debopts);
899 for (s++; isDIGIT(*s); s++) ;
903 warn("Recompile perl with -DDEBUGGING to use -D switch\n");
904 for (s++; isALNUM(*s); s++) ;
911 inplace = savepv(s+1);
913 for (s = inplace; *s && !isSPACE(*s); s++) ;
919 av_push(GvAVn(incgv),newSVpv(s,0));
922 croak("No space allowed after -I");
932 *ors = scan_oct(s, 3 + (*s == '0'), &numlen);
936 ors = savepvn(nrs,nrslen);
966 printf("\nThis is perl, version %s\n\n",patchlevel);
967 fputs("\nCopyright 1987-1994, Larry Wall\n",stdout);
969 fputs("MS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n",
972 fputs("OS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n",
977 fputs("atariST series port, ++jrb bammi@cadence.com\n", stdout);
980 Perl may be copied only under the terms of either the Artistic License or the\n\
981 GNU General Public License, which may be found in the Perl 5.0 source kit.\n",stdout);
992 if (s[1] == '-') /* Additional switches on #! line. */
1005 croak("Can't emulate -%.1s on #! line",s);
1010 /* compliments of Tom Christiansen */
1012 /* unexec() can be found in the Gnu emacs distribution */
1021 sprintf (buf, "%s.perldump", origfilename);
1022 sprintf (tokenbuf, "%s/perl", BIN);
1024 status = unexec(buf, tokenbuf, &etext, sbrk(0), 0);
1026 fprintf(stderr, "unexec of %s into %s failed!\n", tokenbuf, buf);
1029 ABORT(); /* for use with undump */
1037 curstash = defstash = newHV();
1038 curstname = newSVpv("main",4);
1039 GvHV(gv = gv_fetchpv("main::",TRUE, SVt_PVHV)) =
1040 (HV*)SvREFCNT_inc(defstash);
1042 HvNAME(defstash) = savepv("main");
1043 incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
1045 defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
1046 curstash = defstash;
1047 compiling.cop_stash = defstash;
1049 GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV)) = debstash;
1052 #ifdef CAN_PROTOTYPE
1054 open_script(char *scriptname, bool dosearch, SV *sv)
1057 open_script(scriptname,dosearch,sv)
1063 char *xfound = Nullch;
1064 char *xfailed = Nullch;
1068 if (dosearch && !strchr(scriptname, '/') && (s = getenv("PATH"))) {
1070 bufend = s + strlen(s);
1073 s = cpytill(tokenbuf,s,bufend,':',&len);
1076 for (len = 0; *s && *s != ',' && *s != ';'; tokenbuf[len++] = *s++);
1077 tokenbuf[len] = '\0';
1079 for (len = 0; *s && *s != ';'; tokenbuf[len++] = *s++);
1080 tokenbuf[len] = '\0';
1086 if (len && tokenbuf[len-1] != '/')
1089 if (len && ((tokenbuf[len-1] != '\\') && (tokenbuf[len-1] != '/')))
1091 if (len && tokenbuf[len-1] != '\\')
1094 (void)strcat(tokenbuf+len,"/");
1095 (void)strcat(tokenbuf+len,scriptname);
1096 DEBUG_p(fprintf(stderr,"Looking for %s\n",tokenbuf));
1097 if (Stat(tokenbuf,&statbuf) < 0) /* not there? */
1099 if (S_ISREG(statbuf.st_mode)
1100 && cando(S_IRUSR,TRUE,&statbuf) && cando(S_IXUSR,TRUE,&statbuf)) {
1101 xfound = tokenbuf; /* bingo! */
1105 xfailed = savepv(tokenbuf);
1108 croak("Can't execute %s", xfailed ? xfailed : scriptname );
1111 scriptname = xfound;
1114 origfilename = savepv(e_fp ? "-e" : scriptname);
1115 curcop->cop_filegv = gv_fetchfile(origfilename);
1116 if (strEQ(origfilename,"-"))
1119 char *cpp = CPPSTDIN;
1121 if (strEQ(cpp,"cppstdin"))
1122 sprintf(tokenbuf, "%s/%s", SCRIPTDIR, cpp);
1124 sprintf(tokenbuf, "%s", cpp);
1126 sv_catpv(sv,PRIVLIB);
1128 (void)sprintf(buf, "\
1129 sed %s -e \"/^[^#]/b\" \
1130 -e \"/^#[ ]*include[ ]/b\" \
1131 -e \"/^#[ ]*define[ ]/b\" \
1132 -e \"/^#[ ]*if[ ]/b\" \
1133 -e \"/^#[ ]*ifdef[ ]/b\" \
1134 -e \"/^#[ ]*ifndef[ ]/b\" \
1135 -e \"/^#[ ]*else/b\" \
1136 -e \"/^#[ ]*elif[ ]/b\" \
1137 -e \"/^#[ ]*undef[ ]/b\" \
1138 -e \"/^#[ ]*endif/b\" \
1141 (doextract ? "-e \"1,/^#/d\n\"" : ""),
1143 (void)sprintf(buf, "\
1144 %s %s -e '/^[^#]/b' \
1145 -e '/^#[ ]*include[ ]/b' \
1146 -e '/^#[ ]*define[ ]/b' \
1147 -e '/^#[ ]*if[ ]/b' \
1148 -e '/^#[ ]*ifdef[ ]/b' \
1149 -e '/^#[ ]*ifndef[ ]/b' \
1150 -e '/^#[ ]*else/b' \
1151 -e '/^#[ ]*elif[ ]/b' \
1152 -e '/^#[ ]*undef[ ]/b' \
1153 -e '/^#[ ]*endif/b' \
1161 (doextract ? "-e '1,/^#/d\n'" : ""),
1163 scriptname, tokenbuf, SvPV(sv, na), CPPMINUS);
1165 #ifdef IAMSUID /* actually, this is caught earlier */
1166 if (euid != uid && !euid) { /* if running suidperl */
1168 (void)seteuid(uid); /* musn't stay setuid root */
1171 (void)setreuid((Uid_t)-1, uid);
1173 #ifdef HAS_SETRESUID
1174 (void)setresuid((Uid_t)-1, uid, (Uid_t)-1);
1180 if (geteuid() != uid)
1181 croak("Can't do seteuid!\n");
1183 #endif /* IAMSUID */
1184 rsfp = my_popen(buf,"r");
1186 else if (!*scriptname) {
1187 taint_not("program input from stdin");
1191 rsfp = fopen(scriptname,"r");
1192 if ((FILE*)rsfp == Nullfp) {
1194 #ifndef IAMSUID /* in case script is not readable before setuid */
1195 if (euid && Stat(SvPVX(GvSV(curcop->cop_filegv)),&statbuf) >= 0 &&
1196 statbuf.st_mode & (S_ISUID|S_ISGID)) {
1197 (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel);
1198 execv(buf, origargv); /* try again */
1199 croak("Can't do setuid\n");
1203 croak("Can't open perl script \"%s\": %s\n",
1204 SvPVX(GvSV(curcop->cop_filegv)), Strerror(errno));
1209 validate_suid(validarg)
1212 /* do we need to emulate setuid on scripts? */
1214 /* This code is for those BSD systems that have setuid #! scripts disabled
1215 * in the kernel because of a security problem. Merely defining DOSUID
1216 * in perl will not fix that problem, but if you have disabled setuid
1217 * scripts in the kernel, this will attempt to emulate setuid and setgid
1218 * on scripts that have those now-otherwise-useless bits set. The setuid
1219 * root version must be called suidperl or sperlN.NNN. If regular perl
1220 * discovers that it has opened a setuid script, it calls suidperl with
1221 * the same argv that it had. If suidperl finds that the script it has
1222 * just opened is NOT setuid root, it sets the effective uid back to the
1223 * uid. We don't just make perl setuid root because that loses the
1224 * effective uid we had before invoking perl, if it was different from the
1227 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
1228 * be defined in suidperl only. suidperl must be setuid root. The
1229 * Configure script will set this up for you if you want it.
1235 if (Fstat(fileno(rsfp),&statbuf) < 0) /* normal stat is insecure */
1236 croak("Can't stat script \"%s\"",origfilename);
1237 if (statbuf.st_mode & (S_ISUID|S_ISGID)) {
1241 #ifndef HAS_SETREUID
1242 /* On this access check to make sure the directories are readable,
1243 * there is actually a small window that the user could use to make
1244 * filename point to an accessible directory. So there is a faint
1245 * chance that someone could execute a setuid script down in a
1246 * non-accessible directory. I don't know what to do about that.
1247 * But I don't think it's too important. The manual lies when
1248 * it says access() is useful in setuid programs.
1250 if (access(SvPVX(GvSV(curcop->cop_filegv)),1)) /*double check*/
1251 croak("Permission denied");
1253 /* If we can swap euid and uid, then we can determine access rights
1254 * with a simple stat of the file, and then compare device and
1255 * inode to make sure we did stat() on the same file we opened.
1256 * Then we just have to make sure he or she can execute it.
1259 struct stat tmpstatbuf;
1263 setreuid(euid,uid) < 0
1266 setresuid(euid,uid,(Uid_t)-1) < 0
1269 || getuid() != euid || geteuid() != uid)
1270 croak("Can't swap uid and euid"); /* really paranoid */
1271 if (Stat(SvPVX(GvSV(curcop->cop_filegv)),&tmpstatbuf) < 0)
1272 croak("Permission denied"); /* testing full pathname here */
1273 if (tmpstatbuf.st_dev != statbuf.st_dev ||
1274 tmpstatbuf.st_ino != statbuf.st_ino) {
1276 if (rsfp = my_popen("/bin/mail root","w")) { /* heh, heh */
1278 "User %d tried to run dev %d ino %d in place of dev %d ino %d!\n\
1279 (Filename of set-id script was %s, uid %d gid %d.)\n\nSincerely,\nperl\n",
1280 uid,tmpstatbuf.st_dev, tmpstatbuf.st_ino,
1281 statbuf.st_dev, statbuf.st_ino,
1282 SvPVX(GvSV(curcop->cop_filegv)),
1283 statbuf.st_uid, statbuf.st_gid);
1284 (void)my_pclose(rsfp);
1286 croak("Permission denied\n");
1290 setreuid(uid,euid) < 0
1292 # if defined(HAS_SETRESUID)
1293 setresuid(uid,euid,(Uid_t)-1) < 0
1296 || getuid() != uid || geteuid() != euid)
1297 croak("Can't reswap uid and euid");
1298 if (!cando(S_IXUSR,FALSE,&statbuf)) /* can real uid exec? */
1299 croak("Permission denied\n");
1301 #endif /* HAS_SETREUID */
1302 #endif /* IAMSUID */
1304 if (!S_ISREG(statbuf.st_mode))
1305 croak("Permission denied");
1306 if (statbuf.st_mode & S_IWOTH)
1307 croak("Setuid/gid script is writable by world");
1308 doswitches = FALSE; /* -s is insecure in suid */
1310 if (fgets(tokenbuf,sizeof tokenbuf, rsfp) == Nullch ||
1311 strnNE(tokenbuf,"#!",2) ) /* required even on Sys V */
1312 croak("No #! line");
1315 while (!isSPACE(*s)) s++;
1316 if (strnNE(s-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
1317 croak("Not a perl script");
1318 while (*s == ' ' || *s == '\t') s++;
1320 * #! arg must be what we saw above. They can invoke it by
1321 * mentioning suidperl explicitly, but they may not add any strange
1322 * arguments beyond what #! says if they do invoke suidperl that way.
1324 len = strlen(validarg);
1325 if (strEQ(validarg," PHOOEY ") ||
1326 strnNE(s,validarg,len) || !isSPACE(s[len]))
1327 croak("Args must match #! line");
1330 if (euid != uid && (statbuf.st_mode & S_ISUID) &&
1331 euid == statbuf.st_uid)
1333 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
1334 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
1335 #endif /* IAMSUID */
1337 if (euid) { /* oops, we're not the setuid root perl */
1340 (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel);
1341 execv(buf, origargv); /* try again */
1343 croak("Can't do setuid\n");
1346 if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid) {
1348 (void)setegid(statbuf.st_gid);
1351 (void)setregid((Gid_t)-1,statbuf.st_gid);
1353 #ifdef HAS_SETRESGID
1354 (void)setresgid((Gid_t)-1,statbuf.st_gid,(Gid_t)-1);
1356 setgid(statbuf.st_gid);
1360 if (getegid() != statbuf.st_gid)
1361 croak("Can't do setegid!\n");
1363 if (statbuf.st_mode & S_ISUID) {
1364 if (statbuf.st_uid != euid)
1366 (void)seteuid(statbuf.st_uid); /* all that for this */
1369 (void)setreuid((Uid_t)-1,statbuf.st_uid);
1371 #ifdef HAS_SETRESUID
1372 (void)setresuid((Uid_t)-1,statbuf.st_uid,(Uid_t)-1);
1374 setuid(statbuf.st_uid);
1378 if (geteuid() != statbuf.st_uid)
1379 croak("Can't do seteuid!\n");
1381 else if (uid) { /* oops, mustn't run as root */
1383 (void)seteuid((Uid_t)uid);
1386 (void)setreuid((Uid_t)-1,(Uid_t)uid);
1388 #ifdef HAS_SETRESUID
1389 (void)setresuid((Uid_t)-1,(Uid_t)uid,(Uid_t)-1);
1395 if (geteuid() != uid)
1396 croak("Can't do seteuid!\n");
1398 uid = (int)getuid();
1399 euid = (int)geteuid();
1400 gid = (int)getgid();
1401 egid = (int)getegid();
1402 tainting |= (euid != uid || egid != gid);
1403 if (!cando(S_IXUSR,TRUE,&statbuf))
1404 croak("Permission denied\n"); /* they can't do this */
1407 else if (preprocess)
1408 croak("-P not allowed for setuid/setgid script\n");
1410 croak("Script is not setuid/setgid in suidperl\n");
1411 #endif /* IAMSUID */
1413 if (euid != uid || egid != gid) { /* (suidperl doesn't exist, in fact) */
1414 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
1415 Fstat(fileno(rsfp),&statbuf); /* may be either wrapped or real suid */
1416 if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
1418 (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
1421 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
1422 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
1423 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
1424 /* not set-id, must be wrapped */
1434 /* skip forward in input to the real script? */
1438 if ((s = sv_gets(linestr, rsfp, 0)) == Nullch)
1439 croak("No Perl script found in input\n");
1440 if (*s == '#' && s[1] == '!' && instr(s,"perl")) {
1441 ungetc('\n',rsfp); /* to keep line count right */
1443 if (s = instr(s,"perl -")) {
1446 while (s = moreswitches(s)) ;
1448 if (cddir && chdir(cddir) < 0)
1449 croak("Can't chdir to %s",cddir);
1459 curstash = debstash;
1460 dbargs = GvAV(gv_AVadd((tmpgv = gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
1462 DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
1463 DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
1464 DBsub = gv_HVadd(tmpgv = gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
1465 DBsingle = GvSV((tmpgv = gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
1466 DBtrace = GvSV((tmpgv = gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
1467 DBsignal = GvSV((tmpgv = gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
1468 curstash = defstash;
1475 mainstack = stack; /* remember in case we switch stacks */
1476 AvREAL_off(stack); /* not a real array */
1477 av_extend(stack,127);
1479 stack_base = AvARRAY(stack);
1480 stack_sp = stack_base;
1481 stack_max = stack_base + 127;
1483 New(54,markstack,64,I32);
1484 markstack_ptr = markstack;
1485 markstack_max = markstack + 64;
1487 New(54,scopestack,32,I32);
1489 scopestack_max = 32;
1491 New(54,savestack,128,ANY);
1493 savestack_max = 128;
1495 New(54,retstack,16,OP*);
1499 New(50,cxstack,128,CONTEXT);
1503 New(50,tmps_stack,128,SV*);
1508 New(51,debname,128,char);
1509 New(52,debdelim,128,char);
1513 static FILE *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
1521 subname = newSVpv("main",4);
1525 init_predump_symbols()
1530 sv_setpvn(GvSV(gv_fetchpv("\"", TRUE, SVt_PV)), " ", 1);
1532 stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
1533 SvMULTI_on(stdingv);
1534 IoIFP(GvIOp(stdingv)) = stdin;
1535 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PVIO);
1536 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(stdingv));
1539 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
1541 IoOFP(GvIOp(tmpgv)) = IoIFP(GvIOp(tmpgv)) = stdout;
1543 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PVIO);
1544 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(defoutgv));
1547 othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
1548 SvMULTI_on(othergv);
1549 IoOFP(GvIOp(othergv)) = IoIFP(GvIOp(othergv)) = stderr;
1550 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PVIO);
1551 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(othergv));
1554 statname = NEWSV(66,0); /* last filename we did stat on */
1558 init_postdump_symbols(argc,argv,env)
1560 register char **argv;
1561 register char **env;
1567 argc--,argv++; /* skip name of script */
1569 for (; argc > 0 && **argv == '-'; argc--,argv++) {
1572 if (argv[0][1] == '-') {
1576 if (s = strchr(argv[0], '=')) {
1578 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
1581 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
1584 toptarget = NEWSV(0,0);
1585 sv_upgrade(toptarget, SVt_PVFM);
1586 sv_setpvn(toptarget, "", 0);
1587 tmpgv = gv_fetchpv("\001",TRUE, SVt_PV);
1588 bodytarget = GvSV(tmpgv);
1589 sv_upgrade(bodytarget, SVt_PVFM);
1590 sv_setpvn(bodytarget, "", 0);
1591 formtarget = bodytarget;
1594 if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
1595 sv_setpv(GvSV(tmpgv),origfilename);
1596 magicname("0", "0", 1);
1598 if (tmpgv = gv_fetchpv("\024",TRUE, SVt_PV))
1600 if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
1601 sv_setpv(GvSV(tmpgv),origargv[0]);
1602 if (argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
1604 (void)gv_AVadd(argvgv);
1605 av_clear(GvAVn(argvgv));
1606 for (; argc > 0; argc--,argv++) {
1607 av_push(GvAVn(argvgv),newSVpv(argv[0],0));
1610 if (envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
1615 #ifndef VMS /* VMS doesn't have environ array */
1616 if (env != environ) {
1617 environ[0] = Nullch;
1618 hv_magic(hv, envgv, 'E');
1621 #ifdef DYNAMIC_ENV_FETCH
1622 HvNAME(hv) = savepv(ENV_HV_NAME);
1624 for (; *env; env++) {
1625 if (!(s = strchr(*env,'=')))
1628 sv = newSVpv(s--,0);
1629 sv_magic(sv, sv, 'e', *env, s - *env);
1630 (void)hv_store(hv, *env, s - *env, sv, 0);
1633 hv_magic(hv, envgv, 'E');
1636 if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
1637 sv_setiv(GvSV(tmpgv),(I32)getpid());
1646 s = getenv("PERL5LIB");
1650 incpush(getenv("PERLLIB"));
1657 #define PRIVLIB "/usr/local/lib/perl5:/usr/local/lib/perl"
1661 av_push(GvAVn(incgv),newSVpv(".",1));
1671 line_t oldline = curcop->cop_line;
1673 Copy(top_env, oldtop, 1, jmp_buf);
1675 while (AvFILL(list) >= 0) {
1676 CV *cv = (CV*)av_shift(list);
1680 switch (setjmp(top_env)) {
1683 perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
1684 mess = SvPVx(GvSV(gv_fetchpv("@",TRUE, SVt_PV)), len);
1686 Copy(oldtop, top_env, 1, jmp_buf);
1687 curcop = &compiling;
1688 curcop->cop_line = oldline;
1689 if (list == beginav)
1690 croak("%sBEGIN failed--compilation aborted", mess);
1692 croak("%sEND failed--cleanup aborted", mess);
1696 statusvalue = 255; /* XXX I don't think we use 1 anymore. */
1699 /* my_exit() was called */
1700 curstash = defstash;
1704 Copy(oldtop, top_env, 1, jmp_buf);
1705 curcop = &compiling;
1706 curcop->cop_line = oldline;
1708 if (list == beginav)
1709 croak("BEGIN failed--compilation aborted");
1711 croak("END failed--cleanup aborted");
1713 my_exit(statusvalue);
1718 fprintf(stderr, "panic: restartop\n");
1722 Copy(oldtop, top_env, 1, jmp_buf);
1723 curcop = &compiling;
1724 curcop->cop_line = oldline;
1725 longjmp(top_env, 3);
1729 Copy(oldtop, top_env, 1, jmp_buf);