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; \
64 static void find_beginning _((void));
65 static void forbid_setid _((char *));
66 static void incpush _((char *, int));
67 static void init_ids _((void));
68 static void init_debugger _((void));
69 static void init_lexer _((void));
70 static void init_main_stash _((void));
71 static void init_perllib _((void));
72 static void init_postdump_symbols _((int, char **, char **));
73 static void init_predump_symbols _((void));
74 static void init_stacks _((void));
75 static void my_exit_jump _((void)) __attribute__((noreturn));
76 static void nuke_stacks _((void));
77 static void open_script _((char *, bool, SV *));
78 static void usage _((char *));
79 static void validate_suid _((char *, char*));
81 static int fdscript = -1;
86 PerlInterpreter *sv_interp;
89 New(53, sv_interp, 1, PerlInterpreter);
94 perl_construct( sv_interp )
95 register PerlInterpreter *sv_interp;
97 if (!(curinterp = sv_interp))
101 Zero(sv_interp, 1, PerlInterpreter);
104 /* Init the real globals? */
106 linestr = NEWSV(65,80);
107 sv_upgrade(linestr,SVt_PVIV);
109 if (!SvREADONLY(&sv_undef)) {
110 SvREADONLY_on(&sv_undef);
114 SvREADONLY_on(&sv_no);
116 sv_setpv(&sv_yes,Yes);
118 SvREADONLY_on(&sv_yes);
121 nrs = newSVpv("\n", 1);
122 rs = SvREFCNT_inc(nrs);
128 * There is no way we can refer to them from Perl so close them to save
129 * space. The other alternative would be to provide STDAUX and STDPRN
132 (void)fclose(stdaux);
133 (void)fclose(stdprn);
139 perl_destruct_level = 1;
141 if(perl_destruct_level > 0)
147 start_env.je_prev = NULL;
148 start_env.je_ret = -1;
149 start_env.je_mustcatch = TRUE;
150 top_env = &start_env;
153 SET_NUMERIC_STANDARD();
154 #if defined(SUBVERSION) && SUBVERSION > 0
155 sprintf(patchlevel, "%7.5f", (double) 5
156 + ((double) PATCHLEVEL / (double) 1000)
157 + ((double) SUBVERSION / (double) 100000));
159 sprintf(patchlevel, "%5.3f", (double) 5 +
160 ((double) PATCHLEVEL / (double) 1000));
163 #if defined(LOCAL_PATCH_COUNT)
164 localpatches = local_patches; /* For possible -v */
167 PerlIO_init(); /* Hook to IO system */
169 fdpid = newAV(); /* for remembering popen pids by fd */
176 perl_destruct(sv_interp)
177 register PerlInterpreter *sv_interp;
179 int destruct_level; /* 0=none, 1=full, 2=full with checks */
183 if (!(curinterp = sv_interp))
186 destruct_level = perl_destruct_level;
190 if (s = getenv("PERL_DESTRUCT_LEVEL")) {
192 if (destruct_level < i)
201 /* We must account for everything. */
203 /* Destroy the main CV and syntax tree */
205 curpad = AvARRAY(comppad);
210 SvREFCNT_dec(main_cv);
215 * Try to destruct global references. We do this first so that the
216 * destructors and destructees still exist. Some sv's might remain.
217 * Non-referenced objects are on their own.
224 /* unhook hooks which will soon be, or use, destroyed data */
225 SvREFCNT_dec(warnhook);
227 SvREFCNT_dec(diehook);
229 SvREFCNT_dec(parsehook);
232 if (destruct_level == 0){
234 DEBUG_P(debprofdump());
236 /* The exit() function will do everything that needs doing. */
240 /* loosen bonds of global variables */
243 (void)PerlIO_close(rsfp);
247 /* Filters for program text */
248 SvREFCNT_dec(rsfp_filters);
249 rsfp_filters = Nullav;
261 sawampersand = FALSE; /* must save all match strings */
262 sawstudy = FALSE; /* do fbm_instr on all strings */
277 /* magical thingies */
279 Safefree(ofs); /* $, */
282 Safefree(ors); /* $\ */
285 SvREFCNT_dec(nrs); /* $\ helper */
288 multiline = 0; /* $* */
290 SvREFCNT_dec(statname);
294 /* defgv, aka *_ should be taken care of elsewhere */
296 #if 0 /* just about all regexp stuff, seems to be ok */
298 /* shortcuts to regexp stuff */
303 SAVEFREEOP(oldlastpm); /* for saving regexp context during debugger */
305 regprecomp = NULL; /* uncompiled string. */
306 regparse = NULL; /* Input-scan pointer. */
307 regxend = NULL; /* End of input for compile */
308 regnpar = 0; /* () count. */
309 regcode = NULL; /* Code-emit pointer; ®dummy = don't. */
310 regsize = 0; /* Code size. */
311 regnaughty = 0; /* How bad is this pattern? */
312 regsawback = 0; /* Did we see \1, ...? */
314 reginput = NULL; /* String-input pointer. */
315 regbol = NULL; /* Beginning of input, for ^ check. */
316 regeol = NULL; /* End of input, for $ check. */
317 regstartp = (char **)NULL; /* Pointer to startp array. */
318 regendp = (char **)NULL; /* Ditto for endp. */
319 reglastparen = 0; /* Similarly for lastparen. */
320 regtill = NULL; /* How far we are required to go. */
321 regflags = 0; /* are we folding, multilining? */
322 regprev = (char)NULL; /* char before regbol, \n if none */
326 /* clean up after study() */
327 SvREFCNT_dec(lastscream);
329 Safefree(screamfirst);
331 Safefree(screamnext);
334 /* startup and shutdown function lists */
335 SvREFCNT_dec(beginav);
340 /* temp stack during pp_sort() */
341 SvREFCNT_dec(sortstack);
344 /* shortcuts just get cleared */
354 /* reset so print() ends up where we expect */
357 /* Prepare to destruct main symbol table. */
364 if (destruct_level >= 2) {
365 if (scopestack_ix != 0)
366 warn("Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
367 (long)scopestack_ix);
368 if (savestack_ix != 0)
369 warn("Unbalanced saves: %ld more saves than restores\n",
371 if (tmps_floor != -1)
372 warn("Unbalanced tmps: %ld more allocs than frees\n",
373 (long)tmps_floor + 1);
374 if (cxstack_ix != -1)
375 warn("Unbalanced context: %ld more PUSHes than POPs\n",
376 (long)cxstack_ix + 1);
379 /* Now absolutely destruct everything, somehow or other, loops or no. */
381 SvFLAGS(strtab) |= SVTYPEMASK; /* don't clean out strtab now */
382 while (sv_count != 0 && sv_count != last_sv_count) {
383 last_sv_count = sv_count;
386 SvFLAGS(strtab) &= ~SVTYPEMASK;
387 SvFLAGS(strtab) |= SVt_PVHV;
389 /* Destruct the global string table. */
391 /* Yell and reset the HeVAL() slots that are still holding refcounts,
392 * so that sv_free() won't fail on them.
401 array = HvARRAY(strtab);
405 warn("Unbalanced string table refcount: (%d) for \"%s\"",
406 HeVAL(hent) - Nullsv, HeKEY(hent));
407 HeVAL(hent) = Nullsv;
417 SvREFCNT_dec(strtab);
420 warn("Scalars leaked: %ld\n", (long)sv_count);
424 /* No SVs have survived, need to clean out */
428 Safefree(origfilename);
430 hints = 0; /* Reset hints. Should hints be per-interpreter ? */
432 DEBUG_P(debprofdump());
437 PerlInterpreter *sv_interp;
439 if (!(curinterp = sv_interp))
445 perl_parse(sv_interp, xsinit, argc, argv, env)
446 PerlInterpreter *sv_interp;
447 void (*xsinit)_((void));
454 char *scriptname = NULL;
455 VOL bool dosearch = FALSE;
462 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
465 croak("suidperl is no longer needed since the kernel can now execute\n\
466 setuid perl scripts securely.\n");
470 if (!(curinterp = sv_interp))
473 #if defined(NeXT) && defined(__DYNAMIC__)
474 _dyld_lookup_and_bind
475 ("__environ", (unsigned long *) &environ_pointer, NULL);
480 #ifndef VMS /* VMS doesn't have environ array */
481 origenviron = environ;
487 /* Come here if running an undumped a.out. */
489 origfilename = savepv(argv[0]);
491 cxstack_ix = -1; /* start label stack again */
493 init_postdump_symbols(argc,argv,env);
498 curpad = AvARRAY(comppad);
503 SvREFCNT_dec(main_cv);
507 oldscope = scopestack_ix;
515 /* my_exit() was called */
516 while (scopestack_ix > oldscope)
520 call_list(oldscope, endav);
522 return STATUS_NATIVE_EXPORT;
525 PerlIO_printf(PerlIO_stderr(), "panic: top_env\n");
529 sv_setpvn(linestr,"",0);
530 sv = newSVpv("",0); /* first used for -I flags */
534 for (argc--,argv++; argc > 0; argc--,argv++) {
535 if (argv[0][0] != '-' || !argv[0][1])
539 validarg = " PHOOEY ";
564 if (s = moreswitches(s))
574 if (euid != uid || egid != gid)
575 croak("No -e allowed in setuid scripts");
577 e_tmpname = savepv(TMPPATH);
578 (void)mktemp(e_tmpname);
580 croak("Can't mktemp()");
581 e_fp = PerlIO_open(e_tmpname,"w");
583 croak("Cannot open temporary file");
588 PerlIO_puts(e_fp,argv[1]);
592 croak("No code specified for -e");
593 (void)PerlIO_putc(e_fp,'\n');
604 incpush(argv[1], TRUE);
605 sv_catpv(sv,argv[1]);
622 preambleav = newAV();
623 av_push(preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
625 Sv = newSVpv("print myconfig();",0);
627 sv_catpv(Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
629 sv_catpv(Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
631 #if defined(DEBUGGING) || defined(NO_EMBED) || defined(MULTIPLICITY)
632 strcpy(buf,"\" Compile-time options:");
634 strcat(buf," DEBUGGING");
637 strcat(buf," NO_EMBED");
640 strcat(buf," MULTIPLICITY");
642 strcat(buf,"\\n\",");
645 #if defined(LOCAL_PATCH_COUNT)
646 if (LOCAL_PATCH_COUNT > 0) {
648 sv_catpv(Sv,"\" Locally applied patches:\\n\",");
649 for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
650 if (localpatches[i]) {
651 sprintf(buf,"\" \\t%s\\n\",",localpatches[i]);
657 sprintf(buf,"\" Built under %s\\n\"",OSNAME);
661 sprintf(buf,",\" Compiled at %s %s\\n\"",__DATE__,__TIME__);
663 sprintf(buf,",\" Compiled on %s\\n\"",__DATE__);
669 @env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; \
670 print \" \\%ENV:\\n @env\\n\" if @env; \
671 print \" \\@INC:\\n @INC\\n\";");
674 Sv = newSVpv("config_vars(qw(",0);
679 av_push(preambleav, Sv);
680 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
694 croak("Unrecognized switch: -%s",s);
699 if (!tainting && (s = getenv("PERL5OPT"))) {
710 if (!strchr("DIMUdmw", *s))
711 croak("Illegal switch in PERL5OPT: -%c", *s);
717 scriptname = argv[0];
719 if (PerlIO_flush(e_fp) || PerlIO_error(e_fp) || PerlIO_close(e_fp)) {
721 warn("Did you forget to compile with -DMULTIPLICITY?");
723 croak("Can't write to temp file for -e: %s", Strerror(errno));
727 scriptname = e_tmpname;
729 else if (scriptname == Nullch) {
731 if ( isatty(PerlIO_fileno(PerlIO_stdin())) )
739 open_script(scriptname,dosearch,sv);
741 validate_suid(validarg, scriptname);
746 main_cv = compcv = (CV*)NEWSV(1104,0);
747 sv_upgrade((SV *)compcv, SVt_PVCV);
751 av_push(comppad, Nullsv);
752 curpad = AvARRAY(comppad);
753 comppad_name = newAV();
754 comppad_name_fill = 0;
755 min_intro_pending = 0;
758 comppadlist = newAV();
759 AvREAL_off(comppadlist);
760 av_store(comppadlist, 0, (SV*)comppad_name);
761 av_store(comppadlist, 1, (SV*)comppad);
762 CvPADLIST(compcv) = comppadlist;
764 boot_core_UNIVERSAL();
766 (*xsinit)(); /* in case linked C routines want magical variables */
771 init_predump_symbols();
773 init_postdump_symbols(argc,argv,env);
777 /* now parse the script */
780 if (yyparse() || error_count) {
782 croak("%s had compilation errors.\n", origfilename);
784 croak("Execution of %s aborted due to compilation errors.\n",
788 curcop->cop_line = 0;
792 (void)UNLINK(e_tmpname);
797 /* now that script is parsed, we can modify record separator */
799 rs = SvREFCNT_inc(nrs);
800 sv_setsv(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), rs);
811 #ifdef DEBUGGING_MSTATS
812 if ((s=getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
813 dump_mstats("after compilation:");
824 PerlInterpreter *sv_interp;
830 if (!(curinterp = sv_interp))
833 oldscope = scopestack_ix;
838 cxstack_ix = -1; /* start context stack again */
841 /* my_exit() was called */
842 while (scopestack_ix > oldscope)
846 call_list(oldscope, endav);
848 #ifdef DEBUGGING_MSTATS
849 if (getenv("PERL_DEBUG_MSTATS"))
850 dump_mstats("after execution: ");
853 return STATUS_NATIVE_EXPORT;
856 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
861 if (curstack != mainstack) {
863 SWITCHSTACK(curstack, mainstack);
868 DEBUG_r(PerlIO_printf(PerlIO_stderr(), "%s $` $& $' support.\n",
869 sawampersand ? "Enabling" : "Omitting"));
873 DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
876 PerlIO_printf(PerlIO_stderr(), "%s syntax OK\n", origfilename);
879 if (perldb && DBsingle)
880 sv_setiv(DBsingle, 1);
890 else if (main_start) {
891 CvDEPTH(main_cv) = 1;
902 perl_get_sv(name, create)
906 GV* gv = gv_fetchpv(name, create, SVt_PV);
913 perl_get_av(name, create)
917 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
926 perl_get_hv(name, create)
930 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
939 perl_get_cv(name, create)
943 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
944 if (create && !GvCVu(gv))
945 return newSUB(start_subparse(FALSE, 0),
946 newSVOP(OP_CONST, 0, newSVpv(name,0)),
954 /* Be sure to refetch the stack pointer after calling these routines. */
957 perl_call_argv(subname, flags, argv)
959 I32 flags; /* See G_* flags in cop.h */
960 register char **argv; /* null terminated arg list */
967 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
972 return perl_call_pv(subname, flags);
976 perl_call_pv(subname, flags)
977 char *subname; /* name of the subroutine */
978 I32 flags; /* See G_* flags in cop.h */
980 return perl_call_sv((SV*)perl_get_cv(subname, TRUE), flags);
984 perl_call_method(methname, flags)
985 char *methname; /* name of the subroutine */
986 I32 flags; /* See G_* flags in cop.h */
992 XPUSHs(sv_2mortal(newSVpv(methname,0)));
995 return perl_call_sv(*stack_sp--, flags);
998 /* May be called with any of a CV, a GV, or an SV containing the name. */
1000 perl_call_sv(sv, flags)
1002 I32 flags; /* See G_* flags in cop.h */
1004 LOGOP myop; /* fake syntax tree node */
1010 bool oldcatch = CATCH_GET;
1014 if (flags & G_DISCARD) {
1019 Zero(&myop, 1, LOGOP);
1020 myop.op_next = Nullop;
1021 if (!(flags & G_NOARGS))
1022 myop.op_flags |= OPf_STACKED;
1023 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1024 (flags & G_ARRAY) ? OPf_WANT_LIST :
1029 EXTEND(stack_sp, 1);
1032 oldscope = scopestack_ix;
1034 if (perldb && curstash != debstash
1035 /* Handle first BEGIN of -d. */
1036 && (DBcv || (DBcv = GvCV(DBsub)))
1037 /* Try harder, since this may have been a sighandler, thus
1038 * curstash may be meaningless. */
1039 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != debstash))
1040 op->op_private |= OPpENTERSUB_DB;
1042 if (flags & G_EVAL) {
1043 cLOGOP->op_other = op;
1045 /* we're trying to emulate pp_entertry() here */
1047 register CONTEXT *cx;
1048 I32 gimme = GIMME_V;
1053 push_return(op->op_next);
1054 PUSHBLOCK(cx, CXt_EVAL, stack_sp);
1056 eval_root = op; /* Only needed so that goto works right. */
1059 if (flags & G_KEEPERR)
1062 sv_setpv(GvSV(errgv),"");
1074 /* my_exit() was called */
1075 curstash = defstash;
1079 croak("Callback called exit");
1088 stack_sp = stack_base + oldmark;
1089 if (flags & G_ARRAY)
1093 *++stack_sp = &sv_undef;
1101 if (op == (OP*)&myop)
1105 retval = stack_sp - (stack_base + oldmark);
1106 if ((flags & G_EVAL) && !(flags & G_KEEPERR))
1107 sv_setpv(GvSV(errgv),"");
1110 if (flags & G_EVAL) {
1111 if (scopestack_ix > oldscope) {
1115 register CONTEXT *cx;
1127 CATCH_SET(oldcatch);
1129 if (flags & G_DISCARD) {
1130 stack_sp = stack_base + oldmark;
1138 /* Eval a string. The G_EVAL flag is always assumed. */
1141 perl_eval_sv(sv, flags)
1143 I32 flags; /* See G_* flags in cop.h */
1145 UNOP myop; /* fake syntax tree node */
1147 I32 oldmark = sp - stack_base;
1153 if (flags & G_DISCARD) {
1161 EXTEND(stack_sp, 1);
1163 oldscope = scopestack_ix;
1165 if (!(flags & G_NOARGS))
1166 myop.op_flags = OPf_STACKED;
1167 myop.op_next = Nullop;
1168 myop.op_type = OP_ENTEREVAL;
1169 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1170 (flags & G_ARRAY) ? OPf_WANT_LIST :
1172 if (flags & G_KEEPERR)
1173 myop.op_flags |= OPf_SPECIAL;
1183 /* my_exit() was called */
1184 curstash = defstash;
1188 croak("Callback called exit");
1197 stack_sp = stack_base + oldmark;
1198 if (flags & G_ARRAY)
1202 *++stack_sp = &sv_undef;
1207 if (op == (OP*)&myop)
1208 op = pp_entereval();
1211 retval = stack_sp - (stack_base + oldmark);
1212 if (!(flags & G_KEEPERR))
1213 sv_setpv(GvSV(errgv),"");
1217 if (flags & G_DISCARD) {
1218 stack_sp = stack_base + oldmark;
1227 perl_eval_pv(p, croak_on_error)
1232 SV* sv = newSVpv(p, 0);
1235 perl_eval_sv(sv, G_SCALAR);
1242 if (croak_on_error && SvTRUE(GvSV(errgv)))
1243 croak(SvPVx(GvSV(errgv), na));
1248 /* Require a module. */
1254 SV* sv = sv_newmortal();
1255 sv_setpv(sv, "require '");
1258 perl_eval_sv(sv, G_DISCARD);
1262 magicname(sym,name,namlen)
1269 if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
1270 sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
1274 usage(name) /* XXX move this out into a module ? */
1277 /* This message really ought to be max 23 lines.
1278 * Removed -h because the user already knows that opton. Others? */
1279 printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
1280 printf("\n -0[octal] specify record separator (\\0, if no argument)");
1281 printf("\n -a autosplit mode with -n or -p (splits $_ into @F)");
1282 printf("\n -c check syntax only (runs BEGIN and END blocks)");
1283 printf("\n -d[:debugger] run scripts under debugger");
1284 printf("\n -D[number/list] set debugging flags (argument is a bit mask or flags)");
1285 printf("\n -e 'command' one line of script. Several -e's allowed. Omit [programfile].");
1286 printf("\n -F/pattern/ split() pattern for autosplit (-a). The //'s are optional.");
1287 printf("\n -i[extension] edit <> files in place (make backup if extension supplied)");
1288 printf("\n -Idirectory specify @INC/#include directory (may be used more then once)");
1289 printf("\n -l[octal] enable line ending processing, specifies line teminator");
1290 printf("\n -[mM][-]module.. executes `use/no module...' before executing your script.");
1291 printf("\n -n assume 'while (<>) { ... }' loop arround your script");
1292 printf("\n -p assume loop like -n but print line also like sed");
1293 printf("\n -P run script through C preprocessor before compilation");
1294 printf("\n -s enable some switch parsing for switches after script name");
1295 printf("\n -S look for the script using PATH environment variable");
1296 printf("\n -T turn on tainting checks");
1297 printf("\n -u dump core after parsing script");
1298 printf("\n -U allow unsafe operations");
1299 printf("\n -v print version number and patchlevel of perl");
1300 printf("\n -V[:variable] print perl configuration information");
1301 printf("\n -w TURN WARNINGS ON FOR COMPILATION OF YOUR SCRIPT.");
1302 printf("\n -x[directory] strip off text before #!perl line and perhaps cd to directory\n");
1305 /* This routine handles any switches that can be given during run */
1316 rschar = scan_oct(s, 4, &numlen);
1318 if (rschar & ~((U8)~0))
1320 else if (!rschar && numlen >= 2)
1321 nrs = newSVpv("", 0);
1324 nrs = newSVpv(&ch, 1);
1329 splitstr = savepv(s + 1);
1343 if (*s == ':' || *s == '=') {
1344 sprintf(buf, "use Devel::%s;", ++s);
1346 my_setenv("PERL5DB",buf);
1356 if (isALPHA(s[1])) {
1357 static char debopts[] = "psltocPmfrxuLHXD";
1360 for (s++; *s && (d = strchr(debopts,*s)); s++)
1361 debug |= 1 << (d - debopts);
1365 for (s++; isDIGIT(*s); s++) ;
1367 debug |= 0x80000000;
1369 warn("Recompile perl with -DDEBUGGING to use -D switch\n");
1370 for (s++; isALNUM(*s); s++) ;
1380 inplace = savepv(s+1);
1382 for (s = inplace; *s && !isSPACE(*s); s++) ;
1389 for (e = s; *e && !isSPACE(*e); e++) ;
1390 p = savepvn(s, e-s);
1397 croak("No space allowed after -I");
1407 *ors = scan_oct(s, 3 + (*s == '0'), &numlen);
1416 ors = SvPV(nrs, orslen);
1417 ors = savepvn(ors, orslen);
1421 forbid_setid("-M"); /* XXX ? */
1424 forbid_setid("-m"); /* XXX ? */
1428 /* -M-foo == 'no foo' */
1429 if (*s == '-') { use = "no "; ++s; }
1430 Sv = newSVpv(use,0);
1432 /* We allow -M'Module qw(Foo Bar)' */
1433 while(isALNUM(*s) || *s==':') ++s;
1435 sv_catpv(Sv, start);
1436 if (*(start-1) == 'm') {
1438 croak("Can't use '%c' after -mname", *s);
1439 sv_catpv( Sv, " ()");
1442 sv_catpvn(Sv, start, s-start);
1443 sv_catpv(Sv, " split(/,/,q{");
1448 if (preambleav == NULL)
1449 preambleav = newAV();
1450 av_push(preambleav, Sv);
1453 croak("No space allowed after -%c", *(s-1));
1470 croak("Too late for \"-T\" option");
1482 #if defined(SUBVERSION) && SUBVERSION > 0
1483 printf("\nThis is perl, version 5.%03d_%02d", PATCHLEVEL, SUBVERSION);
1485 printf("\nThis is perl, version %s",patchlevel);
1488 printf("\n\nCopyright 1987-1997, Larry Wall\n");
1490 printf("\n\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
1493 printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n");
1496 printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
1497 "Version 5 port Copyright (c) 1994-1997, Andreas Kaiser, Ilya Zakharevich\n");
1500 printf("atariST series port, ++jrb bammi@cadence.com\n");
1503 Perl may be copied only under the terms of either the Artistic License or the\n\
1504 GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n");
1512 if (s[1] == '-') /* Additional switches on #! line. */
1520 #ifdef ALTERNATE_SHEBANG
1521 case 'S': /* OS/2 needs -S on "extproc" line. */
1529 croak("Can't emulate -%.1s on #! line",s);
1534 /* compliments of Tom Christiansen */
1536 /* unexec() can be found in the Gnu emacs distribution */
1545 sprintf (buf, "%s.perldump", origfilename);
1546 sprintf (tokenbuf, "%s/perl", BIN_EXP);
1548 status = unexec(buf, tokenbuf, &etext, sbrk(0), 0);
1550 PerlIO_printf(PerlIO_stderr(), "unexec of %s into %s failed!\n", tokenbuf, buf);
1554 # include <lib$routines.h>
1555 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
1557 ABORT(); /* for use with undump */
1567 /* Note that strtab is a rather special HV. Assumptions are made
1568 about not iterating on it, and not adding tie magic to it.
1569 It is properly deallocated in perl_destruct() */
1571 HvSHAREKEYS_off(strtab); /* mandatory */
1572 Newz(506,((XPVHV*)SvANY(strtab))->xhv_array,
1573 sizeof(HE*) * (((XPVHV*)SvANY(strtab))->xhv_max + 1), char);
1575 curstash = defstash = newHV();
1576 curstname = newSVpv("main",4);
1577 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
1578 SvREFCNT_dec(GvHV(gv));
1579 GvHV(gv) = (HV*)SvREFCNT_inc(defstash);
1581 HvNAME(defstash) = savepv("main");
1582 incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
1584 defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
1585 errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
1587 sv_setpvn(GvSV(errgv), "", 0);
1588 curstash = defstash;
1589 compiling.cop_stash = defstash;
1590 debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
1591 /* We must init $/ before switches are processed. */
1592 sv_setpvn(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), "\n", 1);
1595 #ifdef CAN_PROTOTYPE
1597 open_script(char *scriptname, bool dosearch, SV *sv)
1600 open_script(scriptname,dosearch,sv)
1606 char *xfound = Nullch;
1607 char *xfailed = Nullch;
1611 #if defined(DOSISH) && !defined(OS2) && !defined(atarist)
1612 #define SEARCH_EXTS ".bat", ".cmd", NULL
1615 # define SEARCH_EXTS ".pl", ".com", NULL
1617 /* additional extensions to try in each dir if scriptname not found */
1619 char *ext[] = { SEARCH_EXTS };
1620 int extidx = (strchr(scriptname,'.')) ? -1 : 0; /* has ext already */
1625 int hasdir, idx = 0, deftypes = 1;
1627 hasdir = (strpbrk(scriptname,":[</") != Nullch) ;
1628 /* The first time through, just add SEARCH_EXTS to whatever we
1629 * already have, so we can check for default file types. */
1630 while (deftypes || (!hasdir && my_trnlnm("DCL$PATH",tokenbuf,idx++)) ) {
1631 if (deftypes) { deftypes = 0; *tokenbuf = '\0'; }
1632 strcat(tokenbuf,scriptname);
1634 if (dosearch && !strchr(scriptname, '/') && (s = getenv("PATH"))) {
1636 bufend = s + strlen(s);
1639 s = cpytill(tokenbuf,s,bufend,':',&len);
1642 for (len = 0; *s && *s != ',' && *s != ';'; tokenbuf[len++] = *s++);
1643 tokenbuf[len] = '\0';
1645 for (len = 0; *s && *s != ';'; tokenbuf[len++] = *s++);
1646 tokenbuf[len] = '\0';
1652 if (len && tokenbuf[len-1] != '/')
1655 if (len && ((tokenbuf[len-1] != '\\') && (tokenbuf[len-1] != '/')))
1657 if (len && tokenbuf[len-1] != '\\')
1660 (void)strcat(tokenbuf+len,"/");
1661 (void)strcat(tokenbuf+len,scriptname);
1665 len = strlen(tokenbuf);
1666 if (extidx > 0) /* reset after previous loop */
1670 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tokenbuf));
1671 retval = Stat(tokenbuf,&statbuf);
1673 } while ( retval < 0 /* not there */
1674 && extidx>=0 && ext[extidx] /* try an extension? */
1675 && strcpy(tokenbuf+len, ext[extidx++])
1680 if (S_ISREG(statbuf.st_mode)
1681 && cando(S_IRUSR,TRUE,&statbuf) && cando(S_IXUSR,TRUE,&statbuf)) {
1682 xfound = tokenbuf; /* bingo! */
1686 xfailed = savepv(tokenbuf);
1689 croak("Can't execute %s", xfailed ? xfailed : scriptname );
1692 scriptname = xfound;
1695 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
1696 char *s = scriptname + 8;
1705 origfilename = savepv(e_tmpname ? "-e" : scriptname);
1706 curcop->cop_filegv = gv_fetchfile(origfilename);
1707 if (strEQ(origfilename,"-"))
1709 if (fdscript >= 0) {
1710 rsfp = PerlIO_fdopen(fdscript,"r");
1711 #if defined(HAS_FCNTL) && defined(F_SETFD)
1713 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
1716 else if (preprocess) {
1717 char *cpp = CPPSTDIN;
1719 if (strEQ(cpp,"cppstdin"))
1720 sprintf(tokenbuf, "%s/%s", BIN_EXP, cpp);
1722 sprintf(tokenbuf, "%s", cpp);
1724 sv_catpv(sv,PRIVLIB_EXP);
1726 (void)sprintf(buf, "\
1727 sed %s -e \"/^[^#]/b\" \
1728 -e \"/^#[ ]*include[ ]/b\" \
1729 -e \"/^#[ ]*define[ ]/b\" \
1730 -e \"/^#[ ]*if[ ]/b\" \
1731 -e \"/^#[ ]*ifdef[ ]/b\" \
1732 -e \"/^#[ ]*ifndef[ ]/b\" \
1733 -e \"/^#[ ]*else/b\" \
1734 -e \"/^#[ ]*elif[ ]/b\" \
1735 -e \"/^#[ ]*undef[ ]/b\" \
1736 -e \"/^#[ ]*endif/b\" \
1739 (doextract ? "-e \"1,/^#/d\n\"" : ""),
1741 (void)sprintf(buf, "\
1742 %s %s -e '/^[^#]/b' \
1743 -e '/^#[ ]*include[ ]/b' \
1744 -e '/^#[ ]*define[ ]/b' \
1745 -e '/^#[ ]*if[ ]/b' \
1746 -e '/^#[ ]*ifdef[ ]/b' \
1747 -e '/^#[ ]*ifndef[ ]/b' \
1748 -e '/^#[ ]*else/b' \
1749 -e '/^#[ ]*elif[ ]/b' \
1750 -e '/^#[ ]*undef[ ]/b' \
1751 -e '/^#[ ]*endif/b' \
1759 (doextract ? "-e '1,/^#/d\n'" : ""),
1761 scriptname, tokenbuf, SvPV(sv, na), CPPMINUS);
1763 #ifdef IAMSUID /* actually, this is caught earlier */
1764 if (euid != uid && !euid) { /* if running suidperl */
1766 (void)seteuid(uid); /* musn't stay setuid root */
1769 (void)setreuid((Uid_t)-1, uid);
1771 #ifdef HAS_SETRESUID
1772 (void)setresuid((Uid_t)-1, uid, (Uid_t)-1);
1778 if (geteuid() != uid)
1779 croak("Can't do seteuid!\n");
1781 #endif /* IAMSUID */
1782 rsfp = my_popen(buf,"r");
1784 else if (!*scriptname) {
1785 forbid_setid("program input from stdin");
1786 rsfp = PerlIO_stdin();
1789 rsfp = PerlIO_open(scriptname,"r");
1790 #if defined(HAS_FCNTL) && defined(F_SETFD)
1792 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
1800 #ifndef IAMSUID /* in case script is not readable before setuid */
1801 if (euid && Stat(SvPVX(GvSV(curcop->cop_filegv)),&statbuf) >= 0 &&
1802 statbuf.st_mode & (S_ISUID|S_ISGID)) {
1803 (void)sprintf(buf, "%s/sperl%s", BIN_EXP, patchlevel);
1804 execv(buf, origargv); /* try again */
1805 croak("Can't do setuid\n");
1809 croak("Can't open perl script \"%s\": %s\n",
1810 SvPVX(GvSV(curcop->cop_filegv)), Strerror(errno));
1815 validate_suid(validarg, scriptname)
1821 /* do we need to emulate setuid on scripts? */
1823 /* This code is for those BSD systems that have setuid #! scripts disabled
1824 * in the kernel because of a security problem. Merely defining DOSUID
1825 * in perl will not fix that problem, but if you have disabled setuid
1826 * scripts in the kernel, this will attempt to emulate setuid and setgid
1827 * on scripts that have those now-otherwise-useless bits set. The setuid
1828 * root version must be called suidperl or sperlN.NNN. If regular perl
1829 * discovers that it has opened a setuid script, it calls suidperl with
1830 * the same argv that it had. If suidperl finds that the script it has
1831 * just opened is NOT setuid root, it sets the effective uid back to the
1832 * uid. We don't just make perl setuid root because that loses the
1833 * effective uid we had before invoking perl, if it was different from the
1836 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
1837 * be defined in suidperl only. suidperl must be setuid root. The
1838 * Configure script will set this up for you if you want it.
1844 if (Fstat(PerlIO_fileno(rsfp),&statbuf) < 0) /* normal stat is insecure */
1845 croak("Can't stat script \"%s\"",origfilename);
1846 if (fdscript < 0 && statbuf.st_mode & (S_ISUID|S_ISGID)) {
1850 #ifndef HAS_SETREUID
1851 /* On this access check to make sure the directories are readable,
1852 * there is actually a small window that the user could use to make
1853 * filename point to an accessible directory. So there is a faint
1854 * chance that someone could execute a setuid script down in a
1855 * non-accessible directory. I don't know what to do about that.
1856 * But I don't think it's too important. The manual lies when
1857 * it says access() is useful in setuid programs.
1859 if (access(SvPVX(GvSV(curcop->cop_filegv)),1)) /*double check*/
1860 croak("Permission denied");
1862 /* If we can swap euid and uid, then we can determine access rights
1863 * with a simple stat of the file, and then compare device and
1864 * inode to make sure we did stat() on the same file we opened.
1865 * Then we just have to make sure he or she can execute it.
1868 struct stat tmpstatbuf;
1872 setreuid(euid,uid) < 0
1875 setresuid(euid,uid,(Uid_t)-1) < 0
1878 || getuid() != euid || geteuid() != uid)
1879 croak("Can't swap uid and euid"); /* really paranoid */
1880 if (Stat(SvPVX(GvSV(curcop->cop_filegv)),&tmpstatbuf) < 0)
1881 croak("Permission denied"); /* testing full pathname here */
1882 if (tmpstatbuf.st_dev != statbuf.st_dev ||
1883 tmpstatbuf.st_ino != statbuf.st_ino) {
1884 (void)PerlIO_close(rsfp);
1885 if (rsfp = my_popen("/bin/mail root","w")) { /* heh, heh */
1887 "User %ld tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
1888 (Filename of set-id script was %s, uid %ld gid %ld.)\n\nSincerely,\nperl\n",
1889 (long)uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
1890 (long)statbuf.st_dev, (long)statbuf.st_ino,
1891 SvPVX(GvSV(curcop->cop_filegv)),
1892 (long)statbuf.st_uid, (long)statbuf.st_gid);
1893 (void)my_pclose(rsfp);
1895 croak("Permission denied\n");
1899 setreuid(uid,euid) < 0
1901 # if defined(HAS_SETRESUID)
1902 setresuid(uid,euid,(Uid_t)-1) < 0
1905 || getuid() != uid || geteuid() != euid)
1906 croak("Can't reswap uid and euid");
1907 if (!cando(S_IXUSR,FALSE,&statbuf)) /* can real uid exec? */
1908 croak("Permission denied\n");
1910 #endif /* HAS_SETREUID */
1911 #endif /* IAMSUID */
1913 if (!S_ISREG(statbuf.st_mode))
1914 croak("Permission denied");
1915 if (statbuf.st_mode & S_IWOTH)
1916 croak("Setuid/gid script is writable by world");
1917 doswitches = FALSE; /* -s is insecure in suid */
1919 if (sv_gets(linestr, rsfp, 0) == Nullch ||
1920 strnNE(SvPV(linestr,na),"#!",2) ) /* required even on Sys V */
1921 croak("No #! line");
1922 s = SvPV(linestr,na)+2;
1924 while (!isSPACE(*s)) s++;
1925 for (s2 = s; (s2 > SvPV(linestr,na)+2 &&
1926 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
1927 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
1928 croak("Not a perl script");
1929 while (*s == ' ' || *s == '\t') s++;
1931 * #! arg must be what we saw above. They can invoke it by
1932 * mentioning suidperl explicitly, but they may not add any strange
1933 * arguments beyond what #! says if they do invoke suidperl that way.
1935 len = strlen(validarg);
1936 if (strEQ(validarg," PHOOEY ") ||
1937 strnNE(s,validarg,len) || !isSPACE(s[len]))
1938 croak("Args must match #! line");
1941 if (euid != uid && (statbuf.st_mode & S_ISUID) &&
1942 euid == statbuf.st_uid)
1944 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
1945 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
1946 #endif /* IAMSUID */
1948 if (euid) { /* oops, we're not the setuid root perl */
1949 (void)PerlIO_close(rsfp);
1951 (void)sprintf(buf, "%s/sperl%s", BIN_EXP, patchlevel);
1952 execv(buf, origargv); /* try again */
1954 croak("Can't do setuid\n");
1957 if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid) {
1959 (void)setegid(statbuf.st_gid);
1962 (void)setregid((Gid_t)-1,statbuf.st_gid);
1964 #ifdef HAS_SETRESGID
1965 (void)setresgid((Gid_t)-1,statbuf.st_gid,(Gid_t)-1);
1967 setgid(statbuf.st_gid);
1971 if (getegid() != statbuf.st_gid)
1972 croak("Can't do setegid!\n");
1974 if (statbuf.st_mode & S_ISUID) {
1975 if (statbuf.st_uid != euid)
1977 (void)seteuid(statbuf.st_uid); /* all that for this */
1980 (void)setreuid((Uid_t)-1,statbuf.st_uid);
1982 #ifdef HAS_SETRESUID
1983 (void)setresuid((Uid_t)-1,statbuf.st_uid,(Uid_t)-1);
1985 setuid(statbuf.st_uid);
1989 if (geteuid() != statbuf.st_uid)
1990 croak("Can't do seteuid!\n");
1992 else if (uid) { /* oops, mustn't run as root */
1994 (void)seteuid((Uid_t)uid);
1997 (void)setreuid((Uid_t)-1,(Uid_t)uid);
1999 #ifdef HAS_SETRESUID
2000 (void)setresuid((Uid_t)-1,(Uid_t)uid,(Uid_t)-1);
2006 if (geteuid() != uid)
2007 croak("Can't do seteuid!\n");
2010 if (!cando(S_IXUSR,TRUE,&statbuf))
2011 croak("Permission denied\n"); /* they can't do this */
2014 else if (preprocess)
2015 croak("-P not allowed for setuid/setgid script\n");
2016 else if (fdscript >= 0)
2017 croak("fd script not allowed in suidperl\n");
2019 croak("Script is not setuid/setgid in suidperl\n");
2021 /* We absolutely must clear out any saved ids here, so we */
2022 /* exec the real perl, substituting fd script for scriptname. */
2023 /* (We pass script name as "subdir" of fd, which perl will grok.) */
2024 PerlIO_rewind(rsfp);
2025 lseek(PerlIO_fileno(rsfp),(Off_t)0,0); /* just in case rewind didn't */
2026 for (which = 1; origargv[which] && origargv[which] != scriptname; which++) ;
2027 if (!origargv[which])
2028 croak("Permission denied");
2029 (void)sprintf(buf, "/dev/fd/%d/%.127s", PerlIO_fileno(rsfp), origargv[which]);
2030 origargv[which] = buf;
2032 #if defined(HAS_FCNTL) && defined(F_SETFD)
2033 fcntl(PerlIO_fileno(rsfp),F_SETFD,0); /* ensure no close-on-exec */
2036 (void)sprintf(tokenbuf, "%s/perl%s", BIN_EXP, patchlevel);
2037 execv(tokenbuf, origargv); /* try again */
2038 croak("Can't do setuid\n");
2039 #endif /* IAMSUID */
2041 if (euid != uid || egid != gid) { /* (suidperl doesn't exist, in fact) */
2042 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
2043 Fstat(PerlIO_fileno(rsfp),&statbuf); /* may be either wrapped or real suid */
2044 if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
2046 (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
2049 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2050 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2051 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
2052 /* not set-id, must be wrapped */
2060 register char *s, *s2;
2062 /* skip forward in input to the real script? */
2066 if ((s = sv_gets(linestr, rsfp, 0)) == Nullch)
2067 croak("No Perl script found in input\n");
2068 if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
2069 PerlIO_ungetc(rsfp, '\n'); /* to keep line count right */
2071 while (*s && !(isSPACE (*s) || *s == '#')) s++;
2073 while (*s == ' ' || *s == '\t') s++;
2075 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
2076 if (strnEQ(s2-4,"perl",4))
2078 while (s = moreswitches(s)) ;
2080 if (cddir && chdir(cddir) < 0)
2081 croak("Can't chdir to %s",cddir);
2089 uid = (int)getuid();
2090 euid = (int)geteuid();
2091 gid = (int)getgid();
2092 egid = (int)getegid();
2097 tainting |= (uid && (euid != uid || egid != gid));
2105 croak("No %s allowed while running setuid", s);
2107 croak("No %s allowed while running setgid", s);
2113 curstash = debstash;
2114 dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
2116 DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
2117 DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
2118 DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
2119 DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
2120 sv_setiv(DBsingle, 0);
2121 DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
2122 sv_setiv(DBtrace, 0);
2123 DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
2124 sv_setiv(DBsignal, 0);
2125 curstash = defstash;
2132 mainstack = curstack; /* remember in case we switch stacks */
2133 AvREAL_off(curstack); /* not a real array */
2134 av_extend(curstack,127);
2136 stack_base = AvARRAY(curstack);
2137 stack_sp = stack_base;
2138 stack_max = stack_base + 127;
2140 cxstack_max = 8192 / sizeof(CONTEXT) - 2; /* Use most of 8K. */
2141 New(50,cxstack,cxstack_max + 1,CONTEXT);
2144 New(50,tmps_stack,128,SV*);
2149 New(51,debname,128,char);
2150 New(52,debdelim,128,char);
2154 * The following stacks almost certainly should be per-interpreter,
2155 * but for now they're not. XXX
2159 markstack_ptr = markstack;
2161 New(54,markstack,64,I32);
2162 markstack_ptr = markstack;
2163 markstack_max = markstack + 64;
2169 New(54,scopestack,32,I32);
2171 scopestack_max = 32;
2177 New(54,savestack,128,ANY);
2179 savestack_max = 128;
2185 New(54,retstack,16,OP*);
2195 Safefree(tmps_stack);
2202 static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
2210 subname = newSVpv("main",4);
2214 init_predump_symbols()
2219 sv_setpvn(GvSV(gv_fetchpv("\"", TRUE, SVt_PV)), " ", 1);
2221 stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
2222 GvMULTI_on(stdingv);
2223 IoIFP(GvIOp(stdingv)) = PerlIO_stdin();
2224 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
2226 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(stdingv));
2228 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
2230 IoOFP(GvIOp(tmpgv)) = IoIFP(GvIOp(tmpgv)) = PerlIO_stdout();
2232 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
2234 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(defoutgv));
2236 othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
2237 GvMULTI_on(othergv);
2238 IoOFP(GvIOp(othergv)) = IoIFP(GvIOp(othergv)) = PerlIO_stderr();
2239 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
2241 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(othergv));
2243 statname = NEWSV(66,0); /* last filename we did stat on */
2246 osname = savepv(OSNAME);
2250 init_postdump_symbols(argc,argv,env)
2252 register char **argv;
2253 register char **env;
2259 argc--,argv++; /* skip name of script */
2261 for (; argc > 0 && **argv == '-'; argc--,argv++) {
2264 if (argv[0][1] == '-') {
2268 if (s = strchr(argv[0], '=')) {
2270 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
2273 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
2276 toptarget = NEWSV(0,0);
2277 sv_upgrade(toptarget, SVt_PVFM);
2278 sv_setpvn(toptarget, "", 0);
2279 bodytarget = NEWSV(0,0);
2280 sv_upgrade(bodytarget, SVt_PVFM);
2281 sv_setpvn(bodytarget, "", 0);
2282 formtarget = bodytarget;
2285 if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
2286 sv_setpv(GvSV(tmpgv),origfilename);
2287 magicname("0", "0", 1);
2289 if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
2290 sv_setpv(GvSV(tmpgv),origargv[0]);
2291 if (argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
2293 (void)gv_AVadd(argvgv);
2294 av_clear(GvAVn(argvgv));
2295 for (; argc > 0; argc--,argv++) {
2296 av_push(GvAVn(argvgv),newSVpv(argv[0],0));
2299 if (envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
2303 hv_magic(hv, envgv, 'E');
2304 #ifndef VMS /* VMS doesn't have environ array */
2305 /* Note that if the supplied env parameter is actually a copy
2306 of the global environ then it may now point to free'd memory
2307 if the environment has been modified since. To avoid this
2308 problem we treat env==NULL as meaning 'use the default'
2313 environ[0] = Nullch;
2314 for (; *env; env++) {
2315 if (!(s = strchr(*env,'=')))
2321 sv = newSVpv(s--,0);
2322 (void)hv_store(hv, *env, s - *env, sv, 0);
2326 #ifdef DYNAMIC_ENV_FETCH
2327 HvNAME(hv) = savepv(ENV_HV_NAME);
2331 if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
2332 sv_setiv(GvSV(tmpgv), (IV)getpid());
2341 s = getenv("PERL5LIB");
2345 incpush(getenv("PERLLIB"), FALSE);
2347 /* Treat PERL5?LIB as a possible search list logical name -- the
2348 * "natural" VMS idiom for a Unix path string. We allow each
2349 * element to be a set of |-separated directories for compatibility.
2353 if (my_trnlnm("PERL5LIB",buf,0))
2354 do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
2356 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE);
2360 /* Use the ~-expanded versions of APPLIB (undocumented),
2361 ARCHLIB PRIVLIB SITEARCH SITELIB and OLDARCHLIB
2364 incpush(APPLLIB_EXP, FALSE);
2368 incpush(ARCHLIB_EXP, FALSE);
2371 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
2373 incpush(PRIVLIB_EXP, FALSE);
2376 incpush(SITEARCH_EXP, FALSE);
2379 incpush(SITELIB_EXP, FALSE);
2381 #ifdef OLDARCHLIB_EXP /* 5.00[01] compatibility */
2382 incpush(OLDARCHLIB_EXP, FALSE);
2386 incpush(".", FALSE);
2390 # define PERLLIB_SEP ';'
2393 # define PERLLIB_SEP '|'
2395 # define PERLLIB_SEP ':'
2398 #ifndef PERLLIB_MANGLE
2399 # define PERLLIB_MANGLE(s,n) (s)
2403 incpush(p, addsubdirs)
2407 SV *subdir = Nullsv;
2408 static char *archpat_auto;
2415 if (!archpat_auto) {
2416 STRLEN len = (sizeof(ARCHNAME) + strlen(patchlevel)
2417 + sizeof("//auto"));
2418 New(55, archpat_auto, len, char);
2419 sprintf(archpat_auto, "/%s/%s/auto", ARCHNAME, patchlevel);
2421 for (len = sizeof(ARCHNAME) + 2;
2422 archpat_auto[len] != '\0' && archpat_auto[len] != '/'; len++)
2423 if (archpat_auto[len] == '.') archpat_auto[len] = '_';
2428 /* Break at all separators */
2430 SV *libdir = newSV(0);
2433 /* skip any consecutive separators */
2434 while ( *p == PERLLIB_SEP ) {
2435 /* Uncomment the next line for PATH semantics */
2436 /* av_push(GvAVn(incgv), newSVpv(".", 1)); */
2440 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
2441 sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
2446 sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
2447 p = Nullch; /* break out */
2451 * BEFORE pushing libdir onto @INC we may first push version- and
2452 * archname-specific sub-directories.
2455 struct stat tmpstatbuf;
2460 if ((unix = tounixspec_ts(SvPV(libdir,na),Nullch)) != Nullch) {
2462 while (unix[len-1] == '/') len--; /* Cosmetic */
2463 sv_usepvn(libdir,unix,len);
2466 PerlIO_printf(PerlIO_stderr(),
2467 "Failed to unixify @INC element \"%s\"\n",
2470 /* .../archname/version if -d .../archname/version/auto */
2471 sv_setsv(subdir, libdir);
2472 sv_catpv(subdir, archpat_auto);
2473 if (Stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2474 S_ISDIR(tmpstatbuf.st_mode))
2475 av_push(GvAVn(incgv),
2476 newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2478 /* .../archname if -d .../archname/auto */
2479 sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME),
2480 strlen(patchlevel) + 1, "", 0);
2481 if (Stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2482 S_ISDIR(tmpstatbuf.st_mode))
2483 av_push(GvAVn(incgv),
2484 newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2487 /* finally push this lib directory on the end of @INC */
2488 av_push(GvAVn(incgv), libdir);
2491 SvREFCNT_dec(subdir);
2495 call_list(oldscope, list)
2499 line_t oldline = curcop->cop_line;
2504 while (AvFILL(list) >= 0) {
2505 CV *cv = (CV*)av_shift(list);
2512 SV* atsv = GvSV(errgv);
2514 perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
2515 (void)SvPV(atsv, len);
2518 curcop = &compiling;
2519 curcop->cop_line = oldline;
2520 if (list == beginav)
2521 sv_catpv(atsv, "BEGIN failed--compilation aborted");
2523 sv_catpv(atsv, "END failed--cleanup aborted");
2524 while (scopestack_ix > oldscope)
2526 croak("%s", SvPVX(atsv));
2534 /* my_exit() was called */
2535 while (scopestack_ix > oldscope)
2537 curstash = defstash;
2539 call_list(oldscope, endav);
2542 curcop = &compiling;
2543 curcop->cop_line = oldline;
2545 if (list == beginav)
2546 croak("BEGIN failed--compilation aborted");
2548 croak("END failed--cleanup aborted");
2554 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
2559 curcop = &compiling;
2560 curcop->cop_line = oldline;
2579 STATUS_NATIVE_SET(status);
2589 if (vaxc$errno & 1) {
2590 if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
2591 STATUS_NATIVE_SET(44);
2594 if (!vaxc$errno && errno) /* unlikely */
2595 STATUS_NATIVE_SET(44);
2597 STATUS_NATIVE_SET(vaxc$errno);
2601 STATUS_POSIX_SET(errno);
2602 else if (STATUS_POSIX == 0)
2603 STATUS_POSIX_SET(255);
2611 register CONTEXT *cx;
2620 (void)UNLINK(e_tmpname);
2621 Safefree(e_tmpname);
2625 if (cxstack_ix >= 0) {