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 than once)");
1301 printf("\n -l[octal] enable line ending processing, specifies line terminator");
1302 printf("\n -[mM][-]module.. executes `use/no module...' before executing your script.");
1303 printf("\n -n assume 'while (<>) { ... }' loop around 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;
1674 hasdir = (strpbrk(scriptname,":[</") != Nullch) ;
1675 /* The first time through, just add SEARCH_EXTS to whatever we
1676 * already have, so we can check for default file types. */
1678 (!hasdir && my_trnlnm("DCL$PATH",tokenbuf,idx++)) )
1684 if ((strlen(tokenbuf) + strlen(scriptname)
1685 + MAX_EXT_LEN) >= sizeof tokenbuf)
1686 continue; /* don't search dir with too-long name */
1687 strcat(tokenbuf, scriptname);
1691 if (strEQ(scriptname, "-"))
1693 if (dosearch) { /* Look in '.' first. */
1694 char *cur = scriptname;
1696 if ((curext = strrchr(scriptname,'.'))) /* possible current ext */
1698 if (strEQ(ext[i++],curext)) {
1699 extidx = -1; /* already has an ext */
1704 DEBUG_p(PerlIO_printf(Perl_debug_log,
1705 "Looking for %s\n",cur));
1706 if (Stat(cur,&statbuf) >= 0) {
1714 if (cur == scriptname) {
1715 len = strlen(scriptname);
1716 if (len+MAX_EXT_LEN+1 >= sizeof(tokenbuf))
1718 cur = strcpy(tokenbuf, scriptname);
1720 } while (extidx >= 0 && ext[extidx] /* try an extension? */
1721 && strcpy(tokenbuf+len, ext[extidx++]));
1726 if (dosearch && !strchr(scriptname, '/')
1728 && !strchr(scriptname, '\\')
1730 && (s = getenv("PATH"))) {
1733 bufend = s + strlen(s);
1734 while (s < bufend) {
1735 #if defined(atarist) || defined(DOSISH)
1740 && *s != ';'; len++, s++) {
1741 if (len < sizeof tokenbuf)
1744 if (len < sizeof tokenbuf)
1745 tokenbuf[len] = '\0';
1746 #else /* ! (atarist || DOSISH) */
1747 s = delimcpy(tokenbuf, tokenbuf + sizeof tokenbuf, s, bufend,
1750 #endif /* ! (atarist || DOSISH) */
1753 if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tokenbuf)
1754 continue; /* don't search dir with too-long name */
1756 #if defined(atarist) || defined(DOSISH)
1757 && tokenbuf[len - 1] != '/'
1758 && tokenbuf[len - 1] != '\\'
1761 tokenbuf[len++] = '/';
1762 if (len == 2 && tokenbuf[0] == '.')
1764 (void)strcpy(tokenbuf + len, scriptname);
1768 len = strlen(tokenbuf);
1769 if (extidx > 0) /* reset after previous loop */
1773 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tokenbuf));
1774 retval = Stat(tokenbuf,&statbuf);
1776 } while ( retval < 0 /* not there */
1777 && extidx>=0 && ext[extidx] /* try an extension? */
1778 && strcpy(tokenbuf+len, ext[extidx++])
1783 if (S_ISREG(statbuf.st_mode)
1784 && cando(S_IRUSR,TRUE,&statbuf)
1786 && cando(S_IXUSR,TRUE,&statbuf)
1790 xfound = tokenbuf; /* bingo! */
1794 xfailed = savepv(tokenbuf);
1797 if (!xfound && !seen_dot && !xfailed && (Stat(scriptname,&statbuf) < 0))
1799 seen_dot = 1; /* Disable message. */
1801 croak("Can't %s %s%s%s",
1802 (xfailed ? "execute" : "find"),
1803 (xfailed ? xfailed : scriptname),
1804 (xfailed ? "" : " on PATH"),
1805 (xfailed || seen_dot) ? "" : ", '.' not in PATH");
1808 scriptname = xfound;
1811 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
1812 char *s = scriptname + 8;
1821 origfilename = savepv(e_tmpname ? "-e" : scriptname);
1822 curcop->cop_filegv = gv_fetchfile(origfilename);
1823 if (strEQ(origfilename,"-"))
1825 if (fdscript >= 0) {
1826 rsfp = PerlIO_fdopen(fdscript,"r");
1827 #if defined(HAS_FCNTL) && defined(F_SETFD)
1829 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
1832 else if (preprocess) {
1833 char *cpp_cfg = CPPSTDIN;
1834 SV *cpp = NEWSV(0,0);
1835 SV *cmd = NEWSV(0,0);
1837 if (strEQ(cpp_cfg, "cppstdin"))
1838 sv_catpvf(cpp, "%s/", BIN_EXP);
1839 sv_catpv(cpp, cpp_cfg);
1842 sv_catpv(sv,PRIVLIB_EXP);
1846 sed %s -e \"/^[^#]/b\" \
1847 -e \"/^#[ ]*include[ ]/b\" \
1848 -e \"/^#[ ]*define[ ]/b\" \
1849 -e \"/^#[ ]*if[ ]/b\" \
1850 -e \"/^#[ ]*ifdef[ ]/b\" \
1851 -e \"/^#[ ]*ifndef[ ]/b\" \
1852 -e \"/^#[ ]*else/b\" \
1853 -e \"/^#[ ]*elif[ ]/b\" \
1854 -e \"/^#[ ]*undef[ ]/b\" \
1855 -e \"/^#[ ]*endif/b\" \
1858 (doextract ? "-e \"1,/^#/d\n\"" : ""),
1861 %s %s -e '/^[^#]/b' \
1862 -e '/^#[ ]*include[ ]/b' \
1863 -e '/^#[ ]*define[ ]/b' \
1864 -e '/^#[ ]*if[ ]/b' \
1865 -e '/^#[ ]*ifdef[ ]/b' \
1866 -e '/^#[ ]*ifndef[ ]/b' \
1867 -e '/^#[ ]*else/b' \
1868 -e '/^#[ ]*elif[ ]/b' \
1869 -e '/^#[ ]*undef[ ]/b' \
1870 -e '/^#[ ]*endif/b' \
1878 (doextract ? "-e '1,/^#/d\n'" : ""),
1880 scriptname, cpp, sv, CPPMINUS);
1882 #ifdef IAMSUID /* actually, this is caught earlier */
1883 if (euid != uid && !euid) { /* if running suidperl */
1885 (void)seteuid(uid); /* musn't stay setuid root */
1888 (void)setreuid((Uid_t)-1, uid);
1890 #ifdef HAS_SETRESUID
1891 (void)setresuid((Uid_t)-1, uid, (Uid_t)-1);
1897 if (geteuid() != uid)
1898 croak("Can't do seteuid!\n");
1900 #endif /* IAMSUID */
1901 rsfp = my_popen(SvPVX(cmd), "r");
1905 else if (!*scriptname) {
1906 forbid_setid("program input from stdin");
1907 rsfp = PerlIO_stdin();
1910 rsfp = PerlIO_open(scriptname,"r");
1911 #if defined(HAS_FCNTL) && defined(F_SETFD)
1913 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
1921 #ifndef IAMSUID /* in case script is not readable before setuid */
1922 if (euid && Stat(SvPVX(GvSV(curcop->cop_filegv)),&statbuf) >= 0 &&
1923 statbuf.st_mode & (S_ISUID|S_ISGID)) {
1925 execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
1926 croak("Can't do setuid\n");
1930 croak("Can't open perl script \"%s\": %s\n",
1931 SvPVX(GvSV(curcop->cop_filegv)), Strerror(errno));
1936 validate_suid(validarg, scriptname)
1942 /* do we need to emulate setuid on scripts? */
1944 /* This code is for those BSD systems that have setuid #! scripts disabled
1945 * in the kernel because of a security problem. Merely defining DOSUID
1946 * in perl will not fix that problem, but if you have disabled setuid
1947 * scripts in the kernel, this will attempt to emulate setuid and setgid
1948 * on scripts that have those now-otherwise-useless bits set. The setuid
1949 * root version must be called suidperl or sperlN.NNN. If regular perl
1950 * discovers that it has opened a setuid script, it calls suidperl with
1951 * the same argv that it had. If suidperl finds that the script it has
1952 * just opened is NOT setuid root, it sets the effective uid back to the
1953 * uid. We don't just make perl setuid root because that loses the
1954 * effective uid we had before invoking perl, if it was different from the
1957 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
1958 * be defined in suidperl only. suidperl must be setuid root. The
1959 * Configure script will set this up for you if you want it.
1965 if (Fstat(PerlIO_fileno(rsfp),&statbuf) < 0) /* normal stat is insecure */
1966 croak("Can't stat script \"%s\"",origfilename);
1967 if (fdscript < 0 && statbuf.st_mode & (S_ISUID|S_ISGID)) {
1971 #ifndef HAS_SETREUID
1972 /* On this access check to make sure the directories are readable,
1973 * there is actually a small window that the user could use to make
1974 * filename point to an accessible directory. So there is a faint
1975 * chance that someone could execute a setuid script down in a
1976 * non-accessible directory. I don't know what to do about that.
1977 * But I don't think it's too important. The manual lies when
1978 * it says access() is useful in setuid programs.
1980 if (access(SvPVX(GvSV(curcop->cop_filegv)),1)) /*double check*/
1981 croak("Permission denied");
1983 /* If we can swap euid and uid, then we can determine access rights
1984 * with a simple stat of the file, and then compare device and
1985 * inode to make sure we did stat() on the same file we opened.
1986 * Then we just have to make sure he or she can execute it.
1989 struct stat tmpstatbuf;
1993 setreuid(euid,uid) < 0
1996 setresuid(euid,uid,(Uid_t)-1) < 0
1999 || getuid() != euid || geteuid() != uid)
2000 croak("Can't swap uid and euid"); /* really paranoid */
2001 if (Stat(SvPVX(GvSV(curcop->cop_filegv)),&tmpstatbuf) < 0)
2002 croak("Permission denied"); /* testing full pathname here */
2003 if (tmpstatbuf.st_dev != statbuf.st_dev ||
2004 tmpstatbuf.st_ino != statbuf.st_ino) {
2005 (void)PerlIO_close(rsfp);
2006 if (rsfp = my_popen("/bin/mail root","w")) { /* heh, heh */
2008 "User %ld tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
2009 (Filename of set-id script was %s, uid %ld gid %ld.)\n\nSincerely,\nperl\n",
2010 (long)uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
2011 (long)statbuf.st_dev, (long)statbuf.st_ino,
2012 SvPVX(GvSV(curcop->cop_filegv)),
2013 (long)statbuf.st_uid, (long)statbuf.st_gid);
2014 (void)my_pclose(rsfp);
2016 croak("Permission denied\n");
2020 setreuid(uid,euid) < 0
2022 # if defined(HAS_SETRESUID)
2023 setresuid(uid,euid,(Uid_t)-1) < 0
2026 || getuid() != uid || geteuid() != euid)
2027 croak("Can't reswap uid and euid");
2028 if (!cando(S_IXUSR,FALSE,&statbuf)) /* can real uid exec? */
2029 croak("Permission denied\n");
2031 #endif /* HAS_SETREUID */
2032 #endif /* IAMSUID */
2034 if (!S_ISREG(statbuf.st_mode))
2035 croak("Permission denied");
2036 if (statbuf.st_mode & S_IWOTH)
2037 croak("Setuid/gid script is writable by world");
2038 doswitches = FALSE; /* -s is insecure in suid */
2040 if (sv_gets(linestr, rsfp, 0) == Nullch ||
2041 strnNE(SvPV(linestr,na),"#!",2) ) /* required even on Sys V */
2042 croak("No #! line");
2043 s = SvPV(linestr,na)+2;
2045 while (!isSPACE(*s)) s++;
2046 for (s2 = s; (s2 > SvPV(linestr,na)+2 &&
2047 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
2048 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
2049 croak("Not a perl script");
2050 while (*s == ' ' || *s == '\t') s++;
2052 * #! arg must be what we saw above. They can invoke it by
2053 * mentioning suidperl explicitly, but they may not add any strange
2054 * arguments beyond what #! says if they do invoke suidperl that way.
2056 len = strlen(validarg);
2057 if (strEQ(validarg," PHOOEY ") ||
2058 strnNE(s,validarg,len) || !isSPACE(s[len]))
2059 croak("Args must match #! line");
2062 if (euid != uid && (statbuf.st_mode & S_ISUID) &&
2063 euid == statbuf.st_uid)
2065 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2066 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2067 #endif /* IAMSUID */
2069 if (euid) { /* oops, we're not the setuid root perl */
2070 (void)PerlIO_close(rsfp);
2073 execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
2075 croak("Can't do setuid\n");
2078 if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid) {
2080 (void)setegid(statbuf.st_gid);
2083 (void)setregid((Gid_t)-1,statbuf.st_gid);
2085 #ifdef HAS_SETRESGID
2086 (void)setresgid((Gid_t)-1,statbuf.st_gid,(Gid_t)-1);
2088 setgid(statbuf.st_gid);
2092 if (getegid() != statbuf.st_gid)
2093 croak("Can't do setegid!\n");
2095 if (statbuf.st_mode & S_ISUID) {
2096 if (statbuf.st_uid != euid)
2098 (void)seteuid(statbuf.st_uid); /* all that for this */
2101 (void)setreuid((Uid_t)-1,statbuf.st_uid);
2103 #ifdef HAS_SETRESUID
2104 (void)setresuid((Uid_t)-1,statbuf.st_uid,(Uid_t)-1);
2106 setuid(statbuf.st_uid);
2110 if (geteuid() != statbuf.st_uid)
2111 croak("Can't do seteuid!\n");
2113 else if (uid) { /* oops, mustn't run as root */
2115 (void)seteuid((Uid_t)uid);
2118 (void)setreuid((Uid_t)-1,(Uid_t)uid);
2120 #ifdef HAS_SETRESUID
2121 (void)setresuid((Uid_t)-1,(Uid_t)uid,(Uid_t)-1);
2127 if (geteuid() != uid)
2128 croak("Can't do seteuid!\n");
2131 if (!cando(S_IXUSR,TRUE,&statbuf))
2132 croak("Permission denied\n"); /* they can't do this */
2135 else if (preprocess)
2136 croak("-P not allowed for setuid/setgid script\n");
2137 else if (fdscript >= 0)
2138 croak("fd script not allowed in suidperl\n");
2140 croak("Script is not setuid/setgid in suidperl\n");
2142 /* We absolutely must clear out any saved ids here, so we */
2143 /* exec the real perl, substituting fd script for scriptname. */
2144 /* (We pass script name as "subdir" of fd, which perl will grok.) */
2145 PerlIO_rewind(rsfp);
2146 lseek(PerlIO_fileno(rsfp),(Off_t)0,0); /* just in case rewind didn't */
2147 for (which = 1; origargv[which] && origargv[which] != scriptname; which++) ;
2148 if (!origargv[which])
2149 croak("Permission denied");
2150 origargv[which] = savepv(form("/dev/fd/%d/%s",
2151 PerlIO_fileno(rsfp), origargv[which]));
2152 #if defined(HAS_FCNTL) && defined(F_SETFD)
2153 fcntl(PerlIO_fileno(rsfp),F_SETFD,0); /* ensure no close-on-exec */
2155 execv(form("%s/perl%s", BIN_EXP, patchlevel), origargv); /* try again */
2156 croak("Can't do setuid\n");
2157 #endif /* IAMSUID */
2159 if (euid != uid || egid != gid) { /* (suidperl doesn't exist, in fact) */
2160 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
2161 Fstat(PerlIO_fileno(rsfp),&statbuf); /* may be either wrapped or real suid */
2162 if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
2164 (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
2167 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2168 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2169 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
2170 /* not set-id, must be wrapped */
2178 register char *s, *s2;
2180 /* skip forward in input to the real script? */
2184 if ((s = sv_gets(linestr, rsfp, 0)) == Nullch)
2185 croak("No Perl script found in input\n");
2186 if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
2187 PerlIO_ungetc(rsfp, '\n'); /* to keep line count right */
2189 while (*s && !(isSPACE (*s) || *s == '#')) s++;
2191 while (*s == ' ' || *s == '\t') s++;
2193 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
2194 if (strnEQ(s2-4,"perl",4))
2196 while (s = moreswitches(s)) ;
2198 if (cddir && chdir(cddir) < 0)
2199 croak("Can't chdir to %s",cddir);
2207 uid = (int)getuid();
2208 euid = (int)geteuid();
2209 gid = (int)getgid();
2210 egid = (int)getegid();
2215 tainting |= (uid && (euid != uid || egid != gid));
2223 croak("No %s allowed while running setuid", s);
2225 croak("No %s allowed while running setgid", s);
2231 curstash = debstash;
2232 dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
2234 DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
2235 DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
2236 DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
2237 DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
2238 sv_setiv(DBsingle, 0);
2239 DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
2240 sv_setiv(DBtrace, 0);
2241 DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
2242 sv_setiv(DBsignal, 0);
2243 curstash = defstash;
2250 mainstack = curstack; /* remember in case we switch stacks */
2251 AvREAL_off(curstack); /* not a real array */
2252 av_extend(curstack,127);
2254 stack_base = AvARRAY(curstack);
2255 stack_sp = stack_base;
2256 stack_max = stack_base + 127;
2258 cxstack_max = 8192 / sizeof(CONTEXT) - 2; /* Use most of 8K. */
2259 New(50,cxstack,cxstack_max + 1,CONTEXT);
2262 New(50,tmps_stack,128,SV*);
2267 New(51,debname,128,char);
2268 New(52,debdelim,128,char);
2272 * The following stacks almost certainly should be per-interpreter,
2273 * but for now they're not. XXX
2277 markstack_ptr = markstack;
2279 New(54,markstack,64,I32);
2280 markstack_ptr = markstack;
2281 markstack_max = markstack + 64;
2287 New(54,scopestack,32,I32);
2289 scopestack_max = 32;
2295 New(54,savestack,128,ANY);
2297 savestack_max = 128;
2303 New(54,retstack,16,OP*);
2313 Safefree(tmps_stack);
2320 static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
2328 subname = newSVpv("main",4);
2332 init_predump_symbols()
2337 sv_setpvn(GvSV(gv_fetchpv("\"", TRUE, SVt_PV)), " ", 1);
2339 stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
2340 GvMULTI_on(stdingv);
2341 IoIFP(GvIOp(stdingv)) = PerlIO_stdin();
2342 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
2344 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(stdingv));
2346 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
2348 IoOFP(GvIOp(tmpgv)) = IoIFP(GvIOp(tmpgv)) = PerlIO_stdout();
2350 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
2352 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(defoutgv));
2354 othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
2355 GvMULTI_on(othergv);
2356 IoOFP(GvIOp(othergv)) = IoIFP(GvIOp(othergv)) = PerlIO_stderr();
2357 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
2359 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(othergv));
2361 statname = NEWSV(66,0); /* last filename we did stat on */
2364 osname = savepv(OSNAME);
2368 init_postdump_symbols(argc,argv,env)
2370 register char **argv;
2371 register char **env;
2377 argc--,argv++; /* skip name of script */
2379 for (; argc > 0 && **argv == '-'; argc--,argv++) {
2382 if (argv[0][1] == '-') {
2386 if (s = strchr(argv[0], '=')) {
2388 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
2391 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
2394 toptarget = NEWSV(0,0);
2395 sv_upgrade(toptarget, SVt_PVFM);
2396 sv_setpvn(toptarget, "", 0);
2397 bodytarget = NEWSV(0,0);
2398 sv_upgrade(bodytarget, SVt_PVFM);
2399 sv_setpvn(bodytarget, "", 0);
2400 formtarget = bodytarget;
2403 if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
2404 sv_setpv(GvSV(tmpgv),origfilename);
2405 magicname("0", "0", 1);
2407 if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
2408 sv_setpv(GvSV(tmpgv),origargv[0]);
2409 if (argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
2411 (void)gv_AVadd(argvgv);
2412 av_clear(GvAVn(argvgv));
2413 for (; argc > 0; argc--,argv++) {
2414 av_push(GvAVn(argvgv),newSVpv(argv[0],0));
2417 if (envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
2421 hv_magic(hv, envgv, 'E');
2422 #ifndef VMS /* VMS doesn't have environ array */
2423 /* Note that if the supplied env parameter is actually a copy
2424 of the global environ then it may now point to free'd memory
2425 if the environment has been modified since. To avoid this
2426 problem we treat env==NULL as meaning 'use the default'
2431 environ[0] = Nullch;
2432 for (; *env; env++) {
2433 if (!(s = strchr(*env,'=')))
2439 sv = newSVpv(s--,0);
2440 (void)hv_store(hv, *env, s - *env, sv, 0);
2442 #if defined(__BORLANDC__) && defined(USE_WIN32_RTL_ENV)
2443 /* Sins of the RTL. See note in my_setenv(). */
2444 (void)putenv(savepv(*env));
2448 #ifdef DYNAMIC_ENV_FETCH
2449 HvNAME(hv) = savepv(ENV_HV_NAME);
2453 if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
2454 sv_setiv(GvSV(tmpgv), (IV)getpid());
2463 s = getenv("PERL5LIB");
2467 incpush(getenv("PERLLIB"), FALSE);
2469 /* Treat PERL5?LIB as a possible search list logical name -- the
2470 * "natural" VMS idiom for a Unix path string. We allow each
2471 * element to be a set of |-separated directories for compatibility.
2475 if (my_trnlnm("PERL5LIB",buf,0))
2476 do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
2478 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE);
2482 /* Use the ~-expanded versions of APPLLIB (undocumented),
2483 ARCHLIB PRIVLIB SITEARCH SITELIB and OLDARCHLIB
2486 incpush(APPLLIB_EXP, FALSE);
2490 incpush(ARCHLIB_EXP, FALSE);
2493 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
2495 incpush(PRIVLIB_EXP, FALSE);
2498 incpush(SITEARCH_EXP, FALSE);
2501 incpush(SITELIB_EXP, FALSE);
2503 #ifdef OLDARCHLIB_EXP /* 5.00[01] compatibility */
2504 incpush(OLDARCHLIB_EXP, FALSE);
2508 incpush(".", FALSE);
2512 # define PERLLIB_SEP ';'
2515 # define PERLLIB_SEP '|'
2517 # define PERLLIB_SEP ':'
2520 #ifndef PERLLIB_MANGLE
2521 # define PERLLIB_MANGLE(s,n) (s)
2525 incpush(p, addsubdirs)
2529 SV *subdir = Nullsv;
2530 static char *archpat_auto;
2537 if (!archpat_auto) {
2538 STRLEN len = (sizeof(ARCHNAME) + strlen(patchlevel)
2539 + sizeof("//auto"));
2540 New(55, archpat_auto, len, char);
2541 sprintf(archpat_auto, "/%s/%s/auto", ARCHNAME, patchlevel);
2543 for (len = sizeof(ARCHNAME) + 2;
2544 archpat_auto[len] != '\0' && archpat_auto[len] != '/'; len++)
2545 if (archpat_auto[len] == '.') archpat_auto[len] = '_';
2550 /* Break at all separators */
2552 SV *libdir = newSV(0);
2555 /* skip any consecutive separators */
2556 while ( *p == PERLLIB_SEP ) {
2557 /* Uncomment the next line for PATH semantics */
2558 /* av_push(GvAVn(incgv), newSVpv(".", 1)); */
2562 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
2563 sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
2568 sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
2569 p = Nullch; /* break out */
2573 * BEFORE pushing libdir onto @INC we may first push version- and
2574 * archname-specific sub-directories.
2577 struct stat tmpstatbuf;
2582 if ((unix = tounixspec_ts(SvPV(libdir,na),Nullch)) != Nullch) {
2584 while (unix[len-1] == '/') len--; /* Cosmetic */
2585 sv_usepvn(libdir,unix,len);
2588 PerlIO_printf(PerlIO_stderr(),
2589 "Failed to unixify @INC element \"%s\"\n",
2592 /* .../archname/version if -d .../archname/version/auto */
2593 sv_setsv(subdir, libdir);
2594 sv_catpv(subdir, archpat_auto);
2595 if (Stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2596 S_ISDIR(tmpstatbuf.st_mode))
2597 av_push(GvAVn(incgv),
2598 newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2600 /* .../archname if -d .../archname/auto */
2601 sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME),
2602 strlen(patchlevel) + 1, "", 0);
2603 if (Stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2604 S_ISDIR(tmpstatbuf.st_mode))
2605 av_push(GvAVn(incgv),
2606 newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2609 /* finally push this lib directory on the end of @INC */
2610 av_push(GvAVn(incgv), libdir);
2613 SvREFCNT_dec(subdir);
2617 call_list(oldscope, list)
2621 line_t oldline = curcop->cop_line;
2626 while (AvFILL(list) >= 0) {
2627 CV *cv = (CV*)av_shift(list);
2634 SV* atsv = GvSV(errgv);
2636 perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
2637 (void)SvPV(atsv, len);
2640 curcop = &compiling;
2641 curcop->cop_line = oldline;
2642 if (list == beginav)
2643 sv_catpv(atsv, "BEGIN failed--compilation aborted");
2645 sv_catpv(atsv, "END failed--cleanup aborted");
2646 while (scopestack_ix > oldscope)
2648 croak("%s", SvPVX(atsv));
2656 /* my_exit() was called */
2657 while (scopestack_ix > oldscope)
2660 curstash = defstash;
2662 call_list(oldscope, endav);
2664 curcop = &compiling;
2665 curcop->cop_line = oldline;
2667 if (list == beginav)
2668 croak("BEGIN failed--compilation aborted");
2670 croak("END failed--cleanup aborted");
2676 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
2681 curcop = &compiling;
2682 curcop->cop_line = oldline;
2701 STATUS_NATIVE_SET(status);
2711 if (vaxc$errno & 1) {
2712 if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
2713 STATUS_NATIVE_SET(44);
2716 if (!vaxc$errno && errno) /* unlikely */
2717 STATUS_NATIVE_SET(44);
2719 STATUS_NATIVE_SET(vaxc$errno);
2723 STATUS_POSIX_SET(errno);
2724 else if (STATUS_POSIX == 0)
2725 STATUS_POSIX_SET(255);
2733 register CONTEXT *cx;
2742 (void)UNLINK(e_tmpname);
2743 Safefree(e_tmpname);
2747 if (cxstack_ix >= 0) {