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);
87 nrs = newSVpv("\n", 1);
88 rs = SvREFCNT_inc(nrs);
92 * There is no way we can refer to them from Perl so close them to save
93 * space. The other alternative would be to provide STDAUX and STDPRN
117 sprintf(patchlevel, "%5.3f", 5.0 + (PATCHLEVEL / 1000.0));
119 fdpid = newAV(); /* for remembering popen pids by fd */
120 pidstatus = newHV();/* for remembering status of dead pids */
127 perl_destruct(sv_interp)
128 register PerlInterpreter *sv_interp;
130 int destruct_level; /* 0=none, 1=full, 2=full with checks */
134 if (!(curinterp = sv_interp))
137 destruct_level = perl_destruct_level;
141 if (s = getenv("PERL_DESTRUCT_LEVEL"))
142 destruct_level = atoi(s);
150 /* We must account for everything. First the syntax tree. */
152 curpad = AvARRAY(comppad);
159 * Try to destruct global references. We do this first so that the
160 * destructors and destructees still exist. Some sv's might remain.
161 * Non-referenced objects are on their own.
168 if (destruct_level == 0){
170 DEBUG_P(debprofdump());
172 /* The exit() function will do everything that needs doing. */
176 /* Prepare to destruct main symbol table. */
182 if (destruct_level >= 2) {
183 if (scopestack_ix != 0)
184 warn("Unbalanced scopes: %d more ENTERs than LEAVEs\n", scopestack_ix);
185 if (savestack_ix != 0)
186 warn("Unbalanced saves: %d more saves than restores\n", savestack_ix);
187 if (tmps_floor != -1)
188 warn("Unbalanced tmps: %d more allocs than frees\n", tmps_floor + 1);
189 if (cxstack_ix != -1)
190 warn("Unbalanced context: %d more PUSHes than POPs\n", cxstack_ix + 1);
193 /* Now absolutely destruct everything, somehow or other, loops or no. */
195 while (sv_count != 0 && sv_count != last_sv_count) {
196 last_sv_count = sv_count;
200 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));
228 char *scriptname = NULL;
229 VOL bool dosearch = FALSE;
233 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
236 croak("suidperl is no longer needed since the kernel can now execute\n\
237 setuid perl scripts securely.\n");
241 if (!(curinterp = sv_interp))
246 #ifndef VMS /* VMS doesn't have environ array */
247 origenviron = environ;
252 /* Come here if running an undumped a.out. */
254 origfilename = savepv(argv[0]);
256 cxstack_ix = -1; /* start label stack again */
258 init_postdump_symbols(argc,argv,env);
266 switch (setjmp(top_env)) {
277 return(statusvalue); /* my_exit() was called */
279 fprintf(stderr, "panic: top_env\n");
283 sv_setpvn(linestr,"",0);
284 sv = newSVpv("",0); /* first used for -I flags */
287 for (argc--,argv++; argc > 0; argc--,argv++) {
288 if (argv[0][0] != '-' || !argv[0][1])
292 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]);
367 preambleav = newAV();
368 av_push(preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
370 Sv = newSVpv("print myconfig(),'@INC: '.\"@INC\\n\"",0);
373 Sv = newSVpv("config_vars(qw(",0);
378 av_push(preambleav, Sv);
379 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
393 croak("Unrecognized switch: -%s",s);
398 scriptname = argv[0];
400 if (fflush(e_fp) || ferror(e_fp) || fclose(e_fp))
401 croak("Can't write to temp file for -e: %s", Strerror(errno));
403 scriptname = e_tmpname;
405 else if (scriptname == Nullch) {
407 if ( isatty(fileno(stdin)) )
415 open_script(scriptname,dosearch,sv);
417 validate_suid(validarg);
422 compcv = (CV*)NEWSV(1104,0);
423 sv_upgrade((SV *)compcv, SVt_PVCV);
427 av_push(comppad, Nullsv);
428 curpad = AvARRAY(comppad);
430 comppad_name = padname;
431 comppad_name_fill = 0;
432 min_intro_pending = 0;
435 comppadlist = newAV();
436 AvREAL_off(comppadlist);
437 av_store(comppadlist, 0, (SV*)comppad_name);
438 av_store(comppadlist, 1, (SV*)comppad);
439 CvPADLIST(compcv) = comppadlist;
442 (*xsinit)(); /* in case linked C routines want magical variables */
447 init_predump_symbols();
449 init_postdump_symbols(argc,argv,env);
453 /* now parse the script */
456 if (yyparse() || error_count) {
458 croak("%s had compilation errors.\n", origfilename);
460 croak("Execution of %s aborted due to compilation errors.\n",
464 curcop->cop_line = 0;
469 (void)UNLINK(e_tmpname);
472 /* now that script is parsed, we can modify record separator */
474 rs = SvREFCNT_inc(nrs);
475 sv_setsv(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), rs);
486 #ifdef DEBUGGING_MSTATS
487 if ((s=getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
488 dump_mstats("after compilation:");
498 PerlInterpreter *sv_interp;
500 if (!(curinterp = sv_interp))
502 switch (setjmp(top_env)) {
504 cxstack_ix = -1; /* start context stack again */
511 #ifdef DEBUGGING_MSTATS
512 if (getenv("PERL_DEBUG_MSTATS"))
513 dump_mstats("after execution: ");
515 return(statusvalue); /* my_exit() was called */
518 fprintf(stderr, "panic: restartop\n");
522 if (stack != mainstack) {
524 SWITCHSTACK(stack, mainstack);
531 DEBUG(fprintf(stderr,"\nEXECUTING...\n\n"));
534 fprintf(stderr,"%s syntax OK\n", origfilename);
537 if (perldb && DBsingle)
538 sv_setiv(DBsingle, 1);
548 else if (main_start) {
561 register CONTEXT *cx;
565 statusvalue = FIXSTATUS(status);
566 if (cxstack_ix >= 0) {
576 perl_get_sv(name, create)
580 GV* gv = gv_fetchpv(name, create, SVt_PV);
587 perl_get_av(name, create)
591 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
600 perl_get_hv(name, create)
604 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
613 perl_get_cv(name, create)
617 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
618 if (create && !GvCV(gv))
619 return newSUB(start_subparse(),
620 newSVOP(OP_CONST, 0, newSVpv(name,0)),
628 /* Be sure to refetch the stack pointer after calling these routines. */
631 perl_call_argv(subname, flags, argv)
633 I32 flags; /* See G_* flags in cop.h */
634 register char **argv; /* null terminated arg list */
641 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
646 return perl_call_pv(subname, flags);
650 perl_call_pv(subname, flags)
651 char *subname; /* name of the subroutine */
652 I32 flags; /* See G_* flags in cop.h */
654 return perl_call_sv((SV*)perl_get_cv(subname, TRUE), flags);
658 perl_call_method(methname, flags)
659 char *methname; /* name of the subroutine */
660 I32 flags; /* See G_* flags in cop.h */
666 XPUSHs(sv_2mortal(newSVpv(methname,0)));
669 return perl_call_sv(*stack_sp--, flags);
672 /* May be called with any of a CV, a GV, or an SV containing the name. */
674 perl_call_sv(sv, flags)
676 I32 flags; /* See G_* flags in cop.h */
678 LOGOP myop; /* fake syntax tree node */
680 I32 oldmark = TOPMARK;
685 if (flags & G_DISCARD) {
695 oldscope = scopestack_ix;
697 if (!(flags & G_NOARGS))
698 myop.op_flags = OPf_STACKED;
699 myop.op_next = Nullop;
700 myop.op_flags |= OPf_KNOW;
702 myop.op_flags |= OPf_LIST;
704 if (flags & G_EVAL) {
705 Copy(top_env, oldtop, 1, jmp_buf);
707 cLOGOP->op_other = op;
709 /* we're trying to emulate pp_entertry() here */
711 register CONTEXT *cx;
717 push_return(op->op_next);
718 PUSHBLOCK(cx, CXt_EVAL, stack_sp);
720 eval_root = op; /* Only needed so that goto works right. */
723 if (flags & G_KEEPERR)
726 sv_setpv(GvSV(errgv),"");
731 switch (setjmp(top_env)) {
736 statusvalue = 255; /* XXX I don't think we use 1 anymore. */
742 /* my_exit() was called */
745 Copy(oldtop, top_env, 1, jmp_buf);
747 croak("Callback called exit");
748 my_exit(statusvalue);
756 stack_sp = stack_base + oldmark;
761 *++stack_sp = &sv_undef;
767 if (op == (OP*)&myop)
771 retval = stack_sp - (stack_base + oldmark);
772 if ((flags & G_EVAL) && !(flags & G_KEEPERR))
773 sv_setpv(GvSV(errgv),"");
776 if (flags & G_EVAL) {
777 if (scopestack_ix > oldscope) {
781 register CONTEXT *cx;
790 Copy(oldtop, top_env, 1, jmp_buf);
792 if (flags & G_DISCARD) {
793 stack_sp = stack_base + oldmark;
804 perl_eval_sv(sv, flags)
806 I32 flags; /* See G_* flags in cop.h */
808 UNOP myop; /* fake syntax tree node */
810 I32 oldmark = sp - stack_base;
815 if (flags & G_DISCARD) {
825 oldscope = scopestack_ix;
827 if (!(flags & G_NOARGS))
828 myop.op_flags = OPf_STACKED;
829 myop.op_next = Nullop;
830 myop.op_flags |= OPf_KNOW;
832 myop.op_flags |= OPf_LIST;
834 Copy(top_env, oldtop, 1, jmp_buf);
837 switch (setjmp(top_env)) {
842 statusvalue = 255; /* XXX I don't think we use 1 anymore. */
848 /* my_exit() was called */
851 Copy(oldtop, top_env, 1, jmp_buf);
853 croak("Callback called exit");
854 my_exit(statusvalue);
862 stack_sp = stack_base + oldmark;
867 *++stack_sp = &sv_undef;
872 if (op == (OP*)&myop)
876 retval = stack_sp - (stack_base + oldmark);
877 if ((flags & G_EVAL) && !(flags & G_KEEPERR))
878 sv_setpv(GvSV(errgv),"");
881 Copy(oldtop, top_env, 1, jmp_buf);
882 if (flags & G_DISCARD) {
883 stack_sp = stack_base + oldmark;
891 /* Require a module. */
897 SV* sv = sv_newmortal();
898 sv_setpv(sv, "require '");
901 perl_eval_sv(sv, G_DISCARD);
905 magicname(sym,name,namlen)
912 if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
913 sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
917 # define PERLLIB_SEP ';'
920 # define PERLLIB_SEP '|'
922 # define PERLLIB_SEP ':'
935 /* Break at all separators */
937 /* First, skip any consecutive separators */
938 while ( *p == PERLLIB_SEP ) {
939 /* Uncomment the next line for PATH semantics */
940 /* av_push(GvAVn(incgv), newSVpv(".", 1)); */
943 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
944 av_push(GvAVn(incgv), newSVpv(p, (STRLEN)(s - p)));
947 av_push(GvAVn(incgv), newSVpv(p, 0));
954 usage(name) /* XXX move this out into a module ? */
957 printf("\nUsage: %s [switches] [filename] [arguments]\n",name);
958 printf("\n -0[octal] specify record separator (\\0, if no argument)");
959 printf("\n -a autosplit mode with -n or -p");
960 printf("\n -c check syntax only (runs BEGIN and END blocks)");
961 printf("\n -d[:debugger] run scripts under debugger");
962 printf("\n -D[number/list] set debugging flags (argument is a bit mask or flags)");
963 printf("\n -e command one line of script, multiple -e options are allowed");
964 printf("\n [filename] can be ommitted when -e is used");
965 printf("\n -F regexp regular expression for autosplit (-a)");
966 printf("\n -i[extension] edit <> files in place (make backup if extension supplied)");
967 printf("\n -Idirectory specify include directory (may be used more then once)");
968 printf("\n -l[octal] enable line ending processing, specifies line teminator");
969 printf("\n -n assume 'while (<>) { ... }' loop arround your script");
970 printf("\n -p assume loop like -n but print line also like sed");
971 printf("\n -P run script through C preprocessor before compilation");
973 printf("\n -R enable REXX variable pool");
975 printf("\n -s enable some switch parsing for switches after script name");
976 printf("\n -S look for the script using PATH environment variable");
977 printf("\n -T turn on tainting checks");
978 printf("\n -u dump core after parsing script");
979 printf("\n -U allow unsafe operations");
980 printf("\n -v print version number and patchlevel of perl");
981 printf("\n -V[:variable] print perl configuration information");
982 printf("\n -w turn warnings on for compilation of your script");
983 printf("\n -x[directory] strip off text before #!perl line and perhaps cd to directory\n");
986 /* This routine handles any switches that can be given during run */
997 rschar = scan_oct(s, 4, &numlen);
999 if (rschar & ~((U8)~0))
1001 else if (!rschar && numlen >= 2)
1002 nrs = newSVpv("", 0);
1005 nrs = newSVpv(&ch, 1);
1010 splitstr = savepv(s + 1);
1024 if (*s == ':' || *s == '=') {
1025 sprintf(buf, "use Devel::%s;", ++s);
1027 my_setenv("PERL5DB",buf);
1037 if (isALPHA(s[1])) {
1038 static char debopts[] = "psltocPmfrxuLHXD";
1041 for (s++; *s && (d = strchr(debopts,*s)); s++)
1042 debug |= 1 << (d - debopts);
1046 for (s++; isDIGIT(*s); s++) ;
1048 debug |= 0x80000000;
1050 warn("Recompile perl with -DDEBUGGING to use -D switch\n");
1051 for (s++; isALNUM(*s); s++) ;
1061 inplace = savepv(s+1);
1063 for (s = inplace; *s && !isSPACE(*s); s++) ;
1070 for (e = s; *e && !isSPACE(*e); e++) ;
1071 av_push(GvAVn(incgv),newSVpv(s,e-s));
1076 croak("No space allowed after -I");
1086 *ors = scan_oct(s, 3 + (*s == '0'), &numlen);
1091 ors = savepvn("\n\n", 2);
1095 ors = SvPV(nrs, orslen);
1099 taint_not("-M"); /* XXX ? */
1102 taint_not("-m"); /* XXX ? */
1105 Sv = newSVpv("use ",4);
1106 /* We allow -M'Module qw(Foo Bar)' */
1107 while(isALNUM(*s) || *s==':') ++s;
1109 sv_catpv(Sv, start);
1110 if (*(start-1) == 'm') {
1112 croak("Can't use '%c' after -mname", *s);
1113 sv_catpv( Sv, " ()");
1116 sv_catpvn(Sv, start, s-start);
1117 sv_catpv(Sv, " qw(");
1122 if (preambleav == NULL)
1123 preambleav = newAV();
1124 av_push(preambleav, Sv);
1127 croak("No space allowed after -%c", *(s-1));
1155 printf("\nThis is perl, version %s beta3",patchlevel);
1157 #if defined(DEBUGGING) || defined(EMBED) || defined(MULTIPLICITY)
1158 fputs(" with", stdout);
1160 fputs(" DEBUGGING", stdout);
1163 fputs(" EMBED", stdout);
1166 fputs(" MULTIPLICITY", stdout);
1170 fputs("\n\nCopyright 1987-1996, Larry Wall\n",stdout);
1172 fputs("MS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n",
1176 fputs("OS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
1177 "Version 5 port Copyright (c) 1994-1995, Andreas Kaiser\n", stdout);
1180 fputs("atariST series port, ++jrb bammi@cadence.com\n", stdout);
1183 Perl may be copied only under the terms of either the Artistic License or the\n\
1184 GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n",stdout);
1195 if (s[1] == '-') /* Additional switches on #! line. */
1208 croak("Can't emulate -%.1s on #! line",s);
1213 /* compliments of Tom Christiansen */
1215 /* unexec() can be found in the Gnu emacs distribution */
1224 sprintf (buf, "%s.perldump", origfilename);
1225 sprintf (tokenbuf, "%s/perl", BIN);
1227 status = unexec(buf, tokenbuf, &etext, sbrk(0), 0);
1229 fprintf(stderr, "unexec of %s into %s failed!\n", tokenbuf, buf);
1232 ABORT(); /* for use with undump */
1240 curstash = defstash = newHV();
1241 curstname = newSVpv("main",4);
1242 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
1243 SvREFCNT_dec(GvHV(gv));
1244 GvHV(gv) = (HV*)SvREFCNT_inc(defstash);
1246 HvNAME(defstash) = savepv("main");
1247 incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
1249 defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
1250 errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
1252 curstash = defstash;
1253 compiling.cop_stash = defstash;
1254 debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
1255 /* We must init $/ before switches are processed. */
1256 sv_setpvn(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), "\n", 1);
1259 #ifdef CAN_PROTOTYPE
1261 open_script(char *scriptname, bool dosearch, SV *sv)
1264 open_script(scriptname,dosearch,sv)
1270 char *xfound = Nullch;
1271 char *xfailed = Nullch;
1276 if (dosearch && !strpbrk(scriptname,":[</") && (my_getenv("DCL$PATH"))) {
1279 while (my_trnlnm("DCL$PATH",tokenbuf,idx++)) {
1280 strcat(tokenbuf,scriptname);
1282 if (dosearch && !strchr(scriptname, '/') && (s = getenv("PATH"))) {
1284 bufend = s + strlen(s);
1287 s = cpytill(tokenbuf,s,bufend,':',&len);
1290 for (len = 0; *s && *s != ',' && *s != ';'; tokenbuf[len++] = *s++);
1291 tokenbuf[len] = '\0';
1293 for (len = 0; *s && *s != ';'; tokenbuf[len++] = *s++);
1294 tokenbuf[len] = '\0';
1300 if (len && tokenbuf[len-1] != '/')
1303 if (len && ((tokenbuf[len-1] != '\\') && (tokenbuf[len-1] != '/')))
1305 if (len && tokenbuf[len-1] != '\\')
1308 (void)strcat(tokenbuf+len,"/");
1309 (void)strcat(tokenbuf+len,scriptname);
1311 DEBUG_p(fprintf(stderr,"Looking for %s\n",tokenbuf));
1312 if (Stat(tokenbuf,&statbuf) < 0) /* not there? */
1314 if (S_ISREG(statbuf.st_mode)
1315 && cando(S_IRUSR,TRUE,&statbuf) && cando(S_IXUSR,TRUE,&statbuf)) {
1316 xfound = tokenbuf; /* bingo! */
1320 xfailed = savepv(tokenbuf);
1323 croak("Can't execute %s", xfailed ? xfailed : scriptname );
1326 scriptname = xfound;
1329 origfilename = savepv(e_fp ? "-e" : scriptname);
1330 curcop->cop_filegv = gv_fetchfile(origfilename);
1331 if (strEQ(origfilename,"-"))
1334 char *cpp = CPPSTDIN;
1336 if (strEQ(cpp,"cppstdin"))
1337 sprintf(tokenbuf, "%s/%s", SCRIPTDIR, cpp);
1339 sprintf(tokenbuf, "%s", cpp);
1341 sv_catpv(sv,PRIVLIB_EXP);
1343 (void)sprintf(buf, "\
1344 sed %s -e \"/^[^#]/b\" \
1345 -e \"/^#[ ]*include[ ]/b\" \
1346 -e \"/^#[ ]*define[ ]/b\" \
1347 -e \"/^#[ ]*if[ ]/b\" \
1348 -e \"/^#[ ]*ifdef[ ]/b\" \
1349 -e \"/^#[ ]*ifndef[ ]/b\" \
1350 -e \"/^#[ ]*else/b\" \
1351 -e \"/^#[ ]*elif[ ]/b\" \
1352 -e \"/^#[ ]*undef[ ]/b\" \
1353 -e \"/^#[ ]*endif/b\" \
1356 (doextract ? "-e \"1,/^#/d\n\"" : ""),
1358 (void)sprintf(buf, "\
1359 %s %s -e '/^[^#]/b' \
1360 -e '/^#[ ]*include[ ]/b' \
1361 -e '/^#[ ]*define[ ]/b' \
1362 -e '/^#[ ]*if[ ]/b' \
1363 -e '/^#[ ]*ifdef[ ]/b' \
1364 -e '/^#[ ]*ifndef[ ]/b' \
1365 -e '/^#[ ]*else/b' \
1366 -e '/^#[ ]*elif[ ]/b' \
1367 -e '/^#[ ]*undef[ ]/b' \
1368 -e '/^#[ ]*endif/b' \
1376 (doextract ? "-e '1,/^#/d\n'" : ""),
1378 scriptname, tokenbuf, SvPV(sv, na), CPPMINUS);
1380 #ifdef IAMSUID /* actually, this is caught earlier */
1381 if (euid != uid && !euid) { /* if running suidperl */
1383 (void)seteuid(uid); /* musn't stay setuid root */
1386 (void)setreuid((Uid_t)-1, uid);
1388 #ifdef HAS_SETRESUID
1389 (void)setresuid((Uid_t)-1, uid, (Uid_t)-1);
1395 if (geteuid() != uid)
1396 croak("Can't do seteuid!\n");
1398 #endif /* IAMSUID */
1399 rsfp = my_popen(buf,"r");
1401 else if (!*scriptname) {
1402 taint_not("program input from stdin");
1406 rsfp = fopen(scriptname,"r");
1407 if ((FILE*)rsfp == Nullfp) {
1409 #ifndef IAMSUID /* in case script is not readable before setuid */
1410 if (euid && Stat(SvPVX(GvSV(curcop->cop_filegv)),&statbuf) >= 0 &&
1411 statbuf.st_mode & (S_ISUID|S_ISGID)) {
1412 (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel);
1413 execv(buf, origargv); /* try again */
1414 croak("Can't do setuid\n");
1418 croak("Can't open perl script \"%s\": %s\n",
1419 SvPVX(GvSV(curcop->cop_filegv)), Strerror(errno));
1424 validate_suid(validarg)
1427 /* do we need to emulate setuid on scripts? */
1429 /* This code is for those BSD systems that have setuid #! scripts disabled
1430 * in the kernel because of a security problem. Merely defining DOSUID
1431 * in perl will not fix that problem, but if you have disabled setuid
1432 * scripts in the kernel, this will attempt to emulate setuid and setgid
1433 * on scripts that have those now-otherwise-useless bits set. The setuid
1434 * root version must be called suidperl or sperlN.NNN. If regular perl
1435 * discovers that it has opened a setuid script, it calls suidperl with
1436 * the same argv that it had. If suidperl finds that the script it has
1437 * just opened is NOT setuid root, it sets the effective uid back to the
1438 * uid. We don't just make perl setuid root because that loses the
1439 * effective uid we had before invoking perl, if it was different from the
1442 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
1443 * be defined in suidperl only. suidperl must be setuid root. The
1444 * Configure script will set this up for you if you want it.
1450 if (Fstat(fileno(rsfp),&statbuf) < 0) /* normal stat is insecure */
1451 croak("Can't stat script \"%s\"",origfilename);
1452 if (statbuf.st_mode & (S_ISUID|S_ISGID)) {
1456 #ifndef HAS_SETREUID
1457 /* On this access check to make sure the directories are readable,
1458 * there is actually a small window that the user could use to make
1459 * filename point to an accessible directory. So there is a faint
1460 * chance that someone could execute a setuid script down in a
1461 * non-accessible directory. I don't know what to do about that.
1462 * But I don't think it's too important. The manual lies when
1463 * it says access() is useful in setuid programs.
1465 if (access(SvPVX(GvSV(curcop->cop_filegv)),1)) /*double check*/
1466 croak("Permission denied");
1468 /* If we can swap euid and uid, then we can determine access rights
1469 * with a simple stat of the file, and then compare device and
1470 * inode to make sure we did stat() on the same file we opened.
1471 * Then we just have to make sure he or she can execute it.
1474 struct stat tmpstatbuf;
1478 setreuid(euid,uid) < 0
1481 setresuid(euid,uid,(Uid_t)-1) < 0
1484 || getuid() != euid || geteuid() != uid)
1485 croak("Can't swap uid and euid"); /* really paranoid */
1486 if (Stat(SvPVX(GvSV(curcop->cop_filegv)),&tmpstatbuf) < 0)
1487 croak("Permission denied"); /* testing full pathname here */
1488 if (tmpstatbuf.st_dev != statbuf.st_dev ||
1489 tmpstatbuf.st_ino != statbuf.st_ino) {
1491 if (rsfp = my_popen("/bin/mail root","w")) { /* heh, heh */
1493 "User %d tried to run dev %d ino %d in place of dev %d ino %d!\n\
1494 (Filename of set-id script was %s, uid %d gid %d.)\n\nSincerely,\nperl\n",
1495 uid,tmpstatbuf.st_dev, tmpstatbuf.st_ino,
1496 statbuf.st_dev, statbuf.st_ino,
1497 SvPVX(GvSV(curcop->cop_filegv)),
1498 statbuf.st_uid, statbuf.st_gid);
1499 (void)my_pclose(rsfp);
1501 croak("Permission denied\n");
1505 setreuid(uid,euid) < 0
1507 # if defined(HAS_SETRESUID)
1508 setresuid(uid,euid,(Uid_t)-1) < 0
1511 || getuid() != uid || geteuid() != euid)
1512 croak("Can't reswap uid and euid");
1513 if (!cando(S_IXUSR,FALSE,&statbuf)) /* can real uid exec? */
1514 croak("Permission denied\n");
1516 #endif /* HAS_SETREUID */
1517 #endif /* IAMSUID */
1519 if (!S_ISREG(statbuf.st_mode))
1520 croak("Permission denied");
1521 if (statbuf.st_mode & S_IWOTH)
1522 croak("Setuid/gid script is writable by world");
1523 doswitches = FALSE; /* -s is insecure in suid */
1525 if (fgets(tokenbuf,sizeof tokenbuf, rsfp) == Nullch ||
1526 strnNE(tokenbuf,"#!",2) ) /* required even on Sys V */
1527 croak("No #! line");
1530 while (!isSPACE(*s)) s++;
1531 if (strnNE(s-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
1532 croak("Not a perl script");
1533 while (*s == ' ' || *s == '\t') s++;
1535 * #! arg must be what we saw above. They can invoke it by
1536 * mentioning suidperl explicitly, but they may not add any strange
1537 * arguments beyond what #! says if they do invoke suidperl that way.
1539 len = strlen(validarg);
1540 if (strEQ(validarg," PHOOEY ") ||
1541 strnNE(s,validarg,len) || !isSPACE(s[len]))
1542 croak("Args must match #! line");
1545 if (euid != uid && (statbuf.st_mode & S_ISUID) &&
1546 euid == statbuf.st_uid)
1548 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
1549 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
1550 #endif /* IAMSUID */
1552 if (euid) { /* oops, we're not the setuid root perl */
1555 (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel);
1556 execv(buf, origargv); /* try again */
1558 croak("Can't do setuid\n");
1561 if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid) {
1563 (void)setegid(statbuf.st_gid);
1566 (void)setregid((Gid_t)-1,statbuf.st_gid);
1568 #ifdef HAS_SETRESGID
1569 (void)setresgid((Gid_t)-1,statbuf.st_gid,(Gid_t)-1);
1571 setgid(statbuf.st_gid);
1575 if (getegid() != statbuf.st_gid)
1576 croak("Can't do setegid!\n");
1578 if (statbuf.st_mode & S_ISUID) {
1579 if (statbuf.st_uid != euid)
1581 (void)seteuid(statbuf.st_uid); /* all that for this */
1584 (void)setreuid((Uid_t)-1,statbuf.st_uid);
1586 #ifdef HAS_SETRESUID
1587 (void)setresuid((Uid_t)-1,statbuf.st_uid,(Uid_t)-1);
1589 setuid(statbuf.st_uid);
1593 if (geteuid() != statbuf.st_uid)
1594 croak("Can't do seteuid!\n");
1596 else if (uid) { /* oops, mustn't run as root */
1598 (void)seteuid((Uid_t)uid);
1601 (void)setreuid((Uid_t)-1,(Uid_t)uid);
1603 #ifdef HAS_SETRESUID
1604 (void)setresuid((Uid_t)-1,(Uid_t)uid,(Uid_t)-1);
1610 if (geteuid() != uid)
1611 croak("Can't do seteuid!\n");
1614 if (!cando(S_IXUSR,TRUE,&statbuf))
1615 croak("Permission denied\n"); /* they can't do this */
1618 else if (preprocess)
1619 croak("-P not allowed for setuid/setgid script\n");
1621 croak("Script is not setuid/setgid in suidperl\n");
1622 #endif /* IAMSUID */
1624 if (euid != uid || egid != gid) { /* (suidperl doesn't exist, in fact) */
1625 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
1626 Fstat(fileno(rsfp),&statbuf); /* may be either wrapped or real suid */
1627 if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
1629 (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
1632 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
1633 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
1634 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
1635 /* not set-id, must be wrapped */
1645 /* skip forward in input to the real script? */
1649 if ((s = sv_gets(linestr, rsfp, 0)) == Nullch)
1650 croak("No Perl script found in input\n");
1651 if (*s == '#' && s[1] == '!' && instr(s,"perl")) {
1652 ungetc('\n',rsfp); /* to keep line count right */
1654 if (s = instr(s,"perl -")) {
1657 while (s = moreswitches(s)) ;
1659 if (cddir && chdir(cddir) < 0)
1660 croak("Can't chdir to %s",cddir);
1668 uid = (int)getuid();
1669 euid = (int)geteuid();
1670 gid = (int)getgid();
1671 egid = (int)getegid();
1676 tainting |= (uid && (euid != uid || egid != gid));
1682 curstash = debstash;
1683 dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
1685 DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
1686 DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
1687 DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
1688 DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
1689 sv_setiv(DBsingle, 0);
1690 DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
1691 sv_setiv(DBtrace, 0);
1692 DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
1693 sv_setiv(DBsignal, 0);
1694 curstash = defstash;
1701 mainstack = stack; /* remember in case we switch stacks */
1702 AvREAL_off(stack); /* not a real array */
1703 av_extend(stack,127);
1705 stack_base = AvARRAY(stack);
1706 stack_sp = stack_base;
1707 stack_max = stack_base + 127;
1709 New(54,markstack,64,I32);
1710 markstack_ptr = markstack;
1711 markstack_max = markstack + 64;
1713 New(54,scopestack,32,I32);
1715 scopestack_max = 32;
1717 New(54,savestack,128,ANY);
1719 savestack_max = 128;
1721 New(54,retstack,16,OP*);
1725 New(50,cxstack,128,CONTEXT);
1729 New(50,tmps_stack,128,SV*);
1734 New(51,debname,128,char);
1735 New(52,debdelim,128,char);
1739 static FILE *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
1747 subname = newSVpv("main",4);
1751 init_predump_symbols()
1756 sv_setpvn(GvSV(gv_fetchpv("\"", TRUE, SVt_PV)), " ", 1);
1758 stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
1759 SvMULTI_on(stdingv);
1760 IoIFP(GvIOp(stdingv)) = stdin;
1761 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
1762 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(stdingv));
1765 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
1767 IoOFP(GvIOp(tmpgv)) = IoIFP(GvIOp(tmpgv)) = stdout;
1769 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
1770 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(defoutgv));
1773 othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
1774 SvMULTI_on(othergv);
1775 IoOFP(GvIOp(othergv)) = IoIFP(GvIOp(othergv)) = stderr;
1776 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
1777 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(othergv));
1780 statname = NEWSV(66,0); /* last filename we did stat on */
1784 init_postdump_symbols(argc,argv,env)
1786 register char **argv;
1787 register char **env;
1793 argc--,argv++; /* skip name of script */
1795 for (; argc > 0 && **argv == '-'; argc--,argv++) {
1798 if (argv[0][1] == '-') {
1802 if (s = strchr(argv[0], '=')) {
1804 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
1807 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
1810 toptarget = NEWSV(0,0);
1811 sv_upgrade(toptarget, SVt_PVFM);
1812 sv_setpvn(toptarget, "", 0);
1813 bodytarget = NEWSV(0,0);
1814 sv_upgrade(bodytarget, SVt_PVFM);
1815 sv_setpvn(bodytarget, "", 0);
1816 formtarget = bodytarget;
1819 if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
1820 sv_setpv(GvSV(tmpgv),origfilename);
1821 magicname("0", "0", 1);
1823 if (tmpgv = gv_fetchpv("\024",TRUE, SVt_PV))
1825 if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
1826 sv_setpv(GvSV(tmpgv),origargv[0]);
1827 if (argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
1829 (void)gv_AVadd(argvgv);
1830 av_clear(GvAVn(argvgv));
1831 for (; argc > 0; argc--,argv++) {
1832 av_push(GvAVn(argvgv),newSVpv(argv[0],0));
1835 if (envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
1840 #ifndef VMS /* VMS doesn't have environ array */
1841 /* Note that if the supplied env parameter is actually a copy
1842 of the global environ then it may now point to free'd memory
1843 if the environment has been modified since. To avoid this
1844 problem we treat env==NULL as meaning 'use the default'
1848 if (env != environ) {
1849 environ[0] = Nullch;
1850 hv_magic(hv, envgv, 'E');
1852 for (; *env; env++) {
1853 if (!(s = strchr(*env,'=')))
1856 sv = newSVpv(s--,0);
1857 sv_magic(sv, sv, 'e', *env, s - *env);
1858 (void)hv_store(hv, *env, s - *env, sv, 0);
1862 #ifdef DYNAMIC_ENV_FETCH
1863 HvNAME(hv) = savepv(ENV_HV_NAME);
1865 hv_magic(hv, envgv, 'E');
1868 if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
1869 sv_setiv(GvSV(tmpgv),(I32)getpid());
1878 s = getenv("PERL5LIB");
1882 incpush(getenv("PERLLIB"));
1886 incpush(APPLLIB_EXP);
1890 incpush(ARCHLIB_EXP);
1893 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
1895 incpush(PRIVLIB_EXP);
1898 incpush(SITEARCH_EXP);
1901 incpush(SITELIB_EXP);
1903 #ifdef OLDARCHLIB_EXP /* 5.00[01] compatibility */
1904 incpush(OLDARCHLIB_EXP);
1917 line_t oldline = curcop->cop_line;
1919 Copy(top_env, oldtop, 1, jmp_buf);
1921 while (AvFILL(list) >= 0) {
1922 CV *cv = (CV*)av_shift(list);
1926 switch (setjmp(top_env)) {
1928 SV* atsv = GvSV(errgv);
1930 perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
1931 (void)SvPV(atsv, len);
1933 Copy(oldtop, top_env, 1, jmp_buf);
1934 curcop = &compiling;
1935 curcop->cop_line = oldline;
1936 if (list == beginav)
1937 sv_catpv(atsv, "BEGIN failed--compilation aborted");
1939 sv_catpv(atsv, "END failed--cleanup aborted");
1940 croak("%s", SvPVX(atsv));
1946 statusvalue = 255; /* XXX I don't think we use 1 anymore. */
1952 /* my_exit() was called */
1953 curstash = defstash;
1957 Copy(oldtop, top_env, 1, jmp_buf);
1958 curcop = &compiling;
1959 curcop->cop_line = oldline;
1961 if (list == beginav)
1962 croak("BEGIN failed--compilation aborted");
1964 croak("END failed--cleanup aborted");
1966 my_exit(statusvalue);
1971 fprintf(stderr, "panic: restartop\n");
1975 Copy(oldtop, top_env, 1, jmp_buf);
1976 curcop = &compiling;
1977 curcop->cop_line = oldline;
1978 longjmp(top_env, 3);
1982 Copy(oldtop, top_env, 1, jmp_buf);