3 * Copyright (c) 1987-1995 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 dEXT 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;
143 if (s = getenv("PERL_DESTRUCT_LEVEL"))
144 destruct_level = atoi(s);
152 /* We must account for everything. First the syntax tree. */
154 curpad = AvARRAY(comppad);
161 * Try to destruct global references. We do this first so that the
162 * destructors and destructees still exist. Some sv's might remain.
163 * Non-referenced objects are on their own.
170 if (destruct_level == 0){
172 DEBUG_P(debprofdump());
174 /* The exit() function will do everything that needs doing. */
178 /* Prepare to destruct main symbol table. */
184 if (destruct_level >= 2) {
185 if (scopestack_ix != 0)
186 warn("Unbalanced scopes: %d more ENTERs than LEAVEs\n", scopestack_ix);
187 if (savestack_ix != 0)
188 warn("Unbalanced saves: %d more saves than restores\n", savestack_ix);
189 if (tmps_floor != -1)
190 warn("Unbalanced tmps: %d more allocs than frees\n", tmps_floor + 1);
191 if (cxstack_ix != -1)
192 warn("Unbalanced context: %d more PUSHes than POPs\n", cxstack_ix + 1);
195 /* Now absolutely destruct everything, somehow or other, loops or no. */
197 while (sv_count != 0 && sv_count != last_sv_count) {
198 last_sv_count = sv_count;
202 warn("Scalars leaked: %d\n", sv_count);
205 DEBUG_P(debprofdump());
210 PerlInterpreter *sv_interp;
212 if (!(curinterp = sv_interp))
216 #if !defined(STANDARD_C) && !defined(HAS_GETENV_PROTOTYPE)
217 char *getenv _((char *)); /* Usually in <stdlib.h> */
221 perl_parse(sv_interp, xsinit, argc, argv, env)
222 PerlInterpreter *sv_interp;
223 void (*xsinit)_((void));
231 VOL bool dosearch = FALSE;
235 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
238 croak("suidperl is no longer needed since the kernel can now execute\n\
239 setuid perl scripts securely.\n");
243 if (!(curinterp = sv_interp))
248 #ifndef VMS /* VMS doesn't have environ array */
249 origenviron = environ;
254 /* Come here if running an undumped a.out. */
256 origfilename = savepv(argv[0]);
258 cxstack_ix = -1; /* start label stack again */
260 init_postdump_symbols(argc,argv,env);
268 switch (setjmp(top_env)) {
279 return(statusvalue); /* my_exit() was called */
281 fprintf(stderr, "panic: top_env\n");
285 sv_setpvn(linestr,"",0);
286 sv = newSVpv("",0); /* first used for -I flags */
289 for (argc--,argv++; argc > 0; argc--,argv++) {
290 if (argv[0][0] != '-' || !argv[0][1])
294 validarg = " PHOOEY ";
318 if (s = moreswitches(s))
323 if (euid != uid || egid != gid)
324 croak("No -e allowed in setuid scripts");
326 e_tmpname = savepv(TMPPATH);
327 (void)mktemp(e_tmpname);
329 croak("Can't mktemp()");
330 e_fp = fopen(e_tmpname,"w");
332 croak("Cannot open temporary file");
338 (void)putc('\n', e_fp);
346 av_push(GvAVn(incgv),newSVpv(s,0));
349 av_push(GvAVn(incgv),newSVpv(argv[1],0));
350 sv_catpv(sv,argv[1]);
377 croak("Unrecognized switch: -%s",s);
381 scriptname = argv[0];
383 if (fflush(e_fp) || ferror(e_fp) || fclose(e_fp))
384 croak("Can't write to temp file for -e: %s", Strerror(errno));
386 scriptname = e_tmpname;
388 else if (scriptname == Nullch) {
390 if ( isatty(fileno(stdin)) )
398 open_script(scriptname,dosearch,sv);
400 validate_suid(validarg);
405 compcv = (CV*)NEWSV(1104,0);
406 sv_upgrade((SV *)compcv, SVt_PVCV);
410 av_push(comppad, Nullsv);
411 curpad = AvARRAY(comppad);
413 comppad_name = padname;
414 comppad_name_fill = 0;
415 min_intro_pending = 0;
418 comppadlist = newAV();
419 AvREAL_off(comppadlist);
420 av_store(comppadlist, 0, (SV*)comppad_name);
421 av_store(comppadlist, 1, (SV*)comppad);
422 CvPADLIST(compcv) = comppadlist;
425 (*xsinit)(); /* in case linked C routines want magical variables */
430 init_predump_symbols();
432 init_postdump_symbols(argc,argv,env);
436 /* now parse the script */
439 if (yyparse() || error_count) {
441 croak("%s had compilation errors.\n", origfilename);
443 croak("Execution of %s aborted due to compilation errors.\n",
447 curcop->cop_line = 0;
452 (void)UNLINK(e_tmpname);
455 /* now that script is parsed, we can modify record separator */
460 rspara = (nrslen == 2);
461 sv_setpvn(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), rs, rslen);
478 PerlInterpreter *sv_interp;
480 if (!(curinterp = sv_interp))
482 switch (setjmp(top_env)) {
484 cxstack_ix = -1; /* start context stack again */
491 return(statusvalue); /* my_exit() was called */
494 fprintf(stderr, "panic: restartop\n");
498 if (stack != mainstack) {
500 SWITCHSTACK(stack, mainstack);
507 DEBUG(fprintf(stderr,"\nEXECUTING...\n\n"));
510 fprintf(stderr,"%s syntax OK\n", origfilename);
513 if (perldb && DBsingle)
514 sv_setiv(DBsingle, 1);
524 else if (main_start) {
537 register CONTEXT *cx;
541 statusvalue = FIXSTATUS(status);
542 if (cxstack_ix >= 0) {
552 perl_get_sv(name, create)
556 GV* gv = gv_fetchpv(name, create, SVt_PV);
563 perl_get_av(name, create)
567 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
576 perl_get_hv(name, create)
580 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
589 perl_get_cv(name, create)
593 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
594 if (create && !GvCV(gv))
595 return newSUB(start_subparse(),
596 newSVOP(OP_CONST, 0, newSVpv(name,0)),
604 /* Be sure to refetch the stack pointer after calling these routines. */
607 perl_call_argv(subname, flags, argv)
609 I32 flags; /* See G_* flags in cop.h */
610 register char **argv; /* null terminated arg list */
617 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
622 return perl_call_pv(subname, flags);
626 perl_call_pv(subname, flags)
627 char *subname; /* name of the subroutine */
628 I32 flags; /* See G_* flags in cop.h */
630 return perl_call_sv((SV*)perl_get_cv(subname, TRUE), flags);
634 perl_call_method(methname, flags)
635 char *methname; /* name of the subroutine */
636 I32 flags; /* See G_* flags in cop.h */
642 XPUSHs(sv_2mortal(newSVpv(methname,0)));
645 return perl_call_sv(*stack_sp--, flags);
648 /* May be called with any of a CV, a GV, or an SV containing the name. */
650 perl_call_sv(sv, flags)
652 I32 flags; /* See G_* flags in cop.h */
654 LOGOP myop; /* fake syntax tree node */
656 I32 oldmark = TOPMARK;
661 if (flags & G_DISCARD) {
671 oldscope = scopestack_ix;
673 if (!(flags & G_NOARGS))
674 myop.op_flags = OPf_STACKED;
675 myop.op_next = Nullop;
676 myop.op_flags |= OPf_KNOW;
678 myop.op_flags |= OPf_LIST;
680 if (flags & G_EVAL) {
681 Copy(top_env, oldtop, 1, jmp_buf);
683 cLOGOP->op_other = op;
685 /* we're trying to emulate pp_entertry() here */
687 register CONTEXT *cx;
693 push_return(op->op_next);
694 PUSHBLOCK(cx, CXt_EVAL, stack_sp);
696 eval_root = op; /* Only needed so that goto works right. */
699 if (flags & G_KEEPERR)
702 sv_setpv(GvSV(errgv),"");
707 switch (setjmp(top_env)) {
712 statusvalue = 255; /* XXX I don't think we use 1 anymore. */
718 /* my_exit() was called */
721 Copy(oldtop, top_env, 1, jmp_buf);
723 croak("Callback called exit");
724 my_exit(statusvalue);
732 stack_sp = stack_base + oldmark;
737 *++stack_sp = &sv_undef;
743 if (op == (OP*)&myop)
747 retval = stack_sp - (stack_base + oldmark);
748 if ((flags & G_EVAL) && !(flags & G_KEEPERR))
749 sv_setpv(GvSV(errgv),"");
752 if (flags & G_EVAL) {
753 if (scopestack_ix > oldscope) {
757 register CONTEXT *cx;
766 Copy(oldtop, top_env, 1, jmp_buf);
768 if (flags & G_DISCARD) {
769 stack_sp = stack_base + oldmark;
780 perl_eval_sv(sv, flags)
782 I32 flags; /* See G_* flags in cop.h */
784 UNOP myop; /* fake syntax tree node */
786 I32 oldmark = sp - stack_base;
791 if (flags & G_DISCARD) {
801 oldscope = scopestack_ix;
803 if (!(flags & G_NOARGS))
804 myop.op_flags = OPf_STACKED;
805 myop.op_next = Nullop;
806 myop.op_flags |= OPf_KNOW;
808 myop.op_flags |= OPf_LIST;
810 Copy(top_env, oldtop, 1, jmp_buf);
813 switch (setjmp(top_env)) {
818 statusvalue = 255; /* XXX I don't think we use 1 anymore. */
824 /* my_exit() was called */
827 Copy(oldtop, top_env, 1, jmp_buf);
829 croak("Callback called exit");
830 my_exit(statusvalue);
838 stack_sp = stack_base + oldmark;
843 *++stack_sp = &sv_undef;
848 if (op == (OP*)&myop)
852 retval = stack_sp - (stack_base + oldmark);
853 if ((flags & G_EVAL) && !(flags & G_KEEPERR))
854 sv_setpv(GvSV(errgv),"");
857 Copy(oldtop, top_env, 1, jmp_buf);
858 if (flags & G_DISCARD) {
859 stack_sp = stack_base + oldmark;
867 /* Require a module. */
873 SV* sv = sv_newmortal();
874 sv_setpv(sv, "require '");
877 perl_eval_sv(sv, G_DISCARD);
881 magicname(sym,name,namlen)
888 if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
889 sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
893 # define PERLLIB_SEP ';'
896 # define PERLLIB_SEP '|'
898 # define PERLLIB_SEP ':'
911 /* Break at all separators */
913 /* First, skip any consecutive separators */
914 while ( *p == PERLLIB_SEP ) {
915 /* Uncomment the next line for PATH semantics */
916 /* av_push(GvAVn(incgv), newSVpv(".", 1)); */
919 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
920 av_push(GvAVn(incgv), newSVpv(p, (STRLEN)(s - p)));
923 av_push(GvAVn(incgv), newSVpv(p, 0));
933 printf("\nUsage: %s [switches] [filename] [arguments]\n",name);
934 printf("\n -0[octal] specify record separator (\\0, if no argument)");
935 printf("\n -a autosplit mode with -n or -p");
936 printf("\n -c check syntax only (runs BEGIN and END blocks)");
937 printf("\n -d run scripts under debugger");
938 printf("\n -D[number/list] set debugging flags (argument is a bit mask or flags)");
939 printf("\n -e command one line of script, multiple -e options are allowed");
940 printf("\n [filename] can be ommitted when -e is used");
941 printf("\n -F regexp regular expression for autosplit (-a)");
942 printf("\n -i[extension] edit <> files in place (make backup if extension supplied)");
943 printf("\n -Idirectory specify include directory (may be used more then once)");
944 printf("\n -l[octal] enable line ending processing, specifies line teminator");
945 printf("\n -n assume 'while (<>) { ... }' loop arround your script");
946 printf("\n -p assume loop like -n but print line also like sed");
947 printf("\n -P run script through C preprocessor before compilation");
949 printf("\n -R enable REXX variable pool");
951 printf("\n -s enable some switch parsing for switches after script name");
952 printf("\n -S look for the script using PATH environment variable");
953 printf("\n -T turn on tainting checks");
954 printf("\n -u dump core after parsing script");
955 printf("\n -U allow unsafe operations");
956 printf("\n -v print version number and patchlevel of perl");
957 printf("\n -w turn warnings on for compilation of your script");
958 printf("\n -x[directory] strip off text before #!perl line and perhaps cd to directory\n");
961 /* This routine handles any switches that can be given during run */
971 nrschar = scan_oct(s, 4, &numlen);
972 nrs = savepvn("\n",1);
974 if (nrschar > 0377) {
978 else if (!nrschar && numlen >= 2) {
986 splitstr = savepv(s + 1);
1001 sprintf(buf, "use Devel::%s;", ++s);
1003 my_setenv("PERL5DB",buf);
1013 if (isALPHA(s[1])) {
1014 static char debopts[] = "psltocPmfrxuLHXD";
1017 for (s++; *s && (d = strchr(debopts,*s)); s++)
1018 debug |= 1 << (d - debopts);
1022 for (s++; isDIGIT(*s); s++) ;
1024 debug |= 0x80000000;
1026 warn("Recompile perl with -DDEBUGGING to use -D switch\n");
1027 for (s++; isALNUM(*s); s++) ;
1037 inplace = savepv(s+1);
1039 for (s = inplace; *s && !isSPACE(*s); s++) ;
1046 for (e = s; *e && !isSPACE(*e); e++) ;
1047 av_push(GvAVn(incgv),newSVpv(s,e-s));
1052 croak("No space allowed after -I");
1062 *ors = scan_oct(s, 3 + (*s == '0'), &numlen);
1066 ors = savepvn(nrs,nrslen);
1096 printf("\nThis is perl, version %s beta1h\n\n",patchlevel);
1097 fputs("\nCopyright 1987-1995, Larry Wall\n",stdout);
1099 fputs("MS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n",
1103 fputs("OS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
1104 "Version 5 port Copyright (c) 1994-1995, Andreas Kaiser\n",
1108 fputs("atariST series port, ++jrb bammi@cadence.com\n", stdout);
1111 Perl may be copied only under the terms of either the Artistic License or the\n\
1112 GNU General Public License, which may be found in the Perl 5.0 source kit.\n",stdout);
1123 if (s[1] == '-') /* Additional switches on #! line. */
1136 croak("Can't emulate -%.1s on #! line",s);
1141 /* compliments of Tom Christiansen */
1143 /* unexec() can be found in the Gnu emacs distribution */
1152 sprintf (buf, "%s.perldump", origfilename);
1153 sprintf (tokenbuf, "%s/perl", BIN);
1155 status = unexec(buf, tokenbuf, &etext, sbrk(0), 0);
1157 fprintf(stderr, "unexec of %s into %s failed!\n", tokenbuf, buf);
1160 ABORT(); /* for use with undump */
1168 curstash = defstash = newHV();
1169 curstname = newSVpv("main",4);
1170 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
1171 SvREFCNT_dec(GvHV(gv));
1172 GvHV(gv) = (HV*)SvREFCNT_inc(defstash);
1174 HvNAME(defstash) = savepv("main");
1175 incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
1177 defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
1178 errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
1180 curstash = defstash;
1181 compiling.cop_stash = defstash;
1182 debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
1183 /* We must init $/ before switches are processed. */
1184 sv_setpvn(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), "\n", 1);
1187 #ifdef CAN_PROTOTYPE
1189 open_script(char *scriptname, bool dosearch, SV *sv)
1192 open_script(scriptname,dosearch,sv)
1198 char *xfound = Nullch;
1199 char *xfailed = Nullch;
1203 if (dosearch && !strchr(scriptname, '/') && (s = getenv("PATH"))) {
1205 bufend = s + strlen(s);
1208 s = cpytill(tokenbuf,s,bufend,':',&len);
1211 for (len = 0; *s && *s != ',' && *s != ';'; tokenbuf[len++] = *s++);
1212 tokenbuf[len] = '\0';
1214 for (len = 0; *s && *s != ';'; tokenbuf[len++] = *s++);
1215 tokenbuf[len] = '\0';
1221 if (len && tokenbuf[len-1] != '/')
1224 if (len && ((tokenbuf[len-1] != '\\') && (tokenbuf[len-1] != '/')))
1226 if (len && tokenbuf[len-1] != '\\')
1229 (void)strcat(tokenbuf+len,"/");
1230 (void)strcat(tokenbuf+len,scriptname);
1231 DEBUG_p(fprintf(stderr,"Looking for %s\n",tokenbuf));
1232 if (Stat(tokenbuf,&statbuf) < 0) /* not there? */
1234 if (S_ISREG(statbuf.st_mode)
1235 && cando(S_IRUSR,TRUE,&statbuf) && cando(S_IXUSR,TRUE,&statbuf)) {
1236 xfound = tokenbuf; /* bingo! */
1240 xfailed = savepv(tokenbuf);
1243 croak("Can't execute %s", xfailed ? xfailed : scriptname );
1246 scriptname = xfound;
1249 origfilename = savepv(e_fp ? "-e" : scriptname);
1250 curcop->cop_filegv = gv_fetchfile(origfilename);
1251 if (strEQ(origfilename,"-"))
1254 char *cpp = CPPSTDIN;
1256 if (strEQ(cpp,"cppstdin"))
1257 sprintf(tokenbuf, "%s/%s", SCRIPTDIR, cpp);
1259 sprintf(tokenbuf, "%s", cpp);
1261 sv_catpv(sv,PRIVLIB_EXP);
1263 (void)sprintf(buf, "\
1264 sed %s -e \"/^[^#]/b\" \
1265 -e \"/^#[ ]*include[ ]/b\" \
1266 -e \"/^#[ ]*define[ ]/b\" \
1267 -e \"/^#[ ]*if[ ]/b\" \
1268 -e \"/^#[ ]*ifdef[ ]/b\" \
1269 -e \"/^#[ ]*ifndef[ ]/b\" \
1270 -e \"/^#[ ]*else/b\" \
1271 -e \"/^#[ ]*elif[ ]/b\" \
1272 -e \"/^#[ ]*undef[ ]/b\" \
1273 -e \"/^#[ ]*endif/b\" \
1276 (doextract ? "-e \"1,/^#/d\n\"" : ""),
1278 (void)sprintf(buf, "\
1279 %s %s -e '/^[^#]/b' \
1280 -e '/^#[ ]*include[ ]/b' \
1281 -e '/^#[ ]*define[ ]/b' \
1282 -e '/^#[ ]*if[ ]/b' \
1283 -e '/^#[ ]*ifdef[ ]/b' \
1284 -e '/^#[ ]*ifndef[ ]/b' \
1285 -e '/^#[ ]*else/b' \
1286 -e '/^#[ ]*elif[ ]/b' \
1287 -e '/^#[ ]*undef[ ]/b' \
1288 -e '/^#[ ]*endif/b' \
1296 (doextract ? "-e '1,/^#/d\n'" : ""),
1298 scriptname, tokenbuf, SvPV(sv, na), CPPMINUS);
1300 #ifdef IAMSUID /* actually, this is caught earlier */
1301 if (euid != uid && !euid) { /* if running suidperl */
1303 (void)seteuid(uid); /* musn't stay setuid root */
1306 (void)setreuid((Uid_t)-1, uid);
1308 #ifdef HAS_SETRESUID
1309 (void)setresuid((Uid_t)-1, uid, (Uid_t)-1);
1315 if (geteuid() != uid)
1316 croak("Can't do seteuid!\n");
1318 #endif /* IAMSUID */
1319 rsfp = my_popen(buf,"r");
1321 else if (!*scriptname) {
1322 taint_not("program input from stdin");
1326 rsfp = fopen(scriptname,"r");
1327 if ((FILE*)rsfp == Nullfp) {
1329 #ifndef IAMSUID /* in case script is not readable before setuid */
1330 if (euid && Stat(SvPVX(GvSV(curcop->cop_filegv)),&statbuf) >= 0 &&
1331 statbuf.st_mode & (S_ISUID|S_ISGID)) {
1332 (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel);
1333 execv(buf, origargv); /* try again */
1334 croak("Can't do setuid\n");
1338 croak("Can't open perl script \"%s\": %s\n",
1339 SvPVX(GvSV(curcop->cop_filegv)), Strerror(errno));
1344 validate_suid(validarg)
1347 /* do we need to emulate setuid on scripts? */
1349 /* This code is for those BSD systems that have setuid #! scripts disabled
1350 * in the kernel because of a security problem. Merely defining DOSUID
1351 * in perl will not fix that problem, but if you have disabled setuid
1352 * scripts in the kernel, this will attempt to emulate setuid and setgid
1353 * on scripts that have those now-otherwise-useless bits set. The setuid
1354 * root version must be called suidperl or sperlN.NNN. If regular perl
1355 * discovers that it has opened a setuid script, it calls suidperl with
1356 * the same argv that it had. If suidperl finds that the script it has
1357 * just opened is NOT setuid root, it sets the effective uid back to the
1358 * uid. We don't just make perl setuid root because that loses the
1359 * effective uid we had before invoking perl, if it was different from the
1362 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
1363 * be defined in suidperl only. suidperl must be setuid root. The
1364 * Configure script will set this up for you if you want it.
1370 if (Fstat(fileno(rsfp),&statbuf) < 0) /* normal stat is insecure */
1371 croak("Can't stat script \"%s\"",origfilename);
1372 if (statbuf.st_mode & (S_ISUID|S_ISGID)) {
1376 #ifndef HAS_SETREUID
1377 /* On this access check to make sure the directories are readable,
1378 * there is actually a small window that the user could use to make
1379 * filename point to an accessible directory. So there is a faint
1380 * chance that someone could execute a setuid script down in a
1381 * non-accessible directory. I don't know what to do about that.
1382 * But I don't think it's too important. The manual lies when
1383 * it says access() is useful in setuid programs.
1385 if (access(SvPVX(GvSV(curcop->cop_filegv)),1)) /*double check*/
1386 croak("Permission denied");
1388 /* If we can swap euid and uid, then we can determine access rights
1389 * with a simple stat of the file, and then compare device and
1390 * inode to make sure we did stat() on the same file we opened.
1391 * Then we just have to make sure he or she can execute it.
1394 struct stat tmpstatbuf;
1398 setreuid(euid,uid) < 0
1401 setresuid(euid,uid,(Uid_t)-1) < 0
1404 || getuid() != euid || geteuid() != uid)
1405 croak("Can't swap uid and euid"); /* really paranoid */
1406 if (Stat(SvPVX(GvSV(curcop->cop_filegv)),&tmpstatbuf) < 0)
1407 croak("Permission denied"); /* testing full pathname here */
1408 if (tmpstatbuf.st_dev != statbuf.st_dev ||
1409 tmpstatbuf.st_ino != statbuf.st_ino) {
1411 if (rsfp = my_popen("/bin/mail root","w")) { /* heh, heh */
1413 "User %d tried to run dev %d ino %d in place of dev %d ino %d!\n\
1414 (Filename of set-id script was %s, uid %d gid %d.)\n\nSincerely,\nperl\n",
1415 uid,tmpstatbuf.st_dev, tmpstatbuf.st_ino,
1416 statbuf.st_dev, statbuf.st_ino,
1417 SvPVX(GvSV(curcop->cop_filegv)),
1418 statbuf.st_uid, statbuf.st_gid);
1419 (void)my_pclose(rsfp);
1421 croak("Permission denied\n");
1425 setreuid(uid,euid) < 0
1427 # if defined(HAS_SETRESUID)
1428 setresuid(uid,euid,(Uid_t)-1) < 0
1431 || getuid() != uid || geteuid() != euid)
1432 croak("Can't reswap uid and euid");
1433 if (!cando(S_IXUSR,FALSE,&statbuf)) /* can real uid exec? */
1434 croak("Permission denied\n");
1436 #endif /* HAS_SETREUID */
1437 #endif /* IAMSUID */
1439 if (!S_ISREG(statbuf.st_mode))
1440 croak("Permission denied");
1441 if (statbuf.st_mode & S_IWOTH)
1442 croak("Setuid/gid script is writable by world");
1443 doswitches = FALSE; /* -s is insecure in suid */
1445 if (fgets(tokenbuf,sizeof tokenbuf, rsfp) == Nullch ||
1446 strnNE(tokenbuf,"#!",2) ) /* required even on Sys V */
1447 croak("No #! line");
1450 while (!isSPACE(*s)) s++;
1451 if (strnNE(s-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
1452 croak("Not a perl script");
1453 while (*s == ' ' || *s == '\t') s++;
1455 * #! arg must be what we saw above. They can invoke it by
1456 * mentioning suidperl explicitly, but they may not add any strange
1457 * arguments beyond what #! says if they do invoke suidperl that way.
1459 len = strlen(validarg);
1460 if (strEQ(validarg," PHOOEY ") ||
1461 strnNE(s,validarg,len) || !isSPACE(s[len]))
1462 croak("Args must match #! line");
1465 if (euid != uid && (statbuf.st_mode & S_ISUID) &&
1466 euid == statbuf.st_uid)
1468 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
1469 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
1470 #endif /* IAMSUID */
1472 if (euid) { /* oops, we're not the setuid root perl */
1475 (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel);
1476 execv(buf, origargv); /* try again */
1478 croak("Can't do setuid\n");
1481 if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid) {
1483 (void)setegid(statbuf.st_gid);
1486 (void)setregid((Gid_t)-1,statbuf.st_gid);
1488 #ifdef HAS_SETRESGID
1489 (void)setresgid((Gid_t)-1,statbuf.st_gid,(Gid_t)-1);
1491 setgid(statbuf.st_gid);
1495 if (getegid() != statbuf.st_gid)
1496 croak("Can't do setegid!\n");
1498 if (statbuf.st_mode & S_ISUID) {
1499 if (statbuf.st_uid != euid)
1501 (void)seteuid(statbuf.st_uid); /* all that for this */
1504 (void)setreuid((Uid_t)-1,statbuf.st_uid);
1506 #ifdef HAS_SETRESUID
1507 (void)setresuid((Uid_t)-1,statbuf.st_uid,(Uid_t)-1);
1509 setuid(statbuf.st_uid);
1513 if (geteuid() != statbuf.st_uid)
1514 croak("Can't do seteuid!\n");
1516 else if (uid) { /* oops, mustn't run as root */
1518 (void)seteuid((Uid_t)uid);
1521 (void)setreuid((Uid_t)-1,(Uid_t)uid);
1523 #ifdef HAS_SETRESUID
1524 (void)setresuid((Uid_t)-1,(Uid_t)uid,(Uid_t)-1);
1530 if (geteuid() != uid)
1531 croak("Can't do seteuid!\n");
1534 if (!cando(S_IXUSR,TRUE,&statbuf))
1535 croak("Permission denied\n"); /* they can't do this */
1538 else if (preprocess)
1539 croak("-P not allowed for setuid/setgid script\n");
1541 croak("Script is not setuid/setgid in suidperl\n");
1542 #endif /* IAMSUID */
1544 if (euid != uid || egid != gid) { /* (suidperl doesn't exist, in fact) */
1545 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
1546 Fstat(fileno(rsfp),&statbuf); /* may be either wrapped or real suid */
1547 if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
1549 (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
1552 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
1553 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
1554 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
1555 /* not set-id, must be wrapped */
1565 /* skip forward in input to the real script? */
1569 if ((s = sv_gets(linestr, rsfp, 0)) == Nullch)
1570 croak("No Perl script found in input\n");
1571 if (*s == '#' && s[1] == '!' && instr(s,"perl")) {
1572 ungetc('\n',rsfp); /* to keep line count right */
1574 if (s = instr(s,"perl -")) {
1577 while (s = moreswitches(s)) ;
1579 if (cddir && chdir(cddir) < 0)
1580 croak("Can't chdir to %s",cddir);
1588 uid = (int)getuid();
1589 euid = (int)geteuid();
1590 gid = (int)getgid();
1591 egid = (int)getegid();
1596 tainting |= (uid && (euid != uid || egid != gid));
1602 curstash = debstash;
1603 dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
1605 DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
1606 DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
1607 DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
1608 DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
1609 DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
1610 DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
1611 curstash = defstash;
1618 mainstack = stack; /* remember in case we switch stacks */
1619 AvREAL_off(stack); /* not a real array */
1620 av_extend(stack,127);
1622 stack_base = AvARRAY(stack);
1623 stack_sp = stack_base;
1624 stack_max = stack_base + 127;
1626 New(54,markstack,64,I32);
1627 markstack_ptr = markstack;
1628 markstack_max = markstack + 64;
1630 New(54,scopestack,32,I32);
1632 scopestack_max = 32;
1634 New(54,savestack,128,ANY);
1636 savestack_max = 128;
1638 New(54,retstack,16,OP*);
1642 New(50,cxstack,128,CONTEXT);
1646 New(50,tmps_stack,128,SV*);
1651 New(51,debname,128,char);
1652 New(52,debdelim,128,char);
1656 static FILE *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
1664 subname = newSVpv("main",4);
1668 init_predump_symbols()
1673 sv_setpvn(GvSV(gv_fetchpv("\"", TRUE, SVt_PV)), " ", 1);
1675 stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
1676 SvMULTI_on(stdingv);
1677 IoIFP(GvIOp(stdingv)) = stdin;
1678 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
1679 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(stdingv));
1682 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
1684 IoOFP(GvIOp(tmpgv)) = IoIFP(GvIOp(tmpgv)) = stdout;
1686 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
1687 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(defoutgv));
1690 othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
1691 SvMULTI_on(othergv);
1692 IoOFP(GvIOp(othergv)) = IoIFP(GvIOp(othergv)) = stderr;
1693 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
1694 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(othergv));
1697 statname = NEWSV(66,0); /* last filename we did stat on */
1701 init_postdump_symbols(argc,argv,env)
1703 register char **argv;
1704 register char **env;
1710 argc--,argv++; /* skip name of script */
1712 for (; argc > 0 && **argv == '-'; argc--,argv++) {
1715 if (argv[0][1] == '-') {
1719 if (s = strchr(argv[0], '=')) {
1721 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
1724 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
1727 toptarget = NEWSV(0,0);
1728 sv_upgrade(toptarget, SVt_PVFM);
1729 sv_setpvn(toptarget, "", 0);
1730 bodytarget = NEWSV(0,0);
1731 sv_upgrade(bodytarget, SVt_PVFM);
1732 sv_setpvn(bodytarget, "", 0);
1733 formtarget = bodytarget;
1736 if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
1737 sv_setpv(GvSV(tmpgv),origfilename);
1738 magicname("0", "0", 1);
1740 if (tmpgv = gv_fetchpv("\024",TRUE, SVt_PV))
1742 if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
1743 sv_setpv(GvSV(tmpgv),origargv[0]);
1744 if (argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
1746 (void)gv_AVadd(argvgv);
1747 av_clear(GvAVn(argvgv));
1748 for (; argc > 0; argc--,argv++) {
1749 av_push(GvAVn(argvgv),newSVpv(argv[0],0));
1752 if (envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
1757 #ifndef VMS /* VMS doesn't have environ array */
1758 /* Note that if the supplied env parameter is actually a copy
1759 of the global environ then it may now point to free'd memory
1760 if the environment has been modified since. To avoid this
1761 problem we treat env==NULL as meaning 'use the default'
1765 if (env != environ) {
1766 environ[0] = Nullch;
1767 hv_magic(hv, envgv, 'E');
1769 for (; *env; env++) {
1770 if (!(s = strchr(*env,'=')))
1773 sv = newSVpv(s--,0);
1774 sv_magic(sv, sv, 'e', *env, s - *env);
1775 (void)hv_store(hv, *env, s - *env, sv, 0);
1779 #ifdef DYNAMIC_ENV_FETCH
1780 HvNAME(hv) = savepv(ENV_HV_NAME);
1782 hv_magic(hv, envgv, 'E');
1785 if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
1786 sv_setiv(GvSV(tmpgv),(I32)getpid());
1795 s = getenv("PERL5LIB");
1799 incpush(getenv("PERLLIB"));
1803 incpush(APPLLIB_EXP);
1807 incpush(ARCHLIB_EXP);
1810 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
1812 incpush(PRIVLIB_EXP);
1815 incpush(SITEARCH_EXP);
1818 incpush(SITELIB_EXP);
1820 #ifdef OLDARCHLIB_EXP /* 5.00[01] compatibility */
1821 incpush(OLDARCHLIB_EXP);
1834 line_t oldline = curcop->cop_line;
1836 Copy(top_env, oldtop, 1, jmp_buf);
1838 while (AvFILL(list) >= 0) {
1839 CV *cv = (CV*)av_shift(list);
1843 switch (setjmp(top_env)) {
1845 SV* atsv = GvSV(errgv);
1847 perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
1848 (void)SvPV(atsv, len);
1850 Copy(oldtop, top_env, 1, jmp_buf);
1851 curcop = &compiling;
1852 curcop->cop_line = oldline;
1853 if (list == beginav)
1854 sv_catpv(atsv, "BEGIN failed--compilation aborted");
1856 sv_catpv(atsv, "END failed--cleanup aborted");
1857 croak("%s", SvPVX(atsv));
1863 statusvalue = 255; /* XXX I don't think we use 1 anymore. */
1869 /* my_exit() was called */
1870 curstash = defstash;
1874 Copy(oldtop, top_env, 1, jmp_buf);
1875 curcop = &compiling;
1876 curcop->cop_line = oldline;
1878 if (list == beginav)
1879 croak("BEGIN failed--compilation aborted");
1881 croak("END failed--cleanup aborted");
1883 my_exit(statusvalue);
1888 fprintf(stderr, "panic: restartop\n");
1892 Copy(oldtop, top_env, 1, jmp_buf);
1893 curcop = &compiling;
1894 curcop->cop_line = oldline;
1895 longjmp(top_env, 3);
1899 Copy(oldtop, top_env, 1, jmp_buf);