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);
889 call_list(oldscope, restartav);
899 else if (main_start) {
900 CvDEPTH(main_cv) = 1;
911 perl_get_sv(name, create)
915 GV* gv = gv_fetchpv(name, create, SVt_PV);
922 perl_get_av(name, create)
926 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
935 perl_get_hv(name, create)
939 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
948 perl_get_cv(name, create)
952 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
953 if (create && !GvCVu(gv))
954 return newSUB(start_subparse(FALSE, 0),
955 newSVOP(OP_CONST, 0, newSVpv(name,0)),
963 /* Be sure to refetch the stack pointer after calling these routines. */
966 perl_call_argv(subname, flags, argv)
968 I32 flags; /* See G_* flags in cop.h */
969 register char **argv; /* null terminated arg list */
976 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
981 return perl_call_pv(subname, flags);
985 perl_call_pv(subname, flags)
986 char *subname; /* name of the subroutine */
987 I32 flags; /* See G_* flags in cop.h */
989 return perl_call_sv((SV*)perl_get_cv(subname, TRUE), flags);
993 perl_call_method(methname, flags)
994 char *methname; /* name of the subroutine */
995 I32 flags; /* See G_* flags in cop.h */
1001 XPUSHs(sv_2mortal(newSVpv(methname,0)));
1004 return perl_call_sv(*stack_sp--, flags);
1007 /* May be called with any of a CV, a GV, or an SV containing the name. */
1009 perl_call_sv(sv, flags)
1011 I32 flags; /* See G_* flags in cop.h */
1013 LOGOP myop; /* fake syntax tree node */
1019 bool oldcatch = CATCH_GET;
1023 if (flags & G_DISCARD) {
1028 Zero(&myop, 1, LOGOP);
1029 myop.op_next = Nullop;
1030 if (!(flags & G_NOARGS))
1031 myop.op_flags |= OPf_STACKED;
1032 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1033 (flags & G_ARRAY) ? OPf_WANT_LIST :
1038 EXTEND(stack_sp, 1);
1041 oldscope = scopestack_ix;
1043 if (perldb && curstash != debstash
1044 /* Handle first BEGIN of -d. */
1045 && (DBcv || (DBcv = GvCV(DBsub)))
1046 /* Try harder, since this may have been a sighandler, thus
1047 * curstash may be meaningless. */
1048 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != debstash))
1049 op->op_private |= OPpENTERSUB_DB;
1051 if (flags & G_EVAL) {
1052 cLOGOP->op_other = op;
1054 /* we're trying to emulate pp_entertry() here */
1056 register CONTEXT *cx;
1057 I32 gimme = GIMME_V;
1062 push_return(op->op_next);
1063 PUSHBLOCK(cx, CXt_EVAL, stack_sp);
1065 eval_root = op; /* Only needed so that goto works right. */
1068 if (flags & G_KEEPERR)
1071 sv_setpv(GvSV(errgv),"");
1083 /* my_exit() was called */
1084 curstash = defstash;
1088 croak("Callback called exit");
1097 stack_sp = stack_base + oldmark;
1098 if (flags & G_ARRAY)
1102 *++stack_sp = &sv_undef;
1110 if (op == (OP*)&myop)
1114 retval = stack_sp - (stack_base + oldmark);
1115 if ((flags & G_EVAL) && !(flags & G_KEEPERR))
1116 sv_setpv(GvSV(errgv),"");
1119 if (flags & G_EVAL) {
1120 if (scopestack_ix > oldscope) {
1124 register CONTEXT *cx;
1136 CATCH_SET(oldcatch);
1138 if (flags & G_DISCARD) {
1139 stack_sp = stack_base + oldmark;
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, '/') && (s = getenv("PATH"))) {
1660 bufend = s + strlen(s);
1661 while (s < bufend) {
1663 s = delimcpy(tokenbuf, tokenbuf + sizeof tokenbuf, s, bufend,
1671 for (len = 0; *s && *s != ',' && *s != ';'; len++, s++) {
1672 if (len < sizeof tokenbuf)
1675 if (len < sizeof tokenbuf)
1676 tokenbuf[len] = '\0';
1677 #endif /* atarist */
1680 if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tokenbuf)
1681 continue; /* don't search dir with too-long name */
1683 #if defined(atarist) && !defined(DOSISH)
1684 && tokenbuf[len - 1] != '/'
1686 #if defined(atarist) || defined(DOSISH)
1687 && tokenbuf[len - 1] != '\\'
1690 tokenbuf[len++] = '/';
1691 (void)strcpy(tokenbuf + len, scriptname);
1695 len = strlen(tokenbuf);
1696 if (extidx > 0) /* reset after previous loop */
1700 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tokenbuf));
1701 retval = Stat(tokenbuf,&statbuf);
1703 } while ( retval < 0 /* not there */
1704 && extidx>=0 && ext[extidx] /* try an extension? */
1705 && strcpy(tokenbuf+len, ext[extidx++])
1710 if (S_ISREG(statbuf.st_mode)
1711 && cando(S_IRUSR,TRUE,&statbuf)
1713 && cando(S_IXUSR,TRUE,&statbuf)
1717 xfound = tokenbuf; /* bingo! */
1721 xfailed = savepv(tokenbuf);
1724 croak("Can't execute %s", xfailed ? xfailed : scriptname );
1727 scriptname = xfound;
1730 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
1731 char *s = scriptname + 8;
1740 origfilename = savepv(e_tmpname ? "-e" : scriptname);
1741 curcop->cop_filegv = gv_fetchfile(origfilename);
1742 if (strEQ(origfilename,"-"))
1744 if (fdscript >= 0) {
1745 rsfp = PerlIO_fdopen(fdscript,"r");
1746 #if defined(HAS_FCNTL) && defined(F_SETFD)
1748 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
1751 else if (preprocess) {
1752 char *cpp_cfg = CPPSTDIN;
1753 SV *cpp = NEWSV(0,0);
1754 SV *cmd = NEWSV(0,0);
1756 if (strEQ(cpp_cfg, "cppstdin"))
1757 sv_catpvf(cpp, "%s/", BIN_EXP);
1758 sv_catpv(cpp, cpp_cfg);
1761 sv_catpv(sv,PRIVLIB_EXP);
1765 sed %s -e \"/^[^#]/b\" \
1766 -e \"/^#[ ]*include[ ]/b\" \
1767 -e \"/^#[ ]*define[ ]/b\" \
1768 -e \"/^#[ ]*if[ ]/b\" \
1769 -e \"/^#[ ]*ifdef[ ]/b\" \
1770 -e \"/^#[ ]*ifndef[ ]/b\" \
1771 -e \"/^#[ ]*else/b\" \
1772 -e \"/^#[ ]*elif[ ]/b\" \
1773 -e \"/^#[ ]*undef[ ]/b\" \
1774 -e \"/^#[ ]*endif/b\" \
1777 (doextract ? "-e \"1,/^#/d\n\"" : ""),
1780 %s %s -e '/^[^#]/b' \
1781 -e '/^#[ ]*include[ ]/b' \
1782 -e '/^#[ ]*define[ ]/b' \
1783 -e '/^#[ ]*if[ ]/b' \
1784 -e '/^#[ ]*ifdef[ ]/b' \
1785 -e '/^#[ ]*ifndef[ ]/b' \
1786 -e '/^#[ ]*else/b' \
1787 -e '/^#[ ]*elif[ ]/b' \
1788 -e '/^#[ ]*undef[ ]/b' \
1789 -e '/^#[ ]*endif/b' \
1797 (doextract ? "-e '1,/^#/d\n'" : ""),
1799 scriptname, cpp, sv, CPPMINUS);
1801 #ifdef IAMSUID /* actually, this is caught earlier */
1802 if (euid != uid && !euid) { /* if running suidperl */
1804 (void)seteuid(uid); /* musn't stay setuid root */
1807 (void)setreuid((Uid_t)-1, uid);
1809 #ifdef HAS_SETRESUID
1810 (void)setresuid((Uid_t)-1, uid, (Uid_t)-1);
1816 if (geteuid() != uid)
1817 croak("Can't do seteuid!\n");
1819 #endif /* IAMSUID */
1820 rsfp = my_popen(SvPVX(cmd), "r");
1824 else if (!*scriptname) {
1825 forbid_setid("program input from stdin");
1826 rsfp = PerlIO_stdin();
1829 rsfp = PerlIO_open(scriptname,"r");
1830 #if defined(HAS_FCNTL) && defined(F_SETFD)
1832 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
1840 #ifndef IAMSUID /* in case script is not readable before setuid */
1841 if (euid && Stat(SvPVX(GvSV(curcop->cop_filegv)),&statbuf) >= 0 &&
1842 statbuf.st_mode & (S_ISUID|S_ISGID)) {
1844 execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
1845 croak("Can't do setuid\n");
1849 croak("Can't open perl script \"%s\": %s\n",
1850 SvPVX(GvSV(curcop->cop_filegv)), Strerror(errno));
1855 validate_suid(validarg, scriptname)
1861 /* do we need to emulate setuid on scripts? */
1863 /* This code is for those BSD systems that have setuid #! scripts disabled
1864 * in the kernel because of a security problem. Merely defining DOSUID
1865 * in perl will not fix that problem, but if you have disabled setuid
1866 * scripts in the kernel, this will attempt to emulate setuid and setgid
1867 * on scripts that have those now-otherwise-useless bits set. The setuid
1868 * root version must be called suidperl or sperlN.NNN. If regular perl
1869 * discovers that it has opened a setuid script, it calls suidperl with
1870 * the same argv that it had. If suidperl finds that the script it has
1871 * just opened is NOT setuid root, it sets the effective uid back to the
1872 * uid. We don't just make perl setuid root because that loses the
1873 * effective uid we had before invoking perl, if it was different from the
1876 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
1877 * be defined in suidperl only. suidperl must be setuid root. The
1878 * Configure script will set this up for you if you want it.
1884 if (Fstat(PerlIO_fileno(rsfp),&statbuf) < 0) /* normal stat is insecure */
1885 croak("Can't stat script \"%s\"",origfilename);
1886 if (fdscript < 0 && statbuf.st_mode & (S_ISUID|S_ISGID)) {
1890 #ifndef HAS_SETREUID
1891 /* On this access check to make sure the directories are readable,
1892 * there is actually a small window that the user could use to make
1893 * filename point to an accessible directory. So there is a faint
1894 * chance that someone could execute a setuid script down in a
1895 * non-accessible directory. I don't know what to do about that.
1896 * But I don't think it's too important. The manual lies when
1897 * it says access() is useful in setuid programs.
1899 if (access(SvPVX(GvSV(curcop->cop_filegv)),1)) /*double check*/
1900 croak("Permission denied");
1902 /* If we can swap euid and uid, then we can determine access rights
1903 * with a simple stat of the file, and then compare device and
1904 * inode to make sure we did stat() on the same file we opened.
1905 * Then we just have to make sure he or she can execute it.
1908 struct stat tmpstatbuf;
1912 setreuid(euid,uid) < 0
1915 setresuid(euid,uid,(Uid_t)-1) < 0
1918 || getuid() != euid || geteuid() != uid)
1919 croak("Can't swap uid and euid"); /* really paranoid */
1920 if (Stat(SvPVX(GvSV(curcop->cop_filegv)),&tmpstatbuf) < 0)
1921 croak("Permission denied"); /* testing full pathname here */
1922 if (tmpstatbuf.st_dev != statbuf.st_dev ||
1923 tmpstatbuf.st_ino != statbuf.st_ino) {
1924 (void)PerlIO_close(rsfp);
1925 if (rsfp = my_popen("/bin/mail root","w")) { /* heh, heh */
1927 "User %ld tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
1928 (Filename of set-id script was %s, uid %ld gid %ld.)\n\nSincerely,\nperl\n",
1929 (long)uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
1930 (long)statbuf.st_dev, (long)statbuf.st_ino,
1931 SvPVX(GvSV(curcop->cop_filegv)),
1932 (long)statbuf.st_uid, (long)statbuf.st_gid);
1933 (void)my_pclose(rsfp);
1935 croak("Permission denied\n");
1939 setreuid(uid,euid) < 0
1941 # if defined(HAS_SETRESUID)
1942 setresuid(uid,euid,(Uid_t)-1) < 0
1945 || getuid() != uid || geteuid() != euid)
1946 croak("Can't reswap uid and euid");
1947 if (!cando(S_IXUSR,FALSE,&statbuf)) /* can real uid exec? */
1948 croak("Permission denied\n");
1950 #endif /* HAS_SETREUID */
1951 #endif /* IAMSUID */
1953 if (!S_ISREG(statbuf.st_mode))
1954 croak("Permission denied");
1955 if (statbuf.st_mode & S_IWOTH)
1956 croak("Setuid/gid script is writable by world");
1957 doswitches = FALSE; /* -s is insecure in suid */
1959 if (sv_gets(linestr, rsfp, 0) == Nullch ||
1960 strnNE(SvPV(linestr,na),"#!",2) ) /* required even on Sys V */
1961 croak("No #! line");
1962 s = SvPV(linestr,na)+2;
1964 while (!isSPACE(*s)) s++;
1965 for (s2 = s; (s2 > SvPV(linestr,na)+2 &&
1966 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
1967 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
1968 croak("Not a perl script");
1969 while (*s == ' ' || *s == '\t') s++;
1971 * #! arg must be what we saw above. They can invoke it by
1972 * mentioning suidperl explicitly, but they may not add any strange
1973 * arguments beyond what #! says if they do invoke suidperl that way.
1975 len = strlen(validarg);
1976 if (strEQ(validarg," PHOOEY ") ||
1977 strnNE(s,validarg,len) || !isSPACE(s[len]))
1978 croak("Args must match #! line");
1981 if (euid != uid && (statbuf.st_mode & S_ISUID) &&
1982 euid == statbuf.st_uid)
1984 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
1985 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
1986 #endif /* IAMSUID */
1988 if (euid) { /* oops, we're not the setuid root perl */
1989 (void)PerlIO_close(rsfp);
1992 execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
1994 croak("Can't do setuid\n");
1997 if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid) {
1999 (void)setegid(statbuf.st_gid);
2002 (void)setregid((Gid_t)-1,statbuf.st_gid);
2004 #ifdef HAS_SETRESGID
2005 (void)setresgid((Gid_t)-1,statbuf.st_gid,(Gid_t)-1);
2007 setgid(statbuf.st_gid);
2011 if (getegid() != statbuf.st_gid)
2012 croak("Can't do setegid!\n");
2014 if (statbuf.st_mode & S_ISUID) {
2015 if (statbuf.st_uid != euid)
2017 (void)seteuid(statbuf.st_uid); /* all that for this */
2020 (void)setreuid((Uid_t)-1,statbuf.st_uid);
2022 #ifdef HAS_SETRESUID
2023 (void)setresuid((Uid_t)-1,statbuf.st_uid,(Uid_t)-1);
2025 setuid(statbuf.st_uid);
2029 if (geteuid() != statbuf.st_uid)
2030 croak("Can't do seteuid!\n");
2032 else if (uid) { /* oops, mustn't run as root */
2034 (void)seteuid((Uid_t)uid);
2037 (void)setreuid((Uid_t)-1,(Uid_t)uid);
2039 #ifdef HAS_SETRESUID
2040 (void)setresuid((Uid_t)-1,(Uid_t)uid,(Uid_t)-1);
2046 if (geteuid() != uid)
2047 croak("Can't do seteuid!\n");
2050 if (!cando(S_IXUSR,TRUE,&statbuf))
2051 croak("Permission denied\n"); /* they can't do this */
2054 else if (preprocess)
2055 croak("-P not allowed for setuid/setgid script\n");
2056 else if (fdscript >= 0)
2057 croak("fd script not allowed in suidperl\n");
2059 croak("Script is not setuid/setgid in suidperl\n");
2061 /* We absolutely must clear out any saved ids here, so we */
2062 /* exec the real perl, substituting fd script for scriptname. */
2063 /* (We pass script name as "subdir" of fd, which perl will grok.) */
2064 PerlIO_rewind(rsfp);
2065 lseek(PerlIO_fileno(rsfp),(Off_t)0,0); /* just in case rewind didn't */
2066 for (which = 1; origargv[which] && origargv[which] != scriptname; which++) ;
2067 if (!origargv[which])
2068 croak("Permission denied");
2069 origargv[which] = savepv(form("/dev/fd/%d/%s",
2070 PerlIO_fileno(rsfp), origargv[which]));
2071 #if defined(HAS_FCNTL) && defined(F_SETFD)
2072 fcntl(PerlIO_fileno(rsfp),F_SETFD,0); /* ensure no close-on-exec */
2074 execv(form("%s/perl%s", BIN_EXP, patchlevel), origargv); /* try again */
2075 croak("Can't do setuid\n");
2076 #endif /* IAMSUID */
2078 if (euid != uid || egid != gid) { /* (suidperl doesn't exist, in fact) */
2079 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
2080 Fstat(PerlIO_fileno(rsfp),&statbuf); /* may be either wrapped or real suid */
2081 if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
2083 (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
2086 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2087 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2088 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
2089 /* not set-id, must be wrapped */
2097 register char *s, *s2;
2099 /* skip forward in input to the real script? */
2103 if ((s = sv_gets(linestr, rsfp, 0)) == Nullch)
2104 croak("No Perl script found in input\n");
2105 if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
2106 PerlIO_ungetc(rsfp, '\n'); /* to keep line count right */
2108 while (*s && !(isSPACE (*s) || *s == '#')) s++;
2110 while (*s == ' ' || *s == '\t') s++;
2112 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
2113 if (strnEQ(s2-4,"perl",4))
2115 while (s = moreswitches(s)) ;
2117 if (cddir && chdir(cddir) < 0)
2118 croak("Can't chdir to %s",cddir);
2126 uid = (int)getuid();
2127 euid = (int)geteuid();
2128 gid = (int)getgid();
2129 egid = (int)getegid();
2134 tainting |= (uid && (euid != uid || egid != gid));
2142 croak("No %s allowed while running setuid", s);
2144 croak("No %s allowed while running setgid", s);
2150 curstash = debstash;
2151 dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
2153 DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
2154 DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
2155 DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
2156 DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
2157 sv_setiv(DBsingle, 0);
2158 DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
2159 sv_setiv(DBtrace, 0);
2160 DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
2161 sv_setiv(DBsignal, 0);
2162 curstash = defstash;
2169 mainstack = curstack; /* remember in case we switch stacks */
2170 AvREAL_off(curstack); /* not a real array */
2171 av_extend(curstack,127);
2173 stack_base = AvARRAY(curstack);
2174 stack_sp = stack_base;
2175 stack_max = stack_base + 127;
2177 cxstack_max = 8192 / sizeof(CONTEXT) - 2; /* Use most of 8K. */
2178 New(50,cxstack,cxstack_max + 1,CONTEXT);
2181 New(50,tmps_stack,128,SV*);
2186 New(51,debname,128,char);
2187 New(52,debdelim,128,char);
2191 * The following stacks almost certainly should be per-interpreter,
2192 * but for now they're not. XXX
2196 markstack_ptr = markstack;
2198 New(54,markstack,64,I32);
2199 markstack_ptr = markstack;
2200 markstack_max = markstack + 64;
2206 New(54,scopestack,32,I32);
2208 scopestack_max = 32;
2214 New(54,savestack,128,ANY);
2216 savestack_max = 128;
2222 New(54,retstack,16,OP*);
2232 Safefree(tmps_stack);
2239 static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
2247 subname = newSVpv("main",4);
2251 init_predump_symbols()
2256 sv_setpvn(GvSV(gv_fetchpv("\"", TRUE, SVt_PV)), " ", 1);
2258 stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
2259 GvMULTI_on(stdingv);
2260 IoIFP(GvIOp(stdingv)) = PerlIO_stdin();
2261 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
2263 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(stdingv));
2265 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
2267 IoOFP(GvIOp(tmpgv)) = IoIFP(GvIOp(tmpgv)) = PerlIO_stdout();
2269 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
2271 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(defoutgv));
2273 othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
2274 GvMULTI_on(othergv);
2275 IoOFP(GvIOp(othergv)) = IoIFP(GvIOp(othergv)) = PerlIO_stderr();
2276 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
2278 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(othergv));
2280 statname = NEWSV(66,0); /* last filename we did stat on */
2283 osname = savepv(OSNAME);
2287 init_postdump_symbols(argc,argv,env)
2289 register char **argv;
2290 register char **env;
2296 argc--,argv++; /* skip name of script */
2298 for (; argc > 0 && **argv == '-'; argc--,argv++) {
2301 if (argv[0][1] == '-') {
2305 if (s = strchr(argv[0], '=')) {
2307 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
2310 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
2313 toptarget = NEWSV(0,0);
2314 sv_upgrade(toptarget, SVt_PVFM);
2315 sv_setpvn(toptarget, "", 0);
2316 bodytarget = NEWSV(0,0);
2317 sv_upgrade(bodytarget, SVt_PVFM);
2318 sv_setpvn(bodytarget, "", 0);
2319 formtarget = bodytarget;
2322 if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
2323 sv_setpv(GvSV(tmpgv),origfilename);
2324 magicname("0", "0", 1);
2326 if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
2327 sv_setpv(GvSV(tmpgv),origargv[0]);
2328 if (argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
2330 (void)gv_AVadd(argvgv);
2331 av_clear(GvAVn(argvgv));
2332 for (; argc > 0; argc--,argv++) {
2333 av_push(GvAVn(argvgv),newSVpv(argv[0],0));
2336 if (envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
2340 hv_magic(hv, envgv, 'E');
2341 #ifndef VMS /* VMS doesn't have environ array */
2342 /* Note that if the supplied env parameter is actually a copy
2343 of the global environ then it may now point to free'd memory
2344 if the environment has been modified since. To avoid this
2345 problem we treat env==NULL as meaning 'use the default'
2350 environ[0] = Nullch;
2351 for (; *env; env++) {
2352 if (!(s = strchr(*env,'=')))
2358 sv = newSVpv(s--,0);
2359 (void)hv_store(hv, *env, s - *env, sv, 0);
2363 #ifdef DYNAMIC_ENV_FETCH
2364 HvNAME(hv) = savepv(ENV_HV_NAME);
2368 if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
2369 sv_setiv(GvSV(tmpgv), (IV)getpid());
2378 s = getenv("PERL5LIB");
2382 incpush(getenv("PERLLIB"), FALSE);
2384 /* Treat PERL5?LIB as a possible search list logical name -- the
2385 * "natural" VMS idiom for a Unix path string. We allow each
2386 * element to be a set of |-separated directories for compatibility.
2390 if (my_trnlnm("PERL5LIB",buf,0))
2391 do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
2393 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE);
2397 /* Use the ~-expanded versions of APPLLIB (undocumented),
2398 ARCHLIB PRIVLIB SITEARCH SITELIB and OLDARCHLIB
2401 incpush(APPLLIB_EXP, FALSE);
2405 incpush(ARCHLIB_EXP, FALSE);
2408 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
2410 incpush(PRIVLIB_EXP, FALSE);
2413 incpush(SITEARCH_EXP, FALSE);
2416 incpush(SITELIB_EXP, FALSE);
2418 #ifdef OLDARCHLIB_EXP /* 5.00[01] compatibility */
2419 incpush(OLDARCHLIB_EXP, FALSE);
2423 incpush(".", FALSE);
2427 # define PERLLIB_SEP ';'
2430 # define PERLLIB_SEP '|'
2432 # define PERLLIB_SEP ':'
2435 #ifndef PERLLIB_MANGLE
2436 # define PERLLIB_MANGLE(s,n) (s)
2440 incpush(p, addsubdirs)
2444 SV *subdir = Nullsv;
2445 static char *archpat_auto;
2452 if (!archpat_auto) {
2453 STRLEN len = (sizeof(ARCHNAME) + strlen(patchlevel)
2454 + sizeof("//auto"));
2455 New(55, archpat_auto, len, char);
2456 sprintf(archpat_auto, "/%s/%s/auto", ARCHNAME, patchlevel);
2458 for (len = sizeof(ARCHNAME) + 2;
2459 archpat_auto[len] != '\0' && archpat_auto[len] != '/'; len++)
2460 if (archpat_auto[len] == '.') archpat_auto[len] = '_';
2465 /* Break at all separators */
2467 SV *libdir = newSV(0);
2470 /* skip any consecutive separators */
2471 while ( *p == PERLLIB_SEP ) {
2472 /* Uncomment the next line for PATH semantics */
2473 /* av_push(GvAVn(incgv), newSVpv(".", 1)); */
2477 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
2478 sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
2483 sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
2484 p = Nullch; /* break out */
2488 * BEFORE pushing libdir onto @INC we may first push version- and
2489 * archname-specific sub-directories.
2492 struct stat tmpstatbuf;
2497 if ((unix = tounixspec_ts(SvPV(libdir,na),Nullch)) != Nullch) {
2499 while (unix[len-1] == '/') len--; /* Cosmetic */
2500 sv_usepvn(libdir,unix,len);
2503 PerlIO_printf(PerlIO_stderr(),
2504 "Failed to unixify @INC element \"%s\"\n",
2507 /* .../archname/version if -d .../archname/version/auto */
2508 sv_setsv(subdir, libdir);
2509 sv_catpv(subdir, archpat_auto);
2510 if (Stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2511 S_ISDIR(tmpstatbuf.st_mode))
2512 av_push(GvAVn(incgv),
2513 newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2515 /* .../archname if -d .../archname/auto */
2516 sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME),
2517 strlen(patchlevel) + 1, "", 0);
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"));
2524 /* finally push this lib directory on the end of @INC */
2525 av_push(GvAVn(incgv), libdir);
2528 SvREFCNT_dec(subdir);
2532 call_list(oldscope, list)
2536 line_t oldline = curcop->cop_line;
2541 while (AvFILL(list) >= 0) {
2542 CV *cv = (CV*)av_shift(list);
2549 SV* atsv = GvSV(errgv);
2551 perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
2552 (void)SvPV(atsv, len);
2555 curcop = &compiling;
2556 curcop->cop_line = oldline;
2557 if (list == beginav)
2558 sv_catpv(atsv, "BEGIN failed--compilation aborted");
2560 sv_catpv(atsv, "END failed--cleanup aborted");
2561 while (scopestack_ix > oldscope)
2563 croak("%s", SvPVX(atsv));
2571 /* my_exit() was called */
2572 while (scopestack_ix > oldscope)
2574 curstash = defstash;
2576 call_list(oldscope, endav);
2579 curcop = &compiling;
2580 curcop->cop_line = oldline;
2582 if (list == beginav)
2583 croak("BEGIN failed--compilation aborted");
2585 croak("END failed--cleanup aborted");
2591 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
2596 curcop = &compiling;
2597 curcop->cop_line = oldline;
2616 STATUS_NATIVE_SET(status);
2626 if (vaxc$errno & 1) {
2627 if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
2628 STATUS_NATIVE_SET(44);
2631 if (!vaxc$errno && errno) /* unlikely */
2632 STATUS_NATIVE_SET(44);
2634 STATUS_NATIVE_SET(vaxc$errno);
2638 STATUS_POSIX_SET(errno);
2639 else if (STATUS_POSIX == 0)
2640 STATUS_POSIX_SET(255);
2648 register CONTEXT *cx;
2657 (void)UNLINK(e_tmpname);
2658 Safefree(e_tmpname);
2662 if (cxstack_ix >= 0) {