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 */
957 if (flags & G_DISCARD) {
962 Zero(&myop, 1, LOGOP);
963 if (flags & G_NOARGS) {
967 myop.op_flags |= OPf_STACKED;
968 myop.op_next = Nullop;
969 myop.op_flags |= OPf_KNOW;
971 myop.op_flags |= OPf_LIST;
978 oldscope = scopestack_ix;
980 if (perldb && curstash != debstash
981 /* Handle first BEGIN of -d. */
982 && (DBcv || (DBcv = GvCV(DBsub)))
983 /* Try harder, since this may have been a sighandler, thus
984 * curstash may be meaningless. */
985 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != debstash))
986 op->op_private |= OPpENTERSUB_DB;
988 if (flags & G_EVAL) {
989 Copy(top_env, oldtop, 1, Sigjmp_buf);
991 cLOGOP->op_other = op;
993 /* we're trying to emulate pp_entertry() here */
995 register CONTEXT *cx;
1001 push_return(op->op_next);
1002 PUSHBLOCK(cx, CXt_EVAL, stack_sp);
1004 eval_root = op; /* Only needed so that goto works right. */
1007 if (flags & G_KEEPERR)
1010 sv_setpv(GvSV(errgv),"");
1015 switch (Sigsetjmp(top_env,1)) {
1022 /* my_exit() was called */
1023 curstash = defstash;
1025 Copy(oldtop, top_env, 1, Sigjmp_buf);
1027 croak("Callback called exit");
1036 stack_sp = stack_base + oldmark;
1037 if (flags & G_ARRAY)
1041 *++stack_sp = &sv_undef;
1047 if (op == (OP*)&myop)
1051 retval = stack_sp - (stack_base + oldmark);
1052 if ((flags & G_EVAL) && !(flags & G_KEEPERR))
1053 sv_setpv(GvSV(errgv),"");
1056 if (flags & G_EVAL) {
1057 if (scopestack_ix > oldscope) {
1061 register CONTEXT *cx;
1070 Copy(oldtop, top_env, 1, Sigjmp_buf);
1072 if (flags & G_DISCARD) {
1073 stack_sp = stack_base + oldmark;
1081 /* Eval a string. The G_EVAL flag is always assumed. */
1084 perl_eval_sv(sv, flags)
1086 I32 flags; /* See G_* flags in cop.h */
1088 UNOP myop; /* fake syntax tree node */
1090 I32 oldmark = sp - stack_base;
1095 if (flags & G_DISCARD) {
1103 EXTEND(stack_sp, 1);
1105 oldscope = scopestack_ix;
1107 if (!(flags & G_NOARGS))
1108 myop.op_flags = OPf_STACKED;
1109 myop.op_next = Nullop;
1110 myop.op_type = OP_ENTEREVAL;
1111 myop.op_flags |= OPf_KNOW;
1112 if (flags & G_KEEPERR)
1113 myop.op_flags |= OPf_SPECIAL;
1114 if (flags & G_ARRAY)
1115 myop.op_flags |= OPf_LIST;
1117 Copy(top_env, oldtop, 1, Sigjmp_buf);
1120 switch (Sigsetjmp(top_env,1)) {
1127 /* my_exit() was called */
1128 curstash = defstash;
1130 Copy(oldtop, top_env, 1, Sigjmp_buf);
1132 croak("Callback called exit");
1141 stack_sp = stack_base + oldmark;
1142 if (flags & G_ARRAY)
1146 *++stack_sp = &sv_undef;
1151 if (op == (OP*)&myop)
1152 op = pp_entereval();
1155 retval = stack_sp - (stack_base + oldmark);
1156 if (!(flags & G_KEEPERR))
1157 sv_setpv(GvSV(errgv),"");
1160 Copy(oldtop, top_env, 1, Sigjmp_buf);
1161 if (flags & G_DISCARD) {
1162 stack_sp = stack_base + oldmark;
1170 /* Require a module. */
1176 SV* sv = sv_newmortal();
1177 sv_setpv(sv, "require '");
1180 perl_eval_sv(sv, G_DISCARD);
1184 magicname(sym,name,namlen)
1191 if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
1192 sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
1196 usage(name) /* XXX move this out into a module ? */
1199 /* This message really ought to be max 23 lines.
1200 * Removed -h because the user already knows that opton. Others? */
1201 printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
1202 printf("\n -0[octal] specify record separator (\\0, if no argument)");
1203 printf("\n -a autosplit mode with -n or -p (splits $_ into @F)");
1204 printf("\n -c check syntax only (runs BEGIN and END blocks)");
1205 printf("\n -d[:debugger] run scripts under debugger");
1206 printf("\n -D[number/list] set debugging flags (argument is a bit mask or flags)");
1207 printf("\n -e 'command' one line of script. Several -e's allowed. Omit [programfile].");
1208 printf("\n -F/pattern/ split() pattern for autosplit (-a). The //'s are optional.");
1209 printf("\n -i[extension] edit <> files in place (make backup if extension supplied)");
1210 printf("\n -Idirectory specify @INC/#include directory (may be used more then once)");
1211 printf("\n -l[octal] enable line ending processing, specifies line teminator");
1212 printf("\n -[mM][-]module.. executes `use/no module...' before executing your script.");
1213 printf("\n -n assume 'while (<>) { ... }' loop arround your script");
1214 printf("\n -p assume loop like -n but print line also like sed");
1215 printf("\n -P run script through C preprocessor before compilation");
1216 printf("\n -s enable some switch parsing for switches after script name");
1217 printf("\n -S look for the script using PATH environment variable");
1218 printf("\n -T turn on tainting checks");
1219 printf("\n -u dump core after parsing script");
1220 printf("\n -U allow unsafe operations");
1221 printf("\n -v print version number and patchlevel of perl");
1222 printf("\n -V[:variable] print perl configuration information");
1223 printf("\n -w TURN WARNINGS ON FOR COMPILATION OF YOUR SCRIPT.");
1224 printf("\n -x[directory] strip off text before #!perl line and perhaps cd to directory\n");
1227 /* This routine handles any switches that can be given during run */
1238 rschar = scan_oct(s, 4, &numlen);
1240 if (rschar & ~((U8)~0))
1242 else if (!rschar && numlen >= 2)
1243 nrs = newSVpv("", 0);
1246 nrs = newSVpv(&ch, 1);
1251 splitstr = savepv(s + 1);
1265 if (*s == ':' || *s == '=') {
1266 sprintf(buf, "use Devel::%s;", ++s);
1268 my_setenv("PERL5DB",buf);
1278 if (isALPHA(s[1])) {
1279 static char debopts[] = "psltocPmfrxuLHXD";
1282 for (s++; *s && (d = strchr(debopts,*s)); s++)
1283 debug |= 1 << (d - debopts);
1287 for (s++; isDIGIT(*s); s++) ;
1289 debug |= 0x80000000;
1291 warn("Recompile perl with -DDEBUGGING to use -D switch\n");
1292 for (s++; isALNUM(*s); s++) ;
1302 inplace = savepv(s+1);
1304 for (s = inplace; *s && !isSPACE(*s); s++) ;
1311 for (e = s; *e && !isSPACE(*e); e++) ;
1312 p = savepvn(s, e-s);
1319 croak("No space allowed after -I");
1329 *ors = scan_oct(s, 3 + (*s == '0'), &numlen);
1338 ors = SvPV(nrs, orslen);
1339 ors = savepvn(ors, orslen);
1343 forbid_setid("-M"); /* XXX ? */
1346 forbid_setid("-m"); /* XXX ? */
1350 /* -M-foo == 'no foo' */
1351 if (*s == '-') { use = "no "; ++s; }
1352 Sv = newSVpv(use,0);
1354 /* We allow -M'Module qw(Foo Bar)' */
1355 while(isALNUM(*s) || *s==':') ++s;
1357 sv_catpv(Sv, start);
1358 if (*(start-1) == 'm') {
1360 croak("Can't use '%c' after -mname", *s);
1361 sv_catpv( Sv, " ()");
1364 sv_catpvn(Sv, start, s-start);
1365 sv_catpv(Sv, " split(/,/,q{");
1370 if (preambleav == NULL)
1371 preambleav = newAV();
1372 av_push(preambleav, Sv);
1375 croak("No space allowed after -%c", *(s-1));
1392 croak("Too late for \"-T\" option (try putting it first)");
1404 #if defined(SUBVERSION) && SUBVERSION > 0
1405 printf("\nThis is perl, version 5.%03d_%02d", PATCHLEVEL, SUBVERSION);
1407 printf("\nThis is perl, version %s",patchlevel);
1410 printf("\n\nCopyright 1987-1997, Larry Wall\n");
1412 printf("\n\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
1415 printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n");
1418 printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
1419 "Version 5 port Copyright (c) 1994-1996, Andreas Kaiser, Ilya Zakharevich\n");
1422 printf("atariST series port, ++jrb bammi@cadence.com\n");
1425 Perl may be copied only under the terms of either the Artistic License or the\n\
1426 GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n");
1434 if (s[1] == '-') /* Additional switches on #! line. */
1442 #ifdef ALTERNATE_SHEBANG
1443 case 'S': /* OS/2 needs -S on "extproc" line. */
1451 croak("Can't emulate -%.1s on #! line",s);
1456 /* compliments of Tom Christiansen */
1458 /* unexec() can be found in the Gnu emacs distribution */
1467 sprintf (buf, "%s.perldump", origfilename);
1468 sprintf (tokenbuf, "%s/perl", BIN);
1470 status = unexec(buf, tokenbuf, &etext, sbrk(0), 0);
1472 PerlIO_printf(PerlIO_stderr(), "unexec of %s into %s failed!\n", tokenbuf, buf);
1476 # include <lib$routines.h>
1477 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
1479 ABORT(); /* for use with undump */
1489 /* Note that strtab is a rather special HV. Assumptions are made
1490 about not iterating on it, and not adding tie magic to it.
1491 It is properly deallocated in perl_destruct() */
1493 HvSHAREKEYS_off(strtab); /* mandatory */
1494 Newz(506,((XPVHV*)SvANY(strtab))->xhv_array,
1495 sizeof(HE*) * (((XPVHV*)SvANY(strtab))->xhv_max + 1), char);
1497 curstash = defstash = newHV();
1498 curstname = newSVpv("main",4);
1499 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
1500 SvREFCNT_dec(GvHV(gv));
1501 GvHV(gv) = (HV*)SvREFCNT_inc(defstash);
1503 HvNAME(defstash) = savepv("main");
1504 incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
1506 defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
1507 errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
1509 sv_setpvn(GvSV(errgv), "", 0);
1510 curstash = defstash;
1511 compiling.cop_stash = defstash;
1512 debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
1513 /* We must init $/ before switches are processed. */
1514 sv_setpvn(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), "\n", 1);
1517 #ifdef CAN_PROTOTYPE
1519 open_script(char *scriptname, bool dosearch, SV *sv)
1522 open_script(scriptname,dosearch,sv)
1528 char *xfound = Nullch;
1529 char *xfailed = Nullch;
1533 #if defined(DOSISH) && !defined(OS2) && !defined(atarist)
1534 #define SEARCH_EXTS ".bat", ".cmd", NULL
1537 # define SEARCH_EXTS ".pl", ".com", NULL
1539 /* additional extensions to try in each dir if scriptname not found */
1541 char *ext[] = { SEARCH_EXTS };
1542 int extidx = (strchr(scriptname,'.')) ? -1 : 0; /* has ext already */
1547 int hasdir, idx = 0, deftypes = 1;
1549 hasdir = (strpbrk(scriptname,":[</") != Nullch) ;
1550 /* The first time through, just add SEARCH_EXTS to whatever we
1551 * already have, so we can check for default file types. */
1552 while (deftypes || (!hasdir && my_trnlnm("DCL$PATH",tokenbuf,idx++)) ) {
1553 if (deftypes) { deftypes = 0; *tokenbuf = '\0'; }
1554 strcat(tokenbuf,scriptname);
1556 if (dosearch && !strchr(scriptname, '/') && (s = getenv("PATH"))) {
1558 bufend = s + strlen(s);
1561 s = cpytill(tokenbuf,s,bufend,':',&len);
1564 for (len = 0; *s && *s != ',' && *s != ';'; tokenbuf[len++] = *s++);
1565 tokenbuf[len] = '\0';
1567 for (len = 0; *s && *s != ';'; tokenbuf[len++] = *s++);
1568 tokenbuf[len] = '\0';
1574 if (len && tokenbuf[len-1] != '/')
1577 if (len && ((tokenbuf[len-1] != '\\') && (tokenbuf[len-1] != '/')))
1579 if (len && tokenbuf[len-1] != '\\')
1582 (void)strcat(tokenbuf+len,"/");
1583 (void)strcat(tokenbuf+len,scriptname);
1587 len = strlen(tokenbuf);
1588 if (extidx > 0) /* reset after previous loop */
1592 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tokenbuf));
1593 retval = Stat(tokenbuf,&statbuf);
1595 } while ( retval < 0 /* not there */
1596 && extidx>=0 && ext[extidx] /* try an extension? */
1597 && strcpy(tokenbuf+len, ext[extidx++])
1602 if (S_ISREG(statbuf.st_mode)
1603 && cando(S_IRUSR,TRUE,&statbuf) && cando(S_IXUSR,TRUE,&statbuf)) {
1604 xfound = tokenbuf; /* bingo! */
1608 xfailed = savepv(tokenbuf);
1611 croak("Can't execute %s", xfailed ? xfailed : scriptname );
1614 scriptname = xfound;
1617 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
1618 char *s = scriptname + 8;
1627 origfilename = savepv(e_tmpname ? "-e" : scriptname);
1628 curcop->cop_filegv = gv_fetchfile(origfilename);
1629 if (strEQ(origfilename,"-"))
1631 if (fdscript >= 0) {
1632 rsfp = PerlIO_fdopen(fdscript,"r");
1633 #if defined(HAS_FCNTL) && defined(F_SETFD)
1635 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
1638 else if (preprocess) {
1639 char *cpp = CPPSTDIN;
1641 if (strEQ(cpp,"cppstdin"))
1642 sprintf(tokenbuf, "%s/%s", SCRIPTDIR, cpp);
1644 sprintf(tokenbuf, "%s", cpp);
1646 sv_catpv(sv,PRIVLIB_EXP);
1648 (void)sprintf(buf, "\
1649 sed %s -e \"/^[^#]/b\" \
1650 -e \"/^#[ ]*include[ ]/b\" \
1651 -e \"/^#[ ]*define[ ]/b\" \
1652 -e \"/^#[ ]*if[ ]/b\" \
1653 -e \"/^#[ ]*ifdef[ ]/b\" \
1654 -e \"/^#[ ]*ifndef[ ]/b\" \
1655 -e \"/^#[ ]*else/b\" \
1656 -e \"/^#[ ]*elif[ ]/b\" \
1657 -e \"/^#[ ]*undef[ ]/b\" \
1658 -e \"/^#[ ]*endif/b\" \
1661 (doextract ? "-e \"1,/^#/d\n\"" : ""),
1663 (void)sprintf(buf, "\
1664 %s %s -e '/^[^#]/b' \
1665 -e '/^#[ ]*include[ ]/b' \
1666 -e '/^#[ ]*define[ ]/b' \
1667 -e '/^#[ ]*if[ ]/b' \
1668 -e '/^#[ ]*ifdef[ ]/b' \
1669 -e '/^#[ ]*ifndef[ ]/b' \
1670 -e '/^#[ ]*else/b' \
1671 -e '/^#[ ]*elif[ ]/b' \
1672 -e '/^#[ ]*undef[ ]/b' \
1673 -e '/^#[ ]*endif/b' \
1681 (doextract ? "-e '1,/^#/d\n'" : ""),
1683 scriptname, tokenbuf, SvPV(sv, na), CPPMINUS);
1685 #ifdef IAMSUID /* actually, this is caught earlier */
1686 if (euid != uid && !euid) { /* if running suidperl */
1688 (void)seteuid(uid); /* musn't stay setuid root */
1691 (void)setreuid((Uid_t)-1, uid);
1693 #ifdef HAS_SETRESUID
1694 (void)setresuid((Uid_t)-1, uid, (Uid_t)-1);
1700 if (geteuid() != uid)
1701 croak("Can't do seteuid!\n");
1703 #endif /* IAMSUID */
1704 rsfp = my_popen(buf,"r");
1706 else if (!*scriptname) {
1707 forbid_setid("program input from stdin");
1708 rsfp = PerlIO_stdin();
1711 rsfp = PerlIO_open(scriptname,"r");
1712 #if defined(HAS_FCNTL) && defined(F_SETFD)
1714 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
1722 #ifndef IAMSUID /* in case script is not readable before setuid */
1723 if (euid && Stat(SvPVX(GvSV(curcop->cop_filegv)),&statbuf) >= 0 &&
1724 statbuf.st_mode & (S_ISUID|S_ISGID)) {
1725 (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel);
1726 execv(buf, origargv); /* try again */
1727 croak("Can't do setuid\n");
1731 croak("Can't open perl script \"%s\": %s\n",
1732 SvPVX(GvSV(curcop->cop_filegv)), Strerror(errno));
1737 validate_suid(validarg, scriptname)
1743 /* do we need to emulate setuid on scripts? */
1745 /* This code is for those BSD systems that have setuid #! scripts disabled
1746 * in the kernel because of a security problem. Merely defining DOSUID
1747 * in perl will not fix that problem, but if you have disabled setuid
1748 * scripts in the kernel, this will attempt to emulate setuid and setgid
1749 * on scripts that have those now-otherwise-useless bits set. The setuid
1750 * root version must be called suidperl or sperlN.NNN. If regular perl
1751 * discovers that it has opened a setuid script, it calls suidperl with
1752 * the same argv that it had. If suidperl finds that the script it has
1753 * just opened is NOT setuid root, it sets the effective uid back to the
1754 * uid. We don't just make perl setuid root because that loses the
1755 * effective uid we had before invoking perl, if it was different from the
1758 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
1759 * be defined in suidperl only. suidperl must be setuid root. The
1760 * Configure script will set this up for you if you want it.
1766 if (Fstat(PerlIO_fileno(rsfp),&statbuf) < 0) /* normal stat is insecure */
1767 croak("Can't stat script \"%s\"",origfilename);
1768 if (fdscript < 0 && statbuf.st_mode & (S_ISUID|S_ISGID)) {
1772 #ifndef HAS_SETREUID
1773 /* On this access check to make sure the directories are readable,
1774 * there is actually a small window that the user could use to make
1775 * filename point to an accessible directory. So there is a faint
1776 * chance that someone could execute a setuid script down in a
1777 * non-accessible directory. I don't know what to do about that.
1778 * But I don't think it's too important. The manual lies when
1779 * it says access() is useful in setuid programs.
1781 if (access(SvPVX(GvSV(curcop->cop_filegv)),1)) /*double check*/
1782 croak("Permission denied");
1784 /* If we can swap euid and uid, then we can determine access rights
1785 * with a simple stat of the file, and then compare device and
1786 * inode to make sure we did stat() on the same file we opened.
1787 * Then we just have to make sure he or she can execute it.
1790 struct stat tmpstatbuf;
1794 setreuid(euid,uid) < 0
1797 setresuid(euid,uid,(Uid_t)-1) < 0
1800 || getuid() != euid || geteuid() != uid)
1801 croak("Can't swap uid and euid"); /* really paranoid */
1802 if (Stat(SvPVX(GvSV(curcop->cop_filegv)),&tmpstatbuf) < 0)
1803 croak("Permission denied"); /* testing full pathname here */
1804 if (tmpstatbuf.st_dev != statbuf.st_dev ||
1805 tmpstatbuf.st_ino != statbuf.st_ino) {
1806 (void)PerlIO_close(rsfp);
1807 if (rsfp = my_popen("/bin/mail root","w")) { /* heh, heh */
1809 "User %ld tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
1810 (Filename of set-id script was %s, uid %ld gid %ld.)\n\nSincerely,\nperl\n",
1811 (long)uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
1812 (long)statbuf.st_dev, (long)statbuf.st_ino,
1813 SvPVX(GvSV(curcop->cop_filegv)),
1814 (long)statbuf.st_uid, (long)statbuf.st_gid);
1815 (void)my_pclose(rsfp);
1817 croak("Permission denied\n");
1821 setreuid(uid,euid) < 0
1823 # if defined(HAS_SETRESUID)
1824 setresuid(uid,euid,(Uid_t)-1) < 0
1827 || getuid() != uid || geteuid() != euid)
1828 croak("Can't reswap uid and euid");
1829 if (!cando(S_IXUSR,FALSE,&statbuf)) /* can real uid exec? */
1830 croak("Permission denied\n");
1832 #endif /* HAS_SETREUID */
1833 #endif /* IAMSUID */
1835 if (!S_ISREG(statbuf.st_mode))
1836 croak("Permission denied");
1837 if (statbuf.st_mode & S_IWOTH)
1838 croak("Setuid/gid script is writable by world");
1839 doswitches = FALSE; /* -s is insecure in suid */
1841 if (sv_gets(linestr, rsfp, 0) == Nullch ||
1842 strnNE(SvPV(linestr,na),"#!",2) ) /* required even on Sys V */
1843 croak("No #! line");
1844 s = SvPV(linestr,na)+2;
1846 while (!isSPACE(*s)) s++;
1847 for (s2 = s; (s2 > SvPV(linestr,na)+2 &&
1848 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
1849 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
1850 croak("Not a perl script");
1851 while (*s == ' ' || *s == '\t') s++;
1853 * #! arg must be what we saw above. They can invoke it by
1854 * mentioning suidperl explicitly, but they may not add any strange
1855 * arguments beyond what #! says if they do invoke suidperl that way.
1857 len = strlen(validarg);
1858 if (strEQ(validarg," PHOOEY ") ||
1859 strnNE(s,validarg,len) || !isSPACE(s[len]))
1860 croak("Args must match #! line");
1863 if (euid != uid && (statbuf.st_mode & S_ISUID) &&
1864 euid == statbuf.st_uid)
1866 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
1867 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
1868 #endif /* IAMSUID */
1870 if (euid) { /* oops, we're not the setuid root perl */
1871 (void)PerlIO_close(rsfp);
1873 (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel);
1874 execv(buf, origargv); /* try again */
1876 croak("Can't do setuid\n");
1879 if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid) {
1881 (void)setegid(statbuf.st_gid);
1884 (void)setregid((Gid_t)-1,statbuf.st_gid);
1886 #ifdef HAS_SETRESGID
1887 (void)setresgid((Gid_t)-1,statbuf.st_gid,(Gid_t)-1);
1889 setgid(statbuf.st_gid);
1893 if (getegid() != statbuf.st_gid)
1894 croak("Can't do setegid!\n");
1896 if (statbuf.st_mode & S_ISUID) {
1897 if (statbuf.st_uid != euid)
1899 (void)seteuid(statbuf.st_uid); /* all that for this */
1902 (void)setreuid((Uid_t)-1,statbuf.st_uid);
1904 #ifdef HAS_SETRESUID
1905 (void)setresuid((Uid_t)-1,statbuf.st_uid,(Uid_t)-1);
1907 setuid(statbuf.st_uid);
1911 if (geteuid() != statbuf.st_uid)
1912 croak("Can't do seteuid!\n");
1914 else if (uid) { /* oops, mustn't run as root */
1916 (void)seteuid((Uid_t)uid);
1919 (void)setreuid((Uid_t)-1,(Uid_t)uid);
1921 #ifdef HAS_SETRESUID
1922 (void)setresuid((Uid_t)-1,(Uid_t)uid,(Uid_t)-1);
1928 if (geteuid() != uid)
1929 croak("Can't do seteuid!\n");
1932 if (!cando(S_IXUSR,TRUE,&statbuf))
1933 croak("Permission denied\n"); /* they can't do this */
1936 else if (preprocess)
1937 croak("-P not allowed for setuid/setgid script\n");
1938 else if (fdscript >= 0)
1939 croak("fd script not allowed in suidperl\n");
1941 croak("Script is not setuid/setgid in suidperl\n");
1943 /* We absolutely must clear out any saved ids here, so we */
1944 /* exec the real perl, substituting fd script for scriptname. */
1945 /* (We pass script name as "subdir" of fd, which perl will grok.) */
1946 PerlIO_rewind(rsfp);
1947 lseek(PerlIO_fileno(rsfp),(Off_t)0,0); /* just in case rewind didn't */
1948 for (which = 1; origargv[which] && origargv[which] != scriptname; which++) ;
1949 if (!origargv[which])
1950 croak("Permission denied");
1951 (void)sprintf(buf, "/dev/fd/%d/%.127s", PerlIO_fileno(rsfp), origargv[which]);
1952 origargv[which] = buf;
1954 #if defined(HAS_FCNTL) && defined(F_SETFD)
1955 fcntl(PerlIO_fileno(rsfp),F_SETFD,0); /* ensure no close-on-exec */
1958 (void)sprintf(tokenbuf, "%s/perl%s", BIN, patchlevel);
1959 execv(tokenbuf, origargv); /* try again */
1960 croak("Can't do setuid\n");
1961 #endif /* IAMSUID */
1963 if (euid != uid || egid != gid) { /* (suidperl doesn't exist, in fact) */
1964 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
1965 Fstat(PerlIO_fileno(rsfp),&statbuf); /* may be either wrapped or real suid */
1966 if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
1968 (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
1971 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
1972 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
1973 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
1974 /* not set-id, must be wrapped */
1982 register char *s, *s2;
1984 /* skip forward in input to the real script? */
1988 if ((s = sv_gets(linestr, rsfp, 0)) == Nullch)
1989 croak("No Perl script found in input\n");
1990 if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
1991 PerlIO_ungetc(rsfp, '\n'); /* to keep line count right */
1993 while (*s && !(isSPACE (*s) || *s == '#')) s++;
1995 while (*s == ' ' || *s == '\t') s++;
1997 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
1998 if (strnEQ(s2-4,"perl",4))
2000 while (s = moreswitches(s)) ;
2002 if (cddir && chdir(cddir) < 0)
2003 croak("Can't chdir to %s",cddir);
2011 uid = (int)getuid();
2012 euid = (int)geteuid();
2013 gid = (int)getgid();
2014 egid = (int)getegid();
2019 tainting |= (uid && (euid != uid || egid != gid));
2027 croak("No %s allowed while running setuid", s);
2029 croak("No %s allowed while running setgid", s);
2035 curstash = debstash;
2036 dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
2038 DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
2039 DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
2040 DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
2041 DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
2042 sv_setiv(DBsingle, 0);
2043 DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
2044 sv_setiv(DBtrace, 0);
2045 DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
2046 sv_setiv(DBsignal, 0);
2047 curstash = defstash;
2054 mainstack = curstack; /* remember in case we switch stacks */
2055 AvREAL_off(curstack); /* not a real array */
2056 av_extend(curstack,127);
2058 stack_base = AvARRAY(curstack);
2059 stack_sp = stack_base;
2060 stack_max = stack_base + 127;
2062 cxstack_max = 8192 / sizeof(CONTEXT) - 2; /* Use most of 8K. */
2063 New(50,cxstack,cxstack_max + 1,CONTEXT);
2066 New(50,tmps_stack,128,SV*);
2071 New(51,debname,128,char);
2072 New(52,debdelim,128,char);
2076 * The following stacks almost certainly should be per-interpreter,
2077 * but for now they're not. XXX
2081 markstack_ptr = markstack;
2083 New(54,markstack,64,I32);
2084 markstack_ptr = markstack;
2085 markstack_max = markstack + 64;
2091 New(54,scopestack,32,I32);
2093 scopestack_max = 32;
2099 New(54,savestack,128,ANY);
2101 savestack_max = 128;
2107 New(54,retstack,16,OP*);
2117 Safefree(tmps_stack);
2124 static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
2132 subname = newSVpv("main",4);
2136 init_predump_symbols()
2141 sv_setpvn(GvSV(gv_fetchpv("\"", TRUE, SVt_PV)), " ", 1);
2143 stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
2144 GvMULTI_on(stdingv);
2145 IoIFP(GvIOp(stdingv)) = PerlIO_stdin();
2146 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
2148 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(stdingv));
2150 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
2152 IoOFP(GvIOp(tmpgv)) = IoIFP(GvIOp(tmpgv)) = PerlIO_stdout();
2154 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
2156 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(defoutgv));
2158 othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
2159 GvMULTI_on(othergv);
2160 IoOFP(GvIOp(othergv)) = IoIFP(GvIOp(othergv)) = PerlIO_stderr();
2161 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
2163 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(othergv));
2165 statname = NEWSV(66,0); /* last filename we did stat on */
2168 osname = savepv(OSNAME);
2172 init_postdump_symbols(argc,argv,env)
2174 register char **argv;
2175 register char **env;
2181 argc--,argv++; /* skip name of script */
2183 for (; argc > 0 && **argv == '-'; argc--,argv++) {
2186 if (argv[0][1] == '-') {
2190 if (s = strchr(argv[0], '=')) {
2192 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
2195 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
2198 toptarget = NEWSV(0,0);
2199 sv_upgrade(toptarget, SVt_PVFM);
2200 sv_setpvn(toptarget, "", 0);
2201 bodytarget = NEWSV(0,0);
2202 sv_upgrade(bodytarget, SVt_PVFM);
2203 sv_setpvn(bodytarget, "", 0);
2204 formtarget = bodytarget;
2207 if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
2208 sv_setpv(GvSV(tmpgv),origfilename);
2209 magicname("0", "0", 1);
2211 if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
2212 sv_setpv(GvSV(tmpgv),origargv[0]);
2213 if (argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
2215 (void)gv_AVadd(argvgv);
2216 av_clear(GvAVn(argvgv));
2217 for (; argc > 0; argc--,argv++) {
2218 av_push(GvAVn(argvgv),newSVpv(argv[0],0));
2221 if (envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
2226 #ifndef VMS /* VMS doesn't have environ array */
2227 /* Note that if the supplied env parameter is actually a copy
2228 of the global environ then it may now point to free'd memory
2229 if the environment has been modified since. To avoid this
2230 problem we treat env==NULL as meaning 'use the default'
2234 if (env != environ) {
2235 environ[0] = Nullch;
2236 hv_magic(hv, envgv, 'E');
2238 for (; *env; env++) {
2239 if (!(s = strchr(*env,'=')))
2242 sv = newSVpv(s--,0);
2243 sv_magic(sv, sv, 'e', *env, s - *env);
2244 (void)hv_store(hv, *env, s - *env, sv, 0);
2248 #ifdef DYNAMIC_ENV_FETCH
2249 HvNAME(hv) = savepv(ENV_HV_NAME);
2251 hv_magic(hv, envgv, 'E');
2254 if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
2255 sv_setiv(GvSV(tmpgv),(I32)getpid());
2264 s = getenv("PERL5LIB");
2268 incpush(getenv("PERLLIB"), FALSE);
2270 /* Treat PERL5?LIB as a possible search list logical name -- the
2271 * "natural" VMS idiom for a Unix path string. We allow each
2272 * element to be a set of |-separated directories for compatibility.
2276 if (my_trnlnm("PERL5LIB",buf,0))
2277 do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
2279 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE);
2283 /* Use the ~-expanded versions of APPLIB (undocumented),
2284 ARCHLIB PRIVLIB SITEARCH SITELIB and OLDARCHLIB
2287 incpush(APPLLIB_EXP, FALSE);
2291 incpush(ARCHLIB_EXP, FALSE);
2294 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
2296 incpush(PRIVLIB_EXP, FALSE);
2299 incpush(SITEARCH_EXP, FALSE);
2302 incpush(SITELIB_EXP, FALSE);
2304 #ifdef OLDARCHLIB_EXP /* 5.00[01] compatibility */
2305 incpush(OLDARCHLIB_EXP, FALSE);
2309 incpush(".", FALSE);
2313 # define PERLLIB_SEP ';'
2316 # define PERLLIB_SEP '|'
2318 # define PERLLIB_SEP ':'
2321 #ifndef PERLLIB_MANGLE
2322 # define PERLLIB_MANGLE(s,n) (s)
2326 incpush(p, addsubdirs)
2330 SV *subdir = Nullsv;
2331 static char *archpat_auto;
2338 if (!archpat_auto) {
2339 STRLEN len = (sizeof(ARCHNAME) + strlen(patchlevel)
2340 + sizeof("//auto"));
2341 New(55, archpat_auto, len, char);
2342 sprintf(archpat_auto, "/%s/%s/auto", ARCHNAME, patchlevel);
2344 for (len = sizeof(ARCHNAME) + 2;
2345 archpat_auto[len] != '\0' && archpat_auto[len] != '/'; len++)
2346 if (archpat_auto[len] == '.') archpat_auto[len] = '_';
2351 /* Break at all separators */
2353 SV *libdir = newSV(0);
2356 /* skip any consecutive separators */
2357 while ( *p == PERLLIB_SEP ) {
2358 /* Uncomment the next line for PATH semantics */
2359 /* av_push(GvAVn(incgv), newSVpv(".", 1)); */
2363 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
2364 sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
2369 sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
2370 p = Nullch; /* break out */
2374 * BEFORE pushing libdir onto @INC we may first push version- and
2375 * archname-specific sub-directories.
2378 struct stat tmpstatbuf;
2383 if ((unix = tounixspec_ts(SvPV(libdir,na),Nullch)) != Nullch) {
2385 while (unix[len-1] == '/') len--; /* Cosmetic */
2386 sv_usepvn(libdir,unix,len);
2389 PerlIO_printf(PerlIO_stderr(),
2390 "Failed to unixify @INC element \"%s\"\n",
2393 /* .../archname/version if -d .../archname/version/auto */
2394 sv_setsv(subdir, libdir);
2395 sv_catpv(subdir, archpat_auto);
2396 if (Stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2397 S_ISDIR(tmpstatbuf.st_mode))
2398 av_push(GvAVn(incgv),
2399 newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2401 /* .../archname if -d .../archname/auto */
2402 sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME),
2403 strlen(patchlevel) + 1, "", 0);
2404 if (Stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2405 S_ISDIR(tmpstatbuf.st_mode))
2406 av_push(GvAVn(incgv),
2407 newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2410 /* finally push this lib directory on the end of @INC */
2411 av_push(GvAVn(incgv), libdir);
2414 SvREFCNT_dec(subdir);
2423 line_t oldline = curcop->cop_line;
2425 Copy(top_env, oldtop, 1, Sigjmp_buf);
2427 while (AvFILL(list) >= 0) {
2428 CV *cv = (CV*)av_shift(list);
2432 switch (Sigsetjmp(top_env,1)) {
2434 SV* atsv = GvSV(errgv);
2436 perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
2437 (void)SvPV(atsv, len);
2439 Copy(oldtop, top_env, 1, Sigjmp_buf);
2440 curcop = &compiling;
2441 curcop->cop_line = oldline;
2442 if (list == beginav)
2443 sv_catpv(atsv, "BEGIN failed--compilation aborted");
2445 sv_catpv(atsv, "END failed--cleanup aborted");
2446 croak("%s", SvPVX(atsv));
2454 /* my_exit() was called */
2455 curstash = defstash;
2459 Copy(oldtop, top_env, 1, Sigjmp_buf);
2460 curcop = &compiling;
2461 curcop->cop_line = oldline;
2463 if (list == beginav)
2464 croak("BEGIN failed--compilation aborted");
2466 croak("END failed--cleanup aborted");
2472 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
2476 Copy(oldtop, top_env, 1, Sigjmp_buf);
2477 curcop = &compiling;
2478 curcop->cop_line = oldline;
2479 Siglongjmp(top_env, 3);
2483 Copy(oldtop, top_env, 1, Sigjmp_buf);
2498 STATUS_NATIVE_SET(status);
2508 if (vaxc$errno & 1) {
2509 if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
2510 STATUS_NATIVE_SET(44);
2513 if (!vaxc$errno && errno) /* unlikely */
2514 STATUS_NATIVE_SET(44);
2516 STATUS_NATIVE_SET(vaxc$errno);
2520 STATUS_POSIX_SET(errno);
2521 else if (STATUS_POSIX == 0)
2522 STATUS_POSIX_SET(255);
2530 register CONTEXT *cx;
2539 (void)UNLINK(e_tmpname);
2540 Safefree(e_tmpname);
2544 if (cxstack_ix >= 0) {
2551 Siglongjmp(top_env, 2);