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)
532 call_list(oldscope, endav);
534 return STATUS_NATIVE_EXPORT;
537 PerlIO_printf(PerlIO_stderr(), "panic: top_env\n");
541 sv_setpvn(linestr,"",0);
542 sv = newSVpv("",0); /* first used for -I flags */
546 for (argc--,argv++; argc > 0; argc--,argv++) {
547 if (argv[0][0] != '-' || !argv[0][1])
551 validarg = " PHOOEY ";
576 if (s = moreswitches(s))
586 if (euid != uid || egid != gid)
587 croak("No -e allowed in setuid scripts");
589 e_tmpname = savepv(TMPPATH);
590 (void)mktemp(e_tmpname);
592 croak("Can't mktemp()");
593 e_fp = PerlIO_open(e_tmpname,"w");
595 croak("Cannot open temporary file");
600 PerlIO_puts(e_fp,argv[1]);
604 croak("No code specified for -e");
605 (void)PerlIO_putc(e_fp,'\n');
616 incpush(argv[1], TRUE);
617 sv_catpv(sv,argv[1]);
634 preambleav = newAV();
635 av_push(preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
637 Sv = newSVpv("print myconfig();",0);
639 sv_catpv(Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
641 sv_catpv(Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
643 #if defined(DEBUGGING) || defined(NO_EMBED) || defined(MULTIPLICITY)
644 sv_catpv(Sv,"\" Compile-time options:");
646 sv_catpv(Sv," DEBUGGING");
649 sv_catpv(Sv," NO_EMBED");
652 sv_catpv(Sv," MULTIPLICITY");
654 sv_catpv(Sv,"\\n\",");
656 #if defined(LOCAL_PATCH_COUNT)
657 if (LOCAL_PATCH_COUNT > 0) {
659 sv_catpv(Sv,"\" Locally applied patches:\\n\",");
660 for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
662 sv_catpvf(Sv,"\" \\t%s\\n\",",localpatches[i]);
666 sv_catpvf(Sv,"\" Built under %s\\n\"",OSNAME);
669 sv_catpvf(Sv,",\" Compiled at %s %s\\n\"",__DATE__,__TIME__);
671 sv_catpvf(Sv,",\" Compiled on %s\\n\"",__DATE__);
676 @env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; \
677 print \" \\%ENV:\\n @env\\n\" if @env; \
678 print \" \\@INC:\\n @INC\\n\";");
681 Sv = newSVpv("config_vars(qw(",0);
686 av_push(preambleav, Sv);
687 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
701 croak("Unrecognized switch: -%s",s);
706 if (!tainting && (s = getenv("PERL5OPT"))) {
717 if (!strchr("DIMUdmw", *s))
718 croak("Illegal switch in PERL5OPT: -%c", *s);
724 scriptname = argv[0];
726 if (PerlIO_flush(e_fp) || PerlIO_error(e_fp) || PerlIO_close(e_fp)) {
728 warn("Did you forget to compile with -DMULTIPLICITY?");
730 croak("Can't write to temp file for -e: %s", Strerror(errno));
734 scriptname = e_tmpname;
736 else if (scriptname == Nullch) {
738 if ( isatty(PerlIO_fileno(PerlIO_stdin())) )
746 open_script(scriptname,dosearch,sv);
748 validate_suid(validarg, scriptname);
753 main_cv = compcv = (CV*)NEWSV(1104,0);
754 sv_upgrade((SV *)compcv, SVt_PVCV);
758 av_push(comppad, Nullsv);
759 curpad = AvARRAY(comppad);
760 comppad_name = newAV();
761 comppad_name_fill = 0;
762 min_intro_pending = 0;
765 comppadlist = newAV();
766 AvREAL_off(comppadlist);
767 av_store(comppadlist, 0, (SV*)comppad_name);
768 av_store(comppadlist, 1, (SV*)comppad);
769 CvPADLIST(compcv) = comppadlist;
771 boot_core_UNIVERSAL();
773 (*xsinit)(); /* in case linked C routines want magical variables */
778 init_predump_symbols();
780 init_postdump_symbols(argc,argv,env);
784 /* now parse the script */
787 if (yyparse() || error_count) {
789 croak("%s had compilation errors.\n", origfilename);
791 croak("Execution of %s aborted due to compilation errors.\n",
795 curcop->cop_line = 0;
799 (void)UNLINK(e_tmpname);
804 /* now that script is parsed, we can modify record separator */
806 rs = SvREFCNT_inc(nrs);
807 sv_setsv(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), rs);
818 #ifdef DEBUGGING_MSTATS
819 if ((s=getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
820 dump_mstats("after compilation:");
831 PerlInterpreter *sv_interp;
837 if (!(curinterp = sv_interp))
840 oldscope = scopestack_ix;
845 cxstack_ix = -1; /* start context stack again */
848 /* my_exit() was called */
849 while (scopestack_ix > oldscope)
853 call_list(oldscope, endav);
855 #ifdef DEBUGGING_MSTATS
856 if (getenv("PERL_DEBUG_MSTATS"))
857 dump_mstats("after execution: ");
860 return STATUS_NATIVE_EXPORT;
863 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
868 if (curstack != mainstack) {
870 SWITCHSTACK(curstack, mainstack);
875 DEBUG_r(PerlIO_printf(PerlIO_stderr(), "%s $` $& $' support.\n",
876 sawampersand ? "Enabling" : "Omitting"));
880 DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
883 PerlIO_printf(PerlIO_stderr(), "%s syntax OK\n", origfilename);
886 if (perldb && DBsingle)
887 sv_setiv(DBsingle, 1);
897 else if (main_start) {
898 CvDEPTH(main_cv) = 1;
909 perl_get_sv(name, create)
913 GV* gv = gv_fetchpv(name, create, SVt_PV);
920 perl_get_av(name, create)
924 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
933 perl_get_hv(name, create)
937 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
946 perl_get_cv(name, create)
950 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
951 if (create && !GvCVu(gv))
952 return newSUB(start_subparse(FALSE, 0),
953 newSVOP(OP_CONST, 0, newSVpv(name,0)),
961 /* Be sure to refetch the stack pointer after calling these routines. */
964 perl_call_argv(subname, flags, argv)
966 I32 flags; /* See G_* flags in cop.h */
967 register char **argv; /* null terminated arg list */
974 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
979 return perl_call_pv(subname, flags);
983 perl_call_pv(subname, flags)
984 char *subname; /* name of the subroutine */
985 I32 flags; /* See G_* flags in cop.h */
987 return perl_call_sv((SV*)perl_get_cv(subname, TRUE), flags);
991 perl_call_method(methname, flags)
992 char *methname; /* name of the subroutine */
993 I32 flags; /* See G_* flags in cop.h */
999 XPUSHs(sv_2mortal(newSVpv(methname,0)));
1002 return perl_call_sv(*stack_sp--, flags);
1005 /* May be called with any of a CV, a GV, or an SV containing the name. */
1007 perl_call_sv(sv, flags)
1009 I32 flags; /* See G_* flags in cop.h */
1011 LOGOP myop; /* fake syntax tree node */
1017 bool oldcatch = CATCH_GET;
1021 if (flags & G_DISCARD) {
1026 Zero(&myop, 1, LOGOP);
1027 myop.op_next = Nullop;
1028 if (!(flags & G_NOARGS))
1029 myop.op_flags |= OPf_STACKED;
1030 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1031 (flags & G_ARRAY) ? OPf_WANT_LIST :
1036 EXTEND(stack_sp, 1);
1039 oldscope = scopestack_ix;
1041 if (perldb && curstash != debstash
1042 /* Handle first BEGIN of -d. */
1043 && (DBcv || (DBcv = GvCV(DBsub)))
1044 /* Try harder, since this may have been a sighandler, thus
1045 * curstash may be meaningless. */
1046 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != debstash))
1047 op->op_private |= OPpENTERSUB_DB;
1049 if (flags & G_EVAL) {
1050 cLOGOP->op_other = op;
1052 /* we're trying to emulate pp_entertry() here */
1054 register CONTEXT *cx;
1055 I32 gimme = GIMME_V;
1060 push_return(op->op_next);
1061 PUSHBLOCK(cx, CXt_EVAL, stack_sp);
1063 eval_root = op; /* Only needed so that goto works right. */
1066 if (flags & G_KEEPERR)
1069 sv_setpv(GvSV(errgv),"");
1081 /* my_exit() was called */
1082 curstash = defstash;
1086 croak("Callback called exit");
1095 stack_sp = stack_base + oldmark;
1096 if (flags & G_ARRAY)
1100 *++stack_sp = &sv_undef;
1108 if (op == (OP*)&myop)
1112 retval = stack_sp - (stack_base + oldmark);
1113 if ((flags & G_EVAL) && !(flags & G_KEEPERR))
1114 sv_setpv(GvSV(errgv),"");
1117 if (flags & G_EVAL) {
1118 if (scopestack_ix > oldscope) {
1122 register CONTEXT *cx;
1134 CATCH_SET(oldcatch);
1136 if (flags & G_DISCARD) {
1137 stack_sp = stack_base + oldmark;
1145 /* Eval a string. The G_EVAL flag is always assumed. */
1148 perl_eval_sv(sv, flags)
1150 I32 flags; /* See G_* flags in cop.h */
1152 UNOP myop; /* fake syntax tree node */
1154 I32 oldmark = sp - stack_base;
1160 if (flags & G_DISCARD) {
1168 EXTEND(stack_sp, 1);
1170 oldscope = scopestack_ix;
1172 if (!(flags & G_NOARGS))
1173 myop.op_flags = OPf_STACKED;
1174 myop.op_next = Nullop;
1175 myop.op_type = OP_ENTEREVAL;
1176 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1177 (flags & G_ARRAY) ? OPf_WANT_LIST :
1179 if (flags & G_KEEPERR)
1180 myop.op_flags |= OPf_SPECIAL;
1190 /* my_exit() was called */
1191 curstash = defstash;
1195 croak("Callback called exit");
1204 stack_sp = stack_base + oldmark;
1205 if (flags & G_ARRAY)
1209 *++stack_sp = &sv_undef;
1214 if (op == (OP*)&myop)
1215 op = pp_entereval();
1218 retval = stack_sp - (stack_base + oldmark);
1219 if (!(flags & G_KEEPERR))
1220 sv_setpv(GvSV(errgv),"");
1224 if (flags & G_DISCARD) {
1225 stack_sp = stack_base + oldmark;
1234 perl_eval_pv(p, croak_on_error)
1239 SV* sv = newSVpv(p, 0);
1242 perl_eval_sv(sv, G_SCALAR);
1249 if (croak_on_error && SvTRUE(GvSV(errgv)))
1250 croak(SvPVx(GvSV(errgv), na));
1255 /* Require a module. */
1261 SV* sv = sv_newmortal();
1262 sv_setpv(sv, "require '");
1265 perl_eval_sv(sv, G_DISCARD);
1269 magicname(sym,name,namlen)
1276 if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
1277 sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
1281 usage(name) /* XXX move this out into a module ? */
1284 /* This message really ought to be max 23 lines.
1285 * Removed -h because the user already knows that opton. Others? */
1286 printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
1287 printf("\n -0[octal] specify record separator (\\0, if no argument)");
1288 printf("\n -a autosplit mode with -n or -p (splits $_ into @F)");
1289 printf("\n -c check syntax only (runs BEGIN and END blocks)");
1290 printf("\n -d[:debugger] run scripts under debugger");
1291 printf("\n -D[number/list] set debugging flags (argument is a bit mask or flags)");
1292 printf("\n -e 'command' one line of script. Several -e's allowed. Omit [programfile].");
1293 printf("\n -F/pattern/ split() pattern for autosplit (-a). The //'s are optional.");
1294 printf("\n -i[extension] edit <> files in place (make backup if extension supplied)");
1295 printf("\n -Idirectory specify @INC/#include directory (may be used more then once)");
1296 printf("\n -l[octal] enable line ending processing, specifies line teminator");
1297 printf("\n -[mM][-]module.. executes `use/no module...' before executing your script.");
1298 printf("\n -n assume 'while (<>) { ... }' loop arround your script");
1299 printf("\n -p assume loop like -n but print line also like sed");
1300 printf("\n -P run script through C preprocessor before compilation");
1301 printf("\n -s enable some switch parsing for switches after script name");
1302 printf("\n -S look for the script using PATH environment variable");
1303 printf("\n -T turn on tainting checks");
1304 printf("\n -u dump core after parsing script");
1305 printf("\n -U allow unsafe operations");
1306 printf("\n -v print version number and patchlevel of perl");
1307 printf("\n -V[:variable] print perl configuration information");
1308 printf("\n -w TURN WARNINGS ON FOR COMPILATION OF YOUR SCRIPT.");
1309 printf("\n -x[directory] strip off text before #!perl line and perhaps cd to directory\n");
1312 /* This routine handles any switches that can be given during run */
1323 rschar = scan_oct(s, 4, &numlen);
1325 if (rschar & ~((U8)~0))
1327 else if (!rschar && numlen >= 2)
1328 nrs = newSVpv("", 0);
1331 nrs = newSVpv(&ch, 1);
1336 splitstr = savepv(s + 1);
1350 if (*s == ':' || *s == '=') {
1351 my_setenv("PERL5DB", form("use Devel::%s;", ++s));
1362 if (isALPHA(s[1])) {
1363 static char debopts[] = "psltocPmfrxuLHXD";
1366 for (s++; *s && (d = strchr(debopts,*s)); s++)
1367 debug |= 1 << (d - debopts);
1371 for (s++; isDIGIT(*s); s++) ;
1373 debug |= 0x80000000;
1375 warn("Recompile perl with -DDEBUGGING to use -D switch\n");
1376 for (s++; isALNUM(*s); s++) ;
1386 inplace = savepv(s+1);
1388 for (s = inplace; *s && !isSPACE(*s); s++) ;
1395 for (e = s; *e && !isSPACE(*e); e++) ;
1396 p = savepvn(s, e-s);
1403 croak("No space allowed after -I");
1413 *ors = scan_oct(s, 3 + (*s == '0'), &numlen);
1422 ors = SvPV(nrs, orslen);
1423 ors = savepvn(ors, orslen);
1427 forbid_setid("-M"); /* XXX ? */
1430 forbid_setid("-m"); /* XXX ? */
1434 /* -M-foo == 'no foo' */
1435 if (*s == '-') { use = "no "; ++s; }
1436 Sv = newSVpv(use,0);
1438 /* We allow -M'Module qw(Foo Bar)' */
1439 while(isALNUM(*s) || *s==':') ++s;
1441 sv_catpv(Sv, start);
1442 if (*(start-1) == 'm') {
1444 croak("Can't use '%c' after -mname", *s);
1445 sv_catpv( Sv, " ()");
1448 sv_catpvn(Sv, start, s-start);
1449 sv_catpv(Sv, " split(/,/,q{");
1454 if (preambleav == NULL)
1455 preambleav = newAV();
1456 av_push(preambleav, Sv);
1459 croak("No space allowed after -%c", *(s-1));
1476 croak("Too late for \"-T\" option");
1488 #if defined(SUBVERSION) && SUBVERSION > 0
1489 printf("\nThis is perl, version 5.%03d_%02d", PATCHLEVEL, SUBVERSION);
1491 printf("\nThis is perl, version %s",patchlevel);
1494 printf("\n\nCopyright 1987-1997, Larry Wall\n");
1496 printf("\n\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
1499 printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n");
1502 printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
1503 "Version 5 port Copyright (c) 1994-1997, Andreas Kaiser, Ilya Zakharevich\n");
1506 printf("atariST series port, ++jrb bammi@cadence.com\n");
1509 Perl may be copied only under the terms of either the Artistic License or the\n\
1510 GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n");
1518 if (s[1] == '-') /* Additional switches on #! line. */
1526 #ifdef ALTERNATE_SHEBANG
1527 case 'S': /* OS/2 needs -S on "extproc" line. */
1535 croak("Can't emulate -%.1s on #! line",s);
1540 /* compliments of Tom Christiansen */
1542 /* unexec() can be found in the Gnu emacs distribution */
1553 prog = newSVpv(BIN_EXP);
1554 sv_catpv(prog, "/perl");
1555 file = newSVpv(origfilename);
1556 sv_catpv(file, ".perldump");
1558 status = unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
1560 PerlIO_printf(PerlIO_stderr(), "unexec of %s into %s failed!\n",
1561 SvPVX(prog), SvPVX(file));
1565 # include <lib$routines.h>
1566 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
1568 ABORT(); /* for use with undump */
1578 /* Note that strtab is a rather special HV. Assumptions are made
1579 about not iterating on it, and not adding tie magic to it.
1580 It is properly deallocated in perl_destruct() */
1582 HvSHAREKEYS_off(strtab); /* mandatory */
1583 Newz(506,((XPVHV*)SvANY(strtab))->xhv_array,
1584 sizeof(HE*) * (((XPVHV*)SvANY(strtab))->xhv_max + 1), char);
1586 curstash = defstash = newHV();
1587 curstname = newSVpv("main",4);
1588 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
1589 SvREFCNT_dec(GvHV(gv));
1590 GvHV(gv) = (HV*)SvREFCNT_inc(defstash);
1592 HvNAME(defstash) = savepv("main");
1593 incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
1595 defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
1596 errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
1598 sv_setpvn(GvSV(errgv), "", 0);
1599 curstash = defstash;
1600 compiling.cop_stash = defstash;
1601 debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
1602 /* We must init $/ before switches are processed. */
1603 sv_setpvn(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), "\n", 1);
1606 #ifdef CAN_PROTOTYPE
1608 open_script(char *scriptname, bool dosearch, SV *sv)
1611 open_script(scriptname,dosearch,sv)
1617 char *xfound = Nullch;
1618 char *xfailed = Nullch;
1622 #if defined(DOSISH) && !defined(OS2) && !defined(atarist)
1623 # define SEARCH_EXTS ".bat", ".cmd", NULL
1624 # define MAX_EXT_LEN 4
1627 # define SEARCH_EXTS ".pl", ".com", NULL
1628 # define MAX_EXT_LEN 4
1630 /* additional extensions to try in each dir if scriptname not found */
1632 char *ext[] = { SEARCH_EXTS };
1633 int extidx = (strchr(scriptname,'.')) ? -1 : 0; /* has ext already */
1635 # define MAX_EXT_LEN 0
1640 int hasdir, idx = 0, deftypes = 1;
1642 hasdir = (strpbrk(scriptname,":[</") != Nullch) ;
1643 /* The first time through, just add SEARCH_EXTS to whatever we
1644 * already have, so we can check for default file types. */
1646 (!hasdir && my_trnlnm("DCL$PATH",tokenbuf,idx++)) )
1652 if ((strlen(tokenbuf) + strlen(scriptname)
1653 + MAX_EXT_LEN) >= sizeof tokenbuf)
1654 continue; /* don't search dir with too-long name */
1655 strcat(tokenbuf, scriptname);
1657 if (dosearch && !strchr(scriptname, '/') && (s = getenv("PATH"))) {
1658 bufend = s + strlen(s);
1659 while (s < bufend) {
1661 s = delimcpy(tokenbuf, tokenbuf + sizeof tokenbuf, s, bufend,
1669 for (len = 0; *s && *s != ',' && *s != ';'; len++, s++) {
1670 if (len < sizeof tokenbuf)
1673 if (len < sizeof tokenbuf)
1674 tokenbuf[len] = '\0';
1675 #endif /* atarist */
1678 if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tokenbuf)
1679 continue; /* don't search dir with too-long name */
1681 #if defined(atarist) && !defined(DOSISH)
1682 && tokenbuf[len - 1] != '/'
1684 #if defined(atarist) || defined(DOSISH)
1685 && tokenbuf[len - 1] != '\\'
1688 tokenbuf[len++] = '/';
1689 (void)strcpy(tokenbuf + len, scriptname);
1693 len = strlen(tokenbuf);
1694 if (extidx > 0) /* reset after previous loop */
1698 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tokenbuf));
1699 retval = Stat(tokenbuf,&statbuf);
1701 } while ( retval < 0 /* not there */
1702 && extidx>=0 && ext[extidx] /* try an extension? */
1703 && strcpy(tokenbuf+len, ext[extidx++])
1708 if (S_ISREG(statbuf.st_mode)
1709 && cando(S_IRUSR,TRUE,&statbuf)
1711 && cando(S_IXUSR,TRUE,&statbuf)
1714 xfound = tokenbuf; /* bingo! */
1718 xfailed = savepv(tokenbuf);
1721 croak("Can't execute %s", xfailed ? xfailed : scriptname );
1724 scriptname = xfound;
1727 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
1728 char *s = scriptname + 8;
1737 origfilename = savepv(e_tmpname ? "-e" : scriptname);
1738 curcop->cop_filegv = gv_fetchfile(origfilename);
1739 if (strEQ(origfilename,"-"))
1741 if (fdscript >= 0) {
1742 rsfp = PerlIO_fdopen(fdscript,"r");
1743 #if defined(HAS_FCNTL) && defined(F_SETFD)
1745 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
1748 else if (preprocess) {
1749 char *cpp_cfg = CPPSTDIN;
1750 SV *cpp = NEWSV(0,0);
1751 SV *cmd = NEWSV(0,0);
1753 if (strEQ(cpp_cfg, "cppstdin"))
1754 sv_catpvf(cpp, "%s/", BIN_EXP);
1755 sv_catpv(cpp, cpp_cfg);
1758 sv_catpv(sv,PRIVLIB_EXP);
1762 sed %s -e \"/^[^#]/b\" \
1763 -e \"/^#[ ]*include[ ]/b\" \
1764 -e \"/^#[ ]*define[ ]/b\" \
1765 -e \"/^#[ ]*if[ ]/b\" \
1766 -e \"/^#[ ]*ifdef[ ]/b\" \
1767 -e \"/^#[ ]*ifndef[ ]/b\" \
1768 -e \"/^#[ ]*else/b\" \
1769 -e \"/^#[ ]*elif[ ]/b\" \
1770 -e \"/^#[ ]*undef[ ]/b\" \
1771 -e \"/^#[ ]*endif/b\" \
1774 (doextract ? "-e \"1,/^#/d\n\"" : ""),
1777 %s %s -e '/^[^#]/b' \
1778 -e '/^#[ ]*include[ ]/b' \
1779 -e '/^#[ ]*define[ ]/b' \
1780 -e '/^#[ ]*if[ ]/b' \
1781 -e '/^#[ ]*ifdef[ ]/b' \
1782 -e '/^#[ ]*ifndef[ ]/b' \
1783 -e '/^#[ ]*else/b' \
1784 -e '/^#[ ]*elif[ ]/b' \
1785 -e '/^#[ ]*undef[ ]/b' \
1786 -e '/^#[ ]*endif/b' \
1794 (doextract ? "-e '1,/^#/d\n'" : ""),
1796 scriptname, cpp, sv, CPPMINUS);
1798 #ifdef IAMSUID /* actually, this is caught earlier */
1799 if (euid != uid && !euid) { /* if running suidperl */
1801 (void)seteuid(uid); /* musn't stay setuid root */
1804 (void)setreuid((Uid_t)-1, uid);
1806 #ifdef HAS_SETRESUID
1807 (void)setresuid((Uid_t)-1, uid, (Uid_t)-1);
1813 if (geteuid() != uid)
1814 croak("Can't do seteuid!\n");
1816 #endif /* IAMSUID */
1817 rsfp = my_popen(SvPVX(cmd), "r");
1821 else if (!*scriptname) {
1822 forbid_setid("program input from stdin");
1823 rsfp = PerlIO_stdin();
1826 rsfp = PerlIO_open(scriptname,"r");
1827 #if defined(HAS_FCNTL) && defined(F_SETFD)
1829 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
1837 #ifndef IAMSUID /* in case script is not readable before setuid */
1838 if (euid && Stat(SvPVX(GvSV(curcop->cop_filegv)),&statbuf) >= 0 &&
1839 statbuf.st_mode & (S_ISUID|S_ISGID)) {
1841 execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
1842 croak("Can't do setuid\n");
1846 croak("Can't open perl script \"%s\": %s\n",
1847 SvPVX(GvSV(curcop->cop_filegv)), Strerror(errno));
1852 validate_suid(validarg, scriptname)
1858 /* do we need to emulate setuid on scripts? */
1860 /* This code is for those BSD systems that have setuid #! scripts disabled
1861 * in the kernel because of a security problem. Merely defining DOSUID
1862 * in perl will not fix that problem, but if you have disabled setuid
1863 * scripts in the kernel, this will attempt to emulate setuid and setgid
1864 * on scripts that have those now-otherwise-useless bits set. The setuid
1865 * root version must be called suidperl or sperlN.NNN. If regular perl
1866 * discovers that it has opened a setuid script, it calls suidperl with
1867 * the same argv that it had. If suidperl finds that the script it has
1868 * just opened is NOT setuid root, it sets the effective uid back to the
1869 * uid. We don't just make perl setuid root because that loses the
1870 * effective uid we had before invoking perl, if it was different from the
1873 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
1874 * be defined in suidperl only. suidperl must be setuid root. The
1875 * Configure script will set this up for you if you want it.
1881 if (Fstat(PerlIO_fileno(rsfp),&statbuf) < 0) /* normal stat is insecure */
1882 croak("Can't stat script \"%s\"",origfilename);
1883 if (fdscript < 0 && statbuf.st_mode & (S_ISUID|S_ISGID)) {
1887 #ifndef HAS_SETREUID
1888 /* On this access check to make sure the directories are readable,
1889 * there is actually a small window that the user could use to make
1890 * filename point to an accessible directory. So there is a faint
1891 * chance that someone could execute a setuid script down in a
1892 * non-accessible directory. I don't know what to do about that.
1893 * But I don't think it's too important. The manual lies when
1894 * it says access() is useful in setuid programs.
1896 if (access(SvPVX(GvSV(curcop->cop_filegv)),1)) /*double check*/
1897 croak("Permission denied");
1899 /* If we can swap euid and uid, then we can determine access rights
1900 * with a simple stat of the file, and then compare device and
1901 * inode to make sure we did stat() on the same file we opened.
1902 * Then we just have to make sure he or she can execute it.
1905 struct stat tmpstatbuf;
1909 setreuid(euid,uid) < 0
1912 setresuid(euid,uid,(Uid_t)-1) < 0
1915 || getuid() != euid || geteuid() != uid)
1916 croak("Can't swap uid and euid"); /* really paranoid */
1917 if (Stat(SvPVX(GvSV(curcop->cop_filegv)),&tmpstatbuf) < 0)
1918 croak("Permission denied"); /* testing full pathname here */
1919 if (tmpstatbuf.st_dev != statbuf.st_dev ||
1920 tmpstatbuf.st_ino != statbuf.st_ino) {
1921 (void)PerlIO_close(rsfp);
1922 if (rsfp = my_popen("/bin/mail root","w")) { /* heh, heh */
1924 "User %ld tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
1925 (Filename of set-id script was %s, uid %ld gid %ld.)\n\nSincerely,\nperl\n",
1926 (long)uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
1927 (long)statbuf.st_dev, (long)statbuf.st_ino,
1928 SvPVX(GvSV(curcop->cop_filegv)),
1929 (long)statbuf.st_uid, (long)statbuf.st_gid);
1930 (void)my_pclose(rsfp);
1932 croak("Permission denied\n");
1936 setreuid(uid,euid) < 0
1938 # if defined(HAS_SETRESUID)
1939 setresuid(uid,euid,(Uid_t)-1) < 0
1942 || getuid() != uid || geteuid() != euid)
1943 croak("Can't reswap uid and euid");
1944 if (!cando(S_IXUSR,FALSE,&statbuf)) /* can real uid exec? */
1945 croak("Permission denied\n");
1947 #endif /* HAS_SETREUID */
1948 #endif /* IAMSUID */
1950 if (!S_ISREG(statbuf.st_mode))
1951 croak("Permission denied");
1952 if (statbuf.st_mode & S_IWOTH)
1953 croak("Setuid/gid script is writable by world");
1954 doswitches = FALSE; /* -s is insecure in suid */
1956 if (sv_gets(linestr, rsfp, 0) == Nullch ||
1957 strnNE(SvPV(linestr,na),"#!",2) ) /* required even on Sys V */
1958 croak("No #! line");
1959 s = SvPV(linestr,na)+2;
1961 while (!isSPACE(*s)) s++;
1962 for (s2 = s; (s2 > SvPV(linestr,na)+2 &&
1963 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
1964 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
1965 croak("Not a perl script");
1966 while (*s == ' ' || *s == '\t') s++;
1968 * #! arg must be what we saw above. They can invoke it by
1969 * mentioning suidperl explicitly, but they may not add any strange
1970 * arguments beyond what #! says if they do invoke suidperl that way.
1972 len = strlen(validarg);
1973 if (strEQ(validarg," PHOOEY ") ||
1974 strnNE(s,validarg,len) || !isSPACE(s[len]))
1975 croak("Args must match #! line");
1978 if (euid != uid && (statbuf.st_mode & S_ISUID) &&
1979 euid == statbuf.st_uid)
1981 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
1982 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
1983 #endif /* IAMSUID */
1985 if (euid) { /* oops, we're not the setuid root perl */
1986 (void)PerlIO_close(rsfp);
1989 execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
1991 croak("Can't do setuid\n");
1994 if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid) {
1996 (void)setegid(statbuf.st_gid);
1999 (void)setregid((Gid_t)-1,statbuf.st_gid);
2001 #ifdef HAS_SETRESGID
2002 (void)setresgid((Gid_t)-1,statbuf.st_gid,(Gid_t)-1);
2004 setgid(statbuf.st_gid);
2008 if (getegid() != statbuf.st_gid)
2009 croak("Can't do setegid!\n");
2011 if (statbuf.st_mode & S_ISUID) {
2012 if (statbuf.st_uid != euid)
2014 (void)seteuid(statbuf.st_uid); /* all that for this */
2017 (void)setreuid((Uid_t)-1,statbuf.st_uid);
2019 #ifdef HAS_SETRESUID
2020 (void)setresuid((Uid_t)-1,statbuf.st_uid,(Uid_t)-1);
2022 setuid(statbuf.st_uid);
2026 if (geteuid() != statbuf.st_uid)
2027 croak("Can't do seteuid!\n");
2029 else if (uid) { /* oops, mustn't run as root */
2031 (void)seteuid((Uid_t)uid);
2034 (void)setreuid((Uid_t)-1,(Uid_t)uid);
2036 #ifdef HAS_SETRESUID
2037 (void)setresuid((Uid_t)-1,(Uid_t)uid,(Uid_t)-1);
2043 if (geteuid() != uid)
2044 croak("Can't do seteuid!\n");
2047 if (!cando(S_IXUSR,TRUE,&statbuf))
2048 croak("Permission denied\n"); /* they can't do this */
2051 else if (preprocess)
2052 croak("-P not allowed for setuid/setgid script\n");
2053 else if (fdscript >= 0)
2054 croak("fd script not allowed in suidperl\n");
2056 croak("Script is not setuid/setgid in suidperl\n");
2058 /* We absolutely must clear out any saved ids here, so we */
2059 /* exec the real perl, substituting fd script for scriptname. */
2060 /* (We pass script name as "subdir" of fd, which perl will grok.) */
2061 PerlIO_rewind(rsfp);
2062 lseek(PerlIO_fileno(rsfp),(Off_t)0,0); /* just in case rewind didn't */
2063 for (which = 1; origargv[which] && origargv[which] != scriptname; which++) ;
2064 if (!origargv[which])
2065 croak("Permission denied");
2066 origargv[which] = savepv(form("/dev/fd/%d/%s",
2067 PerlIO_fileno(rsfp), origargv[which]));
2068 #if defined(HAS_FCNTL) && defined(F_SETFD)
2069 fcntl(PerlIO_fileno(rsfp),F_SETFD,0); /* ensure no close-on-exec */
2071 execv(form("%s/perl%s", BIN_EXP, patchlevel), origargv); /* try again */
2072 croak("Can't do setuid\n");
2073 #endif /* IAMSUID */
2075 if (euid != uid || egid != gid) { /* (suidperl doesn't exist, in fact) */
2076 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
2077 Fstat(PerlIO_fileno(rsfp),&statbuf); /* may be either wrapped or real suid */
2078 if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
2080 (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
2083 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2084 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2085 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
2086 /* not set-id, must be wrapped */
2094 register char *s, *s2;
2096 /* skip forward in input to the real script? */
2100 if ((s = sv_gets(linestr, rsfp, 0)) == Nullch)
2101 croak("No Perl script found in input\n");
2102 if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
2103 PerlIO_ungetc(rsfp, '\n'); /* to keep line count right */
2105 while (*s && !(isSPACE (*s) || *s == '#')) s++;
2107 while (*s == ' ' || *s == '\t') s++;
2109 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
2110 if (strnEQ(s2-4,"perl",4))
2112 while (s = moreswitches(s)) ;
2114 if (cddir && chdir(cddir) < 0)
2115 croak("Can't chdir to %s",cddir);
2123 uid = (int)getuid();
2124 euid = (int)geteuid();
2125 gid = (int)getgid();
2126 egid = (int)getegid();
2131 tainting |= (uid && (euid != uid || egid != gid));
2139 croak("No %s allowed while running setuid", s);
2141 croak("No %s allowed while running setgid", s);
2147 curstash = debstash;
2148 dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
2150 DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
2151 DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
2152 DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
2153 DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
2154 sv_setiv(DBsingle, 0);
2155 DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
2156 sv_setiv(DBtrace, 0);
2157 DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
2158 sv_setiv(DBsignal, 0);
2159 curstash = defstash;
2166 mainstack = curstack; /* remember in case we switch stacks */
2167 AvREAL_off(curstack); /* not a real array */
2168 av_extend(curstack,127);
2170 stack_base = AvARRAY(curstack);
2171 stack_sp = stack_base;
2172 stack_max = stack_base + 127;
2174 cxstack_max = 8192 / sizeof(CONTEXT) - 2; /* Use most of 8K. */
2175 New(50,cxstack,cxstack_max + 1,CONTEXT);
2178 New(50,tmps_stack,128,SV*);
2183 New(51,debname,128,char);
2184 New(52,debdelim,128,char);
2188 * The following stacks almost certainly should be per-interpreter,
2189 * but for now they're not. XXX
2193 markstack_ptr = markstack;
2195 New(54,markstack,64,I32);
2196 markstack_ptr = markstack;
2197 markstack_max = markstack + 64;
2203 New(54,scopestack,32,I32);
2205 scopestack_max = 32;
2211 New(54,savestack,128,ANY);
2213 savestack_max = 128;
2219 New(54,retstack,16,OP*);
2229 Safefree(tmps_stack);
2236 static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
2244 subname = newSVpv("main",4);
2248 init_predump_symbols()
2253 sv_setpvn(GvSV(gv_fetchpv("\"", TRUE, SVt_PV)), " ", 1);
2255 stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
2256 GvMULTI_on(stdingv);
2257 IoIFP(GvIOp(stdingv)) = PerlIO_stdin();
2258 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
2260 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(stdingv));
2262 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
2264 IoOFP(GvIOp(tmpgv)) = IoIFP(GvIOp(tmpgv)) = PerlIO_stdout();
2266 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
2268 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(defoutgv));
2270 othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
2271 GvMULTI_on(othergv);
2272 IoOFP(GvIOp(othergv)) = IoIFP(GvIOp(othergv)) = PerlIO_stderr();
2273 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
2275 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(othergv));
2277 statname = NEWSV(66,0); /* last filename we did stat on */
2280 osname = savepv(OSNAME);
2284 init_postdump_symbols(argc,argv,env)
2286 register char **argv;
2287 register char **env;
2293 argc--,argv++; /* skip name of script */
2295 for (; argc > 0 && **argv == '-'; argc--,argv++) {
2298 if (argv[0][1] == '-') {
2302 if (s = strchr(argv[0], '=')) {
2304 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
2307 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
2310 toptarget = NEWSV(0,0);
2311 sv_upgrade(toptarget, SVt_PVFM);
2312 sv_setpvn(toptarget, "", 0);
2313 bodytarget = NEWSV(0,0);
2314 sv_upgrade(bodytarget, SVt_PVFM);
2315 sv_setpvn(bodytarget, "", 0);
2316 formtarget = bodytarget;
2319 if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
2320 sv_setpv(GvSV(tmpgv),origfilename);
2321 magicname("0", "0", 1);
2323 if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
2324 sv_setpv(GvSV(tmpgv),origargv[0]);
2325 if (argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
2327 (void)gv_AVadd(argvgv);
2328 av_clear(GvAVn(argvgv));
2329 for (; argc > 0; argc--,argv++) {
2330 av_push(GvAVn(argvgv),newSVpv(argv[0],0));
2333 if (envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
2337 hv_magic(hv, envgv, 'E');
2338 #ifndef VMS /* VMS doesn't have environ array */
2339 /* Note that if the supplied env parameter is actually a copy
2340 of the global environ then it may now point to free'd memory
2341 if the environment has been modified since. To avoid this
2342 problem we treat env==NULL as meaning 'use the default'
2347 environ[0] = Nullch;
2348 for (; *env; env++) {
2349 if (!(s = strchr(*env,'=')))
2355 sv = newSVpv(s--,0);
2356 (void)hv_store(hv, *env, s - *env, sv, 0);
2360 #ifdef DYNAMIC_ENV_FETCH
2361 HvNAME(hv) = savepv(ENV_HV_NAME);
2365 if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
2366 sv_setiv(GvSV(tmpgv), (IV)getpid());
2375 s = getenv("PERL5LIB");
2379 incpush(getenv("PERLLIB"), FALSE);
2381 /* Treat PERL5?LIB as a possible search list logical name -- the
2382 * "natural" VMS idiom for a Unix path string. We allow each
2383 * element to be a set of |-separated directories for compatibility.
2387 if (my_trnlnm("PERL5LIB",buf,0))
2388 do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
2390 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE);
2394 /* Use the ~-expanded versions of APPLIB (undocumented),
2395 ARCHLIB PRIVLIB SITEARCH SITELIB and OLDARCHLIB
2398 incpush(APPLLIB_EXP, FALSE);
2402 incpush(ARCHLIB_EXP, FALSE);
2405 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
2407 incpush(PRIVLIB_EXP, FALSE);
2410 incpush(SITEARCH_EXP, FALSE);
2413 incpush(SITELIB_EXP, FALSE);
2415 #ifdef OLDARCHLIB_EXP /* 5.00[01] compatibility */
2416 incpush(OLDARCHLIB_EXP, FALSE);
2420 incpush(".", FALSE);
2424 # define PERLLIB_SEP ';'
2427 # define PERLLIB_SEP '|'
2429 # define PERLLIB_SEP ':'
2432 #ifndef PERLLIB_MANGLE
2433 # define PERLLIB_MANGLE(s,n) (s)
2437 incpush(p, addsubdirs)
2441 SV *subdir = Nullsv;
2442 static char *archpat_auto;
2449 if (!archpat_auto) {
2450 STRLEN len = (sizeof(ARCHNAME) + strlen(patchlevel)
2451 + sizeof("//auto"));
2452 New(55, archpat_auto, len, char);
2453 sprintf(archpat_auto, "/%s/%s/auto", ARCHNAME, patchlevel);
2455 for (len = sizeof(ARCHNAME) + 2;
2456 archpat_auto[len] != '\0' && archpat_auto[len] != '/'; len++)
2457 if (archpat_auto[len] == '.') archpat_auto[len] = '_';
2462 /* Break at all separators */
2464 SV *libdir = newSV(0);
2467 /* skip any consecutive separators */
2468 while ( *p == PERLLIB_SEP ) {
2469 /* Uncomment the next line for PATH semantics */
2470 /* av_push(GvAVn(incgv), newSVpv(".", 1)); */
2474 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
2475 sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
2480 sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
2481 p = Nullch; /* break out */
2485 * BEFORE pushing libdir onto @INC we may first push version- and
2486 * archname-specific sub-directories.
2489 struct stat tmpstatbuf;
2494 if ((unix = tounixspec_ts(SvPV(libdir,na),Nullch)) != Nullch) {
2496 while (unix[len-1] == '/') len--; /* Cosmetic */
2497 sv_usepvn(libdir,unix,len);
2500 PerlIO_printf(PerlIO_stderr(),
2501 "Failed to unixify @INC element \"%s\"\n",
2504 /* .../archname/version if -d .../archname/version/auto */
2505 sv_setsv(subdir, libdir);
2506 sv_catpv(subdir, archpat_auto);
2507 if (Stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2508 S_ISDIR(tmpstatbuf.st_mode))
2509 av_push(GvAVn(incgv),
2510 newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2512 /* .../archname if -d .../archname/auto */
2513 sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME),
2514 strlen(patchlevel) + 1, "", 0);
2515 if (Stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2516 S_ISDIR(tmpstatbuf.st_mode))
2517 av_push(GvAVn(incgv),
2518 newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2521 /* finally push this lib directory on the end of @INC */
2522 av_push(GvAVn(incgv), libdir);
2525 SvREFCNT_dec(subdir);
2529 call_list(oldscope, list)
2533 line_t oldline = curcop->cop_line;
2538 while (AvFILL(list) >= 0) {
2539 CV *cv = (CV*)av_shift(list);
2546 SV* atsv = GvSV(errgv);
2548 perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
2549 (void)SvPV(atsv, len);
2552 curcop = &compiling;
2553 curcop->cop_line = oldline;
2554 if (list == beginav)
2555 sv_catpv(atsv, "BEGIN failed--compilation aborted");
2557 sv_catpv(atsv, "END failed--cleanup aborted");
2558 while (scopestack_ix > oldscope)
2560 croak("%s", SvPVX(atsv));
2568 /* my_exit() was called */
2569 while (scopestack_ix > oldscope)
2571 curstash = defstash;
2573 call_list(oldscope, endav);
2576 curcop = &compiling;
2577 curcop->cop_line = oldline;
2579 if (list == beginav)
2580 croak("BEGIN failed--compilation aborted");
2582 croak("END failed--cleanup aborted");
2588 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
2593 curcop = &compiling;
2594 curcop->cop_line = oldline;
2613 STATUS_NATIVE_SET(status);
2623 if (vaxc$errno & 1) {
2624 if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
2625 STATUS_NATIVE_SET(44);
2628 if (!vaxc$errno && errno) /* unlikely */
2629 STATUS_NATIVE_SET(44);
2631 STATUS_NATIVE_SET(vaxc$errno);
2635 STATUS_POSIX_SET(errno);
2636 else if (STATUS_POSIX == 0)
2637 STATUS_POSIX_SET(255);
2645 register CONTEXT *cx;
2654 (void)UNLINK(e_tmpname);
2655 Safefree(e_tmpname);
2659 if (cxstack_ix >= 0) {