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;
1022 if (flags & G_DISCARD) {
1027 Zero(&myop, 1, LOGOP);
1028 myop.op_next = Nullop;
1029 if (!(flags & G_NOARGS))
1030 myop.op_flags |= OPf_STACKED;
1031 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1032 (flags & G_ARRAY) ? OPf_WANT_LIST :
1037 EXTEND(stack_sp, 1);
1040 oldscope = scopestack_ix;
1042 if (perldb && curstash != debstash
1043 /* Handle first BEGIN of -d. */
1044 && (DBcv || (DBcv = GvCV(DBsub)))
1045 /* Try harder, since this may have been a sighandler, thus
1046 * curstash may be meaningless. */
1047 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != debstash))
1048 op->op_private |= OPpENTERSUB_DB;
1050 if (flags & G_EVAL) {
1051 cLOGOP->op_other = op;
1053 /* we're trying to emulate pp_entertry() here */
1055 register CONTEXT *cx;
1056 I32 gimme = GIMME_V;
1061 push_return(op->op_next);
1062 PUSHBLOCK(cx, CXt_EVAL, stack_sp);
1064 eval_root = op; /* Only needed so that goto works right. */
1067 if (flags & G_KEEPERR)
1070 sv_setpv(GvSV(errgv),"");
1082 /* my_exit() was called */
1083 curstash = defstash;
1087 croak("Callback called exit");
1096 stack_sp = stack_base + oldmark;
1097 if (flags & G_ARRAY)
1101 *++stack_sp = &sv_undef;
1109 if (op == (OP*)&myop)
1113 retval = stack_sp - (stack_base + oldmark);
1114 if ((flags & G_EVAL) && !(flags & G_KEEPERR))
1115 sv_setpv(GvSV(errgv),"");
1118 if (flags & G_EVAL) {
1119 if (scopestack_ix > oldscope) {
1123 register CONTEXT *cx;
1135 CATCH_SET(oldcatch);
1137 if (flags & G_DISCARD) {
1138 stack_sp = stack_base + oldmark;
1147 /* Eval a string. The G_EVAL flag is always assumed. */
1150 perl_eval_sv(sv, flags)
1152 I32 flags; /* See G_* flags in cop.h */
1154 UNOP myop; /* fake syntax tree node */
1156 I32 oldmark = sp - stack_base;
1162 if (flags & G_DISCARD) {
1170 EXTEND(stack_sp, 1);
1172 oldscope = scopestack_ix;
1174 if (!(flags & G_NOARGS))
1175 myop.op_flags = OPf_STACKED;
1176 myop.op_next = Nullop;
1177 myop.op_type = OP_ENTEREVAL;
1178 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1179 (flags & G_ARRAY) ? OPf_WANT_LIST :
1181 if (flags & G_KEEPERR)
1182 myop.op_flags |= OPf_SPECIAL;
1192 /* my_exit() was called */
1193 curstash = defstash;
1197 croak("Callback called exit");
1206 stack_sp = stack_base + oldmark;
1207 if (flags & G_ARRAY)
1211 *++stack_sp = &sv_undef;
1216 if (op == (OP*)&myop)
1217 op = pp_entereval();
1220 retval = stack_sp - (stack_base + oldmark);
1221 if (!(flags & G_KEEPERR))
1222 sv_setpv(GvSV(errgv),"");
1226 if (flags & G_DISCARD) {
1227 stack_sp = stack_base + oldmark;
1236 perl_eval_pv(p, croak_on_error)
1241 SV* sv = newSVpv(p, 0);
1244 perl_eval_sv(sv, G_SCALAR);
1251 if (croak_on_error && SvTRUE(GvSV(errgv)))
1252 croak(SvPVx(GvSV(errgv), na));
1257 /* Require a module. */
1263 SV* sv = sv_newmortal();
1264 sv_setpv(sv, "require '");
1267 perl_eval_sv(sv, G_DISCARD);
1271 magicname(sym,name,namlen)
1278 if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
1279 sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
1283 usage(name) /* XXX move this out into a module ? */
1286 /* This message really ought to be max 23 lines.
1287 * Removed -h because the user already knows that opton. Others? */
1288 printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
1289 printf("\n -0[octal] specify record separator (\\0, if no argument)");
1290 printf("\n -a autosplit mode with -n or -p (splits $_ into @F)");
1291 printf("\n -c check syntax only (runs BEGIN and END blocks)");
1292 printf("\n -d[:debugger] run scripts under debugger");
1293 printf("\n -D[number/list] set debugging flags (argument is a bit mask or flags)");
1294 printf("\n -e 'command' one line of script. Several -e's allowed. Omit [programfile].");
1295 printf("\n -F/pattern/ split() pattern for autosplit (-a). The //'s are optional.");
1296 printf("\n -i[extension] edit <> files in place (make backup if extension supplied)");
1297 printf("\n -Idirectory specify @INC/#include directory (may be used more then once)");
1298 printf("\n -l[octal] enable line ending processing, specifies line teminator");
1299 printf("\n -[mM][-]module.. executes `use/no module...' before executing your script.");
1300 printf("\n -n assume 'while (<>) { ... }' loop arround your script");
1301 printf("\n -p assume loop like -n but print line also like sed");
1302 printf("\n -P run script through C preprocessor before compilation");
1303 printf("\n -s enable some switch parsing for switches after script name");
1304 printf("\n -S look for the script using PATH environment variable");
1305 printf("\n -T turn on tainting checks");
1306 printf("\n -u dump core after parsing script");
1307 printf("\n -U allow unsafe operations");
1308 printf("\n -v print version number and patchlevel of perl");
1309 printf("\n -V[:variable] print perl configuration information");
1310 printf("\n -w TURN WARNINGS ON FOR COMPILATION OF YOUR SCRIPT.");
1311 printf("\n -x[directory] strip off text before #!perl line and perhaps cd to directory\n");
1314 /* This routine handles any switches that can be given during run */
1325 rschar = scan_oct(s, 4, &numlen);
1327 if (rschar & ~((U8)~0))
1329 else if (!rschar && numlen >= 2)
1330 nrs = newSVpv("", 0);
1333 nrs = newSVpv(&ch, 1);
1338 splitstr = savepv(s + 1);
1352 if (*s == ':' || *s == '=') {
1353 my_setenv("PERL5DB", form("use Devel::%s;", ++s));
1364 if (isALPHA(s[1])) {
1365 static char debopts[] = "psltocPmfrxuLHXD";
1368 for (s++; *s && (d = strchr(debopts,*s)); s++)
1369 debug |= 1 << (d - debopts);
1373 for (s++; isDIGIT(*s); s++) ;
1375 debug |= 0x80000000;
1377 warn("Recompile perl with -DDEBUGGING to use -D switch\n");
1378 for (s++; isALNUM(*s); s++) ;
1388 inplace = savepv(s+1);
1390 for (s = inplace; *s && !isSPACE(*s); s++) ;
1397 for (e = s; *e && !isSPACE(*e); e++) ;
1398 p = savepvn(s, e-s);
1405 croak("No space allowed after -I");
1415 *ors = scan_oct(s, 3 + (*s == '0'), &numlen);
1424 ors = SvPV(nrs, orslen);
1425 ors = savepvn(ors, orslen);
1429 forbid_setid("-M"); /* XXX ? */
1432 forbid_setid("-m"); /* XXX ? */
1436 /* -M-foo == 'no foo' */
1437 if (*s == '-') { use = "no "; ++s; }
1438 Sv = newSVpv(use,0);
1440 /* We allow -M'Module qw(Foo Bar)' */
1441 while(isALNUM(*s) || *s==':') ++s;
1443 sv_catpv(Sv, start);
1444 if (*(start-1) == 'm') {
1446 croak("Can't use '%c' after -mname", *s);
1447 sv_catpv( Sv, " ()");
1450 sv_catpvn(Sv, start, s-start);
1451 sv_catpv(Sv, " split(/,/,q{");
1456 if (preambleav == NULL)
1457 preambleav = newAV();
1458 av_push(preambleav, Sv);
1461 croak("No space allowed after -%c", *(s-1));
1478 croak("Too late for \"-T\" option");
1490 #if defined(SUBVERSION) && SUBVERSION > 0
1491 printf("\nThis is perl, version 5.%03d_%02d", PATCHLEVEL, SUBVERSION);
1493 printf("\nThis is perl, version %s",patchlevel);
1496 printf("\n\nCopyright 1987-1997, Larry Wall\n");
1498 printf("\n\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
1501 printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n");
1504 printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
1505 "Version 5 port Copyright (c) 1994-1997, Andreas Kaiser, Ilya Zakharevich\n");
1508 printf("atariST series port, ++jrb bammi@cadence.com\n");
1511 Perl may be copied only under the terms of either the Artistic License or the\n\
1512 GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n");
1520 if (s[1] == '-') /* Additional switches on #! line. */
1528 #ifdef ALTERNATE_SHEBANG
1529 case 'S': /* OS/2 needs -S on "extproc" line. */
1537 croak("Can't emulate -%.1s on #! line",s);
1542 /* compliments of Tom Christiansen */
1544 /* unexec() can be found in the Gnu emacs distribution */
1555 prog = newSVpv(BIN_EXP);
1556 sv_catpv(prog, "/perl");
1557 file = newSVpv(origfilename);
1558 sv_catpv(file, ".perldump");
1560 status = unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
1562 PerlIO_printf(PerlIO_stderr(), "unexec of %s into %s failed!\n",
1563 SvPVX(prog), SvPVX(file));
1567 # include <lib$routines.h>
1568 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
1570 ABORT(); /* for use with undump */
1580 /* Note that strtab is a rather special HV. Assumptions are made
1581 about not iterating on it, and not adding tie magic to it.
1582 It is properly deallocated in perl_destruct() */
1584 HvSHAREKEYS_off(strtab); /* mandatory */
1585 Newz(506,((XPVHV*)SvANY(strtab))->xhv_array,
1586 sizeof(HE*) * (((XPVHV*)SvANY(strtab))->xhv_max + 1), char);
1588 curstash = defstash = newHV();
1589 curstname = newSVpv("main",4);
1590 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
1591 SvREFCNT_dec(GvHV(gv));
1592 GvHV(gv) = (HV*)SvREFCNT_inc(defstash);
1594 HvNAME(defstash) = savepv("main");
1595 incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
1597 defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
1598 errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
1600 sv_setpvn(GvSV(errgv), "", 0);
1601 curstash = defstash;
1602 compiling.cop_stash = defstash;
1603 debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
1604 /* We must init $/ before switches are processed. */
1605 sv_setpvn(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), "\n", 1);
1608 #ifdef CAN_PROTOTYPE
1610 open_script(char *scriptname, bool dosearch, SV *sv)
1613 open_script(scriptname,dosearch,sv)
1619 char *xfound = Nullch;
1620 char *xfailed = Nullch;
1624 #if defined(DOSISH) && !defined(OS2) && !defined(atarist)
1625 # define SEARCH_EXTS ".bat", ".cmd", NULL
1626 # define MAX_EXT_LEN 4
1629 # define SEARCH_EXTS ".pl", ".com", NULL
1630 # define MAX_EXT_LEN 4
1632 /* additional extensions to try in each dir if scriptname not found */
1634 char *ext[] = { SEARCH_EXTS };
1635 int extidx = (strchr(scriptname,'.')) ? -1 : 0; /* has ext already */
1637 # define MAX_EXT_LEN 0
1642 int hasdir, idx = 0, deftypes = 1;
1644 hasdir = (strpbrk(scriptname,":[</") != Nullch) ;
1645 /* The first time through, just add SEARCH_EXTS to whatever we
1646 * already have, so we can check for default file types. */
1648 (!hasdir && my_trnlnm("DCL$PATH",tokenbuf,idx++)) )
1654 if ((strlen(tokenbuf) + strlen(scriptname)
1655 + MAX_EXT_LEN) >= sizeof tokenbuf)
1656 continue; /* don't search dir with too-long name */
1657 strcat(tokenbuf, scriptname);
1659 if (dosearch && !strchr(scriptname, '/')
1661 && !strchr(scriptname, '\\')
1663 && (s = getenv("PATH"))) {
1664 bufend = s + strlen(s);
1665 while (s < bufend) {
1667 s = delimcpy(tokenbuf, tokenbuf + sizeof tokenbuf, s, bufend,
1675 for (len = 0; *s && *s != ',' && *s != ';'; len++, s++) {
1676 if (len < sizeof tokenbuf)
1679 if (len < sizeof tokenbuf)
1680 tokenbuf[len] = '\0';
1681 #endif /* atarist */
1684 if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tokenbuf)
1685 continue; /* don't search dir with too-long name */
1687 #if defined(atarist) && !defined(DOSISH)
1688 && tokenbuf[len - 1] != '/'
1690 #if defined(atarist) || defined(DOSISH)
1691 && tokenbuf[len - 1] != '\\'
1694 tokenbuf[len++] = '/';
1695 (void)strcpy(tokenbuf + len, scriptname);
1699 len = strlen(tokenbuf);
1700 if (extidx > 0) /* reset after previous loop */
1704 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tokenbuf));
1705 retval = Stat(tokenbuf,&statbuf);
1707 } while ( retval < 0 /* not there */
1708 && extidx>=0 && ext[extidx] /* try an extension? */
1709 && strcpy(tokenbuf+len, ext[extidx++])
1714 if (S_ISREG(statbuf.st_mode)
1715 && cando(S_IRUSR,TRUE,&statbuf)
1717 && cando(S_IXUSR,TRUE,&statbuf)
1721 xfound = tokenbuf; /* bingo! */
1725 xfailed = savepv(tokenbuf);
1728 croak("Can't execute %s", xfailed ? xfailed : scriptname );
1731 scriptname = xfound;
1734 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
1735 char *s = scriptname + 8;
1744 origfilename = savepv(e_tmpname ? "-e" : scriptname);
1745 curcop->cop_filegv = gv_fetchfile(origfilename);
1746 if (strEQ(origfilename,"-"))
1748 if (fdscript >= 0) {
1749 rsfp = PerlIO_fdopen(fdscript,"r");
1750 #if defined(HAS_FCNTL) && defined(F_SETFD)
1752 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
1755 else if (preprocess) {
1756 char *cpp_cfg = CPPSTDIN;
1757 SV *cpp = NEWSV(0,0);
1758 SV *cmd = NEWSV(0,0);
1760 if (strEQ(cpp_cfg, "cppstdin"))
1761 sv_catpvf(cpp, "%s/", BIN_EXP);
1762 sv_catpv(cpp, cpp_cfg);
1765 sv_catpv(sv,PRIVLIB_EXP);
1769 sed %s -e \"/^[^#]/b\" \
1770 -e \"/^#[ ]*include[ ]/b\" \
1771 -e \"/^#[ ]*define[ ]/b\" \
1772 -e \"/^#[ ]*if[ ]/b\" \
1773 -e \"/^#[ ]*ifdef[ ]/b\" \
1774 -e \"/^#[ ]*ifndef[ ]/b\" \
1775 -e \"/^#[ ]*else/b\" \
1776 -e \"/^#[ ]*elif[ ]/b\" \
1777 -e \"/^#[ ]*undef[ ]/b\" \
1778 -e \"/^#[ ]*endif/b\" \
1781 (doextract ? "-e \"1,/^#/d\n\"" : ""),
1784 %s %s -e '/^[^#]/b' \
1785 -e '/^#[ ]*include[ ]/b' \
1786 -e '/^#[ ]*define[ ]/b' \
1787 -e '/^#[ ]*if[ ]/b' \
1788 -e '/^#[ ]*ifdef[ ]/b' \
1789 -e '/^#[ ]*ifndef[ ]/b' \
1790 -e '/^#[ ]*else/b' \
1791 -e '/^#[ ]*elif[ ]/b' \
1792 -e '/^#[ ]*undef[ ]/b' \
1793 -e '/^#[ ]*endif/b' \
1801 (doextract ? "-e '1,/^#/d\n'" : ""),
1803 scriptname, cpp, sv, CPPMINUS);
1805 #ifdef IAMSUID /* actually, this is caught earlier */
1806 if (euid != uid && !euid) { /* if running suidperl */
1808 (void)seteuid(uid); /* musn't stay setuid root */
1811 (void)setreuid((Uid_t)-1, uid);
1813 #ifdef HAS_SETRESUID
1814 (void)setresuid((Uid_t)-1, uid, (Uid_t)-1);
1820 if (geteuid() != uid)
1821 croak("Can't do seteuid!\n");
1823 #endif /* IAMSUID */
1824 rsfp = my_popen(SvPVX(cmd), "r");
1828 else if (!*scriptname) {
1829 forbid_setid("program input from stdin");
1830 rsfp = PerlIO_stdin();
1833 rsfp = PerlIO_open(scriptname,"r");
1834 #if defined(HAS_FCNTL) && defined(F_SETFD)
1836 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
1844 #ifndef IAMSUID /* in case script is not readable before setuid */
1845 if (euid && Stat(SvPVX(GvSV(curcop->cop_filegv)),&statbuf) >= 0 &&
1846 statbuf.st_mode & (S_ISUID|S_ISGID)) {
1848 execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
1849 croak("Can't do setuid\n");
1853 croak("Can't open perl script \"%s\": %s\n",
1854 SvPVX(GvSV(curcop->cop_filegv)), Strerror(errno));
1859 validate_suid(validarg, scriptname)
1865 /* do we need to emulate setuid on scripts? */
1867 /* This code is for those BSD systems that have setuid #! scripts disabled
1868 * in the kernel because of a security problem. Merely defining DOSUID
1869 * in perl will not fix that problem, but if you have disabled setuid
1870 * scripts in the kernel, this will attempt to emulate setuid and setgid
1871 * on scripts that have those now-otherwise-useless bits set. The setuid
1872 * root version must be called suidperl or sperlN.NNN. If regular perl
1873 * discovers that it has opened a setuid script, it calls suidperl with
1874 * the same argv that it had. If suidperl finds that the script it has
1875 * just opened is NOT setuid root, it sets the effective uid back to the
1876 * uid. We don't just make perl setuid root because that loses the
1877 * effective uid we had before invoking perl, if it was different from the
1880 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
1881 * be defined in suidperl only. suidperl must be setuid root. The
1882 * Configure script will set this up for you if you want it.
1888 if (Fstat(PerlIO_fileno(rsfp),&statbuf) < 0) /* normal stat is insecure */
1889 croak("Can't stat script \"%s\"",origfilename);
1890 if (fdscript < 0 && statbuf.st_mode & (S_ISUID|S_ISGID)) {
1894 #ifndef HAS_SETREUID
1895 /* On this access check to make sure the directories are readable,
1896 * there is actually a small window that the user could use to make
1897 * filename point to an accessible directory. So there is a faint
1898 * chance that someone could execute a setuid script down in a
1899 * non-accessible directory. I don't know what to do about that.
1900 * But I don't think it's too important. The manual lies when
1901 * it says access() is useful in setuid programs.
1903 if (access(SvPVX(GvSV(curcop->cop_filegv)),1)) /*double check*/
1904 croak("Permission denied");
1906 /* If we can swap euid and uid, then we can determine access rights
1907 * with a simple stat of the file, and then compare device and
1908 * inode to make sure we did stat() on the same file we opened.
1909 * Then we just have to make sure he or she can execute it.
1912 struct stat tmpstatbuf;
1916 setreuid(euid,uid) < 0
1919 setresuid(euid,uid,(Uid_t)-1) < 0
1922 || getuid() != euid || geteuid() != uid)
1923 croak("Can't swap uid and euid"); /* really paranoid */
1924 if (Stat(SvPVX(GvSV(curcop->cop_filegv)),&tmpstatbuf) < 0)
1925 croak("Permission denied"); /* testing full pathname here */
1926 if (tmpstatbuf.st_dev != statbuf.st_dev ||
1927 tmpstatbuf.st_ino != statbuf.st_ino) {
1928 (void)PerlIO_close(rsfp);
1929 if (rsfp = my_popen("/bin/mail root","w")) { /* heh, heh */
1931 "User %ld tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
1932 (Filename of set-id script was %s, uid %ld gid %ld.)\n\nSincerely,\nperl\n",
1933 (long)uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
1934 (long)statbuf.st_dev, (long)statbuf.st_ino,
1935 SvPVX(GvSV(curcop->cop_filegv)),
1936 (long)statbuf.st_uid, (long)statbuf.st_gid);
1937 (void)my_pclose(rsfp);
1939 croak("Permission denied\n");
1943 setreuid(uid,euid) < 0
1945 # if defined(HAS_SETRESUID)
1946 setresuid(uid,euid,(Uid_t)-1) < 0
1949 || getuid() != uid || geteuid() != euid)
1950 croak("Can't reswap uid and euid");
1951 if (!cando(S_IXUSR,FALSE,&statbuf)) /* can real uid exec? */
1952 croak("Permission denied\n");
1954 #endif /* HAS_SETREUID */
1955 #endif /* IAMSUID */
1957 if (!S_ISREG(statbuf.st_mode))
1958 croak("Permission denied");
1959 if (statbuf.st_mode & S_IWOTH)
1960 croak("Setuid/gid script is writable by world");
1961 doswitches = FALSE; /* -s is insecure in suid */
1963 if (sv_gets(linestr, rsfp, 0) == Nullch ||
1964 strnNE(SvPV(linestr,na),"#!",2) ) /* required even on Sys V */
1965 croak("No #! line");
1966 s = SvPV(linestr,na)+2;
1968 while (!isSPACE(*s)) s++;
1969 for (s2 = s; (s2 > SvPV(linestr,na)+2 &&
1970 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
1971 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
1972 croak("Not a perl script");
1973 while (*s == ' ' || *s == '\t') s++;
1975 * #! arg must be what we saw above. They can invoke it by
1976 * mentioning suidperl explicitly, but they may not add any strange
1977 * arguments beyond what #! says if they do invoke suidperl that way.
1979 len = strlen(validarg);
1980 if (strEQ(validarg," PHOOEY ") ||
1981 strnNE(s,validarg,len) || !isSPACE(s[len]))
1982 croak("Args must match #! line");
1985 if (euid != uid && (statbuf.st_mode & S_ISUID) &&
1986 euid == statbuf.st_uid)
1988 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
1989 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
1990 #endif /* IAMSUID */
1992 if (euid) { /* oops, we're not the setuid root perl */
1993 (void)PerlIO_close(rsfp);
1996 execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
1998 croak("Can't do setuid\n");
2001 if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid) {
2003 (void)setegid(statbuf.st_gid);
2006 (void)setregid((Gid_t)-1,statbuf.st_gid);
2008 #ifdef HAS_SETRESGID
2009 (void)setresgid((Gid_t)-1,statbuf.st_gid,(Gid_t)-1);
2011 setgid(statbuf.st_gid);
2015 if (getegid() != statbuf.st_gid)
2016 croak("Can't do setegid!\n");
2018 if (statbuf.st_mode & S_ISUID) {
2019 if (statbuf.st_uid != euid)
2021 (void)seteuid(statbuf.st_uid); /* all that for this */
2024 (void)setreuid((Uid_t)-1,statbuf.st_uid);
2026 #ifdef HAS_SETRESUID
2027 (void)setresuid((Uid_t)-1,statbuf.st_uid,(Uid_t)-1);
2029 setuid(statbuf.st_uid);
2033 if (geteuid() != statbuf.st_uid)
2034 croak("Can't do seteuid!\n");
2036 else if (uid) { /* oops, mustn't run as root */
2038 (void)seteuid((Uid_t)uid);
2041 (void)setreuid((Uid_t)-1,(Uid_t)uid);
2043 #ifdef HAS_SETRESUID
2044 (void)setresuid((Uid_t)-1,(Uid_t)uid,(Uid_t)-1);
2050 if (geteuid() != uid)
2051 croak("Can't do seteuid!\n");
2054 if (!cando(S_IXUSR,TRUE,&statbuf))
2055 croak("Permission denied\n"); /* they can't do this */
2058 else if (preprocess)
2059 croak("-P not allowed for setuid/setgid script\n");
2060 else if (fdscript >= 0)
2061 croak("fd script not allowed in suidperl\n");
2063 croak("Script is not setuid/setgid in suidperl\n");
2065 /* We absolutely must clear out any saved ids here, so we */
2066 /* exec the real perl, substituting fd script for scriptname. */
2067 /* (We pass script name as "subdir" of fd, which perl will grok.) */
2068 PerlIO_rewind(rsfp);
2069 lseek(PerlIO_fileno(rsfp),(Off_t)0,0); /* just in case rewind didn't */
2070 for (which = 1; origargv[which] && origargv[which] != scriptname; which++) ;
2071 if (!origargv[which])
2072 croak("Permission denied");
2073 origargv[which] = savepv(form("/dev/fd/%d/%s",
2074 PerlIO_fileno(rsfp), origargv[which]));
2075 #if defined(HAS_FCNTL) && defined(F_SETFD)
2076 fcntl(PerlIO_fileno(rsfp),F_SETFD,0); /* ensure no close-on-exec */
2078 execv(form("%s/perl%s", BIN_EXP, patchlevel), origargv); /* try again */
2079 croak("Can't do setuid\n");
2080 #endif /* IAMSUID */
2082 if (euid != uid || egid != gid) { /* (suidperl doesn't exist, in fact) */
2083 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
2084 Fstat(PerlIO_fileno(rsfp),&statbuf); /* may be either wrapped or real suid */
2085 if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
2087 (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
2090 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2091 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2092 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
2093 /* not set-id, must be wrapped */
2101 register char *s, *s2;
2103 /* skip forward in input to the real script? */
2107 if ((s = sv_gets(linestr, rsfp, 0)) == Nullch)
2108 croak("No Perl script found in input\n");
2109 if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
2110 PerlIO_ungetc(rsfp, '\n'); /* to keep line count right */
2112 while (*s && !(isSPACE (*s) || *s == '#')) s++;
2114 while (*s == ' ' || *s == '\t') s++;
2116 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
2117 if (strnEQ(s2-4,"perl",4))
2119 while (s = moreswitches(s)) ;
2121 if (cddir && chdir(cddir) < 0)
2122 croak("Can't chdir to %s",cddir);
2130 uid = (int)getuid();
2131 euid = (int)geteuid();
2132 gid = (int)getgid();
2133 egid = (int)getegid();
2138 tainting |= (uid && (euid != uid || egid != gid));
2146 croak("No %s allowed while running setuid", s);
2148 croak("No %s allowed while running setgid", s);
2154 curstash = debstash;
2155 dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
2157 DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
2158 DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
2159 DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
2160 DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
2161 sv_setiv(DBsingle, 0);
2162 DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
2163 sv_setiv(DBtrace, 0);
2164 DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
2165 sv_setiv(DBsignal, 0);
2166 curstash = defstash;
2173 mainstack = curstack; /* remember in case we switch stacks */
2174 AvREAL_off(curstack); /* not a real array */
2175 av_extend(curstack,127);
2177 stack_base = AvARRAY(curstack);
2178 stack_sp = stack_base;
2179 stack_max = stack_base + 127;
2181 cxstack_max = 8192 / sizeof(CONTEXT) - 2; /* Use most of 8K. */
2182 New(50,cxstack,cxstack_max + 1,CONTEXT);
2185 New(50,tmps_stack,128,SV*);
2190 New(51,debname,128,char);
2191 New(52,debdelim,128,char);
2195 * The following stacks almost certainly should be per-interpreter,
2196 * but for now they're not. XXX
2200 markstack_ptr = markstack;
2202 New(54,markstack,64,I32);
2203 markstack_ptr = markstack;
2204 markstack_max = markstack + 64;
2210 New(54,scopestack,32,I32);
2212 scopestack_max = 32;
2218 New(54,savestack,128,ANY);
2220 savestack_max = 128;
2226 New(54,retstack,16,OP*);
2236 Safefree(tmps_stack);
2243 static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
2251 subname = newSVpv("main",4);
2255 init_predump_symbols()
2260 sv_setpvn(GvSV(gv_fetchpv("\"", TRUE, SVt_PV)), " ", 1);
2262 stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
2263 GvMULTI_on(stdingv);
2264 IoIFP(GvIOp(stdingv)) = PerlIO_stdin();
2265 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
2267 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(stdingv));
2269 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
2271 IoOFP(GvIOp(tmpgv)) = IoIFP(GvIOp(tmpgv)) = PerlIO_stdout();
2273 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
2275 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(defoutgv));
2277 othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
2278 GvMULTI_on(othergv);
2279 IoOFP(GvIOp(othergv)) = IoIFP(GvIOp(othergv)) = PerlIO_stderr();
2280 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
2282 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(othergv));
2284 statname = NEWSV(66,0); /* last filename we did stat on */
2287 osname = savepv(OSNAME);
2291 init_postdump_symbols(argc,argv,env)
2293 register char **argv;
2294 register char **env;
2300 argc--,argv++; /* skip name of script */
2302 for (; argc > 0 && **argv == '-'; argc--,argv++) {
2305 if (argv[0][1] == '-') {
2309 if (s = strchr(argv[0], '=')) {
2311 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
2314 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
2317 toptarget = NEWSV(0,0);
2318 sv_upgrade(toptarget, SVt_PVFM);
2319 sv_setpvn(toptarget, "", 0);
2320 bodytarget = NEWSV(0,0);
2321 sv_upgrade(bodytarget, SVt_PVFM);
2322 sv_setpvn(bodytarget, "", 0);
2323 formtarget = bodytarget;
2326 if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
2327 sv_setpv(GvSV(tmpgv),origfilename);
2328 magicname("0", "0", 1);
2330 if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
2331 sv_setpv(GvSV(tmpgv),origargv[0]);
2332 if (argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
2334 (void)gv_AVadd(argvgv);
2335 av_clear(GvAVn(argvgv));
2336 for (; argc > 0; argc--,argv++) {
2337 av_push(GvAVn(argvgv),newSVpv(argv[0],0));
2340 if (envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
2344 hv_magic(hv, envgv, 'E');
2345 #ifndef VMS /* VMS doesn't have environ array */
2346 /* Note that if the supplied env parameter is actually a copy
2347 of the global environ then it may now point to free'd memory
2348 if the environment has been modified since. To avoid this
2349 problem we treat env==NULL as meaning 'use the default'
2354 environ[0] = Nullch;
2355 for (; *env; env++) {
2356 if (!(s = strchr(*env,'=')))
2362 sv = newSVpv(s--,0);
2363 (void)hv_store(hv, *env, s - *env, sv, 0);
2365 #if defined(__BORLANDC__) && defined(USE_WIN32_RTL_ENV)
2366 /* Sins of the RTL. See note in my_setenv(). */
2367 (void)putenv(savepv(*env));
2371 #ifdef DYNAMIC_ENV_FETCH
2372 HvNAME(hv) = savepv(ENV_HV_NAME);
2376 if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
2377 sv_setiv(GvSV(tmpgv), (IV)getpid());
2386 s = getenv("PERL5LIB");
2390 incpush(getenv("PERLLIB"), FALSE);
2392 /* Treat PERL5?LIB as a possible search list logical name -- the
2393 * "natural" VMS idiom for a Unix path string. We allow each
2394 * element to be a set of |-separated directories for compatibility.
2398 if (my_trnlnm("PERL5LIB",buf,0))
2399 do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
2401 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE);
2405 /* Use the ~-expanded versions of APPLLIB (undocumented),
2406 ARCHLIB PRIVLIB SITEARCH SITELIB and OLDARCHLIB
2409 incpush(APPLLIB_EXP, FALSE);
2413 incpush(ARCHLIB_EXP, FALSE);
2416 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
2418 incpush(PRIVLIB_EXP, FALSE);
2421 incpush(SITEARCH_EXP, FALSE);
2424 incpush(SITELIB_EXP, FALSE);
2426 #ifdef OLDARCHLIB_EXP /* 5.00[01] compatibility */
2427 incpush(OLDARCHLIB_EXP, FALSE);
2431 incpush(".", FALSE);
2435 # define PERLLIB_SEP ';'
2438 # define PERLLIB_SEP '|'
2440 # define PERLLIB_SEP ':'
2443 #ifndef PERLLIB_MANGLE
2444 # define PERLLIB_MANGLE(s,n) (s)
2448 incpush(p, addsubdirs)
2452 SV *subdir = Nullsv;
2453 static char *archpat_auto;
2460 if (!archpat_auto) {
2461 STRLEN len = (sizeof(ARCHNAME) + strlen(patchlevel)
2462 + sizeof("//auto"));
2463 New(55, archpat_auto, len, char);
2464 sprintf(archpat_auto, "/%s/%s/auto", ARCHNAME, patchlevel);
2466 for (len = sizeof(ARCHNAME) + 2;
2467 archpat_auto[len] != '\0' && archpat_auto[len] != '/'; len++)
2468 if (archpat_auto[len] == '.') archpat_auto[len] = '_';
2473 /* Break at all separators */
2475 SV *libdir = newSV(0);
2478 /* skip any consecutive separators */
2479 while ( *p == PERLLIB_SEP ) {
2480 /* Uncomment the next line for PATH semantics */
2481 /* av_push(GvAVn(incgv), newSVpv(".", 1)); */
2485 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
2486 sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
2491 sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
2492 p = Nullch; /* break out */
2496 * BEFORE pushing libdir onto @INC we may first push version- and
2497 * archname-specific sub-directories.
2500 struct stat tmpstatbuf;
2505 if ((unix = tounixspec_ts(SvPV(libdir,na),Nullch)) != Nullch) {
2507 while (unix[len-1] == '/') len--; /* Cosmetic */
2508 sv_usepvn(libdir,unix,len);
2511 PerlIO_printf(PerlIO_stderr(),
2512 "Failed to unixify @INC element \"%s\"\n",
2515 /* .../archname/version if -d .../archname/version/auto */
2516 sv_setsv(subdir, libdir);
2517 sv_catpv(subdir, archpat_auto);
2518 if (Stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2519 S_ISDIR(tmpstatbuf.st_mode))
2520 av_push(GvAVn(incgv),
2521 newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2523 /* .../archname if -d .../archname/auto */
2524 sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME),
2525 strlen(patchlevel) + 1, "", 0);
2526 if (Stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2527 S_ISDIR(tmpstatbuf.st_mode))
2528 av_push(GvAVn(incgv),
2529 newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2532 /* finally push this lib directory on the end of @INC */
2533 av_push(GvAVn(incgv), libdir);
2536 SvREFCNT_dec(subdir);
2540 call_list(oldscope, list)
2544 line_t oldline = curcop->cop_line;
2549 while (AvFILL(list) >= 0) {
2550 CV *cv = (CV*)av_shift(list);
2557 SV* atsv = GvSV(errgv);
2559 perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
2560 (void)SvPV(atsv, len);
2563 curcop = &compiling;
2564 curcop->cop_line = oldline;
2565 if (list == beginav)
2566 sv_catpv(atsv, "BEGIN failed--compilation aborted");
2568 sv_catpv(atsv, "END failed--cleanup aborted");
2569 while (scopestack_ix > oldscope)
2571 croak("%s", SvPVX(atsv));
2579 /* my_exit() was called */
2580 while (scopestack_ix > oldscope)
2582 curstash = defstash;
2584 call_list(oldscope, endav);
2587 curcop = &compiling;
2588 curcop->cop_line = oldline;
2590 if (list == beginav)
2591 croak("BEGIN failed--compilation aborted");
2593 croak("END failed--cleanup aborted");
2599 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
2604 curcop = &compiling;
2605 curcop->cop_line = oldline;
2624 STATUS_NATIVE_SET(status);
2634 if (vaxc$errno & 1) {
2635 if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
2636 STATUS_NATIVE_SET(44);
2639 if (!vaxc$errno && errno) /* unlikely */
2640 STATUS_NATIVE_SET(44);
2642 STATUS_NATIVE_SET(vaxc$errno);
2646 STATUS_POSIX_SET(errno);
2647 else if (STATUS_POSIX == 0)
2648 STATUS_POSIX_SET(255);
2656 register CONTEXT *cx;
2665 (void)UNLINK(e_tmpname);
2666 Safefree(e_tmpname);
2670 if (cxstack_ix >= 0) {