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) && cando(S_IXUSR,TRUE,&statbuf)) {
1710 xfound = tokenbuf; /* bingo! */
1714 xfailed = savepv(tokenbuf);
1717 croak("Can't execute %s", xfailed ? xfailed : scriptname );
1720 scriptname = xfound;
1723 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
1724 char *s = scriptname + 8;
1733 origfilename = savepv(e_tmpname ? "-e" : scriptname);
1734 curcop->cop_filegv = gv_fetchfile(origfilename);
1735 if (strEQ(origfilename,"-"))
1737 if (fdscript >= 0) {
1738 rsfp = PerlIO_fdopen(fdscript,"r");
1739 #if defined(HAS_FCNTL) && defined(F_SETFD)
1741 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
1744 else if (preprocess) {
1745 char *cpp_cfg = CPPSTDIN;
1746 SV *cpp = NEWSV(0,0);
1747 SV *cmd = NEWSV(0,0);
1749 if (strEQ(cpp_cfg, "cppstdin"))
1750 sv_catpvf(cpp, "%s/", BIN_EXP);
1751 sv_catpv(cpp, cpp_cfg);
1754 sv_catpv(sv,PRIVLIB_EXP);
1758 sed %s -e \"/^[^#]/b\" \
1759 -e \"/^#[ ]*include[ ]/b\" \
1760 -e \"/^#[ ]*define[ ]/b\" \
1761 -e \"/^#[ ]*if[ ]/b\" \
1762 -e \"/^#[ ]*ifdef[ ]/b\" \
1763 -e \"/^#[ ]*ifndef[ ]/b\" \
1764 -e \"/^#[ ]*else/b\" \
1765 -e \"/^#[ ]*elif[ ]/b\" \
1766 -e \"/^#[ ]*undef[ ]/b\" \
1767 -e \"/^#[ ]*endif/b\" \
1770 (doextract ? "-e \"1,/^#/d\n\"" : ""),
1773 %s %s -e '/^[^#]/b' \
1774 -e '/^#[ ]*include[ ]/b' \
1775 -e '/^#[ ]*define[ ]/b' \
1776 -e '/^#[ ]*if[ ]/b' \
1777 -e '/^#[ ]*ifdef[ ]/b' \
1778 -e '/^#[ ]*ifndef[ ]/b' \
1779 -e '/^#[ ]*else/b' \
1780 -e '/^#[ ]*elif[ ]/b' \
1781 -e '/^#[ ]*undef[ ]/b' \
1782 -e '/^#[ ]*endif/b' \
1790 (doextract ? "-e '1,/^#/d\n'" : ""),
1792 scriptname, cpp, sv, CPPMINUS);
1794 #ifdef IAMSUID /* actually, this is caught earlier */
1795 if (euid != uid && !euid) { /* if running suidperl */
1797 (void)seteuid(uid); /* musn't stay setuid root */
1800 (void)setreuid((Uid_t)-1, uid);
1802 #ifdef HAS_SETRESUID
1803 (void)setresuid((Uid_t)-1, uid, (Uid_t)-1);
1809 if (geteuid() != uid)
1810 croak("Can't do seteuid!\n");
1812 #endif /* IAMSUID */
1813 rsfp = my_popen(SvPVX(cmd), "r");
1817 else if (!*scriptname) {
1818 forbid_setid("program input from stdin");
1819 rsfp = PerlIO_stdin();
1822 rsfp = PerlIO_open(scriptname,"r");
1823 #if defined(HAS_FCNTL) && defined(F_SETFD)
1825 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
1833 #ifndef IAMSUID /* in case script is not readable before setuid */
1834 if (euid && Stat(SvPVX(GvSV(curcop->cop_filegv)),&statbuf) >= 0 &&
1835 statbuf.st_mode & (S_ISUID|S_ISGID)) {
1837 execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
1838 croak("Can't do setuid\n");
1842 croak("Can't open perl script \"%s\": %s\n",
1843 SvPVX(GvSV(curcop->cop_filegv)), Strerror(errno));
1848 validate_suid(validarg, scriptname)
1854 /* do we need to emulate setuid on scripts? */
1856 /* This code is for those BSD systems that have setuid #! scripts disabled
1857 * in the kernel because of a security problem. Merely defining DOSUID
1858 * in perl will not fix that problem, but if you have disabled setuid
1859 * scripts in the kernel, this will attempt to emulate setuid and setgid
1860 * on scripts that have those now-otherwise-useless bits set. The setuid
1861 * root version must be called suidperl or sperlN.NNN. If regular perl
1862 * discovers that it has opened a setuid script, it calls suidperl with
1863 * the same argv that it had. If suidperl finds that the script it has
1864 * just opened is NOT setuid root, it sets the effective uid back to the
1865 * uid. We don't just make perl setuid root because that loses the
1866 * effective uid we had before invoking perl, if it was different from the
1869 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
1870 * be defined in suidperl only. suidperl must be setuid root. The
1871 * Configure script will set this up for you if you want it.
1877 if (Fstat(PerlIO_fileno(rsfp),&statbuf) < 0) /* normal stat is insecure */
1878 croak("Can't stat script \"%s\"",origfilename);
1879 if (fdscript < 0 && statbuf.st_mode & (S_ISUID|S_ISGID)) {
1883 #ifndef HAS_SETREUID
1884 /* On this access check to make sure the directories are readable,
1885 * there is actually a small window that the user could use to make
1886 * filename point to an accessible directory. So there is a faint
1887 * chance that someone could execute a setuid script down in a
1888 * non-accessible directory. I don't know what to do about that.
1889 * But I don't think it's too important. The manual lies when
1890 * it says access() is useful in setuid programs.
1892 if (access(SvPVX(GvSV(curcop->cop_filegv)),1)) /*double check*/
1893 croak("Permission denied");
1895 /* If we can swap euid and uid, then we can determine access rights
1896 * with a simple stat of the file, and then compare device and
1897 * inode to make sure we did stat() on the same file we opened.
1898 * Then we just have to make sure he or she can execute it.
1901 struct stat tmpstatbuf;
1905 setreuid(euid,uid) < 0
1908 setresuid(euid,uid,(Uid_t)-1) < 0
1911 || getuid() != euid || geteuid() != uid)
1912 croak("Can't swap uid and euid"); /* really paranoid */
1913 if (Stat(SvPVX(GvSV(curcop->cop_filegv)),&tmpstatbuf) < 0)
1914 croak("Permission denied"); /* testing full pathname here */
1915 if (tmpstatbuf.st_dev != statbuf.st_dev ||
1916 tmpstatbuf.st_ino != statbuf.st_ino) {
1917 (void)PerlIO_close(rsfp);
1918 if (rsfp = my_popen("/bin/mail root","w")) { /* heh, heh */
1920 "User %ld tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
1921 (Filename of set-id script was %s, uid %ld gid %ld.)\n\nSincerely,\nperl\n",
1922 (long)uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
1923 (long)statbuf.st_dev, (long)statbuf.st_ino,
1924 SvPVX(GvSV(curcop->cop_filegv)),
1925 (long)statbuf.st_uid, (long)statbuf.st_gid);
1926 (void)my_pclose(rsfp);
1928 croak("Permission denied\n");
1932 setreuid(uid,euid) < 0
1934 # if defined(HAS_SETRESUID)
1935 setresuid(uid,euid,(Uid_t)-1) < 0
1938 || getuid() != uid || geteuid() != euid)
1939 croak("Can't reswap uid and euid");
1940 if (!cando(S_IXUSR,FALSE,&statbuf)) /* can real uid exec? */
1941 croak("Permission denied\n");
1943 #endif /* HAS_SETREUID */
1944 #endif /* IAMSUID */
1946 if (!S_ISREG(statbuf.st_mode))
1947 croak("Permission denied");
1948 if (statbuf.st_mode & S_IWOTH)
1949 croak("Setuid/gid script is writable by world");
1950 doswitches = FALSE; /* -s is insecure in suid */
1952 if (sv_gets(linestr, rsfp, 0) == Nullch ||
1953 strnNE(SvPV(linestr,na),"#!",2) ) /* required even on Sys V */
1954 croak("No #! line");
1955 s = SvPV(linestr,na)+2;
1957 while (!isSPACE(*s)) s++;
1958 for (s2 = s; (s2 > SvPV(linestr,na)+2 &&
1959 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
1960 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
1961 croak("Not a perl script");
1962 while (*s == ' ' || *s == '\t') s++;
1964 * #! arg must be what we saw above. They can invoke it by
1965 * mentioning suidperl explicitly, but they may not add any strange
1966 * arguments beyond what #! says if they do invoke suidperl that way.
1968 len = strlen(validarg);
1969 if (strEQ(validarg," PHOOEY ") ||
1970 strnNE(s,validarg,len) || !isSPACE(s[len]))
1971 croak("Args must match #! line");
1974 if (euid != uid && (statbuf.st_mode & S_ISUID) &&
1975 euid == statbuf.st_uid)
1977 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
1978 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
1979 #endif /* IAMSUID */
1981 if (euid) { /* oops, we're not the setuid root perl */
1982 (void)PerlIO_close(rsfp);
1985 execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
1987 croak("Can't do setuid\n");
1990 if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid) {
1992 (void)setegid(statbuf.st_gid);
1995 (void)setregid((Gid_t)-1,statbuf.st_gid);
1997 #ifdef HAS_SETRESGID
1998 (void)setresgid((Gid_t)-1,statbuf.st_gid,(Gid_t)-1);
2000 setgid(statbuf.st_gid);
2004 if (getegid() != statbuf.st_gid)
2005 croak("Can't do setegid!\n");
2007 if (statbuf.st_mode & S_ISUID) {
2008 if (statbuf.st_uid != euid)
2010 (void)seteuid(statbuf.st_uid); /* all that for this */
2013 (void)setreuid((Uid_t)-1,statbuf.st_uid);
2015 #ifdef HAS_SETRESUID
2016 (void)setresuid((Uid_t)-1,statbuf.st_uid,(Uid_t)-1);
2018 setuid(statbuf.st_uid);
2022 if (geteuid() != statbuf.st_uid)
2023 croak("Can't do seteuid!\n");
2025 else if (uid) { /* oops, mustn't run as root */
2027 (void)seteuid((Uid_t)uid);
2030 (void)setreuid((Uid_t)-1,(Uid_t)uid);
2032 #ifdef HAS_SETRESUID
2033 (void)setresuid((Uid_t)-1,(Uid_t)uid,(Uid_t)-1);
2039 if (geteuid() != uid)
2040 croak("Can't do seteuid!\n");
2043 if (!cando(S_IXUSR,TRUE,&statbuf))
2044 croak("Permission denied\n"); /* they can't do this */
2047 else if (preprocess)
2048 croak("-P not allowed for setuid/setgid script\n");
2049 else if (fdscript >= 0)
2050 croak("fd script not allowed in suidperl\n");
2052 croak("Script is not setuid/setgid in suidperl\n");
2054 /* We absolutely must clear out any saved ids here, so we */
2055 /* exec the real perl, substituting fd script for scriptname. */
2056 /* (We pass script name as "subdir" of fd, which perl will grok.) */
2057 PerlIO_rewind(rsfp);
2058 lseek(PerlIO_fileno(rsfp),(Off_t)0,0); /* just in case rewind didn't */
2059 for (which = 1; origargv[which] && origargv[which] != scriptname; which++) ;
2060 if (!origargv[which])
2061 croak("Permission denied");
2062 origargv[which] = savepv(form("/dev/fd/%d/%s",
2063 PerlIO_fileno(rsfp), origargv[which]));
2064 #if defined(HAS_FCNTL) && defined(F_SETFD)
2065 fcntl(PerlIO_fileno(rsfp),F_SETFD,0); /* ensure no close-on-exec */
2067 execv(form("%s/perl%s", BIN_EXP, patchlevel), origargv); /* try again */
2068 croak("Can't do setuid\n");
2069 #endif /* IAMSUID */
2071 if (euid != uid || egid != gid) { /* (suidperl doesn't exist, in fact) */
2072 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
2073 Fstat(PerlIO_fileno(rsfp),&statbuf); /* may be either wrapped or real suid */
2074 if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
2076 (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
2079 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2080 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2081 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
2082 /* not set-id, must be wrapped */
2090 register char *s, *s2;
2092 /* skip forward in input to the real script? */
2096 if ((s = sv_gets(linestr, rsfp, 0)) == Nullch)
2097 croak("No Perl script found in input\n");
2098 if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
2099 PerlIO_ungetc(rsfp, '\n'); /* to keep line count right */
2101 while (*s && !(isSPACE (*s) || *s == '#')) s++;
2103 while (*s == ' ' || *s == '\t') s++;
2105 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
2106 if (strnEQ(s2-4,"perl",4))
2108 while (s = moreswitches(s)) ;
2110 if (cddir && chdir(cddir) < 0)
2111 croak("Can't chdir to %s",cddir);
2119 uid = (int)getuid();
2120 euid = (int)geteuid();
2121 gid = (int)getgid();
2122 egid = (int)getegid();
2127 tainting |= (uid && (euid != uid || egid != gid));
2135 croak("No %s allowed while running setuid", s);
2137 croak("No %s allowed while running setgid", s);
2143 curstash = debstash;
2144 dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
2146 DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
2147 DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
2148 DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
2149 DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
2150 sv_setiv(DBsingle, 0);
2151 DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
2152 sv_setiv(DBtrace, 0);
2153 DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
2154 sv_setiv(DBsignal, 0);
2155 curstash = defstash;
2162 mainstack = curstack; /* remember in case we switch stacks */
2163 AvREAL_off(curstack); /* not a real array */
2164 av_extend(curstack,127);
2166 stack_base = AvARRAY(curstack);
2167 stack_sp = stack_base;
2168 stack_max = stack_base + 127;
2170 cxstack_max = 8192 / sizeof(CONTEXT) - 2; /* Use most of 8K. */
2171 New(50,cxstack,cxstack_max + 1,CONTEXT);
2174 New(50,tmps_stack,128,SV*);
2179 New(51,debname,128,char);
2180 New(52,debdelim,128,char);
2184 * The following stacks almost certainly should be per-interpreter,
2185 * but for now they're not. XXX
2189 markstack_ptr = markstack;
2191 New(54,markstack,64,I32);
2192 markstack_ptr = markstack;
2193 markstack_max = markstack + 64;
2199 New(54,scopestack,32,I32);
2201 scopestack_max = 32;
2207 New(54,savestack,128,ANY);
2209 savestack_max = 128;
2215 New(54,retstack,16,OP*);
2225 Safefree(tmps_stack);
2232 static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
2240 subname = newSVpv("main",4);
2244 init_predump_symbols()
2249 sv_setpvn(GvSV(gv_fetchpv("\"", TRUE, SVt_PV)), " ", 1);
2251 stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
2252 GvMULTI_on(stdingv);
2253 IoIFP(GvIOp(stdingv)) = PerlIO_stdin();
2254 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
2256 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(stdingv));
2258 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
2260 IoOFP(GvIOp(tmpgv)) = IoIFP(GvIOp(tmpgv)) = PerlIO_stdout();
2262 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
2264 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(defoutgv));
2266 othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
2267 GvMULTI_on(othergv);
2268 IoOFP(GvIOp(othergv)) = IoIFP(GvIOp(othergv)) = PerlIO_stderr();
2269 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
2271 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(othergv));
2273 statname = NEWSV(66,0); /* last filename we did stat on */
2276 osname = savepv(OSNAME);
2280 init_postdump_symbols(argc,argv,env)
2282 register char **argv;
2283 register char **env;
2289 argc--,argv++; /* skip name of script */
2291 for (; argc > 0 && **argv == '-'; argc--,argv++) {
2294 if (argv[0][1] == '-') {
2298 if (s = strchr(argv[0], '=')) {
2300 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
2303 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
2306 toptarget = NEWSV(0,0);
2307 sv_upgrade(toptarget, SVt_PVFM);
2308 sv_setpvn(toptarget, "", 0);
2309 bodytarget = NEWSV(0,0);
2310 sv_upgrade(bodytarget, SVt_PVFM);
2311 sv_setpvn(bodytarget, "", 0);
2312 formtarget = bodytarget;
2315 if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
2316 sv_setpv(GvSV(tmpgv),origfilename);
2317 magicname("0", "0", 1);
2319 if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
2320 sv_setpv(GvSV(tmpgv),origargv[0]);
2321 if (argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
2323 (void)gv_AVadd(argvgv);
2324 av_clear(GvAVn(argvgv));
2325 for (; argc > 0; argc--,argv++) {
2326 av_push(GvAVn(argvgv),newSVpv(argv[0],0));
2329 if (envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
2333 hv_magic(hv, envgv, 'E');
2334 #ifndef VMS /* VMS doesn't have environ array */
2335 /* Note that if the supplied env parameter is actually a copy
2336 of the global environ then it may now point to free'd memory
2337 if the environment has been modified since. To avoid this
2338 problem we treat env==NULL as meaning 'use the default'
2343 environ[0] = Nullch;
2344 for (; *env; env++) {
2345 if (!(s = strchr(*env,'=')))
2351 sv = newSVpv(s--,0);
2352 (void)hv_store(hv, *env, s - *env, sv, 0);
2356 #ifdef DYNAMIC_ENV_FETCH
2357 HvNAME(hv) = savepv(ENV_HV_NAME);
2361 if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
2362 sv_setiv(GvSV(tmpgv), (IV)getpid());
2371 s = getenv("PERL5LIB");
2375 incpush(getenv("PERLLIB"), FALSE);
2377 /* Treat PERL5?LIB as a possible search list logical name -- the
2378 * "natural" VMS idiom for a Unix path string. We allow each
2379 * element to be a set of |-separated directories for compatibility.
2383 if (my_trnlnm("PERL5LIB",buf,0))
2384 do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
2386 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE);
2390 /* Use the ~-expanded versions of APPLIB (undocumented),
2391 ARCHLIB PRIVLIB SITEARCH SITELIB and OLDARCHLIB
2394 incpush(APPLLIB_EXP, FALSE);
2398 incpush(ARCHLIB_EXP, FALSE);
2401 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
2403 incpush(PRIVLIB_EXP, FALSE);
2406 incpush(SITEARCH_EXP, FALSE);
2409 incpush(SITELIB_EXP, FALSE);
2411 #ifdef OLDARCHLIB_EXP /* 5.00[01] compatibility */
2412 incpush(OLDARCHLIB_EXP, FALSE);
2416 incpush(".", FALSE);
2420 # define PERLLIB_SEP ';'
2423 # define PERLLIB_SEP '|'
2425 # define PERLLIB_SEP ':'
2428 #ifndef PERLLIB_MANGLE
2429 # define PERLLIB_MANGLE(s,n) (s)
2433 incpush(p, addsubdirs)
2437 SV *subdir = Nullsv;
2438 static char *archpat_auto;
2445 if (!archpat_auto) {
2446 STRLEN len = (sizeof(ARCHNAME) + strlen(patchlevel)
2447 + sizeof("//auto"));
2448 New(55, archpat_auto, len, char);
2449 sprintf(archpat_auto, "/%s/%s/auto", ARCHNAME, patchlevel);
2451 for (len = sizeof(ARCHNAME) + 2;
2452 archpat_auto[len] != '\0' && archpat_auto[len] != '/'; len++)
2453 if (archpat_auto[len] == '.') archpat_auto[len] = '_';
2458 /* Break at all separators */
2460 SV *libdir = newSV(0);
2463 /* skip any consecutive separators */
2464 while ( *p == PERLLIB_SEP ) {
2465 /* Uncomment the next line for PATH semantics */
2466 /* av_push(GvAVn(incgv), newSVpv(".", 1)); */
2470 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
2471 sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
2476 sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
2477 p = Nullch; /* break out */
2481 * BEFORE pushing libdir onto @INC we may first push version- and
2482 * archname-specific sub-directories.
2485 struct stat tmpstatbuf;
2490 if ((unix = tounixspec_ts(SvPV(libdir,na),Nullch)) != Nullch) {
2492 while (unix[len-1] == '/') len--; /* Cosmetic */
2493 sv_usepvn(libdir,unix,len);
2496 PerlIO_printf(PerlIO_stderr(),
2497 "Failed to unixify @INC element \"%s\"\n",
2500 /* .../archname/version if -d .../archname/version/auto */
2501 sv_setsv(subdir, libdir);
2502 sv_catpv(subdir, archpat_auto);
2503 if (Stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2504 S_ISDIR(tmpstatbuf.st_mode))
2505 av_push(GvAVn(incgv),
2506 newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2508 /* .../archname if -d .../archname/auto */
2509 sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME),
2510 strlen(patchlevel) + 1, "", 0);
2511 if (Stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2512 S_ISDIR(tmpstatbuf.st_mode))
2513 av_push(GvAVn(incgv),
2514 newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2517 /* finally push this lib directory on the end of @INC */
2518 av_push(GvAVn(incgv), libdir);
2521 SvREFCNT_dec(subdir);
2525 call_list(oldscope, list)
2529 line_t oldline = curcop->cop_line;
2534 while (AvFILL(list) >= 0) {
2535 CV *cv = (CV*)av_shift(list);
2542 SV* atsv = GvSV(errgv);
2544 perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
2545 (void)SvPV(atsv, len);
2548 curcop = &compiling;
2549 curcop->cop_line = oldline;
2550 if (list == beginav)
2551 sv_catpv(atsv, "BEGIN failed--compilation aborted");
2553 sv_catpv(atsv, "END failed--cleanup aborted");
2554 while (scopestack_ix > oldscope)
2556 croak("%s", SvPVX(atsv));
2564 /* my_exit() was called */
2565 while (scopestack_ix > oldscope)
2567 curstash = defstash;
2569 call_list(oldscope, endav);
2572 curcop = &compiling;
2573 curcop->cop_line = oldline;
2575 if (list == beginav)
2576 croak("BEGIN failed--compilation aborted");
2578 croak("END failed--cleanup aborted");
2584 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
2589 curcop = &compiling;
2590 curcop->cop_line = oldline;
2609 STATUS_NATIVE_SET(status);
2619 if (vaxc$errno & 1) {
2620 if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
2621 STATUS_NATIVE_SET(44);
2624 if (!vaxc$errno && errno) /* unlikely */
2625 STATUS_NATIVE_SET(44);
2627 STATUS_NATIVE_SET(vaxc$errno);
2631 STATUS_POSIX_SET(errno);
2632 else if (STATUS_POSIX == 0)
2633 STATUS_POSIX_SET(255);
2641 register CONTEXT *cx;
2650 (void)UNLINK(e_tmpname);
2651 Safefree(e_tmpname);
2655 if (cxstack_ix >= 0) {