3 * Copyright (c) 1987-1997 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 /* XXX If this causes problems, set i_unistd=undef in the hint file. */
23 #if !defined(STANDARD_C) && !defined(HAS_GETENV_PROTOTYPE)
24 char *getenv _((char *)); /* Usually in <stdlib.h> */
27 dEXTCONST char rcsid[] = "perl.c\nPatch level: ###\n";
35 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
45 curcop = &compiling; \
52 laststype = OP_STAT; \
54 maxsysfd = MAXSYSFD; \
61 laststype = OP_STAT; \
65 static void find_beginning _((void));
66 static void forbid_setid _((char *));
67 static void incpush _((char *, int));
68 static void init_ids _((void));
69 static void init_debugger _((void));
70 static void init_lexer _((void));
71 static void init_main_stash _((void));
72 static void init_perllib _((void));
73 static void init_postdump_symbols _((int, char **, char **));
74 static void init_predump_symbols _((void));
75 static void init_stacks _((void));
76 static void my_exit_jump _((void)) __attribute__((noreturn));
77 static void nuke_stacks _((void));
78 static void open_script _((char *, bool, SV *));
79 static void usage _((char *));
80 static void validate_suid _((char *, char*));
82 static int fdscript = -1;
87 PerlInterpreter *sv_interp;
90 New(53, sv_interp, 1, PerlInterpreter);
95 perl_construct( sv_interp )
96 register PerlInterpreter *sv_interp;
98 if (!(curinterp = sv_interp))
102 Zero(sv_interp, 1, PerlInterpreter);
105 /* Init the real globals? */
107 linestr = NEWSV(65,80);
108 sv_upgrade(linestr,SVt_PVIV);
110 if (!SvREADONLY(&sv_undef)) {
111 SvREADONLY_on(&sv_undef);
115 SvREADONLY_on(&sv_no);
117 sv_setpv(&sv_yes,Yes);
119 SvREADONLY_on(&sv_yes);
122 nrs = newSVpv("\n", 1);
123 rs = SvREFCNT_inc(nrs);
129 * There is no way we can refer to them from Perl so close them to save
130 * space. The other alternative would be to provide STDAUX and STDPRN
133 (void)fclose(stdaux);
134 (void)fclose(stdprn);
140 perl_destruct_level = 1;
142 if(perl_destruct_level > 0)
148 start_env.je_prev = NULL;
149 start_env.je_ret = -1;
150 start_env.je_mustcatch = TRUE;
151 top_env = &start_env;
154 SET_NUMERIC_STANDARD();
155 #if defined(SUBVERSION) && SUBVERSION > 0
156 sprintf(patchlevel, "%7.5f", (double) 5
157 + ((double) PATCHLEVEL / (double) 1000)
158 + ((double) SUBVERSION / (double) 100000));
160 sprintf(patchlevel, "%5.3f", (double) 5 +
161 ((double) PATCHLEVEL / (double) 1000));
164 #if defined(LOCAL_PATCH_COUNT)
165 localpatches = local_patches; /* For possible -v */
168 PerlIO_init(); /* Hook to IO system */
170 fdpid = newAV(); /* for remembering popen pids by fd */
177 perl_destruct(sv_interp)
178 register PerlInterpreter *sv_interp;
180 int destruct_level; /* 0=none, 1=full, 2=full with checks */
184 if (!(curinterp = sv_interp))
187 destruct_level = perl_destruct_level;
191 if (s = getenv("PERL_DESTRUCT_LEVEL")) {
193 if (destruct_level < i)
202 /* We must account for everything. */
204 /* Destroy the main CV and syntax tree */
206 curpad = AvARRAY(comppad);
211 SvREFCNT_dec(main_cv);
216 * Try to destruct global references. We do this first so that the
217 * destructors and destructees still exist. Some sv's might remain.
218 * Non-referenced objects are on their own.
225 /* unhook hooks which will soon be, or use, destroyed data */
226 SvREFCNT_dec(warnhook);
228 SvREFCNT_dec(diehook);
230 SvREFCNT_dec(parsehook);
233 if (destruct_level == 0){
235 DEBUG_P(debprofdump());
237 /* The exit() function will do everything that needs doing. */
241 /* loosen bonds of global variables */
244 (void)PerlIO_close(rsfp);
248 /* Filters for program text */
249 SvREFCNT_dec(rsfp_filters);
250 rsfp_filters = Nullav;
262 sawampersand = FALSE; /* must save all match strings */
263 sawstudy = FALSE; /* do fbm_instr on all strings */
278 /* magical thingies */
280 Safefree(ofs); /* $, */
283 Safefree(ors); /* $\ */
286 SvREFCNT_dec(nrs); /* $\ helper */
289 multiline = 0; /* $* */
291 SvREFCNT_dec(statname);
295 /* defgv, aka *_ should be taken care of elsewhere */
297 #if 0 /* just about all regexp stuff, seems to be ok */
299 /* shortcuts to regexp stuff */
304 SAVEFREEOP(oldlastpm); /* for saving regexp context during debugger */
306 regprecomp = NULL; /* uncompiled string. */
307 regparse = NULL; /* Input-scan pointer. */
308 regxend = NULL; /* End of input for compile */
309 regnpar = 0; /* () count. */
310 regcode = NULL; /* Code-emit pointer; ®dummy = don't. */
311 regsize = 0; /* Code size. */
312 regnaughty = 0; /* How bad is this pattern? */
313 regsawback = 0; /* Did we see \1, ...? */
315 reginput = NULL; /* String-input pointer. */
316 regbol = NULL; /* Beginning of input, for ^ check. */
317 regeol = NULL; /* End of input, for $ check. */
318 regstartp = (char **)NULL; /* Pointer to startp array. */
319 regendp = (char **)NULL; /* Ditto for endp. */
320 reglastparen = 0; /* Similarly for lastparen. */
321 regtill = NULL; /* How far we are required to go. */
322 regflags = 0; /* are we folding, multilining? */
323 regprev = (char)NULL; /* char before regbol, \n if none */
327 /* clean up after study() */
328 SvREFCNT_dec(lastscream);
330 Safefree(screamfirst);
332 Safefree(screamnext);
335 /* startup and shutdown function lists */
336 SvREFCNT_dec(beginav);
341 /* temp stack during pp_sort() */
342 SvREFCNT_dec(sortstack);
345 /* shortcuts just get cleared */
355 /* reset so print() ends up where we expect */
358 /* Prepare to destruct main symbol table. */
365 if (destruct_level >= 2) {
366 if (scopestack_ix != 0)
367 warn("Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
368 (long)scopestack_ix);
369 if (savestack_ix != 0)
370 warn("Unbalanced saves: %ld more saves than restores\n",
372 if (tmps_floor != -1)
373 warn("Unbalanced tmps: %ld more allocs than frees\n",
374 (long)tmps_floor + 1);
375 if (cxstack_ix != -1)
376 warn("Unbalanced context: %ld more PUSHes than POPs\n",
377 (long)cxstack_ix + 1);
380 /* Now absolutely destruct everything, somehow or other, loops or no. */
382 SvFLAGS(strtab) |= SVTYPEMASK; /* don't clean out strtab now */
383 while (sv_count != 0 && sv_count != last_sv_count) {
384 last_sv_count = sv_count;
387 SvFLAGS(strtab) &= ~SVTYPEMASK;
388 SvFLAGS(strtab) |= SVt_PVHV;
390 /* Destruct the global string table. */
392 /* Yell and reset the HeVAL() slots that are still holding refcounts,
393 * so that sv_free() won't fail on them.
402 array = HvARRAY(strtab);
406 warn("Unbalanced string table refcount: (%d) for \"%s\"",
407 HeVAL(hent) - Nullsv, HeKEY(hent));
408 HeVAL(hent) = Nullsv;
418 SvREFCNT_dec(strtab);
421 warn("Scalars leaked: %ld\n", (long)sv_count);
425 /* No SVs have survived, need to clean out */
429 Safefree(origfilename);
431 hints = 0; /* Reset hints. Should hints be per-interpreter ? */
433 DEBUG_P(debprofdump());
435 /* As the absolutely last thing, free the non-arena SV for mess() */
438 /* we know that type >= SVt_PV */
440 Safefree(SvPVX(mess_sv));
441 Safefree(SvANY(mess_sv));
449 PerlInterpreter *sv_interp;
451 if (!(curinterp = sv_interp))
457 perl_parse(sv_interp, xsinit, argc, argv, env)
458 PerlInterpreter *sv_interp;
459 void (*xsinit)_((void));
466 char *scriptname = NULL;
467 VOL bool dosearch = FALSE;
474 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
477 croak("suidperl is no longer needed since the kernel can now execute\n\
478 setuid perl scripts securely.\n");
482 if (!(curinterp = sv_interp))
485 #if defined(NeXT) && defined(__DYNAMIC__)
486 _dyld_lookup_and_bind
487 ("__environ", (unsigned long *) &environ_pointer, NULL);
492 #ifndef VMS /* VMS doesn't have environ array */
493 origenviron = environ;
499 /* Come here if running an undumped a.out. */
501 origfilename = savepv(argv[0]);
503 cxstack_ix = -1; /* start label stack again */
505 init_postdump_symbols(argc,argv,env);
510 curpad = AvARRAY(comppad);
515 SvREFCNT_dec(main_cv);
519 oldscope = scopestack_ix;
527 /* my_exit() was called */
528 while (scopestack_ix > oldscope)
533 call_list(oldscope, endav);
535 return STATUS_NATIVE_EXPORT;
538 PerlIO_printf(PerlIO_stderr(), "panic: top_env\n");
542 sv_setpvn(linestr,"",0);
543 sv = newSVpv("",0); /* first used for -I flags */
547 for (argc--,argv++; argc > 0; argc--,argv++) {
548 if (argv[0][0] != '-' || !argv[0][1])
552 validarg = " PHOOEY ";
577 if (s = moreswitches(s))
587 if (euid != uid || egid != gid)
588 croak("No -e allowed in setuid scripts");
590 e_tmpname = savepv(TMPPATH);
591 (void)mktemp(e_tmpname);
593 croak("Can't mktemp()");
594 e_fp = PerlIO_open(e_tmpname,"w");
596 croak("Cannot open temporary file");
601 PerlIO_puts(e_fp,argv[1]);
605 croak("No code specified for -e");
606 (void)PerlIO_putc(e_fp,'\n');
617 incpush(argv[1], TRUE);
618 sv_catpv(sv,argv[1]);
635 preambleav = newAV();
636 av_push(preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
638 Sv = newSVpv("print myconfig();",0);
640 sv_catpv(Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
642 sv_catpv(Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
644 #if defined(DEBUGGING) || defined(NO_EMBED) || defined(MULTIPLICITY)
645 sv_catpv(Sv,"\" Compile-time options:");
647 sv_catpv(Sv," DEBUGGING");
650 sv_catpv(Sv," NO_EMBED");
653 sv_catpv(Sv," MULTIPLICITY");
655 sv_catpv(Sv,"\\n\",");
657 #if defined(LOCAL_PATCH_COUNT)
658 if (LOCAL_PATCH_COUNT > 0) {
660 sv_catpv(Sv,"\" Locally applied patches:\\n\",");
661 for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
663 sv_catpvf(Sv,"\" \\t%s\\n\",",localpatches[i]);
667 sv_catpvf(Sv,"\" Built under %s\\n\"",OSNAME);
670 sv_catpvf(Sv,",\" Compiled at %s %s\\n\"",__DATE__,__TIME__);
672 sv_catpvf(Sv,",\" Compiled on %s\\n\"",__DATE__);
677 @env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; \
678 print \" \\%ENV:\\n @env\\n\" if @env; \
679 print \" \\@INC:\\n @INC\\n\";");
682 Sv = newSVpv("config_vars(qw(",0);
687 av_push(preambleav, Sv);
688 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
697 if (*++s) { /* catch use of gnu style long options */
698 if (strEQ(s, "version")) {
702 if (strEQ(s, "help")) {
706 croak("Unrecognized switch: --%s (-h will show valid options)",s);
713 croak("Unrecognized switch: -%s (-h will show valid options)",s);
718 if (!tainting && (s = getenv("PERL5OPT"))) {
729 if (!strchr("DIMUdmw", *s))
730 croak("Illegal switch in PERL5OPT: -%c", *s);
736 scriptname = argv[0];
738 if (PerlIO_flush(e_fp) || PerlIO_error(e_fp) || PerlIO_close(e_fp)) {
740 warn("Did you forget to compile with -DMULTIPLICITY?");
742 croak("Can't write to temp file for -e: %s", Strerror(errno));
746 scriptname = e_tmpname;
748 else if (scriptname == Nullch) {
750 if ( isatty(PerlIO_fileno(PerlIO_stdin())) )
758 open_script(scriptname,dosearch,sv);
760 validate_suid(validarg, scriptname);
765 main_cv = compcv = (CV*)NEWSV(1104,0);
766 sv_upgrade((SV *)compcv, SVt_PVCV);
770 av_push(comppad, Nullsv);
771 curpad = AvARRAY(comppad);
772 comppad_name = newAV();
773 comppad_name_fill = 0;
774 min_intro_pending = 0;
777 comppadlist = newAV();
778 AvREAL_off(comppadlist);
779 av_store(comppadlist, 0, (SV*)comppad_name);
780 av_store(comppadlist, 1, (SV*)comppad);
781 CvPADLIST(compcv) = comppadlist;
783 boot_core_UNIVERSAL();
785 (*xsinit)(); /* in case linked C routines want magical variables */
786 #if defined(VMS) || defined(WIN32)
790 init_predump_symbols();
792 init_postdump_symbols(argc,argv,env);
796 /* now parse the script */
799 if (yyparse() || error_count) {
801 croak("%s had compilation errors.\n", origfilename);
803 croak("Execution of %s aborted due to compilation errors.\n",
807 curcop->cop_line = 0;
811 (void)UNLINK(e_tmpname);
816 /* now that script is parsed, we can modify record separator */
818 rs = SvREFCNT_inc(nrs);
819 sv_setsv(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), rs);
831 if ((s=getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
832 dump_mstats("after compilation:");
843 PerlInterpreter *sv_interp;
849 if (!(curinterp = sv_interp))
852 oldscope = scopestack_ix;
857 cxstack_ix = -1; /* start context stack again */
860 /* my_exit() was called */
861 while (scopestack_ix > oldscope)
866 call_list(oldscope, endav);
868 if (getenv("PERL_DEBUG_MSTATS"))
869 dump_mstats("after execution: ");
872 return STATUS_NATIVE_EXPORT;
875 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
880 if (curstack != mainstack) {
882 SWITCHSTACK(curstack, mainstack);
887 DEBUG_r(PerlIO_printf(PerlIO_stderr(), "%s $` $& $' support.\n",
888 sawampersand ? "Enabling" : "Omitting"));
892 DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
895 PerlIO_printf(PerlIO_stderr(), "%s syntax OK\n", origfilename);
898 if (PERLDB_SINGLE && DBsingle)
899 sv_setiv(DBsingle, 1);
909 else if (main_start) {
910 CvDEPTH(main_cv) = 1;
921 perl_get_sv(name, create)
925 GV* gv = gv_fetchpv(name, create, SVt_PV);
932 perl_get_av(name, create)
936 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
945 perl_get_hv(name, create)
949 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
958 perl_get_cv(name, create)
962 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
963 if (create && !GvCVu(gv))
964 return newSUB(start_subparse(FALSE, 0),
965 newSVOP(OP_CONST, 0, newSVpv(name,0)),
973 /* Be sure to refetch the stack pointer after calling these routines. */
976 perl_call_argv(subname, flags, argv)
978 I32 flags; /* See G_* flags in cop.h */
979 register char **argv; /* null terminated arg list */
986 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
991 return perl_call_pv(subname, flags);
995 perl_call_pv(subname, flags)
996 char *subname; /* name of the subroutine */
997 I32 flags; /* See G_* flags in cop.h */
999 return perl_call_sv((SV*)perl_get_cv(subname, TRUE), flags);
1003 perl_call_method(methname, flags)
1004 char *methname; /* name of the subroutine */
1005 I32 flags; /* See G_* flags in cop.h */
1011 XPUSHs(sv_2mortal(newSVpv(methname,0)));
1014 return perl_call_sv(*stack_sp--, flags);
1017 /* May be called with any of a CV, a GV, or an SV containing the name. */
1019 perl_call_sv(sv, flags)
1021 I32 flags; /* See G_* flags in cop.h */
1023 LOGOP myop; /* fake syntax tree node */
1029 bool oldcatch = CATCH_GET;
1034 if (flags & G_DISCARD) {
1039 Zero(&myop, 1, LOGOP);
1040 myop.op_next = Nullop;
1041 if (!(flags & G_NOARGS))
1042 myop.op_flags |= OPf_STACKED;
1043 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1044 (flags & G_ARRAY) ? OPf_WANT_LIST :
1049 EXTEND(stack_sp, 1);
1052 oldscope = scopestack_ix;
1054 if (PERLDB_SUB && curstash != debstash
1055 /* Handle first BEGIN of -d. */
1056 && (DBcv || (DBcv = GvCV(DBsub)))
1057 /* Try harder, since this may have been a sighandler, thus
1058 * curstash may be meaningless. */
1059 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != debstash))
1060 op->op_private |= OPpENTERSUB_DB;
1062 if (flags & G_EVAL) {
1063 cLOGOP->op_other = op;
1065 /* we're trying to emulate pp_entertry() here */
1067 register CONTEXT *cx;
1068 I32 gimme = GIMME_V;
1073 push_return(op->op_next);
1074 PUSHBLOCK(cx, CXt_EVAL, stack_sp);
1076 eval_root = op; /* Only needed so that goto works right. */
1079 if (flags & G_KEEPERR)
1082 sv_setpv(GvSV(errgv),"");
1094 /* my_exit() was called */
1095 curstash = defstash;
1099 croak("Callback called exit");
1108 stack_sp = stack_base + oldmark;
1109 if (flags & G_ARRAY)
1113 *++stack_sp = &sv_undef;
1121 if (op == (OP*)&myop)
1125 retval = stack_sp - (stack_base + oldmark);
1126 if ((flags & G_EVAL) && !(flags & G_KEEPERR))
1127 sv_setpv(GvSV(errgv),"");
1130 if (flags & G_EVAL) {
1131 if (scopestack_ix > oldscope) {
1135 register CONTEXT *cx;
1147 CATCH_SET(oldcatch);
1149 if (flags & G_DISCARD) {
1150 stack_sp = stack_base + oldmark;
1159 /* Eval a string. The G_EVAL flag is always assumed. */
1162 perl_eval_sv(sv, flags)
1164 I32 flags; /* See G_* flags in cop.h */
1166 UNOP myop; /* fake syntax tree node */
1168 I32 oldmark = sp - stack_base;
1175 if (flags & G_DISCARD) {
1183 EXTEND(stack_sp, 1);
1185 oldscope = scopestack_ix;
1187 if (!(flags & G_NOARGS))
1188 myop.op_flags = OPf_STACKED;
1189 myop.op_next = Nullop;
1190 myop.op_type = OP_ENTEREVAL;
1191 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1192 (flags & G_ARRAY) ? OPf_WANT_LIST :
1194 if (flags & G_KEEPERR)
1195 myop.op_flags |= OPf_SPECIAL;
1205 /* my_exit() was called */
1206 curstash = defstash;
1210 croak("Callback called exit");
1219 stack_sp = stack_base + oldmark;
1220 if (flags & G_ARRAY)
1224 *++stack_sp = &sv_undef;
1229 if (op == (OP*)&myop)
1230 op = pp_entereval();
1233 retval = stack_sp - (stack_base + oldmark);
1234 if (!(flags & G_KEEPERR))
1235 sv_setpv(GvSV(errgv),"");
1239 if (flags & G_DISCARD) {
1240 stack_sp = stack_base + oldmark;
1250 perl_eval_pv(p, croak_on_error)
1255 SV* sv = newSVpv(p, 0);
1258 perl_eval_sv(sv, G_SCALAR);
1265 if (croak_on_error && SvTRUE(GvSV(errgv)))
1266 croak(SvPVx(GvSV(errgv), na));
1271 /* Require a module. */
1277 SV* sv = sv_newmortal();
1278 sv_setpv(sv, "require '");
1281 perl_eval_sv(sv, G_DISCARD);
1285 magicname(sym,name,namlen)
1292 if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
1293 sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
1297 usage(name) /* XXX move this out into a module ? */
1300 /* This message really ought to be max 23 lines.
1301 * Removed -h because the user already knows that opton. Others? */
1302 printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
1303 printf("\n -0[octal] specify record separator (\\0, if no argument)");
1304 printf("\n -a autosplit mode with -n or -p (splits $_ into @F)");
1305 printf("\n -c check syntax only (runs BEGIN and END blocks)");
1306 printf("\n -d[:debugger] run scripts under debugger");
1307 printf("\n -D[number/list] set debugging flags (argument is a bit mask or flags)");
1308 printf("\n -e 'command' one line of script. Several -e's allowed. Omit [programfile].");
1309 printf("\n -F/pattern/ split() pattern for autosplit (-a). The //'s are optional.");
1310 printf("\n -i[extension] edit <> files in place (make backup if extension supplied)");
1311 printf("\n -Idirectory specify @INC/#include directory (may be used more than once)");
1312 printf("\n -l[octal] enable line ending processing, specifies line terminator");
1313 printf("\n -[mM][-]module.. executes `use/no module...' before executing your script.");
1314 printf("\n -n assume 'while (<>) { ... }' loop around your script");
1315 printf("\n -p assume loop like -n but print line also like sed");
1316 printf("\n -P run script through C preprocessor before compilation");
1317 printf("\n -s enable some switch parsing for switches after script name");
1318 printf("\n -S look for the script using PATH environment variable");
1319 printf("\n -T turn on tainting checks");
1320 printf("\n -u dump core after parsing script");
1321 printf("\n -U allow unsafe operations");
1322 printf("\n -v print version number and patchlevel of perl");
1323 printf("\n -V[:variable] print perl configuration information");
1324 printf("\n -w TURN WARNINGS ON FOR COMPILATION OF YOUR SCRIPT. Recommended.");
1325 printf("\n -x[directory] strip off text before #!perl line and perhaps cd to directory\n");
1328 /* This routine handles any switches that can be given during run */
1339 rschar = scan_oct(s, 4, &numlen);
1341 if (rschar & ~((U8)~0))
1343 else if (!rschar && numlen >= 2)
1344 nrs = newSVpv("", 0);
1347 nrs = newSVpv(&ch, 1);
1352 splitstr = savepv(s + 1);
1366 if (*s == ':' || *s == '=') {
1367 my_setenv("PERL5DB", form("use Devel::%s;", ++s));
1371 perldb = PERLDB_ALL;
1378 if (isALPHA(s[1])) {
1379 static char debopts[] = "psltocPmfrxuLHXD";
1382 for (s++; *s && (d = strchr(debopts,*s)); s++)
1383 debug |= 1 << (d - debopts);
1387 for (s++; isDIGIT(*s); s++) ;
1389 debug |= 0x80000000;
1391 warn("Recompile perl with -DDEBUGGING to use -D switch\n");
1392 for (s++; isALNUM(*s); s++) ;
1402 inplace = savepv(s+1);
1404 for (s = inplace; *s && !isSPACE(*s); s++) ;
1411 for (e = s; *e && !isSPACE(*e); e++) ;
1412 p = savepvn(s, e-s);
1419 croak("No space allowed after -I");
1429 *ors = scan_oct(s, 3 + (*s == '0'), &numlen);
1438 ors = SvPV(nrs, orslen);
1439 ors = savepvn(ors, orslen);
1443 forbid_setid("-M"); /* XXX ? */
1446 forbid_setid("-m"); /* XXX ? */
1450 /* -M-foo == 'no foo' */
1451 if (*s == '-') { use = "no "; ++s; }
1452 Sv = newSVpv(use,0);
1454 /* We allow -M'Module qw(Foo Bar)' */
1455 while(isALNUM(*s) || *s==':') ++s;
1457 sv_catpv(Sv, start);
1458 if (*(start-1) == 'm') {
1460 croak("Can't use '%c' after -mname", *s);
1461 sv_catpv( Sv, " ()");
1464 sv_catpvn(Sv, start, s-start);
1465 sv_catpv(Sv, " split(/,/,q{");
1470 if (preambleav == NULL)
1471 preambleav = newAV();
1472 av_push(preambleav, Sv);
1475 croak("No space allowed after -%c", *(s-1));
1492 croak("Too late for \"-T\" option");
1504 #if defined(SUBVERSION) && SUBVERSION > 0
1505 printf("\nThis is perl, version 5.%03d_%02d", PATCHLEVEL, SUBVERSION);
1507 printf("\nThis is perl, version %s",patchlevel);
1510 printf("\n\nCopyright 1987-1997, Larry Wall\n");
1512 printf("\n\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
1515 printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n");
1518 printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
1519 "Version 5 port Copyright (c) 1994-1997, Andreas Kaiser, Ilya Zakharevich\n");
1522 printf("atariST series port, ++jrb bammi@cadence.com\n");
1525 Perl may be copied only under the terms of either the Artistic License or the\n\
1526 GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n");
1534 if (s[1] == '-') /* Additional switches on #! line. */
1542 #ifdef ALTERNATE_SHEBANG
1543 case 'S': /* OS/2 needs -S on "extproc" line. */
1551 croak("Can't emulate -%.1s on #! line",s);
1556 /* compliments of Tom Christiansen */
1558 /* unexec() can be found in the Gnu emacs distribution */
1569 prog = newSVpv(BIN_EXP);
1570 sv_catpv(prog, "/perl");
1571 file = newSVpv(origfilename);
1572 sv_catpv(file, ".perldump");
1574 status = unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
1576 PerlIO_printf(PerlIO_stderr(), "unexec of %s into %s failed!\n",
1577 SvPVX(prog), SvPVX(file));
1581 # include <lib$routines.h>
1582 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
1584 ABORT(); /* for use with undump */
1594 /* Note that strtab is a rather special HV. Assumptions are made
1595 about not iterating on it, and not adding tie magic to it.
1596 It is properly deallocated in perl_destruct() */
1598 HvSHAREKEYS_off(strtab); /* mandatory */
1599 Newz(506,((XPVHV*)SvANY(strtab))->xhv_array,
1600 sizeof(HE*) * (((XPVHV*)SvANY(strtab))->xhv_max + 1), char);
1602 curstash = defstash = newHV();
1603 curstname = newSVpv("main",4);
1604 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
1605 SvREFCNT_dec(GvHV(gv));
1606 GvHV(gv) = (HV*)SvREFCNT_inc(defstash);
1608 HvNAME(defstash) = savepv("main");
1609 incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
1611 defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
1612 errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
1614 (void)form("%240s",""); /* Preallocate temp - for immediate signals. */
1615 sv_grow(GvSV(errgv), 240); /* Preallocate - for immediate signals. */
1616 sv_setpvn(GvSV(errgv), "", 0);
1617 curstash = defstash;
1618 compiling.cop_stash = defstash;
1619 debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
1620 /* We must init $/ before switches are processed. */
1621 sv_setpvn(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), "\n", 1);
1624 #ifdef CAN_PROTOTYPE
1626 open_script(char *scriptname, bool dosearch, SV *sv)
1629 open_script(scriptname,dosearch,sv)
1635 char *xfound = Nullch;
1636 char *xfailed = Nullch;
1640 #if defined(DOSISH) && !defined(OS2) && !defined(atarist)
1641 # define SEARCH_EXTS ".bat", ".cmd", NULL
1642 # define MAX_EXT_LEN 4
1645 # define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL
1646 # define MAX_EXT_LEN 4
1649 # define SEARCH_EXTS ".pl", ".com", NULL
1650 # define MAX_EXT_LEN 4
1652 /* additional extensions to try in each dir if scriptname not found */
1654 char *ext[] = { SEARCH_EXTS };
1655 int extidx = 0, i = 0;
1656 char *curext = Nullch;
1658 # define MAX_EXT_LEN 0
1662 * If dosearch is true and if scriptname does not contain path
1663 * delimiters, search the PATH for scriptname.
1665 * If SEARCH_EXTS is also defined, will look for each
1666 * scriptname{SEARCH_EXTS} whenever scriptname is not found
1667 * while searching the PATH.
1669 * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
1670 * proceeds as follows:
1672 * + look for ./scriptname{,.foo,.bar}
1673 * + search the PATH for scriptname{,.foo,.bar}
1676 * + look *only* in the PATH for scriptname{,.foo,.bar} (note
1677 * this will not look in '.' if it's not in the PATH)
1682 int hasdir, idx = 0, deftypes = 1;
1685 hasdir = (strpbrk(scriptname,":[</") != Nullch) ;
1686 /* The first time through, just add SEARCH_EXTS to whatever we
1687 * already have, so we can check for default file types. */
1689 (!hasdir && my_trnlnm("DCL$PATH",tokenbuf,idx++)) )
1695 if ((strlen(tokenbuf) + strlen(scriptname)
1696 + MAX_EXT_LEN) >= sizeof tokenbuf)
1697 continue; /* don't search dir with too-long name */
1698 strcat(tokenbuf, scriptname);
1702 if (strEQ(scriptname, "-"))
1704 if (dosearch) { /* Look in '.' first. */
1705 char *cur = scriptname;
1707 if ((curext = strrchr(scriptname,'.'))) /* possible current ext */
1709 if (strEQ(ext[i++],curext)) {
1710 extidx = -1; /* already has an ext */
1715 DEBUG_p(PerlIO_printf(Perl_debug_log,
1716 "Looking for %s\n",cur));
1717 if (Stat(cur,&statbuf) >= 0) {
1725 if (cur == scriptname) {
1726 len = strlen(scriptname);
1727 if (len+MAX_EXT_LEN+1 >= sizeof(tokenbuf))
1729 cur = strcpy(tokenbuf, scriptname);
1731 } while (extidx >= 0 && ext[extidx] /* try an extension? */
1732 && strcpy(tokenbuf+len, ext[extidx++]));
1737 if (dosearch && !strchr(scriptname, '/')
1739 && !strchr(scriptname, '\\')
1741 && (s = getenv("PATH"))) {
1744 bufend = s + strlen(s);
1745 while (s < bufend) {
1746 #if defined(atarist) || defined(DOSISH)
1751 && *s != ';'; len++, s++) {
1752 if (len < sizeof tokenbuf)
1755 if (len < sizeof tokenbuf)
1756 tokenbuf[len] = '\0';
1757 #else /* ! (atarist || DOSISH) */
1758 s = delimcpy(tokenbuf, tokenbuf + sizeof tokenbuf, s, bufend,
1761 #endif /* ! (atarist || DOSISH) */
1764 if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tokenbuf)
1765 continue; /* don't search dir with too-long name */
1767 #if defined(atarist) || defined(DOSISH)
1768 && tokenbuf[len - 1] != '/'
1769 && tokenbuf[len - 1] != '\\'
1772 tokenbuf[len++] = '/';
1773 if (len == 2 && tokenbuf[0] == '.')
1775 (void)strcpy(tokenbuf + len, scriptname);
1779 len = strlen(tokenbuf);
1780 if (extidx > 0) /* reset after previous loop */
1784 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tokenbuf));
1785 retval = Stat(tokenbuf,&statbuf);
1787 } while ( retval < 0 /* not there */
1788 && extidx>=0 && ext[extidx] /* try an extension? */
1789 && strcpy(tokenbuf+len, ext[extidx++])
1794 if (S_ISREG(statbuf.st_mode)
1795 && cando(S_IRUSR,TRUE,&statbuf)
1797 && cando(S_IXUSR,TRUE,&statbuf)
1801 xfound = tokenbuf; /* bingo! */
1805 xfailed = savepv(tokenbuf);
1808 if (!xfound && !seen_dot && !xfailed && (Stat(scriptname,&statbuf) < 0))
1810 seen_dot = 1; /* Disable message. */
1812 croak("Can't %s %s%s%s",
1813 (xfailed ? "execute" : "find"),
1814 (xfailed ? xfailed : scriptname),
1815 (xfailed ? "" : " on PATH"),
1816 (xfailed || seen_dot) ? "" : ", '.' not in PATH");
1819 scriptname = xfound;
1822 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
1823 char *s = scriptname + 8;
1832 origfilename = savepv(e_tmpname ? "-e" : scriptname);
1833 curcop->cop_filegv = gv_fetchfile(origfilename);
1834 if (strEQ(origfilename,"-"))
1836 if (fdscript >= 0) {
1837 rsfp = PerlIO_fdopen(fdscript,"r");
1838 #if defined(HAS_FCNTL) && defined(F_SETFD)
1840 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
1843 else if (preprocess) {
1844 char *cpp_cfg = CPPSTDIN;
1845 SV *cpp = NEWSV(0,0);
1846 SV *cmd = NEWSV(0,0);
1848 if (strEQ(cpp_cfg, "cppstdin"))
1849 sv_catpvf(cpp, "%s/", BIN_EXP);
1850 sv_catpv(cpp, cpp_cfg);
1853 sv_catpv(sv,PRIVLIB_EXP);
1857 sed %s -e \"/^[^#]/b\" \
1858 -e \"/^#[ ]*include[ ]/b\" \
1859 -e \"/^#[ ]*define[ ]/b\" \
1860 -e \"/^#[ ]*if[ ]/b\" \
1861 -e \"/^#[ ]*ifdef[ ]/b\" \
1862 -e \"/^#[ ]*ifndef[ ]/b\" \
1863 -e \"/^#[ ]*else/b\" \
1864 -e \"/^#[ ]*elif[ ]/b\" \
1865 -e \"/^#[ ]*undef[ ]/b\" \
1866 -e \"/^#[ ]*endif/b\" \
1869 (doextract ? "-e \"1,/^#/d\n\"" : ""),
1872 %s %s -e '/^[^#]/b' \
1873 -e '/^#[ ]*include[ ]/b' \
1874 -e '/^#[ ]*define[ ]/b' \
1875 -e '/^#[ ]*if[ ]/b' \
1876 -e '/^#[ ]*ifdef[ ]/b' \
1877 -e '/^#[ ]*ifndef[ ]/b' \
1878 -e '/^#[ ]*else/b' \
1879 -e '/^#[ ]*elif[ ]/b' \
1880 -e '/^#[ ]*undef[ ]/b' \
1881 -e '/^#[ ]*endif/b' \
1889 (doextract ? "-e '1,/^#/d\n'" : ""),
1891 scriptname, cpp, sv, CPPMINUS);
1893 #ifdef IAMSUID /* actually, this is caught earlier */
1894 if (euid != uid && !euid) { /* if running suidperl */
1896 (void)seteuid(uid); /* musn't stay setuid root */
1899 (void)setreuid((Uid_t)-1, uid);
1901 #ifdef HAS_SETRESUID
1902 (void)setresuid((Uid_t)-1, uid, (Uid_t)-1);
1908 if (geteuid() != uid)
1909 croak("Can't do seteuid!\n");
1911 #endif /* IAMSUID */
1912 rsfp = my_popen(SvPVX(cmd), "r");
1916 else if (!*scriptname) {
1917 forbid_setid("program input from stdin");
1918 rsfp = PerlIO_stdin();
1921 rsfp = PerlIO_open(scriptname,"r");
1922 #if defined(HAS_FCNTL) && defined(F_SETFD)
1924 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
1932 #ifndef IAMSUID /* in case script is not readable before setuid */
1933 if (euid && Stat(SvPVX(GvSV(curcop->cop_filegv)),&statbuf) >= 0 &&
1934 statbuf.st_mode & (S_ISUID|S_ISGID)) {
1936 execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
1937 croak("Can't do setuid\n");
1941 croak("Can't open perl script \"%s\": %s\n",
1942 SvPVX(GvSV(curcop->cop_filegv)), Strerror(errno));
1947 validate_suid(validarg, scriptname)
1953 /* do we need to emulate setuid on scripts? */
1955 /* This code is for those BSD systems that have setuid #! scripts disabled
1956 * in the kernel because of a security problem. Merely defining DOSUID
1957 * in perl will not fix that problem, but if you have disabled setuid
1958 * scripts in the kernel, this will attempt to emulate setuid and setgid
1959 * on scripts that have those now-otherwise-useless bits set. The setuid
1960 * root version must be called suidperl or sperlN.NNN. If regular perl
1961 * discovers that it has opened a setuid script, it calls suidperl with
1962 * the same argv that it had. If suidperl finds that the script it has
1963 * just opened is NOT setuid root, it sets the effective uid back to the
1964 * uid. We don't just make perl setuid root because that loses the
1965 * effective uid we had before invoking perl, if it was different from the
1968 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
1969 * be defined in suidperl only. suidperl must be setuid root. The
1970 * Configure script will set this up for you if you want it.
1976 if (Fstat(PerlIO_fileno(rsfp),&statbuf) < 0) /* normal stat is insecure */
1977 croak("Can't stat script \"%s\"",origfilename);
1978 if (fdscript < 0 && statbuf.st_mode & (S_ISUID|S_ISGID)) {
1982 #ifndef HAS_SETREUID
1983 /* On this access check to make sure the directories are readable,
1984 * there is actually a small window that the user could use to make
1985 * filename point to an accessible directory. So there is a faint
1986 * chance that someone could execute a setuid script down in a
1987 * non-accessible directory. I don't know what to do about that.
1988 * But I don't think it's too important. The manual lies when
1989 * it says access() is useful in setuid programs.
1991 if (access(SvPVX(GvSV(curcop->cop_filegv)),1)) /*double check*/
1992 croak("Permission denied");
1994 /* If we can swap euid and uid, then we can determine access rights
1995 * with a simple stat of the file, and then compare device and
1996 * inode to make sure we did stat() on the same file we opened.
1997 * Then we just have to make sure he or she can execute it.
2000 struct stat tmpstatbuf;
2004 setreuid(euid,uid) < 0
2007 setresuid(euid,uid,(Uid_t)-1) < 0
2010 || getuid() != euid || geteuid() != uid)
2011 croak("Can't swap uid and euid"); /* really paranoid */
2012 if (Stat(SvPVX(GvSV(curcop->cop_filegv)),&tmpstatbuf) < 0)
2013 croak("Permission denied"); /* testing full pathname here */
2014 if (tmpstatbuf.st_dev != statbuf.st_dev ||
2015 tmpstatbuf.st_ino != statbuf.st_ino) {
2016 (void)PerlIO_close(rsfp);
2017 if (rsfp = my_popen("/bin/mail root","w")) { /* heh, heh */
2019 "User %ld tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
2020 (Filename of set-id script was %s, uid %ld gid %ld.)\n\nSincerely,\nperl\n",
2021 (long)uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
2022 (long)statbuf.st_dev, (long)statbuf.st_ino,
2023 SvPVX(GvSV(curcop->cop_filegv)),
2024 (long)statbuf.st_uid, (long)statbuf.st_gid);
2025 (void)my_pclose(rsfp);
2027 croak("Permission denied\n");
2031 setreuid(uid,euid) < 0
2033 # if defined(HAS_SETRESUID)
2034 setresuid(uid,euid,(Uid_t)-1) < 0
2037 || getuid() != uid || geteuid() != euid)
2038 croak("Can't reswap uid and euid");
2039 if (!cando(S_IXUSR,FALSE,&statbuf)) /* can real uid exec? */
2040 croak("Permission denied\n");
2042 #endif /* HAS_SETREUID */
2043 #endif /* IAMSUID */
2045 if (!S_ISREG(statbuf.st_mode))
2046 croak("Permission denied");
2047 if (statbuf.st_mode & S_IWOTH)
2048 croak("Setuid/gid script is writable by world");
2049 doswitches = FALSE; /* -s is insecure in suid */
2051 if (sv_gets(linestr, rsfp, 0) == Nullch ||
2052 strnNE(SvPV(linestr,na),"#!",2) ) /* required even on Sys V */
2053 croak("No #! line");
2054 s = SvPV(linestr,na)+2;
2056 while (!isSPACE(*s)) s++;
2057 for (s2 = s; (s2 > SvPV(linestr,na)+2 &&
2058 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
2059 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
2060 croak("Not a perl script");
2061 while (*s == ' ' || *s == '\t') s++;
2063 * #! arg must be what we saw above. They can invoke it by
2064 * mentioning suidperl explicitly, but they may not add any strange
2065 * arguments beyond what #! says if they do invoke suidperl that way.
2067 len = strlen(validarg);
2068 if (strEQ(validarg," PHOOEY ") ||
2069 strnNE(s,validarg,len) || !isSPACE(s[len]))
2070 croak("Args must match #! line");
2073 if (euid != uid && (statbuf.st_mode & S_ISUID) &&
2074 euid == statbuf.st_uid)
2076 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2077 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2078 #endif /* IAMSUID */
2080 if (euid) { /* oops, we're not the setuid root perl */
2081 (void)PerlIO_close(rsfp);
2084 execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
2086 croak("Can't do setuid\n");
2089 if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid) {
2091 (void)setegid(statbuf.st_gid);
2094 (void)setregid((Gid_t)-1,statbuf.st_gid);
2096 #ifdef HAS_SETRESGID
2097 (void)setresgid((Gid_t)-1,statbuf.st_gid,(Gid_t)-1);
2099 setgid(statbuf.st_gid);
2103 if (getegid() != statbuf.st_gid)
2104 croak("Can't do setegid!\n");
2106 if (statbuf.st_mode & S_ISUID) {
2107 if (statbuf.st_uid != euid)
2109 (void)seteuid(statbuf.st_uid); /* all that for this */
2112 (void)setreuid((Uid_t)-1,statbuf.st_uid);
2114 #ifdef HAS_SETRESUID
2115 (void)setresuid((Uid_t)-1,statbuf.st_uid,(Uid_t)-1);
2117 setuid(statbuf.st_uid);
2121 if (geteuid() != statbuf.st_uid)
2122 croak("Can't do seteuid!\n");
2124 else if (uid) { /* oops, mustn't run as root */
2126 (void)seteuid((Uid_t)uid);
2129 (void)setreuid((Uid_t)-1,(Uid_t)uid);
2131 #ifdef HAS_SETRESUID
2132 (void)setresuid((Uid_t)-1,(Uid_t)uid,(Uid_t)-1);
2138 if (geteuid() != uid)
2139 croak("Can't do seteuid!\n");
2142 if (!cando(S_IXUSR,TRUE,&statbuf))
2143 croak("Permission denied\n"); /* they can't do this */
2146 else if (preprocess)
2147 croak("-P not allowed for setuid/setgid script\n");
2148 else if (fdscript >= 0)
2149 croak("fd script not allowed in suidperl\n");
2151 croak("Script is not setuid/setgid in suidperl\n");
2153 /* We absolutely must clear out any saved ids here, so we */
2154 /* exec the real perl, substituting fd script for scriptname. */
2155 /* (We pass script name as "subdir" of fd, which perl will grok.) */
2156 PerlIO_rewind(rsfp);
2157 lseek(PerlIO_fileno(rsfp),(Off_t)0,0); /* just in case rewind didn't */
2158 for (which = 1; origargv[which] && origargv[which] != scriptname; which++) ;
2159 if (!origargv[which])
2160 croak("Permission denied");
2161 origargv[which] = savepv(form("/dev/fd/%d/%s",
2162 PerlIO_fileno(rsfp), origargv[which]));
2163 #if defined(HAS_FCNTL) && defined(F_SETFD)
2164 fcntl(PerlIO_fileno(rsfp),F_SETFD,0); /* ensure no close-on-exec */
2166 execv(form("%s/perl%s", BIN_EXP, patchlevel), origargv); /* try again */
2167 croak("Can't do setuid\n");
2168 #endif /* IAMSUID */
2170 if (euid != uid || egid != gid) { /* (suidperl doesn't exist, in fact) */
2171 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
2172 Fstat(PerlIO_fileno(rsfp),&statbuf); /* may be either wrapped or real suid */
2173 if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
2175 (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
2178 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2179 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2180 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
2181 /* not set-id, must be wrapped */
2189 register char *s, *s2;
2191 /* skip forward in input to the real script? */
2195 if ((s = sv_gets(linestr, rsfp, 0)) == Nullch)
2196 croak("No Perl script found in input\n");
2197 if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
2198 PerlIO_ungetc(rsfp, '\n'); /* to keep line count right */
2200 while (*s && !(isSPACE (*s) || *s == '#')) s++;
2202 while (*s == ' ' || *s == '\t') s++;
2204 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
2205 if (strnEQ(s2-4,"perl",4))
2207 while (s = moreswitches(s)) ;
2209 if (cddir && chdir(cddir) < 0)
2210 croak("Can't chdir to %s",cddir);
2218 uid = (int)getuid();
2219 euid = (int)geteuid();
2220 gid = (int)getgid();
2221 egid = (int)getegid();
2226 tainting |= (uid && (euid != uid || egid != gid));
2234 croak("No %s allowed while running setuid", s);
2236 croak("No %s allowed while running setgid", s);
2242 curstash = debstash;
2243 dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
2245 DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
2246 DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
2247 DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
2248 DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
2249 sv_setiv(DBsingle, 0);
2250 DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
2251 sv_setiv(DBtrace, 0);
2252 DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
2253 sv_setiv(DBsignal, 0);
2254 curstash = defstash;
2261 mainstack = curstack; /* remember in case we switch stacks */
2262 AvREAL_off(curstack); /* not a real array */
2263 av_extend(curstack,127);
2265 stack_base = AvARRAY(curstack);
2266 stack_sp = stack_base;
2267 stack_max = stack_base + 127;
2269 cxstack_max = 8192 / sizeof(CONTEXT) - 2; /* Use most of 8K. */
2270 New(50,cxstack,cxstack_max + 1,CONTEXT);
2273 New(50,tmps_stack,128,SV*);
2278 New(51,debname,128,char);
2279 New(52,debdelim,128,char);
2283 * The following stacks almost certainly should be per-interpreter,
2284 * but for now they're not. XXX
2288 markstack_ptr = markstack;
2290 New(54,markstack,64,I32);
2291 markstack_ptr = markstack;
2292 markstack_max = markstack + 64;
2298 New(54,scopestack,32,I32);
2300 scopestack_max = 32;
2306 New(54,savestack,128,ANY);
2308 savestack_max = 128;
2314 New(54,retstack,16,OP*);
2324 Safefree(tmps_stack);
2331 static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
2340 subname = newSVpv("main",4);
2344 init_predump_symbols()
2349 sv_setpvn(GvSV(gv_fetchpv("\"", TRUE, SVt_PV)), " ", 1);
2351 stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
2352 GvMULTI_on(stdingv);
2353 IoIFP(GvIOp(stdingv)) = PerlIO_stdin();
2354 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
2356 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(stdingv));
2358 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
2360 IoOFP(GvIOp(tmpgv)) = IoIFP(GvIOp(tmpgv)) = PerlIO_stdout();
2362 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
2364 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(defoutgv));
2366 othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
2367 GvMULTI_on(othergv);
2368 IoOFP(GvIOp(othergv)) = IoIFP(GvIOp(othergv)) = PerlIO_stderr();
2369 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
2371 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(othergv));
2373 statname = NEWSV(66,0); /* last filename we did stat on */
2376 osname = savepv(OSNAME);
2380 init_postdump_symbols(argc,argv,env)
2382 register char **argv;
2383 register char **env;
2389 argc--,argv++; /* skip name of script */
2391 for (; argc > 0 && **argv == '-'; argc--,argv++) {
2394 if (argv[0][1] == '-') {
2398 if (s = strchr(argv[0], '=')) {
2400 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
2403 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
2406 toptarget = NEWSV(0,0);
2407 sv_upgrade(toptarget, SVt_PVFM);
2408 sv_setpvn(toptarget, "", 0);
2409 bodytarget = NEWSV(0,0);
2410 sv_upgrade(bodytarget, SVt_PVFM);
2411 sv_setpvn(bodytarget, "", 0);
2412 formtarget = bodytarget;
2415 if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
2416 sv_setpv(GvSV(tmpgv),origfilename);
2417 magicname("0", "0", 1);
2419 if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
2420 sv_setpv(GvSV(tmpgv),origargv[0]);
2421 if (argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
2423 (void)gv_AVadd(argvgv);
2424 av_clear(GvAVn(argvgv));
2425 for (; argc > 0; argc--,argv++) {
2426 av_push(GvAVn(argvgv),newSVpv(argv[0],0));
2429 if (envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
2433 hv_magic(hv, envgv, 'E');
2434 #ifndef VMS /* VMS doesn't have environ array */
2435 /* Note that if the supplied env parameter is actually a copy
2436 of the global environ then it may now point to free'd memory
2437 if the environment has been modified since. To avoid this
2438 problem we treat env==NULL as meaning 'use the default'
2443 environ[0] = Nullch;
2444 for (; *env; env++) {
2445 if (!(s = strchr(*env,'=')))
2451 sv = newSVpv(s--,0);
2452 (void)hv_store(hv, *env, s - *env, sv, 0);
2454 #if defined(__BORLANDC__) && defined(USE_WIN32_RTL_ENV)
2455 /* Sins of the RTL. See note in my_setenv(). */
2456 (void)putenv(savepv(*env));
2460 #ifdef DYNAMIC_ENV_FETCH
2461 HvNAME(hv) = savepv(ENV_HV_NAME);
2465 if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
2466 sv_setiv(GvSV(tmpgv), (IV)getpid());
2475 s = getenv("PERL5LIB");
2479 incpush(getenv("PERLLIB"), FALSE);
2481 /* Treat PERL5?LIB as a possible search list logical name -- the
2482 * "natural" VMS idiom for a Unix path string. We allow each
2483 * element to be a set of |-separated directories for compatibility.
2487 if (my_trnlnm("PERL5LIB",buf,0))
2488 do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
2490 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE);
2494 /* Use the ~-expanded versions of APPLLIB (undocumented),
2495 ARCHLIB PRIVLIB SITEARCH SITELIB and OLDARCHLIB
2498 incpush(APPLLIB_EXP, FALSE);
2502 incpush(ARCHLIB_EXP, FALSE);
2505 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
2507 incpush(PRIVLIB_EXP, FALSE);
2510 incpush(SITEARCH_EXP, FALSE);
2513 incpush(SITELIB_EXP, FALSE);
2515 #ifdef OLDARCHLIB_EXP /* 5.00[01] compatibility */
2516 incpush(OLDARCHLIB_EXP, FALSE);
2520 incpush(".", FALSE);
2524 # define PERLLIB_SEP ';'
2527 # define PERLLIB_SEP '|'
2529 # define PERLLIB_SEP ':'
2532 #ifndef PERLLIB_MANGLE
2533 # define PERLLIB_MANGLE(s,n) (s)
2537 incpush(p, addsubdirs)
2541 SV *subdir = Nullsv;
2542 static char *archpat_auto;
2549 if (!archpat_auto) {
2550 STRLEN len = (sizeof(ARCHNAME) + strlen(patchlevel)
2551 + sizeof("//auto"));
2552 New(55, archpat_auto, len, char);
2553 sprintf(archpat_auto, "/%s/%s/auto", ARCHNAME, patchlevel);
2555 for (len = sizeof(ARCHNAME) + 2;
2556 archpat_auto[len] != '\0' && archpat_auto[len] != '/'; len++)
2557 if (archpat_auto[len] == '.') archpat_auto[len] = '_';
2562 /* Break at all separators */
2564 SV *libdir = newSV(0);
2567 /* skip any consecutive separators */
2568 while ( *p == PERLLIB_SEP ) {
2569 /* Uncomment the next line for PATH semantics */
2570 /* av_push(GvAVn(incgv), newSVpv(".", 1)); */
2574 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
2575 sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
2580 sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
2581 p = Nullch; /* break out */
2585 * BEFORE pushing libdir onto @INC we may first push version- and
2586 * archname-specific sub-directories.
2589 struct stat tmpstatbuf;
2594 if ((unix = tounixspec_ts(SvPV(libdir,na),Nullch)) != Nullch) {
2596 while (unix[len-1] == '/') len--; /* Cosmetic */
2597 sv_usepvn(libdir,unix,len);
2600 PerlIO_printf(PerlIO_stderr(),
2601 "Failed to unixify @INC element \"%s\"\n",
2604 /* .../archname/version if -d .../archname/version/auto */
2605 sv_setsv(subdir, libdir);
2606 sv_catpv(subdir, archpat_auto);
2607 if (Stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2608 S_ISDIR(tmpstatbuf.st_mode))
2609 av_push(GvAVn(incgv),
2610 newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2612 /* .../archname if -d .../archname/auto */
2613 sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME),
2614 strlen(patchlevel) + 1, "", 0);
2615 if (Stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2616 S_ISDIR(tmpstatbuf.st_mode))
2617 av_push(GvAVn(incgv),
2618 newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2621 /* finally push this lib directory on the end of @INC */
2622 av_push(GvAVn(incgv), libdir);
2625 SvREFCNT_dec(subdir);
2629 call_list(oldscope, list)
2633 line_t oldline = curcop->cop_line;
2638 while (AvFILL(list) >= 0) {
2639 CV *cv = (CV*)av_shift(list);
2646 SV* atsv = GvSV(errgv);
2648 perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
2649 (void)SvPV(atsv, len);
2652 curcop = &compiling;
2653 curcop->cop_line = oldline;
2654 if (list == beginav)
2655 sv_catpv(atsv, "BEGIN failed--compilation aborted");
2657 sv_catpv(atsv, "END failed--cleanup aborted");
2658 while (scopestack_ix > oldscope)
2660 croak("%s", SvPVX(atsv));
2668 /* my_exit() was called */
2669 while (scopestack_ix > oldscope)
2672 curstash = defstash;
2674 call_list(oldscope, endav);
2676 curcop = &compiling;
2677 curcop->cop_line = oldline;
2679 if (list == beginav)
2680 croak("BEGIN failed--compilation aborted");
2682 croak("END failed--cleanup aborted");
2688 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
2693 curcop = &compiling;
2694 curcop->cop_line = oldline;
2713 STATUS_NATIVE_SET(status);
2723 if (vaxc$errno & 1) {
2724 if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
2725 STATUS_NATIVE_SET(44);
2728 if (!vaxc$errno && errno) /* unlikely */
2729 STATUS_NATIVE_SET(44);
2731 STATUS_NATIVE_SET(vaxc$errno);
2735 STATUS_POSIX_SET(errno);
2736 else if (STATUS_POSIX == 0)
2737 STATUS_POSIX_SET(255);
2745 register CONTEXT *cx;
2754 (void)UNLINK(e_tmpname);
2755 Safefree(e_tmpname);
2759 if (cxstack_ix >= 0) {