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 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 *, int));
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 my_exit_jump _((void)) __attribute__((noreturn));
72 static void nuke_stacks _((void));
73 static void open_script _((char *, bool, SV *));
74 static void usage _((char *));
75 static void validate_suid _((char *, char*));
77 static int fdscript = -1;
82 PerlInterpreter *sv_interp;
85 New(53, sv_interp, 1, PerlInterpreter);
90 perl_construct( sv_interp )
91 register PerlInterpreter *sv_interp;
93 if (!(curinterp = sv_interp))
97 Zero(sv_interp, 1, PerlInterpreter);
100 /* Init the real globals? */
102 linestr = NEWSV(65,80);
103 sv_upgrade(linestr,SVt_PVIV);
105 if (!SvREADONLY(&sv_undef)) {
106 SvREADONLY_on(&sv_undef);
110 SvREADONLY_on(&sv_no);
112 sv_setpv(&sv_yes,Yes);
114 SvREADONLY_on(&sv_yes);
117 nrs = newSVpv("\n", 1);
118 rs = SvREFCNT_inc(nrs);
124 * There is no way we can refer to them from Perl so close them to save
125 * space. The other alternative would be to provide STDAUX and STDPRN
128 (void)fclose(stdaux);
129 (void)fclose(stdprn);
135 perl_destruct_level = 1;
137 if(perl_destruct_level > 0)
143 start_env.je_prev = NULL;
144 start_env.je_ret = -1;
145 start_env.je_mustcatch = TRUE;
146 top_env = &start_env;
149 SET_NUMERIC_STANDARD();
150 #if defined(SUBVERSION) && SUBVERSION > 0
151 sprintf(patchlevel, "%7.5f", (double) 5
152 + ((double) PATCHLEVEL / (double) 1000)
153 + ((double) SUBVERSION / (double) 100000));
155 sprintf(patchlevel, "%5.3f", (double) 5 +
156 ((double) PATCHLEVEL / (double) 1000));
159 #if defined(LOCAL_PATCH_COUNT)
160 localpatches = local_patches; /* For possible -v */
163 PerlIO_init(); /* Hook to IO system */
165 fdpid = newAV(); /* for remembering popen pids by fd */
172 perl_destruct(sv_interp)
173 register PerlInterpreter *sv_interp;
175 int destruct_level; /* 0=none, 1=full, 2=full with checks */
179 if (!(curinterp = sv_interp))
182 destruct_level = perl_destruct_level;
186 if (s = getenv("PERL_DESTRUCT_LEVEL")) {
188 if (destruct_level < i)
194 /* unhook hooks which will soon be, or use, destroyed data */
195 SvREFCNT_dec(warnhook);
197 SvREFCNT_dec(diehook);
199 SvREFCNT_dec(parsehook);
205 /* We must account for everything. */
207 /* Destroy the main CV and syntax tree */
209 curpad = AvARRAY(comppad);
214 SvREFCNT_dec(main_cv);
219 * Try to destruct global references. We do this first so that the
220 * destructors and destructees still exist. Some sv's might remain.
221 * Non-referenced objects are on their own.
228 if (destruct_level == 0){
230 DEBUG_P(debprofdump());
232 /* The exit() function will do everything that needs doing. */
236 /* loosen bonds of global variables */
239 (void)PerlIO_close(rsfp);
243 /* Filters for program text */
244 SvREFCNT_dec(rsfp_filters);
245 rsfp_filters = Nullav;
257 sawampersand = FALSE; /* must save all match strings */
258 sawstudy = FALSE; /* do fbm_instr on all strings */
273 /* magical thingies */
275 Safefree(ofs); /* $, */
278 Safefree(ors); /* $\ */
281 SvREFCNT_dec(nrs); /* $\ helper */
284 multiline = 0; /* $* */
286 SvREFCNT_dec(statname);
290 /* defgv, aka *_ should be taken care of elsewhere */
292 #if 0 /* just about all regexp stuff, seems to be ok */
294 /* shortcuts to regexp stuff */
299 SAVEFREEOP(oldlastpm); /* for saving regexp context during debugger */
301 regprecomp = NULL; /* uncompiled string. */
302 regparse = NULL; /* Input-scan pointer. */
303 regxend = NULL; /* End of input for compile */
304 regnpar = 0; /* () count. */
305 regcode = NULL; /* Code-emit pointer; ®dummy = don't. */
306 regsize = 0; /* Code size. */
307 regnaughty = 0; /* How bad is this pattern? */
308 regsawback = 0; /* Did we see \1, ...? */
310 reginput = NULL; /* String-input pointer. */
311 regbol = NULL; /* Beginning of input, for ^ check. */
312 regeol = NULL; /* End of input, for $ check. */
313 regstartp = (char **)NULL; /* Pointer to startp array. */
314 regendp = (char **)NULL; /* Ditto for endp. */
315 reglastparen = 0; /* Similarly for lastparen. */
316 regtill = NULL; /* How far we are required to go. */
317 regflags = 0; /* are we folding, multilining? */
318 regprev = (char)NULL; /* char before regbol, \n if none */
322 /* clean up after study() */
323 SvREFCNT_dec(lastscream);
325 Safefree(screamfirst);
327 Safefree(screamnext);
330 /* startup and shutdown function lists */
331 SvREFCNT_dec(beginav);
336 /* temp stack during pp_sort() */
337 SvREFCNT_dec(sortstack);
340 /* shortcuts just get cleared */
350 /* reset so print() ends up where we expect */
353 /* Prepare to destruct main symbol table. */
360 if (destruct_level >= 2) {
361 if (scopestack_ix != 0)
362 warn("Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
363 (long)scopestack_ix);
364 if (savestack_ix != 0)
365 warn("Unbalanced saves: %ld more saves than restores\n",
367 if (tmps_floor != -1)
368 warn("Unbalanced tmps: %ld more allocs than frees\n",
369 (long)tmps_floor + 1);
370 if (cxstack_ix != -1)
371 warn("Unbalanced context: %ld more PUSHes than POPs\n",
372 (long)cxstack_ix + 1);
375 /* Now absolutely destruct everything, somehow or other, loops or no. */
377 SvFLAGS(strtab) |= SVTYPEMASK; /* don't clean out strtab now */
378 while (sv_count != 0 && sv_count != last_sv_count) {
379 last_sv_count = sv_count;
382 SvFLAGS(strtab) &= ~SVTYPEMASK;
383 SvFLAGS(strtab) |= SVt_PVHV;
385 /* Destruct the global string table. */
387 /* Yell and reset the HeVAL() slots that are still holding refcounts,
388 * so that sv_free() won't fail on them.
397 array = HvARRAY(strtab);
401 warn("Unbalanced string table refcount: (%d) for \"%s\"",
402 HeVAL(hent) - Nullsv, HeKEY(hent));
403 HeVAL(hent) = Nullsv;
413 SvREFCNT_dec(strtab);
416 warn("Scalars leaked: %ld\n", (long)sv_count);
420 /* No SVs have survived, need to clean out */
424 Safefree(origfilename);
426 hints = 0; /* Reset hints. Should hints be per-interpreter ? */
428 DEBUG_P(debprofdump());
433 PerlInterpreter *sv_interp;
435 if (!(curinterp = sv_interp))
439 #if !defined(STANDARD_C) && !defined(HAS_GETENV_PROTOTYPE)
440 char *getenv _((char *)); /* Usually in <stdlib.h> */
444 perl_parse(sv_interp, xsinit, argc, argv, env)
445 PerlInterpreter *sv_interp;
446 void (*xsinit)_((void));
453 char *scriptname = NULL;
454 VOL bool dosearch = FALSE;
460 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
463 croak("suidperl is no longer needed since the kernel can now execute\n\
464 setuid perl scripts securely.\n");
468 if (!(curinterp = sv_interp))
471 #if defined(NeXT) && defined(__DYNAMIC__)
472 _dyld_lookup_and_bind
473 ("__environ", (unsigned long *) &environ_pointer, NULL);
478 #ifndef VMS /* VMS doesn't have environ array */
479 origenviron = environ;
485 /* Come here if running an undumped a.out. */
487 origfilename = savepv(argv[0]);
489 cxstack_ix = -1; /* start label stack again */
491 init_postdump_symbols(argc,argv,env);
496 curpad = AvARRAY(comppad);
501 SvREFCNT_dec(main_cv);
505 oldscope = scopestack_ix;
507 switch (JMPENV_PUSH) {
512 /* my_exit() was called */
513 while (scopestack_ix > oldscope)
517 call_list(oldscope, endav);
519 return STATUS_NATIVE_EXPORT;
522 PerlIO_printf(PerlIO_stderr(), "panic: top_env\n");
526 sv_setpvn(linestr,"",0);
527 sv = newSVpv("",0); /* first used for -I flags */
530 for (argc--,argv++; argc > 0; argc--,argv++) {
531 if (argv[0][0] != '-' || !argv[0][1])
535 validarg = " PHOOEY ";
560 if (s = moreswitches(s))
570 if (euid != uid || egid != gid)
571 croak("No -e allowed in setuid scripts");
573 e_tmpname = savepv(TMPPATH);
574 (void)mktemp(e_tmpname);
576 croak("Can't mktemp()");
577 e_fp = PerlIO_open(e_tmpname,"w");
579 croak("Cannot open temporary file");
584 PerlIO_puts(e_fp,argv[1]);
588 croak("No code specified for -e");
589 (void)PerlIO_putc(e_fp,'\n');
600 incpush(argv[1], TRUE);
601 sv_catpv(sv,argv[1]);
618 preambleav = newAV();
619 av_push(preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
621 Sv = newSVpv("print myconfig();",0);
623 sv_catpv(Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
625 sv_catpv(Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
627 #if defined(DEBUGGING) || defined(NO_EMBED) || defined(MULTIPLICITY)
628 strcpy(buf,"\" Compile-time options:");
630 strcat(buf," DEBUGGING");
633 strcat(buf," NO_EMBED");
636 strcat(buf," MULTIPLICITY");
638 strcat(buf,"\\n\",");
641 #if defined(LOCAL_PATCH_COUNT)
642 if (LOCAL_PATCH_COUNT > 0)
644 sv_catpv(Sv,"print \" Locally applied patches:\\n\",");
645 for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
646 if (localpatches[i]) {
647 sprintf(buf,"\" \\t%s\\n\",",localpatches[i]);
653 sprintf(buf,"\" Built under %s\\n\",",OSNAME);
657 sprintf(buf,"\" Compiled at %s %s\\n\"",__DATE__,__TIME__);
659 sprintf(buf,"\" Compiled on %s\\n\"",__DATE__);
663 sv_catpv(Sv,"; $\"=\"\\n \"; print \" \\@INC:\\n @INC\\n\"");
666 Sv = newSVpv("config_vars(qw(",0);
671 av_push(preambleav, Sv);
672 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
686 croak("Unrecognized switch: -%s",s);
691 scriptname = argv[0];
693 if (PerlIO_flush(e_fp) || PerlIO_error(e_fp) || PerlIO_close(e_fp)) {
695 warn("Did you forget to compile with -DMULTIPLICITY?");
697 croak("Can't write to temp file for -e: %s", Strerror(errno));
701 scriptname = e_tmpname;
703 else if (scriptname == Nullch) {
705 if ( isatty(PerlIO_fileno(PerlIO_stdin())) )
713 open_script(scriptname,dosearch,sv);
715 validate_suid(validarg, scriptname);
720 main_cv = compcv = (CV*)NEWSV(1104,0);
721 sv_upgrade((SV *)compcv, SVt_PVCV);
725 av_push(comppad, Nullsv);
726 curpad = AvARRAY(comppad);
727 comppad_name = newAV();
728 comppad_name_fill = 0;
729 min_intro_pending = 0;
732 comppadlist = newAV();
733 AvREAL_off(comppadlist);
734 av_store(comppadlist, 0, (SV*)comppad_name);
735 av_store(comppadlist, 1, (SV*)comppad);
736 CvPADLIST(compcv) = comppadlist;
738 boot_core_UNIVERSAL();
740 (*xsinit)(); /* in case linked C routines want magical variables */
745 init_predump_symbols();
747 init_postdump_symbols(argc,argv,env);
751 /* now parse the script */
754 if (yyparse() || error_count) {
756 croak("%s had compilation errors.\n", origfilename);
758 croak("Execution of %s aborted due to compilation errors.\n",
762 curcop->cop_line = 0;
766 (void)UNLINK(e_tmpname);
771 /* now that script is parsed, we can modify record separator */
773 rs = SvREFCNT_inc(nrs);
774 sv_setsv(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), rs);
785 #ifdef DEBUGGING_MSTATS
786 if ((s=getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
787 dump_mstats("after compilation:");
798 PerlInterpreter *sv_interp;
803 if (!(curinterp = sv_interp))
806 oldscope = scopestack_ix;
808 switch (JMPENV_PUSH) {
810 cxstack_ix = -1; /* start context stack again */
813 /* my_exit() was called */
814 while (scopestack_ix > oldscope)
818 call_list(oldscope, endav);
820 #ifdef DEBUGGING_MSTATS
821 if (getenv("PERL_DEBUG_MSTATS"))
822 dump_mstats("after execution: ");
825 return STATUS_NATIVE_EXPORT;
828 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
833 if (curstack != mainstack) {
835 SWITCHSTACK(curstack, mainstack);
840 DEBUG_r(PerlIO_printf(PerlIO_stderr(), "%s $` $& $' support.\n",
841 sawampersand ? "Enabling" : "Omitting"));
845 DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
848 PerlIO_printf(PerlIO_stderr(), "%s syntax OK\n", origfilename);
851 if (perldb && DBsingle)
852 sv_setiv(DBsingle, 1);
862 else if (main_start) {
863 CvDEPTH(main_cv) = 1;
874 perl_get_sv(name, create)
878 GV* gv = gv_fetchpv(name, create, SVt_PV);
885 perl_get_av(name, create)
889 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
898 perl_get_hv(name, create)
902 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
911 perl_get_cv(name, create)
915 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
916 if (create && !GvCVu(gv))
917 return newSUB(start_subparse(FALSE, 0),
918 newSVOP(OP_CONST, 0, newSVpv(name,0)),
926 /* Be sure to refetch the stack pointer after calling these routines. */
929 perl_call_argv(subname, flags, argv)
931 I32 flags; /* See G_* flags in cop.h */
932 register char **argv; /* null terminated arg list */
939 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
944 return perl_call_pv(subname, flags);
948 perl_call_pv(subname, flags)
949 char *subname; /* name of the subroutine */
950 I32 flags; /* See G_* flags in cop.h */
952 return perl_call_sv((SV*)perl_get_cv(subname, TRUE), flags);
956 perl_call_method(methname, flags)
957 char *methname; /* name of the subroutine */
958 I32 flags; /* See G_* flags in cop.h */
964 XPUSHs(sv_2mortal(newSVpv(methname,0)));
967 return perl_call_sv(*stack_sp--, flags);
970 /* May be called with any of a CV, a GV, or an SV containing the name. */
972 perl_call_sv(sv, flags)
974 I32 flags; /* See G_* flags in cop.h */
976 LOGOP myop; /* fake syntax tree node */
982 bool oldcatch = CATCH_GET;
985 if (flags & G_DISCARD) {
990 Zero(&myop, 1, LOGOP);
991 if (!(flags & G_NOARGS))
992 myop.op_flags |= OPf_STACKED;
993 myop.op_next = Nullop;
994 myop.op_flags |= OPf_KNOW;
996 myop.op_flags |= OPf_LIST;
1000 EXTEND(stack_sp, 1);
1003 oldscope = scopestack_ix;
1005 if (perldb && curstash != debstash
1006 /* Handle first BEGIN of -d. */
1007 && (DBcv || (DBcv = GvCV(DBsub)))
1008 /* Try harder, since this may have been a sighandler, thus
1009 * curstash may be meaningless. */
1010 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != debstash))
1011 op->op_private |= OPpENTERSUB_DB;
1013 if (flags & G_EVAL) {
1014 cLOGOP->op_other = op;
1016 /* we're trying to emulate pp_entertry() here */
1018 register CONTEXT *cx;
1024 push_return(op->op_next);
1025 PUSHBLOCK(cx, CXt_EVAL, stack_sp);
1027 eval_root = op; /* Only needed so that goto works right. */
1030 if (flags & G_KEEPERR)
1033 sv_setpv(GvSV(errgv),"");
1037 switch (JMPENV_PUSH) {
1044 /* my_exit() was called */
1045 curstash = defstash;
1049 croak("Callback called exit");
1058 stack_sp = stack_base + oldmark;
1059 if (flags & G_ARRAY)
1063 *++stack_sp = &sv_undef;
1071 if (op == (OP*)&myop)
1075 retval = stack_sp - (stack_base + oldmark);
1076 if ((flags & G_EVAL) && !(flags & G_KEEPERR))
1077 sv_setpv(GvSV(errgv),"");
1080 if (flags & G_EVAL) {
1081 if (scopestack_ix > oldscope) {
1085 register CONTEXT *cx;
1097 CATCH_SET(oldcatch);
1099 if (flags & G_DISCARD) {
1100 stack_sp = stack_base + oldmark;
1108 /* Eval a string. The G_EVAL flag is always assumed. */
1111 perl_eval_sv(sv, flags)
1113 I32 flags; /* See G_* flags in cop.h */
1115 UNOP myop; /* fake syntax tree node */
1117 I32 oldmark = sp - stack_base;
1122 if (flags & G_DISCARD) {
1130 EXTEND(stack_sp, 1);
1132 oldscope = scopestack_ix;
1134 if (!(flags & G_NOARGS))
1135 myop.op_flags = OPf_STACKED;
1136 myop.op_next = Nullop;
1137 myop.op_type = OP_ENTEREVAL;
1138 myop.op_flags |= OPf_KNOW;
1139 if (flags & G_KEEPERR)
1140 myop.op_flags |= OPf_SPECIAL;
1141 if (flags & G_ARRAY)
1142 myop.op_flags |= OPf_LIST;
1144 switch (JMPENV_PUSH) {
1151 /* my_exit() was called */
1152 curstash = defstash;
1156 croak("Callback called exit");
1165 stack_sp = stack_base + oldmark;
1166 if (flags & G_ARRAY)
1170 *++stack_sp = &sv_undef;
1175 if (op == (OP*)&myop)
1176 op = pp_entereval();
1179 retval = stack_sp - (stack_base + oldmark);
1180 if (!(flags & G_KEEPERR))
1181 sv_setpv(GvSV(errgv),"");
1185 if (flags & G_DISCARD) {
1186 stack_sp = stack_base + oldmark;
1194 /* Require a module. */
1200 SV* sv = sv_newmortal();
1201 sv_setpv(sv, "require '");
1204 perl_eval_sv(sv, G_DISCARD);
1208 magicname(sym,name,namlen)
1215 if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
1216 sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
1220 usage(name) /* XXX move this out into a module ? */
1223 /* This message really ought to be max 23 lines.
1224 * Removed -h because the user already knows that opton. Others? */
1225 printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
1226 printf("\n -0[octal] specify record separator (\\0, if no argument)");
1227 printf("\n -a autosplit mode with -n or -p (splits $_ into @F)");
1228 printf("\n -c check syntax only (runs BEGIN and END blocks)");
1229 printf("\n -d[:debugger] run scripts under debugger");
1230 printf("\n -D[number/list] set debugging flags (argument is a bit mask or flags)");
1231 printf("\n -e 'command' one line of script. Several -e's allowed. Omit [programfile].");
1232 printf("\n -F/pattern/ split() pattern for autosplit (-a). The //'s are optional.");
1233 printf("\n -i[extension] edit <> files in place (make backup if extension supplied)");
1234 printf("\n -Idirectory specify @INC/#include directory (may be used more then once)");
1235 printf("\n -l[octal] enable line ending processing, specifies line teminator");
1236 printf("\n -[mM][-]module.. executes `use/no module...' before executing your script.");
1237 printf("\n -n assume 'while (<>) { ... }' loop arround your script");
1238 printf("\n -p assume loop like -n but print line also like sed");
1239 printf("\n -P run script through C preprocessor before compilation");
1240 printf("\n -s enable some switch parsing for switches after script name");
1241 printf("\n -S look for the script using PATH environment variable");
1242 printf("\n -T turn on tainting checks");
1243 printf("\n -u dump core after parsing script");
1244 printf("\n -U allow unsafe operations");
1245 printf("\n -v print version number and patchlevel of perl");
1246 printf("\n -V[:variable] print perl configuration information");
1247 printf("\n -w TURN WARNINGS ON FOR COMPILATION OF YOUR SCRIPT.");
1248 printf("\n -x[directory] strip off text before #!perl line and perhaps cd to directory\n");
1251 /* This routine handles any switches that can be given during run */
1262 rschar = scan_oct(s, 4, &numlen);
1264 if (rschar & ~((U8)~0))
1266 else if (!rschar && numlen >= 2)
1267 nrs = newSVpv("", 0);
1270 nrs = newSVpv(&ch, 1);
1275 splitstr = savepv(s + 1);
1289 if (*s == ':' || *s == '=') {
1290 sprintf(buf, "use Devel::%s;", ++s);
1292 my_setenv("PERL5DB",buf);
1302 if (isALPHA(s[1])) {
1303 static char debopts[] = "psltocPmfrxuLHXD";
1306 for (s++; *s && (d = strchr(debopts,*s)); s++)
1307 debug |= 1 << (d - debopts);
1311 for (s++; isDIGIT(*s); s++) ;
1313 debug |= 0x80000000;
1315 warn("Recompile perl with -DDEBUGGING to use -D switch\n");
1316 for (s++; isALNUM(*s); s++) ;
1326 inplace = savepv(s+1);
1328 for (s = inplace; *s && !isSPACE(*s); s++) ;
1335 for (e = s; *e && !isSPACE(*e); e++) ;
1336 p = savepvn(s, e-s);
1343 croak("No space allowed after -I");
1353 *ors = scan_oct(s, 3 + (*s == '0'), &numlen);
1362 ors = SvPV(nrs, orslen);
1363 ors = savepvn(ors, orslen);
1367 forbid_setid("-M"); /* XXX ? */
1370 forbid_setid("-m"); /* XXX ? */
1374 /* -M-foo == 'no foo' */
1375 if (*s == '-') { use = "no "; ++s; }
1376 Sv = newSVpv(use,0);
1378 /* We allow -M'Module qw(Foo Bar)' */
1379 while(isALNUM(*s) || *s==':') ++s;
1381 sv_catpv(Sv, start);
1382 if (*(start-1) == 'm') {
1384 croak("Can't use '%c' after -mname", *s);
1385 sv_catpv( Sv, " ()");
1388 sv_catpvn(Sv, start, s-start);
1389 sv_catpv(Sv, " split(/,/,q{");
1394 if (preambleav == NULL)
1395 preambleav = newAV();
1396 av_push(preambleav, Sv);
1399 croak("No space allowed after -%c", *(s-1));
1416 croak("Too late for \"-T\" option");
1428 #if defined(SUBVERSION) && SUBVERSION > 0
1429 printf("\nThis is perl, version 5.%03d_%02d", PATCHLEVEL, SUBVERSION);
1431 printf("\nThis is perl, version %s",patchlevel);
1434 printf("\n\nCopyright 1987-1997, Larry Wall\n");
1436 printf("\n\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
1439 printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n");
1442 printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
1443 "Version 5 port Copyright (c) 1994-1997, Andreas Kaiser, Ilya Zakharevich\n");
1446 printf("atariST series port, ++jrb bammi@cadence.com\n");
1449 Perl may be copied only under the terms of either the Artistic License or the\n\
1450 GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n");
1458 if (s[1] == '-') /* Additional switches on #! line. */
1466 #ifdef ALTERNATE_SHEBANG
1467 case 'S': /* OS/2 needs -S on "extproc" line. */
1475 croak("Can't emulate -%.1s on #! line",s);
1480 /* compliments of Tom Christiansen */
1482 /* unexec() can be found in the Gnu emacs distribution */
1491 sprintf (buf, "%s.perldump", origfilename);
1492 sprintf (tokenbuf, "%s/perl", BIN_EXP);
1494 status = unexec(buf, tokenbuf, &etext, sbrk(0), 0);
1496 PerlIO_printf(PerlIO_stderr(), "unexec of %s into %s failed!\n", tokenbuf, buf);
1500 # include <lib$routines.h>
1501 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
1503 ABORT(); /* for use with undump */
1513 /* Note that strtab is a rather special HV. Assumptions are made
1514 about not iterating on it, and not adding tie magic to it.
1515 It is properly deallocated in perl_destruct() */
1517 HvSHAREKEYS_off(strtab); /* mandatory */
1518 Newz(506,((XPVHV*)SvANY(strtab))->xhv_array,
1519 sizeof(HE*) * (((XPVHV*)SvANY(strtab))->xhv_max + 1), char);
1521 curstash = defstash = newHV();
1522 curstname = newSVpv("main",4);
1523 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
1524 SvREFCNT_dec(GvHV(gv));
1525 GvHV(gv) = (HV*)SvREFCNT_inc(defstash);
1527 HvNAME(defstash) = savepv("main");
1528 incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
1530 defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
1531 errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
1533 sv_setpvn(GvSV(errgv), "", 0);
1534 curstash = defstash;
1535 compiling.cop_stash = defstash;
1536 debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
1537 /* We must init $/ before switches are processed. */
1538 sv_setpvn(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), "\n", 1);
1541 #ifdef CAN_PROTOTYPE
1543 open_script(char *scriptname, bool dosearch, SV *sv)
1546 open_script(scriptname,dosearch,sv)
1552 char *xfound = Nullch;
1553 char *xfailed = Nullch;
1557 #if defined(DOSISH) && !defined(OS2) && !defined(atarist)
1558 #define SEARCH_EXTS ".bat", ".cmd", NULL
1561 # define SEARCH_EXTS ".pl", ".com", NULL
1563 /* additional extensions to try in each dir if scriptname not found */
1565 char *ext[] = { SEARCH_EXTS };
1566 int extidx = (strchr(scriptname,'.')) ? -1 : 0; /* has ext already */
1571 int hasdir, idx = 0, deftypes = 1;
1573 hasdir = (strpbrk(scriptname,":[</") != Nullch) ;
1574 /* The first time through, just add SEARCH_EXTS to whatever we
1575 * already have, so we can check for default file types. */
1576 while (deftypes || (!hasdir && my_trnlnm("DCL$PATH",tokenbuf,idx++)) ) {
1577 if (deftypes) { deftypes = 0; *tokenbuf = '\0'; }
1578 strcat(tokenbuf,scriptname);
1580 if (dosearch && !strchr(scriptname, '/') && (s = getenv("PATH"))) {
1582 bufend = s + strlen(s);
1585 s = cpytill(tokenbuf,s,bufend,':',&len);
1588 for (len = 0; *s && *s != ',' && *s != ';'; tokenbuf[len++] = *s++);
1589 tokenbuf[len] = '\0';
1591 for (len = 0; *s && *s != ';'; tokenbuf[len++] = *s++);
1592 tokenbuf[len] = '\0';
1598 if (len && tokenbuf[len-1] != '/')
1601 if (len && ((tokenbuf[len-1] != '\\') && (tokenbuf[len-1] != '/')))
1603 if (len && tokenbuf[len-1] != '\\')
1606 (void)strcat(tokenbuf+len,"/");
1607 (void)strcat(tokenbuf+len,scriptname);
1611 len = strlen(tokenbuf);
1612 if (extidx > 0) /* reset after previous loop */
1616 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tokenbuf));
1617 retval = Stat(tokenbuf,&statbuf);
1619 } while ( retval < 0 /* not there */
1620 && extidx>=0 && ext[extidx] /* try an extension? */
1621 && strcpy(tokenbuf+len, ext[extidx++])
1626 if (S_ISREG(statbuf.st_mode)
1627 && cando(S_IRUSR,TRUE,&statbuf) && cando(S_IXUSR,TRUE,&statbuf)) {
1628 xfound = tokenbuf; /* bingo! */
1632 xfailed = savepv(tokenbuf);
1635 croak("Can't execute %s", xfailed ? xfailed : scriptname );
1638 scriptname = xfound;
1641 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
1642 char *s = scriptname + 8;
1651 origfilename = savepv(e_tmpname ? "-e" : scriptname);
1652 curcop->cop_filegv = gv_fetchfile(origfilename);
1653 if (strEQ(origfilename,"-"))
1655 if (fdscript >= 0) {
1656 rsfp = PerlIO_fdopen(fdscript,"r");
1657 #if defined(HAS_FCNTL) && defined(F_SETFD)
1659 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
1662 else if (preprocess) {
1663 char *cpp = CPPSTDIN;
1665 if (strEQ(cpp,"cppstdin"))
1666 sprintf(tokenbuf, "%s/%s", BIN_EXP, cpp);
1668 sprintf(tokenbuf, "%s", cpp);
1670 sv_catpv(sv,PRIVLIB_EXP);
1672 (void)sprintf(buf, "\
1673 sed %s -e \"/^[^#]/b\" \
1674 -e \"/^#[ ]*include[ ]/b\" \
1675 -e \"/^#[ ]*define[ ]/b\" \
1676 -e \"/^#[ ]*if[ ]/b\" \
1677 -e \"/^#[ ]*ifdef[ ]/b\" \
1678 -e \"/^#[ ]*ifndef[ ]/b\" \
1679 -e \"/^#[ ]*else/b\" \
1680 -e \"/^#[ ]*elif[ ]/b\" \
1681 -e \"/^#[ ]*undef[ ]/b\" \
1682 -e \"/^#[ ]*endif/b\" \
1685 (doextract ? "-e \"1,/^#/d\n\"" : ""),
1687 (void)sprintf(buf, "\
1688 %s %s -e '/^[^#]/b' \
1689 -e '/^#[ ]*include[ ]/b' \
1690 -e '/^#[ ]*define[ ]/b' \
1691 -e '/^#[ ]*if[ ]/b' \
1692 -e '/^#[ ]*ifdef[ ]/b' \
1693 -e '/^#[ ]*ifndef[ ]/b' \
1694 -e '/^#[ ]*else/b' \
1695 -e '/^#[ ]*elif[ ]/b' \
1696 -e '/^#[ ]*undef[ ]/b' \
1697 -e '/^#[ ]*endif/b' \
1705 (doextract ? "-e '1,/^#/d\n'" : ""),
1707 scriptname, tokenbuf, SvPV(sv, na), CPPMINUS);
1709 #ifdef IAMSUID /* actually, this is caught earlier */
1710 if (euid != uid && !euid) { /* if running suidperl */
1712 (void)seteuid(uid); /* musn't stay setuid root */
1715 (void)setreuid((Uid_t)-1, uid);
1717 #ifdef HAS_SETRESUID
1718 (void)setresuid((Uid_t)-1, uid, (Uid_t)-1);
1724 if (geteuid() != uid)
1725 croak("Can't do seteuid!\n");
1727 #endif /* IAMSUID */
1728 rsfp = my_popen(buf,"r");
1730 else if (!*scriptname) {
1731 forbid_setid("program input from stdin");
1732 rsfp = PerlIO_stdin();
1735 rsfp = PerlIO_open(scriptname,"r");
1736 #if defined(HAS_FCNTL) && defined(F_SETFD)
1738 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
1746 #ifndef IAMSUID /* in case script is not readable before setuid */
1747 if (euid && Stat(SvPVX(GvSV(curcop->cop_filegv)),&statbuf) >= 0 &&
1748 statbuf.st_mode & (S_ISUID|S_ISGID)) {
1749 (void)sprintf(buf, "%s/sperl%s", BIN_EXP, patchlevel);
1750 execv(buf, origargv); /* try again */
1751 croak("Can't do setuid\n");
1755 croak("Can't open perl script \"%s\": %s\n",
1756 SvPVX(GvSV(curcop->cop_filegv)), Strerror(errno));
1761 validate_suid(validarg, scriptname)
1767 /* do we need to emulate setuid on scripts? */
1769 /* This code is for those BSD systems that have setuid #! scripts disabled
1770 * in the kernel because of a security problem. Merely defining DOSUID
1771 * in perl will not fix that problem, but if you have disabled setuid
1772 * scripts in the kernel, this will attempt to emulate setuid and setgid
1773 * on scripts that have those now-otherwise-useless bits set. The setuid
1774 * root version must be called suidperl or sperlN.NNN. If regular perl
1775 * discovers that it has opened a setuid script, it calls suidperl with
1776 * the same argv that it had. If suidperl finds that the script it has
1777 * just opened is NOT setuid root, it sets the effective uid back to the
1778 * uid. We don't just make perl setuid root because that loses the
1779 * effective uid we had before invoking perl, if it was different from the
1782 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
1783 * be defined in suidperl only. suidperl must be setuid root. The
1784 * Configure script will set this up for you if you want it.
1790 if (Fstat(PerlIO_fileno(rsfp),&statbuf) < 0) /* normal stat is insecure */
1791 croak("Can't stat script \"%s\"",origfilename);
1792 if (fdscript < 0 && statbuf.st_mode & (S_ISUID|S_ISGID)) {
1796 #ifndef HAS_SETREUID
1797 /* On this access check to make sure the directories are readable,
1798 * there is actually a small window that the user could use to make
1799 * filename point to an accessible directory. So there is a faint
1800 * chance that someone could execute a setuid script down in a
1801 * non-accessible directory. I don't know what to do about that.
1802 * But I don't think it's too important. The manual lies when
1803 * it says access() is useful in setuid programs.
1805 if (access(SvPVX(GvSV(curcop->cop_filegv)),1)) /*double check*/
1806 croak("Permission denied");
1808 /* If we can swap euid and uid, then we can determine access rights
1809 * with a simple stat of the file, and then compare device and
1810 * inode to make sure we did stat() on the same file we opened.
1811 * Then we just have to make sure he or she can execute it.
1814 struct stat tmpstatbuf;
1818 setreuid(euid,uid) < 0
1821 setresuid(euid,uid,(Uid_t)-1) < 0
1824 || getuid() != euid || geteuid() != uid)
1825 croak("Can't swap uid and euid"); /* really paranoid */
1826 if (Stat(SvPVX(GvSV(curcop->cop_filegv)),&tmpstatbuf) < 0)
1827 croak("Permission denied"); /* testing full pathname here */
1828 if (tmpstatbuf.st_dev != statbuf.st_dev ||
1829 tmpstatbuf.st_ino != statbuf.st_ino) {
1830 (void)PerlIO_close(rsfp);
1831 if (rsfp = my_popen("/bin/mail root","w")) { /* heh, heh */
1833 "User %ld tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
1834 (Filename of set-id script was %s, uid %ld gid %ld.)\n\nSincerely,\nperl\n",
1835 (long)uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
1836 (long)statbuf.st_dev, (long)statbuf.st_ino,
1837 SvPVX(GvSV(curcop->cop_filegv)),
1838 (long)statbuf.st_uid, (long)statbuf.st_gid);
1839 (void)my_pclose(rsfp);
1841 croak("Permission denied\n");
1845 setreuid(uid,euid) < 0
1847 # if defined(HAS_SETRESUID)
1848 setresuid(uid,euid,(Uid_t)-1) < 0
1851 || getuid() != uid || geteuid() != euid)
1852 croak("Can't reswap uid and euid");
1853 if (!cando(S_IXUSR,FALSE,&statbuf)) /* can real uid exec? */
1854 croak("Permission denied\n");
1856 #endif /* HAS_SETREUID */
1857 #endif /* IAMSUID */
1859 if (!S_ISREG(statbuf.st_mode))
1860 croak("Permission denied");
1861 if (statbuf.st_mode & S_IWOTH)
1862 croak("Setuid/gid script is writable by world");
1863 doswitches = FALSE; /* -s is insecure in suid */
1865 if (sv_gets(linestr, rsfp, 0) == Nullch ||
1866 strnNE(SvPV(linestr,na),"#!",2) ) /* required even on Sys V */
1867 croak("No #! line");
1868 s = SvPV(linestr,na)+2;
1870 while (!isSPACE(*s)) s++;
1871 for (s2 = s; (s2 > SvPV(linestr,na)+2 &&
1872 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
1873 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
1874 croak("Not a perl script");
1875 while (*s == ' ' || *s == '\t') s++;
1877 * #! arg must be what we saw above. They can invoke it by
1878 * mentioning suidperl explicitly, but they may not add any strange
1879 * arguments beyond what #! says if they do invoke suidperl that way.
1881 len = strlen(validarg);
1882 if (strEQ(validarg," PHOOEY ") ||
1883 strnNE(s,validarg,len) || !isSPACE(s[len]))
1884 croak("Args must match #! line");
1887 if (euid != uid && (statbuf.st_mode & S_ISUID) &&
1888 euid == statbuf.st_uid)
1890 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
1891 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
1892 #endif /* IAMSUID */
1894 if (euid) { /* oops, we're not the setuid root perl */
1895 (void)PerlIO_close(rsfp);
1897 (void)sprintf(buf, "%s/sperl%s", BIN_EXP, patchlevel);
1898 execv(buf, origargv); /* try again */
1900 croak("Can't do setuid\n");
1903 if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid) {
1905 (void)setegid(statbuf.st_gid);
1908 (void)setregid((Gid_t)-1,statbuf.st_gid);
1910 #ifdef HAS_SETRESGID
1911 (void)setresgid((Gid_t)-1,statbuf.st_gid,(Gid_t)-1);
1913 setgid(statbuf.st_gid);
1917 if (getegid() != statbuf.st_gid)
1918 croak("Can't do setegid!\n");
1920 if (statbuf.st_mode & S_ISUID) {
1921 if (statbuf.st_uid != euid)
1923 (void)seteuid(statbuf.st_uid); /* all that for this */
1926 (void)setreuid((Uid_t)-1,statbuf.st_uid);
1928 #ifdef HAS_SETRESUID
1929 (void)setresuid((Uid_t)-1,statbuf.st_uid,(Uid_t)-1);
1931 setuid(statbuf.st_uid);
1935 if (geteuid() != statbuf.st_uid)
1936 croak("Can't do seteuid!\n");
1938 else if (uid) { /* oops, mustn't run as root */
1940 (void)seteuid((Uid_t)uid);
1943 (void)setreuid((Uid_t)-1,(Uid_t)uid);
1945 #ifdef HAS_SETRESUID
1946 (void)setresuid((Uid_t)-1,(Uid_t)uid,(Uid_t)-1);
1952 if (geteuid() != uid)
1953 croak("Can't do seteuid!\n");
1956 if (!cando(S_IXUSR,TRUE,&statbuf))
1957 croak("Permission denied\n"); /* they can't do this */
1960 else if (preprocess)
1961 croak("-P not allowed for setuid/setgid script\n");
1962 else if (fdscript >= 0)
1963 croak("fd script not allowed in suidperl\n");
1965 croak("Script is not setuid/setgid in suidperl\n");
1967 /* We absolutely must clear out any saved ids here, so we */
1968 /* exec the real perl, substituting fd script for scriptname. */
1969 /* (We pass script name as "subdir" of fd, which perl will grok.) */
1970 PerlIO_rewind(rsfp);
1971 lseek(PerlIO_fileno(rsfp),(Off_t)0,0); /* just in case rewind didn't */
1972 for (which = 1; origargv[which] && origargv[which] != scriptname; which++) ;
1973 if (!origargv[which])
1974 croak("Permission denied");
1975 (void)sprintf(buf, "/dev/fd/%d/%.127s", PerlIO_fileno(rsfp), origargv[which]);
1976 origargv[which] = buf;
1978 #if defined(HAS_FCNTL) && defined(F_SETFD)
1979 fcntl(PerlIO_fileno(rsfp),F_SETFD,0); /* ensure no close-on-exec */
1982 (void)sprintf(tokenbuf, "%s/perl%s", BIN_EXP, patchlevel);
1983 execv(tokenbuf, origargv); /* try again */
1984 croak("Can't do setuid\n");
1985 #endif /* IAMSUID */
1987 if (euid != uid || egid != gid) { /* (suidperl doesn't exist, in fact) */
1988 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
1989 Fstat(PerlIO_fileno(rsfp),&statbuf); /* may be either wrapped or real suid */
1990 if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
1992 (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
1995 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
1996 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
1997 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
1998 /* not set-id, must be wrapped */
2006 register char *s, *s2;
2008 /* skip forward in input to the real script? */
2012 if ((s = sv_gets(linestr, rsfp, 0)) == Nullch)
2013 croak("No Perl script found in input\n");
2014 if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
2015 PerlIO_ungetc(rsfp, '\n'); /* to keep line count right */
2017 while (*s && !(isSPACE (*s) || *s == '#')) s++;
2019 while (*s == ' ' || *s == '\t') s++;
2021 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
2022 if (strnEQ(s2-4,"perl",4))
2024 while (s = moreswitches(s)) ;
2026 if (cddir && chdir(cddir) < 0)
2027 croak("Can't chdir to %s",cddir);
2035 uid = (int)getuid();
2036 euid = (int)geteuid();
2037 gid = (int)getgid();
2038 egid = (int)getegid();
2043 tainting |= (uid && (euid != uid || egid != gid));
2051 croak("No %s allowed while running setuid", s);
2053 croak("No %s allowed while running setgid", s);
2059 curstash = debstash;
2060 dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
2062 DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
2063 DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
2064 DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
2065 DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
2066 sv_setiv(DBsingle, 0);
2067 DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
2068 sv_setiv(DBtrace, 0);
2069 DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
2070 sv_setiv(DBsignal, 0);
2071 curstash = defstash;
2078 mainstack = curstack; /* remember in case we switch stacks */
2079 AvREAL_off(curstack); /* not a real array */
2080 av_extend(curstack,127);
2082 stack_base = AvARRAY(curstack);
2083 stack_sp = stack_base;
2084 stack_max = stack_base + 127;
2086 cxstack_max = 8192 / sizeof(CONTEXT) - 2; /* Use most of 8K. */
2087 New(50,cxstack,cxstack_max + 1,CONTEXT);
2090 New(50,tmps_stack,128,SV*);
2095 New(51,debname,128,char);
2096 New(52,debdelim,128,char);
2100 * The following stacks almost certainly should be per-interpreter,
2101 * but for now they're not. XXX
2105 markstack_ptr = markstack;
2107 New(54,markstack,64,I32);
2108 markstack_ptr = markstack;
2109 markstack_max = markstack + 64;
2115 New(54,scopestack,32,I32);
2117 scopestack_max = 32;
2123 New(54,savestack,128,ANY);
2125 savestack_max = 128;
2131 New(54,retstack,16,OP*);
2141 Safefree(tmps_stack);
2148 static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
2156 subname = newSVpv("main",4);
2160 init_predump_symbols()
2165 sv_setpvn(GvSV(gv_fetchpv("\"", TRUE, SVt_PV)), " ", 1);
2167 stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
2168 GvMULTI_on(stdingv);
2169 IoIFP(GvIOp(stdingv)) = PerlIO_stdin();
2170 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
2172 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(stdingv));
2174 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
2176 IoOFP(GvIOp(tmpgv)) = IoIFP(GvIOp(tmpgv)) = PerlIO_stdout();
2178 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
2180 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(defoutgv));
2182 othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
2183 GvMULTI_on(othergv);
2184 IoOFP(GvIOp(othergv)) = IoIFP(GvIOp(othergv)) = PerlIO_stderr();
2185 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
2187 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(othergv));
2189 statname = NEWSV(66,0); /* last filename we did stat on */
2192 osname = savepv(OSNAME);
2196 init_postdump_symbols(argc,argv,env)
2198 register char **argv;
2199 register char **env;
2205 argc--,argv++; /* skip name of script */
2207 for (; argc > 0 && **argv == '-'; argc--,argv++) {
2210 if (argv[0][1] == '-') {
2214 if (s = strchr(argv[0], '=')) {
2216 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
2219 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
2222 toptarget = NEWSV(0,0);
2223 sv_upgrade(toptarget, SVt_PVFM);
2224 sv_setpvn(toptarget, "", 0);
2225 bodytarget = NEWSV(0,0);
2226 sv_upgrade(bodytarget, SVt_PVFM);
2227 sv_setpvn(bodytarget, "", 0);
2228 formtarget = bodytarget;
2231 if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
2232 sv_setpv(GvSV(tmpgv),origfilename);
2233 magicname("0", "0", 1);
2235 if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
2236 sv_setpv(GvSV(tmpgv),origargv[0]);
2237 if (argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
2239 (void)gv_AVadd(argvgv);
2240 av_clear(GvAVn(argvgv));
2241 for (; argc > 0; argc--,argv++) {
2242 av_push(GvAVn(argvgv),newSVpv(argv[0],0));
2245 if (envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
2250 #ifndef VMS /* VMS doesn't have environ array */
2251 /* Note that if the supplied env parameter is actually a copy
2252 of the global environ then it may now point to free'd memory
2253 if the environment has been modified since. To avoid this
2254 problem we treat env==NULL as meaning 'use the default'
2258 if (env != environ) {
2259 environ[0] = Nullch;
2260 hv_magic(hv, envgv, 'E');
2262 for (; *env; env++) {
2263 if (!(s = strchr(*env,'=')))
2266 sv = newSVpv(s--,0);
2267 sv_magic(sv, sv, 'e', *env, s - *env);
2268 (void)hv_store(hv, *env, s - *env, sv, 0);
2272 #ifdef DYNAMIC_ENV_FETCH
2273 HvNAME(hv) = savepv(ENV_HV_NAME);
2275 hv_magic(hv, envgv, 'E');
2278 if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
2279 sv_setiv(GvSV(tmpgv), (IV)getpid());
2288 s = getenv("PERL5LIB");
2292 incpush(getenv("PERLLIB"), FALSE);
2294 /* Treat PERL5?LIB as a possible search list logical name -- the
2295 * "natural" VMS idiom for a Unix path string. We allow each
2296 * element to be a set of |-separated directories for compatibility.
2300 if (my_trnlnm("PERL5LIB",buf,0))
2301 do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
2303 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE);
2307 /* Use the ~-expanded versions of APPLIB (undocumented),
2308 ARCHLIB PRIVLIB SITEARCH SITELIB and OLDARCHLIB
2311 incpush(APPLLIB_EXP, FALSE);
2315 incpush(ARCHLIB_EXP, FALSE);
2318 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
2320 incpush(PRIVLIB_EXP, FALSE);
2323 incpush(SITEARCH_EXP, FALSE);
2326 incpush(SITELIB_EXP, FALSE);
2328 #ifdef OLDARCHLIB_EXP /* 5.00[01] compatibility */
2329 incpush(OLDARCHLIB_EXP, FALSE);
2333 incpush(".", FALSE);
2337 # define PERLLIB_SEP ';'
2340 # define PERLLIB_SEP '|'
2342 # define PERLLIB_SEP ':'
2345 #ifndef PERLLIB_MANGLE
2346 # define PERLLIB_MANGLE(s,n) (s)
2350 incpush(p, addsubdirs)
2354 SV *subdir = Nullsv;
2355 static char *archpat_auto;
2362 if (!archpat_auto) {
2363 STRLEN len = (sizeof(ARCHNAME) + strlen(patchlevel)
2364 + sizeof("//auto"));
2365 New(55, archpat_auto, len, char);
2366 sprintf(archpat_auto, "/%s/%s/auto", ARCHNAME, patchlevel);
2368 for (len = sizeof(ARCHNAME) + 2;
2369 archpat_auto[len] != '\0' && archpat_auto[len] != '/'; len++)
2370 if (archpat_auto[len] == '.') archpat_auto[len] = '_';
2375 /* Break at all separators */
2377 SV *libdir = newSV(0);
2380 /* skip any consecutive separators */
2381 while ( *p == PERLLIB_SEP ) {
2382 /* Uncomment the next line for PATH semantics */
2383 /* av_push(GvAVn(incgv), newSVpv(".", 1)); */
2387 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
2388 sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
2393 sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
2394 p = Nullch; /* break out */
2398 * BEFORE pushing libdir onto @INC we may first push version- and
2399 * archname-specific sub-directories.
2402 struct stat tmpstatbuf;
2407 if ((unix = tounixspec_ts(SvPV(libdir,na),Nullch)) != Nullch) {
2409 while (unix[len-1] == '/') len--; /* Cosmetic */
2410 sv_usepvn(libdir,unix,len);
2413 PerlIO_printf(PerlIO_stderr(),
2414 "Failed to unixify @INC element \"%s\"\n",
2417 /* .../archname/version if -d .../archname/version/auto */
2418 sv_setsv(subdir, libdir);
2419 sv_catpv(subdir, archpat_auto);
2420 if (Stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2421 S_ISDIR(tmpstatbuf.st_mode))
2422 av_push(GvAVn(incgv),
2423 newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2425 /* .../archname if -d .../archname/auto */
2426 sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME),
2427 strlen(patchlevel) + 1, "", 0);
2428 if (Stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2429 S_ISDIR(tmpstatbuf.st_mode))
2430 av_push(GvAVn(incgv),
2431 newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2434 /* finally push this lib directory on the end of @INC */
2435 av_push(GvAVn(incgv), libdir);
2438 SvREFCNT_dec(subdir);
2442 call_list(oldscope, list)
2448 line_t oldline = curcop->cop_line;
2450 while (AvFILL(list) >= 0) {
2451 CV *cv = (CV*)av_shift(list);
2455 switch (JMPENV_PUSH) {
2457 SV* atsv = GvSV(errgv);
2459 perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
2460 (void)SvPV(atsv, len);
2463 curcop = &compiling;
2464 curcop->cop_line = oldline;
2465 if (list == beginav)
2466 sv_catpv(atsv, "BEGIN failed--compilation aborted");
2468 sv_catpv(atsv, "END failed--cleanup aborted");
2469 while (scopestack_ix > oldscope)
2471 croak("%s", SvPVX(atsv));
2479 /* my_exit() was called */
2480 while (scopestack_ix > oldscope)
2482 curstash = defstash;
2484 call_list(oldscope, endav);
2487 curcop = &compiling;
2488 curcop->cop_line = oldline;
2490 if (list == beginav)
2491 croak("BEGIN failed--compilation aborted");
2493 croak("END failed--cleanup aborted");
2499 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
2504 curcop = &compiling;
2505 curcop->cop_line = oldline;
2524 STATUS_NATIVE_SET(status);
2534 if (vaxc$errno & 1) {
2535 if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
2536 STATUS_NATIVE_SET(44);
2539 if (!vaxc$errno && errno) /* unlikely */
2540 STATUS_NATIVE_SET(44);
2542 STATUS_NATIVE_SET(vaxc$errno);
2546 STATUS_POSIX_SET(errno);
2547 else if (STATUS_POSIX == 0)
2548 STATUS_POSIX_SET(255);
2556 register CONTEXT *cx;
2565 (void)UNLINK(e_tmpname);
2566 Safefree(e_tmpname);
2570 if (cxstack_ix >= 0) {