3 * Copyright (c) 1987-1996 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 dEXTCONST char rcsid[] = "perl.c\nPatch level: ###\n";
31 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
41 curcop = &compiling; \
48 laststype = OP_STAT; \
50 maxsysfd = MAXSYSFD; \
57 laststype = OP_STAT; \
60 static void find_beginning _((void));
61 static void forbid_setid _((char *));
62 static void incpush _((char *));
63 static void init_ids _((void));
64 static void init_debugger _((void));
65 static void init_lexer _((void));
66 static void init_main_stash _((void));
67 static void init_perllib _((void));
68 static void init_postdump_symbols _((int, char **, char **));
69 static void init_predump_symbols _((void));
70 static void init_stacks _((void));
71 static void nuke_stacks _((void));
72 static void open_script _((char *, bool, SV *));
73 static void usage _((char *));
74 static void validate_suid _((char *, char*));
76 static int fdscript = -1;
81 PerlInterpreter *sv_interp;
84 New(53, sv_interp, 1, PerlInterpreter);
89 perl_construct( sv_interp )
90 register PerlInterpreter *sv_interp;
92 if (!(curinterp = sv_interp))
96 Zero(sv_interp, 1, PerlInterpreter);
99 /* Init the real globals? */
101 linestr = NEWSV(65,80);
102 sv_upgrade(linestr,SVt_PVIV);
104 if (!SvREADONLY(&sv_undef)) {
105 SvREADONLY_on(&sv_undef);
109 SvREADONLY_on(&sv_no);
111 sv_setpv(&sv_yes,Yes);
113 SvREADONLY_on(&sv_yes);
116 nrs = newSVpv("\n", 1);
117 rs = SvREFCNT_inc(nrs);
121 * There is no way we can refer to them from Perl so close them to save
122 * space. The other alternative would be to provide STDAUX and STDPRN
125 (void)fclose(stdaux);
126 (void)fclose(stdprn);
132 perl_destruct_level = 1;
134 if(perl_destruct_level > 0)
140 SET_NUMERIC_STANDARD();
141 #if defined(SUBVERSION) && SUBVERSION > 0
142 sprintf(patchlevel, "%7.5f", (double) 5
143 + ((double) PATCHLEVEL / (double) 1000)
144 + ((double) SUBVERSION / (double) 100000));
146 sprintf(patchlevel, "%5.3f", (double) 5 +
147 ((double) PATCHLEVEL / (double) 1000));
150 #if defined(LOCAL_PATCH_COUNT)
151 localpatches = local_patches; /* For possible -v */
154 PerlIO_init(); /* Hook to IO system */
156 fdpid = newAV(); /* for remembering popen pids by fd */
157 pidstatus = newHV();/* for remembering status of dead pids */
164 perl_destruct(sv_interp)
165 register PerlInterpreter *sv_interp;
167 int destruct_level; /* 0=none, 1=full, 2=full with checks */
171 if (!(curinterp = sv_interp))
174 destruct_level = perl_destruct_level;
178 if (s = getenv("PERL_DESTRUCT_LEVEL")) {
180 if (destruct_level < i)
186 /* unhook hooks which will soon be, or use, destroyed data */
187 SvREFCNT_dec(warnhook);
189 SvREFCNT_dec(diehook);
191 SvREFCNT_dec(parsehook);
197 /* We must account for everything. First the syntax tree. */
199 curpad = AvARRAY(comppad);
205 * Try to destruct global references. We do this first so that the
206 * destructors and destructees still exist. Some sv's might remain.
207 * Non-referenced objects are on their own.
214 if (destruct_level == 0){
216 DEBUG_P(debprofdump());
218 /* The exit() function will do everything that needs doing. */
222 /* loosen bonds of global variables */
225 (void)PerlIO_close(rsfp);
229 /* Filters for program text */
230 SvREFCNT_dec(rsfp_filters);
231 rsfp_filters = Nullav;
243 sawampersand = FALSE; /* must save all match strings */
244 sawstudy = FALSE; /* do fbm_instr on all strings */
259 /* magical thingies */
261 Safefree(ofs); /* $, */
264 Safefree(ors); /* $\ */
267 SvREFCNT_dec(nrs); /* $\ helper */
270 multiline = 0; /* $* */
272 SvREFCNT_dec(statname);
276 /* defgv, aka *_ should be taken care of elsewhere */
278 #if 0 /* just about all regexp stuff, seems to be ok */
280 /* shortcuts to regexp stuff */
285 SAVEFREEOP(oldlastpm); /* for saving regexp context during debugger */
287 regprecomp = NULL; /* uncompiled string. */
288 regparse = NULL; /* Input-scan pointer. */
289 regxend = NULL; /* End of input for compile */
290 regnpar = 0; /* () count. */
291 regcode = NULL; /* Code-emit pointer; ®dummy = don't. */
292 regsize = 0; /* Code size. */
293 regnaughty = 0; /* How bad is this pattern? */
294 regsawback = 0; /* Did we see \1, ...? */
296 reginput = NULL; /* String-input pointer. */
297 regbol = NULL; /* Beginning of input, for ^ check. */
298 regeol = NULL; /* End of input, for $ check. */
299 regstartp = (char **)NULL; /* Pointer to startp array. */
300 regendp = (char **)NULL; /* Ditto for endp. */
301 reglastparen = 0; /* Similarly for lastparen. */
302 regtill = NULL; /* How far we are required to go. */
303 regflags = 0; /* are we folding, multilining? */
304 regprev = (char)NULL; /* char before regbol, \n if none */
308 /* clean up after study() */
309 SvREFCNT_dec(lastscream);
311 Safefree(screamfirst);
313 Safefree(screamnext);
316 /* startup and shutdown function lists */
317 SvREFCNT_dec(beginav);
322 /* pid-to-status mappings for waitpid */
323 SvREFCNT_dec(pidstatus);
326 /* temp stack during pp_sort() */
327 SvREFCNT_dec(sortstack);
330 /* shortcuts just get cleared */
340 /* reset so print() ends up where we expect */
343 /* Prepare to destruct main symbol table. */
350 if (destruct_level >= 2) {
351 if (scopestack_ix != 0)
352 warn("Unbalanced scopes: %d more ENTERs than LEAVEs\n", scopestack_ix);
353 if (savestack_ix != 0)
354 warn("Unbalanced saves: %d more saves than restores\n", savestack_ix);
355 if (tmps_floor != -1)
356 warn("Unbalanced tmps: %d more allocs than frees\n", tmps_floor + 1);
357 if (cxstack_ix != -1)
358 warn("Unbalanced context: %d more PUSHes than POPs\n", cxstack_ix + 1);
361 /* Now absolutely destruct everything, somehow or other, loops or no. */
363 SvFLAGS(strtab) |= SVTYPEMASK; /* don't clean out strtab now */
364 while (sv_count != 0 && sv_count != last_sv_count) {
365 last_sv_count = sv_count;
368 SvFLAGS(strtab) &= ~SVTYPEMASK;
369 SvFLAGS(strtab) |= SVt_PVHV;
371 /* Destruct the global string table. */
373 /* Yell and reset the HeVAL() slots that are still holding refcounts,
374 * so that sv_free() won't fail on them.
383 array = HvARRAY(strtab);
387 warn("Unbalanced string table refcount: (%d) for \"%s\"",
388 HeVAL(hent) - Nullsv, HeKEY(hent));
389 HeVAL(hent) = Nullsv;
399 SvREFCNT_dec(strtab);
402 warn("Scalars leaked: %d\n", sv_count);
406 linestr = NULL; /* No SVs have survived, need to clean out */
408 Safefree(origfilename);
410 hints = 0; /* Reset hints. Should hints be per-interpreter ? */
412 DEBUG_P(debprofdump());
417 PerlInterpreter *sv_interp;
419 if (!(curinterp = sv_interp))
423 #if !defined(STANDARD_C) && !defined(HAS_GETENV_PROTOTYPE)
424 char *getenv _((char *)); /* Usually in <stdlib.h> */
428 perl_parse(sv_interp, xsinit, argc, argv, env)
429 PerlInterpreter *sv_interp;
430 void (*xsinit)_((void));
437 char *scriptname = NULL;
438 VOL bool dosearch = FALSE;
442 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
445 croak("suidperl is no longer needed since the kernel can now execute\n\
446 setuid perl scripts securely.\n");
450 if (!(curinterp = sv_interp))
453 #if defined(NeXT) && defined(__DYNAMIC__)
454 _dyld_lookup_and_bind
455 ("__environ", (unsigned long *) &environ_pointer, NULL);
460 #ifndef VMS /* VMS doesn't have environ array */
461 origenviron = environ;
467 /* Come here if running an undumped a.out. */
469 origfilename = savepv(argv[0]);
471 cxstack_ix = -1; /* start label stack again */
473 init_postdump_symbols(argc,argv,env);
481 switch (Sigsetjmp(top_env,1)) {
492 return(statusvalue); /* my_exit() was called */
494 PerlIO_printf(PerlIO_stderr(), "panic: top_env\n");
498 sv_setpvn(linestr,"",0);
499 sv = newSVpv("",0); /* first used for -I flags */
502 for (argc--,argv++; argc > 0; argc--,argv++) {
503 if (argv[0][0] != '-' || !argv[0][1])
507 validarg = " PHOOEY ";
533 if (s = moreswitches(s))
538 if (euid != uid || egid != gid)
539 croak("No -e allowed in setuid scripts");
541 e_tmpname = savepv(TMPPATH);
542 (void)mktemp(e_tmpname);
544 croak("Can't mktemp()");
545 e_fp = PerlIO_open(e_tmpname,"w");
547 croak("Cannot open temporary file");
552 PerlIO_puts(e_fp,argv[1]);
556 croak("No code specified for -e");
557 (void)PerlIO_putc(e_fp,'\n');
565 av_push(GvAVn(incgv),newSVpv(s,0));
568 av_push(GvAVn(incgv),newSVpv(argv[1],0));
569 sv_catpv(sv,argv[1]);
586 preambleav = newAV();
587 av_push(preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
589 Sv = newSVpv("print myconfig();",0);
591 sv_catpv(Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
593 sv_catpv(Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
595 #if defined(DEBUGGING) || defined(NOEMBED) || defined(MULTIPLICITY)
596 strcpy(buf,"\" Compile-time options:");
598 strcat(buf," DEBUGGING");
601 strcat(buf," NOEMBED");
604 strcat(buf," MULTIPLICITY");
606 strcat(buf,"\\n\",");
609 #if defined(LOCAL_PATCH_COUNT)
610 if (LOCAL_PATCH_COUNT > 0)
612 sv_catpv(Sv,"print \" Locally applied patches:\\n\",");
613 for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
614 if (localpatches[i]) {
615 sprintf(buf,"\" \\t%s\\n\",",localpatches[i]);
621 sprintf(buf,"\" Built under %s\\n\",",OSNAME);
625 sprintf(buf,"\" Compiled at %s %s\\n\"",__DATE__,__TIME__);
627 sprintf(buf,"\" Compiled on %s\\n\"",__DATE__);
631 sv_catpv(Sv,"; $\"=\"\\n \"; print \" \\@INC:\\n @INC\\n\"");
634 Sv = newSVpv("config_vars(qw(",0);
639 av_push(preambleav, Sv);
640 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
654 croak("Unrecognized switch: -%s",s);
659 scriptname = argv[0];
661 if (PerlIO_flush(e_fp) || PerlIO_error(e_fp) || PerlIO_close(e_fp))
662 croak("Can't write to temp file for -e: %s", Strerror(errno));
665 scriptname = e_tmpname;
667 else if (scriptname == Nullch) {
669 if ( isatty(PerlIO_fileno(PerlIO_stdin())) )
677 open_script(scriptname,dosearch,sv);
679 validate_suid(validarg, scriptname);
684 compcv = (CV*)NEWSV(1104,0);
685 sv_upgrade((SV *)compcv, SVt_PVCV);
689 av_push(comppad, Nullsv);
690 curpad = AvARRAY(comppad);
691 comppad_name = newAV();
692 comppad_name_fill = 0;
693 min_intro_pending = 0;
696 comppadlist = newAV();
697 AvREAL_off(comppadlist);
698 av_store(comppadlist, 0, (SV*)comppad_name);
699 av_store(comppadlist, 1, (SV*)comppad);
700 CvPADLIST(compcv) = comppadlist;
702 boot_core_UNIVERSAL();
704 (*xsinit)(); /* in case linked C routines want magical variables */
709 init_predump_symbols();
711 init_postdump_symbols(argc,argv,env);
715 /* now parse the script */
718 if (yyparse() || error_count) {
720 croak("%s had compilation errors.\n", origfilename);
722 croak("Execution of %s aborted due to compilation errors.\n",
726 curcop->cop_line = 0;
730 (void)UNLINK(e_tmpname);
735 /* now that script is parsed, we can modify record separator */
737 rs = SvREFCNT_inc(nrs);
738 sv_setsv(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), rs);
749 #ifdef DEBUGGING_MSTATS
750 if ((s=getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
751 dump_mstats("after compilation:");
761 PerlInterpreter *sv_interp;
763 if (!(curinterp = sv_interp))
765 switch (Sigsetjmp(top_env,1)) {
767 cxstack_ix = -1; /* start context stack again */
774 #ifdef DEBUGGING_MSTATS
775 if (getenv("PERL_DEBUG_MSTATS"))
776 dump_mstats("after execution: ");
778 return(statusvalue); /* my_exit() was called */
781 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
785 if (curstack != mainstack) {
787 SWITCHSTACK(curstack, mainstack);
792 DEBUG_r(PerlIO_printf(PerlIO_stderr(), "%s $` $& $' support.\n",
793 sawampersand ? "Enabling" : "Omitting"));
797 DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
800 PerlIO_printf(PerlIO_stderr(), "%s syntax OK\n", origfilename);
803 if (perldb && DBsingle)
804 sv_setiv(DBsingle, 1);
814 else if (main_start) {
827 register CONTEXT *cx;
831 statusvalue = FIXSTATUS(status);
832 if (cxstack_ix >= 0) {
838 Siglongjmp(top_env, 2);
842 perl_get_sv(name, create)
846 GV* gv = gv_fetchpv(name, create, SVt_PV);
853 perl_get_av(name, create)
857 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
866 perl_get_hv(name, create)
870 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
879 perl_get_cv(name, create)
883 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
884 if (create && !GvCVu(gv))
885 return newSUB(start_subparse(),
886 newSVOP(OP_CONST, 0, newSVpv(name,0)),
894 /* Be sure to refetch the stack pointer after calling these routines. */
897 perl_call_argv(subname, flags, argv)
899 I32 flags; /* See G_* flags in cop.h */
900 register char **argv; /* null terminated arg list */
907 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
912 return perl_call_pv(subname, flags);
916 perl_call_pv(subname, flags)
917 char *subname; /* name of the subroutine */
918 I32 flags; /* See G_* flags in cop.h */
920 return perl_call_sv((SV*)perl_get_cv(subname, TRUE), flags);
924 perl_call_method(methname, flags)
925 char *methname; /* name of the subroutine */
926 I32 flags; /* See G_* flags in cop.h */
932 XPUSHs(sv_2mortal(newSVpv(methname,0)));
935 return perl_call_sv(*stack_sp--, flags);
938 /* May be called with any of a CV, a GV, or an SV containing the name. */
940 perl_call_sv(sv, flags)
942 I32 flags; /* See G_* flags in cop.h */
944 LOGOP myop; /* fake syntax tree node */
946 I32 oldmark = TOPMARK;
952 if (flags & G_DISCARD) {
962 oldscope = scopestack_ix;
964 if (!(flags & G_NOARGS))
965 myop.op_flags = OPf_STACKED;
966 myop.op_next = Nullop;
967 myop.op_flags |= OPf_KNOW;
969 myop.op_flags |= OPf_LIST;
971 if (perldb && curstash != debstash
972 /* Handle first BEGIN of -d. */
973 && (DBcv || (DBcv = GvCV(DBsub)))
974 /* Try harder, since this may have been a sighandler, thus
975 * curstash may be meaningless. */
976 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != debstash))
977 op->op_private |= OPpENTERSUB_DB;
979 if (flags & G_EVAL) {
980 Copy(top_env, oldtop, 1, Sigjmp_buf);
982 cLOGOP->op_other = op;
984 /* we're trying to emulate pp_entertry() here */
986 register CONTEXT *cx;
992 push_return(op->op_next);
993 PUSHBLOCK(cx, CXt_EVAL, stack_sp);
995 eval_root = op; /* Only needed so that goto works right. */
998 if (flags & G_KEEPERR)
1001 sv_setpv(GvSV(errgv),"");
1006 switch (Sigsetjmp(top_env,1)) {
1011 statusvalue = 255; /* XXX I don't think we use 1 anymore. */
1017 /* my_exit() was called */
1018 curstash = defstash;
1020 Copy(oldtop, top_env, 1, Sigjmp_buf);
1022 croak("Callback called exit");
1023 my_exit(statusvalue);
1031 stack_sp = stack_base + oldmark;
1032 if (flags & G_ARRAY)
1036 *++stack_sp = &sv_undef;
1042 if (op == (OP*)&myop)
1046 retval = stack_sp - (stack_base + oldmark);
1047 if ((flags & G_EVAL) && !(flags & G_KEEPERR))
1048 sv_setpv(GvSV(errgv),"");
1051 if (flags & G_EVAL) {
1052 if (scopestack_ix > oldscope) {
1056 register CONTEXT *cx;
1065 Copy(oldtop, top_env, 1, Sigjmp_buf);
1067 if (flags & G_DISCARD) {
1068 stack_sp = stack_base + oldmark;
1076 /* Eval a string. The G_EVAL flag is always assumed. */
1079 perl_eval_sv(sv, flags)
1081 I32 flags; /* See G_* flags in cop.h */
1083 UNOP myop; /* fake syntax tree node */
1085 I32 oldmark = sp - stack_base;
1090 if (flags & G_DISCARD) {
1098 EXTEND(stack_sp, 1);
1100 oldscope = scopestack_ix;
1102 if (!(flags & G_NOARGS))
1103 myop.op_flags = OPf_STACKED;
1104 myop.op_next = Nullop;
1105 myop.op_type = OP_ENTEREVAL;
1106 myop.op_flags |= OPf_KNOW;
1107 if (flags & G_KEEPERR)
1108 myop.op_flags |= OPf_SPECIAL;
1109 if (flags & G_ARRAY)
1110 myop.op_flags |= OPf_LIST;
1112 Copy(top_env, oldtop, 1, Sigjmp_buf);
1115 switch (Sigsetjmp(top_env,1)) {
1120 statusvalue = 255; /* XXX I don't think we use 1 anymore. */
1126 /* my_exit() was called */
1127 curstash = defstash;
1129 Copy(oldtop, top_env, 1, Sigjmp_buf);
1131 croak("Callback called exit");
1132 my_exit(statusvalue);
1140 stack_sp = stack_base + oldmark;
1141 if (flags & G_ARRAY)
1145 *++stack_sp = &sv_undef;
1150 if (op == (OP*)&myop)
1151 op = pp_entereval();
1154 retval = stack_sp - (stack_base + oldmark);
1155 if (!(flags & G_KEEPERR))
1156 sv_setpv(GvSV(errgv),"");
1159 Copy(oldtop, top_env, 1, Sigjmp_buf);
1160 if (flags & G_DISCARD) {
1161 stack_sp = stack_base + oldmark;
1169 /* Require a module. */
1175 SV* sv = sv_newmortal();
1176 sv_setpv(sv, "require '");
1179 perl_eval_sv(sv, G_DISCARD);
1183 magicname(sym,name,namlen)
1190 if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
1191 sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
1195 # define PERLLIB_SEP ';'
1198 # define PERLLIB_SEP '|'
1200 # define PERLLIB_SEP ':'
1203 #ifndef PERLLIB_MANGLE
1204 # define PERLLIB_MANGLE(s,n) (s)
1216 /* Break at all separators */
1218 /* First, skip any consecutive separators */
1219 while ( *p == PERLLIB_SEP ) {
1220 /* Uncomment the next line for PATH semantics */
1221 /* av_push(GvAVn(incgv), newSVpv(".", 1)); */
1224 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
1225 av_push(GvAVn(incgv), newSVpv(PERLLIB_MANGLE(p, (STRLEN)(s - p)),
1229 av_push(GvAVn(incgv), newSVpv(PERLLIB_MANGLE(p, 0), 0));
1236 usage(name) /* XXX move this out into a module ? */
1239 /* This message really ought to be max 23 lines.
1240 * Removed -h because the user already knows that opton. Others? */
1241 printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
1242 printf("\n -0[octal] specify record separator (\\0, if no argument)");
1243 printf("\n -a autosplit mode with -n or -p (splits $_ into @F)");
1244 printf("\n -c check syntax only (runs BEGIN and END blocks)");
1245 printf("\n -d[:debugger] run scripts under debugger");
1246 printf("\n -D[number/list] set debugging flags (argument is a bit mask or flags)");
1247 printf("\n -e 'command' one line of script. Several -e's allowed. Omit [programfile].");
1248 printf("\n -F/pattern/ split() pattern for autosplit (-a). The //'s are optional.");
1249 printf("\n -i[extension] edit <> files in place (make backup if extension supplied)");
1250 printf("\n -Idirectory specify @INC/#include directory (may be used more then once)");
1251 printf("\n -l[octal] enable line ending processing, specifies line teminator");
1252 printf("\n -[mM][-]module.. executes `use/no module...' before executing your script.");
1253 printf("\n -n assume 'while (<>) { ... }' loop arround your script");
1254 printf("\n -p assume loop like -n but print line also like sed");
1255 printf("\n -P run script through C preprocessor before compilation");
1256 printf("\n -s enable some switch parsing for switches after script name");
1257 printf("\n -S look for the script using PATH environment variable");
1258 printf("\n -T turn on tainting checks");
1259 printf("\n -u dump core after parsing script");
1260 printf("\n -U allow unsafe operations");
1261 printf("\n -v print version number and patchlevel of perl");
1262 printf("\n -V[:variable] print perl configuration information");
1263 printf("\n -w TURN WARNINGS ON FOR COMPILATION OF YOUR SCRIPT.");
1264 printf("\n -x[directory] strip off text before #!perl line and perhaps cd to directory\n");
1267 /* This routine handles any switches that can be given during run */
1278 rschar = scan_oct(s, 4, &numlen);
1280 if (rschar & ~((U8)~0))
1282 else if (!rschar && numlen >= 2)
1283 nrs = newSVpv("", 0);
1286 nrs = newSVpv(&ch, 1);
1291 splitstr = savepv(s + 1);
1305 if (*s == ':' || *s == '=') {
1306 sprintf(buf, "use Devel::%s;", ++s);
1308 my_setenv("PERL5DB",buf);
1318 if (isALPHA(s[1])) {
1319 static char debopts[] = "psltocPmfrxuLHXD";
1322 for (s++; *s && (d = strchr(debopts,*s)); s++)
1323 debug |= 1 << (d - debopts);
1327 for (s++; isDIGIT(*s); s++) ;
1329 debug |= 0x80000000;
1331 warn("Recompile perl with -DDEBUGGING to use -D switch\n");
1332 for (s++; isALNUM(*s); s++) ;
1342 inplace = savepv(s+1);
1344 for (s = inplace; *s && !isSPACE(*s); s++) ;
1351 for (e = s; *e && !isSPACE(*e); e++) ;
1352 av_push(GvAVn(incgv),newSVpv(s,e-s));
1357 croak("No space allowed after -I");
1367 *ors = scan_oct(s, 3 + (*s == '0'), &numlen);
1376 ors = SvPV(nrs, orslen);
1377 ors = savepvn(ors, orslen);
1381 forbid_setid("-M"); /* XXX ? */
1384 forbid_setid("-m"); /* XXX ? */
1388 /* -M-foo == 'no foo' */
1389 if (*s == '-') { use = "no "; ++s; }
1390 Sv = newSVpv(use,0);
1392 /* We allow -M'Module qw(Foo Bar)' */
1393 while(isALNUM(*s) || *s==':') ++s;
1395 sv_catpv(Sv, start);
1396 if (*(start-1) == 'm') {
1398 croak("Can't use '%c' after -mname", *s);
1399 sv_catpv( Sv, " ()");
1402 sv_catpvn(Sv, start, s-start);
1403 sv_catpv(Sv, " split(/,/,q{");
1408 if (preambleav == NULL)
1409 preambleav = newAV();
1410 av_push(preambleav, Sv);
1413 croak("No space allowed after -%c", *(s-1));
1441 #if defined(SUBVERSION) && SUBVERSION > 0
1442 printf("\nThis is perl, version 5.%03d_%02d", PATCHLEVEL, SUBVERSION);
1444 printf("\nThis is perl, version %s",patchlevel);
1447 printf("\n\nCopyright 1987-1996, Larry Wall\n");
1448 printf("\n\t+ suidperl security patch");
1450 printf("\n\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
1453 printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n");
1456 printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
1457 "Version 5 port Copyright (c) 1994-1996, Andreas Kaiser, Ilya Zakharevich\n");
1460 printf("atariST series port, ++jrb bammi@cadence.com\n");
1463 Perl may be copied only under the terms of either the Artistic License or the\n\
1464 GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n");
1472 if (s[1] == '-') /* Additional switches on #! line. */
1485 croak("Can't emulate -%.1s on #! line",s);
1490 /* compliments of Tom Christiansen */
1492 /* unexec() can be found in the Gnu emacs distribution */
1501 sprintf (buf, "%s.perldump", origfilename);
1502 sprintf (tokenbuf, "%s/perl", BIN);
1504 status = unexec(buf, tokenbuf, &etext, sbrk(0), 0);
1506 PerlIO_printf(PerlIO_stderr(), "unexec of %s into %s failed!\n", tokenbuf, buf);
1510 # include <lib$routines.h>
1511 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
1513 ABORT(); /* for use with undump */
1523 /* Note that strtab is a rather special HV. Assumptions are made
1524 about not iterating on it, and not adding tie magic to it.
1525 It is properly deallocated in perl_destruct() */
1527 HvSHAREKEYS_off(strtab); /* mandatory */
1528 Newz(506,((XPVHV*)SvANY(strtab))->xhv_array,
1529 sizeof(HE*) * (((XPVHV*)SvANY(strtab))->xhv_max + 1), char);
1531 curstash = defstash = newHV();
1532 curstname = newSVpv("main",4);
1533 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
1534 SvREFCNT_dec(GvHV(gv));
1535 GvHV(gv) = (HV*)SvREFCNT_inc(defstash);
1537 HvNAME(defstash) = savepv("main");
1538 incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
1540 defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
1541 errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
1543 sv_setpvn(GvSV(errgv), "", 0);
1544 curstash = defstash;
1545 compiling.cop_stash = defstash;
1546 debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
1547 /* We must init $/ before switches are processed. */
1548 sv_setpvn(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), "\n", 1);
1551 #ifdef CAN_PROTOTYPE
1553 open_script(char *scriptname, bool dosearch, SV *sv)
1556 open_script(scriptname,dosearch,sv)
1562 char *xfound = Nullch;
1563 char *xfailed = Nullch;
1567 #if defined(DOSISH) && !defined(OS2) && !defined(atarist)
1568 #define SEARCH_EXTS ".bat", ".cmd", NULL
1571 # define SEARCH_EXTS ".pl", ".com", NULL
1573 /* additional extensions to try in each dir if scriptname not found */
1575 char *ext[] = { SEARCH_EXTS };
1576 int extidx = (strchr(scriptname,'.')) ? -1 : 0; /* has ext already */
1581 int hasdir, idx = 0, deftypes = 1;
1583 hasdir = (strpbrk(scriptname,":[</") != Nullch) ;
1584 /* The first time through, just add SEARCH_EXTS to whatever we
1585 * already have, so we can check for default file types. */
1586 while (deftypes || (!hasdir && my_trnlnm("DCL$PATH",tokenbuf,idx++)) ) {
1587 if (deftypes) { deftypes = 0; *tokenbuf = '\0'; }
1588 strcat(tokenbuf,scriptname);
1590 if (dosearch && !strchr(scriptname, '/') && (s = getenv("PATH"))) {
1592 bufend = s + strlen(s);
1595 s = cpytill(tokenbuf,s,bufend,':',&len);
1598 for (len = 0; *s && *s != ',' && *s != ';'; tokenbuf[len++] = *s++);
1599 tokenbuf[len] = '\0';
1601 for (len = 0; *s && *s != ';'; tokenbuf[len++] = *s++);
1602 tokenbuf[len] = '\0';
1608 if (len && tokenbuf[len-1] != '/')
1611 if (len && ((tokenbuf[len-1] != '\\') && (tokenbuf[len-1] != '/')))
1613 if (len && tokenbuf[len-1] != '\\')
1616 (void)strcat(tokenbuf+len,"/");
1617 (void)strcat(tokenbuf+len,scriptname);
1621 len = strlen(tokenbuf);
1622 if (extidx > 0) /* reset after previous loop */
1626 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tokenbuf));
1627 retval = Stat(tokenbuf,&statbuf);
1629 } while ( retval < 0 /* not there */
1630 && extidx>=0 && ext[extidx] /* try an extension? */
1631 && strcpy(tokenbuf+len, ext[extidx++])
1636 if (S_ISREG(statbuf.st_mode)
1637 && cando(S_IRUSR,TRUE,&statbuf) && cando(S_IXUSR,TRUE,&statbuf)) {
1638 xfound = tokenbuf; /* bingo! */
1642 xfailed = savepv(tokenbuf);
1645 croak("Can't execute %s", xfailed ? xfailed : scriptname );
1648 scriptname = xfound;
1651 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
1652 char *s = scriptname + 8;
1661 origfilename = savepv(e_tmpname ? "-e" : scriptname);
1662 curcop->cop_filegv = gv_fetchfile(origfilename);
1663 if (strEQ(origfilename,"-"))
1665 if (fdscript >= 0) {
1666 rsfp = PerlIO_fdopen(fdscript,"r");
1667 #if defined(HAS_FCNTL) && defined(F_SETFD)
1669 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
1672 else if (preprocess) {
1673 char *cpp = CPPSTDIN;
1675 if (strEQ(cpp,"cppstdin"))
1676 sprintf(tokenbuf, "%s/%s", SCRIPTDIR, cpp);
1678 sprintf(tokenbuf, "%s", cpp);
1680 sv_catpv(sv,PRIVLIB_EXP);
1682 (void)sprintf(buf, "\
1683 sed %s -e \"/^[^#]/b\" \
1684 -e \"/^#[ ]*include[ ]/b\" \
1685 -e \"/^#[ ]*define[ ]/b\" \
1686 -e \"/^#[ ]*if[ ]/b\" \
1687 -e \"/^#[ ]*ifdef[ ]/b\" \
1688 -e \"/^#[ ]*ifndef[ ]/b\" \
1689 -e \"/^#[ ]*else/b\" \
1690 -e \"/^#[ ]*elif[ ]/b\" \
1691 -e \"/^#[ ]*undef[ ]/b\" \
1692 -e \"/^#[ ]*endif/b\" \
1695 (doextract ? "-e \"1,/^#/d\n\"" : ""),
1697 (void)sprintf(buf, "\
1698 %s %s -e '/^[^#]/b' \
1699 -e '/^#[ ]*include[ ]/b' \
1700 -e '/^#[ ]*define[ ]/b' \
1701 -e '/^#[ ]*if[ ]/b' \
1702 -e '/^#[ ]*ifdef[ ]/b' \
1703 -e '/^#[ ]*ifndef[ ]/b' \
1704 -e '/^#[ ]*else/b' \
1705 -e '/^#[ ]*elif[ ]/b' \
1706 -e '/^#[ ]*undef[ ]/b' \
1707 -e '/^#[ ]*endif/b' \
1715 (doextract ? "-e '1,/^#/d\n'" : ""),
1717 scriptname, tokenbuf, SvPV(sv, na), CPPMINUS);
1719 #ifdef IAMSUID /* actually, this is caught earlier */
1720 if (euid != uid && !euid) { /* if running suidperl */
1722 (void)seteuid(uid); /* musn't stay setuid root */
1725 (void)setreuid((Uid_t)-1, uid);
1727 #ifdef HAS_SETRESUID
1728 (void)setresuid((Uid_t)-1, uid, (Uid_t)-1);
1734 if (geteuid() != uid)
1735 croak("Can't do seteuid!\n");
1737 #endif /* IAMSUID */
1738 rsfp = my_popen(buf,"r");
1740 else if (!*scriptname) {
1741 forbid_setid("program input from stdin");
1742 rsfp = PerlIO_stdin();
1745 rsfp = PerlIO_open(scriptname,"r");
1746 #if defined(HAS_FCNTL) && defined(F_SETFD)
1748 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
1756 #ifndef IAMSUID /* in case script is not readable before setuid */
1757 if (euid && Stat(SvPVX(GvSV(curcop->cop_filegv)),&statbuf) >= 0 &&
1758 statbuf.st_mode & (S_ISUID|S_ISGID)) {
1759 (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel);
1760 execv(buf, origargv); /* try again */
1761 croak("Can't do setuid\n");
1765 croak("Can't open perl script \"%s\": %s\n",
1766 SvPVX(GvSV(curcop->cop_filegv)), Strerror(errno));
1771 validate_suid(validarg, scriptname)
1777 /* do we need to emulate setuid on scripts? */
1779 /* This code is for those BSD systems that have setuid #! scripts disabled
1780 * in the kernel because of a security problem. Merely defining DOSUID
1781 * in perl will not fix that problem, but if you have disabled setuid
1782 * scripts in the kernel, this will attempt to emulate setuid and setgid
1783 * on scripts that have those now-otherwise-useless bits set. The setuid
1784 * root version must be called suidperl or sperlN.NNN. If regular perl
1785 * discovers that it has opened a setuid script, it calls suidperl with
1786 * the same argv that it had. If suidperl finds that the script it has
1787 * just opened is NOT setuid root, it sets the effective uid back to the
1788 * uid. We don't just make perl setuid root because that loses the
1789 * effective uid we had before invoking perl, if it was different from the
1792 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
1793 * be defined in suidperl only. suidperl must be setuid root. The
1794 * Configure script will set this up for you if you want it.
1800 if (Fstat(PerlIO_fileno(rsfp),&statbuf) < 0) /* normal stat is insecure */
1801 croak("Can't stat script \"%s\"",origfilename);
1802 if (fdscript < 0 && statbuf.st_mode & (S_ISUID|S_ISGID)) {
1806 #ifndef HAS_SETREUID
1807 /* On this access check to make sure the directories are readable,
1808 * there is actually a small window that the user could use to make
1809 * filename point to an accessible directory. So there is a faint
1810 * chance that someone could execute a setuid script down in a
1811 * non-accessible directory. I don't know what to do about that.
1812 * But I don't think it's too important. The manual lies when
1813 * it says access() is useful in setuid programs.
1815 if (access(SvPVX(GvSV(curcop->cop_filegv)),1)) /*double check*/
1816 croak("Permission denied");
1818 /* If we can swap euid and uid, then we can determine access rights
1819 * with a simple stat of the file, and then compare device and
1820 * inode to make sure we did stat() on the same file we opened.
1821 * Then we just have to make sure he or she can execute it.
1824 struct stat tmpstatbuf;
1828 setreuid(euid,uid) < 0
1831 setresuid(euid,uid,(Uid_t)-1) < 0
1834 || getuid() != euid || geteuid() != uid)
1835 croak("Can't swap uid and euid"); /* really paranoid */
1836 if (Stat(SvPVX(GvSV(curcop->cop_filegv)),&tmpstatbuf) < 0)
1837 croak("Permission denied"); /* testing full pathname here */
1838 if (tmpstatbuf.st_dev != statbuf.st_dev ||
1839 tmpstatbuf.st_ino != statbuf.st_ino) {
1840 (void)PerlIO_close(rsfp);
1841 if (rsfp = my_popen("/bin/mail root","w")) { /* heh, heh */
1843 "User %d tried to run dev %d ino %d in place of dev %d ino %d!\n\
1844 (Filename of set-id script was %s, uid %d gid %d.)\n\nSincerely,\nperl\n",
1845 uid,tmpstatbuf.st_dev, tmpstatbuf.st_ino,
1846 statbuf.st_dev, statbuf.st_ino,
1847 SvPVX(GvSV(curcop->cop_filegv)),
1848 statbuf.st_uid, statbuf.st_gid);
1849 (void)my_pclose(rsfp);
1851 croak("Permission denied\n");
1855 setreuid(uid,euid) < 0
1857 # if defined(HAS_SETRESUID)
1858 setresuid(uid,euid,(Uid_t)-1) < 0
1861 || getuid() != uid || geteuid() != euid)
1862 croak("Can't reswap uid and euid");
1863 if (!cando(S_IXUSR,FALSE,&statbuf)) /* can real uid exec? */
1864 croak("Permission denied\n");
1866 #endif /* HAS_SETREUID */
1867 #endif /* IAMSUID */
1869 if (!S_ISREG(statbuf.st_mode))
1870 croak("Permission denied");
1871 if (statbuf.st_mode & S_IWOTH)
1872 croak("Setuid/gid script is writable by world");
1873 doswitches = FALSE; /* -s is insecure in suid */
1875 if (sv_gets(linestr, rsfp, 0) == Nullch ||
1876 strnNE(SvPV(linestr,na),"#!",2) ) /* required even on Sys V */
1877 croak("No #! line");
1878 s = SvPV(linestr,na)+2;
1880 while (!isSPACE(*s)) s++;
1881 for (s2 = s; (s2 > SvPV(linestr,na)+2 &&
1882 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
1883 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
1884 croak("Not a perl script");
1885 while (*s == ' ' || *s == '\t') s++;
1887 * #! arg must be what we saw above. They can invoke it by
1888 * mentioning suidperl explicitly, but they may not add any strange
1889 * arguments beyond what #! says if they do invoke suidperl that way.
1891 len = strlen(validarg);
1892 if (strEQ(validarg," PHOOEY ") ||
1893 strnNE(s,validarg,len) || !isSPACE(s[len]))
1894 croak("Args must match #! line");
1897 if (euid != uid && (statbuf.st_mode & S_ISUID) &&
1898 euid == statbuf.st_uid)
1900 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
1901 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
1902 #endif /* IAMSUID */
1904 if (euid) { /* oops, we're not the setuid root perl */
1905 (void)PerlIO_close(rsfp);
1907 (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel);
1908 execv(buf, origargv); /* try again */
1910 croak("Can't do setuid\n");
1913 if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid) {
1915 (void)setegid(statbuf.st_gid);
1918 (void)setregid((Gid_t)-1,statbuf.st_gid);
1920 #ifdef HAS_SETRESGID
1921 (void)setresgid((Gid_t)-1,statbuf.st_gid,(Gid_t)-1);
1923 setgid(statbuf.st_gid);
1927 if (getegid() != statbuf.st_gid)
1928 croak("Can't do setegid!\n");
1930 if (statbuf.st_mode & S_ISUID) {
1931 if (statbuf.st_uid != euid)
1933 (void)seteuid(statbuf.st_uid); /* all that for this */
1936 (void)setreuid((Uid_t)-1,statbuf.st_uid);
1938 #ifdef HAS_SETRESUID
1939 (void)setresuid((Uid_t)-1,statbuf.st_uid,(Uid_t)-1);
1941 setuid(statbuf.st_uid);
1945 if (geteuid() != statbuf.st_uid)
1946 croak("Can't do seteuid!\n");
1948 else if (uid) { /* oops, mustn't run as root */
1950 (void)seteuid((Uid_t)uid);
1953 (void)setreuid((Uid_t)-1,(Uid_t)uid);
1955 #ifdef HAS_SETRESUID
1956 (void)setresuid((Uid_t)-1,(Uid_t)uid,(Uid_t)-1);
1962 if (geteuid() != uid)
1963 croak("Can't do seteuid!\n");
1966 if (!cando(S_IXUSR,TRUE,&statbuf))
1967 croak("Permission denied\n"); /* they can't do this */
1970 else if (preprocess)
1971 croak("-P not allowed for setuid/setgid script\n");
1972 else if (fdscript >= 0)
1973 croak("fd script not allowed in suidperl\n");
1975 croak("Script is not setuid/setgid in suidperl\n");
1977 /* We absolutely must clear out any saved ids here, so we */
1978 /* exec the real perl, substituting fd script for scriptname. */
1979 /* (We pass script name as "subdir" of fd, which perl will grok.) */
1980 PerlIO_rewind(rsfp);
1981 lseek(PerlIO_fileno(rsfp),(Off_t)0,0); /* just in case rewind didn't */
1982 for (which = 1; origargv[which] && origargv[which] != scriptname; which++) ;
1983 if (!origargv[which])
1984 croak("Permission denied");
1985 (void)sprintf(buf, "/dev/fd/%d/%.127s", PerlIO_fileno(rsfp), origargv[which]);
1986 origargv[which] = buf;
1988 #if defined(HAS_FCNTL) && defined(F_SETFD)
1989 fcntl(PerlIO_fileno(rsfp),F_SETFD,0); /* ensure no close-on-exec */
1992 (void)sprintf(tokenbuf, "%s/perl%s", BIN, patchlevel);
1993 execv(tokenbuf, origargv); /* try again */
1994 croak("Can't do setuid\n");
1995 #endif /* IAMSUID */
1997 if (euid != uid || egid != gid) { /* (suidperl doesn't exist, in fact) */
1998 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
1999 Fstat(PerlIO_fileno(rsfp),&statbuf); /* may be either wrapped or real suid */
2000 if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
2002 (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
2005 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2006 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2007 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
2008 /* not set-id, must be wrapped */
2016 register char *s, *s2;
2018 /* skip forward in input to the real script? */
2022 if ((s = sv_gets(linestr, rsfp, 0)) == Nullch)
2023 croak("No Perl script found in input\n");
2024 if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
2025 PerlIO_ungetc(rsfp, '\n'); /* to keep line count right */
2027 while (*s && !(isSPACE (*s) || *s == '#')) s++;
2029 while (*s == ' ' || *s == '\t') s++;
2031 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
2032 if (strnEQ(s2-4,"perl",4))
2034 while (s = moreswitches(s)) ;
2036 if (cddir && chdir(cddir) < 0)
2037 croak("Can't chdir to %s",cddir);
2045 uid = (int)getuid();
2046 euid = (int)geteuid();
2047 gid = (int)getgid();
2048 egid = (int)getegid();
2053 tainting |= (uid && (euid != uid || egid != gid));
2061 croak("No %s allowed while running setuid", s);
2063 croak("No %s allowed while running setgid", s);
2069 curstash = debstash;
2070 dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
2072 DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
2073 DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
2074 DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
2075 DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
2076 sv_setiv(DBsingle, 0);
2077 DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
2078 sv_setiv(DBtrace, 0);
2079 DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
2080 sv_setiv(DBsignal, 0);
2081 curstash = defstash;
2088 mainstack = curstack; /* remember in case we switch stacks */
2089 AvREAL_off(curstack); /* not a real array */
2090 av_extend(curstack,127);
2092 stack_base = AvARRAY(curstack);
2093 stack_sp = stack_base;
2094 stack_max = stack_base + 127;
2096 cxstack_max = 8192 / sizeof(CONTEXT) - 2; /* Use most of 8K. */
2097 New(50,cxstack,cxstack_max + 1,CONTEXT);
2100 New(50,tmps_stack,128,SV*);
2105 New(51,debname,128,char);
2106 New(52,debdelim,128,char);
2110 * The following stacks almost certainly should be per-interpreter,
2111 * but for now they're not. XXX
2115 markstack_ptr = markstack;
2117 New(54,markstack,64,I32);
2118 markstack_ptr = markstack;
2119 markstack_max = markstack + 64;
2125 New(54,scopestack,32,I32);
2127 scopestack_max = 32;
2133 New(54,savestack,128,ANY);
2135 savestack_max = 128;
2141 New(54,retstack,16,OP*);
2151 Safefree(tmps_stack);
2158 static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
2166 subname = newSVpv("main",4);
2170 init_predump_symbols()
2175 sv_setpvn(GvSV(gv_fetchpv("\"", TRUE, SVt_PV)), " ", 1);
2177 stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
2178 GvMULTI_on(stdingv);
2179 IoIFP(GvIOp(stdingv)) = PerlIO_stdin();
2180 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
2182 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(stdingv));
2184 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
2186 IoOFP(GvIOp(tmpgv)) = IoIFP(GvIOp(tmpgv)) = PerlIO_stdout();
2188 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
2190 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(defoutgv));
2192 othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
2193 GvMULTI_on(othergv);
2194 IoOFP(GvIOp(othergv)) = IoIFP(GvIOp(othergv)) = PerlIO_stderr();
2195 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
2197 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(othergv));
2199 statname = NEWSV(66,0); /* last filename we did stat on */
2202 osname = savepv(OSNAME);
2206 init_postdump_symbols(argc,argv,env)
2208 register char **argv;
2209 register char **env;
2215 argc--,argv++; /* skip name of script */
2217 for (; argc > 0 && **argv == '-'; argc--,argv++) {
2220 if (argv[0][1] == '-') {
2224 if (s = strchr(argv[0], '=')) {
2226 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
2229 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
2232 toptarget = NEWSV(0,0);
2233 sv_upgrade(toptarget, SVt_PVFM);
2234 sv_setpvn(toptarget, "", 0);
2235 bodytarget = NEWSV(0,0);
2236 sv_upgrade(bodytarget, SVt_PVFM);
2237 sv_setpvn(bodytarget, "", 0);
2238 formtarget = bodytarget;
2241 if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
2242 sv_setpv(GvSV(tmpgv),origfilename);
2243 magicname("0", "0", 1);
2245 if (tmpgv = gv_fetchpv("\024",TRUE, SVt_PV))
2247 if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
2248 sv_setpv(GvSV(tmpgv),origargv[0]);
2249 if (argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
2251 (void)gv_AVadd(argvgv);
2252 av_clear(GvAVn(argvgv));
2253 for (; argc > 0; argc--,argv++) {
2254 av_push(GvAVn(argvgv),newSVpv(argv[0],0));
2257 if (envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
2262 #ifndef VMS /* VMS doesn't have environ array */
2263 /* Note that if the supplied env parameter is actually a copy
2264 of the global environ then it may now point to free'd memory
2265 if the environment has been modified since. To avoid this
2266 problem we treat env==NULL as meaning 'use the default'
2270 if (env != environ) {
2271 environ[0] = Nullch;
2272 hv_magic(hv, envgv, 'E');
2274 for (; *env; env++) {
2275 if (!(s = strchr(*env,'=')))
2278 sv = newSVpv(s--,0);
2279 sv_magic(sv, sv, 'e', *env, s - *env);
2280 (void)hv_store(hv, *env, s - *env, sv, 0);
2284 #ifdef DYNAMIC_ENV_FETCH
2285 HvNAME(hv) = savepv(ENV_HV_NAME);
2287 hv_magic(hv, envgv, 'E');
2290 if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
2291 sv_setiv(GvSV(tmpgv),(I32)getpid());
2300 s = getenv("PERL5LIB");
2304 incpush(getenv("PERLLIB"));
2306 /* Treat PERL5?LIB as a possible search list logical name -- the
2307 * "natural" VMS idiom for a Unix path string. We allow each
2308 * element to be a set of |-separated directories for compatibility.
2312 if (my_trnlnm("PERL5LIB",buf,0))
2313 do { incpush(buf); } while (my_trnlnm("PERL5LIB",buf,++idx));
2315 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf);
2319 /* Use the ~-expanded versions of APPLIB (undocumented),
2320 ARCHLIB PRIVLIB SITEARCH SITELIB and OLDARCHLIB
2323 incpush(APPLLIB_EXP);
2327 incpush(ARCHLIB_EXP);
2330 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
2332 incpush(PRIVLIB_EXP);
2335 incpush(SITEARCH_EXP);
2338 incpush(SITELIB_EXP);
2340 #ifdef OLDARCHLIB_EXP /* 5.00[01] compatibility */
2341 incpush(OLDARCHLIB_EXP);
2354 line_t oldline = curcop->cop_line;
2356 Copy(top_env, oldtop, 1, Sigjmp_buf);
2358 while (AvFILL(list) >= 0) {
2359 CV *cv = (CV*)av_shift(list);
2363 switch (Sigsetjmp(top_env,1)) {
2365 SV* atsv = GvSV(errgv);
2367 perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
2368 (void)SvPV(atsv, len);
2370 Copy(oldtop, top_env, 1, Sigjmp_buf);
2371 curcop = &compiling;
2372 curcop->cop_line = oldline;
2373 if (list == beginav)
2374 sv_catpv(atsv, "BEGIN failed--compilation aborted");
2376 sv_catpv(atsv, "END failed--cleanup aborted");
2377 croak("%s", SvPVX(atsv));
2383 statusvalue = 255; /* XXX I don't think we use 1 anymore. */
2389 /* my_exit() was called */
2390 curstash = defstash;
2394 Copy(oldtop, top_env, 1, Sigjmp_buf);
2395 curcop = &compiling;
2396 curcop->cop_line = oldline;
2398 if (list == beginav)
2399 croak("BEGIN failed--compilation aborted");
2401 croak("END failed--cleanup aborted");
2403 my_exit(statusvalue);
2408 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
2412 Copy(oldtop, top_env, 1, Sigjmp_buf);
2413 curcop = &compiling;
2414 curcop->cop_line = oldline;
2415 Siglongjmp(top_env, 3);
2419 Copy(oldtop, top_env, 1, Sigjmp_buf);