3 * Copyright (c) 1987-1996 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
120 sprintf(patchlevel, "%5.3f", 5.0 + (PATCHLEVEL / 1000.0));
122 fdpid = newAV(); /* for remembering popen pids by fd */
123 pidstatus = newHV();/* for remembering status of dead pids */
130 perl_destruct(sv_interp)
131 register PerlInterpreter *sv_interp;
133 int destruct_level; /* 0=none, 1=full, 2=full with checks */
137 if (!(curinterp = sv_interp))
140 destruct_level = perl_destruct_level;
144 if (s = getenv("PERL_DESTRUCT_LEVEL"))
145 destruct_level = atoi(s);
153 /* We must account for everything. First the syntax tree. */
155 curpad = AvARRAY(comppad);
162 * Try to destruct global references. We do this first so that the
163 * destructors and destructees still exist. Some sv's might remain.
164 * Non-referenced objects are on their own.
171 if (destruct_level == 0){
173 DEBUG_P(debprofdump());
175 /* The exit() function will do everything that needs doing. */
179 /* Prepare to destruct main symbol table. */
185 if (destruct_level >= 2) {
186 if (scopestack_ix != 0)
187 warn("Unbalanced scopes: %d more ENTERs than LEAVEs\n", scopestack_ix);
188 if (savestack_ix != 0)
189 warn("Unbalanced saves: %d more saves than restores\n", savestack_ix);
190 if (tmps_floor != -1)
191 warn("Unbalanced tmps: %d more allocs than frees\n", tmps_floor + 1);
192 if (cxstack_ix != -1)
193 warn("Unbalanced context: %d more PUSHes than POPs\n", cxstack_ix + 1);
196 /* Now absolutely destruct everything, somehow or other, loops or no. */
198 while (sv_count != 0 && sv_count != last_sv_count) {
199 last_sv_count = sv_count;
203 warn("Scalars leaked: %d\n", sv_count);
206 DEBUG_P(debprofdump());
211 PerlInterpreter *sv_interp;
213 if (!(curinterp = sv_interp))
217 #if !defined(STANDARD_C) && !defined(HAS_GETENV_PROTOTYPE)
218 char *getenv _((char *)); /* Usually in <stdlib.h> */
222 perl_parse(sv_interp, xsinit, argc, argv, env)
223 PerlInterpreter *sv_interp;
224 void (*xsinit)_((void));
231 char *scriptname = NULL;
232 VOL bool dosearch = FALSE;
236 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
239 croak("suidperl is no longer needed since the kernel can now execute\n\
240 setuid perl scripts securely.\n");
244 if (!(curinterp = sv_interp))
249 #ifndef VMS /* VMS doesn't have environ array */
250 origenviron = environ;
255 /* Come here if running an undumped a.out. */
257 origfilename = savepv(argv[0]);
259 cxstack_ix = -1; /* start label stack again */
261 init_postdump_symbols(argc,argv,env);
269 switch (setjmp(top_env)) {
280 return(statusvalue); /* my_exit() was called */
282 fprintf(stderr, "panic: top_env\n");
286 sv_setpvn(linestr,"",0);
287 sv = newSVpv("",0); /* first used for -I flags */
290 for (argc--,argv++; argc > 0; argc--,argv++) {
291 if (argv[0][0] != '-' || !argv[0][1])
295 validarg = " PHOOEY ";
321 if (s = moreswitches(s))
326 if (euid != uid || egid != gid)
327 croak("No -e allowed in setuid scripts");
329 e_tmpname = savepv(TMPPATH);
330 (void)mktemp(e_tmpname);
332 croak("Can't mktemp()");
333 e_fp = fopen(e_tmpname,"w");
335 croak("Cannot open temporary file");
341 (void)putc('\n', e_fp);
349 av_push(GvAVn(incgv),newSVpv(s,0));
352 av_push(GvAVn(incgv),newSVpv(argv[1],0));
353 sv_catpv(sv,argv[1]);
370 preambleav = newAV();
371 av_push(preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
373 Sv = newSVpv("print myconfig(),'@INC: '.\"@INC\\n\"",0);
376 Sv = newSVpv("config_vars(qw(",0);
381 av_push(preambleav, Sv);
382 scriptname = "/dev/null"; /* don't look for script or read stdin */
396 croak("Unrecognized switch: -%s",s);
401 scriptname = argv[0];
403 if (fflush(e_fp) || ferror(e_fp) || fclose(e_fp))
404 croak("Can't write to temp file for -e: %s", Strerror(errno));
406 scriptname = e_tmpname;
408 else if (scriptname == Nullch) {
410 if ( isatty(fileno(stdin)) )
418 open_script(scriptname,dosearch,sv);
420 validate_suid(validarg);
425 compcv = (CV*)NEWSV(1104,0);
426 sv_upgrade((SV *)compcv, SVt_PVCV);
430 av_push(comppad, Nullsv);
431 curpad = AvARRAY(comppad);
433 comppad_name = padname;
434 comppad_name_fill = 0;
435 min_intro_pending = 0;
438 comppadlist = newAV();
439 AvREAL_off(comppadlist);
440 av_store(comppadlist, 0, (SV*)comppad_name);
441 av_store(comppadlist, 1, (SV*)comppad);
442 CvPADLIST(compcv) = comppadlist;
445 (*xsinit)(); /* in case linked C routines want magical variables */
450 init_predump_symbols();
452 init_postdump_symbols(argc,argv,env);
456 /* now parse the script */
459 if (yyparse() || error_count) {
461 croak("%s had compilation errors.\n", origfilename);
463 croak("Execution of %s aborted due to compilation errors.\n",
467 curcop->cop_line = 0;
472 (void)UNLINK(e_tmpname);
475 /* now that script is parsed, we can modify record separator */
480 rspara = (nrslen == 2);
481 sv_setpvn(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), rs, rslen);
498 PerlInterpreter *sv_interp;
500 if (!(curinterp = sv_interp))
502 switch (setjmp(top_env)) {
504 cxstack_ix = -1; /* start context stack again */
511 return(statusvalue); /* my_exit() was called */
514 fprintf(stderr, "panic: restartop\n");
518 if (stack != mainstack) {
520 SWITCHSTACK(stack, mainstack);
527 DEBUG(fprintf(stderr,"\nEXECUTING...\n\n"));
530 fprintf(stderr,"%s syntax OK\n", origfilename);
533 if (perldb && DBsingle)
534 sv_setiv(DBsingle, 1);
544 else if (main_start) {
557 register CONTEXT *cx;
561 statusvalue = FIXSTATUS(status);
562 if (cxstack_ix >= 0) {
572 perl_get_sv(name, create)
576 GV* gv = gv_fetchpv(name, create, SVt_PV);
583 perl_get_av(name, create)
587 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
596 perl_get_hv(name, create)
600 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
609 perl_get_cv(name, create)
613 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
614 if (create && !GvCV(gv))
615 return newSUB(start_subparse(),
616 newSVOP(OP_CONST, 0, newSVpv(name,0)),
624 /* Be sure to refetch the stack pointer after calling these routines. */
627 perl_call_argv(subname, flags, argv)
629 I32 flags; /* See G_* flags in cop.h */
630 register char **argv; /* null terminated arg list */
637 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
642 return perl_call_pv(subname, flags);
646 perl_call_pv(subname, flags)
647 char *subname; /* name of the subroutine */
648 I32 flags; /* See G_* flags in cop.h */
650 return perl_call_sv((SV*)perl_get_cv(subname, TRUE), flags);
654 perl_call_method(methname, flags)
655 char *methname; /* name of the subroutine */
656 I32 flags; /* See G_* flags in cop.h */
662 XPUSHs(sv_2mortal(newSVpv(methname,0)));
665 return perl_call_sv(*stack_sp--, flags);
668 /* May be called with any of a CV, a GV, or an SV containing the name. */
670 perl_call_sv(sv, flags)
672 I32 flags; /* See G_* flags in cop.h */
674 LOGOP myop; /* fake syntax tree node */
676 I32 oldmark = TOPMARK;
681 if (flags & G_DISCARD) {
691 oldscope = scopestack_ix;
693 if (!(flags & G_NOARGS))
694 myop.op_flags = OPf_STACKED;
695 myop.op_next = Nullop;
696 myop.op_flags |= OPf_KNOW;
698 myop.op_flags |= OPf_LIST;
700 if (flags & G_EVAL) {
701 Copy(top_env, oldtop, 1, jmp_buf);
703 cLOGOP->op_other = op;
705 /* we're trying to emulate pp_entertry() here */
707 register CONTEXT *cx;
713 push_return(op->op_next);
714 PUSHBLOCK(cx, CXt_EVAL, stack_sp);
716 eval_root = op; /* Only needed so that goto works right. */
719 if (flags & G_KEEPERR)
722 sv_setpv(GvSV(errgv),"");
727 switch (setjmp(top_env)) {
732 statusvalue = 255; /* XXX I don't think we use 1 anymore. */
738 /* my_exit() was called */
741 Copy(oldtop, top_env, 1, jmp_buf);
743 croak("Callback called exit");
744 my_exit(statusvalue);
752 stack_sp = stack_base + oldmark;
757 *++stack_sp = &sv_undef;
763 if (op == (OP*)&myop)
767 retval = stack_sp - (stack_base + oldmark);
768 if ((flags & G_EVAL) && !(flags & G_KEEPERR))
769 sv_setpv(GvSV(errgv),"");
772 if (flags & G_EVAL) {
773 if (scopestack_ix > oldscope) {
777 register CONTEXT *cx;
786 Copy(oldtop, top_env, 1, jmp_buf);
788 if (flags & G_DISCARD) {
789 stack_sp = stack_base + oldmark;
800 perl_eval_sv(sv, flags)
802 I32 flags; /* See G_* flags in cop.h */
804 UNOP myop; /* fake syntax tree node */
806 I32 oldmark = sp - stack_base;
811 if (flags & G_DISCARD) {
821 oldscope = scopestack_ix;
823 if (!(flags & G_NOARGS))
824 myop.op_flags = OPf_STACKED;
825 myop.op_next = Nullop;
826 myop.op_flags |= OPf_KNOW;
828 myop.op_flags |= OPf_LIST;
830 Copy(top_env, oldtop, 1, jmp_buf);
833 switch (setjmp(top_env)) {
838 statusvalue = 255; /* XXX I don't think we use 1 anymore. */
844 /* my_exit() was called */
847 Copy(oldtop, top_env, 1, jmp_buf);
849 croak("Callback called exit");
850 my_exit(statusvalue);
858 stack_sp = stack_base + oldmark;
863 *++stack_sp = &sv_undef;
868 if (op == (OP*)&myop)
872 retval = stack_sp - (stack_base + oldmark);
873 if ((flags & G_EVAL) && !(flags & G_KEEPERR))
874 sv_setpv(GvSV(errgv),"");
877 Copy(oldtop, top_env, 1, jmp_buf);
878 if (flags & G_DISCARD) {
879 stack_sp = stack_base + oldmark;
887 /* Require a module. */
893 SV* sv = sv_newmortal();
894 sv_setpv(sv, "require '");
897 perl_eval_sv(sv, G_DISCARD);
901 magicname(sym,name,namlen)
908 if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
909 sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
913 # define PERLLIB_SEP ';'
916 # define PERLLIB_SEP '|'
918 # define PERLLIB_SEP ':'
931 /* Break at all separators */
933 /* First, skip any consecutive separators */
934 while ( *p == PERLLIB_SEP ) {
935 /* Uncomment the next line for PATH semantics */
936 /* av_push(GvAVn(incgv), newSVpv(".", 1)); */
939 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
940 av_push(GvAVn(incgv), newSVpv(p, (STRLEN)(s - p)));
943 av_push(GvAVn(incgv), newSVpv(p, 0));
950 usage(name) /* XXX move this out into a module ? */
953 printf("\nUsage: %s [switches] [filename] [arguments]\n",name);
954 printf("\n -0[octal] specify record separator (\\0, if no argument)");
955 printf("\n -a autosplit mode with -n or -p");
956 printf("\n -c check syntax only (runs BEGIN and END blocks)");
957 printf("\n -d[:debugger] run scripts under debugger");
958 printf("\n -D[number/list] set debugging flags (argument is a bit mask or flags)");
959 printf("\n -e command one line of script, multiple -e options are allowed");
960 printf("\n [filename] can be ommitted when -e is used");
961 printf("\n -F regexp regular expression for autosplit (-a)");
962 printf("\n -i[extension] edit <> files in place (make backup if extension supplied)");
963 printf("\n -Idirectory specify include directory (may be used more then once)");
964 printf("\n -l[octal] enable line ending processing, specifies line teminator");
965 printf("\n -n assume 'while (<>) { ... }' loop arround your script");
966 printf("\n -p assume loop like -n but print line also like sed");
967 printf("\n -P run script through C preprocessor before compilation");
969 printf("\n -R enable REXX variable pool");
971 printf("\n -s enable some switch parsing for switches after script name");
972 printf("\n -S look for the script using PATH environment variable");
973 printf("\n -T turn on tainting checks");
974 printf("\n -u dump core after parsing script");
975 printf("\n -U allow unsafe operations");
976 printf("\n -v print version number and patchlevel of perl");
977 printf("\n -V[:variable] print perl configuration information");
978 printf("\n -w turn warnings on for compilation of your script");
979 printf("\n -x[directory] strip off text before #!perl line and perhaps cd to directory\n");
982 /* This routine handles any switches that can be given during run */
992 nrschar = scan_oct(s, 4, &numlen);
993 nrs = savepvn("\n",1);
995 if (nrschar > 0377) {
999 else if (!nrschar && numlen >= 2) {
1007 splitstr = savepv(s + 1);
1022 sprintf(buf, "use Devel::%s;", ++s);
1024 my_setenv("PERL5DB",buf);
1034 if (isALPHA(s[1])) {
1035 static char debopts[] = "psltocPmfrxuLHXD";
1038 for (s++; *s && (d = strchr(debopts,*s)); s++)
1039 debug |= 1 << (d - debopts);
1043 for (s++; isDIGIT(*s); s++) ;
1045 debug |= 0x80000000;
1047 warn("Recompile perl with -DDEBUGGING to use -D switch\n");
1048 for (s++; isALNUM(*s); s++) ;
1058 inplace = savepv(s+1);
1060 for (s = inplace; *s && !isSPACE(*s); s++) ;
1067 for (e = s; *e && !isSPACE(*e); e++) ;
1068 av_push(GvAVn(incgv),newSVpv(s,e-s));
1073 croak("No space allowed after -I");
1083 *ors = scan_oct(s, 3 + (*s == '0'), &numlen);
1087 ors = savepvn(nrs,nrslen);
1092 taint_not("-M"); /* XXX ? */
1095 taint_not("-m"); /* XXX ? */
1098 if (preambleav == NULL)
1099 preambleav = newAV();
1100 /* We allow -M'Module qw(Foo Bar)' */
1102 sprintf(tmpbuf, "use %s;", s);
1104 sprintf(tmpbuf, "use %s ();", s);
1105 av_push(preambleav, newSVpv(tmpbuf,0));
1109 croak("No space allowed after -%c", *(s-1));
1137 printf("\nThis is perl, version %s beta2",patchlevel);
1139 #if defined(DEBUGGING) || defined(EMBED) || defined(MULTIPLICITY)
1140 fputs(" with", stdout);
1142 fputs(" DEBUGGING", stdout);
1145 fputs(" EMBED", stdout);
1148 fputs(" MULTIPLICITY", stdout);
1152 fputs("\n\nCopyright 1987-1996, Larry Wall\n",stdout);
1154 fputs("MS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n",
1158 fputs("OS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
1159 "Version 5 port Copyright (c) 1994-1995, Andreas Kaiser\n", stdout);
1162 fputs("atariST series port, ++jrb bammi@cadence.com\n", stdout);
1165 Perl may be copied only under the terms of either the Artistic License or the\n\
1166 GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n",stdout);
1177 if (s[1] == '-') /* Additional switches on #! line. */
1190 croak("Can't emulate -%.1s on #! line",s);
1195 /* compliments of Tom Christiansen */
1197 /* unexec() can be found in the Gnu emacs distribution */
1206 sprintf (buf, "%s.perldump", origfilename);
1207 sprintf (tokenbuf, "%s/perl", BIN);
1209 status = unexec(buf, tokenbuf, &etext, sbrk(0), 0);
1211 fprintf(stderr, "unexec of %s into %s failed!\n", tokenbuf, buf);
1214 ABORT(); /* for use with undump */
1222 curstash = defstash = newHV();
1223 curstname = newSVpv("main",4);
1224 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
1225 SvREFCNT_dec(GvHV(gv));
1226 GvHV(gv) = (HV*)SvREFCNT_inc(defstash);
1228 HvNAME(defstash) = savepv("main");
1229 incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
1231 defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
1232 errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
1234 curstash = defstash;
1235 compiling.cop_stash = defstash;
1236 debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
1237 /* We must init $/ before switches are processed. */
1238 sv_setpvn(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), "\n", 1);
1241 #ifdef CAN_PROTOTYPE
1243 open_script(char *scriptname, bool dosearch, SV *sv)
1246 open_script(scriptname,dosearch,sv)
1252 char *xfound = Nullch;
1253 char *xfailed = Nullch;
1257 if (dosearch && !strchr(scriptname, '/') && (s = getenv("PATH"))) {
1259 bufend = s + strlen(s);
1262 s = cpytill(tokenbuf,s,bufend,':',&len);
1265 for (len = 0; *s && *s != ',' && *s != ';'; tokenbuf[len++] = *s++);
1266 tokenbuf[len] = '\0';
1268 for (len = 0; *s && *s != ';'; tokenbuf[len++] = *s++);
1269 tokenbuf[len] = '\0';
1275 if (len && tokenbuf[len-1] != '/')
1278 if (len && ((tokenbuf[len-1] != '\\') && (tokenbuf[len-1] != '/')))
1280 if (len && tokenbuf[len-1] != '\\')
1283 (void)strcat(tokenbuf+len,"/");
1284 (void)strcat(tokenbuf+len,scriptname);
1285 DEBUG_p(fprintf(stderr,"Looking for %s\n",tokenbuf));
1286 if (Stat(tokenbuf,&statbuf) < 0) /* not there? */
1288 if (S_ISREG(statbuf.st_mode)
1289 && cando(S_IRUSR,TRUE,&statbuf) && cando(S_IXUSR,TRUE,&statbuf)) {
1290 xfound = tokenbuf; /* bingo! */
1294 xfailed = savepv(tokenbuf);
1297 croak("Can't execute %s", xfailed ? xfailed : scriptname );
1300 scriptname = xfound;
1303 origfilename = savepv(e_fp ? "-e" : scriptname);
1304 curcop->cop_filegv = gv_fetchfile(origfilename);
1305 if (strEQ(origfilename,"-"))
1308 char *cpp = CPPSTDIN;
1310 if (strEQ(cpp,"cppstdin"))
1311 sprintf(tokenbuf, "%s/%s", SCRIPTDIR, cpp);
1313 sprintf(tokenbuf, "%s", cpp);
1315 sv_catpv(sv,PRIVLIB_EXP);
1317 (void)sprintf(buf, "\
1318 sed %s -e \"/^[^#]/b\" \
1319 -e \"/^#[ ]*include[ ]/b\" \
1320 -e \"/^#[ ]*define[ ]/b\" \
1321 -e \"/^#[ ]*if[ ]/b\" \
1322 -e \"/^#[ ]*ifdef[ ]/b\" \
1323 -e \"/^#[ ]*ifndef[ ]/b\" \
1324 -e \"/^#[ ]*else/b\" \
1325 -e \"/^#[ ]*elif[ ]/b\" \
1326 -e \"/^#[ ]*undef[ ]/b\" \
1327 -e \"/^#[ ]*endif/b\" \
1330 (doextract ? "-e \"1,/^#/d\n\"" : ""),
1332 (void)sprintf(buf, "\
1333 %s %s -e '/^[^#]/b' \
1334 -e '/^#[ ]*include[ ]/b' \
1335 -e '/^#[ ]*define[ ]/b' \
1336 -e '/^#[ ]*if[ ]/b' \
1337 -e '/^#[ ]*ifdef[ ]/b' \
1338 -e '/^#[ ]*ifndef[ ]/b' \
1339 -e '/^#[ ]*else/b' \
1340 -e '/^#[ ]*elif[ ]/b' \
1341 -e '/^#[ ]*undef[ ]/b' \
1342 -e '/^#[ ]*endif/b' \
1350 (doextract ? "-e '1,/^#/d\n'" : ""),
1352 scriptname, tokenbuf, SvPV(sv, na), CPPMINUS);
1354 #ifdef IAMSUID /* actually, this is caught earlier */
1355 if (euid != uid && !euid) { /* if running suidperl */
1357 (void)seteuid(uid); /* musn't stay setuid root */
1360 (void)setreuid((Uid_t)-1, uid);
1362 #ifdef HAS_SETRESUID
1363 (void)setresuid((Uid_t)-1, uid, (Uid_t)-1);
1369 if (geteuid() != uid)
1370 croak("Can't do seteuid!\n");
1372 #endif /* IAMSUID */
1373 rsfp = my_popen(buf,"r");
1375 else if (!*scriptname) {
1376 taint_not("program input from stdin");
1380 rsfp = fopen(scriptname,"r");
1381 if ((FILE*)rsfp == Nullfp) {
1383 #ifndef IAMSUID /* in case script is not readable before setuid */
1384 if (euid && Stat(SvPVX(GvSV(curcop->cop_filegv)),&statbuf) >= 0 &&
1385 statbuf.st_mode & (S_ISUID|S_ISGID)) {
1386 (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel);
1387 execv(buf, origargv); /* try again */
1388 croak("Can't do setuid\n");
1392 croak("Can't open perl script \"%s\": %s\n",
1393 SvPVX(GvSV(curcop->cop_filegv)), Strerror(errno));
1398 validate_suid(validarg)
1401 /* do we need to emulate setuid on scripts? */
1403 /* This code is for those BSD systems that have setuid #! scripts disabled
1404 * in the kernel because of a security problem. Merely defining DOSUID
1405 * in perl will not fix that problem, but if you have disabled setuid
1406 * scripts in the kernel, this will attempt to emulate setuid and setgid
1407 * on scripts that have those now-otherwise-useless bits set. The setuid
1408 * root version must be called suidperl or sperlN.NNN. If regular perl
1409 * discovers that it has opened a setuid script, it calls suidperl with
1410 * the same argv that it had. If suidperl finds that the script it has
1411 * just opened is NOT setuid root, it sets the effective uid back to the
1412 * uid. We don't just make perl setuid root because that loses the
1413 * effective uid we had before invoking perl, if it was different from the
1416 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
1417 * be defined in suidperl only. suidperl must be setuid root. The
1418 * Configure script will set this up for you if you want it.
1424 if (Fstat(fileno(rsfp),&statbuf) < 0) /* normal stat is insecure */
1425 croak("Can't stat script \"%s\"",origfilename);
1426 if (statbuf.st_mode & (S_ISUID|S_ISGID)) {
1430 #ifndef HAS_SETREUID
1431 /* On this access check to make sure the directories are readable,
1432 * there is actually a small window that the user could use to make
1433 * filename point to an accessible directory. So there is a faint
1434 * chance that someone could execute a setuid script down in a
1435 * non-accessible directory. I don't know what to do about that.
1436 * But I don't think it's too important. The manual lies when
1437 * it says access() is useful in setuid programs.
1439 if (access(SvPVX(GvSV(curcop->cop_filegv)),1)) /*double check*/
1440 croak("Permission denied");
1442 /* If we can swap euid and uid, then we can determine access rights
1443 * with a simple stat of the file, and then compare device and
1444 * inode to make sure we did stat() on the same file we opened.
1445 * Then we just have to make sure he or she can execute it.
1448 struct stat tmpstatbuf;
1452 setreuid(euid,uid) < 0
1455 setresuid(euid,uid,(Uid_t)-1) < 0
1458 || getuid() != euid || geteuid() != uid)
1459 croak("Can't swap uid and euid"); /* really paranoid */
1460 if (Stat(SvPVX(GvSV(curcop->cop_filegv)),&tmpstatbuf) < 0)
1461 croak("Permission denied"); /* testing full pathname here */
1462 if (tmpstatbuf.st_dev != statbuf.st_dev ||
1463 tmpstatbuf.st_ino != statbuf.st_ino) {
1465 if (rsfp = my_popen("/bin/mail root","w")) { /* heh, heh */
1467 "User %d tried to run dev %d ino %d in place of dev %d ino %d!\n\
1468 (Filename of set-id script was %s, uid %d gid %d.)\n\nSincerely,\nperl\n",
1469 uid,tmpstatbuf.st_dev, tmpstatbuf.st_ino,
1470 statbuf.st_dev, statbuf.st_ino,
1471 SvPVX(GvSV(curcop->cop_filegv)),
1472 statbuf.st_uid, statbuf.st_gid);
1473 (void)my_pclose(rsfp);
1475 croak("Permission denied\n");
1479 setreuid(uid,euid) < 0
1481 # if defined(HAS_SETRESUID)
1482 setresuid(uid,euid,(Uid_t)-1) < 0
1485 || getuid() != uid || geteuid() != euid)
1486 croak("Can't reswap uid and euid");
1487 if (!cando(S_IXUSR,FALSE,&statbuf)) /* can real uid exec? */
1488 croak("Permission denied\n");
1490 #endif /* HAS_SETREUID */
1491 #endif /* IAMSUID */
1493 if (!S_ISREG(statbuf.st_mode))
1494 croak("Permission denied");
1495 if (statbuf.st_mode & S_IWOTH)
1496 croak("Setuid/gid script is writable by world");
1497 doswitches = FALSE; /* -s is insecure in suid */
1499 if (fgets(tokenbuf,sizeof tokenbuf, rsfp) == Nullch ||
1500 strnNE(tokenbuf,"#!",2) ) /* required even on Sys V */
1501 croak("No #! line");
1504 while (!isSPACE(*s)) s++;
1505 if (strnNE(s-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
1506 croak("Not a perl script");
1507 while (*s == ' ' || *s == '\t') s++;
1509 * #! arg must be what we saw above. They can invoke it by
1510 * mentioning suidperl explicitly, but they may not add any strange
1511 * arguments beyond what #! says if they do invoke suidperl that way.
1513 len = strlen(validarg);
1514 if (strEQ(validarg," PHOOEY ") ||
1515 strnNE(s,validarg,len) || !isSPACE(s[len]))
1516 croak("Args must match #! line");
1519 if (euid != uid && (statbuf.st_mode & S_ISUID) &&
1520 euid == statbuf.st_uid)
1522 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
1523 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
1524 #endif /* IAMSUID */
1526 if (euid) { /* oops, we're not the setuid root perl */
1529 (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel);
1530 execv(buf, origargv); /* try again */
1532 croak("Can't do setuid\n");
1535 if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid) {
1537 (void)setegid(statbuf.st_gid);
1540 (void)setregid((Gid_t)-1,statbuf.st_gid);
1542 #ifdef HAS_SETRESGID
1543 (void)setresgid((Gid_t)-1,statbuf.st_gid,(Gid_t)-1);
1545 setgid(statbuf.st_gid);
1549 if (getegid() != statbuf.st_gid)
1550 croak("Can't do setegid!\n");
1552 if (statbuf.st_mode & S_ISUID) {
1553 if (statbuf.st_uid != euid)
1555 (void)seteuid(statbuf.st_uid); /* all that for this */
1558 (void)setreuid((Uid_t)-1,statbuf.st_uid);
1560 #ifdef HAS_SETRESUID
1561 (void)setresuid((Uid_t)-1,statbuf.st_uid,(Uid_t)-1);
1563 setuid(statbuf.st_uid);
1567 if (geteuid() != statbuf.st_uid)
1568 croak("Can't do seteuid!\n");
1570 else if (uid) { /* oops, mustn't run as root */
1572 (void)seteuid((Uid_t)uid);
1575 (void)setreuid((Uid_t)-1,(Uid_t)uid);
1577 #ifdef HAS_SETRESUID
1578 (void)setresuid((Uid_t)-1,(Uid_t)uid,(Uid_t)-1);
1584 if (geteuid() != uid)
1585 croak("Can't do seteuid!\n");
1588 if (!cando(S_IXUSR,TRUE,&statbuf))
1589 croak("Permission denied\n"); /* they can't do this */
1592 else if (preprocess)
1593 croak("-P not allowed for setuid/setgid script\n");
1595 croak("Script is not setuid/setgid in suidperl\n");
1596 #endif /* IAMSUID */
1598 if (euid != uid || egid != gid) { /* (suidperl doesn't exist, in fact) */
1599 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
1600 Fstat(fileno(rsfp),&statbuf); /* may be either wrapped or real suid */
1601 if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
1603 (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
1606 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
1607 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
1608 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
1609 /* not set-id, must be wrapped */
1619 /* skip forward in input to the real script? */
1623 if ((s = sv_gets(linestr, rsfp, 0)) == Nullch)
1624 croak("No Perl script found in input\n");
1625 if (*s == '#' && s[1] == '!' && instr(s,"perl")) {
1626 ungetc('\n',rsfp); /* to keep line count right */
1628 if (s = instr(s,"perl -")) {
1631 while (s = moreswitches(s)) ;
1633 if (cddir && chdir(cddir) < 0)
1634 croak("Can't chdir to %s",cddir);
1642 uid = (int)getuid();
1643 euid = (int)geteuid();
1644 gid = (int)getgid();
1645 egid = (int)getegid();
1650 tainting |= (uid && (euid != uid || egid != gid));
1656 curstash = debstash;
1657 dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
1659 DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
1660 DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
1661 DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
1662 DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
1663 DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
1664 DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
1665 curstash = defstash;
1672 mainstack = stack; /* remember in case we switch stacks */
1673 AvREAL_off(stack); /* not a real array */
1674 av_extend(stack,127);
1676 stack_base = AvARRAY(stack);
1677 stack_sp = stack_base;
1678 stack_max = stack_base + 127;
1680 New(54,markstack,64,I32);
1681 markstack_ptr = markstack;
1682 markstack_max = markstack + 64;
1684 New(54,scopestack,32,I32);
1686 scopestack_max = 32;
1688 New(54,savestack,128,ANY);
1690 savestack_max = 128;
1692 New(54,retstack,16,OP*);
1696 New(50,cxstack,128,CONTEXT);
1700 New(50,tmps_stack,128,SV*);
1705 New(51,debname,128,char);
1706 New(52,debdelim,128,char);
1710 static FILE *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
1718 subname = newSVpv("main",4);
1722 init_predump_symbols()
1727 sv_setpvn(GvSV(gv_fetchpv("\"", TRUE, SVt_PV)), " ", 1);
1729 stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
1730 SvMULTI_on(stdingv);
1731 IoIFP(GvIOp(stdingv)) = stdin;
1732 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
1733 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(stdingv));
1736 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
1738 IoOFP(GvIOp(tmpgv)) = IoIFP(GvIOp(tmpgv)) = stdout;
1740 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
1741 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(defoutgv));
1744 othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
1745 SvMULTI_on(othergv);
1746 IoOFP(GvIOp(othergv)) = IoIFP(GvIOp(othergv)) = stderr;
1747 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
1748 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(othergv));
1751 statname = NEWSV(66,0); /* last filename we did stat on */
1755 init_postdump_symbols(argc,argv,env)
1757 register char **argv;
1758 register char **env;
1764 argc--,argv++; /* skip name of script */
1766 for (; argc > 0 && **argv == '-'; argc--,argv++) {
1769 if (argv[0][1] == '-') {
1773 if (s = strchr(argv[0], '=')) {
1775 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
1778 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
1781 toptarget = NEWSV(0,0);
1782 sv_upgrade(toptarget, SVt_PVFM);
1783 sv_setpvn(toptarget, "", 0);
1784 bodytarget = NEWSV(0,0);
1785 sv_upgrade(bodytarget, SVt_PVFM);
1786 sv_setpvn(bodytarget, "", 0);
1787 formtarget = bodytarget;
1790 if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
1791 sv_setpv(GvSV(tmpgv),origfilename);
1792 magicname("0", "0", 1);
1794 if (tmpgv = gv_fetchpv("\024",TRUE, SVt_PV))
1796 if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
1797 sv_setpv(GvSV(tmpgv),origargv[0]);
1798 if (argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
1800 (void)gv_AVadd(argvgv);
1801 av_clear(GvAVn(argvgv));
1802 for (; argc > 0; argc--,argv++) {
1803 av_push(GvAVn(argvgv),newSVpv(argv[0],0));
1806 if (envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
1811 #ifndef VMS /* VMS doesn't have environ array */
1812 /* Note that if the supplied env parameter is actually a copy
1813 of the global environ then it may now point to free'd memory
1814 if the environment has been modified since. To avoid this
1815 problem we treat env==NULL as meaning 'use the default'
1819 if (env != environ) {
1820 environ[0] = Nullch;
1821 hv_magic(hv, envgv, 'E');
1823 for (; *env; env++) {
1824 if (!(s = strchr(*env,'=')))
1827 sv = newSVpv(s--,0);
1828 sv_magic(sv, sv, 'e', *env, s - *env);
1829 (void)hv_store(hv, *env, s - *env, sv, 0);
1833 #ifdef DYNAMIC_ENV_FETCH
1834 HvNAME(hv) = savepv(ENV_HV_NAME);
1836 hv_magic(hv, envgv, 'E');
1839 if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
1840 sv_setiv(GvSV(tmpgv),(I32)getpid());
1849 s = getenv("PERL5LIB");
1853 incpush(getenv("PERLLIB"));
1857 incpush(APPLLIB_EXP);
1861 incpush(ARCHLIB_EXP);
1864 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
1866 incpush(PRIVLIB_EXP);
1869 incpush(SITEARCH_EXP);
1872 incpush(SITELIB_EXP);
1874 #ifdef OLDARCHLIB_EXP /* 5.00[01] compatibility */
1875 incpush(OLDARCHLIB_EXP);
1888 line_t oldline = curcop->cop_line;
1890 Copy(top_env, oldtop, 1, jmp_buf);
1892 while (AvFILL(list) >= 0) {
1893 CV *cv = (CV*)av_shift(list);
1897 switch (setjmp(top_env)) {
1899 SV* atsv = GvSV(errgv);
1901 perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
1902 (void)SvPV(atsv, len);
1904 Copy(oldtop, top_env, 1, jmp_buf);
1905 curcop = &compiling;
1906 curcop->cop_line = oldline;
1907 if (list == beginav)
1908 sv_catpv(atsv, "BEGIN failed--compilation aborted");
1910 sv_catpv(atsv, "END failed--cleanup aborted");
1911 croak("%s", SvPVX(atsv));
1917 statusvalue = 255; /* XXX I don't think we use 1 anymore. */
1923 /* my_exit() was called */
1924 curstash = defstash;
1928 Copy(oldtop, top_env, 1, jmp_buf);
1929 curcop = &compiling;
1930 curcop->cop_line = oldline;
1932 if (list == beginav)
1933 croak("BEGIN failed--compilation aborted");
1935 croak("END failed--cleanup aborted");
1937 my_exit(statusvalue);
1942 fprintf(stderr, "panic: restartop\n");
1946 Copy(oldtop, top_env, 1, jmp_buf);
1947 curcop = &compiling;
1948 curcop->cop_line = oldline;
1949 longjmp(top_env, 3);
1953 Copy(oldtop, top_env, 1, jmp_buf);