3 * Copyright (c) 1987-1996 Larry Wall
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
11 * "A ship then new they built for him/of mithril and of elven glass" --Bilbo
16 #include "patchlevel.h"
18 /* XXX If this causes problems, set i_unistd=undef in the hint file. */
23 dEXTCONST char rcsid[] = "perl.c\nPatch level: ###\n";
31 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
41 curcop = &compiling; \
48 laststype = OP_STAT; \
50 maxsysfd = MAXSYSFD; \
57 laststype = OP_STAT; \
60 static void find_beginning _((void));
61 static void forbid_setid _((char *));
62 static void incpush _((char *, 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)
145 SET_NUMERIC_STANDARD();
146 #if defined(SUBVERSION) && SUBVERSION > 0
147 sprintf(patchlevel, "%7.5f", (double) 5
148 + ((double) PATCHLEVEL / (double) 1000)
149 + ((double) SUBVERSION / (double) 100000));
151 sprintf(patchlevel, "%5.3f", (double) 5 +
152 ((double) PATCHLEVEL / (double) 1000));
155 #if defined(LOCAL_PATCH_COUNT)
156 localpatches = local_patches; /* For possible -v */
159 PerlIO_init(); /* Hook to IO system */
161 fdpid = newAV(); /* for remembering popen pids by fd */
168 perl_destruct(sv_interp)
169 register PerlInterpreter *sv_interp;
171 int destruct_level; /* 0=none, 1=full, 2=full with checks */
175 if (!(curinterp = sv_interp))
178 destruct_level = perl_destruct_level;
182 if (s = getenv("PERL_DESTRUCT_LEVEL")) {
184 if (destruct_level < i)
190 /* unhook hooks which will soon be, or use, destroyed data */
191 SvREFCNT_dec(warnhook);
193 SvREFCNT_dec(diehook);
195 SvREFCNT_dec(parsehook);
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 if (destruct_level == 0){
226 DEBUG_P(debprofdump());
228 /* The exit() function will do everything that needs doing. */
232 /* loosen bonds of global variables */
235 (void)PerlIO_close(rsfp);
239 /* Filters for program text */
240 SvREFCNT_dec(rsfp_filters);
241 rsfp_filters = Nullav;
253 sawampersand = FALSE; /* must save all match strings */
254 sawstudy = FALSE; /* do fbm_instr on all strings */
269 /* magical thingies */
271 Safefree(ofs); /* $, */
274 Safefree(ors); /* $\ */
277 SvREFCNT_dec(nrs); /* $\ helper */
280 multiline = 0; /* $* */
282 SvREFCNT_dec(statname);
286 /* defgv, aka *_ should be taken care of elsewhere */
288 #if 0 /* just about all regexp stuff, seems to be ok */
290 /* shortcuts to regexp stuff */
295 SAVEFREEOP(oldlastpm); /* for saving regexp context during debugger */
297 regprecomp = NULL; /* uncompiled string. */
298 regparse = NULL; /* Input-scan pointer. */
299 regxend = NULL; /* End of input for compile */
300 regnpar = 0; /* () count. */
301 regcode = NULL; /* Code-emit pointer; ®dummy = don't. */
302 regsize = 0; /* Code size. */
303 regnaughty = 0; /* How bad is this pattern? */
304 regsawback = 0; /* Did we see \1, ...? */
306 reginput = NULL; /* String-input pointer. */
307 regbol = NULL; /* Beginning of input, for ^ check. */
308 regeol = NULL; /* End of input, for $ check. */
309 regstartp = (char **)NULL; /* Pointer to startp array. */
310 regendp = (char **)NULL; /* Ditto for endp. */
311 reglastparen = 0; /* Similarly for lastparen. */
312 regtill = NULL; /* How far we are required to go. */
313 regflags = 0; /* are we folding, multilining? */
314 regprev = (char)NULL; /* char before regbol, \n if none */
318 /* clean up after study() */
319 SvREFCNT_dec(lastscream);
321 Safefree(screamfirst);
323 Safefree(screamnext);
326 /* startup and shutdown function lists */
327 SvREFCNT_dec(beginav);
332 /* temp stack during pp_sort() */
333 SvREFCNT_dec(sortstack);
336 /* shortcuts just get cleared */
346 /* reset so print() ends up where we expect */
349 /* Prepare to destruct main symbol table. */
356 if (destruct_level >= 2) {
357 if (scopestack_ix != 0)
358 warn("Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
359 (long)scopestack_ix);
360 if (savestack_ix != 0)
361 warn("Unbalanced saves: %ld more saves than restores\n",
363 if (tmps_floor != -1)
364 warn("Unbalanced tmps: %ld more allocs than frees\n",
365 (long)tmps_floor + 1);
366 if (cxstack_ix != -1)
367 warn("Unbalanced context: %ld more PUSHes than POPs\n",
368 (long)cxstack_ix + 1);
371 /* Now absolutely destruct everything, somehow or other, loops or no. */
373 SvFLAGS(strtab) |= SVTYPEMASK; /* don't clean out strtab now */
374 while (sv_count != 0 && sv_count != last_sv_count) {
375 last_sv_count = sv_count;
378 SvFLAGS(strtab) &= ~SVTYPEMASK;
379 SvFLAGS(strtab) |= SVt_PVHV;
381 /* Destruct the global string table. */
383 /* Yell and reset the HeVAL() slots that are still holding refcounts,
384 * so that sv_free() won't fail on them.
393 array = HvARRAY(strtab);
397 warn("Unbalanced string table refcount: (%d) for \"%s\"",
398 HeVAL(hent) - Nullsv, HeKEY(hent));
399 HeVAL(hent) = Nullsv;
409 SvREFCNT_dec(strtab);
412 warn("Scalars leaked: %ld\n", (long)sv_count);
416 /* No SVs have survived, need to clean out */
420 Safefree(origfilename);
422 hints = 0; /* Reset hints. Should hints be per-interpreter ? */
424 DEBUG_P(debprofdump());
429 PerlInterpreter *sv_interp;
431 if (!(curinterp = sv_interp))
435 #if !defined(STANDARD_C) && !defined(HAS_GETENV_PROTOTYPE)
436 char *getenv _((char *)); /* Usually in <stdlib.h> */
440 perl_parse(sv_interp, xsinit, argc, argv, env)
441 PerlInterpreter *sv_interp;
442 void (*xsinit)_((void));
449 char *scriptname = NULL;
450 VOL bool dosearch = FALSE;
454 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
457 croak("suidperl is no longer needed since the kernel can now execute\n\
458 setuid perl scripts securely.\n");
462 if (!(curinterp = sv_interp))
465 #if defined(NeXT) && defined(__DYNAMIC__)
466 _dyld_lookup_and_bind
467 ("__environ", (unsigned long *) &environ_pointer, NULL);
472 #ifndef VMS /* VMS doesn't have environ array */
473 origenviron = environ;
479 /* Come here if running an undumped a.out. */
481 origfilename = savepv(argv[0]);
483 cxstack_ix = -1; /* start label stack again */
485 init_postdump_symbols(argc,argv,env);
490 curpad = AvARRAY(comppad);
495 SvREFCNT_dec(main_cv);
500 switch (Sigsetjmp(top_env,1)) {
505 /* my_exit() was called */
509 return STATUS_NATIVE_EXPORT;
511 PerlIO_printf(PerlIO_stderr(), "panic: top_env\n");
515 sv_setpvn(linestr,"",0);
516 sv = newSVpv("",0); /* first used for -I flags */
519 for (argc--,argv++; argc > 0; argc--,argv++) {
520 if (argv[0][0] != '-' || !argv[0][1])
524 validarg = " PHOOEY ";
549 if (s = moreswitches(s))
559 if (euid != uid || egid != gid)
560 croak("No -e allowed in setuid scripts");
562 e_tmpname = savepv(TMPPATH);
563 (void)mktemp(e_tmpname);
565 croak("Can't mktemp()");
566 e_fp = PerlIO_open(e_tmpname,"w");
568 croak("Cannot open temporary file");
573 PerlIO_puts(e_fp,argv[1]);
577 croak("No code specified for -e");
578 (void)PerlIO_putc(e_fp,'\n');
589 incpush(argv[1], TRUE);
590 sv_catpv(sv,argv[1]);
607 preambleav = newAV();
608 av_push(preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
610 Sv = newSVpv("print myconfig();",0);
612 sv_catpv(Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
614 sv_catpv(Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
616 #if defined(DEBUGGING) || defined(NOEMBED) || defined(MULTIPLICITY)
617 strcpy(buf,"\" Compile-time options:");
619 strcat(buf," DEBUGGING");
622 strcat(buf," NOEMBED");
625 strcat(buf," MULTIPLICITY");
627 strcat(buf,"\\n\",");
630 #if defined(LOCAL_PATCH_COUNT)
631 if (LOCAL_PATCH_COUNT > 0)
633 sv_catpv(Sv,"print \" Locally applied patches:\\n\",");
634 for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
635 if (localpatches[i]) {
636 sprintf(buf,"\" \\t%s\\n\",",localpatches[i]);
642 sprintf(buf,"\" Built under %s\\n\",",OSNAME);
646 sprintf(buf,"\" Compiled at %s %s\\n\"",__DATE__,__TIME__);
648 sprintf(buf,"\" Compiled on %s\\n\"",__DATE__);
652 sv_catpv(Sv,"; $\"=\"\\n \"; print \" \\@INC:\\n @INC\\n\"");
655 Sv = newSVpv("config_vars(qw(",0);
660 av_push(preambleav, Sv);
661 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
675 croak("Unrecognized switch: -%s",s);
680 scriptname = argv[0];
682 if (PerlIO_flush(e_fp) || PerlIO_error(e_fp) || PerlIO_close(e_fp))
683 croak("Can't write to temp file for -e: %s", Strerror(errno));
686 scriptname = e_tmpname;
688 else if (scriptname == Nullch) {
690 if ( isatty(PerlIO_fileno(PerlIO_stdin())) )
698 open_script(scriptname,dosearch,sv);
700 validate_suid(validarg, scriptname);
705 main_cv = compcv = (CV*)NEWSV(1104,0);
706 sv_upgrade((SV *)compcv, SVt_PVCV);
710 av_push(comppad, Nullsv);
711 curpad = AvARRAY(comppad);
712 comppad_name = newAV();
713 comppad_name_fill = 0;
714 min_intro_pending = 0;
717 comppadlist = newAV();
718 AvREAL_off(comppadlist);
719 av_store(comppadlist, 0, (SV*)comppad_name);
720 av_store(comppadlist, 1, (SV*)comppad);
721 CvPADLIST(compcv) = comppadlist;
723 boot_core_UNIVERSAL();
725 (*xsinit)(); /* in case linked C routines want magical variables */
730 init_predump_symbols();
732 init_postdump_symbols(argc,argv,env);
736 /* now parse the script */
739 if (yyparse() || error_count) {
741 croak("%s had compilation errors.\n", origfilename);
743 croak("Execution of %s aborted due to compilation errors.\n",
747 curcop->cop_line = 0;
751 (void)UNLINK(e_tmpname);
756 /* now that script is parsed, we can modify record separator */
758 rs = SvREFCNT_inc(nrs);
759 sv_setsv(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), rs);
770 #ifdef DEBUGGING_MSTATS
771 if ((s=getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
772 dump_mstats("after compilation:");
782 PerlInterpreter *sv_interp;
784 if (!(curinterp = sv_interp))
786 switch (Sigsetjmp(top_env,1)) {
788 cxstack_ix = -1; /* start context stack again */
791 /* my_exit() was called */
796 #ifdef DEBUGGING_MSTATS
797 if (getenv("PERL_DEBUG_MSTATS"))
798 dump_mstats("after execution: ");
800 return STATUS_NATIVE_EXPORT;
803 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
807 if (curstack != mainstack) {
809 SWITCHSTACK(curstack, mainstack);
814 DEBUG_r(PerlIO_printf(PerlIO_stderr(), "%s $` $& $' support.\n",
815 sawampersand ? "Enabling" : "Omitting"));
819 DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
822 PerlIO_printf(PerlIO_stderr(), "%s syntax OK\n", origfilename);
825 if (perldb && DBsingle)
826 sv_setiv(DBsingle, 1);
836 else if (main_start) {
837 CvDEPTH(main_cv) = 1;
847 perl_get_sv(name, create)
851 GV* gv = gv_fetchpv(name, create, SVt_PV);
858 perl_get_av(name, create)
862 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
871 perl_get_hv(name, create)
875 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
884 perl_get_cv(name, create)
888 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
889 if (create && !GvCVu(gv))
890 return newSUB(start_subparse(FALSE, 0),
891 newSVOP(OP_CONST, 0, newSVpv(name,0)),
899 /* Be sure to refetch the stack pointer after calling these routines. */
902 perl_call_argv(subname, flags, argv)
904 I32 flags; /* See G_* flags in cop.h */
905 register char **argv; /* null terminated arg list */
912 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
917 return perl_call_pv(subname, flags);
921 perl_call_pv(subname, flags)
922 char *subname; /* name of the subroutine */
923 I32 flags; /* See G_* flags in cop.h */
925 return perl_call_sv((SV*)perl_get_cv(subname, TRUE), flags);
929 perl_call_method(methname, flags)
930 char *methname; /* name of the subroutine */
931 I32 flags; /* See G_* flags in cop.h */
937 XPUSHs(sv_2mortal(newSVpv(methname,0)));
940 return perl_call_sv(*stack_sp--, flags);
943 /* May be called with any of a CV, a GV, or an SV containing the name. */
945 perl_call_sv(sv, flags)
947 I32 flags; /* See G_* flags in cop.h */
949 LOGOP myop; /* fake syntax tree node */
951 I32 oldmark = TOPMARK;
957 if (flags & G_DISCARD) {
967 oldscope = scopestack_ix;
969 if (!(flags & G_NOARGS))
970 myop.op_flags = OPf_STACKED;
971 myop.op_next = Nullop;
972 myop.op_flags |= OPf_KNOW;
974 myop.op_flags |= OPf_LIST;
976 if (perldb && curstash != debstash
977 /* Handle first BEGIN of -d. */
978 && (DBcv || (DBcv = GvCV(DBsub)))
979 /* Try harder, since this may have been a sighandler, thus
980 * curstash may be meaningless. */
981 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != debstash))
982 op->op_private |= OPpENTERSUB_DB;
984 if (flags & G_EVAL) {
985 Copy(top_env, oldtop, 1, Sigjmp_buf);
987 cLOGOP->op_other = op;
989 /* we're trying to emulate pp_entertry() here */
991 register CONTEXT *cx;
997 push_return(op->op_next);
998 PUSHBLOCK(cx, CXt_EVAL, stack_sp);
1000 eval_root = op; /* Only needed so that goto works right. */
1003 if (flags & G_KEEPERR)
1006 sv_setpv(GvSV(errgv),"");
1011 switch (Sigsetjmp(top_env,1)) {
1018 /* my_exit() was called */
1019 curstash = defstash;
1021 Copy(oldtop, top_env, 1, Sigjmp_buf);
1023 croak("Callback called exit");
1032 stack_sp = stack_base + oldmark;
1033 if (flags & G_ARRAY)
1037 *++stack_sp = &sv_undef;
1043 if (op == (OP*)&myop)
1047 retval = stack_sp - (stack_base + oldmark);
1048 if ((flags & G_EVAL) && !(flags & G_KEEPERR))
1049 sv_setpv(GvSV(errgv),"");
1052 if (flags & G_EVAL) {
1053 if (scopestack_ix > oldscope) {
1057 register CONTEXT *cx;
1066 Copy(oldtop, top_env, 1, Sigjmp_buf);
1068 if (flags & G_DISCARD) {
1069 stack_sp = stack_base + oldmark;
1077 /* Eval a string. The G_EVAL flag is always assumed. */
1080 perl_eval_sv(sv, flags)
1082 I32 flags; /* See G_* flags in cop.h */
1084 UNOP myop; /* fake syntax tree node */
1086 I32 oldmark = sp - stack_base;
1091 if (flags & G_DISCARD) {
1099 EXTEND(stack_sp, 1);
1101 oldscope = scopestack_ix;
1103 if (!(flags & G_NOARGS))
1104 myop.op_flags = OPf_STACKED;
1105 myop.op_next = Nullop;
1106 myop.op_type = OP_ENTEREVAL;
1107 myop.op_flags |= OPf_KNOW;
1108 if (flags & G_KEEPERR)
1109 myop.op_flags |= OPf_SPECIAL;
1110 if (flags & G_ARRAY)
1111 myop.op_flags |= OPf_LIST;
1113 Copy(top_env, oldtop, 1, Sigjmp_buf);
1116 switch (Sigsetjmp(top_env,1)) {
1123 /* my_exit() was called */
1124 curstash = defstash;
1126 Copy(oldtop, top_env, 1, Sigjmp_buf);
1128 croak("Callback called exit");
1137 stack_sp = stack_base + oldmark;
1138 if (flags & G_ARRAY)
1142 *++stack_sp = &sv_undef;
1147 if (op == (OP*)&myop)
1148 op = pp_entereval();
1151 retval = stack_sp - (stack_base + oldmark);
1152 if (!(flags & G_KEEPERR))
1153 sv_setpv(GvSV(errgv),"");
1156 Copy(oldtop, top_env, 1, Sigjmp_buf);
1157 if (flags & G_DISCARD) {
1158 stack_sp = stack_base + oldmark;
1166 /* Require a module. */
1172 SV* sv = sv_newmortal();
1173 sv_setpv(sv, "require '");
1176 perl_eval_sv(sv, G_DISCARD);
1180 magicname(sym,name,namlen)
1187 if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
1188 sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
1192 usage(name) /* XXX move this out into a module ? */
1195 /* This message really ought to be max 23 lines.
1196 * Removed -h because the user already knows that opton. Others? */
1197 printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
1198 printf("\n -0[octal] specify record separator (\\0, if no argument)");
1199 printf("\n -a autosplit mode with -n or -p (splits $_ into @F)");
1200 printf("\n -c check syntax only (runs BEGIN and END blocks)");
1201 printf("\n -d[:debugger] run scripts under debugger");
1202 printf("\n -D[number/list] set debugging flags (argument is a bit mask or flags)");
1203 printf("\n -e 'command' one line of script. Several -e's allowed. Omit [programfile].");
1204 printf("\n -F/pattern/ split() pattern for autosplit (-a). The //'s are optional.");
1205 printf("\n -i[extension] edit <> files in place (make backup if extension supplied)");
1206 printf("\n -Idirectory specify @INC/#include directory (may be used more then once)");
1207 printf("\n -l[octal] enable line ending processing, specifies line teminator");
1208 printf("\n -[mM][-]module.. executes `use/no module...' before executing your script.");
1209 printf("\n -n assume 'while (<>) { ... }' loop arround your script");
1210 printf("\n -p assume loop like -n but print line also like sed");
1211 printf("\n -P run script through C preprocessor before compilation");
1212 printf("\n -s enable some switch parsing for switches after script name");
1213 printf("\n -S look for the script using PATH environment variable");
1214 printf("\n -T turn on tainting checks");
1215 printf("\n -u dump core after parsing script");
1216 printf("\n -U allow unsafe operations");
1217 printf("\n -v print version number and patchlevel of perl");
1218 printf("\n -V[:variable] print perl configuration information");
1219 printf("\n -w TURN WARNINGS ON FOR COMPILATION OF YOUR SCRIPT.");
1220 printf("\n -x[directory] strip off text before #!perl line and perhaps cd to directory\n");
1223 /* This routine handles any switches that can be given during run */
1234 rschar = scan_oct(s, 4, &numlen);
1236 if (rschar & ~((U8)~0))
1238 else if (!rschar && numlen >= 2)
1239 nrs = newSVpv("", 0);
1242 nrs = newSVpv(&ch, 1);
1247 splitstr = savepv(s + 1);
1261 if (*s == ':' || *s == '=') {
1262 sprintf(buf, "use Devel::%s;", ++s);
1264 my_setenv("PERL5DB",buf);
1274 if (isALPHA(s[1])) {
1275 static char debopts[] = "psltocPmfrxuLHXD";
1278 for (s++; *s && (d = strchr(debopts,*s)); s++)
1279 debug |= 1 << (d - debopts);
1283 for (s++; isDIGIT(*s); s++) ;
1285 debug |= 0x80000000;
1287 warn("Recompile perl with -DDEBUGGING to use -D switch\n");
1288 for (s++; isALNUM(*s); s++) ;
1298 inplace = savepv(s+1);
1300 for (s = inplace; *s && !isSPACE(*s); s++) ;
1307 for (e = s; *e && !isSPACE(*e); e++) ;
1308 p = savepvn(s, e-s);
1315 croak("No space allowed after -I");
1325 *ors = scan_oct(s, 3 + (*s == '0'), &numlen);
1334 ors = SvPV(nrs, orslen);
1335 ors = savepvn(ors, orslen);
1339 forbid_setid("-M"); /* XXX ? */
1342 forbid_setid("-m"); /* XXX ? */
1346 /* -M-foo == 'no foo' */
1347 if (*s == '-') { use = "no "; ++s; }
1348 Sv = newSVpv(use,0);
1350 /* We allow -M'Module qw(Foo Bar)' */
1351 while(isALNUM(*s) || *s==':') ++s;
1353 sv_catpv(Sv, start);
1354 if (*(start-1) == 'm') {
1356 croak("Can't use '%c' after -mname", *s);
1357 sv_catpv( Sv, " ()");
1360 sv_catpvn(Sv, start, s-start);
1361 sv_catpv(Sv, " split(/,/,q{");
1366 if (preambleav == NULL)
1367 preambleav = newAV();
1368 av_push(preambleav, Sv);
1371 croak("No space allowed after -%c", *(s-1));
1388 croak("Too late for \"-T\" option (try putting it first)");
1400 #if defined(SUBVERSION) && SUBVERSION > 0
1401 printf("\nThis is perl, version 5.%03d_%02d", PATCHLEVEL, SUBVERSION);
1403 printf("\nThis is perl, version %s",patchlevel);
1406 printf("\n\nCopyright 1987-1997, Larry Wall\n");
1408 printf("\n\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
1411 printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n");
1414 printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
1415 "Version 5 port Copyright (c) 1994-1996, Andreas Kaiser, Ilya Zakharevich\n");
1418 printf("atariST series port, ++jrb bammi@cadence.com\n");
1421 Perl may be copied only under the terms of either the Artistic License or the\n\
1422 GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n");
1430 if (s[1] == '-') /* Additional switches on #! line. */
1441 #ifdef ALTERNATE_SHEBANG
1442 case 'S': /* OS/2 needs -S on "extproc" line. */
1447 croak("Can't emulate -%.1s on #! line",s);
1452 /* compliments of Tom Christiansen */
1454 /* unexec() can be found in the Gnu emacs distribution */
1463 sprintf (buf, "%s.perldump", origfilename);
1464 sprintf (tokenbuf, "%s/perl", BIN);
1466 status = unexec(buf, tokenbuf, &etext, sbrk(0), 0);
1468 PerlIO_printf(PerlIO_stderr(), "unexec of %s into %s failed!\n", tokenbuf, buf);
1472 # include <lib$routines.h>
1473 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
1475 ABORT(); /* for use with undump */
1485 /* Note that strtab is a rather special HV. Assumptions are made
1486 about not iterating on it, and not adding tie magic to it.
1487 It is properly deallocated in perl_destruct() */
1489 HvSHAREKEYS_off(strtab); /* mandatory */
1490 Newz(506,((XPVHV*)SvANY(strtab))->xhv_array,
1491 sizeof(HE*) * (((XPVHV*)SvANY(strtab))->xhv_max + 1), char);
1493 curstash = defstash = newHV();
1494 curstname = newSVpv("main",4);
1495 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
1496 SvREFCNT_dec(GvHV(gv));
1497 GvHV(gv) = (HV*)SvREFCNT_inc(defstash);
1499 HvNAME(defstash) = savepv("main");
1500 incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
1502 defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
1503 errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
1505 sv_setpvn(GvSV(errgv), "", 0);
1506 curstash = defstash;
1507 compiling.cop_stash = defstash;
1508 debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
1509 /* We must init $/ before switches are processed. */
1510 sv_setpvn(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), "\n", 1);
1513 #ifdef CAN_PROTOTYPE
1515 open_script(char *scriptname, bool dosearch, SV *sv)
1518 open_script(scriptname,dosearch,sv)
1524 char *xfound = Nullch;
1525 char *xfailed = Nullch;
1529 #if defined(DOSISH) && !defined(OS2) && !defined(atarist)
1530 #define SEARCH_EXTS ".bat", ".cmd", NULL
1533 # define SEARCH_EXTS ".pl", ".com", NULL
1535 /* additional extensions to try in each dir if scriptname not found */
1537 char *ext[] = { SEARCH_EXTS };
1538 int extidx = (strchr(scriptname,'.')) ? -1 : 0; /* has ext already */
1543 int hasdir, idx = 0, deftypes = 1;
1545 hasdir = (strpbrk(scriptname,":[</") != Nullch) ;
1546 /* The first time through, just add SEARCH_EXTS to whatever we
1547 * already have, so we can check for default file types. */
1548 while (deftypes || (!hasdir && my_trnlnm("DCL$PATH",tokenbuf,idx++)) ) {
1549 if (deftypes) { deftypes = 0; *tokenbuf = '\0'; }
1550 strcat(tokenbuf,scriptname);
1552 if (dosearch && !strchr(scriptname, '/') && (s = getenv("PATH"))) {
1554 bufend = s + strlen(s);
1557 s = cpytill(tokenbuf,s,bufend,':',&len);
1560 for (len = 0; *s && *s != ',' && *s != ';'; tokenbuf[len++] = *s++);
1561 tokenbuf[len] = '\0';
1563 for (len = 0; *s && *s != ';'; tokenbuf[len++] = *s++);
1564 tokenbuf[len] = '\0';
1570 if (len && tokenbuf[len-1] != '/')
1573 if (len && ((tokenbuf[len-1] != '\\') && (tokenbuf[len-1] != '/')))
1575 if (len && tokenbuf[len-1] != '\\')
1578 (void)strcat(tokenbuf+len,"/");
1579 (void)strcat(tokenbuf+len,scriptname);
1583 len = strlen(tokenbuf);
1584 if (extidx > 0) /* reset after previous loop */
1588 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tokenbuf));
1589 retval = Stat(tokenbuf,&statbuf);
1591 } while ( retval < 0 /* not there */
1592 && extidx>=0 && ext[extidx] /* try an extension? */
1593 && strcpy(tokenbuf+len, ext[extidx++])
1598 if (S_ISREG(statbuf.st_mode)
1599 && cando(S_IRUSR,TRUE,&statbuf) && cando(S_IXUSR,TRUE,&statbuf)) {
1600 xfound = tokenbuf; /* bingo! */
1604 xfailed = savepv(tokenbuf);
1607 croak("Can't execute %s", xfailed ? xfailed : scriptname );
1610 scriptname = xfound;
1613 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
1614 char *s = scriptname + 8;
1623 origfilename = savepv(e_tmpname ? "-e" : scriptname);
1624 curcop->cop_filegv = gv_fetchfile(origfilename);
1625 if (strEQ(origfilename,"-"))
1627 if (fdscript >= 0) {
1628 rsfp = PerlIO_fdopen(fdscript,"r");
1629 #if defined(HAS_FCNTL) && defined(F_SETFD)
1631 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
1634 else if (preprocess) {
1635 char *cpp = CPPSTDIN;
1637 if (strEQ(cpp,"cppstdin"))
1638 sprintf(tokenbuf, "%s/%s", SCRIPTDIR, cpp);
1640 sprintf(tokenbuf, "%s", cpp);
1642 sv_catpv(sv,PRIVLIB_EXP);
1644 (void)sprintf(buf, "\
1645 sed %s -e \"/^[^#]/b\" \
1646 -e \"/^#[ ]*include[ ]/b\" \
1647 -e \"/^#[ ]*define[ ]/b\" \
1648 -e \"/^#[ ]*if[ ]/b\" \
1649 -e \"/^#[ ]*ifdef[ ]/b\" \
1650 -e \"/^#[ ]*ifndef[ ]/b\" \
1651 -e \"/^#[ ]*else/b\" \
1652 -e \"/^#[ ]*elif[ ]/b\" \
1653 -e \"/^#[ ]*undef[ ]/b\" \
1654 -e \"/^#[ ]*endif/b\" \
1657 (doextract ? "-e \"1,/^#/d\n\"" : ""),
1659 (void)sprintf(buf, "\
1660 %s %s -e '/^[^#]/b' \
1661 -e '/^#[ ]*include[ ]/b' \
1662 -e '/^#[ ]*define[ ]/b' \
1663 -e '/^#[ ]*if[ ]/b' \
1664 -e '/^#[ ]*ifdef[ ]/b' \
1665 -e '/^#[ ]*ifndef[ ]/b' \
1666 -e '/^#[ ]*else/b' \
1667 -e '/^#[ ]*elif[ ]/b' \
1668 -e '/^#[ ]*undef[ ]/b' \
1669 -e '/^#[ ]*endif/b' \
1677 (doextract ? "-e '1,/^#/d\n'" : ""),
1679 scriptname, tokenbuf, SvPV(sv, na), CPPMINUS);
1681 #ifdef IAMSUID /* actually, this is caught earlier */
1682 if (euid != uid && !euid) { /* if running suidperl */
1684 (void)seteuid(uid); /* musn't stay setuid root */
1687 (void)setreuid((Uid_t)-1, uid);
1689 #ifdef HAS_SETRESUID
1690 (void)setresuid((Uid_t)-1, uid, (Uid_t)-1);
1696 if (geteuid() != uid)
1697 croak("Can't do seteuid!\n");
1699 #endif /* IAMSUID */
1700 rsfp = my_popen(buf,"r");
1702 else if (!*scriptname) {
1703 forbid_setid("program input from stdin");
1704 rsfp = PerlIO_stdin();
1707 rsfp = PerlIO_open(scriptname,"r");
1708 #if defined(HAS_FCNTL) && defined(F_SETFD)
1710 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
1718 #ifndef IAMSUID /* in case script is not readable before setuid */
1719 if (euid && Stat(SvPVX(GvSV(curcop->cop_filegv)),&statbuf) >= 0 &&
1720 statbuf.st_mode & (S_ISUID|S_ISGID)) {
1721 (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel);
1722 execv(buf, origargv); /* try again */
1723 croak("Can't do setuid\n");
1727 croak("Can't open perl script \"%s\": %s\n",
1728 SvPVX(GvSV(curcop->cop_filegv)), Strerror(errno));
1733 validate_suid(validarg, scriptname)
1739 /* do we need to emulate setuid on scripts? */
1741 /* This code is for those BSD systems that have setuid #! scripts disabled
1742 * in the kernel because of a security problem. Merely defining DOSUID
1743 * in perl will not fix that problem, but if you have disabled setuid
1744 * scripts in the kernel, this will attempt to emulate setuid and setgid
1745 * on scripts that have those now-otherwise-useless bits set. The setuid
1746 * root version must be called suidperl or sperlN.NNN. If regular perl
1747 * discovers that it has opened a setuid script, it calls suidperl with
1748 * the same argv that it had. If suidperl finds that the script it has
1749 * just opened is NOT setuid root, it sets the effective uid back to the
1750 * uid. We don't just make perl setuid root because that loses the
1751 * effective uid we had before invoking perl, if it was different from the
1754 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
1755 * be defined in suidperl only. suidperl must be setuid root. The
1756 * Configure script will set this up for you if you want it.
1762 if (Fstat(PerlIO_fileno(rsfp),&statbuf) < 0) /* normal stat is insecure */
1763 croak("Can't stat script \"%s\"",origfilename);
1764 if (fdscript < 0 && statbuf.st_mode & (S_ISUID|S_ISGID)) {
1768 #ifndef HAS_SETREUID
1769 /* On this access check to make sure the directories are readable,
1770 * there is actually a small window that the user could use to make
1771 * filename point to an accessible directory. So there is a faint
1772 * chance that someone could execute a setuid script down in a
1773 * non-accessible directory. I don't know what to do about that.
1774 * But I don't think it's too important. The manual lies when
1775 * it says access() is useful in setuid programs.
1777 if (access(SvPVX(GvSV(curcop->cop_filegv)),1)) /*double check*/
1778 croak("Permission denied");
1780 /* If we can swap euid and uid, then we can determine access rights
1781 * with a simple stat of the file, and then compare device and
1782 * inode to make sure we did stat() on the same file we opened.
1783 * Then we just have to make sure he or she can execute it.
1786 struct stat tmpstatbuf;
1790 setreuid(euid,uid) < 0
1793 setresuid(euid,uid,(Uid_t)-1) < 0
1796 || getuid() != euid || geteuid() != uid)
1797 croak("Can't swap uid and euid"); /* really paranoid */
1798 if (Stat(SvPVX(GvSV(curcop->cop_filegv)),&tmpstatbuf) < 0)
1799 croak("Permission denied"); /* testing full pathname here */
1800 if (tmpstatbuf.st_dev != statbuf.st_dev ||
1801 tmpstatbuf.st_ino != statbuf.st_ino) {
1802 (void)PerlIO_close(rsfp);
1803 if (rsfp = my_popen("/bin/mail root","w")) { /* heh, heh */
1805 "User %ld tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
1806 (Filename of set-id script was %s, uid %ld gid %ld.)\n\nSincerely,\nperl\n",
1807 (long)uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
1808 (long)statbuf.st_dev, (long)statbuf.st_ino,
1809 SvPVX(GvSV(curcop->cop_filegv)),
1810 (long)statbuf.st_uid, (long)statbuf.st_gid);
1811 (void)my_pclose(rsfp);
1813 croak("Permission denied\n");
1817 setreuid(uid,euid) < 0
1819 # if defined(HAS_SETRESUID)
1820 setresuid(uid,euid,(Uid_t)-1) < 0
1823 || getuid() != uid || geteuid() != euid)
1824 croak("Can't reswap uid and euid");
1825 if (!cando(S_IXUSR,FALSE,&statbuf)) /* can real uid exec? */
1826 croak("Permission denied\n");
1828 #endif /* HAS_SETREUID */
1829 #endif /* IAMSUID */
1831 if (!S_ISREG(statbuf.st_mode))
1832 croak("Permission denied");
1833 if (statbuf.st_mode & S_IWOTH)
1834 croak("Setuid/gid script is writable by world");
1835 doswitches = FALSE; /* -s is insecure in suid */
1837 if (sv_gets(linestr, rsfp, 0) == Nullch ||
1838 strnNE(SvPV(linestr,na),"#!",2) ) /* required even on Sys V */
1839 croak("No #! line");
1840 s = SvPV(linestr,na)+2;
1842 while (!isSPACE(*s)) s++;
1843 for (s2 = s; (s2 > SvPV(linestr,na)+2 &&
1844 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
1845 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
1846 croak("Not a perl script");
1847 while (*s == ' ' || *s == '\t') s++;
1849 * #! arg must be what we saw above. They can invoke it by
1850 * mentioning suidperl explicitly, but they may not add any strange
1851 * arguments beyond what #! says if they do invoke suidperl that way.
1853 len = strlen(validarg);
1854 if (strEQ(validarg," PHOOEY ") ||
1855 strnNE(s,validarg,len) || !isSPACE(s[len]))
1856 croak("Args must match #! line");
1859 if (euid != uid && (statbuf.st_mode & S_ISUID) &&
1860 euid == statbuf.st_uid)
1862 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
1863 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
1864 #endif /* IAMSUID */
1866 if (euid) { /* oops, we're not the setuid root perl */
1867 (void)PerlIO_close(rsfp);
1869 (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel);
1870 execv(buf, origargv); /* try again */
1872 croak("Can't do setuid\n");
1875 if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid) {
1877 (void)setegid(statbuf.st_gid);
1880 (void)setregid((Gid_t)-1,statbuf.st_gid);
1882 #ifdef HAS_SETRESGID
1883 (void)setresgid((Gid_t)-1,statbuf.st_gid,(Gid_t)-1);
1885 setgid(statbuf.st_gid);
1889 if (getegid() != statbuf.st_gid)
1890 croak("Can't do setegid!\n");
1892 if (statbuf.st_mode & S_ISUID) {
1893 if (statbuf.st_uid != euid)
1895 (void)seteuid(statbuf.st_uid); /* all that for this */
1898 (void)setreuid((Uid_t)-1,statbuf.st_uid);
1900 #ifdef HAS_SETRESUID
1901 (void)setresuid((Uid_t)-1,statbuf.st_uid,(Uid_t)-1);
1903 setuid(statbuf.st_uid);
1907 if (geteuid() != statbuf.st_uid)
1908 croak("Can't do seteuid!\n");
1910 else if (uid) { /* oops, mustn't run as root */
1912 (void)seteuid((Uid_t)uid);
1915 (void)setreuid((Uid_t)-1,(Uid_t)uid);
1917 #ifdef HAS_SETRESUID
1918 (void)setresuid((Uid_t)-1,(Uid_t)uid,(Uid_t)-1);
1924 if (geteuid() != uid)
1925 croak("Can't do seteuid!\n");
1928 if (!cando(S_IXUSR,TRUE,&statbuf))
1929 croak("Permission denied\n"); /* they can't do this */
1932 else if (preprocess)
1933 croak("-P not allowed for setuid/setgid script\n");
1934 else if (fdscript >= 0)
1935 croak("fd script not allowed in suidperl\n");
1937 croak("Script is not setuid/setgid in suidperl\n");
1939 /* We absolutely must clear out any saved ids here, so we */
1940 /* exec the real perl, substituting fd script for scriptname. */
1941 /* (We pass script name as "subdir" of fd, which perl will grok.) */
1942 PerlIO_rewind(rsfp);
1943 lseek(PerlIO_fileno(rsfp),(Off_t)0,0); /* just in case rewind didn't */
1944 for (which = 1; origargv[which] && origargv[which] != scriptname; which++) ;
1945 if (!origargv[which])
1946 croak("Permission denied");
1947 (void)sprintf(buf, "/dev/fd/%d/%.127s", PerlIO_fileno(rsfp), origargv[which]);
1948 origargv[which] = buf;
1950 #if defined(HAS_FCNTL) && defined(F_SETFD)
1951 fcntl(PerlIO_fileno(rsfp),F_SETFD,0); /* ensure no close-on-exec */
1954 (void)sprintf(tokenbuf, "%s/perl%s", BIN, patchlevel);
1955 execv(tokenbuf, origargv); /* try again */
1956 croak("Can't do setuid\n");
1957 #endif /* IAMSUID */
1959 if (euid != uid || egid != gid) { /* (suidperl doesn't exist, in fact) */
1960 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
1961 Fstat(PerlIO_fileno(rsfp),&statbuf); /* may be either wrapped or real suid */
1962 if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
1964 (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
1967 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
1968 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
1969 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
1970 /* not set-id, must be wrapped */
1978 register char *s, *s2;
1980 /* skip forward in input to the real script? */
1984 if ((s = sv_gets(linestr, rsfp, 0)) == Nullch)
1985 croak("No Perl script found in input\n");
1986 if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
1987 PerlIO_ungetc(rsfp, '\n'); /* to keep line count right */
1989 while (*s && !(isSPACE (*s) || *s == '#')) s++;
1991 while (*s == ' ' || *s == '\t') s++;
1993 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
1994 if (strnEQ(s2-4,"perl",4))
1996 while (s = moreswitches(s)) ;
1998 if (cddir && chdir(cddir) < 0)
1999 croak("Can't chdir to %s",cddir);
2007 uid = (int)getuid();
2008 euid = (int)geteuid();
2009 gid = (int)getgid();
2010 egid = (int)getegid();
2015 tainting |= (uid && (euid != uid || egid != gid));
2023 croak("No %s allowed while running setuid", s);
2025 croak("No %s allowed while running setgid", s);
2031 curstash = debstash;
2032 dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
2034 DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
2035 DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
2036 DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
2037 DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
2038 sv_setiv(DBsingle, 0);
2039 DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
2040 sv_setiv(DBtrace, 0);
2041 DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
2042 sv_setiv(DBsignal, 0);
2043 curstash = defstash;
2050 mainstack = curstack; /* remember in case we switch stacks */
2051 AvREAL_off(curstack); /* not a real array */
2052 av_extend(curstack,127);
2054 stack_base = AvARRAY(curstack);
2055 stack_sp = stack_base;
2056 stack_max = stack_base + 127;
2058 cxstack_max = 8192 / sizeof(CONTEXT) - 2; /* Use most of 8K. */
2059 New(50,cxstack,cxstack_max + 1,CONTEXT);
2062 New(50,tmps_stack,128,SV*);
2067 New(51,debname,128,char);
2068 New(52,debdelim,128,char);
2072 * The following stacks almost certainly should be per-interpreter,
2073 * but for now they're not. XXX
2077 markstack_ptr = markstack;
2079 New(54,markstack,64,I32);
2080 markstack_ptr = markstack;
2081 markstack_max = markstack + 64;
2087 New(54,scopestack,32,I32);
2089 scopestack_max = 32;
2095 New(54,savestack,128,ANY);
2097 savestack_max = 128;
2103 New(54,retstack,16,OP*);
2113 Safefree(tmps_stack);
2120 static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
2128 subname = newSVpv("main",4);
2132 init_predump_symbols()
2137 sv_setpvn(GvSV(gv_fetchpv("\"", TRUE, SVt_PV)), " ", 1);
2139 stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
2140 GvMULTI_on(stdingv);
2141 IoIFP(GvIOp(stdingv)) = PerlIO_stdin();
2142 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
2144 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(stdingv));
2146 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
2148 IoOFP(GvIOp(tmpgv)) = IoIFP(GvIOp(tmpgv)) = PerlIO_stdout();
2150 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
2152 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(defoutgv));
2154 othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
2155 GvMULTI_on(othergv);
2156 IoOFP(GvIOp(othergv)) = IoIFP(GvIOp(othergv)) = PerlIO_stderr();
2157 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
2159 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(othergv));
2161 statname = NEWSV(66,0); /* last filename we did stat on */
2164 osname = savepv(OSNAME);
2168 init_postdump_symbols(argc,argv,env)
2170 register char **argv;
2171 register char **env;
2177 argc--,argv++; /* skip name of script */
2179 for (; argc > 0 && **argv == '-'; argc--,argv++) {
2182 if (argv[0][1] == '-') {
2186 if (s = strchr(argv[0], '=')) {
2188 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
2191 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
2194 toptarget = NEWSV(0,0);
2195 sv_upgrade(toptarget, SVt_PVFM);
2196 sv_setpvn(toptarget, "", 0);
2197 bodytarget = NEWSV(0,0);
2198 sv_upgrade(bodytarget, SVt_PVFM);
2199 sv_setpvn(bodytarget, "", 0);
2200 formtarget = bodytarget;
2203 if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
2204 sv_setpv(GvSV(tmpgv),origfilename);
2205 magicname("0", "0", 1);
2207 if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
2208 sv_setpv(GvSV(tmpgv),origargv[0]);
2209 if (argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
2211 (void)gv_AVadd(argvgv);
2212 av_clear(GvAVn(argvgv));
2213 for (; argc > 0; argc--,argv++) {
2214 av_push(GvAVn(argvgv),newSVpv(argv[0],0));
2217 if (envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
2222 #ifndef VMS /* VMS doesn't have environ array */
2223 /* Note that if the supplied env parameter is actually a copy
2224 of the global environ then it may now point to free'd memory
2225 if the environment has been modified since. To avoid this
2226 problem we treat env==NULL as meaning 'use the default'
2230 if (env != environ) {
2231 environ[0] = Nullch;
2232 hv_magic(hv, envgv, 'E');
2234 for (; *env; env++) {
2235 if (!(s = strchr(*env,'=')))
2238 sv = newSVpv(s--,0);
2239 sv_magic(sv, sv, 'e', *env, s - *env);
2240 (void)hv_store(hv, *env, s - *env, sv, 0);
2244 #ifdef DYNAMIC_ENV_FETCH
2245 HvNAME(hv) = savepv(ENV_HV_NAME);
2247 hv_magic(hv, envgv, 'E');
2250 if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
2251 sv_setiv(GvSV(tmpgv),(I32)getpid());
2260 s = getenv("PERL5LIB");
2264 incpush(getenv("PERLLIB"), FALSE);
2266 /* Treat PERL5?LIB as a possible search list logical name -- the
2267 * "natural" VMS idiom for a Unix path string. We allow each
2268 * element to be a set of |-separated directories for compatibility.
2272 if (my_trnlnm("PERL5LIB",buf,0))
2273 do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
2275 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE);
2279 /* Use the ~-expanded versions of APPLIB (undocumented),
2280 ARCHLIB PRIVLIB SITEARCH SITELIB and OLDARCHLIB
2283 incpush(APPLLIB_EXP, FALSE);
2287 incpush(ARCHLIB_EXP, FALSE);
2290 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
2292 incpush(PRIVLIB_EXP, FALSE);
2295 incpush(SITEARCH_EXP, FALSE);
2298 incpush(SITELIB_EXP, FALSE);
2300 #ifdef OLDARCHLIB_EXP /* 5.00[01] compatibility */
2301 incpush(OLDARCHLIB_EXP, FALSE);
2305 incpush(".", FALSE);
2309 # define PERLLIB_SEP ';'
2312 # define PERLLIB_SEP '|'
2314 # define PERLLIB_SEP ':'
2317 #ifndef PERLLIB_MANGLE
2318 # define PERLLIB_MANGLE(s,n) (s)
2322 incpush(p, addsubdirs)
2326 SV *subdir = Nullsv;
2327 static char *archpat_auto;
2334 if (!archpat_auto) {
2335 STRLEN len = (sizeof(ARCHNAME) + strlen(patchlevel)
2336 + sizeof("//auto"));
2337 New(55, archpat_auto, len, char);
2338 sprintf(archpat_auto, "/%s/%s/auto", ARCHNAME, patchlevel);
2342 /* Break at all separators */
2344 SV *libdir = newSV(0);
2347 /* skip any consecutive separators */
2348 while ( *p == PERLLIB_SEP ) {
2349 /* Uncomment the next line for PATH semantics */
2350 /* av_push(GvAVn(incgv), newSVpv(".", 1)); */
2354 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
2355 sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
2360 sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
2361 p = Nullch; /* break out */
2365 * BEFORE pushing libdir onto @INC we may first push version- and
2366 * archname-specific sub-directories.
2369 struct stat tmpstatbuf;
2371 /* .../archname/version if -d .../archname/version/auto */
2372 sv_setsv(subdir, libdir);
2373 sv_catpv(subdir, archpat_auto);
2374 if (Stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2375 S_ISDIR(tmpstatbuf.st_mode))
2376 av_push(GvAVn(incgv),
2377 newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2379 /* .../archname if -d .../archname/auto */
2380 sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME),
2381 strlen(patchlevel) + 1, "", 0);
2382 if (Stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2383 S_ISDIR(tmpstatbuf.st_mode))
2384 av_push(GvAVn(incgv),
2385 newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2388 /* finally push this lib directory on the end of @INC */
2389 av_push(GvAVn(incgv), libdir);
2392 SvREFCNT_dec(subdir);
2401 line_t oldline = curcop->cop_line;
2403 Copy(top_env, oldtop, 1, Sigjmp_buf);
2405 while (AvFILL(list) >= 0) {
2406 CV *cv = (CV*)av_shift(list);
2410 switch (Sigsetjmp(top_env,1)) {
2412 SV* atsv = GvSV(errgv);
2414 perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
2415 (void)SvPV(atsv, len);
2417 Copy(oldtop, top_env, 1, Sigjmp_buf);
2418 curcop = &compiling;
2419 curcop->cop_line = oldline;
2420 if (list == beginav)
2421 sv_catpv(atsv, "BEGIN failed--compilation aborted");
2423 sv_catpv(atsv, "END failed--cleanup aborted");
2424 croak("%s", SvPVX(atsv));
2432 /* my_exit() was called */
2433 curstash = defstash;
2437 Copy(oldtop, top_env, 1, Sigjmp_buf);
2438 curcop = &compiling;
2439 curcop->cop_line = oldline;
2441 if (list == beginav)
2442 croak("BEGIN failed--compilation aborted");
2444 croak("END failed--cleanup aborted");
2450 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
2454 Copy(oldtop, top_env, 1, Sigjmp_buf);
2455 curcop = &compiling;
2456 curcop->cop_line = oldline;
2457 Siglongjmp(top_env, 3);
2461 Copy(oldtop, top_env, 1, Sigjmp_buf);
2476 STATUS_NATIVE_SET(status);
2486 if (vaxc$errno & 1) {
2487 if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
2488 STATUS_NATIVE_SET(44);
2491 if (!vaxc$errno && errno) /* unlikely */
2492 STATUS_NATIVE_SET(44);
2494 STATUS_NATIVE_SET(vaxc$errno);
2498 STATUS_POSIX_SET(errno);
2499 else if (STATUS_POSIX == 0)
2500 STATUS_POSIX_SET(255);
2508 register CONTEXT *cx;
2517 (void)UNLINK(e_tmpname);
2518 Safefree(e_tmpname);
2522 if (cxstack_ix >= 0) {
2529 Siglongjmp(top_env, 2);