3 * Copyright (c) 1987-1997 Larry Wall
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
11 * "A ship then new they built for him/of mithril and of elven glass" --Bilbo
16 #include "patchlevel.h"
18 /* XXX If this causes problems, set i_unistd=undef in the hint file. */
23 #if !defined(STANDARD_C) && !defined(HAS_GETENV_PROTOTYPE)
24 char *getenv _((char *)); /* Usually in <stdlib.h> */
27 dEXTCONST char rcsid[] = "perl.c\nPatch level: ###\n";
35 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
45 curcop = &compiling; \
52 laststype = OP_STAT; \
54 maxsysfd = MAXSYSFD; \
61 laststype = OP_STAT; \
65 static void find_beginning _((void));
66 static void forbid_setid _((char *));
67 static void incpush _((char *, int));
68 static void init_ids _((void));
69 static void init_debugger _((void));
70 static void init_lexer _((void));
71 static void init_main_stash _((void));
72 static void init_perllib _((void));
73 static void init_postdump_symbols _((int, char **, char **));
74 static void init_predump_symbols _((void));
75 static void init_stacks _((void));
76 static void my_exit_jump _((void)) __attribute__((noreturn));
77 static void nuke_stacks _((void));
78 static void open_script _((char *, bool, SV *));
79 static void usage _((char *));
80 static void validate_suid _((char *, char*));
82 static int fdscript = -1;
87 PerlInterpreter *sv_interp;
90 New(53, sv_interp, 1, PerlInterpreter);
95 perl_construct( sv_interp )
96 register PerlInterpreter *sv_interp;
98 if (!(curinterp = sv_interp))
102 Zero(sv_interp, 1, PerlInterpreter);
105 /* Init the real globals? */
107 linestr = NEWSV(65,80);
108 sv_upgrade(linestr,SVt_PVIV);
110 if (!SvREADONLY(&sv_undef)) {
111 SvREADONLY_on(&sv_undef);
115 SvREADONLY_on(&sv_no);
117 sv_setpv(&sv_yes,Yes);
119 SvREADONLY_on(&sv_yes);
122 nrs = newSVpv("\n", 1);
123 rs = SvREFCNT_inc(nrs);
129 * There is no way we can refer to them from Perl so close them to save
130 * space. The other alternative would be to provide STDAUX and STDPRN
133 (void)fclose(stdaux);
134 (void)fclose(stdprn);
140 perl_destruct_level = 1;
142 if(perl_destruct_level > 0)
148 start_env.je_prev = NULL;
149 start_env.je_ret = -1;
150 start_env.je_mustcatch = TRUE;
151 top_env = &start_env;
154 SET_NUMERIC_STANDARD();
155 #if defined(SUBVERSION) && SUBVERSION > 0
156 sprintf(patchlevel, "%7.5f", (double) 5
157 + ((double) PATCHLEVEL / (double) 1000)
158 + ((double) SUBVERSION / (double) 100000));
160 sprintf(patchlevel, "%5.3f", (double) 5 +
161 ((double) PATCHLEVEL / (double) 1000));
164 #if defined(LOCAL_PATCH_COUNT)
165 localpatches = local_patches; /* For possible -v */
168 PerlIO_init(); /* Hook to IO system */
170 fdpid = newAV(); /* for remembering popen pids by fd */
177 perl_destruct(sv_interp)
178 register PerlInterpreter *sv_interp;
180 int destruct_level; /* 0=none, 1=full, 2=full with checks */
184 if (!(curinterp = sv_interp))
187 destruct_level = perl_destruct_level;
191 if (s = getenv("PERL_DESTRUCT_LEVEL")) {
193 if (destruct_level < i)
202 /* We must account for everything. */
204 /* Destroy the main CV and syntax tree */
206 curpad = AvARRAY(comppad);
211 SvREFCNT_dec(main_cv);
216 * Try to destruct global references. We do this first so that the
217 * destructors and destructees still exist. Some sv's might remain.
218 * Non-referenced objects are on their own.
225 /* unhook hooks which will soon be, or use, destroyed data */
226 SvREFCNT_dec(warnhook);
228 SvREFCNT_dec(diehook);
230 SvREFCNT_dec(parsehook);
233 if (destruct_level == 0){
235 DEBUG_P(debprofdump());
237 /* The exit() function will do everything that needs doing. */
241 /* loosen bonds of global variables */
244 (void)PerlIO_close(rsfp);
248 /* Filters for program text */
249 SvREFCNT_dec(rsfp_filters);
250 rsfp_filters = Nullav;
262 sawampersand = FALSE; /* must save all match strings */
263 sawstudy = FALSE; /* do fbm_instr on all strings */
278 /* magical thingies */
280 Safefree(ofs); /* $, */
283 Safefree(ors); /* $\ */
286 SvREFCNT_dec(nrs); /* $\ helper */
289 multiline = 0; /* $* */
291 SvREFCNT_dec(statname);
295 /* defgv, aka *_ should be taken care of elsewhere */
297 #if 0 /* just about all regexp stuff, seems to be ok */
299 /* shortcuts to regexp stuff */
304 SAVEFREEOP(oldlastpm); /* for saving regexp context during debugger */
306 regprecomp = NULL; /* uncompiled string. */
307 regparse = NULL; /* Input-scan pointer. */
308 regxend = NULL; /* End of input for compile */
309 regnpar = 0; /* () count. */
310 regcode = NULL; /* Code-emit pointer; ®dummy = don't. */
311 regsize = 0; /* Code size. */
312 regnaughty = 0; /* How bad is this pattern? */
313 regsawback = 0; /* Did we see \1, ...? */
315 reginput = NULL; /* String-input pointer. */
316 regbol = NULL; /* Beginning of input, for ^ check. */
317 regeol = NULL; /* End of input, for $ check. */
318 regstartp = (char **)NULL; /* Pointer to startp array. */
319 regendp = (char **)NULL; /* Ditto for endp. */
320 reglastparen = 0; /* Similarly for lastparen. */
321 regtill = NULL; /* How far we are required to go. */
322 regflags = 0; /* are we folding, multilining? */
323 regprev = (char)NULL; /* char before regbol, \n if none */
327 /* clean up after study() */
328 SvREFCNT_dec(lastscream);
330 Safefree(screamfirst);
332 Safefree(screamnext);
335 /* startup and shutdown function lists */
336 SvREFCNT_dec(beginav);
341 /* temp stack during pp_sort() */
342 SvREFCNT_dec(sortstack);
345 /* shortcuts just get cleared */
355 /* reset so print() ends up where we expect */
358 /* Prepare to destruct main symbol table. */
365 if (destruct_level >= 2) {
366 if (scopestack_ix != 0)
367 warn("Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
368 (long)scopestack_ix);
369 if (savestack_ix != 0)
370 warn("Unbalanced saves: %ld more saves than restores\n",
372 if (tmps_floor != -1)
373 warn("Unbalanced tmps: %ld more allocs than frees\n",
374 (long)tmps_floor + 1);
375 if (cxstack_ix != -1)
376 warn("Unbalanced context: %ld more PUSHes than POPs\n",
377 (long)cxstack_ix + 1);
380 /* Now absolutely destruct everything, somehow or other, loops or no. */
382 SvFLAGS(strtab) |= SVTYPEMASK; /* don't clean out strtab now */
383 while (sv_count != 0 && sv_count != last_sv_count) {
384 last_sv_count = sv_count;
387 SvFLAGS(strtab) &= ~SVTYPEMASK;
388 SvFLAGS(strtab) |= SVt_PVHV;
390 /* Destruct the global string table. */
392 /* Yell and reset the HeVAL() slots that are still holding refcounts,
393 * so that sv_free() won't fail on them.
402 array = HvARRAY(strtab);
406 warn("Unbalanced string table refcount: (%d) for \"%s\"",
407 HeVAL(hent) - Nullsv, HeKEY(hent));
408 HeVAL(hent) = Nullsv;
418 SvREFCNT_dec(strtab);
421 warn("Scalars leaked: %ld\n", (long)sv_count);
425 /* No SVs have survived, need to clean out */
429 Safefree(origfilename);
431 hints = 0; /* Reset hints. Should hints be per-interpreter ? */
433 DEBUG_P(debprofdump());
435 /* As the absolutely last thing, free the non-arena SV for mess() */
438 /* we know that type >= SVt_PV */
440 Safefree(SvPVX(mess_sv));
441 Safefree(SvANY(mess_sv));
449 PerlInterpreter *sv_interp;
451 if (!(curinterp = sv_interp))
457 perl_parse(sv_interp, xsinit, argc, argv, env)
458 PerlInterpreter *sv_interp;
459 void (*xsinit)_((void));
466 char *scriptname = NULL;
467 VOL bool dosearch = FALSE;
474 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
477 croak("suidperl is no longer needed since the kernel can now execute\n\
478 setuid perl scripts securely.\n");
482 if (!(curinterp = sv_interp))
485 #if defined(NeXT) && defined(__DYNAMIC__)
486 _dyld_lookup_and_bind
487 ("__environ", (unsigned long *) &environ_pointer, NULL);
492 #ifndef VMS /* VMS doesn't have environ array */
493 origenviron = environ;
499 /* Come here if running an undumped a.out. */
501 origfilename = savepv(argv[0]);
503 cxstack_ix = -1; /* start label stack again */
505 init_postdump_symbols(argc,argv,env);
510 curpad = AvARRAY(comppad);
515 SvREFCNT_dec(main_cv);
519 oldscope = scopestack_ix;
527 /* my_exit() was called */
528 while (scopestack_ix > oldscope)
532 call_list(oldscope, endav);
534 return STATUS_NATIVE_EXPORT;
537 PerlIO_printf(PerlIO_stderr(), "panic: top_env\n");
541 sv_setpvn(linestr,"",0);
542 sv = newSVpv("",0); /* first used for -I flags */
546 for (argc--,argv++; argc > 0; argc--,argv++) {
547 if (argv[0][0] != '-' || !argv[0][1])
551 validarg = " PHOOEY ";
576 if (s = moreswitches(s))
586 if (euid != uid || egid != gid)
587 croak("No -e allowed in setuid scripts");
589 e_tmpname = savepv(TMPPATH);
590 (void)mktemp(e_tmpname);
592 croak("Can't mktemp()");
593 e_fp = PerlIO_open(e_tmpname,"w");
595 croak("Cannot open temporary file");
600 PerlIO_puts(e_fp,argv[1]);
604 croak("No code specified for -e");
605 (void)PerlIO_putc(e_fp,'\n');
616 incpush(argv[1], TRUE);
617 sv_catpv(sv,argv[1]);
634 preambleav = newAV();
635 av_push(preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
637 Sv = newSVpv("print myconfig();",0);
639 sv_catpv(Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
641 sv_catpv(Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
643 #if defined(DEBUGGING) || defined(NO_EMBED) || defined(MULTIPLICITY)
644 sv_catpv(Sv,"\" Compile-time options:");
646 sv_catpv(Sv," DEBUGGING");
649 sv_catpv(Sv," NO_EMBED");
652 sv_catpv(Sv," MULTIPLICITY");
654 sv_catpv(Sv,"\\n\",");
656 #if defined(LOCAL_PATCH_COUNT)
657 if (LOCAL_PATCH_COUNT > 0) {
659 sv_catpv(Sv,"\" Locally applied patches:\\n\",");
660 for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
662 sv_catpvf(Sv,"\" \\t%s\\n\",",localpatches[i]);
666 sv_catpvf(Sv,"\" Built under %s\\n\"",OSNAME);
669 sv_catpvf(Sv,",\" Compiled at %s %s\\n\"",__DATE__,__TIME__);
671 sv_catpvf(Sv,",\" Compiled on %s\\n\"",__DATE__);
676 @env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; \
677 print \" \\%ENV:\\n @env\\n\" if @env; \
678 print \" \\@INC:\\n @INC\\n\";");
681 Sv = newSVpv("config_vars(qw(",0);
686 av_push(preambleav, Sv);
687 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
701 croak("Unrecognized switch: -%s",s);
706 if (!tainting && (s = getenv("PERL5OPT"))) {
717 if (!strchr("DIMUdmw", *s))
718 croak("Illegal switch in PERL5OPT: -%c", *s);
724 scriptname = argv[0];
726 if (PerlIO_flush(e_fp) || PerlIO_error(e_fp) || PerlIO_close(e_fp)) {
728 warn("Did you forget to compile with -DMULTIPLICITY?");
730 croak("Can't write to temp file for -e: %s", Strerror(errno));
734 scriptname = e_tmpname;
736 else if (scriptname == Nullch) {
738 if ( isatty(PerlIO_fileno(PerlIO_stdin())) )
746 open_script(scriptname,dosearch,sv);
748 validate_suid(validarg, scriptname);
753 main_cv = compcv = (CV*)NEWSV(1104,0);
754 sv_upgrade((SV *)compcv, SVt_PVCV);
758 av_push(comppad, Nullsv);
759 curpad = AvARRAY(comppad);
760 comppad_name = newAV();
761 comppad_name_fill = 0;
762 min_intro_pending = 0;
765 comppadlist = newAV();
766 AvREAL_off(comppadlist);
767 av_store(comppadlist, 0, (SV*)comppad_name);
768 av_store(comppadlist, 1, (SV*)comppad);
769 CvPADLIST(compcv) = comppadlist;
771 boot_core_UNIVERSAL();
773 (*xsinit)(); /* in case linked C routines want magical variables */
774 #if defined(VMS) || defined(WIN32)
778 init_predump_symbols();
780 init_postdump_symbols(argc,argv,env);
784 /* now parse the script */
787 if (yyparse() || error_count) {
789 croak("%s had compilation errors.\n", origfilename);
791 croak("Execution of %s aborted due to compilation errors.\n",
795 curcop->cop_line = 0;
799 (void)UNLINK(e_tmpname);
804 /* now that script is parsed, we can modify record separator */
806 rs = SvREFCNT_inc(nrs);
807 sv_setsv(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), rs);
819 if ((s=getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
820 dump_mstats("after compilation:");
831 PerlInterpreter *sv_interp;
837 if (!(curinterp = sv_interp))
840 oldscope = scopestack_ix;
845 cxstack_ix = -1; /* start context stack again */
848 /* my_exit() was called */
849 while (scopestack_ix > oldscope)
853 call_list(oldscope, endav);
856 if (getenv("PERL_DEBUG_MSTATS"))
857 dump_mstats("after execution: ");
860 return STATUS_NATIVE_EXPORT;
863 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
868 if (curstack != mainstack) {
870 SWITCHSTACK(curstack, mainstack);
875 DEBUG_r(PerlIO_printf(PerlIO_stderr(), "%s $` $& $' support.\n",
876 sawampersand ? "Enabling" : "Omitting"));
880 DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
883 PerlIO_printf(PerlIO_stderr(), "%s syntax OK\n", origfilename);
886 if (perldb && DBsingle)
887 sv_setiv(DBsingle, 1);
897 else if (main_start) {
898 CvDEPTH(main_cv) = 1;
909 perl_get_sv(name, create)
913 GV* gv = gv_fetchpv(name, create, SVt_PV);
920 perl_get_av(name, create)
924 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
933 perl_get_hv(name, create)
937 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
946 perl_get_cv(name, create)
950 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
951 if (create && !GvCVu(gv))
952 return newSUB(start_subparse(FALSE, 0),
953 newSVOP(OP_CONST, 0, newSVpv(name,0)),
961 /* Be sure to refetch the stack pointer after calling these routines. */
964 perl_call_argv(subname, flags, argv)
966 I32 flags; /* See G_* flags in cop.h */
967 register char **argv; /* null terminated arg list */
974 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
979 return perl_call_pv(subname, flags);
983 perl_call_pv(subname, flags)
984 char *subname; /* name of the subroutine */
985 I32 flags; /* See G_* flags in cop.h */
987 return perl_call_sv((SV*)perl_get_cv(subname, TRUE), flags);
991 perl_call_method(methname, flags)
992 char *methname; /* name of the subroutine */
993 I32 flags; /* See G_* flags in cop.h */
999 XPUSHs(sv_2mortal(newSVpv(methname,0)));
1002 return perl_call_sv(*stack_sp--, flags);
1005 /* May be called with any of a CV, a GV, or an SV containing the name. */
1007 perl_call_sv(sv, flags)
1009 I32 flags; /* See G_* flags in cop.h */
1011 LOGOP myop; /* fake syntax tree node */
1017 bool oldcatch = CATCH_GET;
1022 if (flags & G_DISCARD) {
1027 Zero(&myop, 1, LOGOP);
1028 myop.op_next = Nullop;
1029 if (!(flags & G_NOARGS))
1030 myop.op_flags |= OPf_STACKED;
1031 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1032 (flags & G_ARRAY) ? OPf_WANT_LIST :
1037 EXTEND(stack_sp, 1);
1040 oldscope = scopestack_ix;
1042 if (perldb && curstash != debstash
1043 /* Handle first BEGIN of -d. */
1044 && (DBcv || (DBcv = GvCV(DBsub)))
1045 /* Try harder, since this may have been a sighandler, thus
1046 * curstash may be meaningless. */
1047 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != debstash))
1048 op->op_private |= OPpENTERSUB_DB;
1050 if (flags & G_EVAL) {
1051 cLOGOP->op_other = op;
1053 /* we're trying to emulate pp_entertry() here */
1055 register CONTEXT *cx;
1056 I32 gimme = GIMME_V;
1061 push_return(op->op_next);
1062 PUSHBLOCK(cx, CXt_EVAL, stack_sp);
1064 eval_root = op; /* Only needed so that goto works right. */
1067 if (flags & G_KEEPERR)
1070 sv_setpv(GvSV(errgv),"");
1082 /* my_exit() was called */
1083 curstash = defstash;
1087 croak("Callback called exit");
1096 stack_sp = stack_base + oldmark;
1097 if (flags & G_ARRAY)
1101 *++stack_sp = &sv_undef;
1109 if (op == (OP*)&myop)
1113 retval = stack_sp - (stack_base + oldmark);
1114 if ((flags & G_EVAL) && !(flags & G_KEEPERR))
1115 sv_setpv(GvSV(errgv),"");
1118 if (flags & G_EVAL) {
1119 if (scopestack_ix > oldscope) {
1123 register CONTEXT *cx;
1135 CATCH_SET(oldcatch);
1137 if (flags & G_DISCARD) {
1138 stack_sp = stack_base + oldmark;
1147 /* Eval a string. The G_EVAL flag is always assumed. */
1150 perl_eval_sv(sv, flags)
1152 I32 flags; /* See G_* flags in cop.h */
1154 UNOP myop; /* fake syntax tree node */
1156 I32 oldmark = sp - stack_base;
1162 if (flags & G_DISCARD) {
1170 EXTEND(stack_sp, 1);
1172 oldscope = scopestack_ix;
1174 if (!(flags & G_NOARGS))
1175 myop.op_flags = OPf_STACKED;
1176 myop.op_next = Nullop;
1177 myop.op_type = OP_ENTEREVAL;
1178 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1179 (flags & G_ARRAY) ? OPf_WANT_LIST :
1181 if (flags & G_KEEPERR)
1182 myop.op_flags |= OPf_SPECIAL;
1192 /* my_exit() was called */
1193 curstash = defstash;
1197 croak("Callback called exit");
1206 stack_sp = stack_base + oldmark;
1207 if (flags & G_ARRAY)
1211 *++stack_sp = &sv_undef;
1216 if (op == (OP*)&myop)
1217 op = pp_entereval();
1220 retval = stack_sp - (stack_base + oldmark);
1221 if (!(flags & G_KEEPERR))
1222 sv_setpv(GvSV(errgv),"");
1226 if (flags & G_DISCARD) {
1227 stack_sp = stack_base + oldmark;
1236 perl_eval_pv(p, croak_on_error)
1241 SV* sv = newSVpv(p, 0);
1244 perl_eval_sv(sv, G_SCALAR);
1251 if (croak_on_error && SvTRUE(GvSV(errgv)))
1252 croak(SvPVx(GvSV(errgv), na));
1257 /* Require a module. */
1263 SV* sv = sv_newmortal();
1264 sv_setpv(sv, "require '");
1267 perl_eval_sv(sv, G_DISCARD);
1271 magicname(sym,name,namlen)
1278 if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
1279 sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
1283 usage(name) /* XXX move this out into a module ? */
1286 /* This message really ought to be max 23 lines.
1287 * Removed -h because the user already knows that opton. Others? */
1288 printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
1289 printf("\n -0[octal] specify record separator (\\0, if no argument)");
1290 printf("\n -a autosplit mode with -n or -p (splits $_ into @F)");
1291 printf("\n -c check syntax only (runs BEGIN and END blocks)");
1292 printf("\n -d[:debugger] run scripts under debugger");
1293 printf("\n -D[number/list] set debugging flags (argument is a bit mask or flags)");
1294 printf("\n -e 'command' one line of script. Several -e's allowed. Omit [programfile].");
1295 printf("\n -F/pattern/ split() pattern for autosplit (-a). The //'s are optional.");
1296 printf("\n -i[extension] edit <> files in place (make backup if extension supplied)");
1297 printf("\n -Idirectory specify @INC/#include directory (may be used more then once)");
1298 printf("\n -l[octal] enable line ending processing, specifies line teminator");
1299 printf("\n -[mM][-]module.. executes `use/no module...' before executing your script.");
1300 printf("\n -n assume 'while (<>) { ... }' loop arround your script");
1301 printf("\n -p assume loop like -n but print line also like sed");
1302 printf("\n -P run script through C preprocessor before compilation");
1303 printf("\n -s enable some switch parsing for switches after script name");
1304 printf("\n -S look for the script using PATH environment variable");
1305 printf("\n -T turn on tainting checks");
1306 printf("\n -u dump core after parsing script");
1307 printf("\n -U allow unsafe operations");
1308 printf("\n -v print version number and patchlevel of perl");
1309 printf("\n -V[:variable] print perl configuration information");
1310 printf("\n -w TURN WARNINGS ON FOR COMPILATION OF YOUR SCRIPT.");
1311 printf("\n -x[directory] strip off text before #!perl line and perhaps cd to directory\n");
1314 /* This routine handles any switches that can be given during run */
1325 rschar = scan_oct(s, 4, &numlen);
1327 if (rschar & ~((U8)~0))
1329 else if (!rschar && numlen >= 2)
1330 nrs = newSVpv("", 0);
1333 nrs = newSVpv(&ch, 1);
1338 splitstr = savepv(s + 1);
1352 if (*s == ':' || *s == '=') {
1353 my_setenv("PERL5DB", form("use Devel::%s;", ++s));
1364 if (isALPHA(s[1])) {
1365 static char debopts[] = "psltocPmfrxuLHXD";
1368 for (s++; *s && (d = strchr(debopts,*s)); s++)
1369 debug |= 1 << (d - debopts);
1373 for (s++; isDIGIT(*s); s++) ;
1375 debug |= 0x80000000;
1377 warn("Recompile perl with -DDEBUGGING to use -D switch\n");
1378 for (s++; isALNUM(*s); s++) ;
1388 inplace = savepv(s+1);
1390 for (s = inplace; *s && !isSPACE(*s); s++) ;
1397 for (e = s; *e && !isSPACE(*e); e++) ;
1398 p = savepvn(s, e-s);
1405 croak("No space allowed after -I");
1415 *ors = scan_oct(s, 3 + (*s == '0'), &numlen);
1424 ors = SvPV(nrs, orslen);
1425 ors = savepvn(ors, orslen);
1429 forbid_setid("-M"); /* XXX ? */
1432 forbid_setid("-m"); /* XXX ? */
1436 /* -M-foo == 'no foo' */
1437 if (*s == '-') { use = "no "; ++s; }
1438 Sv = newSVpv(use,0);
1440 /* We allow -M'Module qw(Foo Bar)' */
1441 while(isALNUM(*s) || *s==':') ++s;
1443 sv_catpv(Sv, start);
1444 if (*(start-1) == 'm') {
1446 croak("Can't use '%c' after -mname", *s);
1447 sv_catpv( Sv, " ()");
1450 sv_catpvn(Sv, start, s-start);
1451 sv_catpv(Sv, " split(/,/,q{");
1456 if (preambleav == NULL)
1457 preambleav = newAV();
1458 av_push(preambleav, Sv);
1461 croak("No space allowed after -%c", *(s-1));
1478 croak("Too late for \"-T\" option");
1490 #if defined(SUBVERSION) && SUBVERSION > 0
1491 printf("\nThis is perl, version 5.%03d_%02d", PATCHLEVEL, SUBVERSION);
1493 printf("\nThis is perl, version %s",patchlevel);
1496 printf("\n\nCopyright 1987-1997, Larry Wall\n");
1498 printf("\n\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
1501 printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n");
1504 printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
1505 "Version 5 port Copyright (c) 1994-1997, Andreas Kaiser, Ilya Zakharevich\n");
1508 printf("atariST series port, ++jrb bammi@cadence.com\n");
1511 Perl may be copied only under the terms of either the Artistic License or the\n\
1512 GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n");
1520 if (s[1] == '-') /* Additional switches on #! line. */
1528 #ifdef ALTERNATE_SHEBANG
1529 case 'S': /* OS/2 needs -S on "extproc" line. */
1537 croak("Can't emulate -%.1s on #! line",s);
1542 /* compliments of Tom Christiansen */
1544 /* unexec() can be found in the Gnu emacs distribution */
1555 prog = newSVpv(BIN_EXP);
1556 sv_catpv(prog, "/perl");
1557 file = newSVpv(origfilename);
1558 sv_catpv(file, ".perldump");
1560 status = unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
1562 PerlIO_printf(PerlIO_stderr(), "unexec of %s into %s failed!\n",
1563 SvPVX(prog), SvPVX(file));
1567 # include <lib$routines.h>
1568 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
1570 ABORT(); /* for use with undump */
1580 /* Note that strtab is a rather special HV. Assumptions are made
1581 about not iterating on it, and not adding tie magic to it.
1582 It is properly deallocated in perl_destruct() */
1584 HvSHAREKEYS_off(strtab); /* mandatory */
1585 Newz(506,((XPVHV*)SvANY(strtab))->xhv_array,
1586 sizeof(HE*) * (((XPVHV*)SvANY(strtab))->xhv_max + 1), char);
1588 curstash = defstash = newHV();
1589 curstname = newSVpv("main",4);
1590 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
1591 SvREFCNT_dec(GvHV(gv));
1592 GvHV(gv) = (HV*)SvREFCNT_inc(defstash);
1594 HvNAME(defstash) = savepv("main");
1595 incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
1597 defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
1598 errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
1600 sv_setpvn(GvSV(errgv), "", 0);
1601 curstash = defstash;
1602 compiling.cop_stash = defstash;
1603 debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
1604 /* We must init $/ before switches are processed. */
1605 sv_setpvn(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), "\n", 1);
1608 #ifdef CAN_PROTOTYPE
1610 open_script(char *scriptname, bool dosearch, SV *sv)
1613 open_script(scriptname,dosearch,sv)
1619 char *xfound = Nullch;
1620 char *xfailed = Nullch;
1624 #if defined(DOSISH) && !defined(OS2) && !defined(atarist)
1625 # define SEARCH_EXTS ".bat", ".cmd", NULL
1626 # define MAX_EXT_LEN 4
1629 # define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL
1630 # define MAX_EXT_LEN 4
1633 # define SEARCH_EXTS ".pl", ".com", NULL
1634 # define MAX_EXT_LEN 4
1636 /* additional extensions to try in each dir if scriptname not found */
1638 char *ext[] = { SEARCH_EXTS };
1639 int extidx = 0, i = 0;
1640 char *curext = Nullch;
1642 # define MAX_EXT_LEN 0
1646 * If dosearch is true and if scriptname does not contain path
1647 * delimiters, search the PATH for scriptname.
1649 * If SEARCH_EXTS is also defined, will look for each
1650 * scriptname{SEARCH_EXTS} whenever scriptname is not found
1651 * while searching the PATH.
1653 * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
1654 * proceeds as follows:
1656 * + look for ./scriptname{,.foo,.bar}
1657 * + search the PATH for scriptname{,.foo,.bar}
1660 * + look *only* in the PATH for scriptname{,.foo,.bar} (note
1661 * this will not look in '.' if it's not in the PATH)
1666 int hasdir, idx = 0, deftypes = 1;
1668 hasdir = (strpbrk(scriptname,":[</") != Nullch) ;
1669 /* The first time through, just add SEARCH_EXTS to whatever we
1670 * already have, so we can check for default file types. */
1672 (!hasdir && my_trnlnm("DCL$PATH",tokenbuf,idx++)) )
1678 if ((strlen(tokenbuf) + strlen(scriptname)
1679 + MAX_EXT_LEN) >= sizeof tokenbuf)
1680 continue; /* don't search dir with too-long name */
1681 strcat(tokenbuf, scriptname);
1685 if (strEQ(scriptname, "-"))
1687 if (dosearch) { /* Look in '.' first. */
1688 char *cur = scriptname;
1690 if ((curext = strrchr(scriptname,'.'))) /* possible current ext */
1692 if (strEQ(ext[i++],curext)) {
1693 extidx = -1; /* already has an ext */
1698 DEBUG_p(PerlIO_printf(Perl_debug_log,
1699 "Looking for %s\n",cur));
1700 if (Stat(cur,&statbuf) >= 0) {
1706 if (cur == scriptname) {
1707 len = strlen(scriptname);
1708 if (len+MAX_EXT_LEN+1 >= sizeof(tokenbuf))
1710 cur = strcpy(tokenbuf, scriptname);
1712 } while (extidx >= 0 && ext[extidx] /* try an extension? */
1713 && strcpy(tokenbuf+len, ext[extidx++]));
1717 if (dosearch && !strchr(scriptname, '/')
1719 && !strchr(scriptname, '\\')
1721 && (s = getenv("PATH"))) {
1724 bufend = s + strlen(s);
1725 while (s < bufend) {
1726 #if defined(atarist) || defined(DOSISH)
1731 && *s != ';'; len++, s++) {
1732 if (len < sizeof tokenbuf)
1735 if (len < sizeof tokenbuf)
1736 tokenbuf[len] = '\0';
1737 #else /* ! (atarist || DOSISH) */
1738 s = delimcpy(tokenbuf, tokenbuf + sizeof tokenbuf, s, bufend
1741 #endif /* ! (atarist || DOSISH) */
1744 if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tokenbuf)
1745 continue; /* don't search dir with too-long name */
1747 #if defined(atarist) || defined(DOSISH)
1748 && tokenbuf[len - 1] != '/'
1749 && tokenbuf[len - 1] != '\\'
1752 tokenbuf[len++] = '/';
1753 if (len == 2 && tokenbuf[0] == '.')
1755 (void)strcpy(tokenbuf + len, scriptname);
1759 len = strlen(tokenbuf);
1760 if (extidx > 0) /* reset after previous loop */
1764 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tokenbuf));
1765 retval = Stat(tokenbuf,&statbuf);
1767 } while ( retval < 0 /* not there */
1768 && extidx>=0 && ext[extidx] /* try an extension? */
1769 && strcpy(tokenbuf+len, ext[extidx++])
1774 if (S_ISREG(statbuf.st_mode)
1775 && cando(S_IRUSR,TRUE,&statbuf)
1777 && cando(S_IXUSR,TRUE,&statbuf)
1781 xfound = tokenbuf; /* bingo! */
1785 xfailed = savepv(tokenbuf);
1788 if (!xfound && !seen_dot && !xfailed && (Stat(scriptname,&statbuf) < 0))
1790 seen_dot = 1; /* Disable message. */
1792 croak("Can't %s %s%s%s",
1793 (xfailed ? "execute" : "find"),
1794 (xfailed ? xfailed : scriptname),
1795 (xfailed ? "" : " on PATH"),
1796 (xfailed || seen_dot) ? "" : ", '.' not in PATH");
1799 scriptname = xfound;
1802 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
1803 char *s = scriptname + 8;
1812 origfilename = savepv(e_tmpname ? "-e" : scriptname);
1813 curcop->cop_filegv = gv_fetchfile(origfilename);
1814 if (strEQ(origfilename,"-"))
1816 if (fdscript >= 0) {
1817 rsfp = PerlIO_fdopen(fdscript,"r");
1818 #if defined(HAS_FCNTL) && defined(F_SETFD)
1820 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
1823 else if (preprocess) {
1824 char *cpp_cfg = CPPSTDIN;
1825 SV *cpp = NEWSV(0,0);
1826 SV *cmd = NEWSV(0,0);
1828 if (strEQ(cpp_cfg, "cppstdin"))
1829 sv_catpvf(cpp, "%s/", BIN_EXP);
1830 sv_catpv(cpp, cpp_cfg);
1833 sv_catpv(sv,PRIVLIB_EXP);
1837 sed %s -e \"/^[^#]/b\" \
1838 -e \"/^#[ ]*include[ ]/b\" \
1839 -e \"/^#[ ]*define[ ]/b\" \
1840 -e \"/^#[ ]*if[ ]/b\" \
1841 -e \"/^#[ ]*ifdef[ ]/b\" \
1842 -e \"/^#[ ]*ifndef[ ]/b\" \
1843 -e \"/^#[ ]*else/b\" \
1844 -e \"/^#[ ]*elif[ ]/b\" \
1845 -e \"/^#[ ]*undef[ ]/b\" \
1846 -e \"/^#[ ]*endif/b\" \
1849 (doextract ? "-e \"1,/^#/d\n\"" : ""),
1852 %s %s -e '/^[^#]/b' \
1853 -e '/^#[ ]*include[ ]/b' \
1854 -e '/^#[ ]*define[ ]/b' \
1855 -e '/^#[ ]*if[ ]/b' \
1856 -e '/^#[ ]*ifdef[ ]/b' \
1857 -e '/^#[ ]*ifndef[ ]/b' \
1858 -e '/^#[ ]*else/b' \
1859 -e '/^#[ ]*elif[ ]/b' \
1860 -e '/^#[ ]*undef[ ]/b' \
1861 -e '/^#[ ]*endif/b' \
1869 (doextract ? "-e '1,/^#/d\n'" : ""),
1871 scriptname, cpp, sv, CPPMINUS);
1873 #ifdef IAMSUID /* actually, this is caught earlier */
1874 if (euid != uid && !euid) { /* if running suidperl */
1876 (void)seteuid(uid); /* musn't stay setuid root */
1879 (void)setreuid((Uid_t)-1, uid);
1881 #ifdef HAS_SETRESUID
1882 (void)setresuid((Uid_t)-1, uid, (Uid_t)-1);
1888 if (geteuid() != uid)
1889 croak("Can't do seteuid!\n");
1891 #endif /* IAMSUID */
1892 rsfp = my_popen(SvPVX(cmd), "r");
1896 else if (!*scriptname) {
1897 forbid_setid("program input from stdin");
1898 rsfp = PerlIO_stdin();
1901 rsfp = PerlIO_open(scriptname,"r");
1902 #if defined(HAS_FCNTL) && defined(F_SETFD)
1904 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
1912 #ifndef IAMSUID /* in case script is not readable before setuid */
1913 if (euid && Stat(SvPVX(GvSV(curcop->cop_filegv)),&statbuf) >= 0 &&
1914 statbuf.st_mode & (S_ISUID|S_ISGID)) {
1916 execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
1917 croak("Can't do setuid\n");
1921 croak("Can't open perl script \"%s\": %s\n",
1922 SvPVX(GvSV(curcop->cop_filegv)), Strerror(errno));
1927 validate_suid(validarg, scriptname)
1933 /* do we need to emulate setuid on scripts? */
1935 /* This code is for those BSD systems that have setuid #! scripts disabled
1936 * in the kernel because of a security problem. Merely defining DOSUID
1937 * in perl will not fix that problem, but if you have disabled setuid
1938 * scripts in the kernel, this will attempt to emulate setuid and setgid
1939 * on scripts that have those now-otherwise-useless bits set. The setuid
1940 * root version must be called suidperl or sperlN.NNN. If regular perl
1941 * discovers that it has opened a setuid script, it calls suidperl with
1942 * the same argv that it had. If suidperl finds that the script it has
1943 * just opened is NOT setuid root, it sets the effective uid back to the
1944 * uid. We don't just make perl setuid root because that loses the
1945 * effective uid we had before invoking perl, if it was different from the
1948 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
1949 * be defined in suidperl only. suidperl must be setuid root. The
1950 * Configure script will set this up for you if you want it.
1956 if (Fstat(PerlIO_fileno(rsfp),&statbuf) < 0) /* normal stat is insecure */
1957 croak("Can't stat script \"%s\"",origfilename);
1958 if (fdscript < 0 && statbuf.st_mode & (S_ISUID|S_ISGID)) {
1962 #ifndef HAS_SETREUID
1963 /* On this access check to make sure the directories are readable,
1964 * there is actually a small window that the user could use to make
1965 * filename point to an accessible directory. So there is a faint
1966 * chance that someone could execute a setuid script down in a
1967 * non-accessible directory. I don't know what to do about that.
1968 * But I don't think it's too important. The manual lies when
1969 * it says access() is useful in setuid programs.
1971 if (access(SvPVX(GvSV(curcop->cop_filegv)),1)) /*double check*/
1972 croak("Permission denied");
1974 /* If we can swap euid and uid, then we can determine access rights
1975 * with a simple stat of the file, and then compare device and
1976 * inode to make sure we did stat() on the same file we opened.
1977 * Then we just have to make sure he or she can execute it.
1980 struct stat tmpstatbuf;
1984 setreuid(euid,uid) < 0
1987 setresuid(euid,uid,(Uid_t)-1) < 0
1990 || getuid() != euid || geteuid() != uid)
1991 croak("Can't swap uid and euid"); /* really paranoid */
1992 if (Stat(SvPVX(GvSV(curcop->cop_filegv)),&tmpstatbuf) < 0)
1993 croak("Permission denied"); /* testing full pathname here */
1994 if (tmpstatbuf.st_dev != statbuf.st_dev ||
1995 tmpstatbuf.st_ino != statbuf.st_ino) {
1996 (void)PerlIO_close(rsfp);
1997 if (rsfp = my_popen("/bin/mail root","w")) { /* heh, heh */
1999 "User %ld tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
2000 (Filename of set-id script was %s, uid %ld gid %ld.)\n\nSincerely,\nperl\n",
2001 (long)uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
2002 (long)statbuf.st_dev, (long)statbuf.st_ino,
2003 SvPVX(GvSV(curcop->cop_filegv)),
2004 (long)statbuf.st_uid, (long)statbuf.st_gid);
2005 (void)my_pclose(rsfp);
2007 croak("Permission denied\n");
2011 setreuid(uid,euid) < 0
2013 # if defined(HAS_SETRESUID)
2014 setresuid(uid,euid,(Uid_t)-1) < 0
2017 || getuid() != uid || geteuid() != euid)
2018 croak("Can't reswap uid and euid");
2019 if (!cando(S_IXUSR,FALSE,&statbuf)) /* can real uid exec? */
2020 croak("Permission denied\n");
2022 #endif /* HAS_SETREUID */
2023 #endif /* IAMSUID */
2025 if (!S_ISREG(statbuf.st_mode))
2026 croak("Permission denied");
2027 if (statbuf.st_mode & S_IWOTH)
2028 croak("Setuid/gid script is writable by world");
2029 doswitches = FALSE; /* -s is insecure in suid */
2031 if (sv_gets(linestr, rsfp, 0) == Nullch ||
2032 strnNE(SvPV(linestr,na),"#!",2) ) /* required even on Sys V */
2033 croak("No #! line");
2034 s = SvPV(linestr,na)+2;
2036 while (!isSPACE(*s)) s++;
2037 for (s2 = s; (s2 > SvPV(linestr,na)+2 &&
2038 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
2039 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
2040 croak("Not a perl script");
2041 while (*s == ' ' || *s == '\t') s++;
2043 * #! arg must be what we saw above. They can invoke it by
2044 * mentioning suidperl explicitly, but they may not add any strange
2045 * arguments beyond what #! says if they do invoke suidperl that way.
2047 len = strlen(validarg);
2048 if (strEQ(validarg," PHOOEY ") ||
2049 strnNE(s,validarg,len) || !isSPACE(s[len]))
2050 croak("Args must match #! line");
2053 if (euid != uid && (statbuf.st_mode & S_ISUID) &&
2054 euid == statbuf.st_uid)
2056 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2057 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2058 #endif /* IAMSUID */
2060 if (euid) { /* oops, we're not the setuid root perl */
2061 (void)PerlIO_close(rsfp);
2064 execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
2066 croak("Can't do setuid\n");
2069 if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid) {
2071 (void)setegid(statbuf.st_gid);
2074 (void)setregid((Gid_t)-1,statbuf.st_gid);
2076 #ifdef HAS_SETRESGID
2077 (void)setresgid((Gid_t)-1,statbuf.st_gid,(Gid_t)-1);
2079 setgid(statbuf.st_gid);
2083 if (getegid() != statbuf.st_gid)
2084 croak("Can't do setegid!\n");
2086 if (statbuf.st_mode & S_ISUID) {
2087 if (statbuf.st_uid != euid)
2089 (void)seteuid(statbuf.st_uid); /* all that for this */
2092 (void)setreuid((Uid_t)-1,statbuf.st_uid);
2094 #ifdef HAS_SETRESUID
2095 (void)setresuid((Uid_t)-1,statbuf.st_uid,(Uid_t)-1);
2097 setuid(statbuf.st_uid);
2101 if (geteuid() != statbuf.st_uid)
2102 croak("Can't do seteuid!\n");
2104 else if (uid) { /* oops, mustn't run as root */
2106 (void)seteuid((Uid_t)uid);
2109 (void)setreuid((Uid_t)-1,(Uid_t)uid);
2111 #ifdef HAS_SETRESUID
2112 (void)setresuid((Uid_t)-1,(Uid_t)uid,(Uid_t)-1);
2118 if (geteuid() != uid)
2119 croak("Can't do seteuid!\n");
2122 if (!cando(S_IXUSR,TRUE,&statbuf))
2123 croak("Permission denied\n"); /* they can't do this */
2126 else if (preprocess)
2127 croak("-P not allowed for setuid/setgid script\n");
2128 else if (fdscript >= 0)
2129 croak("fd script not allowed in suidperl\n");
2131 croak("Script is not setuid/setgid in suidperl\n");
2133 /* We absolutely must clear out any saved ids here, so we */
2134 /* exec the real perl, substituting fd script for scriptname. */
2135 /* (We pass script name as "subdir" of fd, which perl will grok.) */
2136 PerlIO_rewind(rsfp);
2137 lseek(PerlIO_fileno(rsfp),(Off_t)0,0); /* just in case rewind didn't */
2138 for (which = 1; origargv[which] && origargv[which] != scriptname; which++) ;
2139 if (!origargv[which])
2140 croak("Permission denied");
2141 origargv[which] = savepv(form("/dev/fd/%d/%s",
2142 PerlIO_fileno(rsfp), origargv[which]));
2143 #if defined(HAS_FCNTL) && defined(F_SETFD)
2144 fcntl(PerlIO_fileno(rsfp),F_SETFD,0); /* ensure no close-on-exec */
2146 execv(form("%s/perl%s", BIN_EXP, patchlevel), origargv); /* try again */
2147 croak("Can't do setuid\n");
2148 #endif /* IAMSUID */
2150 if (euid != uid || egid != gid) { /* (suidperl doesn't exist, in fact) */
2151 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
2152 Fstat(PerlIO_fileno(rsfp),&statbuf); /* may be either wrapped or real suid */
2153 if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
2155 (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
2158 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2159 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2160 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
2161 /* not set-id, must be wrapped */
2169 register char *s, *s2;
2171 /* skip forward in input to the real script? */
2175 if ((s = sv_gets(linestr, rsfp, 0)) == Nullch)
2176 croak("No Perl script found in input\n");
2177 if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
2178 PerlIO_ungetc(rsfp, '\n'); /* to keep line count right */
2180 while (*s && !(isSPACE (*s) || *s == '#')) s++;
2182 while (*s == ' ' || *s == '\t') s++;
2184 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
2185 if (strnEQ(s2-4,"perl",4))
2187 while (s = moreswitches(s)) ;
2189 if (cddir && chdir(cddir) < 0)
2190 croak("Can't chdir to %s",cddir);
2198 uid = (int)getuid();
2199 euid = (int)geteuid();
2200 gid = (int)getgid();
2201 egid = (int)getegid();
2206 tainting |= (uid && (euid != uid || egid != gid));
2214 croak("No %s allowed while running setuid", s);
2216 croak("No %s allowed while running setgid", s);
2222 curstash = debstash;
2223 dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
2225 DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
2226 DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
2227 DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
2228 DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
2229 sv_setiv(DBsingle, 0);
2230 DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
2231 sv_setiv(DBtrace, 0);
2232 DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
2233 sv_setiv(DBsignal, 0);
2234 curstash = defstash;
2241 mainstack = curstack; /* remember in case we switch stacks */
2242 AvREAL_off(curstack); /* not a real array */
2243 av_extend(curstack,127);
2245 stack_base = AvARRAY(curstack);
2246 stack_sp = stack_base;
2247 stack_max = stack_base + 127;
2249 cxstack_max = 8192 / sizeof(CONTEXT) - 2; /* Use most of 8K. */
2250 New(50,cxstack,cxstack_max + 1,CONTEXT);
2253 New(50,tmps_stack,128,SV*);
2258 New(51,debname,128,char);
2259 New(52,debdelim,128,char);
2263 * The following stacks almost certainly should be per-interpreter,
2264 * but for now they're not. XXX
2268 markstack_ptr = markstack;
2270 New(54,markstack,64,I32);
2271 markstack_ptr = markstack;
2272 markstack_max = markstack + 64;
2278 New(54,scopestack,32,I32);
2280 scopestack_max = 32;
2286 New(54,savestack,128,ANY);
2288 savestack_max = 128;
2294 New(54,retstack,16,OP*);
2304 Safefree(tmps_stack);
2311 static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
2319 subname = newSVpv("main",4);
2323 init_predump_symbols()
2328 sv_setpvn(GvSV(gv_fetchpv("\"", TRUE, SVt_PV)), " ", 1);
2330 stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
2331 GvMULTI_on(stdingv);
2332 IoIFP(GvIOp(stdingv)) = PerlIO_stdin();
2333 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
2335 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(stdingv));
2337 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
2339 IoOFP(GvIOp(tmpgv)) = IoIFP(GvIOp(tmpgv)) = PerlIO_stdout();
2341 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
2343 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(defoutgv));
2345 othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
2346 GvMULTI_on(othergv);
2347 IoOFP(GvIOp(othergv)) = IoIFP(GvIOp(othergv)) = PerlIO_stderr();
2348 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
2350 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(othergv));
2352 statname = NEWSV(66,0); /* last filename we did stat on */
2355 osname = savepv(OSNAME);
2359 init_postdump_symbols(argc,argv,env)
2361 register char **argv;
2362 register char **env;
2368 argc--,argv++; /* skip name of script */
2370 for (; argc > 0 && **argv == '-'; argc--,argv++) {
2373 if (argv[0][1] == '-') {
2377 if (s = strchr(argv[0], '=')) {
2379 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
2382 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
2385 toptarget = NEWSV(0,0);
2386 sv_upgrade(toptarget, SVt_PVFM);
2387 sv_setpvn(toptarget, "", 0);
2388 bodytarget = NEWSV(0,0);
2389 sv_upgrade(bodytarget, SVt_PVFM);
2390 sv_setpvn(bodytarget, "", 0);
2391 formtarget = bodytarget;
2394 if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
2395 sv_setpv(GvSV(tmpgv),origfilename);
2396 magicname("0", "0", 1);
2398 if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
2399 sv_setpv(GvSV(tmpgv),origargv[0]);
2400 if (argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
2402 (void)gv_AVadd(argvgv);
2403 av_clear(GvAVn(argvgv));
2404 for (; argc > 0; argc--,argv++) {
2405 av_push(GvAVn(argvgv),newSVpv(argv[0],0));
2408 if (envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
2412 hv_magic(hv, envgv, 'E');
2413 #ifndef VMS /* VMS doesn't have environ array */
2414 /* Note that if the supplied env parameter is actually a copy
2415 of the global environ then it may now point to free'd memory
2416 if the environment has been modified since. To avoid this
2417 problem we treat env==NULL as meaning 'use the default'
2422 environ[0] = Nullch;
2423 for (; *env; env++) {
2424 if (!(s = strchr(*env,'=')))
2430 sv = newSVpv(s--,0);
2431 (void)hv_store(hv, *env, s - *env, sv, 0);
2433 #if defined(__BORLANDC__) && defined(USE_WIN32_RTL_ENV)
2434 /* Sins of the RTL. See note in my_setenv(). */
2435 (void)putenv(savepv(*env));
2439 #ifdef DYNAMIC_ENV_FETCH
2440 HvNAME(hv) = savepv(ENV_HV_NAME);
2444 if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
2445 sv_setiv(GvSV(tmpgv), (IV)getpid());
2454 s = getenv("PERL5LIB");
2458 incpush(getenv("PERLLIB"), FALSE);
2460 /* Treat PERL5?LIB as a possible search list logical name -- the
2461 * "natural" VMS idiom for a Unix path string. We allow each
2462 * element to be a set of |-separated directories for compatibility.
2466 if (my_trnlnm("PERL5LIB",buf,0))
2467 do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
2469 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE);
2473 /* Use the ~-expanded versions of APPLLIB (undocumented),
2474 ARCHLIB PRIVLIB SITEARCH SITELIB and OLDARCHLIB
2477 incpush(APPLLIB_EXP, FALSE);
2481 incpush(ARCHLIB_EXP, FALSE);
2484 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
2486 incpush(PRIVLIB_EXP, FALSE);
2489 incpush(SITEARCH_EXP, FALSE);
2492 incpush(SITELIB_EXP, FALSE);
2494 #ifdef OLDARCHLIB_EXP /* 5.00[01] compatibility */
2495 incpush(OLDARCHLIB_EXP, FALSE);
2499 incpush(".", FALSE);
2503 # define PERLLIB_SEP ';'
2506 # define PERLLIB_SEP '|'
2508 # define PERLLIB_SEP ':'
2511 #ifndef PERLLIB_MANGLE
2512 # define PERLLIB_MANGLE(s,n) (s)
2516 incpush(p, addsubdirs)
2520 SV *subdir = Nullsv;
2521 static char *archpat_auto;
2528 if (!archpat_auto) {
2529 STRLEN len = (sizeof(ARCHNAME) + strlen(patchlevel)
2530 + sizeof("//auto"));
2531 New(55, archpat_auto, len, char);
2532 sprintf(archpat_auto, "/%s/%s/auto", ARCHNAME, patchlevel);
2534 for (len = sizeof(ARCHNAME) + 2;
2535 archpat_auto[len] != '\0' && archpat_auto[len] != '/'; len++)
2536 if (archpat_auto[len] == '.') archpat_auto[len] = '_';
2541 /* Break at all separators */
2543 SV *libdir = newSV(0);
2546 /* skip any consecutive separators */
2547 while ( *p == PERLLIB_SEP ) {
2548 /* Uncomment the next line for PATH semantics */
2549 /* av_push(GvAVn(incgv), newSVpv(".", 1)); */
2553 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
2554 sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
2559 sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
2560 p = Nullch; /* break out */
2564 * BEFORE pushing libdir onto @INC we may first push version- and
2565 * archname-specific sub-directories.
2568 struct stat tmpstatbuf;
2573 if ((unix = tounixspec_ts(SvPV(libdir,na),Nullch)) != Nullch) {
2575 while (unix[len-1] == '/') len--; /* Cosmetic */
2576 sv_usepvn(libdir,unix,len);
2579 PerlIO_printf(PerlIO_stderr(),
2580 "Failed to unixify @INC element \"%s\"\n",
2583 /* .../archname/version if -d .../archname/version/auto */
2584 sv_setsv(subdir, libdir);
2585 sv_catpv(subdir, archpat_auto);
2586 if (Stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2587 S_ISDIR(tmpstatbuf.st_mode))
2588 av_push(GvAVn(incgv),
2589 newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2591 /* .../archname if -d .../archname/auto */
2592 sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME),
2593 strlen(patchlevel) + 1, "", 0);
2594 if (Stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2595 S_ISDIR(tmpstatbuf.st_mode))
2596 av_push(GvAVn(incgv),
2597 newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2600 /* finally push this lib directory on the end of @INC */
2601 av_push(GvAVn(incgv), libdir);
2604 SvREFCNT_dec(subdir);
2608 call_list(oldscope, list)
2612 line_t oldline = curcop->cop_line;
2617 while (AvFILL(list) >= 0) {
2618 CV *cv = (CV*)av_shift(list);
2625 SV* atsv = GvSV(errgv);
2627 perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
2628 (void)SvPV(atsv, len);
2631 curcop = &compiling;
2632 curcop->cop_line = oldline;
2633 if (list == beginav)
2634 sv_catpv(atsv, "BEGIN failed--compilation aborted");
2636 sv_catpv(atsv, "END failed--cleanup aborted");
2637 while (scopestack_ix > oldscope)
2639 croak("%s", SvPVX(atsv));
2647 /* my_exit() was called */
2648 while (scopestack_ix > oldscope)
2650 curstash = defstash;
2652 call_list(oldscope, endav);
2655 curcop = &compiling;
2656 curcop->cop_line = oldline;
2658 if (list == beginav)
2659 croak("BEGIN failed--compilation aborted");
2661 croak("END failed--cleanup aborted");
2667 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
2672 curcop = &compiling;
2673 curcop->cop_line = oldline;
2692 STATUS_NATIVE_SET(status);
2702 if (vaxc$errno & 1) {
2703 if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
2704 STATUS_NATIVE_SET(44);
2707 if (!vaxc$errno && errno) /* unlikely */
2708 STATUS_NATIVE_SET(44);
2710 STATUS_NATIVE_SET(vaxc$errno);
2714 STATUS_POSIX_SET(errno);
2715 else if (STATUS_POSIX == 0)
2716 STATUS_POSIX_SET(255);
2724 register CONTEXT *cx;
2733 (void)UNLINK(e_tmpname);
2734 Safefree(e_tmpname);
2738 if (cxstack_ix >= 0) {