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 */
702 croak("Unrecognized switch: -%s",s);
707 if (!tainting && (s = getenv("PERL5OPT"))) {
718 if (!strchr("DIMUdmw", *s))
719 croak("Illegal switch in PERL5OPT: -%c", *s);
725 scriptname = argv[0];
727 if (PerlIO_flush(e_fp) || PerlIO_error(e_fp) || PerlIO_close(e_fp)) {
729 warn("Did you forget to compile with -DMULTIPLICITY?");
731 croak("Can't write to temp file for -e: %s", Strerror(errno));
735 scriptname = e_tmpname;
737 else if (scriptname == Nullch) {
739 if ( isatty(PerlIO_fileno(PerlIO_stdin())) )
747 open_script(scriptname,dosearch,sv);
749 validate_suid(validarg, scriptname);
754 main_cv = compcv = (CV*)NEWSV(1104,0);
755 sv_upgrade((SV *)compcv, SVt_PVCV);
759 av_push(comppad, Nullsv);
760 curpad = AvARRAY(comppad);
761 comppad_name = newAV();
762 comppad_name_fill = 0;
763 min_intro_pending = 0;
766 comppadlist = newAV();
767 AvREAL_off(comppadlist);
768 av_store(comppadlist, 0, (SV*)comppad_name);
769 av_store(comppadlist, 1, (SV*)comppad);
770 CvPADLIST(compcv) = comppadlist;
772 boot_core_UNIVERSAL();
774 (*xsinit)(); /* in case linked C routines want magical variables */
775 #if defined(VMS) || defined(WIN32)
779 init_predump_symbols();
781 init_postdump_symbols(argc,argv,env);
785 /* now parse the script */
788 if (yyparse() || error_count) {
790 croak("%s had compilation errors.\n", origfilename);
792 croak("Execution of %s aborted due to compilation errors.\n",
796 curcop->cop_line = 0;
800 (void)UNLINK(e_tmpname);
805 /* now that script is parsed, we can modify record separator */
807 rs = SvREFCNT_inc(nrs);
808 sv_setsv(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), rs);
820 if ((s=getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
821 dump_mstats("after compilation:");
832 PerlInterpreter *sv_interp;
838 if (!(curinterp = sv_interp))
841 oldscope = scopestack_ix;
846 cxstack_ix = -1; /* start context stack again */
849 /* my_exit() was called */
850 while (scopestack_ix > oldscope)
855 call_list(oldscope, endav);
857 if (getenv("PERL_DEBUG_MSTATS"))
858 dump_mstats("after execution: ");
861 return STATUS_NATIVE_EXPORT;
864 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
869 if (curstack != mainstack) {
871 SWITCHSTACK(curstack, mainstack);
876 DEBUG_r(PerlIO_printf(PerlIO_stderr(), "%s $` $& $' support.\n",
877 sawampersand ? "Enabling" : "Omitting"));
881 DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
884 PerlIO_printf(PerlIO_stderr(), "%s syntax OK\n", origfilename);
887 if (PERLDB_SINGLE && DBsingle)
888 sv_setiv(DBsingle, 1);
898 else if (main_start) {
899 CvDEPTH(main_cv) = 1;
910 perl_get_sv(name, create)
914 GV* gv = gv_fetchpv(name, create, SVt_PV);
921 perl_get_av(name, create)
925 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
934 perl_get_hv(name, create)
938 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
947 perl_get_cv(name, create)
951 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
952 if (create && !GvCVu(gv))
953 return newSUB(start_subparse(FALSE, 0),
954 newSVOP(OP_CONST, 0, newSVpv(name,0)),
962 /* Be sure to refetch the stack pointer after calling these routines. */
965 perl_call_argv(subname, flags, argv)
967 I32 flags; /* See G_* flags in cop.h */
968 register char **argv; /* null terminated arg list */
975 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
980 return perl_call_pv(subname, flags);
984 perl_call_pv(subname, flags)
985 char *subname; /* name of the subroutine */
986 I32 flags; /* See G_* flags in cop.h */
988 return perl_call_sv((SV*)perl_get_cv(subname, TRUE), flags);
992 perl_call_method(methname, flags)
993 char *methname; /* name of the subroutine */
994 I32 flags; /* See G_* flags in cop.h */
1000 XPUSHs(sv_2mortal(newSVpv(methname,0)));
1003 return perl_call_sv(*stack_sp--, flags);
1006 /* May be called with any of a CV, a GV, or an SV containing the name. */
1008 perl_call_sv(sv, flags)
1010 I32 flags; /* See G_* flags in cop.h */
1012 LOGOP myop; /* fake syntax tree node */
1018 bool oldcatch = CATCH_GET;
1023 if (flags & G_DISCARD) {
1028 Zero(&myop, 1, LOGOP);
1029 myop.op_next = Nullop;
1030 if (!(flags & G_NOARGS))
1031 myop.op_flags |= OPf_STACKED;
1032 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1033 (flags & G_ARRAY) ? OPf_WANT_LIST :
1038 EXTEND(stack_sp, 1);
1041 oldscope = scopestack_ix;
1043 if (PERLDB_SUB && curstash != debstash
1044 /* Handle first BEGIN of -d. */
1045 && (DBcv || (DBcv = GvCV(DBsub)))
1046 /* Try harder, since this may have been a sighandler, thus
1047 * curstash may be meaningless. */
1048 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != debstash))
1049 op->op_private |= OPpENTERSUB_DB;
1051 if (flags & G_EVAL) {
1052 cLOGOP->op_other = op;
1054 /* we're trying to emulate pp_entertry() here */
1056 register CONTEXT *cx;
1057 I32 gimme = GIMME_V;
1062 push_return(op->op_next);
1063 PUSHBLOCK(cx, CXt_EVAL, stack_sp);
1065 eval_root = op; /* Only needed so that goto works right. */
1068 if (flags & G_KEEPERR)
1071 sv_setpv(GvSV(errgv),"");
1083 /* my_exit() was called */
1084 curstash = defstash;
1088 croak("Callback called exit");
1097 stack_sp = stack_base + oldmark;
1098 if (flags & G_ARRAY)
1102 *++stack_sp = &sv_undef;
1110 if (op == (OP*)&myop)
1114 retval = stack_sp - (stack_base + oldmark);
1115 if ((flags & G_EVAL) && !(flags & G_KEEPERR))
1116 sv_setpv(GvSV(errgv),"");
1119 if (flags & G_EVAL) {
1120 if (scopestack_ix > oldscope) {
1124 register CONTEXT *cx;
1136 CATCH_SET(oldcatch);
1138 if (flags & G_DISCARD) {
1139 stack_sp = stack_base + oldmark;
1148 /* Eval a string. The G_EVAL flag is always assumed. */
1151 perl_eval_sv(sv, flags)
1153 I32 flags; /* See G_* flags in cop.h */
1155 UNOP myop; /* fake syntax tree node */
1157 I32 oldmark = sp - stack_base;
1164 if (flags & G_DISCARD) {
1172 EXTEND(stack_sp, 1);
1174 oldscope = scopestack_ix;
1176 if (!(flags & G_NOARGS))
1177 myop.op_flags = OPf_STACKED;
1178 myop.op_next = Nullop;
1179 myop.op_type = OP_ENTEREVAL;
1180 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1181 (flags & G_ARRAY) ? OPf_WANT_LIST :
1183 if (flags & G_KEEPERR)
1184 myop.op_flags |= OPf_SPECIAL;
1194 /* my_exit() was called */
1195 curstash = defstash;
1199 croak("Callback called exit");
1208 stack_sp = stack_base + oldmark;
1209 if (flags & G_ARRAY)
1213 *++stack_sp = &sv_undef;
1218 if (op == (OP*)&myop)
1219 op = pp_entereval();
1222 retval = stack_sp - (stack_base + oldmark);
1223 if (!(flags & G_KEEPERR))
1224 sv_setpv(GvSV(errgv),"");
1228 if (flags & G_DISCARD) {
1229 stack_sp = stack_base + oldmark;
1239 perl_eval_pv(p, croak_on_error)
1244 SV* sv = newSVpv(p, 0);
1247 perl_eval_sv(sv, G_SCALAR);
1254 if (croak_on_error && SvTRUE(GvSV(errgv)))
1255 croak(SvPVx(GvSV(errgv), na));
1260 /* Require a module. */
1266 SV* sv = sv_newmortal();
1267 sv_setpv(sv, "require '");
1270 perl_eval_sv(sv, G_DISCARD);
1274 magicname(sym,name,namlen)
1281 if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
1282 sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
1286 usage(name) /* XXX move this out into a module ? */
1289 /* This message really ought to be max 23 lines.
1290 * Removed -h because the user already knows that opton. Others? */
1291 printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
1292 printf("\n -0[octal] specify record separator (\\0, if no argument)");
1293 printf("\n -a autosplit mode with -n or -p (splits $_ into @F)");
1294 printf("\n -c check syntax only (runs BEGIN and END blocks)");
1295 printf("\n -d[:debugger] run scripts under debugger");
1296 printf("\n -D[number/list] set debugging flags (argument is a bit mask or flags)");
1297 printf("\n -e 'command' one line of script. Several -e's allowed. Omit [programfile].");
1298 printf("\n -F/pattern/ split() pattern for autosplit (-a). The //'s are optional.");
1299 printf("\n -i[extension] edit <> files in place (make backup if extension supplied)");
1300 printf("\n -Idirectory specify @INC/#include directory (may be used more then once)");
1301 printf("\n -l[octal] enable line ending processing, specifies line teminator");
1302 printf("\n -[mM][-]module.. executes `use/no module...' before executing your script.");
1303 printf("\n -n assume 'while (<>) { ... }' loop arround your script");
1304 printf("\n -p assume loop like -n but print line also like sed");
1305 printf("\n -P run script through C preprocessor before compilation");
1306 printf("\n -s enable some switch parsing for switches after script name");
1307 printf("\n -S look for the script using PATH environment variable");
1308 printf("\n -T turn on tainting checks");
1309 printf("\n -u dump core after parsing script");
1310 printf("\n -U allow unsafe operations");
1311 printf("\n -v print version number and patchlevel of perl");
1312 printf("\n -V[:variable] print perl configuration information");
1313 printf("\n -w TURN WARNINGS ON FOR COMPILATION OF YOUR SCRIPT.");
1314 printf("\n -x[directory] strip off text before #!perl line and perhaps cd to directory\n");
1317 /* This routine handles any switches that can be given during run */
1328 rschar = scan_oct(s, 4, &numlen);
1330 if (rschar & ~((U8)~0))
1332 else if (!rschar && numlen >= 2)
1333 nrs = newSVpv("", 0);
1336 nrs = newSVpv(&ch, 1);
1341 splitstr = savepv(s + 1);
1355 if (*s == ':' || *s == '=') {
1356 my_setenv("PERL5DB", form("use Devel::%s;", ++s));
1360 perldb = PERLDB_ALL;
1367 if (isALPHA(s[1])) {
1368 static char debopts[] = "psltocPmfrxuLHXD";
1371 for (s++; *s && (d = strchr(debopts,*s)); s++)
1372 debug |= 1 << (d - debopts);
1376 for (s++; isDIGIT(*s); s++) ;
1378 debug |= 0x80000000;
1380 warn("Recompile perl with -DDEBUGGING to use -D switch\n");
1381 for (s++; isALNUM(*s); s++) ;
1391 inplace = savepv(s+1);
1393 for (s = inplace; *s && !isSPACE(*s); s++) ;
1400 for (e = s; *e && !isSPACE(*e); e++) ;
1401 p = savepvn(s, e-s);
1408 croak("No space allowed after -I");
1418 *ors = scan_oct(s, 3 + (*s == '0'), &numlen);
1427 ors = SvPV(nrs, orslen);
1428 ors = savepvn(ors, orslen);
1432 forbid_setid("-M"); /* XXX ? */
1435 forbid_setid("-m"); /* XXX ? */
1439 /* -M-foo == 'no foo' */
1440 if (*s == '-') { use = "no "; ++s; }
1441 Sv = newSVpv(use,0);
1443 /* We allow -M'Module qw(Foo Bar)' */
1444 while(isALNUM(*s) || *s==':') ++s;
1446 sv_catpv(Sv, start);
1447 if (*(start-1) == 'm') {
1449 croak("Can't use '%c' after -mname", *s);
1450 sv_catpv( Sv, " ()");
1453 sv_catpvn(Sv, start, s-start);
1454 sv_catpv(Sv, " split(/,/,q{");
1459 if (preambleav == NULL)
1460 preambleav = newAV();
1461 av_push(preambleav, Sv);
1464 croak("No space allowed after -%c", *(s-1));
1481 croak("Too late for \"-T\" option");
1493 #if defined(SUBVERSION) && SUBVERSION > 0
1494 printf("\nThis is perl, version 5.%03d_%02d", PATCHLEVEL, SUBVERSION);
1496 printf("\nThis is perl, version %s",patchlevel);
1499 printf("\n\nCopyright 1987-1997, Larry Wall\n");
1501 printf("\n\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
1504 printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n");
1507 printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
1508 "Version 5 port Copyright (c) 1994-1997, Andreas Kaiser, Ilya Zakharevich\n");
1511 printf("atariST series port, ++jrb bammi@cadence.com\n");
1514 Perl may be copied only under the terms of either the Artistic License or the\n\
1515 GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n");
1523 if (s[1] == '-') /* Additional switches on #! line. */
1531 #ifdef ALTERNATE_SHEBANG
1532 case 'S': /* OS/2 needs -S on "extproc" line. */
1540 croak("Can't emulate -%.1s on #! line",s);
1545 /* compliments of Tom Christiansen */
1547 /* unexec() can be found in the Gnu emacs distribution */
1558 prog = newSVpv(BIN_EXP);
1559 sv_catpv(prog, "/perl");
1560 file = newSVpv(origfilename);
1561 sv_catpv(file, ".perldump");
1563 status = unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
1565 PerlIO_printf(PerlIO_stderr(), "unexec of %s into %s failed!\n",
1566 SvPVX(prog), SvPVX(file));
1570 # include <lib$routines.h>
1571 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
1573 ABORT(); /* for use with undump */
1583 /* Note that strtab is a rather special HV. Assumptions are made
1584 about not iterating on it, and not adding tie magic to it.
1585 It is properly deallocated in perl_destruct() */
1587 HvSHAREKEYS_off(strtab); /* mandatory */
1588 Newz(506,((XPVHV*)SvANY(strtab))->xhv_array,
1589 sizeof(HE*) * (((XPVHV*)SvANY(strtab))->xhv_max + 1), char);
1591 curstash = defstash = newHV();
1592 curstname = newSVpv("main",4);
1593 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
1594 SvREFCNT_dec(GvHV(gv));
1595 GvHV(gv) = (HV*)SvREFCNT_inc(defstash);
1597 HvNAME(defstash) = savepv("main");
1598 incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
1600 defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
1601 errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
1603 (void)form("%240s",""); /* Preallocate temp - for immediate signals. */
1604 sv_grow(GvSV(errgv), 240); /* Preallocate - for immediate signals. */
1605 sv_setpvn(GvSV(errgv), "", 0);
1606 curstash = defstash;
1607 compiling.cop_stash = defstash;
1608 debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
1609 /* We must init $/ before switches are processed. */
1610 sv_setpvn(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), "\n", 1);
1613 #ifdef CAN_PROTOTYPE
1615 open_script(char *scriptname, bool dosearch, SV *sv)
1618 open_script(scriptname,dosearch,sv)
1624 char *xfound = Nullch;
1625 char *xfailed = Nullch;
1629 #if defined(DOSISH) && !defined(OS2) && !defined(atarist)
1630 # define SEARCH_EXTS ".bat", ".cmd", NULL
1631 # define MAX_EXT_LEN 4
1634 # define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL
1635 # define MAX_EXT_LEN 4
1638 # define SEARCH_EXTS ".pl", ".com", NULL
1639 # define MAX_EXT_LEN 4
1641 /* additional extensions to try in each dir if scriptname not found */
1643 char *ext[] = { SEARCH_EXTS };
1644 int extidx = 0, i = 0;
1645 char *curext = Nullch;
1647 # define MAX_EXT_LEN 0
1651 * If dosearch is true and if scriptname does not contain path
1652 * delimiters, search the PATH for scriptname.
1654 * If SEARCH_EXTS is also defined, will look for each
1655 * scriptname{SEARCH_EXTS} whenever scriptname is not found
1656 * while searching the PATH.
1658 * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
1659 * proceeds as follows:
1661 * + look for ./scriptname{,.foo,.bar}
1662 * + search the PATH for scriptname{,.foo,.bar}
1665 * + look *only* in the PATH for scriptname{,.foo,.bar} (note
1666 * this will not look in '.' if it's not in the PATH)
1671 int hasdir, idx = 0, deftypes = 1;
1673 hasdir = (strpbrk(scriptname,":[</") != Nullch) ;
1674 /* The first time through, just add SEARCH_EXTS to whatever we
1675 * already have, so we can check for default file types. */
1677 (!hasdir && my_trnlnm("DCL$PATH",tokenbuf,idx++)) )
1683 if ((strlen(tokenbuf) + strlen(scriptname)
1684 + MAX_EXT_LEN) >= sizeof tokenbuf)
1685 continue; /* don't search dir with too-long name */
1686 strcat(tokenbuf, scriptname);
1690 if (strEQ(scriptname, "-"))
1692 if (dosearch) { /* Look in '.' first. */
1693 char *cur = scriptname;
1695 if ((curext = strrchr(scriptname,'.'))) /* possible current ext */
1697 if (strEQ(ext[i++],curext)) {
1698 extidx = -1; /* already has an ext */
1703 DEBUG_p(PerlIO_printf(Perl_debug_log,
1704 "Looking for %s\n",cur));
1705 if (Stat(cur,&statbuf) >= 0) {
1713 if (cur == scriptname) {
1714 len = strlen(scriptname);
1715 if (len+MAX_EXT_LEN+1 >= sizeof(tokenbuf))
1717 cur = strcpy(tokenbuf, scriptname);
1719 } while (extidx >= 0 && ext[extidx] /* try an extension? */
1720 && strcpy(tokenbuf+len, ext[extidx++]));
1725 if (dosearch && !strchr(scriptname, '/')
1727 && !strchr(scriptname, '\\')
1729 && (s = getenv("PATH"))) {
1732 bufend = s + strlen(s);
1733 while (s < bufend) {
1734 #if defined(atarist) || defined(DOSISH)
1739 && *s != ';'; len++, s++) {
1740 if (len < sizeof tokenbuf)
1743 if (len < sizeof tokenbuf)
1744 tokenbuf[len] = '\0';
1745 #else /* ! (atarist || DOSISH) */
1746 s = delimcpy(tokenbuf, tokenbuf + sizeof tokenbuf, s, bufend,
1749 #endif /* ! (atarist || DOSISH) */
1752 if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tokenbuf)
1753 continue; /* don't search dir with too-long name */
1755 #if defined(atarist) || defined(DOSISH)
1756 && tokenbuf[len - 1] != '/'
1757 && tokenbuf[len - 1] != '\\'
1760 tokenbuf[len++] = '/';
1761 if (len == 2 && tokenbuf[0] == '.')
1763 (void)strcpy(tokenbuf + len, scriptname);
1767 len = strlen(tokenbuf);
1768 if (extidx > 0) /* reset after previous loop */
1772 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tokenbuf));
1773 retval = Stat(tokenbuf,&statbuf);
1775 } while ( retval < 0 /* not there */
1776 && extidx>=0 && ext[extidx] /* try an extension? */
1777 && strcpy(tokenbuf+len, ext[extidx++])
1782 if (S_ISREG(statbuf.st_mode)
1783 && cando(S_IRUSR,TRUE,&statbuf)
1785 && cando(S_IXUSR,TRUE,&statbuf)
1789 xfound = tokenbuf; /* bingo! */
1793 xfailed = savepv(tokenbuf);
1796 if (!xfound && !seen_dot && !xfailed && (Stat(scriptname,&statbuf) < 0))
1798 seen_dot = 1; /* Disable message. */
1800 croak("Can't %s %s%s%s",
1801 (xfailed ? "execute" : "find"),
1802 (xfailed ? xfailed : scriptname),
1803 (xfailed ? "" : " on PATH"),
1804 (xfailed || seen_dot) ? "" : ", '.' not in PATH");
1807 scriptname = xfound;
1810 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
1811 char *s = scriptname + 8;
1820 origfilename = savepv(e_tmpname ? "-e" : scriptname);
1821 curcop->cop_filegv = gv_fetchfile(origfilename);
1822 if (strEQ(origfilename,"-"))
1824 if (fdscript >= 0) {
1825 rsfp = PerlIO_fdopen(fdscript,"r");
1826 #if defined(HAS_FCNTL) && defined(F_SETFD)
1828 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
1831 else if (preprocess) {
1832 char *cpp_cfg = CPPSTDIN;
1833 SV *cpp = NEWSV(0,0);
1834 SV *cmd = NEWSV(0,0);
1836 if (strEQ(cpp_cfg, "cppstdin"))
1837 sv_catpvf(cpp, "%s/", BIN_EXP);
1838 sv_catpv(cpp, cpp_cfg);
1841 sv_catpv(sv,PRIVLIB_EXP);
1845 sed %s -e \"/^[^#]/b\" \
1846 -e \"/^#[ ]*include[ ]/b\" \
1847 -e \"/^#[ ]*define[ ]/b\" \
1848 -e \"/^#[ ]*if[ ]/b\" \
1849 -e \"/^#[ ]*ifdef[ ]/b\" \
1850 -e \"/^#[ ]*ifndef[ ]/b\" \
1851 -e \"/^#[ ]*else/b\" \
1852 -e \"/^#[ ]*elif[ ]/b\" \
1853 -e \"/^#[ ]*undef[ ]/b\" \
1854 -e \"/^#[ ]*endif/b\" \
1857 (doextract ? "-e \"1,/^#/d\n\"" : ""),
1860 %s %s -e '/^[^#]/b' \
1861 -e '/^#[ ]*include[ ]/b' \
1862 -e '/^#[ ]*define[ ]/b' \
1863 -e '/^#[ ]*if[ ]/b' \
1864 -e '/^#[ ]*ifdef[ ]/b' \
1865 -e '/^#[ ]*ifndef[ ]/b' \
1866 -e '/^#[ ]*else/b' \
1867 -e '/^#[ ]*elif[ ]/b' \
1868 -e '/^#[ ]*undef[ ]/b' \
1869 -e '/^#[ ]*endif/b' \
1877 (doextract ? "-e '1,/^#/d\n'" : ""),
1879 scriptname, cpp, sv, CPPMINUS);
1881 #ifdef IAMSUID /* actually, this is caught earlier */
1882 if (euid != uid && !euid) { /* if running suidperl */
1884 (void)seteuid(uid); /* musn't stay setuid root */
1887 (void)setreuid((Uid_t)-1, uid);
1889 #ifdef HAS_SETRESUID
1890 (void)setresuid((Uid_t)-1, uid, (Uid_t)-1);
1896 if (geteuid() != uid)
1897 croak("Can't do seteuid!\n");
1899 #endif /* IAMSUID */
1900 rsfp = my_popen(SvPVX(cmd), "r");
1904 else if (!*scriptname) {
1905 forbid_setid("program input from stdin");
1906 rsfp = PerlIO_stdin();
1909 rsfp = PerlIO_open(scriptname,"r");
1910 #if defined(HAS_FCNTL) && defined(F_SETFD)
1912 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
1920 #ifndef IAMSUID /* in case script is not readable before setuid */
1921 if (euid && Stat(SvPVX(GvSV(curcop->cop_filegv)),&statbuf) >= 0 &&
1922 statbuf.st_mode & (S_ISUID|S_ISGID)) {
1924 execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
1925 croak("Can't do setuid\n");
1929 croak("Can't open perl script \"%s\": %s\n",
1930 SvPVX(GvSV(curcop->cop_filegv)), Strerror(errno));
1935 validate_suid(validarg, scriptname)
1941 /* do we need to emulate setuid on scripts? */
1943 /* This code is for those BSD systems that have setuid #! scripts disabled
1944 * in the kernel because of a security problem. Merely defining DOSUID
1945 * in perl will not fix that problem, but if you have disabled setuid
1946 * scripts in the kernel, this will attempt to emulate setuid and setgid
1947 * on scripts that have those now-otherwise-useless bits set. The setuid
1948 * root version must be called suidperl or sperlN.NNN. If regular perl
1949 * discovers that it has opened a setuid script, it calls suidperl with
1950 * the same argv that it had. If suidperl finds that the script it has
1951 * just opened is NOT setuid root, it sets the effective uid back to the
1952 * uid. We don't just make perl setuid root because that loses the
1953 * effective uid we had before invoking perl, if it was different from the
1956 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
1957 * be defined in suidperl only. suidperl must be setuid root. The
1958 * Configure script will set this up for you if you want it.
1964 if (Fstat(PerlIO_fileno(rsfp),&statbuf) < 0) /* normal stat is insecure */
1965 croak("Can't stat script \"%s\"",origfilename);
1966 if (fdscript < 0 && statbuf.st_mode & (S_ISUID|S_ISGID)) {
1970 #ifndef HAS_SETREUID
1971 /* On this access check to make sure the directories are readable,
1972 * there is actually a small window that the user could use to make
1973 * filename point to an accessible directory. So there is a faint
1974 * chance that someone could execute a setuid script down in a
1975 * non-accessible directory. I don't know what to do about that.
1976 * But I don't think it's too important. The manual lies when
1977 * it says access() is useful in setuid programs.
1979 if (access(SvPVX(GvSV(curcop->cop_filegv)),1)) /*double check*/
1980 croak("Permission denied");
1982 /* If we can swap euid and uid, then we can determine access rights
1983 * with a simple stat of the file, and then compare device and
1984 * inode to make sure we did stat() on the same file we opened.
1985 * Then we just have to make sure he or she can execute it.
1988 struct stat tmpstatbuf;
1992 setreuid(euid,uid) < 0
1995 setresuid(euid,uid,(Uid_t)-1) < 0
1998 || getuid() != euid || geteuid() != uid)
1999 croak("Can't swap uid and euid"); /* really paranoid */
2000 if (Stat(SvPVX(GvSV(curcop->cop_filegv)),&tmpstatbuf) < 0)
2001 croak("Permission denied"); /* testing full pathname here */
2002 if (tmpstatbuf.st_dev != statbuf.st_dev ||
2003 tmpstatbuf.st_ino != statbuf.st_ino) {
2004 (void)PerlIO_close(rsfp);
2005 if (rsfp = my_popen("/bin/mail root","w")) { /* heh, heh */
2007 "User %ld tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
2008 (Filename of set-id script was %s, uid %ld gid %ld.)\n\nSincerely,\nperl\n",
2009 (long)uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
2010 (long)statbuf.st_dev, (long)statbuf.st_ino,
2011 SvPVX(GvSV(curcop->cop_filegv)),
2012 (long)statbuf.st_uid, (long)statbuf.st_gid);
2013 (void)my_pclose(rsfp);
2015 croak("Permission denied\n");
2019 setreuid(uid,euid) < 0
2021 # if defined(HAS_SETRESUID)
2022 setresuid(uid,euid,(Uid_t)-1) < 0
2025 || getuid() != uid || geteuid() != euid)
2026 croak("Can't reswap uid and euid");
2027 if (!cando(S_IXUSR,FALSE,&statbuf)) /* can real uid exec? */
2028 croak("Permission denied\n");
2030 #endif /* HAS_SETREUID */
2031 #endif /* IAMSUID */
2033 if (!S_ISREG(statbuf.st_mode))
2034 croak("Permission denied");
2035 if (statbuf.st_mode & S_IWOTH)
2036 croak("Setuid/gid script is writable by world");
2037 doswitches = FALSE; /* -s is insecure in suid */
2039 if (sv_gets(linestr, rsfp, 0) == Nullch ||
2040 strnNE(SvPV(linestr,na),"#!",2) ) /* required even on Sys V */
2041 croak("No #! line");
2042 s = SvPV(linestr,na)+2;
2044 while (!isSPACE(*s)) s++;
2045 for (s2 = s; (s2 > SvPV(linestr,na)+2 &&
2046 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
2047 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
2048 croak("Not a perl script");
2049 while (*s == ' ' || *s == '\t') s++;
2051 * #! arg must be what we saw above. They can invoke it by
2052 * mentioning suidperl explicitly, but they may not add any strange
2053 * arguments beyond what #! says if they do invoke suidperl that way.
2055 len = strlen(validarg);
2056 if (strEQ(validarg," PHOOEY ") ||
2057 strnNE(s,validarg,len) || !isSPACE(s[len]))
2058 croak("Args must match #! line");
2061 if (euid != uid && (statbuf.st_mode & S_ISUID) &&
2062 euid == statbuf.st_uid)
2064 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2065 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2066 #endif /* IAMSUID */
2068 if (euid) { /* oops, we're not the setuid root perl */
2069 (void)PerlIO_close(rsfp);
2072 execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
2074 croak("Can't do setuid\n");
2077 if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid) {
2079 (void)setegid(statbuf.st_gid);
2082 (void)setregid((Gid_t)-1,statbuf.st_gid);
2084 #ifdef HAS_SETRESGID
2085 (void)setresgid((Gid_t)-1,statbuf.st_gid,(Gid_t)-1);
2087 setgid(statbuf.st_gid);
2091 if (getegid() != statbuf.st_gid)
2092 croak("Can't do setegid!\n");
2094 if (statbuf.st_mode & S_ISUID) {
2095 if (statbuf.st_uid != euid)
2097 (void)seteuid(statbuf.st_uid); /* all that for this */
2100 (void)setreuid((Uid_t)-1,statbuf.st_uid);
2102 #ifdef HAS_SETRESUID
2103 (void)setresuid((Uid_t)-1,statbuf.st_uid,(Uid_t)-1);
2105 setuid(statbuf.st_uid);
2109 if (geteuid() != statbuf.st_uid)
2110 croak("Can't do seteuid!\n");
2112 else if (uid) { /* oops, mustn't run as root */
2114 (void)seteuid((Uid_t)uid);
2117 (void)setreuid((Uid_t)-1,(Uid_t)uid);
2119 #ifdef HAS_SETRESUID
2120 (void)setresuid((Uid_t)-1,(Uid_t)uid,(Uid_t)-1);
2126 if (geteuid() != uid)
2127 croak("Can't do seteuid!\n");
2130 if (!cando(S_IXUSR,TRUE,&statbuf))
2131 croak("Permission denied\n"); /* they can't do this */
2134 else if (preprocess)
2135 croak("-P not allowed for setuid/setgid script\n");
2136 else if (fdscript >= 0)
2137 croak("fd script not allowed in suidperl\n");
2139 croak("Script is not setuid/setgid in suidperl\n");
2141 /* We absolutely must clear out any saved ids here, so we */
2142 /* exec the real perl, substituting fd script for scriptname. */
2143 /* (We pass script name as "subdir" of fd, which perl will grok.) */
2144 PerlIO_rewind(rsfp);
2145 lseek(PerlIO_fileno(rsfp),(Off_t)0,0); /* just in case rewind didn't */
2146 for (which = 1; origargv[which] && origargv[which] != scriptname; which++) ;
2147 if (!origargv[which])
2148 croak("Permission denied");
2149 origargv[which] = savepv(form("/dev/fd/%d/%s",
2150 PerlIO_fileno(rsfp), origargv[which]));
2151 #if defined(HAS_FCNTL) && defined(F_SETFD)
2152 fcntl(PerlIO_fileno(rsfp),F_SETFD,0); /* ensure no close-on-exec */
2154 execv(form("%s/perl%s", BIN_EXP, patchlevel), origargv); /* try again */
2155 croak("Can't do setuid\n");
2156 #endif /* IAMSUID */
2158 if (euid != uid || egid != gid) { /* (suidperl doesn't exist, in fact) */
2159 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
2160 Fstat(PerlIO_fileno(rsfp),&statbuf); /* may be either wrapped or real suid */
2161 if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
2163 (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
2166 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2167 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2168 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
2169 /* not set-id, must be wrapped */
2177 register char *s, *s2;
2179 /* skip forward in input to the real script? */
2183 if ((s = sv_gets(linestr, rsfp, 0)) == Nullch)
2184 croak("No Perl script found in input\n");
2185 if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
2186 PerlIO_ungetc(rsfp, '\n'); /* to keep line count right */
2188 while (*s && !(isSPACE (*s) || *s == '#')) s++;
2190 while (*s == ' ' || *s == '\t') s++;
2192 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
2193 if (strnEQ(s2-4,"perl",4))
2195 while (s = moreswitches(s)) ;
2197 if (cddir && chdir(cddir) < 0)
2198 croak("Can't chdir to %s",cddir);
2206 uid = (int)getuid();
2207 euid = (int)geteuid();
2208 gid = (int)getgid();
2209 egid = (int)getegid();
2214 tainting |= (uid && (euid != uid || egid != gid));
2222 croak("No %s allowed while running setuid", s);
2224 croak("No %s allowed while running setgid", s);
2230 curstash = debstash;
2231 dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
2233 DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
2234 DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
2235 DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
2236 DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
2237 sv_setiv(DBsingle, 0);
2238 DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
2239 sv_setiv(DBtrace, 0);
2240 DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
2241 sv_setiv(DBsignal, 0);
2242 curstash = defstash;
2249 mainstack = curstack; /* remember in case we switch stacks */
2250 AvREAL_off(curstack); /* not a real array */
2251 av_extend(curstack,127);
2253 stack_base = AvARRAY(curstack);
2254 stack_sp = stack_base;
2255 stack_max = stack_base + 127;
2257 cxstack_max = 8192 / sizeof(CONTEXT) - 2; /* Use most of 8K. */
2258 New(50,cxstack,cxstack_max + 1,CONTEXT);
2261 New(50,tmps_stack,128,SV*);
2266 New(51,debname,128,char);
2267 New(52,debdelim,128,char);
2271 * The following stacks almost certainly should be per-interpreter,
2272 * but for now they're not. XXX
2276 markstack_ptr = markstack;
2278 New(54,markstack,64,I32);
2279 markstack_ptr = markstack;
2280 markstack_max = markstack + 64;
2286 New(54,scopestack,32,I32);
2288 scopestack_max = 32;
2294 New(54,savestack,128,ANY);
2296 savestack_max = 128;
2302 New(54,retstack,16,OP*);
2312 Safefree(tmps_stack);
2319 static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
2327 subname = newSVpv("main",4);
2331 init_predump_symbols()
2336 sv_setpvn(GvSV(gv_fetchpv("\"", TRUE, SVt_PV)), " ", 1);
2338 stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
2339 GvMULTI_on(stdingv);
2340 IoIFP(GvIOp(stdingv)) = PerlIO_stdin();
2341 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
2343 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(stdingv));
2345 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
2347 IoOFP(GvIOp(tmpgv)) = IoIFP(GvIOp(tmpgv)) = PerlIO_stdout();
2349 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
2351 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(defoutgv));
2353 othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
2354 GvMULTI_on(othergv);
2355 IoOFP(GvIOp(othergv)) = IoIFP(GvIOp(othergv)) = PerlIO_stderr();
2356 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
2358 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(othergv));
2360 statname = NEWSV(66,0); /* last filename we did stat on */
2363 osname = savepv(OSNAME);
2367 init_postdump_symbols(argc,argv,env)
2369 register char **argv;
2370 register char **env;
2376 argc--,argv++; /* skip name of script */
2378 for (; argc > 0 && **argv == '-'; argc--,argv++) {
2381 if (argv[0][1] == '-') {
2385 if (s = strchr(argv[0], '=')) {
2387 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
2390 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
2393 toptarget = NEWSV(0,0);
2394 sv_upgrade(toptarget, SVt_PVFM);
2395 sv_setpvn(toptarget, "", 0);
2396 bodytarget = NEWSV(0,0);
2397 sv_upgrade(bodytarget, SVt_PVFM);
2398 sv_setpvn(bodytarget, "", 0);
2399 formtarget = bodytarget;
2402 if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
2403 sv_setpv(GvSV(tmpgv),origfilename);
2404 magicname("0", "0", 1);
2406 if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
2407 sv_setpv(GvSV(tmpgv),origargv[0]);
2408 if (argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
2410 (void)gv_AVadd(argvgv);
2411 av_clear(GvAVn(argvgv));
2412 for (; argc > 0; argc--,argv++) {
2413 av_push(GvAVn(argvgv),newSVpv(argv[0],0));
2416 if (envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
2420 hv_magic(hv, envgv, 'E');
2421 #ifndef VMS /* VMS doesn't have environ array */
2422 /* Note that if the supplied env parameter is actually a copy
2423 of the global environ then it may now point to free'd memory
2424 if the environment has been modified since. To avoid this
2425 problem we treat env==NULL as meaning 'use the default'
2430 environ[0] = Nullch;
2431 for (; *env; env++) {
2432 if (!(s = strchr(*env,'=')))
2438 sv = newSVpv(s--,0);
2439 (void)hv_store(hv, *env, s - *env, sv, 0);
2441 #if defined(__BORLANDC__) && defined(USE_WIN32_RTL_ENV)
2442 /* Sins of the RTL. See note in my_setenv(). */
2443 (void)putenv(savepv(*env));
2447 #ifdef DYNAMIC_ENV_FETCH
2448 HvNAME(hv) = savepv(ENV_HV_NAME);
2452 if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
2453 sv_setiv(GvSV(tmpgv), (IV)getpid());
2462 s = getenv("PERL5LIB");
2466 incpush(getenv("PERLLIB"), FALSE);
2468 /* Treat PERL5?LIB as a possible search list logical name -- the
2469 * "natural" VMS idiom for a Unix path string. We allow each
2470 * element to be a set of |-separated directories for compatibility.
2474 if (my_trnlnm("PERL5LIB",buf,0))
2475 do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
2477 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE);
2481 /* Use the ~-expanded versions of APPLLIB (undocumented),
2482 ARCHLIB PRIVLIB SITEARCH SITELIB and OLDARCHLIB
2485 incpush(APPLLIB_EXP, FALSE);
2489 incpush(ARCHLIB_EXP, FALSE);
2492 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
2494 incpush(PRIVLIB_EXP, FALSE);
2497 incpush(SITEARCH_EXP, FALSE);
2500 incpush(SITELIB_EXP, FALSE);
2502 #ifdef OLDARCHLIB_EXP /* 5.00[01] compatibility */
2503 incpush(OLDARCHLIB_EXP, FALSE);
2507 incpush(".", FALSE);
2511 # define PERLLIB_SEP ';'
2514 # define PERLLIB_SEP '|'
2516 # define PERLLIB_SEP ':'
2519 #ifndef PERLLIB_MANGLE
2520 # define PERLLIB_MANGLE(s,n) (s)
2524 incpush(p, addsubdirs)
2528 SV *subdir = Nullsv;
2529 static char *archpat_auto;
2536 if (!archpat_auto) {
2537 STRLEN len = (sizeof(ARCHNAME) + strlen(patchlevel)
2538 + sizeof("//auto"));
2539 New(55, archpat_auto, len, char);
2540 sprintf(archpat_auto, "/%s/%s/auto", ARCHNAME, patchlevel);
2542 for (len = sizeof(ARCHNAME) + 2;
2543 archpat_auto[len] != '\0' && archpat_auto[len] != '/'; len++)
2544 if (archpat_auto[len] == '.') archpat_auto[len] = '_';
2549 /* Break at all separators */
2551 SV *libdir = newSV(0);
2554 /* skip any consecutive separators */
2555 while ( *p == PERLLIB_SEP ) {
2556 /* Uncomment the next line for PATH semantics */
2557 /* av_push(GvAVn(incgv), newSVpv(".", 1)); */
2561 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
2562 sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
2567 sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
2568 p = Nullch; /* break out */
2572 * BEFORE pushing libdir onto @INC we may first push version- and
2573 * archname-specific sub-directories.
2576 struct stat tmpstatbuf;
2581 if ((unix = tounixspec_ts(SvPV(libdir,na),Nullch)) != Nullch) {
2583 while (unix[len-1] == '/') len--; /* Cosmetic */
2584 sv_usepvn(libdir,unix,len);
2587 PerlIO_printf(PerlIO_stderr(),
2588 "Failed to unixify @INC element \"%s\"\n",
2591 /* .../archname/version if -d .../archname/version/auto */
2592 sv_setsv(subdir, libdir);
2593 sv_catpv(subdir, archpat_auto);
2594 if (Stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2595 S_ISDIR(tmpstatbuf.st_mode))
2596 av_push(GvAVn(incgv),
2597 newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2599 /* .../archname if -d .../archname/auto */
2600 sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME),
2601 strlen(patchlevel) + 1, "", 0);
2602 if (Stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2603 S_ISDIR(tmpstatbuf.st_mode))
2604 av_push(GvAVn(incgv),
2605 newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2608 /* finally push this lib directory on the end of @INC */
2609 av_push(GvAVn(incgv), libdir);
2612 SvREFCNT_dec(subdir);
2616 call_list(oldscope, list)
2620 line_t oldline = curcop->cop_line;
2625 while (AvFILL(list) >= 0) {
2626 CV *cv = (CV*)av_shift(list);
2633 SV* atsv = GvSV(errgv);
2635 perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
2636 (void)SvPV(atsv, len);
2639 curcop = &compiling;
2640 curcop->cop_line = oldline;
2641 if (list == beginav)
2642 sv_catpv(atsv, "BEGIN failed--compilation aborted");
2644 sv_catpv(atsv, "END failed--cleanup aborted");
2645 while (scopestack_ix > oldscope)
2647 croak("%s", SvPVX(atsv));
2655 /* my_exit() was called */
2656 while (scopestack_ix > oldscope)
2659 curstash = defstash;
2661 call_list(oldscope, endav);
2663 curcop = &compiling;
2664 curcop->cop_line = oldline;
2666 if (list == beginav)
2667 croak("BEGIN failed--compilation aborted");
2669 croak("END failed--cleanup aborted");
2675 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
2680 curcop = &compiling;
2681 curcop->cop_line = oldline;
2700 STATUS_NATIVE_SET(status);
2710 if (vaxc$errno & 1) {
2711 if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
2712 STATUS_NATIVE_SET(44);
2715 if (!vaxc$errno && errno) /* unlikely */
2716 STATUS_NATIVE_SET(44);
2718 STATUS_NATIVE_SET(vaxc$errno);
2722 STATUS_POSIX_SET(errno);
2723 else if (STATUS_POSIX == 0)
2724 STATUS_POSIX_SET(255);
2732 register CONTEXT *cx;
2741 (void)UNLINK(e_tmpname);
2742 Safefree(e_tmpname);
2746 if (cxstack_ix >= 0) {