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);
381 /* Without SVs, messages must be primitive. */
382 SvREFCNT_dec(mess_sv);
385 /* Now absolutely destruct everything, somehow or other, loops or no. */
387 SvFLAGS(strtab) |= SVTYPEMASK; /* don't clean out strtab now */
388 while (sv_count != 0 && sv_count != last_sv_count) {
389 last_sv_count = sv_count;
392 SvFLAGS(strtab) &= ~SVTYPEMASK;
393 SvFLAGS(strtab) |= SVt_PVHV;
395 /* Destruct the global string table. */
397 /* Yell and reset the HeVAL() slots that are still holding refcounts,
398 * so that sv_free() won't fail on them.
407 array = HvARRAY(strtab);
411 warn("Unbalanced string table refcount: (%d) for \"%s\"",
412 HeVAL(hent) - Nullsv, HeKEY(hent));
413 HeVAL(hent) = Nullsv;
423 SvREFCNT_dec(strtab);
426 warn("Scalars leaked: %ld\n", (long)sv_count);
430 /* No SVs have survived, need to clean out */
434 Safefree(origfilename);
436 hints = 0; /* Reset hints. Should hints be per-interpreter ? */
438 DEBUG_P(debprofdump());
443 PerlInterpreter *sv_interp;
445 if (!(curinterp = sv_interp))
451 perl_parse(sv_interp, xsinit, argc, argv, env)
452 PerlInterpreter *sv_interp;
453 void (*xsinit)_((void));
460 char *scriptname = NULL;
461 VOL bool dosearch = FALSE;
468 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
471 croak("suidperl is no longer needed since the kernel can now execute\n\
472 setuid perl scripts securely.\n");
476 if (!(curinterp = sv_interp))
479 #if defined(NeXT) && defined(__DYNAMIC__)
480 _dyld_lookup_and_bind
481 ("__environ", (unsigned long *) &environ_pointer, NULL);
486 #ifndef VMS /* VMS doesn't have environ array */
487 origenviron = environ;
493 /* Come here if running an undumped a.out. */
495 origfilename = savepv(argv[0]);
497 cxstack_ix = -1; /* start label stack again */
499 init_postdump_symbols(argc,argv,env);
504 curpad = AvARRAY(comppad);
509 SvREFCNT_dec(main_cv);
513 oldscope = scopestack_ix;
521 /* my_exit() was called */
522 while (scopestack_ix > oldscope)
526 call_list(oldscope, endav);
528 return STATUS_NATIVE_EXPORT;
531 PerlIO_printf(PerlIO_stderr(), "panic: top_env\n");
535 sv_setpvn(linestr,"",0);
536 sv = newSVpv("",0); /* first used for -I flags */
540 for (argc--,argv++; argc > 0; argc--,argv++) {
541 if (argv[0][0] != '-' || !argv[0][1])
545 validarg = " PHOOEY ";
570 if (s = moreswitches(s))
580 if (euid != uid || egid != gid)
581 croak("No -e allowed in setuid scripts");
583 e_tmpname = savepv(TMPPATH);
584 (void)mktemp(e_tmpname);
586 croak("Can't mktemp()");
587 e_fp = PerlIO_open(e_tmpname,"w");
589 croak("Cannot open temporary file");
594 PerlIO_puts(e_fp,argv[1]);
598 croak("No code specified for -e");
599 (void)PerlIO_putc(e_fp,'\n');
610 incpush(argv[1], TRUE);
611 sv_catpv(sv,argv[1]);
628 preambleav = newAV();
629 av_push(preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
631 Sv = newSVpv("print myconfig();",0);
633 sv_catpv(Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
635 sv_catpv(Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
637 #if defined(DEBUGGING) || defined(NO_EMBED) || defined(MULTIPLICITY)
638 sv_catpv(Sv,"\" Compile-time options:");
640 sv_catpv(Sv," DEBUGGING");
643 sv_catpv(Sv," NO_EMBED");
646 sv_catpv(Sv," MULTIPLICITY");
648 sv_catpv(Sv,"\\n\",");
650 #if defined(LOCAL_PATCH_COUNT)
651 if (LOCAL_PATCH_COUNT > 0) {
653 sv_catpv(Sv,"\" Locally applied patches:\\n\",");
654 for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
656 sv_catpvf(Sv,"\" \\t%s\\n\",",localpatches[i]);
660 sv_catpvf(Sv,"\" Built under %s\\n\"",OSNAME);
663 sv_catpvf(Sv,",\" Compiled at %s %s\\n\"",__DATE__,__TIME__);
665 sv_catpvf(Sv,",\" Compiled on %s\\n\"",__DATE__);
670 @env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; \
671 print \" \\%ENV:\\n @env\\n\" if @env; \
672 print \" \\@INC:\\n @INC\\n\";");
675 Sv = newSVpv("config_vars(qw(",0);
680 av_push(preambleav, Sv);
681 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
695 croak("Unrecognized switch: -%s",s);
700 if (!tainting && (s = getenv("PERL5OPT"))) {
711 if (!strchr("DIMUdmw", *s))
712 croak("Illegal switch in PERL5OPT: -%c", *s);
718 scriptname = argv[0];
720 if (PerlIO_flush(e_fp) || PerlIO_error(e_fp) || PerlIO_close(e_fp)) {
722 warn("Did you forget to compile with -DMULTIPLICITY?");
724 croak("Can't write to temp file for -e: %s", Strerror(errno));
728 scriptname = e_tmpname;
730 else if (scriptname == Nullch) {
732 if ( isatty(PerlIO_fileno(PerlIO_stdin())) )
740 open_script(scriptname,dosearch,sv);
742 validate_suid(validarg, scriptname);
747 main_cv = compcv = (CV*)NEWSV(1104,0);
748 sv_upgrade((SV *)compcv, SVt_PVCV);
752 av_push(comppad, Nullsv);
753 curpad = AvARRAY(comppad);
754 comppad_name = newAV();
755 comppad_name_fill = 0;
756 min_intro_pending = 0;
759 comppadlist = newAV();
760 AvREAL_off(comppadlist);
761 av_store(comppadlist, 0, (SV*)comppad_name);
762 av_store(comppadlist, 1, (SV*)comppad);
763 CvPADLIST(compcv) = comppadlist;
765 boot_core_UNIVERSAL();
767 (*xsinit)(); /* in case linked C routines want magical variables */
772 init_predump_symbols();
774 init_postdump_symbols(argc,argv,env);
778 /* now parse the script */
781 if (yyparse() || error_count) {
783 croak("%s had compilation errors.\n", origfilename);
785 croak("Execution of %s aborted due to compilation errors.\n",
789 curcop->cop_line = 0;
793 (void)UNLINK(e_tmpname);
798 /* now that script is parsed, we can modify record separator */
800 rs = SvREFCNT_inc(nrs);
801 sv_setsv(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), rs);
812 #ifdef DEBUGGING_MSTATS
813 if ((s=getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
814 dump_mstats("after compilation:");
825 PerlInterpreter *sv_interp;
831 if (!(curinterp = sv_interp))
834 oldscope = scopestack_ix;
839 cxstack_ix = -1; /* start context stack again */
842 /* my_exit() was called */
843 while (scopestack_ix > oldscope)
847 call_list(oldscope, endav);
849 #ifdef DEBUGGING_MSTATS
850 if (getenv("PERL_DEBUG_MSTATS"))
851 dump_mstats("after execution: ");
854 return STATUS_NATIVE_EXPORT;
857 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
862 if (curstack != mainstack) {
864 SWITCHSTACK(curstack, mainstack);
869 DEBUG_r(PerlIO_printf(PerlIO_stderr(), "%s $` $& $' support.\n",
870 sawampersand ? "Enabling" : "Omitting"));
874 DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
877 PerlIO_printf(PerlIO_stderr(), "%s syntax OK\n", origfilename);
880 if (perldb && DBsingle)
881 sv_setiv(DBsingle, 1);
891 else if (main_start) {
892 CvDEPTH(main_cv) = 1;
903 perl_get_sv(name, create)
907 GV* gv = gv_fetchpv(name, create, SVt_PV);
914 perl_get_av(name, create)
918 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
927 perl_get_hv(name, create)
931 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
940 perl_get_cv(name, create)
944 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
945 if (create && !GvCVu(gv))
946 return newSUB(start_subparse(FALSE, 0),
947 newSVOP(OP_CONST, 0, newSVpv(name,0)),
955 /* Be sure to refetch the stack pointer after calling these routines. */
958 perl_call_argv(subname, flags, argv)
960 I32 flags; /* See G_* flags in cop.h */
961 register char **argv; /* null terminated arg list */
968 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
973 return perl_call_pv(subname, flags);
977 perl_call_pv(subname, flags)
978 char *subname; /* name of the subroutine */
979 I32 flags; /* See G_* flags in cop.h */
981 return perl_call_sv((SV*)perl_get_cv(subname, TRUE), flags);
985 perl_call_method(methname, flags)
986 char *methname; /* name of the subroutine */
987 I32 flags; /* See G_* flags in cop.h */
993 XPUSHs(sv_2mortal(newSVpv(methname,0)));
996 return perl_call_sv(*stack_sp--, flags);
999 /* May be called with any of a CV, a GV, or an SV containing the name. */
1001 perl_call_sv(sv, flags)
1003 I32 flags; /* See G_* flags in cop.h */
1005 LOGOP myop; /* fake syntax tree node */
1011 bool oldcatch = CATCH_GET;
1015 if (flags & G_DISCARD) {
1020 Zero(&myop, 1, LOGOP);
1021 myop.op_next = Nullop;
1022 if (!(flags & G_NOARGS))
1023 myop.op_flags |= OPf_STACKED;
1024 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1025 (flags & G_ARRAY) ? OPf_WANT_LIST :
1030 EXTEND(stack_sp, 1);
1033 oldscope = scopestack_ix;
1035 if (perldb && curstash != debstash
1036 /* Handle first BEGIN of -d. */
1037 && (DBcv || (DBcv = GvCV(DBsub)))
1038 /* Try harder, since this may have been a sighandler, thus
1039 * curstash may be meaningless. */
1040 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != debstash))
1041 op->op_private |= OPpENTERSUB_DB;
1043 if (flags & G_EVAL) {
1044 cLOGOP->op_other = op;
1046 /* we're trying to emulate pp_entertry() here */
1048 register CONTEXT *cx;
1049 I32 gimme = GIMME_V;
1054 push_return(op->op_next);
1055 PUSHBLOCK(cx, CXt_EVAL, stack_sp);
1057 eval_root = op; /* Only needed so that goto works right. */
1060 if (flags & G_KEEPERR)
1063 sv_setpv(GvSV(errgv),"");
1075 /* my_exit() was called */
1076 curstash = defstash;
1080 croak("Callback called exit");
1089 stack_sp = stack_base + oldmark;
1090 if (flags & G_ARRAY)
1094 *++stack_sp = &sv_undef;
1102 if (op == (OP*)&myop)
1106 retval = stack_sp - (stack_base + oldmark);
1107 if ((flags & G_EVAL) && !(flags & G_KEEPERR))
1108 sv_setpv(GvSV(errgv),"");
1111 if (flags & G_EVAL) {
1112 if (scopestack_ix > oldscope) {
1116 register CONTEXT *cx;
1128 CATCH_SET(oldcatch);
1130 if (flags & G_DISCARD) {
1131 stack_sp = stack_base + oldmark;
1139 /* Eval a string. The G_EVAL flag is always assumed. */
1142 perl_eval_sv(sv, flags)
1144 I32 flags; /* See G_* flags in cop.h */
1146 UNOP myop; /* fake syntax tree node */
1148 I32 oldmark = sp - stack_base;
1154 if (flags & G_DISCARD) {
1162 EXTEND(stack_sp, 1);
1164 oldscope = scopestack_ix;
1166 if (!(flags & G_NOARGS))
1167 myop.op_flags = OPf_STACKED;
1168 myop.op_next = Nullop;
1169 myop.op_type = OP_ENTEREVAL;
1170 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1171 (flags & G_ARRAY) ? OPf_WANT_LIST :
1173 if (flags & G_KEEPERR)
1174 myop.op_flags |= OPf_SPECIAL;
1184 /* my_exit() was called */
1185 curstash = defstash;
1189 croak("Callback called exit");
1198 stack_sp = stack_base + oldmark;
1199 if (flags & G_ARRAY)
1203 *++stack_sp = &sv_undef;
1208 if (op == (OP*)&myop)
1209 op = pp_entereval();
1212 retval = stack_sp - (stack_base + oldmark);
1213 if (!(flags & G_KEEPERR))
1214 sv_setpv(GvSV(errgv),"");
1218 if (flags & G_DISCARD) {
1219 stack_sp = stack_base + oldmark;
1228 perl_eval_pv(p, croak_on_error)
1233 SV* sv = newSVpv(p, 0);
1236 perl_eval_sv(sv, G_SCALAR);
1243 if (croak_on_error && SvTRUE(GvSV(errgv)))
1244 croak(SvPVx(GvSV(errgv), na));
1249 /* Require a module. */
1255 SV* sv = sv_newmortal();
1256 sv_setpv(sv, "require '");
1259 perl_eval_sv(sv, G_DISCARD);
1263 magicname(sym,name,namlen)
1270 if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
1271 sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
1275 usage(name) /* XXX move this out into a module ? */
1278 /* This message really ought to be max 23 lines.
1279 * Removed -h because the user already knows that opton. Others? */
1280 printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
1281 printf("\n -0[octal] specify record separator (\\0, if no argument)");
1282 printf("\n -a autosplit mode with -n or -p (splits $_ into @F)");
1283 printf("\n -c check syntax only (runs BEGIN and END blocks)");
1284 printf("\n -d[:debugger] run scripts under debugger");
1285 printf("\n -D[number/list] set debugging flags (argument is a bit mask or flags)");
1286 printf("\n -e 'command' one line of script. Several -e's allowed. Omit [programfile].");
1287 printf("\n -F/pattern/ split() pattern for autosplit (-a). The //'s are optional.");
1288 printf("\n -i[extension] edit <> files in place (make backup if extension supplied)");
1289 printf("\n -Idirectory specify @INC/#include directory (may be used more then once)");
1290 printf("\n -l[octal] enable line ending processing, specifies line teminator");
1291 printf("\n -[mM][-]module.. executes `use/no module...' before executing your script.");
1292 printf("\n -n assume 'while (<>) { ... }' loop arround your script");
1293 printf("\n -p assume loop like -n but print line also like sed");
1294 printf("\n -P run script through C preprocessor before compilation");
1295 printf("\n -s enable some switch parsing for switches after script name");
1296 printf("\n -S look for the script using PATH environment variable");
1297 printf("\n -T turn on tainting checks");
1298 printf("\n -u dump core after parsing script");
1299 printf("\n -U allow unsafe operations");
1300 printf("\n -v print version number and patchlevel of perl");
1301 printf("\n -V[:variable] print perl configuration information");
1302 printf("\n -w TURN WARNINGS ON FOR COMPILATION OF YOUR SCRIPT.");
1303 printf("\n -x[directory] strip off text before #!perl line and perhaps cd to directory\n");
1306 /* This routine handles any switches that can be given during run */
1317 rschar = scan_oct(s, 4, &numlen);
1319 if (rschar & ~((U8)~0))
1321 else if (!rschar && numlen >= 2)
1322 nrs = newSVpv("", 0);
1325 nrs = newSVpv(&ch, 1);
1330 splitstr = savepv(s + 1);
1344 if (*s == ':' || *s == '=') {
1345 my_setenv("PERL5DB", form("use Devel::%s;", ++s));
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 */
1547 prog = newSVpv(BIN_EXP);
1548 sv_catpv(prog, "/perl");
1549 file = newSVpv(origfilename);
1550 sv_catpv(file, ".perldump");
1552 status = unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
1554 PerlIO_printf(PerlIO_stderr(), "unexec of %s into %s failed!\n",
1555 SvPVX(prog), SvPVX(file));
1559 # include <lib$routines.h>
1560 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
1562 ABORT(); /* for use with undump */
1572 /* Note that strtab is a rather special HV. Assumptions are made
1573 about not iterating on it, and not adding tie magic to it.
1574 It is properly deallocated in perl_destruct() */
1576 HvSHAREKEYS_off(strtab); /* mandatory */
1577 Newz(506,((XPVHV*)SvANY(strtab))->xhv_array,
1578 sizeof(HE*) * (((XPVHV*)SvANY(strtab))->xhv_max + 1), char);
1580 curstash = defstash = newHV();
1581 curstname = newSVpv("main",4);
1582 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
1583 SvREFCNT_dec(GvHV(gv));
1584 GvHV(gv) = (HV*)SvREFCNT_inc(defstash);
1586 HvNAME(defstash) = savepv("main");
1587 incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
1589 defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
1590 errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
1592 sv_setpvn(GvSV(errgv), "", 0);
1593 curstash = defstash;
1594 compiling.cop_stash = defstash;
1595 debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
1596 /* We must init $/ before switches are processed. */
1597 sv_setpvn(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), "\n", 1);
1600 #ifdef CAN_PROTOTYPE
1602 open_script(char *scriptname, bool dosearch, SV *sv)
1605 open_script(scriptname,dosearch,sv)
1611 char *xfound = Nullch;
1612 char *xfailed = Nullch;
1616 #if defined(DOSISH) && !defined(OS2) && !defined(atarist)
1617 #define SEARCH_EXTS ".bat", ".cmd", NULL
1620 # define SEARCH_EXTS ".pl", ".com", NULL
1622 /* additional extensions to try in each dir if scriptname not found */
1624 char *ext[] = { SEARCH_EXTS };
1625 int extidx = (strchr(scriptname,'.')) ? -1 : 0; /* has ext already */
1630 int hasdir, idx = 0, deftypes = 1;
1632 hasdir = (strpbrk(scriptname,":[</") != Nullch) ;
1633 /* The first time through, just add SEARCH_EXTS to whatever we
1634 * already have, so we can check for default file types. */
1635 while (deftypes || (!hasdir && my_trnlnm("DCL$PATH",tokenbuf,idx++)) ) {
1636 if (deftypes) { deftypes = 0; *tokenbuf = '\0'; }
1637 strcat(tokenbuf,scriptname);
1639 if (dosearch && !strchr(scriptname, '/') && (s = getenv("PATH"))) {
1641 bufend = s + strlen(s);
1644 s = cpytill(tokenbuf,s,bufend,':',&len);
1647 for (len = 0; *s && *s != ',' && *s != ';'; tokenbuf[len++] = *s++);
1648 tokenbuf[len] = '\0';
1650 for (len = 0; *s && *s != ';'; tokenbuf[len++] = *s++);
1651 tokenbuf[len] = '\0';
1657 if (len && tokenbuf[len-1] != '/')
1660 if (len && ((tokenbuf[len-1] != '\\') && (tokenbuf[len-1] != '/')))
1662 if (len && tokenbuf[len-1] != '\\')
1665 (void)strcat(tokenbuf+len,"/");
1666 (void)strcat(tokenbuf+len,scriptname);
1670 len = strlen(tokenbuf);
1671 if (extidx > 0) /* reset after previous loop */
1675 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tokenbuf));
1676 retval = Stat(tokenbuf,&statbuf);
1678 } while ( retval < 0 /* not there */
1679 && extidx>=0 && ext[extidx] /* try an extension? */
1680 && strcpy(tokenbuf+len, ext[extidx++])
1685 if (S_ISREG(statbuf.st_mode)
1686 && cando(S_IRUSR,TRUE,&statbuf) && cando(S_IXUSR,TRUE,&statbuf)) {
1687 xfound = tokenbuf; /* bingo! */
1691 xfailed = savepv(tokenbuf);
1694 croak("Can't execute %s", xfailed ? xfailed : scriptname );
1697 scriptname = xfound;
1700 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
1701 char *s = scriptname + 8;
1710 origfilename = savepv(e_tmpname ? "-e" : scriptname);
1711 curcop->cop_filegv = gv_fetchfile(origfilename);
1712 if (strEQ(origfilename,"-"))
1714 if (fdscript >= 0) {
1715 rsfp = PerlIO_fdopen(fdscript,"r");
1716 #if defined(HAS_FCNTL) && defined(F_SETFD)
1718 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
1721 else if (preprocess) {
1722 char *cpp_cfg = CPPSTDIN;
1723 SV *cpp = NEWSV(0,0);
1724 SV *cmd = NEWSV(0,0);
1726 if (strEQ(cpp_cfg, "cppstdin"))
1727 sv_catpvf(cpp, "%s/", BIN_EXP);
1728 sv_catpv(cpp, cpp_cfg);
1731 sv_catpv(sv,PRIVLIB_EXP);
1735 sed %s -e \"/^[^#]/b\" \
1736 -e \"/^#[ ]*include[ ]/b\" \
1737 -e \"/^#[ ]*define[ ]/b\" \
1738 -e \"/^#[ ]*if[ ]/b\" \
1739 -e \"/^#[ ]*ifdef[ ]/b\" \
1740 -e \"/^#[ ]*ifndef[ ]/b\" \
1741 -e \"/^#[ ]*else/b\" \
1742 -e \"/^#[ ]*elif[ ]/b\" \
1743 -e \"/^#[ ]*undef[ ]/b\" \
1744 -e \"/^#[ ]*endif/b\" \
1747 (doextract ? "-e \"1,/^#/d\n\"" : ""),
1750 %s %s -e '/^[^#]/b' \
1751 -e '/^#[ ]*include[ ]/b' \
1752 -e '/^#[ ]*define[ ]/b' \
1753 -e '/^#[ ]*if[ ]/b' \
1754 -e '/^#[ ]*ifdef[ ]/b' \
1755 -e '/^#[ ]*ifndef[ ]/b' \
1756 -e '/^#[ ]*else/b' \
1757 -e '/^#[ ]*elif[ ]/b' \
1758 -e '/^#[ ]*undef[ ]/b' \
1759 -e '/^#[ ]*endif/b' \
1767 (doextract ? "-e '1,/^#/d\n'" : ""),
1769 scriptname, cpp, sv, CPPMINUS);
1771 #ifdef IAMSUID /* actually, this is caught earlier */
1772 if (euid != uid && !euid) { /* if running suidperl */
1774 (void)seteuid(uid); /* musn't stay setuid root */
1777 (void)setreuid((Uid_t)-1, uid);
1779 #ifdef HAS_SETRESUID
1780 (void)setresuid((Uid_t)-1, uid, (Uid_t)-1);
1786 if (geteuid() != uid)
1787 croak("Can't do seteuid!\n");
1789 #endif /* IAMSUID */
1790 rsfp = my_popen(SvPVX(cmd), "r");
1794 else if (!*scriptname) {
1795 forbid_setid("program input from stdin");
1796 rsfp = PerlIO_stdin();
1799 rsfp = PerlIO_open(scriptname,"r");
1800 #if defined(HAS_FCNTL) && defined(F_SETFD)
1802 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
1810 #ifndef IAMSUID /* in case script is not readable before setuid */
1811 if (euid && Stat(SvPVX(GvSV(curcop->cop_filegv)),&statbuf) >= 0 &&
1812 statbuf.st_mode & (S_ISUID|S_ISGID)) {
1814 execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
1815 croak("Can't do setuid\n");
1819 croak("Can't open perl script \"%s\": %s\n",
1820 SvPVX(GvSV(curcop->cop_filegv)), Strerror(errno));
1825 validate_suid(validarg, scriptname)
1831 /* do we need to emulate setuid on scripts? */
1833 /* This code is for those BSD systems that have setuid #! scripts disabled
1834 * in the kernel because of a security problem. Merely defining DOSUID
1835 * in perl will not fix that problem, but if you have disabled setuid
1836 * scripts in the kernel, this will attempt to emulate setuid and setgid
1837 * on scripts that have those now-otherwise-useless bits set. The setuid
1838 * root version must be called suidperl or sperlN.NNN. If regular perl
1839 * discovers that it has opened a setuid script, it calls suidperl with
1840 * the same argv that it had. If suidperl finds that the script it has
1841 * just opened is NOT setuid root, it sets the effective uid back to the
1842 * uid. We don't just make perl setuid root because that loses the
1843 * effective uid we had before invoking perl, if it was different from the
1846 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
1847 * be defined in suidperl only. suidperl must be setuid root. The
1848 * Configure script will set this up for you if you want it.
1854 if (Fstat(PerlIO_fileno(rsfp),&statbuf) < 0) /* normal stat is insecure */
1855 croak("Can't stat script \"%s\"",origfilename);
1856 if (fdscript < 0 && statbuf.st_mode & (S_ISUID|S_ISGID)) {
1860 #ifndef HAS_SETREUID
1861 /* On this access check to make sure the directories are readable,
1862 * there is actually a small window that the user could use to make
1863 * filename point to an accessible directory. So there is a faint
1864 * chance that someone could execute a setuid script down in a
1865 * non-accessible directory. I don't know what to do about that.
1866 * But I don't think it's too important. The manual lies when
1867 * it says access() is useful in setuid programs.
1869 if (access(SvPVX(GvSV(curcop->cop_filegv)),1)) /*double check*/
1870 croak("Permission denied");
1872 /* If we can swap euid and uid, then we can determine access rights
1873 * with a simple stat of the file, and then compare device and
1874 * inode to make sure we did stat() on the same file we opened.
1875 * Then we just have to make sure he or she can execute it.
1878 struct stat tmpstatbuf;
1882 setreuid(euid,uid) < 0
1885 setresuid(euid,uid,(Uid_t)-1) < 0
1888 || getuid() != euid || geteuid() != uid)
1889 croak("Can't swap uid and euid"); /* really paranoid */
1890 if (Stat(SvPVX(GvSV(curcop->cop_filegv)),&tmpstatbuf) < 0)
1891 croak("Permission denied"); /* testing full pathname here */
1892 if (tmpstatbuf.st_dev != statbuf.st_dev ||
1893 tmpstatbuf.st_ino != statbuf.st_ino) {
1894 (void)PerlIO_close(rsfp);
1895 if (rsfp = my_popen("/bin/mail root","w")) { /* heh, heh */
1897 "User %ld tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
1898 (Filename of set-id script was %s, uid %ld gid %ld.)\n\nSincerely,\nperl\n",
1899 (long)uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
1900 (long)statbuf.st_dev, (long)statbuf.st_ino,
1901 SvPVX(GvSV(curcop->cop_filegv)),
1902 (long)statbuf.st_uid, (long)statbuf.st_gid);
1903 (void)my_pclose(rsfp);
1905 croak("Permission denied\n");
1909 setreuid(uid,euid) < 0
1911 # if defined(HAS_SETRESUID)
1912 setresuid(uid,euid,(Uid_t)-1) < 0
1915 || getuid() != uid || geteuid() != euid)
1916 croak("Can't reswap uid and euid");
1917 if (!cando(S_IXUSR,FALSE,&statbuf)) /* can real uid exec? */
1918 croak("Permission denied\n");
1920 #endif /* HAS_SETREUID */
1921 #endif /* IAMSUID */
1923 if (!S_ISREG(statbuf.st_mode))
1924 croak("Permission denied");
1925 if (statbuf.st_mode & S_IWOTH)
1926 croak("Setuid/gid script is writable by world");
1927 doswitches = FALSE; /* -s is insecure in suid */
1929 if (sv_gets(linestr, rsfp, 0) == Nullch ||
1930 strnNE(SvPV(linestr,na),"#!",2) ) /* required even on Sys V */
1931 croak("No #! line");
1932 s = SvPV(linestr,na)+2;
1934 while (!isSPACE(*s)) s++;
1935 for (s2 = s; (s2 > SvPV(linestr,na)+2 &&
1936 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
1937 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
1938 croak("Not a perl script");
1939 while (*s == ' ' || *s == '\t') s++;
1941 * #! arg must be what we saw above. They can invoke it by
1942 * mentioning suidperl explicitly, but they may not add any strange
1943 * arguments beyond what #! says if they do invoke suidperl that way.
1945 len = strlen(validarg);
1946 if (strEQ(validarg," PHOOEY ") ||
1947 strnNE(s,validarg,len) || !isSPACE(s[len]))
1948 croak("Args must match #! line");
1951 if (euid != uid && (statbuf.st_mode & S_ISUID) &&
1952 euid == statbuf.st_uid)
1954 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
1955 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
1956 #endif /* IAMSUID */
1958 if (euid) { /* oops, we're not the setuid root perl */
1959 (void)PerlIO_close(rsfp);
1962 execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
1964 croak("Can't do setuid\n");
1967 if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid) {
1969 (void)setegid(statbuf.st_gid);
1972 (void)setregid((Gid_t)-1,statbuf.st_gid);
1974 #ifdef HAS_SETRESGID
1975 (void)setresgid((Gid_t)-1,statbuf.st_gid,(Gid_t)-1);
1977 setgid(statbuf.st_gid);
1981 if (getegid() != statbuf.st_gid)
1982 croak("Can't do setegid!\n");
1984 if (statbuf.st_mode & S_ISUID) {
1985 if (statbuf.st_uid != euid)
1987 (void)seteuid(statbuf.st_uid); /* all that for this */
1990 (void)setreuid((Uid_t)-1,statbuf.st_uid);
1992 #ifdef HAS_SETRESUID
1993 (void)setresuid((Uid_t)-1,statbuf.st_uid,(Uid_t)-1);
1995 setuid(statbuf.st_uid);
1999 if (geteuid() != statbuf.st_uid)
2000 croak("Can't do seteuid!\n");
2002 else if (uid) { /* oops, mustn't run as root */
2004 (void)seteuid((Uid_t)uid);
2007 (void)setreuid((Uid_t)-1,(Uid_t)uid);
2009 #ifdef HAS_SETRESUID
2010 (void)setresuid((Uid_t)-1,(Uid_t)uid,(Uid_t)-1);
2016 if (geteuid() != uid)
2017 croak("Can't do seteuid!\n");
2020 if (!cando(S_IXUSR,TRUE,&statbuf))
2021 croak("Permission denied\n"); /* they can't do this */
2024 else if (preprocess)
2025 croak("-P not allowed for setuid/setgid script\n");
2026 else if (fdscript >= 0)
2027 croak("fd script not allowed in suidperl\n");
2029 croak("Script is not setuid/setgid in suidperl\n");
2031 /* We absolutely must clear out any saved ids here, so we */
2032 /* exec the real perl, substituting fd script for scriptname. */
2033 /* (We pass script name as "subdir" of fd, which perl will grok.) */
2034 PerlIO_rewind(rsfp);
2035 lseek(PerlIO_fileno(rsfp),(Off_t)0,0); /* just in case rewind didn't */
2036 for (which = 1; origargv[which] && origargv[which] != scriptname; which++) ;
2037 if (!origargv[which])
2038 croak("Permission denied");
2039 origargv[which] = savepv(form("/dev/fd/%d/%s",
2040 PerlIO_fileno(rsfp), origargv[which]));
2041 #if defined(HAS_FCNTL) && defined(F_SETFD)
2042 fcntl(PerlIO_fileno(rsfp),F_SETFD,0); /* ensure no close-on-exec */
2044 execv(form("%s/perl%s", BIN_EXP, patchlevel), origargv); /* try again */
2045 croak("Can't do setuid\n");
2046 #endif /* IAMSUID */
2048 if (euid != uid || egid != gid) { /* (suidperl doesn't exist, in fact) */
2049 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
2050 Fstat(PerlIO_fileno(rsfp),&statbuf); /* may be either wrapped or real suid */
2051 if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
2053 (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
2056 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2057 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2058 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
2059 /* not set-id, must be wrapped */
2067 register char *s, *s2;
2069 /* skip forward in input to the real script? */
2073 if ((s = sv_gets(linestr, rsfp, 0)) == Nullch)
2074 croak("No Perl script found in input\n");
2075 if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
2076 PerlIO_ungetc(rsfp, '\n'); /* to keep line count right */
2078 while (*s && !(isSPACE (*s) || *s == '#')) s++;
2080 while (*s == ' ' || *s == '\t') s++;
2082 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
2083 if (strnEQ(s2-4,"perl",4))
2085 while (s = moreswitches(s)) ;
2087 if (cddir && chdir(cddir) < 0)
2088 croak("Can't chdir to %s",cddir);
2096 uid = (int)getuid();
2097 euid = (int)geteuid();
2098 gid = (int)getgid();
2099 egid = (int)getegid();
2104 tainting |= (uid && (euid != uid || egid != gid));
2112 croak("No %s allowed while running setuid", s);
2114 croak("No %s allowed while running setgid", s);
2120 curstash = debstash;
2121 dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
2123 DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
2124 DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
2125 DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
2126 DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
2127 sv_setiv(DBsingle, 0);
2128 DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
2129 sv_setiv(DBtrace, 0);
2130 DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
2131 sv_setiv(DBsignal, 0);
2132 curstash = defstash;
2139 mainstack = curstack; /* remember in case we switch stacks */
2140 AvREAL_off(curstack); /* not a real array */
2141 av_extend(curstack,127);
2143 stack_base = AvARRAY(curstack);
2144 stack_sp = stack_base;
2145 stack_max = stack_base + 127;
2147 cxstack_max = 8192 / sizeof(CONTEXT) - 2; /* Use most of 8K. */
2148 New(50,cxstack,cxstack_max + 1,CONTEXT);
2151 New(50,tmps_stack,128,SV*);
2156 New(51,debname,128,char);
2157 New(52,debdelim,128,char);
2161 * The following stacks almost certainly should be per-interpreter,
2162 * but for now they're not. XXX
2166 markstack_ptr = markstack;
2168 New(54,markstack,64,I32);
2169 markstack_ptr = markstack;
2170 markstack_max = markstack + 64;
2176 New(54,scopestack,32,I32);
2178 scopestack_max = 32;
2184 New(54,savestack,128,ANY);
2186 savestack_max = 128;
2192 New(54,retstack,16,OP*);
2202 Safefree(tmps_stack);
2209 static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
2217 subname = newSVpv("main",4);
2221 init_predump_symbols()
2226 sv_setpvn(GvSV(gv_fetchpv("\"", TRUE, SVt_PV)), " ", 1);
2228 stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
2229 GvMULTI_on(stdingv);
2230 IoIFP(GvIOp(stdingv)) = PerlIO_stdin();
2231 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
2233 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(stdingv));
2235 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
2237 IoOFP(GvIOp(tmpgv)) = IoIFP(GvIOp(tmpgv)) = PerlIO_stdout();
2239 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
2241 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(defoutgv));
2243 othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
2244 GvMULTI_on(othergv);
2245 IoOFP(GvIOp(othergv)) = IoIFP(GvIOp(othergv)) = PerlIO_stderr();
2246 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
2248 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(othergv));
2250 statname = NEWSV(66,0); /* last filename we did stat on */
2253 osname = savepv(OSNAME);
2257 init_postdump_symbols(argc,argv,env)
2259 register char **argv;
2260 register char **env;
2266 argc--,argv++; /* skip name of script */
2268 for (; argc > 0 && **argv == '-'; argc--,argv++) {
2271 if (argv[0][1] == '-') {
2275 if (s = strchr(argv[0], '=')) {
2277 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
2280 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
2283 toptarget = NEWSV(0,0);
2284 sv_upgrade(toptarget, SVt_PVFM);
2285 sv_setpvn(toptarget, "", 0);
2286 bodytarget = NEWSV(0,0);
2287 sv_upgrade(bodytarget, SVt_PVFM);
2288 sv_setpvn(bodytarget, "", 0);
2289 formtarget = bodytarget;
2292 if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
2293 sv_setpv(GvSV(tmpgv),origfilename);
2294 magicname("0", "0", 1);
2296 if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
2297 sv_setpv(GvSV(tmpgv),origargv[0]);
2298 if (argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
2300 (void)gv_AVadd(argvgv);
2301 av_clear(GvAVn(argvgv));
2302 for (; argc > 0; argc--,argv++) {
2303 av_push(GvAVn(argvgv),newSVpv(argv[0],0));
2306 if (envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
2310 hv_magic(hv, envgv, 'E');
2311 #ifndef VMS /* VMS doesn't have environ array */
2312 /* Note that if the supplied env parameter is actually a copy
2313 of the global environ then it may now point to free'd memory
2314 if the environment has been modified since. To avoid this
2315 problem we treat env==NULL as meaning 'use the default'
2320 environ[0] = Nullch;
2321 for (; *env; env++) {
2322 if (!(s = strchr(*env,'=')))
2328 sv = newSVpv(s--,0);
2329 (void)hv_store(hv, *env, s - *env, sv, 0);
2333 #ifdef DYNAMIC_ENV_FETCH
2334 HvNAME(hv) = savepv(ENV_HV_NAME);
2338 if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
2339 sv_setiv(GvSV(tmpgv), (IV)getpid());
2348 s = getenv("PERL5LIB");
2352 incpush(getenv("PERLLIB"), FALSE);
2354 /* Treat PERL5?LIB as a possible search list logical name -- the
2355 * "natural" VMS idiom for a Unix path string. We allow each
2356 * element to be a set of |-separated directories for compatibility.
2360 if (my_trnlnm("PERL5LIB",buf,0))
2361 do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
2363 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE);
2367 /* Use the ~-expanded versions of APPLIB (undocumented),
2368 ARCHLIB PRIVLIB SITEARCH SITELIB and OLDARCHLIB
2371 incpush(APPLLIB_EXP, FALSE);
2375 incpush(ARCHLIB_EXP, FALSE);
2378 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
2380 incpush(PRIVLIB_EXP, FALSE);
2383 incpush(SITEARCH_EXP, FALSE);
2386 incpush(SITELIB_EXP, FALSE);
2388 #ifdef OLDARCHLIB_EXP /* 5.00[01] compatibility */
2389 incpush(OLDARCHLIB_EXP, FALSE);
2393 incpush(".", FALSE);
2397 # define PERLLIB_SEP ';'
2400 # define PERLLIB_SEP '|'
2402 # define PERLLIB_SEP ':'
2405 #ifndef PERLLIB_MANGLE
2406 # define PERLLIB_MANGLE(s,n) (s)
2410 incpush(p, addsubdirs)
2414 SV *subdir = Nullsv;
2415 static char *archpat_auto;
2422 if (!archpat_auto) {
2423 STRLEN len = (sizeof(ARCHNAME) + strlen(patchlevel)
2424 + sizeof("//auto"));
2425 New(55, archpat_auto, len, char);
2426 sprintf(archpat_auto, "/%s/%s/auto", ARCHNAME, patchlevel);
2428 for (len = sizeof(ARCHNAME) + 2;
2429 archpat_auto[len] != '\0' && archpat_auto[len] != '/'; len++)
2430 if (archpat_auto[len] == '.') archpat_auto[len] = '_';
2435 /* Break at all separators */
2437 SV *libdir = newSV(0);
2440 /* skip any consecutive separators */
2441 while ( *p == PERLLIB_SEP ) {
2442 /* Uncomment the next line for PATH semantics */
2443 /* av_push(GvAVn(incgv), newSVpv(".", 1)); */
2447 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
2448 sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
2453 sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
2454 p = Nullch; /* break out */
2458 * BEFORE pushing libdir onto @INC we may first push version- and
2459 * archname-specific sub-directories.
2462 struct stat tmpstatbuf;
2467 if ((unix = tounixspec_ts(SvPV(libdir,na),Nullch)) != Nullch) {
2469 while (unix[len-1] == '/') len--; /* Cosmetic */
2470 sv_usepvn(libdir,unix,len);
2473 PerlIO_printf(PerlIO_stderr(),
2474 "Failed to unixify @INC element \"%s\"\n",
2477 /* .../archname/version if -d .../archname/version/auto */
2478 sv_setsv(subdir, libdir);
2479 sv_catpv(subdir, archpat_auto);
2480 if (Stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2481 S_ISDIR(tmpstatbuf.st_mode))
2482 av_push(GvAVn(incgv),
2483 newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2485 /* .../archname if -d .../archname/auto */
2486 sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME),
2487 strlen(patchlevel) + 1, "", 0);
2488 if (Stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2489 S_ISDIR(tmpstatbuf.st_mode))
2490 av_push(GvAVn(incgv),
2491 newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2494 /* finally push this lib directory on the end of @INC */
2495 av_push(GvAVn(incgv), libdir);
2498 SvREFCNT_dec(subdir);
2502 call_list(oldscope, list)
2506 line_t oldline = curcop->cop_line;
2511 while (AvFILL(list) >= 0) {
2512 CV *cv = (CV*)av_shift(list);
2519 SV* atsv = GvSV(errgv);
2521 perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
2522 (void)SvPV(atsv, len);
2525 curcop = &compiling;
2526 curcop->cop_line = oldline;
2527 if (list == beginav)
2528 sv_catpv(atsv, "BEGIN failed--compilation aborted");
2530 sv_catpv(atsv, "END failed--cleanup aborted");
2531 while (scopestack_ix > oldscope)
2533 croak("%s", SvPVX(atsv));
2541 /* my_exit() was called */
2542 while (scopestack_ix > oldscope)
2544 curstash = defstash;
2546 call_list(oldscope, endav);
2549 curcop = &compiling;
2550 curcop->cop_line = oldline;
2552 if (list == beginav)
2553 croak("BEGIN failed--compilation aborted");
2555 croak("END failed--cleanup aborted");
2561 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
2566 curcop = &compiling;
2567 curcop->cop_line = oldline;
2586 STATUS_NATIVE_SET(status);
2596 if (vaxc$errno & 1) {
2597 if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
2598 STATUS_NATIVE_SET(44);
2601 if (!vaxc$errno && errno) /* unlikely */
2602 STATUS_NATIVE_SET(44);
2604 STATUS_NATIVE_SET(vaxc$errno);
2608 STATUS_POSIX_SET(errno);
2609 else if (STATUS_POSIX == 0)
2610 STATUS_POSIX_SET(255);
2618 register CONTEXT *cx;
2627 (void)UNLINK(e_tmpname);
2628 Safefree(e_tmpname);
2632 if (cxstack_ix >= 0) {