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; \
66 static void find_beginning _((void));
67 static void forbid_setid _((char *));
68 static void incpush _((char *, int));
69 static void init_ids _((void));
70 static void init_debugger _((void));
71 static void init_lexer _((void));
72 static void init_main_stash _((void));
74 static struct perl_thread * init_main_thread _((void));
75 #endif /* USE_THREADS */
76 static void init_perllib _((void));
77 static void init_postdump_symbols _((int, char **, char **));
78 static void init_predump_symbols _((void));
79 static void my_exit_jump _((void)) __attribute__((noreturn));
80 static void nuke_stacks _((void));
81 static void open_script _((char *, bool, SV *));
82 static void usage _((char *));
83 static void validate_suid _((char *, char*));
86 static int fdscript = -1;
88 #if defined(DEBUGGING) && defined(USE_THREADS) && defined(__linux__)
89 #include <asm/sigcontext.h>
91 catch_sigsegv(int signo, struct sigcontext_struct sc)
93 PerlProc_signal(SIGSEGV, SIG_DFL);
94 fprintf(stderr, "Segmentation fault dereferencing 0x%lx\n"
95 "return_address = 0x%lx, eip = 0x%lx\n",
96 sc.cr2, __builtin_return_address(0), sc.eip);
97 fprintf(stderr, "thread = 0x%lx\n", (unsigned long)THR);
102 CPerlObj* perl_alloc(IPerlMem* ipM, IPerlEnv* ipE, IPerlStdIO* ipStd,
103 IPerlLIO* ipLIO, IPerlDir* ipD, IPerlSock* ipS, IPerlProc* ipP)
105 CPerlObj* pPerl = new(ipM) CPerlObj(ipM, ipE, ipStd, ipLIO, ipD, ipS, ipP);
115 PerlInterpreter *sv_interp;
118 New(53, sv_interp, 1, PerlInterpreter);
125 CPerlObj::perl_construct(void)
127 perl_construct(register PerlInterpreter *sv_interp)
133 struct perl_thread *thr;
134 #endif /* FAKE_THREADS */
135 #endif /* USE_THREADS */
138 if (!(curinterp = sv_interp))
143 Zero(sv_interp, 1, PerlInterpreter);
146 /* Init the real globals (and main thread)? */
151 #ifdef ALLOC_THREAD_KEY
154 if (pthread_key_create(&thr_key, 0))
155 croak("panic: pthread_key_create");
157 MUTEX_INIT(&sv_mutex);
159 * Safe to use basic SV functions from now on (though
160 * not things like mortals or tainting yet).
162 MUTEX_INIT(&eval_mutex);
163 COND_INIT(&eval_cond);
164 MUTEX_INIT(&threads_mutex);
165 COND_INIT(&nthreads_cond);
168 MUTEX_INIT(&sort_mutex);
171 thr = init_main_thread();
172 #endif /* USE_THREADS */
174 linestr = NEWSV(65,80);
175 sv_upgrade(linestr,SVt_PVIV);
177 if (!SvREADONLY(&sv_undef)) {
178 SvREADONLY_on(&sv_undef);
182 SvREADONLY_on(&sv_no);
184 sv_setpv(&sv_yes,Yes);
186 SvREADONLY_on(&sv_yes);
189 nrs = newSVpv("\n", 1);
190 rs = SvREFCNT_inc(nrs);
194 /* sighandlerp = sighandler; */
196 sighandlerp = sighandler;
202 * There is no way we can refer to them from Perl so close them to save
203 * space. The other alternative would be to provide STDAUX and STDPRN
206 (void)fclose(stdaux);
207 (void)fclose(stdprn);
213 perl_destruct_level = 1;
215 if(perl_destruct_level > 0)
220 lex_state = LEX_NOTPARSING;
222 start_env.je_prev = NULL;
223 start_env.je_ret = -1;
224 start_env.je_mustcatch = TRUE;
225 top_env = &start_env;
228 SET_NUMERIC_STANDARD();
229 #if defined(SUBVERSION) && SUBVERSION > 0
230 sprintf(patchlevel, "%7.5f", (double) 5
231 + ((double) PATCHLEVEL / (double) 1000)
232 + ((double) SUBVERSION / (double) 100000));
234 sprintf(patchlevel, "%5.3f", (double) 5 +
235 ((double) PATCHLEVEL / (double) 1000));
238 #if defined(LOCAL_PATCH_COUNT)
239 localpatches = local_patches; /* For possible -v */
242 PerlIO_init(); /* Hook to IO system */
244 fdpid = newAV(); /* for remembering popen pids by fd */
248 New(51,debname,128,char);
249 New(52,debdelim,128,char);
257 CPerlObj::perl_destruct(void)
259 perl_destruct(register PerlInterpreter *sv_interp)
263 int destruct_level; /* 0=none, 1=full, 2=full with checks */
268 #endif /* USE_THREADS */
271 if (!(curinterp = sv_interp))
277 /* Pass 1 on any remaining threads: detach joinables, join zombies */
279 MUTEX_LOCK(&threads_mutex);
280 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
281 "perl_destruct: waiting for %d threads...\n",
283 for (t = thr->next; t != thr; t = t->next) {
284 MUTEX_LOCK(&t->mutex);
285 switch (ThrSTATE(t)) {
288 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
289 "perl_destruct: joining zombie %p\n", t));
290 ThrSETSTATE(t, THRf_DEAD);
291 MUTEX_UNLOCK(&t->mutex);
294 * The SvREFCNT_dec below may take a long time (e.g. av
295 * may contain an object scalar whose destructor gets
296 * called) so we have to unlock threads_mutex and start
299 MUTEX_UNLOCK(&threads_mutex);
301 SvREFCNT_dec((SV*)av);
302 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
303 "perl_destruct: joined zombie %p OK\n", t));
305 case THRf_R_JOINABLE:
306 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
307 "perl_destruct: detaching thread %p\n", t));
308 ThrSETSTATE(t, THRf_R_DETACHED);
310 * We unlock threads_mutex and t->mutex in the opposite order
311 * from which we locked them just so that DETACH won't
312 * deadlock if it panics. It's only a breach of good style
313 * not a bug since they are unlocks not locks.
315 MUTEX_UNLOCK(&threads_mutex);
317 MUTEX_UNLOCK(&t->mutex);
320 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
321 "perl_destruct: ignoring %p (state %u)\n",
323 MUTEX_UNLOCK(&t->mutex);
324 /* fall through and out */
327 /* We leave the above "Pass 1" loop with threads_mutex still locked */
329 /* Pass 2 on remaining threads: wait for the thread count to drop to one */
332 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
333 "perl_destruct: final wait for %d threads\n",
335 COND_WAIT(&nthreads_cond, &threads_mutex);
337 /* At this point, we're the last thread */
338 MUTEX_UNLOCK(&threads_mutex);
339 DEBUG_L(PerlIO_printf(PerlIO_stderr(), "perl_destruct: armageddon has arrived\n"));
340 MUTEX_DESTROY(&threads_mutex);
341 COND_DESTROY(&nthreads_cond);
342 #endif /* !defined(FAKE_THREADS) */
343 #endif /* USE_THREADS */
345 destruct_level = perl_destruct_level;
349 if (s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL")) {
351 if (destruct_level < i)
360 /* We must account for everything. */
362 /* Destroy the main CV and syntax tree */
364 curpad = AvARRAY(comppad);
369 SvREFCNT_dec(main_cv);
374 * Try to destruct global references. We do this first so that the
375 * destructors and destructees still exist. Some sv's might remain.
376 * Non-referenced objects are on their own.
383 /* unhook hooks which will soon be, or use, destroyed data */
384 SvREFCNT_dec(warnhook);
386 SvREFCNT_dec(diehook);
388 SvREFCNT_dec(parsehook);
391 if (destruct_level == 0){
393 DEBUG_P(debprofdump());
395 /* The exit() function will do everything that needs doing. */
399 /* loosen bonds of global variables */
402 (void)PerlIO_close(rsfp);
406 /* Filters for program text */
407 SvREFCNT_dec(rsfp_filters);
408 rsfp_filters = Nullav;
420 sawampersand = FALSE; /* must save all match strings */
421 sawstudy = FALSE; /* do fbm_instr on all strings */
436 /* magical thingies */
438 Safefree(ofs); /* $, */
441 Safefree(ors); /* $\ */
444 SvREFCNT_dec(nrs); /* $\ helper */
447 multiline = 0; /* $* */
449 SvREFCNT_dec(statname);
453 /* defgv, aka *_ should be taken care of elsewhere */
455 /* clean up after study() */
456 SvREFCNT_dec(lastscream);
458 Safefree(screamfirst);
460 Safefree(screamnext);
463 /* startup and shutdown function lists */
464 SvREFCNT_dec(beginav);
466 SvREFCNT_dec(initav);
471 /* temp stack during pp_sort() */
472 SvREFCNT_dec(sortstack);
475 /* shortcuts just get cleared */
485 /* reset so print() ends up where we expect */
488 /* Prepare to destruct main symbol table. */
495 if (destruct_level >= 2) {
496 if (scopestack_ix != 0)
497 warn("Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
498 (long)scopestack_ix);
499 if (savestack_ix != 0)
500 warn("Unbalanced saves: %ld more saves than restores\n",
502 if (tmps_floor != -1)
503 warn("Unbalanced tmps: %ld more allocs than frees\n",
504 (long)tmps_floor + 1);
505 if (cxstack_ix != -1)
506 warn("Unbalanced context: %ld more PUSHes than POPs\n",
507 (long)cxstack_ix + 1);
510 /* Now absolutely destruct everything, somehow or other, loops or no. */
512 SvFLAGS(strtab) |= SVTYPEMASK; /* don't clean out strtab now */
513 while (sv_count != 0 && sv_count != last_sv_count) {
514 last_sv_count = sv_count;
517 SvFLAGS(strtab) &= ~SVTYPEMASK;
518 SvFLAGS(strtab) |= SVt_PVHV;
520 /* Destruct the global string table. */
522 /* Yell and reset the HeVAL() slots that are still holding refcounts,
523 * so that sv_free() won't fail on them.
532 array = HvARRAY(strtab);
536 warn("Unbalanced string table refcount: (%d) for \"%s\"",
537 HeVAL(hent) - Nullsv, HeKEY(hent));
538 HeVAL(hent) = Nullsv;
548 SvREFCNT_dec(strtab);
551 warn("Scalars leaked: %ld\n", (long)sv_count);
555 /* No SVs have survived, need to clean out */
559 Safefree(origfilename);
561 hints = 0; /* Reset hints. Should hints be per-interpreter ? */
563 DEBUG_P(debprofdump());
565 MUTEX_DESTROY(&sort_mutex);
568 MUTEX_DESTROY(&sv_mutex);
569 MUTEX_DESTROY(&eval_mutex);
570 COND_DESTROY(&eval_cond);
572 /* As the penultimate thing, free the non-arena SV for thrsv */
573 Safefree(SvPVX(thrsv));
574 Safefree(SvANY(thrsv));
577 #endif /* USE_THREADS */
579 /* As the absolutely last thing, free the non-arena SV for mess() */
582 /* we know that type >= SVt_PV */
584 Safefree(SvPVX(mess_sv));
585 Safefree(SvANY(mess_sv));
593 CPerlObj::perl_free(void)
595 perl_free(PerlInterpreter *sv_interp)
600 if (!(curinterp = sv_interp))
608 CPerlObj::perl_parse(void (*xsinit) (CPerlObj*), int argc, char **argv, char **env)
610 perl_parse(PerlInterpreter *sv_interp, void (*xsinit) (void), int argc, char **argv, char **env)
616 char *scriptname = NULL;
617 VOL bool dosearch = FALSE;
624 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
627 croak("suidperl is no longer needed since the kernel can now execute\n\
628 setuid perl scripts securely.\n");
633 if (!(curinterp = sv_interp))
637 #if defined(NeXT) && defined(__DYNAMIC__)
638 _dyld_lookup_and_bind
639 ("__environ", (unsigned long *) &environ_pointer, NULL);
644 #ifndef VMS /* VMS doesn't have environ array */
645 origenviron = environ;
651 /* Come here if running an undumped a.out. */
653 origfilename = savepv(argv[0]);
655 cxstack_ix = -1; /* start label stack again */
657 init_postdump_symbols(argc,argv,env);
662 curpad = AvARRAY(comppad);
667 SvREFCNT_dec(main_cv);
671 oldscope = scopestack_ix;
679 /* my_exit() was called */
680 while (scopestack_ix > oldscope)
685 call_list(oldscope, endav);
687 return STATUS_NATIVE_EXPORT;
690 PerlIO_printf(PerlIO_stderr(), "panic: top_env\n");
694 sv_setpvn(linestr,"",0);
695 sv = newSVpv("",0); /* first used for -I flags */
699 for (argc--,argv++; argc > 0; argc--,argv++) {
700 if (argv[0][0] != '-' || !argv[0][1])
704 validarg = " PHOOEY ";
729 if (s = moreswitches(s))
739 if (euid != uid || egid != gid)
740 croak("No -e allowed in setuid scripts");
742 e_tmpname = savepv(TMPPATH);
743 (void)PerlLIO_mktemp(e_tmpname);
745 croak("Can't mktemp()");
746 e_fp = PerlIO_open(e_tmpname,"w");
748 croak("Cannot open temporary file");
753 PerlIO_puts(e_fp,argv[1]);
757 croak("No code specified for -e");
758 (void)PerlIO_putc(e_fp,'\n');
760 case 'I': /* -I handled both here and in moreswitches() */
762 if (!*++s && (s=argv[1]) != Nullch) {
765 while (s && isSPACE(*s))
769 for (e = s; *e && !isSPACE(*e); e++) ;
776 } /* XXX else croak? */
790 preambleav = newAV();
791 av_push(preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
793 Sv = newSVpv("print myconfig();",0);
795 sv_catpv(Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
797 sv_catpv(Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
799 #if defined(DEBUGGING) || defined(NO_EMBED) || defined(MULTIPLICITY)
800 sv_catpv(Sv,"\" Compile-time options:");
802 sv_catpv(Sv," DEBUGGING");
805 sv_catpv(Sv," NO_EMBED");
808 sv_catpv(Sv," MULTIPLICITY");
810 sv_catpv(Sv,"\\n\",");
812 #if defined(LOCAL_PATCH_COUNT)
813 if (LOCAL_PATCH_COUNT > 0) {
815 sv_catpv(Sv,"\" Locally applied patches:\\n\",");
816 for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
818 sv_catpvf(Sv,"\" \\t%s\\n\",",localpatches[i]);
822 sv_catpvf(Sv,"\" Built under %s\\n\"",OSNAME);
825 sv_catpvf(Sv,",\" Compiled at %s %s\\n\"",__DATE__,__TIME__);
827 sv_catpvf(Sv,",\" Compiled on %s\\n\"",__DATE__);
832 @env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; \
833 print \" \\%ENV:\\n @env\\n\" if @env; \
834 print \" \\@INC:\\n @INC\\n\";");
837 Sv = newSVpv("config_vars(qw(",0);
842 av_push(preambleav, Sv);
843 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
854 if (!*++s || isSPACE(*s)) {
858 /* catch use of gnu style long options */
859 if (strEQ(s, "version")) {
863 if (strEQ(s, "help")) {
870 croak("Unrecognized switch: -%s (-h will show valid options)",s);
875 if (!tainting && (s = PerlEnv_getenv("PERL5OPT"))) {
886 if (!strchr("DIMUdmw", *s))
887 croak("Illegal switch in PERL5OPT: -%c", *s);
893 scriptname = argv[0];
895 if (PerlIO_flush(e_fp) || PerlIO_error(e_fp) || PerlIO_close(e_fp)) {
897 warn("Did you forget to compile with -DMULTIPLICITY?");
899 croak("Can't write to temp file for -e: %s", Strerror(errno));
903 scriptname = e_tmpname;
905 else if (scriptname == Nullch) {
907 if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) )
915 open_script(scriptname,dosearch,sv);
917 validate_suid(validarg, scriptname);
922 main_cv = compcv = (CV*)NEWSV(1104,0);
923 sv_upgrade((SV *)compcv, SVt_PVCV);
927 av_push(comppad, Nullsv);
928 curpad = AvARRAY(comppad);
929 comppad_name = newAV();
930 comppad_name_fill = 0;
931 min_intro_pending = 0;
934 av_store(comppad_name, 0, newSVpv("@_", 2));
935 curpad[0] = (SV*)newAV();
936 SvPADMY_on(curpad[0]); /* XXX Needed? */
938 New(666, CvMUTEXP(compcv), 1, perl_mutex);
939 MUTEX_INIT(CvMUTEXP(compcv));
940 #endif /* USE_THREADS */
942 comppadlist = newAV();
943 AvREAL_off(comppadlist);
944 av_store(comppadlist, 0, (SV*)comppad_name);
945 av_store(comppadlist, 1, (SV*)comppad);
946 CvPADLIST(compcv) = comppadlist;
948 boot_core_UNIVERSAL();
950 (*xsinit)(THIS); /* in case linked C routines want magical variables */
951 #if defined(VMS) || defined(WIN32) || defined(DJGPP)
955 #if defined(DEBUGGING) && defined(USE_THREADS) && defined(__linux__)
956 DEBUG_L(PerlProc_signal(SIGSEGV, (void(*)(int))catch_sigsegv););
959 init_predump_symbols();
961 init_postdump_symbols(argc,argv,env);
965 /* now parse the script */
967 SETERRNO(0,SS$_NORMAL);
969 if (yyparse() || error_count) {
971 croak("%s had compilation errors.\n", origfilename);
973 croak("Execution of %s aborted due to compilation errors.\n",
977 curcop->cop_line = 0;
981 (void)UNLINK(e_tmpname);
986 /* now that script is parsed, we can modify record separator */
988 rs = SvREFCNT_inc(nrs);
990 sv_setsv(*av_fetch(thr->threadsv, find_threadsv("/"), FALSE), rs);
992 sv_setsv(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), rs);
993 #endif /* USE_THREADS */
1004 if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
1005 dump_mstats("after compilation:");
1016 CPerlObj::perl_run(void)
1018 perl_run(PerlInterpreter *sv_interp)
1027 if (!(curinterp = sv_interp))
1031 oldscope = scopestack_ix;
1036 cxstack_ix = -1; /* start context stack again */
1039 /* my_exit() was called */
1040 while (scopestack_ix > oldscope)
1043 curstash = defstash;
1045 call_list(oldscope, endav);
1047 if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
1048 dump_mstats("after execution: ");
1051 return STATUS_NATIVE_EXPORT;
1054 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
1059 if (curstack != mainstack) {
1061 SWITCHSTACK(curstack, mainstack);
1066 DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
1067 sawampersand ? "Enabling" : "Omitting"));
1070 DEBUG_x(dump_all());
1071 DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
1073 DEBUG_L(PerlIO_printf(Perl_debug_log, "main thread is 0x%lx\n",
1074 (unsigned long) thr));
1075 #endif /* USE_THREADS */
1078 PerlIO_printf(PerlIO_stderr(), "%s syntax OK\n", origfilename);
1081 if (PERLDB_SINGLE && DBsingle)
1082 sv_setiv(DBsingle, 1);
1084 call_list(oldscope, initav);
1094 else if (main_start) {
1095 CvDEPTH(main_cv) = 1;
1106 perl_get_sv(char *name, I32 create)
1110 if (name[1] == '\0' && !isALPHA(name[0])) {
1111 PADOFFSET tmp = find_threadsv(name);
1112 if (tmp != NOT_IN_PAD) {
1114 return *av_fetch(thr->threadsv, tmp, FALSE);
1117 #endif /* USE_THREADS */
1118 gv = gv_fetchpv(name, create, SVt_PV);
1125 perl_get_av(char *name, I32 create)
1127 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
1136 perl_get_hv(char *name, I32 create)
1138 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
1147 perl_get_cv(char *name, I32 create)
1149 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
1150 if (create && !GvCVu(gv))
1151 return newSUB(start_subparse(FALSE, 0),
1152 newSVOP(OP_CONST, 0, newSVpv(name,0)),
1160 /* Be sure to refetch the stack pointer after calling these routines. */
1163 perl_call_argv(char *sub_name, I32 flags, register char **argv)
1165 /* See G_* flags in cop.h */
1166 /* null terminated arg list */
1173 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
1178 return perl_call_pv(sub_name, flags);
1182 perl_call_pv(char *sub_name, I32 flags)
1183 /* name of the subroutine */
1184 /* See G_* flags in cop.h */
1186 return perl_call_sv((SV*)perl_get_cv(sub_name, TRUE), flags);
1190 perl_call_method(char *methname, I32 flags)
1191 /* name of the subroutine */
1192 /* See G_* flags in cop.h */
1198 XPUSHs(sv_2mortal(newSVpv(methname,0)));
1201 return perl_call_sv(*stack_sp--, flags);
1204 /* May be called with any of a CV, a GV, or an SV containing the name. */
1206 perl_call_sv(SV *sv, I32 flags)
1208 /* See G_* flags in cop.h */
1211 LOGOP myop; /* fake syntax tree node */
1217 bool oldcatch = CATCH_GET;
1222 if (flags & G_DISCARD) {
1227 Zero(&myop, 1, LOGOP);
1228 myop.op_next = Nullop;
1229 if (!(flags & G_NOARGS))
1230 myop.op_flags |= OPf_STACKED;
1231 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1232 (flags & G_ARRAY) ? OPf_WANT_LIST :
1237 EXTEND(stack_sp, 1);
1240 oldscope = scopestack_ix;
1242 if (PERLDB_SUB && curstash != debstash
1243 /* Handle first BEGIN of -d. */
1244 && (DBcv || (DBcv = GvCV(DBsub)))
1245 /* Try harder, since this may have been a sighandler, thus
1246 * curstash may be meaningless. */
1247 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != debstash))
1248 op->op_private |= OPpENTERSUB_DB;
1250 if (flags & G_EVAL) {
1251 cLOGOP->op_other = op;
1253 /* we're trying to emulate pp_entertry() here */
1255 register PERL_CONTEXT *cx;
1256 I32 gimme = GIMME_V;
1261 push_return(op->op_next);
1262 PUSHBLOCK(cx, CXt_EVAL, stack_sp);
1264 eval_root = op; /* Only needed so that goto works right. */
1267 if (flags & G_KEEPERR)
1282 /* my_exit() was called */
1283 curstash = defstash;
1287 croak("Callback called exit");
1296 stack_sp = stack_base + oldmark;
1297 if (flags & G_ARRAY)
1301 *++stack_sp = &sv_undef;
1309 if (op == (OP*)&myop)
1310 op = pp_entersub(ARGS);
1313 retval = stack_sp - (stack_base + oldmark);
1314 if ((flags & G_EVAL) && !(flags & G_KEEPERR))
1318 if (flags & G_EVAL) {
1319 if (scopestack_ix > oldscope) {
1323 register PERL_CONTEXT *cx;
1335 CATCH_SET(oldcatch);
1337 if (flags & G_DISCARD) {
1338 stack_sp = stack_base + oldmark;
1347 /* Eval a string. The G_EVAL flag is always assumed. */
1350 perl_eval_sv(SV *sv, I32 flags)
1352 /* See G_* flags in cop.h */
1355 UNOP myop; /* fake syntax tree node */
1357 I32 oldmark = sp - stack_base;
1364 if (flags & G_DISCARD) {
1372 EXTEND(stack_sp, 1);
1374 oldscope = scopestack_ix;
1376 if (!(flags & G_NOARGS))
1377 myop.op_flags = OPf_STACKED;
1378 myop.op_next = Nullop;
1379 myop.op_type = OP_ENTEREVAL;
1380 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1381 (flags & G_ARRAY) ? OPf_WANT_LIST :
1383 if (flags & G_KEEPERR)
1384 myop.op_flags |= OPf_SPECIAL;
1394 /* my_exit() was called */
1395 curstash = defstash;
1399 croak("Callback called exit");
1408 stack_sp = stack_base + oldmark;
1409 if (flags & G_ARRAY)
1413 *++stack_sp = &sv_undef;
1418 if (op == (OP*)&myop)
1419 op = pp_entereval(ARGS);
1422 retval = stack_sp - (stack_base + oldmark);
1423 if (!(flags & G_KEEPERR))
1428 if (flags & G_DISCARD) {
1429 stack_sp = stack_base + oldmark;
1439 perl_eval_pv(char *p, I32 croak_on_error)
1442 SV* sv = newSVpv(p, 0);
1445 perl_eval_sv(sv, G_SCALAR);
1452 if (croak_on_error && SvTRUE(ERRSV))
1453 croak(SvPVx(ERRSV, na));
1458 /* Require a module. */
1461 perl_require_pv(char *pv)
1463 SV* sv = sv_newmortal();
1464 sv_setpv(sv, "require '");
1467 perl_eval_sv(sv, G_DISCARD);
1471 magicname(char *sym, char *name, I32 namlen)
1475 if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
1476 sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
1480 usage(char *name) /* XXX move this out into a module ? */
1483 /* This message really ought to be max 23 lines.
1484 * Removed -h because the user already knows that opton. Others? */
1486 static char *usage_msg[] = {
1487 "-0[octal] specify record separator (\\0, if no argument)",
1488 "-a autosplit mode with -n or -p (splits $_ into @F)",
1489 "-c check syntax only (runs BEGIN and END blocks)",
1490 "-d[:debugger] run scripts under debugger",
1491 "-D[number/list] set debugging flags (argument is a bit mask or flags)",
1492 "-e 'command' one line of script. Several -e's allowed. Omit [programfile].",
1493 "-F/pattern/ split() pattern for autosplit (-a). The //'s are optional.",
1494 "-i[extension] edit <> files in place (make backup if extension supplied)",
1495 "-Idirectory specify @INC/#include directory (may be used more than once)",
1496 "-l[octal] enable line ending processing, specifies line terminator",
1497 "-[mM][-]module.. executes `use/no module...' before executing your script.",
1498 "-n assume 'while (<>) { ... }' loop around your script",
1499 "-p assume loop like -n but print line also like sed",
1500 "-P run script through C preprocessor before compilation",
1501 "-s enable some switch parsing for switches after script name",
1502 "-S look for the script using PATH environment variable",
1503 "-T turn on tainting checks",
1504 "-u dump core after parsing script",
1505 "-U allow unsafe operations",
1506 "-v print version number and patchlevel of perl",
1507 "-V[:variable] print perl configuration information",
1508 "-w TURN WARNINGS ON FOR COMPILATION OF YOUR SCRIPT. Recommended.",
1509 "-x[directory] strip off text before #!perl line and perhaps cd to directory",
1513 char **p = usage_msg;
1515 printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
1517 printf("\n %s", *p++);
1520 /* This routine handles any switches that can be given during run */
1523 moreswitches(char *s)
1532 rschar = scan_oct(s, 4, &numlen);
1534 if (rschar & ~((U8)~0))
1536 else if (!rschar && numlen >= 2)
1537 nrs = newSVpv("", 0);
1540 nrs = newSVpv(&ch, 1);
1546 splitstr = savepv(s + 1);
1560 if (*s == ':' || *s == '=') {
1561 my_setenv("PERL5DB", form("use Devel::%s;", ++s));
1565 perldb = PERLDB_ALL;
1572 if (isALPHA(s[1])) {
1573 static char debopts[] = "psltocPmfrxuLHXD";
1576 for (s++; *s && (d = strchr(debopts,*s)); s++)
1577 debug |= 1 << (d - debopts);
1581 for (s++; isDIGIT(*s); s++) ;
1583 debug |= 0x80000000;
1585 warn("Recompile perl with -DDEBUGGING to use -D switch\n");
1586 for (s++; isALNUM(*s); s++) ;
1596 inplace = savepv(s+1);
1598 for (s = inplace; *s && !isSPACE(*s); s++) ;
1602 case 'I': /* -I handled both here and in parse_perl() */
1605 while (*s && isSPACE(*s))
1609 for (e = s; *e && !isSPACE(*e); e++) ;
1610 p = savepvn(s, e-s);
1616 croak("No space allowed after -I");
1626 *ors = scan_oct(s, 3 + (*s == '0'), &numlen);
1636 ors = SvPV(nrs, orslen);
1637 ors = savepvn(ors, orslen);
1641 forbid_setid("-M"); /* XXX ? */
1644 forbid_setid("-m"); /* XXX ? */
1649 /* -M-foo == 'no foo' */
1650 if (*s == '-') { use = "no "; ++s; }
1651 sv = newSVpv(use,0);
1653 /* We allow -M'Module qw(Foo Bar)' */
1654 while(isALNUM(*s) || *s==':') ++s;
1656 sv_catpv(sv, start);
1657 if (*(start-1) == 'm') {
1659 croak("Can't use '%c' after -mname", *s);
1660 sv_catpv( sv, " ()");
1663 sv_catpvn(sv, start, s-start);
1664 sv_catpv(sv, " split(/,/,q{");
1669 if (preambleav == NULL)
1670 preambleav = newAV();
1671 av_push(preambleav, sv);
1674 croak("No space allowed after -%c", *(s-1));
1691 croak("Too late for \"-T\" option");
1703 #if defined(SUBVERSION) && SUBVERSION > 0
1704 printf("\nThis is perl, version 5.%03d_%02d built for %s",
1705 PATCHLEVEL, SUBVERSION, ARCHNAME);
1707 printf("\nThis is perl, version %s built for %s",
1708 patchlevel, ARCHNAME);
1710 #if defined(LOCAL_PATCH_COUNT)
1711 if (LOCAL_PATCH_COUNT > 0)
1712 printf("\n(with %d registered patch%s, see perl -V for more detail)",
1713 LOCAL_PATCH_COUNT, (LOCAL_PATCH_COUNT!=1) ? "es" : "");
1716 printf("\n\nCopyright 1987-1997, Larry Wall\n");
1718 printf("\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
1721 printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n");
1722 printf("djgpp v2 port (perl5004) by Laszlo Molnar, 1997\n");
1725 printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
1726 "Version 5 port Copyright (c) 1994-1997, Andreas Kaiser, Ilya Zakharevich\n");
1729 printf("atariST series port, ++jrb bammi@cadence.com\n");
1732 Perl may be copied only under the terms of either the Artistic License or the\n\
1733 GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n");
1741 if (s[1] == '-') /* Additional switches on #! line. */
1752 #ifdef ALTERNATE_SHEBANG
1753 case 'S': /* OS/2 needs -S on "extproc" line. */
1761 croak("Can't emulate -%.1s on #! line",s);
1766 /* compliments of Tom Christiansen */
1768 /* unexec() can be found in the Gnu emacs distribution */
1779 prog = newSVpv(BIN_EXP);
1780 sv_catpv(prog, "/perl");
1781 file = newSVpv(origfilename);
1782 sv_catpv(file, ".perldump");
1784 status = unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
1786 PerlIO_printf(PerlIO_stderr(), "unexec of %s into %s failed!\n",
1787 SvPVX(prog), SvPVX(file));
1788 PerlProc_exit(status);
1791 # include <lib$routines.h>
1792 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
1794 ABORT(); /* for use with undump */
1800 init_main_stash(void)
1805 /* Note that strtab is a rather special HV. Assumptions are made
1806 about not iterating on it, and not adding tie magic to it.
1807 It is properly deallocated in perl_destruct() */
1809 HvSHAREKEYS_off(strtab); /* mandatory */
1810 Newz(506,((XPVHV*)SvANY(strtab))->xhv_array,
1811 sizeof(HE*) * (((XPVHV*)SvANY(strtab))->xhv_max + 1), char);
1813 curstash = defstash = newHV();
1814 curstname = newSVpv("main",4);
1815 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
1816 SvREFCNT_dec(GvHV(gv));
1817 GvHV(gv) = (HV*)SvREFCNT_inc(defstash);
1819 HvNAME(defstash) = savepv("main");
1820 incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
1822 defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
1823 errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
1825 (void)form("%240s",""); /* Preallocate temp - for immediate signals. */
1826 sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */
1827 sv_setpvn(ERRSV, "", 0);
1828 curstash = defstash;
1829 compiling.cop_stash = defstash;
1830 debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
1831 globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
1832 /* We must init $/ before switches are processed. */
1833 sv_setpvn(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), "\n", 1);
1836 #ifdef CAN_PROTOTYPE
1838 open_script(char *scriptname, bool dosearch, SV *sv)
1841 open_script(scriptname,dosearch,sv)
1848 char *xfound = Nullch;
1849 char *xfailed = Nullch;
1853 #if defined(DOSISH) && !defined(OS2) && !defined(atarist)
1854 # define SEARCH_EXTS ".bat", ".cmd", NULL
1855 # define MAX_EXT_LEN 4
1858 # define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL
1859 # define MAX_EXT_LEN 4
1862 # define SEARCH_EXTS ".pl", ".com", NULL
1863 # define MAX_EXT_LEN 4
1865 /* additional extensions to try in each dir if scriptname not found */
1867 char *ext[] = { SEARCH_EXTS };
1868 int extidx = 0, i = 0;
1869 char *curext = Nullch;
1871 # define MAX_EXT_LEN 0
1875 * If dosearch is true and if scriptname does not contain path
1876 * delimiters, search the PATH for scriptname.
1878 * If SEARCH_EXTS is also defined, will look for each
1879 * scriptname{SEARCH_EXTS} whenever scriptname is not found
1880 * while searching the PATH.
1882 * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
1883 * proceeds as follows:
1884 * If DOSISH or VMSISH:
1885 * + look for ./scriptname{,.foo,.bar}
1886 * + search the PATH for scriptname{,.foo,.bar}
1889 * + look *only* in the PATH for scriptname{,.foo,.bar} (note
1890 * this will not look in '.' if it's not in the PATH)
1894 # ifdef ALWAYS_DEFTYPES
1895 len = strlen(scriptname);
1896 if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') {
1897 int hasdir, idx = 0, deftypes = 1;
1900 hasdir = !dosearch || (strpbrk(scriptname,":[</") != Nullch) ;
1903 int hasdir, idx = 0, deftypes = 1;
1906 hasdir = (strpbrk(scriptname,":[</") != Nullch) ;
1908 /* The first time through, just add SEARCH_EXTS to whatever we
1909 * already have, so we can check for default file types. */
1911 (!hasdir && my_trnlnm("DCL$PATH",tokenbuf,idx++)) )
1917 if ((strlen(tokenbuf) + strlen(scriptname)
1918 + MAX_EXT_LEN) >= sizeof tokenbuf)
1919 continue; /* don't search dir with too-long name */
1920 strcat(tokenbuf, scriptname);
1924 if (strEQ(scriptname, "-"))
1926 if (dosearch) { /* Look in '.' first. */
1927 char *cur = scriptname;
1929 if ((curext = strrchr(scriptname,'.'))) /* possible current ext */
1931 if (strEQ(ext[i++],curext)) {
1932 extidx = -1; /* already has an ext */
1937 DEBUG_p(PerlIO_printf(Perl_debug_log,
1938 "Looking for %s\n",cur));
1939 if (PerlLIO_stat(cur,&statbuf) >= 0) {
1947 if (cur == scriptname) {
1948 len = strlen(scriptname);
1949 if (len+MAX_EXT_LEN+1 >= sizeof(tokenbuf))
1951 cur = strcpy(tokenbuf, scriptname);
1953 } while (extidx >= 0 && ext[extidx] /* try an extension? */
1954 && strcpy(tokenbuf+len, ext[extidx++]));
1959 if (dosearch && !strchr(scriptname, '/')
1961 && !strchr(scriptname, '\\')
1963 && (s = PerlEnv_getenv("PATH"))) {
1966 bufend = s + strlen(s);
1967 while (s < bufend) {
1968 #if defined(atarist) || defined(DOSISH)
1973 && *s != ';'; len++, s++) {
1974 if (len < sizeof tokenbuf)
1977 if (len < sizeof tokenbuf)
1978 tokenbuf[len] = '\0';
1979 #else /* ! (atarist || DOSISH) */
1980 s = delimcpy(tokenbuf, tokenbuf + sizeof tokenbuf, s, bufend,
1983 #endif /* ! (atarist || DOSISH) */
1986 if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tokenbuf)
1987 continue; /* don't search dir with too-long name */
1989 #if defined(atarist) || defined(DOSISH)
1990 && tokenbuf[len - 1] != '/'
1991 && tokenbuf[len - 1] != '\\'
1994 tokenbuf[len++] = '/';
1995 if (len == 2 && tokenbuf[0] == '.')
1997 (void)strcpy(tokenbuf + len, scriptname);
2001 len = strlen(tokenbuf);
2002 if (extidx > 0) /* reset after previous loop */
2006 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tokenbuf));
2007 retval = PerlLIO_stat(tokenbuf,&statbuf);
2009 } while ( retval < 0 /* not there */
2010 && extidx>=0 && ext[extidx] /* try an extension? */
2011 && strcpy(tokenbuf+len, ext[extidx++])
2016 if (S_ISREG(statbuf.st_mode)
2017 && cando(S_IRUSR,TRUE,&statbuf)
2019 && cando(S_IXUSR,TRUE,&statbuf)
2023 xfound = tokenbuf; /* bingo! */
2027 xfailed = savepv(tokenbuf);
2030 if (!xfound && !seen_dot && !xfailed && (PerlLIO_stat(scriptname,&statbuf) < 0))
2032 seen_dot = 1; /* Disable message. */
2034 croak("Can't %s %s%s%s",
2035 (xfailed ? "execute" : "find"),
2036 (xfailed ? xfailed : scriptname),
2037 (xfailed ? "" : " on PATH"),
2038 (xfailed || seen_dot) ? "" : ", '.' not in PATH");
2041 scriptname = xfound;
2044 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
2045 char *s = scriptname + 8;
2054 origfilename = savepv(e_tmpname ? "-e" : scriptname);
2055 curcop->cop_filegv = gv_fetchfile(origfilename);
2056 if (strEQ(origfilename,"-"))
2058 if (fdscript >= 0) {
2059 rsfp = PerlIO_fdopen(fdscript,PERL_SCRIPT_MODE);
2060 #if defined(HAS_FCNTL) && defined(F_SETFD)
2062 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
2065 else if (preprocess) {
2066 char *cpp_cfg = CPPSTDIN;
2067 SV *cpp = NEWSV(0,0);
2068 SV *cmd = NEWSV(0,0);
2070 if (strEQ(cpp_cfg, "cppstdin"))
2071 sv_catpvf(cpp, "%s/", BIN_EXP);
2072 sv_catpv(cpp, cpp_cfg);
2075 sv_catpv(sv,PRIVLIB_EXP);
2079 sed %s -e \"/^[^#]/b\" \
2080 -e \"/^#[ ]*include[ ]/b\" \
2081 -e \"/^#[ ]*define[ ]/b\" \
2082 -e \"/^#[ ]*if[ ]/b\" \
2083 -e \"/^#[ ]*ifdef[ ]/b\" \
2084 -e \"/^#[ ]*ifndef[ ]/b\" \
2085 -e \"/^#[ ]*else/b\" \
2086 -e \"/^#[ ]*elif[ ]/b\" \
2087 -e \"/^#[ ]*undef[ ]/b\" \
2088 -e \"/^#[ ]*endif/b\" \
2091 (doextract ? "-e \"1,/^#/d\n\"" : ""),
2094 %s %s -e '/^[^#]/b' \
2095 -e '/^#[ ]*include[ ]/b' \
2096 -e '/^#[ ]*define[ ]/b' \
2097 -e '/^#[ ]*if[ ]/b' \
2098 -e '/^#[ ]*ifdef[ ]/b' \
2099 -e '/^#[ ]*ifndef[ ]/b' \
2100 -e '/^#[ ]*else/b' \
2101 -e '/^#[ ]*elif[ ]/b' \
2102 -e '/^#[ ]*undef[ ]/b' \
2103 -e '/^#[ ]*endif/b' \
2111 (doextract ? "-e '1,/^#/d\n'" : ""),
2113 scriptname, cpp, sv, CPPMINUS);
2115 #ifdef IAMSUID /* actually, this is caught earlier */
2116 if (euid != uid && !euid) { /* if running suidperl */
2118 (void)seteuid(uid); /* musn't stay setuid root */
2121 (void)setreuid((Uid_t)-1, uid);
2123 #ifdef HAS_SETRESUID
2124 (void)setresuid((Uid_t)-1, uid, (Uid_t)-1);
2126 PerlProc_setuid(uid);
2130 if (PerlProc_geteuid() != uid)
2131 croak("Can't do seteuid!\n");
2133 #endif /* IAMSUID */
2134 rsfp = PerlProc_popen(SvPVX(cmd), "r");
2138 else if (!*scriptname) {
2139 forbid_setid("program input from stdin");
2140 rsfp = PerlIO_stdin();
2143 rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
2144 #if defined(HAS_FCNTL) && defined(F_SETFD)
2146 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
2154 #ifndef IAMSUID /* in case script is not readable before setuid */
2155 if (euid && PerlLIO_stat(SvPVX(GvSV(curcop->cop_filegv)),&statbuf) >= 0 &&
2156 statbuf.st_mode & (S_ISUID|S_ISGID)) {
2158 PerlProc_execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
2159 croak("Can't do setuid\n");
2163 croak("Can't open perl script \"%s\": %s\n",
2164 SvPVX(GvSV(curcop->cop_filegv)), Strerror(errno));
2169 validate_suid(char *validarg, char *scriptname)
2173 /* do we need to emulate setuid on scripts? */
2175 /* This code is for those BSD systems that have setuid #! scripts disabled
2176 * in the kernel because of a security problem. Merely defining DOSUID
2177 * in perl will not fix that problem, but if you have disabled setuid
2178 * scripts in the kernel, this will attempt to emulate setuid and setgid
2179 * on scripts that have those now-otherwise-useless bits set. The setuid
2180 * root version must be called suidperl or sperlN.NNN. If regular perl
2181 * discovers that it has opened a setuid script, it calls suidperl with
2182 * the same argv that it had. If suidperl finds that the script it has
2183 * just opened is NOT setuid root, it sets the effective uid back to the
2184 * uid. We don't just make perl setuid root because that loses the
2185 * effective uid we had before invoking perl, if it was different from the
2188 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
2189 * be defined in suidperl only. suidperl must be setuid root. The
2190 * Configure script will set this up for you if you want it.
2197 if (PerlLIO_fstat(PerlIO_fileno(rsfp),&statbuf) < 0) /* normal stat is insecure */
2198 croak("Can't stat script \"%s\"",origfilename);
2199 if (fdscript < 0 && statbuf.st_mode & (S_ISUID|S_ISGID)) {
2203 #ifndef HAS_SETREUID
2204 /* On this access check to make sure the directories are readable,
2205 * there is actually a small window that the user could use to make
2206 * filename point to an accessible directory. So there is a faint
2207 * chance that someone could execute a setuid script down in a
2208 * non-accessible directory. I don't know what to do about that.
2209 * But I don't think it's too important. The manual lies when
2210 * it says access() is useful in setuid programs.
2212 if (PerlLIO_access(SvPVX(GvSV(curcop->cop_filegv)),1)) /*double check*/
2213 croak("Permission denied");
2215 /* If we can swap euid and uid, then we can determine access rights
2216 * with a simple stat of the file, and then compare device and
2217 * inode to make sure we did stat() on the same file we opened.
2218 * Then we just have to make sure he or she can execute it.
2221 struct stat tmpstatbuf;
2225 setreuid(euid,uid) < 0
2228 setresuid(euid,uid,(Uid_t)-1) < 0
2231 || PerlProc_getuid() != euid || PerlProc_geteuid() != uid)
2232 croak("Can't swap uid and euid"); /* really paranoid */
2233 if (PerlLIO_stat(SvPVX(GvSV(curcop->cop_filegv)),&tmpstatbuf) < 0)
2234 croak("Permission denied"); /* testing full pathname here */
2235 if (tmpstatbuf.st_dev != statbuf.st_dev ||
2236 tmpstatbuf.st_ino != statbuf.st_ino) {
2237 (void)PerlIO_close(rsfp);
2238 if (rsfp = PerlProc_popen("/bin/mail root","w")) { /* heh, heh */
2240 "User %ld tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
2241 (Filename of set-id script was %s, uid %ld gid %ld.)\n\nSincerely,\nperl\n",
2242 (long)uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
2243 (long)statbuf.st_dev, (long)statbuf.st_ino,
2244 SvPVX(GvSV(curcop->cop_filegv)),
2245 (long)statbuf.st_uid, (long)statbuf.st_gid);
2246 (void)PerlProc_pclose(rsfp);
2248 croak("Permission denied\n");
2252 setreuid(uid,euid) < 0
2254 # if defined(HAS_SETRESUID)
2255 setresuid(uid,euid,(Uid_t)-1) < 0
2258 || PerlProc_getuid() != uid || PerlProc_geteuid() != euid)
2259 croak("Can't reswap uid and euid");
2260 if (!cando(S_IXUSR,FALSE,&statbuf)) /* can real uid exec? */
2261 croak("Permission denied\n");
2263 #endif /* HAS_SETREUID */
2264 #endif /* IAMSUID */
2266 if (!S_ISREG(statbuf.st_mode))
2267 croak("Permission denied");
2268 if (statbuf.st_mode & S_IWOTH)
2269 croak("Setuid/gid script is writable by world");
2270 doswitches = FALSE; /* -s is insecure in suid */
2272 if (sv_gets(linestr, rsfp, 0) == Nullch ||
2273 strnNE(SvPV(linestr,na),"#!",2) ) /* required even on Sys V */
2274 croak("No #! line");
2275 s = SvPV(linestr,na)+2;
2277 while (!isSPACE(*s)) s++;
2278 for (s2 = s; (s2 > SvPV(linestr,na)+2 &&
2279 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
2280 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
2281 croak("Not a perl script");
2282 while (*s == ' ' || *s == '\t') s++;
2284 * #! arg must be what we saw above. They can invoke it by
2285 * mentioning suidperl explicitly, but they may not add any strange
2286 * arguments beyond what #! says if they do invoke suidperl that way.
2288 len = strlen(validarg);
2289 if (strEQ(validarg," PHOOEY ") ||
2290 strnNE(s,validarg,len) || !isSPACE(s[len]))
2291 croak("Args must match #! line");
2294 if (euid != uid && (statbuf.st_mode & S_ISUID) &&
2295 euid == statbuf.st_uid)
2297 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2298 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2299 #endif /* IAMSUID */
2301 if (euid) { /* oops, we're not the setuid root perl */
2302 (void)PerlIO_close(rsfp);
2305 PerlProc_execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
2307 croak("Can't do setuid\n");
2310 if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid) {
2312 (void)setegid(statbuf.st_gid);
2315 (void)setregid((Gid_t)-1,statbuf.st_gid);
2317 #ifdef HAS_SETRESGID
2318 (void)setresgid((Gid_t)-1,statbuf.st_gid,(Gid_t)-1);
2320 PerlProc_setgid(statbuf.st_gid);
2324 if (PerlProc_getegid() != statbuf.st_gid)
2325 croak("Can't do setegid!\n");
2327 if (statbuf.st_mode & S_ISUID) {
2328 if (statbuf.st_uid != euid)
2330 (void)seteuid(statbuf.st_uid); /* all that for this */
2333 (void)setreuid((Uid_t)-1,statbuf.st_uid);
2335 #ifdef HAS_SETRESUID
2336 (void)setresuid((Uid_t)-1,statbuf.st_uid,(Uid_t)-1);
2338 PerlProc_setuid(statbuf.st_uid);
2342 if (PerlProc_geteuid() != statbuf.st_uid)
2343 croak("Can't do seteuid!\n");
2345 else if (uid) { /* oops, mustn't run as root */
2347 (void)seteuid((Uid_t)uid);
2350 (void)setreuid((Uid_t)-1,(Uid_t)uid);
2352 #ifdef HAS_SETRESUID
2353 (void)setresuid((Uid_t)-1,(Uid_t)uid,(Uid_t)-1);
2355 PerlProc_setuid((Uid_t)uid);
2359 if (PerlProc_geteuid() != uid)
2360 croak("Can't do seteuid!\n");
2363 if (!cando(S_IXUSR,TRUE,&statbuf))
2364 croak("Permission denied\n"); /* they can't do this */
2367 else if (preprocess)
2368 croak("-P not allowed for setuid/setgid script\n");
2369 else if (fdscript >= 0)
2370 croak("fd script not allowed in suidperl\n");
2372 croak("Script is not setuid/setgid in suidperl\n");
2374 /* We absolutely must clear out any saved ids here, so we */
2375 /* exec the real perl, substituting fd script for scriptname. */
2376 /* (We pass script name as "subdir" of fd, which perl will grok.) */
2377 PerlIO_rewind(rsfp);
2378 PerlLIO_lseek(PerlIO_fileno(rsfp),(Off_t)0,0); /* just in case rewind didn't */
2379 for (which = 1; origargv[which] && origargv[which] != scriptname; which++) ;
2380 if (!origargv[which])
2381 croak("Permission denied");
2382 origargv[which] = savepv(form("/dev/fd/%d/%s",
2383 PerlIO_fileno(rsfp), origargv[which]));
2384 #if defined(HAS_FCNTL) && defined(F_SETFD)
2385 fcntl(PerlIO_fileno(rsfp),F_SETFD,0); /* ensure no close-on-exec */
2387 PerlProc_execv(form("%s/perl%s", BIN_EXP, patchlevel), origargv); /* try again */
2388 croak("Can't do setuid\n");
2389 #endif /* IAMSUID */
2391 if (euid != uid || egid != gid) { /* (suidperl doesn't exist, in fact) */
2392 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
2394 PerlLIO_fstat(PerlIO_fileno(rsfp),&statbuf); /* may be either wrapped or real suid */
2395 if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
2397 (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
2400 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2401 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2402 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
2403 /* not set-id, must be wrapped */
2409 find_beginning(void)
2411 register char *s, *s2;
2413 /* skip forward in input to the real script? */
2417 if ((s = sv_gets(linestr, rsfp, 0)) == Nullch)
2418 croak("No Perl script found in input\n");
2419 if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
2420 PerlIO_ungetc(rsfp, '\n'); /* to keep line count right */
2422 while (*s && !(isSPACE (*s) || *s == '#')) s++;
2424 while (*s == ' ' || *s == '\t') s++;
2426 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
2427 if (strnEQ(s2-4,"perl",4))
2429 while (s = moreswitches(s)) ;
2431 if (cddir && PerlDir_chdir(cddir) < 0)
2432 croak("Can't chdir to %s",cddir);
2440 uid = (int)PerlProc_getuid();
2441 euid = (int)PerlProc_geteuid();
2442 gid = (int)PerlProc_getgid();
2443 egid = (int)PerlProc_getegid();
2448 tainting |= (uid && (euid != uid || egid != gid));
2452 forbid_setid(char *s)
2455 croak("No %s allowed while running setuid", s);
2457 croak("No %s allowed while running setgid", s);
2464 curstash = debstash;
2465 dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
2467 DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
2468 DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
2469 DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
2470 DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
2471 sv_setiv(DBsingle, 0);
2472 DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
2473 sv_setiv(DBtrace, 0);
2474 DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
2475 sv_setiv(DBsignal, 0);
2476 curstash = defstash;
2480 init_stacks(ARGSproto)
2483 mainstack = curstack; /* remember in case we switch stacks */
2484 AvREAL_off(curstack); /* not a real array */
2485 av_extend(curstack,127);
2487 stack_base = AvARRAY(curstack);
2488 stack_sp = stack_base;
2489 stack_max = stack_base + 127;
2491 cxstack_max = 8192 / sizeof(PERL_CONTEXT) - 2; /* Use most of 8K. */
2492 New(50,cxstack,cxstack_max + 1,PERL_CONTEXT);
2495 New(50,tmps_stack,128,SV*);
2501 * The following stacks almost certainly should be per-interpreter,
2502 * but for now they're not. XXX
2506 markstack_ptr = markstack;
2508 New(54,markstack,64,I32);
2509 markstack_ptr = markstack;
2510 markstack_max = markstack + 64;
2516 New(54,scopestack,32,I32);
2518 scopestack_max = 32;
2524 New(54,savestack,128,ANY);
2526 savestack_max = 128;
2532 New(54,retstack,16,OP*);
2543 Safefree(tmps_stack);
2551 static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
2564 subname = newSVpv("main",4);
2568 init_predump_symbols(void)
2575 sv_setpvn(*av_fetch(thr->threadsv,find_threadsv("\""),FALSE)," ", 1);
2577 sv_setpvn(GvSV(gv_fetchpv("\"", TRUE, SVt_PV)), " ", 1);
2578 #endif /* USE_THREADS */
2580 stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
2581 GvMULTI_on(stdingv);
2582 IoIFP(GvIOp(stdingv)) = PerlIO_stdin();
2583 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
2585 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(stdingv));
2587 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
2589 IoOFP(GvIOp(tmpgv)) = IoIFP(GvIOp(tmpgv)) = PerlIO_stdout();
2591 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
2593 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(defoutgv));
2595 othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
2596 GvMULTI_on(othergv);
2597 IoOFP(GvIOp(othergv)) = IoIFP(GvIOp(othergv)) = PerlIO_stderr();
2598 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
2600 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(othergv));
2602 statname = NEWSV(66,0); /* last filename we did stat on */
2605 osname = savepv(OSNAME);
2609 init_postdump_symbols(register int argc, register char **argv, register char **env)
2616 argc--,argv++; /* skip name of script */
2618 for (; argc > 0 && **argv == '-'; argc--,argv++) {
2621 if (argv[0][1] == '-') {
2625 if (s = strchr(argv[0], '=')) {
2627 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
2630 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
2633 toptarget = NEWSV(0,0);
2634 sv_upgrade(toptarget, SVt_PVFM);
2635 sv_setpvn(toptarget, "", 0);
2636 bodytarget = NEWSV(0,0);
2637 sv_upgrade(bodytarget, SVt_PVFM);
2638 sv_setpvn(bodytarget, "", 0);
2639 formtarget = bodytarget;
2642 if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
2643 sv_setpv(GvSV(tmpgv),origfilename);
2644 magicname("0", "0", 1);
2646 if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
2647 sv_setpv(GvSV(tmpgv),origargv[0]);
2648 if (argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
2650 (void)gv_AVadd(argvgv);
2651 av_clear(GvAVn(argvgv));
2652 for (; argc > 0; argc--,argv++) {
2653 av_push(GvAVn(argvgv),newSVpv(argv[0],0));
2656 if (envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
2660 hv_magic(hv, envgv, 'E');
2661 #ifndef VMS /* VMS doesn't have environ array */
2662 /* Note that if the supplied env parameter is actually a copy
2663 of the global environ then it may now point to free'd memory
2664 if the environment has been modified since. To avoid this
2665 problem we treat env==NULL as meaning 'use the default'
2670 environ[0] = Nullch;
2671 for (; *env; env++) {
2672 if (!(s = strchr(*env,'=')))
2675 #if defined(WIN32) || defined(MSDOS)
2678 sv = newSVpv(s--,0);
2679 (void)hv_store(hv, *env, s - *env, sv, 0);
2681 #if defined(__BORLANDC__) && defined(USE_WIN32_RTL_ENV)
2682 /* Sins of the RTL. See note in my_setenv(). */
2683 (void)PerlEnv_putenv(savepv(*env));
2687 #ifdef DYNAMIC_ENV_FETCH
2688 HvNAME(hv) = savepv(ENV_HV_NAME);
2692 if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
2693 sv_setiv(GvSV(tmpgv), (IV)getpid());
2702 s = PerlEnv_getenv("PERL5LIB");
2706 incpush(PerlEnv_getenv("PERLLIB"), FALSE);
2708 /* Treat PERL5?LIB as a possible search list logical name -- the
2709 * "natural" VMS idiom for a Unix path string. We allow each
2710 * element to be a set of |-separated directories for compatibility.
2714 if (my_trnlnm("PERL5LIB",buf,0))
2715 do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
2717 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE);
2721 /* Use the ~-expanded versions of APPLLIB (undocumented),
2722 ARCHLIB PRIVLIB SITEARCH SITELIB and OLDARCHLIB
2725 incpush(APPLLIB_EXP, FALSE);
2729 incpush(ARCHLIB_EXP, FALSE);
2732 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
2734 incpush(PRIVLIB_EXP, FALSE);
2737 incpush(SITEARCH_EXP, FALSE);
2740 incpush(SITELIB_EXP, FALSE);
2742 #ifdef OLDARCHLIB_EXP /* 5.00[01] compatibility */
2743 incpush(OLDARCHLIB_EXP, FALSE);
2747 incpush(".", FALSE);
2751 # define PERLLIB_SEP ';'
2754 # define PERLLIB_SEP '|'
2756 # define PERLLIB_SEP ':'
2759 #ifndef PERLLIB_MANGLE
2760 # define PERLLIB_MANGLE(s,n) (s)
2764 incpush(char *p, int addsubdirs)
2766 SV *subdir = Nullsv;
2767 static char *archpat_auto;
2774 if (!archpat_auto) {
2775 STRLEN len = (sizeof(ARCHNAME) + strlen(patchlevel)
2776 + sizeof("//auto"));
2777 New(55, archpat_auto, len, char);
2778 sprintf(archpat_auto, "/%s/%s/auto", ARCHNAME, patchlevel);
2780 for (len = sizeof(ARCHNAME) + 2;
2781 archpat_auto[len] != '\0' && archpat_auto[len] != '/'; len++)
2782 if (archpat_auto[len] == '.') archpat_auto[len] = '_';
2787 /* Break at all separators */
2789 SV *libdir = newSV(0);
2792 /* skip any consecutive separators */
2793 while ( *p == PERLLIB_SEP ) {
2794 /* Uncomment the next line for PATH semantics */
2795 /* av_push(GvAVn(incgv), newSVpv(".", 1)); */
2799 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
2800 sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
2805 sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
2806 p = Nullch; /* break out */
2810 * BEFORE pushing libdir onto @INC we may first push version- and
2811 * archname-specific sub-directories.
2814 struct stat tmpstatbuf;
2819 if ((unix = tounixspec_ts(SvPV(libdir,na),Nullch)) != Nullch) {
2821 while (unix[len-1] == '/') len--; /* Cosmetic */
2822 sv_usepvn(libdir,unix,len);
2825 PerlIO_printf(PerlIO_stderr(),
2826 "Failed to unixify @INC element \"%s\"\n",
2829 /* .../archname/version if -d .../archname/version/auto */
2830 sv_setsv(subdir, libdir);
2831 sv_catpv(subdir, archpat_auto);
2832 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2833 S_ISDIR(tmpstatbuf.st_mode))
2834 av_push(GvAVn(incgv),
2835 newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2837 /* .../archname if -d .../archname/auto */
2838 sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME),
2839 strlen(patchlevel) + 1, "", 0);
2840 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2841 S_ISDIR(tmpstatbuf.st_mode))
2842 av_push(GvAVn(incgv),
2843 newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2846 /* finally push this lib directory on the end of @INC */
2847 av_push(GvAVn(incgv), libdir);
2850 SvREFCNT_dec(subdir);
2854 STATIC struct perl_thread *
2857 struct perl_thread *thr;
2860 Newz(53, thr, 1, struct perl_thread);
2861 curcop = &compiling;
2862 thr->cvcache = newHV();
2863 thr->threadsv = newAV();
2864 thr->specific = newAV();
2865 thr->errhv = newHV();
2866 thr->flags = THRf_R_JOINABLE;
2867 MUTEX_INIT(&thr->mutex);
2868 /* Handcraft thrsv similarly to mess_sv */
2869 New(53, thrsv, 1, SV);
2870 Newz(53, xpv, 1, XPV);
2871 SvFLAGS(thrsv) = SVt_PV;
2872 SvANY(thrsv) = (void*)xpv;
2873 SvREFCNT(thrsv) = 1 << 30; /* practically infinite */
2874 SvPVX(thrsv) = (char*)thr;
2875 SvCUR_set(thrsv, sizeof(thr));
2876 SvLEN_set(thrsv, sizeof(thr));
2877 *SvEND(thrsv) = '\0'; /* in the trailing_nul field */
2879 curcop = &compiling;
2882 MUTEX_LOCK(&threads_mutex);
2887 MUTEX_UNLOCK(&threads_mutex);
2889 #ifdef HAVE_THREAD_INTERN
2890 init_thread_intern(thr);
2893 #ifdef SET_THREAD_SELF
2894 SET_THREAD_SELF(thr);
2896 thr->self = pthread_self();
2897 #endif /* SET_THREAD_SELF */
2901 * These must come after the SET_THR because sv_setpvn does
2902 * SvTAINT and the taint fields require dTHR.
2904 toptarget = NEWSV(0,0);
2905 sv_upgrade(toptarget, SVt_PVFM);
2906 sv_setpvn(toptarget, "", 0);
2907 bodytarget = NEWSV(0,0);
2908 sv_upgrade(bodytarget, SVt_PVFM);
2909 sv_setpvn(bodytarget, "", 0);
2910 formtarget = bodytarget;
2911 thr->errsv = newSVpv("", 0);
2914 #endif /* USE_THREADS */
2917 call_list(I32 oldscope, AV *paramList)
2920 line_t oldline = curcop->cop_line;
2925 while (AvFILL(paramList) >= 0) {
2926 CV *cv = (CV*)av_shift(paramList);
2935 perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
2936 (void)SvPV(atsv, len);
2939 curcop = &compiling;
2940 curcop->cop_line = oldline;
2941 if (paramList == beginav)
2942 sv_catpv(atsv, "BEGIN failed--compilation aborted");
2944 sv_catpv(atsv, "END failed--cleanup aborted");
2945 while (scopestack_ix > oldscope)
2947 croak("%s", SvPVX(atsv));
2955 /* my_exit() was called */
2956 while (scopestack_ix > oldscope)
2959 curstash = defstash;
2961 call_list(oldscope, endav);
2963 curcop = &compiling;
2964 curcop->cop_line = oldline;
2966 if (paramList == beginav)
2967 croak("BEGIN failed--compilation aborted");
2969 croak("END failed--cleanup aborted");
2975 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
2980 curcop = &compiling;
2981 curcop->cop_line = oldline;
2994 DEBUG_L(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
2995 thr, (unsigned long) status));
2996 #endif /* USE_THREADS */
3005 STATUS_NATIVE_SET(status);
3012 my_failure_exit(void)
3015 if (vaxc$errno & 1) {
3016 if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
3017 STATUS_NATIVE_SET(44);
3020 if (!vaxc$errno && errno) /* unlikely */
3021 STATUS_NATIVE_SET(44);
3023 STATUS_NATIVE_SET(vaxc$errno);
3027 STATUS_POSIX_SET(errno);
3028 else if (STATUS_POSIX == 0)
3029 STATUS_POSIX_SET(255);
3038 register PERL_CONTEXT *cx;
3047 (void)UNLINK(e_tmpname);
3048 Safefree(e_tmpname);
3052 if (cxstack_ix >= 0) {