3 * Copyright (c) 1987-1998 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));
73 static struct perl_thread * init_main_thread _((void));
74 #endif /* USE_THREADS */
75 static void init_perllib _((void));
76 static void init_postdump_symbols _((int, char **, char **));
77 static void init_predump_symbols _((void));
78 static void my_exit_jump _((void)) __attribute__((noreturn));
79 static void nuke_stacks _((void));
80 static void open_script _((char *, bool, SV *));
81 static void usage _((char *));
82 static void validate_suid _((char *, char*));
84 static int fdscript = -1;
89 PerlInterpreter *sv_interp;
92 New(53, sv_interp, 1, PerlInterpreter);
97 perl_construct(register PerlInterpreter *sv_interp)
102 struct perl_thread *thr;
103 #endif /* FAKE_THREADS */
104 #endif /* USE_THREADS */
106 if (!(curinterp = sv_interp))
110 Zero(sv_interp, 1, PerlInterpreter);
113 /* Init the real globals (and main thread)? */
118 #ifdef ALLOC_THREAD_KEY
121 if (pthread_key_create(&thr_key, 0))
122 croak("panic: pthread_key_create");
124 MUTEX_INIT(&sv_mutex);
126 * Safe to use basic SV functions from now on (though
127 * not things like mortals or tainting yet).
129 MUTEX_INIT(&eval_mutex);
130 COND_INIT(&eval_cond);
131 MUTEX_INIT(&threads_mutex);
132 COND_INIT(&nthreads_cond);
133 #ifdef EMULATE_ATOMIC_REFCOUNTS
134 MUTEX_INIT(&svref_mutex);
135 #endif /* EMULATE_ATOMIC_REFCOUNTS */
137 thr = init_main_thread();
138 #endif /* USE_THREADS */
140 linestr = NEWSV(65,80);
141 sv_upgrade(linestr,SVt_PVIV);
143 if (!SvREADONLY(&sv_undef)) {
144 SvREADONLY_on(&sv_undef);
148 SvREADONLY_on(&sv_no);
150 sv_setpv(&sv_yes,Yes);
152 SvREADONLY_on(&sv_yes);
155 nrs = newSVpv("\n", 1);
156 rs = SvREFCNT_inc(nrs);
158 sighandlerp = sighandler;
163 * There is no way we can refer to them from Perl so close them to save
164 * space. The other alternative would be to provide STDAUX and STDPRN
167 (void)fclose(stdaux);
168 (void)fclose(stdprn);
174 perl_destruct_level = 1;
176 if(perl_destruct_level > 0)
181 lex_state = LEX_NOTPARSING;
183 start_env.je_prev = NULL;
184 start_env.je_ret = -1;
185 start_env.je_mustcatch = TRUE;
186 top_env = &start_env;
189 SET_NUMERIC_STANDARD();
190 #if defined(SUBVERSION) && SUBVERSION > 0
191 sprintf(patchlevel, "%7.5f", (double) 5
192 + ((double) PATCHLEVEL / (double) 1000)
193 + ((double) SUBVERSION / (double) 100000));
195 sprintf(patchlevel, "%5.3f", (double) 5 +
196 ((double) PATCHLEVEL / (double) 1000));
199 #if defined(LOCAL_PATCH_COUNT)
200 localpatches = local_patches; /* For possible -v */
203 PerlIO_init(); /* Hook to IO system */
205 fdpid = newAV(); /* for remembering popen pids by fd */
209 New(51,debname,128,char);
210 New(52,debdelim,128,char);
217 perl_destruct(register PerlInterpreter *sv_interp)
220 int destruct_level; /* 0=none, 1=full, 2=full with checks */
225 #endif /* USE_THREADS */
227 if (!(curinterp = sv_interp))
232 /* Pass 1 on any remaining threads: detach joinables, join zombies */
234 MUTEX_LOCK(&threads_mutex);
235 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
236 "perl_destruct: waiting for %d threads...\n",
238 for (t = thr->next; t != thr; t = t->next) {
239 MUTEX_LOCK(&t->mutex);
240 switch (ThrSTATE(t)) {
243 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
244 "perl_destruct: joining zombie %p\n", t));
245 ThrSETSTATE(t, THRf_DEAD);
246 MUTEX_UNLOCK(&t->mutex);
249 * The SvREFCNT_dec below may take a long time (e.g. av
250 * may contain an object scalar whose destructor gets
251 * called) so we have to unlock threads_mutex and start
254 MUTEX_UNLOCK(&threads_mutex);
256 SvREFCNT_dec((SV*)av);
257 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
258 "perl_destruct: joined zombie %p OK\n", t));
260 case THRf_R_JOINABLE:
261 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
262 "perl_destruct: detaching thread %p\n", t));
263 ThrSETSTATE(t, THRf_R_DETACHED);
265 * We unlock threads_mutex and t->mutex in the opposite order
266 * from which we locked them just so that DETACH won't
267 * deadlock if it panics. It's only a breach of good style
268 * not a bug since they are unlocks not locks.
270 MUTEX_UNLOCK(&threads_mutex);
272 MUTEX_UNLOCK(&t->mutex);
275 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
276 "perl_destruct: ignoring %p (state %u)\n",
278 MUTEX_UNLOCK(&t->mutex);
279 /* fall through and out */
282 /* We leave the above "Pass 1" loop with threads_mutex still locked */
284 /* Pass 2 on remaining threads: wait for the thread count to drop to one */
287 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
288 "perl_destruct: final wait for %d threads\n",
290 COND_WAIT(&nthreads_cond, &threads_mutex);
292 /* At this point, we're the last thread */
293 MUTEX_UNLOCK(&threads_mutex);
294 DEBUG_L(PerlIO_printf(PerlIO_stderr(), "perl_destruct: armageddon has arrived\n"));
295 MUTEX_DESTROY(&threads_mutex);
296 COND_DESTROY(&nthreads_cond);
297 #endif /* !defined(FAKE_THREADS) */
298 #endif /* USE_THREADS */
300 destruct_level = perl_destruct_level;
304 if (s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL")) {
306 if (destruct_level < i)
315 /* We must account for everything. */
317 /* Destroy the main CV and syntax tree */
319 curpad = AvARRAY(comppad);
324 SvREFCNT_dec(main_cv);
329 * Try to destruct global references. We do this first so that the
330 * destructors and destructees still exist. Some sv's might remain.
331 * Non-referenced objects are on their own.
338 /* unhook hooks which will soon be, or use, destroyed data */
339 SvREFCNT_dec(warnhook);
341 SvREFCNT_dec(diehook);
343 SvREFCNT_dec(parsehook);
346 if (destruct_level == 0){
348 DEBUG_P(debprofdump());
350 /* The exit() function will do everything that needs doing. */
354 /* loosen bonds of global variables */
357 (void)PerlIO_close(rsfp);
361 /* Filters for program text */
362 SvREFCNT_dec(rsfp_filters);
363 rsfp_filters = Nullav;
375 sawampersand = FALSE; /* must save all match strings */
376 sawstudy = FALSE; /* do fbm_instr on all strings */
391 /* magical thingies */
393 Safefree(ofs); /* $, */
396 Safefree(ors); /* $\ */
399 SvREFCNT_dec(nrs); /* $\ helper */
402 multiline = 0; /* $* */
404 SvREFCNT_dec(statname);
408 /* defgv, aka *_ should be taken care of elsewhere */
410 /* clean up after study() */
411 SvREFCNT_dec(lastscream);
413 Safefree(screamfirst);
415 Safefree(screamnext);
418 /* startup and shutdown function lists */
419 SvREFCNT_dec(beginav);
421 SvREFCNT_dec(initav);
426 /* temp stack during pp_sort() */
427 SvREFCNT_dec(sortstack);
430 /* shortcuts just get cleared */
440 /* reset so print() ends up where we expect */
443 /* Prepare to destruct main symbol table. */
450 if (destruct_level >= 2) {
451 if (scopestack_ix != 0)
452 warn("Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
453 (long)scopestack_ix);
454 if (savestack_ix != 0)
455 warn("Unbalanced saves: %ld more saves than restores\n",
457 if (tmps_floor != -1)
458 warn("Unbalanced tmps: %ld more allocs than frees\n",
459 (long)tmps_floor + 1);
460 if (cxstack_ix != -1)
461 warn("Unbalanced context: %ld more PUSHes than POPs\n",
462 (long)cxstack_ix + 1);
465 /* Now absolutely destruct everything, somehow or other, loops or no. */
467 SvFLAGS(strtab) |= SVTYPEMASK; /* don't clean out strtab now */
468 while (sv_count != 0 && sv_count != last_sv_count) {
469 last_sv_count = sv_count;
472 SvFLAGS(strtab) &= ~SVTYPEMASK;
473 SvFLAGS(strtab) |= SVt_PVHV;
475 /* Destruct the global string table. */
477 /* Yell and reset the HeVAL() slots that are still holding refcounts,
478 * so that sv_free() won't fail on them.
487 array = HvARRAY(strtab);
491 warn("Unbalanced string table refcount: (%d) for \"%s\"",
492 HeVAL(hent) - Nullsv, HeKEY(hent));
493 HeVAL(hent) = Nullsv;
503 SvREFCNT_dec(strtab);
506 warn("Scalars leaked: %ld\n", (long)sv_count);
510 /* No SVs have survived, need to clean out */
514 Safefree(origfilename);
516 hints = 0; /* Reset hints. Should hints be per-interpreter ? */
518 DEBUG_P(debprofdump());
520 MUTEX_DESTROY(&sv_mutex);
521 MUTEX_DESTROY(&eval_mutex);
522 COND_DESTROY(&eval_cond);
524 /* As the penultimate thing, free the non-arena SV for thrsv */
525 Safefree(SvPVX(thrsv));
526 Safefree(SvANY(thrsv));
529 #endif /* USE_THREADS */
531 /* As the absolutely last thing, free the non-arena SV for mess() */
534 /* we know that type >= SVt_PV */
536 Safefree(SvPVX(mess_sv));
537 Safefree(SvANY(mess_sv));
544 perl_free(PerlInterpreter *sv_interp)
546 if (!(curinterp = sv_interp))
552 perl_parse(PerlInterpreter *sv_interp, void (*xsinit) (void), int argc, char **argv, char **env)
557 char *scriptname = NULL;
558 VOL bool dosearch = FALSE;
565 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
568 croak("suidperl is no longer needed since the kernel can now execute\n\
569 setuid perl scripts securely.\n");
573 if (!(curinterp = sv_interp))
576 #if defined(NeXT) && defined(__DYNAMIC__)
577 _dyld_lookup_and_bind
578 ("__environ", (unsigned long *) &environ_pointer, NULL);
583 #ifndef VMS /* VMS doesn't have environ array */
584 origenviron = environ;
590 /* Come here if running an undumped a.out. */
592 origfilename = savepv(argv[0]);
594 cxstack_ix = -1; /* start label stack again */
596 init_postdump_symbols(argc,argv,env);
601 curpad = AvARRAY(comppad);
606 SvREFCNT_dec(main_cv);
610 oldscope = scopestack_ix;
618 /* my_exit() was called */
619 while (scopestack_ix > oldscope)
624 call_list(oldscope, endav);
626 return STATUS_NATIVE_EXPORT;
629 PerlIO_printf(PerlIO_stderr(), "panic: top_env\n");
633 sv_setpvn(linestr,"",0);
634 sv = newSVpv("",0); /* first used for -I flags */
638 for (argc--,argv++; argc > 0; argc--,argv++) {
639 if (argv[0][0] != '-' || !argv[0][1])
643 validarg = " PHOOEY ";
668 if (s = moreswitches(s))
678 if (euid != uid || egid != gid)
679 croak("No -e allowed in setuid scripts");
681 e_tmpname = savepv(TMPPATH);
682 (void)PerlLIO_mktemp(e_tmpname);
684 croak("Can't mktemp()");
685 e_fp = PerlIO_open(e_tmpname,"w");
687 croak("Cannot open temporary file");
692 PerlIO_puts(e_fp,argv[1]);
696 croak("No code specified for -e");
697 (void)PerlIO_putc(e_fp,'\n');
699 case 'I': /* -I handled both here and in moreswitches() */
701 if (!*++s && (s=argv[1]) != Nullch) {
704 while (s && isSPACE(*s))
708 for (e = s; *e && !isSPACE(*e); e++) ;
715 } /* XXX else croak? */
729 preambleav = newAV();
730 av_push(preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
732 Sv = newSVpv("print myconfig();",0);
734 sv_catpv(Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
736 sv_catpv(Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
738 #if defined(DEBUGGING) || defined(NO_EMBED) || defined(MULTIPLICITY)
739 sv_catpv(Sv,"\" Compile-time options:");
741 sv_catpv(Sv," DEBUGGING");
744 sv_catpv(Sv," NO_EMBED");
747 sv_catpv(Sv," MULTIPLICITY");
749 sv_catpv(Sv,"\\n\",");
751 #if defined(LOCAL_PATCH_COUNT)
752 if (LOCAL_PATCH_COUNT > 0) {
754 sv_catpv(Sv,"\" Locally applied patches:\\n\",");
755 for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
757 sv_catpvf(Sv,"\" \\t%s\\n\",",localpatches[i]);
761 sv_catpvf(Sv,"\" Built under %s\\n\"",OSNAME);
764 sv_catpvf(Sv,",\" Compiled at %s %s\\n\"",__DATE__,__TIME__);
766 sv_catpvf(Sv,",\" Compiled on %s\\n\"",__DATE__);
771 @env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; \
772 print \" \\%ENV:\\n @env\\n\" if @env; \
773 print \" \\@INC:\\n @INC\\n\";");
776 Sv = newSVpv("config_vars(qw(",0);
781 av_push(preambleav, Sv);
782 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
793 if (!*++s || isSPACE(*s)) {
797 /* catch use of gnu style long options */
798 if (strEQ(s, "version")) {
802 if (strEQ(s, "help")) {
809 croak("Unrecognized switch: -%s (-h will show valid options)",s);
814 if (!tainting && (s = PerlEnv_getenv("PERL5OPT"))) {
825 if (!strchr("DIMUdmw", *s))
826 croak("Illegal switch in PERL5OPT: -%c", *s);
832 scriptname = argv[0];
834 if (PerlIO_flush(e_fp) || PerlIO_error(e_fp) || PerlIO_close(e_fp)) {
836 warn("Did you forget to compile with -DMULTIPLICITY?");
838 croak("Can't write to temp file for -e: %s", Strerror(errno));
842 scriptname = e_tmpname;
844 else if (scriptname == Nullch) {
846 if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) )
854 open_script(scriptname,dosearch,sv);
856 validate_suid(validarg, scriptname);
861 main_cv = compcv = (CV*)NEWSV(1104,0);
862 sv_upgrade((SV *)compcv, SVt_PVCV);
866 av_push(comppad, Nullsv);
867 curpad = AvARRAY(comppad);
868 comppad_name = newAV();
869 comppad_name_fill = 0;
870 min_intro_pending = 0;
873 av_store(comppad_name, 0, newSVpv("@_", 2));
874 curpad[0] = (SV*)newAV();
875 SvPADMY_on(curpad[0]); /* XXX Needed? */
877 New(666, CvMUTEXP(compcv), 1, perl_mutex);
878 MUTEX_INIT(CvMUTEXP(compcv));
879 #endif /* USE_THREADS */
881 comppadlist = newAV();
882 AvREAL_off(comppadlist);
883 av_store(comppadlist, 0, (SV*)comppad_name);
884 av_store(comppadlist, 1, (SV*)comppad);
885 CvPADLIST(compcv) = comppadlist;
887 boot_core_UNIVERSAL();
889 (*xsinit)(); /* in case linked C routines want magical variables */
890 #if defined(VMS) || defined(WIN32) || defined(DJGPP)
894 init_predump_symbols();
896 init_postdump_symbols(argc,argv,env);
900 /* now parse the script */
902 SETERRNO(0,SS$_NORMAL);
904 if (yyparse() || error_count) {
906 croak("%s had compilation errors.\n", origfilename);
908 croak("Execution of %s aborted due to compilation errors.\n",
912 curcop->cop_line = 0;
916 (void)UNLINK(e_tmpname);
921 /* now that script is parsed, we can modify record separator */
923 rs = SvREFCNT_inc(nrs);
924 sv_setsv(perl_get_sv("/", TRUE), rs);
935 if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
936 dump_mstats("after compilation:");
946 perl_run(PerlInterpreter *sv_interp)
953 if (!(curinterp = sv_interp))
956 oldscope = scopestack_ix;
961 cxstack_ix = -1; /* start context stack again */
964 /* my_exit() was called */
965 while (scopestack_ix > oldscope)
970 call_list(oldscope, endav);
972 if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
973 dump_mstats("after execution: ");
976 return STATUS_NATIVE_EXPORT;
979 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
984 if (curstack != mainstack) {
986 SWITCHSTACK(curstack, mainstack);
991 DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
992 sawampersand ? "Enabling" : "Omitting"));
996 DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
998 DEBUG_L(PerlIO_printf(Perl_debug_log, "main thread is 0x%lx\n",
999 (unsigned long) thr));
1000 #endif /* USE_THREADS */
1003 PerlIO_printf(PerlIO_stderr(), "%s syntax OK\n", origfilename);
1006 if (PERLDB_SINGLE && DBsingle)
1007 sv_setiv(DBsingle, 1);
1009 call_list(oldscope, initav);
1019 else if (main_start) {
1020 CvDEPTH(main_cv) = 1;
1031 perl_get_sv(char *name, I32 create)
1035 if (name[1] == '\0' && !isALPHA(name[0])) {
1036 PADOFFSET tmp = find_threadsv(name);
1037 if (tmp != NOT_IN_PAD) {
1039 return THREADSV(tmp);
1042 #endif /* USE_THREADS */
1043 gv = gv_fetchpv(name, create, SVt_PV);
1050 perl_get_av(char *name, I32 create)
1052 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
1061 perl_get_hv(char *name, I32 create)
1063 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
1072 perl_get_cv(char *name, I32 create)
1074 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
1075 if (create && !GvCVu(gv))
1076 return newSUB(start_subparse(FALSE, 0),
1077 newSVOP(OP_CONST, 0, newSVpv(name,0)),
1085 /* Be sure to refetch the stack pointer after calling these routines. */
1088 perl_call_argv(char *sub_name, I32 flags, register char **argv)
1090 /* See G_* flags in cop.h */
1091 /* null terminated arg list */
1098 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
1103 return perl_call_pv(sub_name, flags);
1107 perl_call_pv(char *sub_name, I32 flags)
1108 /* name of the subroutine */
1109 /* See G_* flags in cop.h */
1111 return perl_call_sv((SV*)perl_get_cv(sub_name, TRUE), flags);
1115 perl_call_method(char *methname, I32 flags)
1116 /* name of the subroutine */
1117 /* See G_* flags in cop.h */
1123 XPUSHs(sv_2mortal(newSVpv(methname,0)));
1126 return perl_call_sv(*stack_sp--, flags);
1129 /* May be called with any of a CV, a GV, or an SV containing the name. */
1131 perl_call_sv(SV *sv, I32 flags)
1133 /* See G_* flags in cop.h */
1136 LOGOP myop; /* fake syntax tree node */
1142 bool oldcatch = CATCH_GET;
1147 if (flags & G_DISCARD) {
1152 Zero(&myop, 1, LOGOP);
1153 myop.op_next = Nullop;
1154 if (!(flags & G_NOARGS))
1155 myop.op_flags |= OPf_STACKED;
1156 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1157 (flags & G_ARRAY) ? OPf_WANT_LIST :
1162 EXTEND(stack_sp, 1);
1165 oldscope = scopestack_ix;
1167 if (PERLDB_SUB && curstash != debstash
1168 /* Handle first BEGIN of -d. */
1169 && (DBcv || (DBcv = GvCV(DBsub)))
1170 /* Try harder, since this may have been a sighandler, thus
1171 * curstash may be meaningless. */
1172 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != debstash))
1173 op->op_private |= OPpENTERSUB_DB;
1175 if (flags & G_EVAL) {
1176 cLOGOP->op_other = op;
1178 /* we're trying to emulate pp_entertry() here */
1180 register PERL_CONTEXT *cx;
1181 I32 gimme = GIMME_V;
1186 push_return(op->op_next);
1187 PUSHBLOCK(cx, CXt_EVAL, stack_sp);
1189 eval_root = op; /* Only needed so that goto works right. */
1192 if (flags & G_KEEPERR)
1207 /* my_exit() was called */
1208 curstash = defstash;
1212 croak("Callback called exit");
1221 stack_sp = stack_base + oldmark;
1222 if (flags & G_ARRAY)
1226 *++stack_sp = &sv_undef;
1234 if (op == (OP*)&myop)
1235 op = pp_entersub(ARGS);
1238 retval = stack_sp - (stack_base + oldmark);
1239 if ((flags & G_EVAL) && !(flags & G_KEEPERR))
1243 if (flags & G_EVAL) {
1244 if (scopestack_ix > oldscope) {
1248 register PERL_CONTEXT *cx;
1260 CATCH_SET(oldcatch);
1262 if (flags & G_DISCARD) {
1263 stack_sp = stack_base + oldmark;
1272 /* Eval a string. The G_EVAL flag is always assumed. */
1275 perl_eval_sv(SV *sv, I32 flags)
1277 /* See G_* flags in cop.h */
1280 UNOP myop; /* fake syntax tree node */
1282 I32 oldmark = sp - stack_base;
1289 if (flags & G_DISCARD) {
1297 EXTEND(stack_sp, 1);
1299 oldscope = scopestack_ix;
1301 if (!(flags & G_NOARGS))
1302 myop.op_flags = OPf_STACKED;
1303 myop.op_next = Nullop;
1304 myop.op_type = OP_ENTEREVAL;
1305 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1306 (flags & G_ARRAY) ? OPf_WANT_LIST :
1308 if (flags & G_KEEPERR)
1309 myop.op_flags |= OPf_SPECIAL;
1319 /* my_exit() was called */
1320 curstash = defstash;
1324 croak("Callback called exit");
1333 stack_sp = stack_base + oldmark;
1334 if (flags & G_ARRAY)
1338 *++stack_sp = &sv_undef;
1343 if (op == (OP*)&myop)
1344 op = pp_entereval(ARGS);
1347 retval = stack_sp - (stack_base + oldmark);
1348 if (!(flags & G_KEEPERR))
1353 if (flags & G_DISCARD) {
1354 stack_sp = stack_base + oldmark;
1364 perl_eval_pv(char *p, I32 croak_on_error)
1367 SV* sv = newSVpv(p, 0);
1370 perl_eval_sv(sv, G_SCALAR);
1377 if (croak_on_error && SvTRUE(ERRSV))
1378 croak(SvPVx(ERRSV, na));
1383 /* Require a module. */
1386 perl_require_pv(char *pv)
1388 SV* sv = sv_newmortal();
1389 sv_setpv(sv, "require '");
1392 perl_eval_sv(sv, G_DISCARD);
1396 magicname(char *sym, char *name, I32 namlen)
1400 if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
1401 sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
1405 usage(char *name) /* XXX move this out into a module ? */
1408 /* This message really ought to be max 23 lines.
1409 * Removed -h because the user already knows that opton. Others? */
1411 static char *usage[] = {
1412 "-0[octal] specify record separator (\\0, if no argument)",
1413 "-a autosplit mode with -n or -p (splits $_ into @F)",
1414 "-c check syntax only (runs BEGIN and END blocks)",
1415 "-d[:debugger] run scripts under debugger",
1416 "-D[number/list] set debugging flags (argument is a bit mask or flags)",
1417 "-e 'command' one line of script. Several -e's allowed. Omit [programfile].",
1418 "-F/pattern/ split() pattern for autosplit (-a). The //'s are optional.",
1419 "-i[extension] edit <> files in place (make backup if extension supplied)",
1420 "-Idirectory specify @INC/#include directory (may be used more than once)",
1421 "-l[octal] enable line ending processing, specifies line terminator",
1422 "-[mM][-]module.. executes `use/no module...' before executing your script.",
1423 "-n assume 'while (<>) { ... }' loop around your script",
1424 "-p assume loop like -n but print line also like sed",
1425 "-P run script through C preprocessor before compilation",
1426 "-s enable some switch parsing for switches after script name",
1427 "-S look for the script using PATH environment variable",
1428 "-T turn on tainting checks",
1429 "-u dump core after parsing script",
1430 "-U allow unsafe operations",
1431 "-v print version number and patchlevel of perl",
1432 "-V[:variable] print perl configuration information",
1433 "-w TURN WARNINGS ON FOR COMPILATION OF YOUR SCRIPT. Recommended.",
1434 "-x[directory] strip off text before #!perl line and perhaps cd to directory",
1440 printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
1442 printf("\n %s", *p++);
1445 /* This routine handles any switches that can be given during run */
1448 moreswitches(char *s)
1457 rschar = scan_oct(s, 4, &numlen);
1459 if (rschar & ~((U8)~0))
1461 else if (!rschar && numlen >= 2)
1462 nrs = newSVpv("", 0);
1465 nrs = newSVpv(&ch, 1);
1471 splitstr = savepv(s + 1);
1485 if (*s == ':' || *s == '=') {
1486 my_setenv("PERL5DB", form("use Devel::%s;", ++s));
1490 perldb = PERLDB_ALL;
1497 if (isALPHA(s[1])) {
1498 static char debopts[] = "psltocPmfrxuLHXD";
1501 for (s++; *s && (d = strchr(debopts,*s)); s++)
1502 debug |= 1 << (d - debopts);
1506 for (s++; isDIGIT(*s); s++) ;
1508 debug |= 0x80000000;
1510 warn("Recompile perl with -DDEBUGGING to use -D switch\n");
1511 for (s++; isALNUM(*s); s++) ;
1521 inplace = savepv(s+1);
1523 for (s = inplace; *s && !isSPACE(*s); s++) ;
1527 case 'I': /* -I handled both here and in parse_perl() */
1530 while (*s && isSPACE(*s))
1534 for (e = s; *e && !isSPACE(*e); e++) ;
1535 p = savepvn(s, e-s);
1541 croak("No space allowed after -I");
1551 *ors = scan_oct(s, 3 + (*s == '0'), &numlen);
1561 ors = SvPV(nrs, orslen);
1562 ors = savepvn(ors, orslen);
1566 forbid_setid("-M"); /* XXX ? */
1569 forbid_setid("-m"); /* XXX ? */
1574 /* -M-foo == 'no foo' */
1575 if (*s == '-') { use = "no "; ++s; }
1576 sv = newSVpv(use,0);
1578 /* We allow -M'Module qw(Foo Bar)' */
1579 while(isALNUM(*s) || *s==':') ++s;
1581 sv_catpv(sv, start);
1582 if (*(start-1) == 'm') {
1584 croak("Can't use '%c' after -mname", *s);
1585 sv_catpv( sv, " ()");
1588 sv_catpvn(sv, start, s-start);
1589 sv_catpv(sv, " split(/,/,q{");
1594 if (preambleav == NULL)
1595 preambleav = newAV();
1596 av_push(preambleav, sv);
1599 croak("No space allowed after -%c", *(s-1));
1616 croak("Too late for \"-T\" option");
1628 #if defined(SUBVERSION) && SUBVERSION > 0
1629 printf("\nThis is perl, version 5.%03d_%02d built for %s",
1630 PATCHLEVEL, SUBVERSION, ARCHNAME);
1632 printf("\nThis is perl, version %s built for %s",
1633 patchlevel, ARCHNAME);
1635 #if defined(LOCAL_PATCH_COUNT)
1636 if (LOCAL_PATCH_COUNT > 0)
1637 printf("\n(with %d registered patch%s, see perl -V for more detail)",
1638 LOCAL_PATCH_COUNT, (LOCAL_PATCH_COUNT!=1) ? "es" : "");
1641 printf("\n\nCopyright 1987-1998, Larry Wall\n");
1643 printf("\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
1646 printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n");
1647 printf("djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1998\n");
1650 printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
1651 "Version 5 port Copyright (c) 1994-1998, Andreas Kaiser, Ilya Zakharevich\n");
1654 printf("atariST series port, ++jrb bammi@cadence.com\n");
1657 Perl may be copied only under the terms of either the Artistic License or the\n\
1658 GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n");
1666 if (s[1] == '-') /* Additional switches on #! line. */
1677 #ifdef ALTERNATE_SHEBANG
1678 case 'S': /* OS/2 needs -S on "extproc" line. */
1686 croak("Can't emulate -%.1s on #! line",s);
1691 /* compliments of Tom Christiansen */
1693 /* unexec() can be found in the Gnu emacs distribution */
1704 prog = newSVpv(BIN_EXP);
1705 sv_catpv(prog, "/perl");
1706 file = newSVpv(origfilename);
1707 sv_catpv(file, ".perldump");
1709 status = unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
1711 PerlIO_printf(PerlIO_stderr(), "unexec of %s into %s failed!\n",
1712 SvPVX(prog), SvPVX(file));
1713 PerlProc_exit(status);
1716 # include <lib$routines.h>
1717 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
1719 ABORT(); /* for use with undump */
1725 init_main_stash(void)
1730 /* Note that strtab is a rather special HV. Assumptions are made
1731 about not iterating on it, and not adding tie magic to it.
1732 It is properly deallocated in perl_destruct() */
1734 HvSHAREKEYS_off(strtab); /* mandatory */
1735 Newz(506,((XPVHV*)SvANY(strtab))->xhv_array,
1736 sizeof(HE*) * (((XPVHV*)SvANY(strtab))->xhv_max + 1), char);
1738 curstash = defstash = newHV();
1739 curstname = newSVpv("main",4);
1740 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
1741 SvREFCNT_dec(GvHV(gv));
1742 GvHV(gv) = (HV*)SvREFCNT_inc(defstash);
1744 HvNAME(defstash) = savepv("main");
1745 incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
1747 defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
1748 errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
1750 (void)form("%240s",""); /* Preallocate temp - for immediate signals. */
1751 sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */
1752 sv_setpvn(ERRSV, "", 0);
1753 curstash = defstash;
1754 compiling.cop_stash = defstash;
1755 debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
1756 globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
1757 /* We must init $/ before switches are processed. */
1758 sv_setpvn(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), "\n", 1);
1762 open_script(char *scriptname, bool dosearch, SV *sv)
1765 char *xfound = Nullch;
1766 char *xfailed = Nullch;
1770 #if defined(DOSISH) && !defined(OS2) && !defined(atarist)
1771 # define SEARCH_EXTS ".bat", ".cmd", NULL
1772 # define MAX_EXT_LEN 4
1775 # define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL
1776 # define MAX_EXT_LEN 4
1779 # define SEARCH_EXTS ".pl", ".com", NULL
1780 # define MAX_EXT_LEN 4
1782 /* additional extensions to try in each dir if scriptname not found */
1784 char *ext[] = { SEARCH_EXTS };
1785 int extidx = 0, i = 0;
1786 char *curext = Nullch;
1788 # define MAX_EXT_LEN 0
1792 * If dosearch is true and if scriptname does not contain path
1793 * delimiters, search the PATH for scriptname.
1795 * If SEARCH_EXTS is also defined, will look for each
1796 * scriptname{SEARCH_EXTS} whenever scriptname is not found
1797 * while searching the PATH.
1799 * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
1800 * proceeds as follows:
1801 * If DOSISH or VMSISH:
1802 * + look for ./scriptname{,.foo,.bar}
1803 * + search the PATH for scriptname{,.foo,.bar}
1806 * + look *only* in the PATH for scriptname{,.foo,.bar} (note
1807 * this will not look in '.' if it's not in the PATH)
1811 # ifdef ALWAYS_DEFTYPES
1812 len = strlen(scriptname);
1813 if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') {
1814 int hasdir, idx = 0, deftypes = 1;
1817 hasdir = !dosearch || (strpbrk(scriptname,":[</") != Nullch) ;
1820 int hasdir, idx = 0, deftypes = 1;
1823 hasdir = (strpbrk(scriptname,":[</") != Nullch) ;
1825 /* The first time through, just add SEARCH_EXTS to whatever we
1826 * already have, so we can check for default file types. */
1828 (!hasdir && my_trnlnm("DCL$PATH",tokenbuf,idx++)) )
1834 if ((strlen(tokenbuf) + strlen(scriptname)
1835 + MAX_EXT_LEN) >= sizeof tokenbuf)
1836 continue; /* don't search dir with too-long name */
1837 strcat(tokenbuf, scriptname);
1841 if (strEQ(scriptname, "-"))
1843 if (dosearch) { /* Look in '.' first. */
1844 char *cur = scriptname;
1846 if ((curext = strrchr(scriptname,'.'))) /* possible current ext */
1848 if (strEQ(ext[i++],curext)) {
1849 extidx = -1; /* already has an ext */
1854 DEBUG_p(PerlIO_printf(Perl_debug_log,
1855 "Looking for %s\n",cur));
1856 if (Stat(cur,&statbuf) >= 0) {
1864 if (cur == scriptname) {
1865 len = strlen(scriptname);
1866 if (len+MAX_EXT_LEN+1 >= sizeof(tokenbuf))
1868 cur = strcpy(tokenbuf, scriptname);
1870 } while (extidx >= 0 && ext[extidx] /* try an extension? */
1871 && strcpy(tokenbuf+len, ext[extidx++]));
1876 if (dosearch && !strchr(scriptname, '/')
1878 && !strchr(scriptname, '\\')
1880 && (s = PerlEnv_getenv("PATH"))) {
1883 bufend = s + strlen(s);
1884 while (s < bufend) {
1885 #if defined(atarist) || defined(DOSISH)
1890 && *s != ';'; len++, s++) {
1891 if (len < sizeof tokenbuf)
1894 if (len < sizeof tokenbuf)
1895 tokenbuf[len] = '\0';
1896 #else /* ! (atarist || DOSISH) */
1897 s = delimcpy(tokenbuf, tokenbuf + sizeof tokenbuf, s, bufend,
1900 #endif /* ! (atarist || DOSISH) */
1903 if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tokenbuf)
1904 continue; /* don't search dir with too-long name */
1906 #if defined(atarist) || defined(DOSISH)
1907 && tokenbuf[len - 1] != '/'
1908 && tokenbuf[len - 1] != '\\'
1911 tokenbuf[len++] = '/';
1912 if (len == 2 && tokenbuf[0] == '.')
1914 (void)strcpy(tokenbuf + len, scriptname);
1918 len = strlen(tokenbuf);
1919 if (extidx > 0) /* reset after previous loop */
1923 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tokenbuf));
1924 retval = Stat(tokenbuf,&statbuf);
1926 } while ( retval < 0 /* not there */
1927 && extidx>=0 && ext[extidx] /* try an extension? */
1928 && strcpy(tokenbuf+len, ext[extidx++])
1933 if (S_ISREG(statbuf.st_mode)
1934 && cando(S_IRUSR,TRUE,&statbuf)
1936 && cando(S_IXUSR,TRUE,&statbuf)
1940 xfound = tokenbuf; /* bingo! */
1944 xfailed = savepv(tokenbuf);
1947 if (!xfound && !seen_dot && !xfailed && (Stat(scriptname,&statbuf) < 0))
1949 seen_dot = 1; /* Disable message. */
1951 croak("Can't %s %s%s%s",
1952 (xfailed ? "execute" : "find"),
1953 (xfailed ? xfailed : scriptname),
1954 (xfailed ? "" : " on PATH"),
1955 (xfailed || seen_dot) ? "" : ", '.' not in PATH");
1958 scriptname = xfound;
1961 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
1962 char *s = scriptname + 8;
1971 origfilename = savepv(e_tmpname ? "-e" : scriptname);
1972 curcop->cop_filegv = gv_fetchfile(origfilename);
1973 if (strEQ(origfilename,"-"))
1975 if (fdscript >= 0) {
1976 rsfp = PerlIO_fdopen(fdscript,PERL_SCRIPT_MODE);
1977 #if defined(HAS_FCNTL) && defined(F_SETFD)
1979 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
1982 else if (preprocess) {
1983 char *cpp_cfg = CPPSTDIN;
1984 SV *cpp = NEWSV(0,0);
1985 SV *cmd = NEWSV(0,0);
1987 if (strEQ(cpp_cfg, "cppstdin"))
1988 sv_catpvf(cpp, "%s/", BIN_EXP);
1989 sv_catpv(cpp, cpp_cfg);
1992 sv_catpv(sv,PRIVLIB_EXP);
1996 sed %s -e \"/^[^#]/b\" \
1997 -e \"/^#[ ]*include[ ]/b\" \
1998 -e \"/^#[ ]*define[ ]/b\" \
1999 -e \"/^#[ ]*if[ ]/b\" \
2000 -e \"/^#[ ]*ifdef[ ]/b\" \
2001 -e \"/^#[ ]*ifndef[ ]/b\" \
2002 -e \"/^#[ ]*else/b\" \
2003 -e \"/^#[ ]*elif[ ]/b\" \
2004 -e \"/^#[ ]*undef[ ]/b\" \
2005 -e \"/^#[ ]*endif/b\" \
2008 (doextract ? "-e \"1,/^#/d\n\"" : ""),
2011 %s %s -e '/^[^#]/b' \
2012 -e '/^#[ ]*include[ ]/b' \
2013 -e '/^#[ ]*define[ ]/b' \
2014 -e '/^#[ ]*if[ ]/b' \
2015 -e '/^#[ ]*ifdef[ ]/b' \
2016 -e '/^#[ ]*ifndef[ ]/b' \
2017 -e '/^#[ ]*else/b' \
2018 -e '/^#[ ]*elif[ ]/b' \
2019 -e '/^#[ ]*undef[ ]/b' \
2020 -e '/^#[ ]*endif/b' \
2028 (doextract ? "-e '1,/^#/d\n'" : ""),
2030 scriptname, cpp, sv, CPPMINUS);
2032 #ifdef IAMSUID /* actually, this is caught earlier */
2033 if (euid != uid && !euid) { /* if running suidperl */
2035 (void)seteuid(uid); /* musn't stay setuid root */
2038 (void)setreuid((Uid_t)-1, uid);
2040 #ifdef HAS_SETRESUID
2041 (void)setresuid((Uid_t)-1, uid, (Uid_t)-1);
2047 if (geteuid() != uid)
2048 croak("Can't do seteuid!\n");
2050 #endif /* IAMSUID */
2051 rsfp = PerlProc_popen(SvPVX(cmd), "r");
2055 else if (!*scriptname) {
2056 forbid_setid("program input from stdin");
2057 rsfp = PerlIO_stdin();
2060 rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
2061 #if defined(HAS_FCNTL) && defined(F_SETFD)
2063 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
2071 #ifndef IAMSUID /* in case script is not readable before setuid */
2072 if (euid && Stat(SvPVX(GvSV(curcop->cop_filegv)),&statbuf) >= 0 &&
2073 statbuf.st_mode & (S_ISUID|S_ISGID)) {
2075 PerlProc_execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
2076 croak("Can't do setuid\n");
2080 croak("Can't open perl script \"%s\": %s\n",
2081 SvPVX(GvSV(curcop->cop_filegv)), Strerror(errno));
2086 validate_suid(char *validarg, char *scriptname)
2090 /* do we need to emulate setuid on scripts? */
2092 /* This code is for those BSD systems that have setuid #! scripts disabled
2093 * in the kernel because of a security problem. Merely defining DOSUID
2094 * in perl will not fix that problem, but if you have disabled setuid
2095 * scripts in the kernel, this will attempt to emulate setuid and setgid
2096 * on scripts that have those now-otherwise-useless bits set. The setuid
2097 * root version must be called suidperl or sperlN.NNN. If regular perl
2098 * discovers that it has opened a setuid script, it calls suidperl with
2099 * the same argv that it had. If suidperl finds that the script it has
2100 * just opened is NOT setuid root, it sets the effective uid back to the
2101 * uid. We don't just make perl setuid root because that loses the
2102 * effective uid we had before invoking perl, if it was different from the
2105 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
2106 * be defined in suidperl only. suidperl must be setuid root. The
2107 * Configure script will set this up for you if you want it.
2114 if (PerlLIO_fstat(PerlIO_fileno(rsfp),&statbuf) < 0) /* normal stat is insecure */
2115 croak("Can't stat script \"%s\"",origfilename);
2116 if (fdscript < 0 && statbuf.st_mode & (S_ISUID|S_ISGID)) {
2120 #ifndef HAS_SETREUID
2121 /* On this access check to make sure the directories are readable,
2122 * there is actually a small window that the user could use to make
2123 * filename point to an accessible directory. So there is a faint
2124 * chance that someone could execute a setuid script down in a
2125 * non-accessible directory. I don't know what to do about that.
2126 * But I don't think it's too important. The manual lies when
2127 * it says access() is useful in setuid programs.
2129 if (PerlLIO_access(SvPVX(GvSV(curcop->cop_filegv)),1)) /*double check*/
2130 croak("Permission denied");
2132 /* If we can swap euid and uid, then we can determine access rights
2133 * with a simple stat of the file, and then compare device and
2134 * inode to make sure we did stat() on the same file we opened.
2135 * Then we just have to make sure he or she can execute it.
2138 struct stat tmpstatbuf;
2142 setreuid(euid,uid) < 0
2145 setresuid(euid,uid,(Uid_t)-1) < 0
2148 || getuid() != euid || geteuid() != uid)
2149 croak("Can't swap uid and euid"); /* really paranoid */
2150 if (Stat(SvPVX(GvSV(curcop->cop_filegv)),&tmpstatbuf) < 0)
2151 croak("Permission denied"); /* testing full pathname here */
2152 if (tmpstatbuf.st_dev != statbuf.st_dev ||
2153 tmpstatbuf.st_ino != statbuf.st_ino) {
2154 (void)PerlIO_close(rsfp);
2155 if (rsfp = PerlProc_popen("/bin/mail root","w")) { /* heh, heh */
2157 "User %ld tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
2158 (Filename of set-id script was %s, uid %ld gid %ld.)\n\nSincerely,\nperl\n",
2159 (long)uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
2160 (long)statbuf.st_dev, (long)statbuf.st_ino,
2161 SvPVX(GvSV(curcop->cop_filegv)),
2162 (long)statbuf.st_uid, (long)statbuf.st_gid);
2163 (void)PerlProc_pclose(rsfp);
2165 croak("Permission denied\n");
2169 setreuid(uid,euid) < 0
2171 # if defined(HAS_SETRESUID)
2172 setresuid(uid,euid,(Uid_t)-1) < 0
2175 || getuid() != uid || geteuid() != euid)
2176 croak("Can't reswap uid and euid");
2177 if (!cando(S_IXUSR,FALSE,&statbuf)) /* can real uid exec? */
2178 croak("Permission denied\n");
2180 #endif /* HAS_SETREUID */
2181 #endif /* IAMSUID */
2183 if (!S_ISREG(statbuf.st_mode))
2184 croak("Permission denied");
2185 if (statbuf.st_mode & S_IWOTH)
2186 croak("Setuid/gid script is writable by world");
2187 doswitches = FALSE; /* -s is insecure in suid */
2189 if (sv_gets(linestr, rsfp, 0) == Nullch ||
2190 strnNE(SvPV(linestr,na),"#!",2) ) /* required even on Sys V */
2191 croak("No #! line");
2192 s = SvPV(linestr,na)+2;
2194 while (!isSPACE(*s)) s++;
2195 for (s2 = s; (s2 > SvPV(linestr,na)+2 &&
2196 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
2197 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
2198 croak("Not a perl script");
2199 while (*s == ' ' || *s == '\t') s++;
2201 * #! arg must be what we saw above. They can invoke it by
2202 * mentioning suidperl explicitly, but they may not add any strange
2203 * arguments beyond what #! says if they do invoke suidperl that way.
2205 len = strlen(validarg);
2206 if (strEQ(validarg," PHOOEY ") ||
2207 strnNE(s,validarg,len) || !isSPACE(s[len]))
2208 croak("Args must match #! line");
2211 if (euid != uid && (statbuf.st_mode & S_ISUID) &&
2212 euid == statbuf.st_uid)
2214 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2215 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2216 #endif /* IAMSUID */
2218 if (euid) { /* oops, we're not the setuid root perl */
2219 (void)PerlIO_close(rsfp);
2222 PerlProc_execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
2224 croak("Can't do setuid\n");
2227 if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid) {
2229 (void)setegid(statbuf.st_gid);
2232 (void)setregid((Gid_t)-1,statbuf.st_gid);
2234 #ifdef HAS_SETRESGID
2235 (void)setresgid((Gid_t)-1,statbuf.st_gid,(Gid_t)-1);
2237 setgid(statbuf.st_gid);
2241 if (getegid() != statbuf.st_gid)
2242 croak("Can't do setegid!\n");
2244 if (statbuf.st_mode & S_ISUID) {
2245 if (statbuf.st_uid != euid)
2247 (void)seteuid(statbuf.st_uid); /* all that for this */
2250 (void)setreuid((Uid_t)-1,statbuf.st_uid);
2252 #ifdef HAS_SETRESUID
2253 (void)setresuid((Uid_t)-1,statbuf.st_uid,(Uid_t)-1);
2255 setuid(statbuf.st_uid);
2259 if (geteuid() != statbuf.st_uid)
2260 croak("Can't do seteuid!\n");
2262 else if (uid) { /* oops, mustn't run as root */
2264 (void)seteuid((Uid_t)uid);
2267 (void)setreuid((Uid_t)-1,(Uid_t)uid);
2269 #ifdef HAS_SETRESUID
2270 (void)setresuid((Uid_t)-1,(Uid_t)uid,(Uid_t)-1);
2276 if (geteuid() != uid)
2277 croak("Can't do seteuid!\n");
2280 if (!cando(S_IXUSR,TRUE,&statbuf))
2281 croak("Permission denied\n"); /* they can't do this */
2284 else if (preprocess)
2285 croak("-P not allowed for setuid/setgid script\n");
2286 else if (fdscript >= 0)
2287 croak("fd script not allowed in suidperl\n");
2289 croak("Script is not setuid/setgid in suidperl\n");
2291 /* We absolutely must clear out any saved ids here, so we */
2292 /* exec the real perl, substituting fd script for scriptname. */
2293 /* (We pass script name as "subdir" of fd, which perl will grok.) */
2294 PerlIO_rewind(rsfp);
2295 PerlLIO_lseek(PerlIO_fileno(rsfp),(Off_t)0,0); /* just in case rewind didn't */
2296 for (which = 1; origargv[which] && origargv[which] != scriptname; which++) ;
2297 if (!origargv[which])
2298 croak("Permission denied");
2299 origargv[which] = savepv(form("/dev/fd/%d/%s",
2300 PerlIO_fileno(rsfp), origargv[which]));
2301 #if defined(HAS_FCNTL) && defined(F_SETFD)
2302 fcntl(PerlIO_fileno(rsfp),F_SETFD,0); /* ensure no close-on-exec */
2304 PerlProc_execv(form("%s/perl%s", BIN_EXP, patchlevel), origargv); /* try again */
2305 croak("Can't do setuid\n");
2306 #endif /* IAMSUID */
2308 if (euid != uid || egid != gid) { /* (suidperl doesn't exist, in fact) */
2309 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
2311 PerlLIO_fstat(PerlIO_fileno(rsfp),&statbuf); /* may be either wrapped or real suid */
2312 if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
2314 (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
2317 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2318 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2319 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
2320 /* not set-id, must be wrapped */
2326 find_beginning(void)
2328 register char *s, *s2;
2330 /* skip forward in input to the real script? */
2334 if ((s = sv_gets(linestr, rsfp, 0)) == Nullch)
2335 croak("No Perl script found in input\n");
2336 if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
2337 PerlIO_ungetc(rsfp, '\n'); /* to keep line count right */
2339 while (*s && !(isSPACE (*s) || *s == '#')) s++;
2341 while (*s == ' ' || *s == '\t') s++;
2343 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
2344 if (strnEQ(s2-4,"perl",4))
2346 while (s = moreswitches(s)) ;
2348 if (cddir && PerlDir_chdir(cddir) < 0)
2349 croak("Can't chdir to %s",cddir);
2357 uid = (int)getuid();
2358 euid = (int)geteuid();
2359 gid = (int)getgid();
2360 egid = (int)getegid();
2365 tainting |= (uid && (euid != uid || egid != gid));
2369 forbid_setid(char *s)
2372 croak("No %s allowed while running setuid", s);
2374 croak("No %s allowed while running setgid", s);
2381 curstash = debstash;
2382 dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
2384 DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
2385 DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
2386 DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
2387 DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
2388 sv_setiv(DBsingle, 0);
2389 DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
2390 sv_setiv(DBtrace, 0);
2391 DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
2392 sv_setiv(DBsignal, 0);
2393 curstash = defstash;
2397 init_stacks(ARGSproto)
2400 mainstack = curstack; /* remember in case we switch stacks */
2401 AvREAL_off(curstack); /* not a real array */
2402 av_extend(curstack,127);
2404 stack_base = AvARRAY(curstack);
2405 stack_sp = stack_base;
2406 stack_max = stack_base + 127;
2408 cxstack_max = 8192 / sizeof(PERL_CONTEXT) - 2; /* Use most of 8K. */
2409 New(50,cxstack,cxstack_max + 1,PERL_CONTEXT);
2412 New(50,tmps_stack,128,SV*);
2418 * The following stacks almost certainly should be per-interpreter,
2419 * but for now they're not. XXX
2423 markstack_ptr = markstack;
2425 New(54,markstack,64,I32);
2426 markstack_ptr = markstack;
2427 markstack_max = markstack + 64;
2433 New(54,scopestack,32,I32);
2435 scopestack_max = 32;
2441 New(54,savestack,128,ANY);
2443 savestack_max = 128;
2449 New(54,retstack,16,OP*);
2460 Safefree(tmps_stack);
2467 static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
2476 subname = newSVpv("main",4);
2480 init_predump_symbols(void)
2486 sv_setpvn(perl_get_sv("\"", TRUE), " ", 1);
2487 stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
2488 GvMULTI_on(stdingv);
2489 IoIFP(GvIOp(stdingv)) = PerlIO_stdin();
2490 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
2492 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(stdingv));
2494 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
2496 IoOFP(GvIOp(tmpgv)) = IoIFP(GvIOp(tmpgv)) = PerlIO_stdout();
2498 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
2500 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(defoutgv));
2502 othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
2503 GvMULTI_on(othergv);
2504 IoOFP(GvIOp(othergv)) = IoIFP(GvIOp(othergv)) = PerlIO_stderr();
2505 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
2507 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(othergv));
2509 statname = NEWSV(66,0); /* last filename we did stat on */
2512 osname = savepv(OSNAME);
2516 init_postdump_symbols(register int argc, register char **argv, register char **env)
2523 argc--,argv++; /* skip name of script */
2525 for (; argc > 0 && **argv == '-'; argc--,argv++) {
2528 if (argv[0][1] == '-') {
2532 if (s = strchr(argv[0], '=')) {
2534 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
2537 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
2540 toptarget = NEWSV(0,0);
2541 sv_upgrade(toptarget, SVt_PVFM);
2542 sv_setpvn(toptarget, "", 0);
2543 bodytarget = NEWSV(0,0);
2544 sv_upgrade(bodytarget, SVt_PVFM);
2545 sv_setpvn(bodytarget, "", 0);
2546 formtarget = bodytarget;
2549 if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
2550 sv_setpv(GvSV(tmpgv),origfilename);
2551 magicname("0", "0", 1);
2553 if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
2554 sv_setpv(GvSV(tmpgv),origargv[0]);
2555 if (argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
2557 (void)gv_AVadd(argvgv);
2558 av_clear(GvAVn(argvgv));
2559 for (; argc > 0; argc--,argv++) {
2560 av_push(GvAVn(argvgv),newSVpv(argv[0],0));
2563 if (envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
2567 hv_magic(hv, envgv, 'E');
2568 #ifndef VMS /* VMS doesn't have environ array */
2569 /* Note that if the supplied env parameter is actually a copy
2570 of the global environ then it may now point to free'd memory
2571 if the environment has been modified since. To avoid this
2572 problem we treat env==NULL as meaning 'use the default'
2577 environ[0] = Nullch;
2578 for (; *env; env++) {
2579 if (!(s = strchr(*env,'=')))
2582 #if defined(WIN32) || defined(MSDOS)
2585 sv = newSVpv(s--,0);
2586 (void)hv_store(hv, *env, s - *env, sv, 0);
2588 #if defined(__BORLANDC__) && defined(USE_WIN32_RTL_ENV)
2589 /* Sins of the RTL. See note in my_setenv(). */
2590 (void)PerlEnv_putenv(savepv(*env));
2594 #ifdef DYNAMIC_ENV_FETCH
2595 HvNAME(hv) = savepv(ENV_HV_NAME);
2599 if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
2600 sv_setiv(GvSV(tmpgv), (IV)getpid());
2609 s = PerlEnv_getenv("PERL5LIB");
2613 incpush(PerlEnv_getenv("PERLLIB"), FALSE);
2615 /* Treat PERL5?LIB as a possible search list logical name -- the
2616 * "natural" VMS idiom for a Unix path string. We allow each
2617 * element to be a set of |-separated directories for compatibility.
2621 if (my_trnlnm("PERL5LIB",buf,0))
2622 do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
2624 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE);
2628 /* Use the ~-expanded versions of APPLLIB (undocumented),
2629 ARCHLIB PRIVLIB SITEARCH and SITELIB
2632 incpush(APPLLIB_EXP, FALSE);
2636 incpush(ARCHLIB_EXP, FALSE);
2639 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
2641 incpush(PRIVLIB_EXP, FALSE);
2644 incpush(SITEARCH_EXP, FALSE);
2647 incpush(SITELIB_EXP, FALSE);
2650 incpush(".", FALSE);
2654 # define PERLLIB_SEP ';'
2657 # define PERLLIB_SEP '|'
2659 # define PERLLIB_SEP ':'
2662 #ifndef PERLLIB_MANGLE
2663 # define PERLLIB_MANGLE(s,n) (s)
2667 incpush(char *p, int addsubdirs)
2669 SV *subdir = Nullsv;
2670 static char *archpat_auto;
2676 subdir = NEWSV(55,0);
2677 if (!archpat_auto) {
2678 STRLEN len = (sizeof(ARCHNAME) + strlen(patchlevel)
2679 + sizeof("//auto"));
2680 New(55, archpat_auto, len, char);
2681 sprintf(archpat_auto, "/%s/%s/auto", ARCHNAME, patchlevel);
2683 for (len = sizeof(ARCHNAME) + 2;
2684 archpat_auto[len] != '\0' && archpat_auto[len] != '/'; len++)
2685 if (archpat_auto[len] == '.') archpat_auto[len] = '_';
2690 /* Break at all separators */
2692 SV *libdir = NEWSV(55,0);
2695 /* skip any consecutive separators */
2696 while ( *p == PERLLIB_SEP ) {
2697 /* Uncomment the next line for PATH semantics */
2698 /* av_push(GvAVn(incgv), newSVpv(".", 1)); */
2702 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
2703 sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
2708 sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
2709 p = Nullch; /* break out */
2713 * BEFORE pushing libdir onto @INC we may first push version- and
2714 * archname-specific sub-directories.
2717 struct stat tmpstatbuf;
2722 if ((unix = tounixspec_ts(SvPV(libdir,na),Nullch)) != Nullch) {
2724 while (unix[len-1] == '/') len--; /* Cosmetic */
2725 sv_usepvn(libdir,unix,len);
2728 PerlIO_printf(PerlIO_stderr(),
2729 "Failed to unixify @INC element \"%s\"\n",
2732 /* .../archname/version if -d .../archname/version/auto */
2733 sv_setsv(subdir, libdir);
2734 sv_catpv(subdir, archpat_auto);
2735 if (Stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2736 S_ISDIR(tmpstatbuf.st_mode))
2737 av_push(GvAVn(incgv),
2738 newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2740 /* .../archname if -d .../archname/auto */
2741 sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME),
2742 strlen(patchlevel) + 1, "", 0);
2743 if (Stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2744 S_ISDIR(tmpstatbuf.st_mode))
2745 av_push(GvAVn(incgv),
2746 newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2749 /* finally push this lib directory on the end of @INC */
2750 av_push(GvAVn(incgv), libdir);
2753 SvREFCNT_dec(subdir);
2757 static struct perl_thread *
2760 struct perl_thread *thr;
2763 Newz(53, thr, 1, struct perl_thread);
2764 curcop = &compiling;
2765 thr->cvcache = newHV();
2766 thr->threadsv = newAV();
2767 /* thr->threadsvp is set when find_threadsv is called */
2768 thr->specific = newAV();
2769 thr->errhv = newHV();
2770 thr->flags = THRf_R_JOINABLE;
2771 MUTEX_INIT(&thr->mutex);
2772 /* Handcraft thrsv similarly to mess_sv */
2773 New(53, thrsv, 1, SV);
2774 Newz(53, xpv, 1, XPV);
2775 SvFLAGS(thrsv) = SVt_PV;
2776 SvANY(thrsv) = (void*)xpv;
2777 SvREFCNT(thrsv) = 1 << 30; /* practically infinite */
2778 SvPVX(thrsv) = (char*)thr;
2779 SvCUR_set(thrsv, sizeof(thr));
2780 SvLEN_set(thrsv, sizeof(thr));
2781 *SvEND(thrsv) = '\0'; /* in the trailing_nul field */
2783 curcop = &compiling;
2786 MUTEX_LOCK(&threads_mutex);
2791 MUTEX_UNLOCK(&threads_mutex);
2793 #ifdef HAVE_THREAD_INTERN
2794 init_thread_intern(thr);
2797 #ifdef SET_THREAD_SELF
2798 SET_THREAD_SELF(thr);
2800 thr->self = pthread_self();
2801 #endif /* SET_THREAD_SELF */
2805 * These must come after the SET_THR because sv_setpvn does
2806 * SvTAINT and the taint fields require dTHR.
2808 toptarget = NEWSV(0,0);
2809 sv_upgrade(toptarget, SVt_PVFM);
2810 sv_setpvn(toptarget, "", 0);
2811 bodytarget = NEWSV(0,0);
2812 sv_upgrade(bodytarget, SVt_PVFM);
2813 sv_setpvn(bodytarget, "", 0);
2814 formtarget = bodytarget;
2815 thr->errsv = newSVpv("", 0);
2816 (void) find_threadsv("@"); /* Ensure $@ is initialised early */
2819 #endif /* USE_THREADS */
2822 call_list(I32 oldscope, AV *list)
2825 line_t oldline = curcop->cop_line;
2830 while (AvFILL(list) >= 0) {
2831 CV *cv = (CV*)av_shift(list);
2840 perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
2841 (void)SvPV(atsv, len);
2844 curcop = &compiling;
2845 curcop->cop_line = oldline;
2846 if (list == beginav)
2847 sv_catpv(atsv, "BEGIN failed--compilation aborted");
2849 sv_catpv(atsv, "END failed--cleanup aborted");
2850 while (scopestack_ix > oldscope)
2852 croak("%s", SvPVX(atsv));
2860 /* my_exit() was called */
2861 while (scopestack_ix > oldscope)
2864 curstash = defstash;
2866 call_list(oldscope, endav);
2868 curcop = &compiling;
2869 curcop->cop_line = oldline;
2871 if (list == beginav)
2872 croak("BEGIN failed--compilation aborted");
2874 croak("END failed--cleanup aborted");
2880 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
2885 curcop = &compiling;
2886 curcop->cop_line = oldline;
2899 DEBUG_L(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
2900 thr, (unsigned long) status));
2901 #endif /* USE_THREADS */
2910 STATUS_NATIVE_SET(status);
2917 my_failure_exit(void)
2920 if (vaxc$errno & 1) {
2921 if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
2922 STATUS_NATIVE_SET(44);
2925 if (!vaxc$errno && errno) /* unlikely */
2926 STATUS_NATIVE_SET(44);
2928 STATUS_NATIVE_SET(vaxc$errno);
2932 STATUS_POSIX_SET(errno);
2933 else if (STATUS_POSIX == 0)
2934 STATUS_POSIX_SET(255);
2943 register PERL_CONTEXT *cx;
2952 (void)UNLINK(e_tmpname);
2953 Safefree(e_tmpname);
2957 if (cxstack_ix >= 0) {