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 ".pl", ".com", NULL
1630 # define MAX_EXT_LEN 4
1632 /* additional extensions to try in each dir if scriptname not found */
1634 char *ext[] = { SEARCH_EXTS };
1635 int extidx = 0, i = 0;
1636 char *curext = Nullch;
1638 # define MAX_EXT_LEN 0
1642 * If dosearch is true and if scriptname does not contain path
1643 * delimiters, search the PATH for scriptname.
1645 * If SEARCH_EXTS is also defined, will look for each
1646 * scriptname{SEARCH_EXTS} whenever scriptname is not found
1647 * while searching the PATH.
1649 * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
1650 * proceeds as follows:
1652 * + look for ./scriptname{,.foo,.bar}
1653 * + search the PATH for scriptname{,.foo,.bar}
1656 * + look *only* in the PATH for scriptname{,.foo,.bar} (note
1657 * this will not look in '.' if it's not in the PATH)
1662 int hasdir, idx = 0, deftypes = 1;
1664 hasdir = (strpbrk(scriptname,":[</") != Nullch) ;
1665 /* The first time through, just add SEARCH_EXTS to whatever we
1666 * already have, so we can check for default file types. */
1668 (!hasdir && my_trnlnm("DCL$PATH",tokenbuf,idx++)) )
1674 if ((strlen(tokenbuf) + strlen(scriptname)
1675 + MAX_EXT_LEN) >= sizeof tokenbuf)
1676 continue; /* don't search dir with too-long name */
1677 strcat(tokenbuf, scriptname);
1681 if (strEQ(scriptname, "-"))
1683 if (dosearch) { /* Look in '.' first. */
1684 char *cur = scriptname;
1686 if ((curext = strrchr(scriptname,'.'))) /* possible current ext */
1688 if (strEQ(ext[i++],curext)) {
1689 extidx = -1; /* already has an ext */
1694 DEBUG_p(PerlIO_printf(Perl_debug_log,
1695 "Looking for %s\n",cur));
1696 if (Stat(cur,&statbuf) >= 0) {
1702 if (cur == scriptname) {
1703 len = strlen(scriptname);
1704 if (len+MAX_EXT_LEN+1 >= sizeof(tokenbuf))
1706 cur = strcpy(tokenbuf, scriptname);
1708 } while (extidx >= 0 && ext[extidx] /* try an extension? */
1709 && strcpy(tokenbuf+len, ext[extidx++]));
1713 if (dosearch && !strchr(scriptname, '/')
1715 && !strchr(scriptname, '\\')
1717 && (s = getenv("PATH"))) {
1720 bufend = s + strlen(s);
1721 while (s < bufend) {
1722 #if defined(atarist) || defined(DOSISH)
1727 && *s != ';'; len++, s++) {
1728 if (len < sizeof tokenbuf)
1731 if (len < sizeof tokenbuf)
1732 tokenbuf[len] = '\0';
1733 #else /* ! (atarist || DOSISH) */
1734 s = delimcpy(tokenbuf, tokenbuf + sizeof tokenbuf, s, bufend
1737 #endif /* ! (atarist || DOSISH) */
1740 if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tokenbuf)
1741 continue; /* don't search dir with too-long name */
1743 #if defined(atarist) || defined(DOSISH)
1744 && tokenbuf[len - 1] != '/'
1745 && tokenbuf[len - 1] != '\\'
1748 tokenbuf[len++] = '/';
1749 if (len == 2 && tokenbuf[0] == '.')
1751 (void)strcpy(tokenbuf + len, scriptname);
1755 len = strlen(tokenbuf);
1756 if (extidx > 0) /* reset after previous loop */
1760 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tokenbuf));
1761 retval = Stat(tokenbuf,&statbuf);
1763 } while ( retval < 0 /* not there */
1764 && extidx>=0 && ext[extidx] /* try an extension? */
1765 && strcpy(tokenbuf+len, ext[extidx++])
1770 if (S_ISREG(statbuf.st_mode)
1771 && cando(S_IRUSR,TRUE,&statbuf)
1773 && cando(S_IXUSR,TRUE,&statbuf)
1777 xfound = tokenbuf; /* bingo! */
1781 xfailed = savepv(tokenbuf);
1784 if (!xfound && !seen_dot && !xfailed && (Stat(scriptname,&statbuf) < 0))
1786 seen_dot = 1; /* Disable message. */
1788 croak("Can't %s %s%s%s",
1789 (xfailed ? "execute" : "find"),
1790 (xfailed ? xfailed : scriptname),
1791 (xfailed ? "" : " on PATH"),
1792 (xfailed || seen_dot) ? "" : ", '.' not in PATH");
1795 scriptname = xfound;
1798 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
1799 char *s = scriptname + 8;
1808 origfilename = savepv(e_tmpname ? "-e" : scriptname);
1809 curcop->cop_filegv = gv_fetchfile(origfilename);
1810 if (strEQ(origfilename,"-"))
1812 if (fdscript >= 0) {
1813 rsfp = PerlIO_fdopen(fdscript,"r");
1814 #if defined(HAS_FCNTL) && defined(F_SETFD)
1816 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
1819 else if (preprocess) {
1820 char *cpp_cfg = CPPSTDIN;
1821 SV *cpp = NEWSV(0,0);
1822 SV *cmd = NEWSV(0,0);
1824 if (strEQ(cpp_cfg, "cppstdin"))
1825 sv_catpvf(cpp, "%s/", BIN_EXP);
1826 sv_catpv(cpp, cpp_cfg);
1829 sv_catpv(sv,PRIVLIB_EXP);
1833 sed %s -e \"/^[^#]/b\" \
1834 -e \"/^#[ ]*include[ ]/b\" \
1835 -e \"/^#[ ]*define[ ]/b\" \
1836 -e \"/^#[ ]*if[ ]/b\" \
1837 -e \"/^#[ ]*ifdef[ ]/b\" \
1838 -e \"/^#[ ]*ifndef[ ]/b\" \
1839 -e \"/^#[ ]*else/b\" \
1840 -e \"/^#[ ]*elif[ ]/b\" \
1841 -e \"/^#[ ]*undef[ ]/b\" \
1842 -e \"/^#[ ]*endif/b\" \
1845 (doextract ? "-e \"1,/^#/d\n\"" : ""),
1848 %s %s -e '/^[^#]/b' \
1849 -e '/^#[ ]*include[ ]/b' \
1850 -e '/^#[ ]*define[ ]/b' \
1851 -e '/^#[ ]*if[ ]/b' \
1852 -e '/^#[ ]*ifdef[ ]/b' \
1853 -e '/^#[ ]*ifndef[ ]/b' \
1854 -e '/^#[ ]*else/b' \
1855 -e '/^#[ ]*elif[ ]/b' \
1856 -e '/^#[ ]*undef[ ]/b' \
1857 -e '/^#[ ]*endif/b' \
1865 (doextract ? "-e '1,/^#/d\n'" : ""),
1867 scriptname, cpp, sv, CPPMINUS);
1869 #ifdef IAMSUID /* actually, this is caught earlier */
1870 if (euid != uid && !euid) { /* if running suidperl */
1872 (void)seteuid(uid); /* musn't stay setuid root */
1875 (void)setreuid((Uid_t)-1, uid);
1877 #ifdef HAS_SETRESUID
1878 (void)setresuid((Uid_t)-1, uid, (Uid_t)-1);
1884 if (geteuid() != uid)
1885 croak("Can't do seteuid!\n");
1887 #endif /* IAMSUID */
1888 rsfp = my_popen(SvPVX(cmd), "r");
1892 else if (!*scriptname) {
1893 forbid_setid("program input from stdin");
1894 rsfp = PerlIO_stdin();
1897 rsfp = PerlIO_open(scriptname,"r");
1898 #if defined(HAS_FCNTL) && defined(F_SETFD)
1900 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
1908 #ifndef IAMSUID /* in case script is not readable before setuid */
1909 if (euid && Stat(SvPVX(GvSV(curcop->cop_filegv)),&statbuf) >= 0 &&
1910 statbuf.st_mode & (S_ISUID|S_ISGID)) {
1912 execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
1913 croak("Can't do setuid\n");
1917 croak("Can't open perl script \"%s\": %s\n",
1918 SvPVX(GvSV(curcop->cop_filegv)), Strerror(errno));
1923 validate_suid(validarg, scriptname)
1929 /* do we need to emulate setuid on scripts? */
1931 /* This code is for those BSD systems that have setuid #! scripts disabled
1932 * in the kernel because of a security problem. Merely defining DOSUID
1933 * in perl will not fix that problem, but if you have disabled setuid
1934 * scripts in the kernel, this will attempt to emulate setuid and setgid
1935 * on scripts that have those now-otherwise-useless bits set. The setuid
1936 * root version must be called suidperl or sperlN.NNN. If regular perl
1937 * discovers that it has opened a setuid script, it calls suidperl with
1938 * the same argv that it had. If suidperl finds that the script it has
1939 * just opened is NOT setuid root, it sets the effective uid back to the
1940 * uid. We don't just make perl setuid root because that loses the
1941 * effective uid we had before invoking perl, if it was different from the
1944 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
1945 * be defined in suidperl only. suidperl must be setuid root. The
1946 * Configure script will set this up for you if you want it.
1952 if (Fstat(PerlIO_fileno(rsfp),&statbuf) < 0) /* normal stat is insecure */
1953 croak("Can't stat script \"%s\"",origfilename);
1954 if (fdscript < 0 && statbuf.st_mode & (S_ISUID|S_ISGID)) {
1958 #ifndef HAS_SETREUID
1959 /* On this access check to make sure the directories are readable,
1960 * there is actually a small window that the user could use to make
1961 * filename point to an accessible directory. So there is a faint
1962 * chance that someone could execute a setuid script down in a
1963 * non-accessible directory. I don't know what to do about that.
1964 * But I don't think it's too important. The manual lies when
1965 * it says access() is useful in setuid programs.
1967 if (access(SvPVX(GvSV(curcop->cop_filegv)),1)) /*double check*/
1968 croak("Permission denied");
1970 /* If we can swap euid and uid, then we can determine access rights
1971 * with a simple stat of the file, and then compare device and
1972 * inode to make sure we did stat() on the same file we opened.
1973 * Then we just have to make sure he or she can execute it.
1976 struct stat tmpstatbuf;
1980 setreuid(euid,uid) < 0
1983 setresuid(euid,uid,(Uid_t)-1) < 0
1986 || getuid() != euid || geteuid() != uid)
1987 croak("Can't swap uid and euid"); /* really paranoid */
1988 if (Stat(SvPVX(GvSV(curcop->cop_filegv)),&tmpstatbuf) < 0)
1989 croak("Permission denied"); /* testing full pathname here */
1990 if (tmpstatbuf.st_dev != statbuf.st_dev ||
1991 tmpstatbuf.st_ino != statbuf.st_ino) {
1992 (void)PerlIO_close(rsfp);
1993 if (rsfp = my_popen("/bin/mail root","w")) { /* heh, heh */
1995 "User %ld tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
1996 (Filename of set-id script was %s, uid %ld gid %ld.)\n\nSincerely,\nperl\n",
1997 (long)uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
1998 (long)statbuf.st_dev, (long)statbuf.st_ino,
1999 SvPVX(GvSV(curcop->cop_filegv)),
2000 (long)statbuf.st_uid, (long)statbuf.st_gid);
2001 (void)my_pclose(rsfp);
2003 croak("Permission denied\n");
2007 setreuid(uid,euid) < 0
2009 # if defined(HAS_SETRESUID)
2010 setresuid(uid,euid,(Uid_t)-1) < 0
2013 || getuid() != uid || geteuid() != euid)
2014 croak("Can't reswap uid and euid");
2015 if (!cando(S_IXUSR,FALSE,&statbuf)) /* can real uid exec? */
2016 croak("Permission denied\n");
2018 #endif /* HAS_SETREUID */
2019 #endif /* IAMSUID */
2021 if (!S_ISREG(statbuf.st_mode))
2022 croak("Permission denied");
2023 if (statbuf.st_mode & S_IWOTH)
2024 croak("Setuid/gid script is writable by world");
2025 doswitches = FALSE; /* -s is insecure in suid */
2027 if (sv_gets(linestr, rsfp, 0) == Nullch ||
2028 strnNE(SvPV(linestr,na),"#!",2) ) /* required even on Sys V */
2029 croak("No #! line");
2030 s = SvPV(linestr,na)+2;
2032 while (!isSPACE(*s)) s++;
2033 for (s2 = s; (s2 > SvPV(linestr,na)+2 &&
2034 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
2035 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
2036 croak("Not a perl script");
2037 while (*s == ' ' || *s == '\t') s++;
2039 * #! arg must be what we saw above. They can invoke it by
2040 * mentioning suidperl explicitly, but they may not add any strange
2041 * arguments beyond what #! says if they do invoke suidperl that way.
2043 len = strlen(validarg);
2044 if (strEQ(validarg," PHOOEY ") ||
2045 strnNE(s,validarg,len) || !isSPACE(s[len]))
2046 croak("Args must match #! line");
2049 if (euid != uid && (statbuf.st_mode & S_ISUID) &&
2050 euid == statbuf.st_uid)
2052 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2053 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2054 #endif /* IAMSUID */
2056 if (euid) { /* oops, we're not the setuid root perl */
2057 (void)PerlIO_close(rsfp);
2060 execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
2062 croak("Can't do setuid\n");
2065 if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid) {
2067 (void)setegid(statbuf.st_gid);
2070 (void)setregid((Gid_t)-1,statbuf.st_gid);
2072 #ifdef HAS_SETRESGID
2073 (void)setresgid((Gid_t)-1,statbuf.st_gid,(Gid_t)-1);
2075 setgid(statbuf.st_gid);
2079 if (getegid() != statbuf.st_gid)
2080 croak("Can't do setegid!\n");
2082 if (statbuf.st_mode & S_ISUID) {
2083 if (statbuf.st_uid != euid)
2085 (void)seteuid(statbuf.st_uid); /* all that for this */
2088 (void)setreuid((Uid_t)-1,statbuf.st_uid);
2090 #ifdef HAS_SETRESUID
2091 (void)setresuid((Uid_t)-1,statbuf.st_uid,(Uid_t)-1);
2093 setuid(statbuf.st_uid);
2097 if (geteuid() != statbuf.st_uid)
2098 croak("Can't do seteuid!\n");
2100 else if (uid) { /* oops, mustn't run as root */
2102 (void)seteuid((Uid_t)uid);
2105 (void)setreuid((Uid_t)-1,(Uid_t)uid);
2107 #ifdef HAS_SETRESUID
2108 (void)setresuid((Uid_t)-1,(Uid_t)uid,(Uid_t)-1);
2114 if (geteuid() != uid)
2115 croak("Can't do seteuid!\n");
2118 if (!cando(S_IXUSR,TRUE,&statbuf))
2119 croak("Permission denied\n"); /* they can't do this */
2122 else if (preprocess)
2123 croak("-P not allowed for setuid/setgid script\n");
2124 else if (fdscript >= 0)
2125 croak("fd script not allowed in suidperl\n");
2127 croak("Script is not setuid/setgid in suidperl\n");
2129 /* We absolutely must clear out any saved ids here, so we */
2130 /* exec the real perl, substituting fd script for scriptname. */
2131 /* (We pass script name as "subdir" of fd, which perl will grok.) */
2132 PerlIO_rewind(rsfp);
2133 lseek(PerlIO_fileno(rsfp),(Off_t)0,0); /* just in case rewind didn't */
2134 for (which = 1; origargv[which] && origargv[which] != scriptname; which++) ;
2135 if (!origargv[which])
2136 croak("Permission denied");
2137 origargv[which] = savepv(form("/dev/fd/%d/%s",
2138 PerlIO_fileno(rsfp), origargv[which]));
2139 #if defined(HAS_FCNTL) && defined(F_SETFD)
2140 fcntl(PerlIO_fileno(rsfp),F_SETFD,0); /* ensure no close-on-exec */
2142 execv(form("%s/perl%s", BIN_EXP, patchlevel), origargv); /* try again */
2143 croak("Can't do setuid\n");
2144 #endif /* IAMSUID */
2146 if (euid != uid || egid != gid) { /* (suidperl doesn't exist, in fact) */
2147 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
2148 Fstat(PerlIO_fileno(rsfp),&statbuf); /* may be either wrapped or real suid */
2149 if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
2151 (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
2154 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2155 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2156 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
2157 /* not set-id, must be wrapped */
2165 register char *s, *s2;
2167 /* skip forward in input to the real script? */
2171 if ((s = sv_gets(linestr, rsfp, 0)) == Nullch)
2172 croak("No Perl script found in input\n");
2173 if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
2174 PerlIO_ungetc(rsfp, '\n'); /* to keep line count right */
2176 while (*s && !(isSPACE (*s) || *s == '#')) s++;
2178 while (*s == ' ' || *s == '\t') s++;
2180 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
2181 if (strnEQ(s2-4,"perl",4))
2183 while (s = moreswitches(s)) ;
2185 if (cddir && chdir(cddir) < 0)
2186 croak("Can't chdir to %s",cddir);
2194 uid = (int)getuid();
2195 euid = (int)geteuid();
2196 gid = (int)getgid();
2197 egid = (int)getegid();
2202 tainting |= (uid && (euid != uid || egid != gid));
2210 croak("No %s allowed while running setuid", s);
2212 croak("No %s allowed while running setgid", s);
2218 curstash = debstash;
2219 dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
2221 DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
2222 DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
2223 DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
2224 DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
2225 sv_setiv(DBsingle, 0);
2226 DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
2227 sv_setiv(DBtrace, 0);
2228 DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
2229 sv_setiv(DBsignal, 0);
2230 curstash = defstash;
2237 mainstack = curstack; /* remember in case we switch stacks */
2238 AvREAL_off(curstack); /* not a real array */
2239 av_extend(curstack,127);
2241 stack_base = AvARRAY(curstack);
2242 stack_sp = stack_base;
2243 stack_max = stack_base + 127;
2245 cxstack_max = 8192 / sizeof(CONTEXT) - 2; /* Use most of 8K. */
2246 New(50,cxstack,cxstack_max + 1,CONTEXT);
2249 New(50,tmps_stack,128,SV*);
2254 New(51,debname,128,char);
2255 New(52,debdelim,128,char);
2259 * The following stacks almost certainly should be per-interpreter,
2260 * but for now they're not. XXX
2264 markstack_ptr = markstack;
2266 New(54,markstack,64,I32);
2267 markstack_ptr = markstack;
2268 markstack_max = markstack + 64;
2274 New(54,scopestack,32,I32);
2276 scopestack_max = 32;
2282 New(54,savestack,128,ANY);
2284 savestack_max = 128;
2290 New(54,retstack,16,OP*);
2300 Safefree(tmps_stack);
2307 static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
2315 subname = newSVpv("main",4);
2319 init_predump_symbols()
2324 sv_setpvn(GvSV(gv_fetchpv("\"", TRUE, SVt_PV)), " ", 1);
2326 stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
2327 GvMULTI_on(stdingv);
2328 IoIFP(GvIOp(stdingv)) = PerlIO_stdin();
2329 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
2331 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(stdingv));
2333 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
2335 IoOFP(GvIOp(tmpgv)) = IoIFP(GvIOp(tmpgv)) = PerlIO_stdout();
2337 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
2339 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(defoutgv));
2341 othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
2342 GvMULTI_on(othergv);
2343 IoOFP(GvIOp(othergv)) = IoIFP(GvIOp(othergv)) = PerlIO_stderr();
2344 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
2346 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(othergv));
2348 statname = NEWSV(66,0); /* last filename we did stat on */
2351 osname = savepv(OSNAME);
2355 init_postdump_symbols(argc,argv,env)
2357 register char **argv;
2358 register char **env;
2364 argc--,argv++; /* skip name of script */
2366 for (; argc > 0 && **argv == '-'; argc--,argv++) {
2369 if (argv[0][1] == '-') {
2373 if (s = strchr(argv[0], '=')) {
2375 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
2378 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
2381 toptarget = NEWSV(0,0);
2382 sv_upgrade(toptarget, SVt_PVFM);
2383 sv_setpvn(toptarget, "", 0);
2384 bodytarget = NEWSV(0,0);
2385 sv_upgrade(bodytarget, SVt_PVFM);
2386 sv_setpvn(bodytarget, "", 0);
2387 formtarget = bodytarget;
2390 if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
2391 sv_setpv(GvSV(tmpgv),origfilename);
2392 magicname("0", "0", 1);
2394 if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
2395 sv_setpv(GvSV(tmpgv),origargv[0]);
2396 if (argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
2398 (void)gv_AVadd(argvgv);
2399 av_clear(GvAVn(argvgv));
2400 for (; argc > 0; argc--,argv++) {
2401 av_push(GvAVn(argvgv),newSVpv(argv[0],0));
2404 if (envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
2408 hv_magic(hv, envgv, 'E');
2409 #ifndef VMS /* VMS doesn't have environ array */
2410 /* Note that if the supplied env parameter is actually a copy
2411 of the global environ then it may now point to free'd memory
2412 if the environment has been modified since. To avoid this
2413 problem we treat env==NULL as meaning 'use the default'
2418 environ[0] = Nullch;
2419 for (; *env; env++) {
2420 if (!(s = strchr(*env,'=')))
2426 sv = newSVpv(s--,0);
2427 (void)hv_store(hv, *env, s - *env, sv, 0);
2429 #if defined(__BORLANDC__) && defined(USE_WIN32_RTL_ENV)
2430 /* Sins of the RTL. See note in my_setenv(). */
2431 (void)putenv(savepv(*env));
2435 #ifdef DYNAMIC_ENV_FETCH
2436 HvNAME(hv) = savepv(ENV_HV_NAME);
2440 if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
2441 sv_setiv(GvSV(tmpgv), (IV)getpid());
2450 s = getenv("PERL5LIB");
2454 incpush(getenv("PERLLIB"), FALSE);
2456 /* Treat PERL5?LIB as a possible search list logical name -- the
2457 * "natural" VMS idiom for a Unix path string. We allow each
2458 * element to be a set of |-separated directories for compatibility.
2462 if (my_trnlnm("PERL5LIB",buf,0))
2463 do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
2465 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE);
2469 /* Use the ~-expanded versions of APPLLIB (undocumented),
2470 ARCHLIB PRIVLIB SITEARCH SITELIB and OLDARCHLIB
2473 incpush(APPLLIB_EXP, FALSE);
2477 incpush(ARCHLIB_EXP, FALSE);
2480 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
2482 incpush(PRIVLIB_EXP, FALSE);
2485 incpush(SITEARCH_EXP, FALSE);
2488 incpush(SITELIB_EXP, FALSE);
2490 #ifdef OLDARCHLIB_EXP /* 5.00[01] compatibility */
2491 incpush(OLDARCHLIB_EXP, FALSE);
2495 incpush(".", FALSE);
2499 # define PERLLIB_SEP ';'
2502 # define PERLLIB_SEP '|'
2504 # define PERLLIB_SEP ':'
2507 #ifndef PERLLIB_MANGLE
2508 # define PERLLIB_MANGLE(s,n) (s)
2512 incpush(p, addsubdirs)
2516 SV *subdir = Nullsv;
2517 static char *archpat_auto;
2524 if (!archpat_auto) {
2525 STRLEN len = (sizeof(ARCHNAME) + strlen(patchlevel)
2526 + sizeof("//auto"));
2527 New(55, archpat_auto, len, char);
2528 sprintf(archpat_auto, "/%s/%s/auto", ARCHNAME, patchlevel);
2530 for (len = sizeof(ARCHNAME) + 2;
2531 archpat_auto[len] != '\0' && archpat_auto[len] != '/'; len++)
2532 if (archpat_auto[len] == '.') archpat_auto[len] = '_';
2537 /* Break at all separators */
2539 SV *libdir = newSV(0);
2542 /* skip any consecutive separators */
2543 while ( *p == PERLLIB_SEP ) {
2544 /* Uncomment the next line for PATH semantics */
2545 /* av_push(GvAVn(incgv), newSVpv(".", 1)); */
2549 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
2550 sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
2555 sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
2556 p = Nullch; /* break out */
2560 * BEFORE pushing libdir onto @INC we may first push version- and
2561 * archname-specific sub-directories.
2564 struct stat tmpstatbuf;
2569 if ((unix = tounixspec_ts(SvPV(libdir,na),Nullch)) != Nullch) {
2571 while (unix[len-1] == '/') len--; /* Cosmetic */
2572 sv_usepvn(libdir,unix,len);
2575 PerlIO_printf(PerlIO_stderr(),
2576 "Failed to unixify @INC element \"%s\"\n",
2579 /* .../archname/version if -d .../archname/version/auto */
2580 sv_setsv(subdir, libdir);
2581 sv_catpv(subdir, archpat_auto);
2582 if (Stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2583 S_ISDIR(tmpstatbuf.st_mode))
2584 av_push(GvAVn(incgv),
2585 newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2587 /* .../archname if -d .../archname/auto */
2588 sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME),
2589 strlen(patchlevel) + 1, "", 0);
2590 if (Stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2591 S_ISDIR(tmpstatbuf.st_mode))
2592 av_push(GvAVn(incgv),
2593 newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2596 /* finally push this lib directory on the end of @INC */
2597 av_push(GvAVn(incgv), libdir);
2600 SvREFCNT_dec(subdir);
2604 call_list(oldscope, list)
2608 line_t oldline = curcop->cop_line;
2613 while (AvFILL(list) >= 0) {
2614 CV *cv = (CV*)av_shift(list);
2621 SV* atsv = GvSV(errgv);
2623 perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
2624 (void)SvPV(atsv, len);
2627 curcop = &compiling;
2628 curcop->cop_line = oldline;
2629 if (list == beginav)
2630 sv_catpv(atsv, "BEGIN failed--compilation aborted");
2632 sv_catpv(atsv, "END failed--cleanup aborted");
2633 while (scopestack_ix > oldscope)
2635 croak("%s", SvPVX(atsv));
2643 /* my_exit() was called */
2644 while (scopestack_ix > oldscope)
2646 curstash = defstash;
2648 call_list(oldscope, endav);
2651 curcop = &compiling;
2652 curcop->cop_line = oldline;
2654 if (list == beginav)
2655 croak("BEGIN failed--compilation aborted");
2657 croak("END failed--cleanup aborted");
2663 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
2668 curcop = &compiling;
2669 curcop->cop_line = oldline;
2688 STATUS_NATIVE_SET(status);
2698 if (vaxc$errno & 1) {
2699 if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
2700 STATUS_NATIVE_SET(44);
2703 if (!vaxc$errno && errno) /* unlikely */
2704 STATUS_NATIVE_SET(44);
2706 STATUS_NATIVE_SET(vaxc$errno);
2710 STATUS_POSIX_SET(errno);
2711 else if (STATUS_POSIX == 0)
2712 STATUS_POSIX_SET(255);
2720 register CONTEXT *cx;
2729 (void)UNLINK(e_tmpname);
2730 Safefree(e_tmpname);
2734 if (cxstack_ix >= 0) {