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> */
34 dEXTCONST char rcsid[] = "perl.c\nPatch level: ###\n";
42 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
52 curcop = &compiling; \
59 laststype = OP_STAT; \
61 maxsysfd = MAXSYSFD; \
68 laststype = OP_STAT; \
73 static I32 read_e_script _((CPerlObj* pPerl, int idx, SV *buf_sv, int maxlen));
75 static void find_beginning _((void));
76 static void forbid_setid _((char *));
77 static void incpush _((char *, int));
78 static void init_ids _((void));
79 static void init_debugger _((void));
80 static void init_lexer _((void));
81 static void init_main_stash _((void));
83 static struct perl_thread * init_main_thread _((void));
84 #endif /* USE_THREADS */
85 static void init_perllib _((void));
86 static void init_postdump_symbols _((int, char **, char **));
87 static void init_predump_symbols _((void));
88 static void my_exit_jump _((void)) __attribute__((noreturn));
89 static void nuke_stacks _((void));
90 static void open_script _((char *, bool, SV *, int *fd));
91 static void usage _((char *));
92 static void validate_suid _((char *, char*, int));
93 static I32 read_e_script _((int idx, SV *buf_sv, int maxlen));
97 CPerlObj* perl_alloc(IPerlMem* ipM, IPerlEnv* ipE, IPerlStdIO* ipStd,
98 IPerlLIO* ipLIO, IPerlDir* ipD, IPerlSock* ipS, IPerlProc* ipP)
100 CPerlObj* pPerl = new(ipM) CPerlObj(ipM, ipE, ipStd, ipLIO, ipD, ipS, ipP);
110 PerlInterpreter *sv_interp;
113 New(53, sv_interp, 1, PerlInterpreter);
116 #endif /* PERL_OBJECT */
120 CPerlObj::perl_construct(void)
122 perl_construct(register PerlInterpreter *sv_interp)
128 struct perl_thread *thr;
129 #endif /* FAKE_THREADS */
130 #endif /* USE_THREADS */
133 if (!(curinterp = sv_interp))
138 Zero(sv_interp, 1, PerlInterpreter);
141 /* Init the real globals (and main thread)? */
146 #ifdef ALLOC_THREAD_KEY
149 if (pthread_key_create(&thr_key, 0))
150 croak("panic: pthread_key_create");
152 MUTEX_INIT(&sv_mutex);
154 * Safe to use basic SV functions from now on (though
155 * not things like mortals or tainting yet).
157 MUTEX_INIT(&eval_mutex);
158 COND_INIT(&eval_cond);
159 MUTEX_INIT(&threads_mutex);
160 COND_INIT(&nthreads_cond);
161 #ifdef EMULATE_ATOMIC_REFCOUNTS
162 MUTEX_INIT(&svref_mutex);
163 #endif /* EMULATE_ATOMIC_REFCOUNTS */
165 thr = init_main_thread();
166 #endif /* USE_THREADS */
168 linestr = NEWSV(65,80);
169 sv_upgrade(linestr,SVt_PVIV);
171 if (!SvREADONLY(&sv_undef)) {
172 SvREADONLY_on(&sv_undef);
176 SvREADONLY_on(&sv_no);
178 sv_setpv(&sv_yes,Yes);
180 SvREADONLY_on(&sv_yes);
183 nrs = newSVpv("\n", 1);
184 rs = SvREFCNT_inc(nrs);
188 /* sighandlerp = sighandler; */
190 sighandlerp = sighandler;
196 * There is no way we can refer to them from Perl so close them to save
197 * space. The other alternative would be to provide STDAUX and STDPRN
200 (void)fclose(stdaux);
201 (void)fclose(stdprn);
208 perl_destruct_level = 1;
210 if(perl_destruct_level > 0)
215 lex_state = LEX_NOTPARSING;
217 start_env.je_prev = NULL;
218 start_env.je_ret = -1;
219 start_env.je_mustcatch = TRUE;
220 top_env = &start_env;
223 SET_NUMERIC_STANDARD();
224 #if defined(SUBVERSION) && SUBVERSION > 0
225 sprintf(patchlevel, "%7.5f", (double) 5
226 + ((double) PATCHLEVEL / (double) 1000)
227 + ((double) SUBVERSION / (double) 100000));
229 sprintf(patchlevel, "%5.3f", (double) 5 +
230 ((double) PATCHLEVEL / (double) 1000));
233 #if defined(LOCAL_PATCH_COUNT)
234 localpatches = local_patches; /* For possible -v */
237 PerlIO_init(); /* Hook to IO system */
239 fdpid = newAV(); /* for remembering popen pids by fd */
240 modglobal = newHV(); /* pointers to per-interpreter module globals */
243 New(51,debname,128,char);
244 New(52,debdelim,128,char);
252 CPerlObj::perl_destruct(void)
254 perl_destruct(register PerlInterpreter *sv_interp)
258 int destruct_level; /* 0=none, 1=full, 2=full with checks */
263 #endif /* USE_THREADS */
266 if (!(curinterp = sv_interp))
272 /* Pass 1 on any remaining threads: detach joinables, join zombies */
274 MUTEX_LOCK(&threads_mutex);
275 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
276 "perl_destruct: waiting for %d threads...\n",
278 for (t = thr->next; t != thr; t = t->next) {
279 MUTEX_LOCK(&t->mutex);
280 switch (ThrSTATE(t)) {
283 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
284 "perl_destruct: joining zombie %p\n", t));
285 ThrSETSTATE(t, THRf_DEAD);
286 MUTEX_UNLOCK(&t->mutex);
289 * The SvREFCNT_dec below may take a long time (e.g. av
290 * may contain an object scalar whose destructor gets
291 * called) so we have to unlock threads_mutex and start
294 MUTEX_UNLOCK(&threads_mutex);
296 SvREFCNT_dec((SV*)av);
297 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
298 "perl_destruct: joined zombie %p OK\n", t));
300 case THRf_R_JOINABLE:
301 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
302 "perl_destruct: detaching thread %p\n", t));
303 ThrSETSTATE(t, THRf_R_DETACHED);
305 * We unlock threads_mutex and t->mutex in the opposite order
306 * from which we locked them just so that DETACH won't
307 * deadlock if it panics. It's only a breach of good style
308 * not a bug since they are unlocks not locks.
310 MUTEX_UNLOCK(&threads_mutex);
312 MUTEX_UNLOCK(&t->mutex);
315 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
316 "perl_destruct: ignoring %p (state %u)\n",
318 MUTEX_UNLOCK(&t->mutex);
319 /* fall through and out */
322 /* We leave the above "Pass 1" loop with threads_mutex still locked */
324 /* Pass 2 on remaining threads: wait for the thread count to drop to one */
327 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
328 "perl_destruct: final wait for %d threads\n",
330 COND_WAIT(&nthreads_cond, &threads_mutex);
332 /* At this point, we're the last thread */
333 MUTEX_UNLOCK(&threads_mutex);
334 DEBUG_L(PerlIO_printf(PerlIO_stderr(), "perl_destruct: armageddon has arrived\n"));
335 MUTEX_DESTROY(&threads_mutex);
336 COND_DESTROY(&nthreads_cond);
337 #endif /* !defined(FAKE_THREADS) */
338 #endif /* USE_THREADS */
340 destruct_level = perl_destruct_level;
344 if (s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL")) {
346 if (destruct_level < i)
355 /* We must account for everything. */
357 /* Destroy the main CV and syntax tree */
359 curpad = AvARRAY(comppad);
365 SvREFCNT_dec(main_cv);
370 * Try to destruct global references. We do this first so that the
371 * destructors and destructees still exist. Some sv's might remain.
372 * Non-referenced objects are on their own.
379 /* unhook hooks which will soon be, or use, destroyed data */
380 SvREFCNT_dec(warnhook);
382 SvREFCNT_dec(diehook);
384 SvREFCNT_dec(parsehook);
387 /* call exit list functions */
388 while (exitlistlen-- > 0)
389 exitlist[exitlistlen].fn(THIS_ exitlist[exitlistlen].ptr);
393 if (destruct_level == 0){
395 DEBUG_P(debprofdump());
397 /* The exit() function will do everything that needs doing. */
401 /* loosen bonds of global variables */
404 (void)PerlIO_close(rsfp);
408 /* Filters for program text */
409 SvREFCNT_dec(rsfp_filters);
410 rsfp_filters = Nullav;
422 sawampersand = FALSE; /* must save all match strings */
423 sawstudy = FALSE; /* do fbm_instr on all strings */
431 SvREFCNT_dec(e_script);
435 /* magical thingies */
437 Safefree(ofs); /* $, */
440 Safefree(ors); /* $\ */
443 SvREFCNT_dec(nrs); /* $\ helper */
446 multiline = 0; /* $* */
448 SvREFCNT_dec(statname);
452 /* defgv, aka *_ should be taken care of elsewhere */
454 /* clean up after study() */
455 SvREFCNT_dec(lastscream);
457 Safefree(screamfirst);
459 Safefree(screamnext);
462 /* startup and shutdown function lists */
463 SvREFCNT_dec(beginav);
465 SvREFCNT_dec(initav);
470 /* shortcuts just get cleared */
480 /* reset so print() ends up where we expect */
483 /* Prepare to destruct main symbol table. */
490 if (destruct_level >= 2) {
491 if (scopestack_ix != 0)
492 warn("Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
493 (long)scopestack_ix);
494 if (savestack_ix != 0)
495 warn("Unbalanced saves: %ld more saves than restores\n",
497 if (tmps_floor != -1)
498 warn("Unbalanced tmps: %ld more allocs than frees\n",
499 (long)tmps_floor + 1);
500 if (cxstack_ix != -1)
501 warn("Unbalanced context: %ld more PUSHes than POPs\n",
502 (long)cxstack_ix + 1);
505 /* Now absolutely destruct everything, somehow or other, loops or no. */
507 SvFLAGS(strtab) |= SVTYPEMASK; /* don't clean out strtab now */
508 while (sv_count != 0 && sv_count != last_sv_count) {
509 last_sv_count = sv_count;
512 SvFLAGS(strtab) &= ~SVTYPEMASK;
513 SvFLAGS(strtab) |= SVt_PVHV;
515 /* Destruct the global string table. */
517 /* Yell and reset the HeVAL() slots that are still holding refcounts,
518 * so that sv_free() won't fail on them.
527 array = HvARRAY(strtab);
531 warn("Unbalanced string table refcount: (%d) for \"%s\"",
532 HeVAL(hent) - Nullsv, HeKEY(hent));
533 HeVAL(hent) = Nullsv;
543 SvREFCNT_dec(strtab);
546 warn("Scalars leaked: %ld\n", (long)sv_count);
550 /* No SVs have survived, need to clean out */
554 Safefree(origfilename);
556 hints = 0; /* Reset hints. Should hints be per-interpreter ? */
558 DEBUG_P(debprofdump());
560 MUTEX_DESTROY(&sv_mutex);
561 MUTEX_DESTROY(&eval_mutex);
562 COND_DESTROY(&eval_cond);
564 /* As the penultimate thing, free the non-arena SV for thrsv */
565 Safefree(SvPVX(thrsv));
566 Safefree(SvANY(thrsv));
569 #endif /* USE_THREADS */
571 /* As the absolutely last thing, free the non-arena SV for mess() */
574 /* we know that type >= SVt_PV */
576 Safefree(SvPVX(mess_sv));
577 Safefree(SvANY(mess_sv));
585 CPerlObj::perl_free(void)
587 perl_free(PerlInterpreter *sv_interp)
593 if (!(curinterp = sv_interp))
601 CPerlObj::perl_atexit(void (*fn) (CPerlObj*,void *), void *ptr)
603 perl_atexit(void (*fn) (void *), void *ptr)
606 Renew(exitlist, exitlistlen+1, PerlExitListEntry);
607 exitlist[exitlistlen].fn = fn;
608 exitlist[exitlistlen].ptr = ptr;
614 CPerlObj::perl_parse(void (*xsinit) (CPerlObj*), int argc, char **argv, char **env)
616 perl_parse(PerlInterpreter *sv_interp, void (*xsinit) (void), int argc, char **argv, char **env)
622 char *scriptname = NULL;
623 VOL bool dosearch = FALSE;
631 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
634 croak("suidperl is no longer needed since the kernel can now execute\n\
635 setuid perl scripts securely.\n");
640 if (!(curinterp = sv_interp))
644 #if defined(NeXT) && defined(__DYNAMIC__)
645 _dyld_lookup_and_bind
646 ("__environ", (unsigned long *) &environ_pointer, NULL);
651 #ifndef VMS /* VMS doesn't have environ array */
652 origenviron = environ;
657 /* Come here if running an undumped a.out. */
659 origfilename = savepv(argv[0]);
661 cxstack_ix = -1; /* start label stack again */
663 init_postdump_symbols(argc,argv,env);
668 curpad = AvARRAY(comppad);
673 SvREFCNT_dec(main_cv);
677 oldscope = scopestack_ix;
685 /* my_exit() was called */
686 while (scopestack_ix > oldscope)
691 call_list(oldscope, endav);
693 return STATUS_NATIVE_EXPORT;
696 PerlIO_printf(PerlIO_stderr(), "panic: top_env\n");
700 sv_setpvn(linestr,"",0);
701 sv = newSVpv("",0); /* first used for -I flags */
705 for (argc--,argv++; argc > 0; argc--,argv++) {
706 if (argv[0][0] != '-' || !argv[0][1])
710 validarg = " PHOOEY ";
736 if (s = moreswitches(s))
746 if (euid != uid || egid != gid)
747 croak("No -e allowed in setuid scripts");
749 e_script = newSVpv("",0);
750 filter_add(read_e_script, NULL);
753 sv_catpv(e_script, s);
755 sv_catpv(e_script, argv[1]);
759 croak("No code specified for -e");
760 sv_catpv(e_script, "\n");
763 case 'I': /* -I handled both here and in moreswitches() */
765 if (!*++s && (s=argv[1]) != Nullch) {
768 while (s && isSPACE(*s))
772 for (e = s; *e && !isSPACE(*e); e++) ;
779 } /* XXX else croak? */
793 preambleav = newAV();
794 av_push(preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
796 Sv = newSVpv("print myconfig();",0);
798 sv_catpv(Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
800 sv_catpv(Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
802 #if defined(DEBUGGING) || defined(NO_EMBED) || defined(MULTIPLICITY)
803 sv_catpv(Sv,"\" Compile-time options:");
805 sv_catpv(Sv," DEBUGGING");
808 sv_catpv(Sv," NO_EMBED");
811 sv_catpv(Sv," MULTIPLICITY");
813 sv_catpv(Sv,"\\n\",");
815 #if defined(LOCAL_PATCH_COUNT)
816 if (LOCAL_PATCH_COUNT > 0) {
818 sv_catpv(Sv,"\" Locally applied patches:\\n\",");
819 for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
821 sv_catpvf(Sv,"\" \\t%s\\n\",",localpatches[i]);
825 sv_catpvf(Sv,"\" Built under %s\\n\"",OSNAME);
828 sv_catpvf(Sv,",\" Compiled at %s %s\\n\"",__DATE__,__TIME__);
830 sv_catpvf(Sv,",\" Compiled on %s\\n\"",__DATE__);
835 @env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; \
836 print \" \\%ENV:\\n @env\\n\" if @env; \
837 print \" \\@INC:\\n @INC\\n\";");
840 Sv = newSVpv("config_vars(qw(",0);
845 av_push(preambleav, Sv);
846 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
857 if (!*++s || isSPACE(*s)) {
861 /* catch use of gnu style long options */
862 if (strEQ(s, "version")) {
866 if (strEQ(s, "help")) {
873 croak("Unrecognized switch: -%s (-h will show valid options)",s);
878 if (!tainting && (s = PerlEnv_getenv("PERL5OPT"))) {
889 if (!strchr("DIMUdmw", *s))
890 croak("Illegal switch in PERL5OPT: -%c", *s);
896 scriptname = argv[0];
899 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
901 else if (scriptname == Nullch) {
903 if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) )
911 open_script(scriptname,dosearch,sv,&fdscript);
913 validate_suid(validarg, scriptname,fdscript);
918 main_cv = compcv = (CV*)NEWSV(1104,0);
919 sv_upgrade((SV *)compcv, SVt_PVCV);
923 av_push(comppad, Nullsv);
924 curpad = AvARRAY(comppad);
925 comppad_name = newAV();
926 comppad_name_fill = 0;
927 min_intro_pending = 0;
930 av_store(comppad_name, 0, newSVpv("@_", 2));
931 curpad[0] = (SV*)newAV();
932 SvPADMY_on(curpad[0]); /* XXX Needed? */
934 New(666, CvMUTEXP(compcv), 1, perl_mutex);
935 MUTEX_INIT(CvMUTEXP(compcv));
936 #endif /* USE_THREADS */
938 comppadlist = newAV();
939 AvREAL_off(comppadlist);
940 av_store(comppadlist, 0, (SV*)comppad_name);
941 av_store(comppadlist, 1, (SV*)comppad);
942 CvPADLIST(compcv) = comppadlist;
944 boot_core_UNIVERSAL();
947 (*xsinit)(THIS); /* in case linked C routines want magical variables */
948 #if defined(VMS) || defined(WIN32) || defined(DJGPP)
952 init_predump_symbols();
953 /* init_postdump_symbols not currently designed to be called */
954 /* more than once (ENV isn't cleared first, for example) */
955 /* But running with -u leaves %ENV & @ARGV undefined! XXX */
957 init_postdump_symbols(argc,argv,env);
961 /* now parse the script */
963 SETERRNO(0,SS$_NORMAL);
965 if (yyparse() || error_count) {
967 croak("%s had compilation errors.\n", origfilename);
969 croak("Execution of %s aborted due to compilation errors.\n",
973 curcop->cop_line = 0;
977 SvREFCNT_dec(e_script);
981 /* now that script is parsed, we can modify record separator */
983 rs = SvREFCNT_inc(nrs);
984 sv_setsv(perl_get_sv("/", TRUE), rs);
995 if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
996 dump_mstats("after compilation:");
1007 CPerlObj::perl_run(void)
1009 perl_run(PerlInterpreter *sv_interp)
1018 if (!(curinterp = sv_interp))
1022 oldscope = scopestack_ix;
1027 cxstack_ix = -1; /* start context stack again */
1030 /* my_exit() was called */
1031 while (scopestack_ix > oldscope)
1034 curstash = defstash;
1036 call_list(oldscope, endav);
1038 if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
1039 dump_mstats("after execution: ");
1042 return STATUS_NATIVE_EXPORT;
1045 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
1050 POPSTACK_TO(mainstack);
1054 DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
1055 sawampersand ? "Enabling" : "Omitting"));
1058 DEBUG_x(dump_all());
1059 DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
1061 DEBUG_L(PerlIO_printf(Perl_debug_log, "main thread is 0x%lx\n",
1062 (unsigned long) thr));
1063 #endif /* USE_THREADS */
1066 PerlIO_printf(PerlIO_stderr(), "%s syntax OK\n", origfilename);
1069 if (PERLDB_SINGLE && DBsingle)
1070 sv_setiv(DBsingle, 1);
1072 call_list(oldscope, initav);
1082 else if (main_start) {
1083 CvDEPTH(main_cv) = 1;
1094 perl_get_sv(char *name, I32 create)
1098 if (name[1] == '\0' && !isALPHA(name[0])) {
1099 PADOFFSET tmp = find_threadsv(name);
1100 if (tmp != NOT_IN_PAD) {
1102 return THREADSV(tmp);
1105 #endif /* USE_THREADS */
1106 gv = gv_fetchpv(name, create, SVt_PV);
1113 perl_get_av(char *name, I32 create)
1115 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
1124 perl_get_hv(char *name, I32 create)
1126 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
1135 perl_get_cv(char *name, I32 create)
1137 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
1138 if (create && !GvCVu(gv))
1139 return newSUB(start_subparse(FALSE, 0),
1140 newSVOP(OP_CONST, 0, newSVpv(name,0)),
1148 /* Be sure to refetch the stack pointer after calling these routines. */
1151 perl_call_argv(char *sub_name, I32 flags, register char **argv)
1153 /* See G_* flags in cop.h */
1154 /* null terminated arg list */
1161 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
1166 return perl_call_pv(sub_name, flags);
1170 perl_call_pv(char *sub_name, I32 flags)
1171 /* name of the subroutine */
1172 /* See G_* flags in cop.h */
1174 return perl_call_sv((SV*)perl_get_cv(sub_name, TRUE), flags);
1178 perl_call_method(char *methname, I32 flags)
1179 /* name of the subroutine */
1180 /* See G_* flags in cop.h */
1186 XPUSHs(sv_2mortal(newSVpv(methname,0)));
1191 return perl_call_sv(*stack_sp--, flags);
1194 /* May be called with any of a CV, a GV, or an SV containing the name. */
1196 perl_call_sv(SV *sv, I32 flags)
1198 /* See G_* flags in cop.h */
1201 LOGOP myop; /* fake syntax tree node */
1205 bool oldcatch = CATCH_GET;
1210 if (flags & G_DISCARD) {
1215 Zero(&myop, 1, LOGOP);
1216 myop.op_next = Nullop;
1217 if (!(flags & G_NOARGS))
1218 myop.op_flags |= OPf_STACKED;
1219 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1220 (flags & G_ARRAY) ? OPf_WANT_LIST :
1225 EXTEND(stack_sp, 1);
1228 oldscope = scopestack_ix;
1230 if (PERLDB_SUB && curstash != debstash
1231 /* Handle first BEGIN of -d. */
1232 && (DBcv || (DBcv = GvCV(DBsub)))
1233 /* Try harder, since this may have been a sighandler, thus
1234 * curstash may be meaningless. */
1235 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != debstash)
1236 && !(flags & G_NODEBUG))
1237 op->op_private |= OPpENTERSUB_DB;
1239 if (flags & G_EVAL) {
1240 cLOGOP->op_other = op;
1242 /* we're trying to emulate pp_entertry() here */
1244 register PERL_CONTEXT *cx;
1245 I32 gimme = GIMME_V;
1250 push_return(op->op_next);
1251 PUSHBLOCK(cx, CXt_EVAL, stack_sp);
1253 eval_root = op; /* Only needed so that goto works right. */
1256 if (flags & G_KEEPERR)
1271 /* my_exit() was called */
1272 curstash = defstash;
1276 croak("Callback called exit");
1285 stack_sp = stack_base + oldmark;
1286 if (flags & G_ARRAY)
1290 *++stack_sp = &sv_undef;
1298 if (op == (OP*)&myop)
1299 op = pp_entersub(ARGS);
1302 retval = stack_sp - (stack_base + oldmark);
1303 if ((flags & G_EVAL) && !(flags & G_KEEPERR))
1307 if (flags & G_EVAL) {
1308 if (scopestack_ix > oldscope) {
1312 register PERL_CONTEXT *cx;
1324 CATCH_SET(oldcatch);
1326 if (flags & G_DISCARD) {
1327 stack_sp = stack_base + oldmark;
1336 /* Eval a string. The G_EVAL flag is always assumed. */
1339 perl_eval_sv(SV *sv, I32 flags)
1341 /* See G_* flags in cop.h */
1344 UNOP myop; /* fake syntax tree node */
1345 I32 oldmark = SP - stack_base;
1352 if (flags & G_DISCARD) {
1360 EXTEND(stack_sp, 1);
1362 oldscope = scopestack_ix;
1364 if (!(flags & G_NOARGS))
1365 myop.op_flags = OPf_STACKED;
1366 myop.op_next = Nullop;
1367 myop.op_type = OP_ENTEREVAL;
1368 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1369 (flags & G_ARRAY) ? OPf_WANT_LIST :
1371 if (flags & G_KEEPERR)
1372 myop.op_flags |= OPf_SPECIAL;
1382 /* my_exit() was called */
1383 curstash = defstash;
1387 croak("Callback called exit");
1396 stack_sp = stack_base + oldmark;
1397 if (flags & G_ARRAY)
1401 *++stack_sp = &sv_undef;
1406 if (op == (OP*)&myop)
1407 op = pp_entereval(ARGS);
1410 retval = stack_sp - (stack_base + oldmark);
1411 if (!(flags & G_KEEPERR))
1416 if (flags & G_DISCARD) {
1417 stack_sp = stack_base + oldmark;
1427 perl_eval_pv(char *p, I32 croak_on_error)
1430 SV* sv = newSVpv(p, 0);
1433 perl_eval_sv(sv, G_SCALAR);
1440 if (croak_on_error && SvTRUE(ERRSV))
1441 croak(SvPVx(ERRSV, na));
1446 /* Require a module. */
1449 perl_require_pv(char *pv)
1451 SV* sv = sv_newmortal();
1452 sv_setpv(sv, "require '");
1455 perl_eval_sv(sv, G_DISCARD);
1459 magicname(char *sym, char *name, I32 namlen)
1463 if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
1464 sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
1468 usage(char *name) /* XXX move this out into a module ? */
1471 /* This message really ought to be max 23 lines.
1472 * Removed -h because the user already knows that opton. Others? */
1474 static char *usage_msg[] = {
1475 "-0[octal] specify record separator (\\0, if no argument)",
1476 "-a autosplit mode with -n or -p (splits $_ into @F)",
1477 "-c check syntax only (runs BEGIN and END blocks)",
1478 "-d[:debugger] run scripts under debugger",
1479 "-D[number/list] set debugging flags (argument is a bit mask or flags)",
1480 "-e 'command' one line of script. Several -e's allowed. Omit [programfile].",
1481 "-F/pattern/ split() pattern for autosplit (-a). The //'s are optional.",
1482 "-i[extension] edit <> files in place (make backup if extension supplied)",
1483 "-Idirectory specify @INC/#include directory (may be used more than once)",
1484 "-l[octal] enable line ending processing, specifies line terminator",
1485 "-[mM][-]module.. executes `use/no module...' before executing your script.",
1486 "-n assume 'while (<>) { ... }' loop around your script",
1487 "-p assume loop like -n but print line also like sed",
1488 "-P run script through C preprocessor before compilation",
1489 "-s enable some switch parsing for switches after script name",
1490 "-S look for the script using PATH environment variable",
1491 "-T turn on tainting checks",
1492 "-u dump core after parsing script",
1493 "-U allow unsafe operations",
1494 "-v print version number, patchlevel plus VERY IMPORTANT perl info",
1495 "-V[:variable] print perl configuration information",
1496 "-w TURN WARNINGS ON FOR COMPILATION OF YOUR SCRIPT. Recommended.",
1497 "-x[directory] strip off text before #!perl line and perhaps cd to directory",
1501 char **p = usage_msg;
1503 printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
1505 printf("\n %s", *p++);
1508 /* This routine handles any switches that can be given during run */
1511 moreswitches(char *s)
1520 rschar = scan_oct(s, 4, &numlen);
1522 if (rschar & ~((U8)~0))
1524 else if (!rschar && numlen >= 2)
1525 nrs = newSVpv("", 0);
1528 nrs = newSVpv(&ch, 1);
1534 splitstr = savepv(s + 1);
1548 if (*s == ':' || *s == '=') {
1549 my_setenv("PERL5DB", form("use Devel::%s;", ++s));
1553 perldb = PERLDB_ALL;
1560 if (isALPHA(s[1])) {
1561 static char debopts[] = "psltocPmfrxuLHXD";
1564 for (s++; *s && (d = strchr(debopts,*s)); s++)
1565 debug |= 1 << (d - debopts);
1569 for (s++; isDIGIT(*s); s++) ;
1571 debug |= 0x80000000;
1573 warn("Recompile perl with -DDEBUGGING to use -D switch\n");
1574 for (s++; isALNUM(*s); s++) ;
1584 inplace = savepv(s+1);
1586 for (s = inplace; *s && !isSPACE(*s); s++) ;
1589 if (*s == '-') /* Additional switches on #! line. */
1593 case 'I': /* -I handled both here and in parse_perl() */
1596 while (*s && isSPACE(*s))
1600 for (e = s; *e && !isSPACE(*e); e++) ;
1601 p = savepvn(s, e-s);
1607 croak("No space allowed after -I");
1617 *ors = scan_oct(s, 3 + (*s == '0'), &numlen);
1627 ors = SvPV(nrs, orslen);
1628 ors = savepvn(ors, orslen);
1632 forbid_setid("-M"); /* XXX ? */
1635 forbid_setid("-m"); /* XXX ? */
1640 /* -M-foo == 'no foo' */
1641 if (*s == '-') { use = "no "; ++s; }
1642 sv = newSVpv(use,0);
1644 /* We allow -M'Module qw(Foo Bar)' */
1645 while(isALNUM(*s) || *s==':') ++s;
1647 sv_catpv(sv, start);
1648 if (*(start-1) == 'm') {
1650 croak("Can't use '%c' after -mname", *s);
1651 sv_catpv( sv, " ()");
1654 sv_catpvn(sv, start, s-start);
1655 sv_catpv(sv, " split(/,/,q{");
1660 if (preambleav == NULL)
1661 preambleav = newAV();
1662 av_push(preambleav, sv);
1665 croak("No space allowed after -%c", *(s-1));
1682 croak("Too late for \"-T\" option");
1694 #if defined(SUBVERSION) && SUBVERSION > 0
1695 printf("\nThis is perl, version 5.%03d_%02d built for %s",
1696 PATCHLEVEL, SUBVERSION, ARCHNAME);
1698 printf("\nThis is perl, version %s built for %s",
1699 patchlevel, ARCHNAME);
1701 #if defined(LOCAL_PATCH_COUNT)
1702 if (LOCAL_PATCH_COUNT > 0)
1703 printf("\n(with %d registered patch%s, see perl -V for more detail)",
1704 LOCAL_PATCH_COUNT, (LOCAL_PATCH_COUNT!=1) ? "es" : "");
1707 printf("\n\nCopyright 1987-1998, Larry Wall\n");
1709 printf("\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
1712 printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n");
1713 printf("djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1998\n");
1716 printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
1717 "Version 5 port Copyright (c) 1994-1998, Andreas Kaiser, Ilya Zakharevich\n");
1720 printf("atariST series port, ++jrb bammi@cadence.com\n");
1723 Perl may be copied only under the terms of either the Artistic License or the\n\
1724 GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n\
1725 Complete documentation for Perl, including FAQ lists, should be found on\n\
1726 this system using `man perl' or `perldoc perl'. If you have access to the\n\
1727 Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n");
1735 if (s[1] == '-') /* Additional switches on #! line. */
1746 #ifdef ALTERNATE_SHEBANG
1747 case 'S': /* OS/2 needs -S on "extproc" line. */
1755 croak("Can't emulate -%.1s on #! line",s);
1760 /* compliments of Tom Christiansen */
1762 /* unexec() can be found in the Gnu emacs distribution */
1763 /* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
1774 prog = newSVpv(BIN_EXP, 0);
1775 sv_catpv(prog, "/perl");
1776 file = newSVpv(origfilename, 0);
1777 sv_catpv(file, ".perldump");
1779 unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
1780 /* unexec prints msg to stderr in case of failure */
1781 PerlProc_exit(status);
1784 # include <lib$routines.h>
1785 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
1787 ABORT(); /* for use with undump */
1793 init_main_stash(void)
1798 /* Note that strtab is a rather special HV. Assumptions are made
1799 about not iterating on it, and not adding tie magic to it.
1800 It is properly deallocated in perl_destruct() */
1802 HvSHAREKEYS_off(strtab); /* mandatory */
1803 Newz(506,((XPVHV*)SvANY(strtab))->xhv_array,
1804 sizeof(HE*) * (((XPVHV*)SvANY(strtab))->xhv_max + 1), char);
1806 curstash = defstash = newHV();
1807 curstname = newSVpv("main",4);
1808 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
1809 SvREFCNT_dec(GvHV(gv));
1810 GvHV(gv) = (HV*)SvREFCNT_inc(defstash);
1812 HvNAME(defstash) = savepv("main");
1813 incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
1815 defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
1816 errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
1818 (void)form("%240s",""); /* Preallocate temp - for immediate signals. */
1819 sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */
1820 sv_setpvn(ERRSV, "", 0);
1821 curstash = defstash;
1822 compiling.cop_stash = defstash;
1823 debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
1824 globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
1825 /* We must init $/ before switches are processed. */
1826 sv_setpvn(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), "\n", 1);
1830 open_script(char *scriptname, bool dosearch, SV *sv, int *fdscript)
1835 scriptname = find_script(scriptname, dosearch, NULL, 0);
1837 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
1838 char *s = scriptname + 8;
1839 *fdscript = atoi(s);
1847 origfilename = savepv(e_script ? "-e" : scriptname);
1848 curcop->cop_filegv = gv_fetchfile(origfilename);
1849 if (strEQ(origfilename,"-"))
1851 if (*fdscript >= 0) {
1852 rsfp = PerlIO_fdopen(*fdscript,PERL_SCRIPT_MODE);
1853 #if defined(HAS_FCNTL) && defined(F_SETFD)
1855 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
1858 else if (preprocess) {
1859 char *cpp_cfg = CPPSTDIN;
1860 SV *cpp = NEWSV(0,0);
1861 SV *cmd = NEWSV(0,0);
1863 if (strEQ(cpp_cfg, "cppstdin"))
1864 sv_catpvf(cpp, "%s/", BIN_EXP);
1865 sv_catpv(cpp, cpp_cfg);
1868 sv_catpv(sv,PRIVLIB_EXP);
1872 sed %s -e \"/^[^#]/b\" \
1873 -e \"/^#[ ]*include[ ]/b\" \
1874 -e \"/^#[ ]*define[ ]/b\" \
1875 -e \"/^#[ ]*if[ ]/b\" \
1876 -e \"/^#[ ]*ifdef[ ]/b\" \
1877 -e \"/^#[ ]*ifndef[ ]/b\" \
1878 -e \"/^#[ ]*else/b\" \
1879 -e \"/^#[ ]*elif[ ]/b\" \
1880 -e \"/^#[ ]*undef[ ]/b\" \
1881 -e \"/^#[ ]*endif/b\" \
1884 (doextract ? "-e \"1,/^#/d\n\"" : ""),
1887 %s %s -e '/^[^#]/b' \
1888 -e '/^#[ ]*include[ ]/b' \
1889 -e '/^#[ ]*define[ ]/b' \
1890 -e '/^#[ ]*if[ ]/b' \
1891 -e '/^#[ ]*ifdef[ ]/b' \
1892 -e '/^#[ ]*ifndef[ ]/b' \
1893 -e '/^#[ ]*else/b' \
1894 -e '/^#[ ]*elif[ ]/b' \
1895 -e '/^#[ ]*undef[ ]/b' \
1896 -e '/^#[ ]*endif/b' \
1904 (doextract ? "-e '1,/^#/d\n'" : ""),
1906 scriptname, cpp, sv, CPPMINUS);
1908 #ifdef IAMSUID /* actually, this is caught earlier */
1909 if (euid != uid && !euid) { /* if running suidperl */
1911 (void)seteuid(uid); /* musn't stay setuid root */
1914 (void)setreuid((Uid_t)-1, uid);
1916 #ifdef HAS_SETRESUID
1917 (void)setresuid((Uid_t)-1, uid, (Uid_t)-1);
1919 PerlProc_setuid(uid);
1923 if (PerlProc_geteuid() != uid)
1924 croak("Can't do seteuid!\n");
1926 #endif /* IAMSUID */
1927 rsfp = PerlProc_popen(SvPVX(cmd), "r");
1931 else if (!*scriptname) {
1932 forbid_setid("program input from stdin");
1933 rsfp = PerlIO_stdin();
1936 rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
1937 #if defined(HAS_FCNTL) && defined(F_SETFD)
1939 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
1944 #ifndef IAMSUID /* in case script is not readable before setuid */
1945 if (euid && PerlLIO_stat(SvPVX(GvSV(curcop->cop_filegv)),&statbuf) >= 0 &&
1946 statbuf.st_mode & (S_ISUID|S_ISGID)) {
1948 PerlProc_execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
1949 croak("Can't do setuid\n");
1953 croak("Can't open perl script \"%s\": %s\n",
1954 SvPVX(GvSV(curcop->cop_filegv)), Strerror(errno));
1959 validate_suid(char *validarg, char *scriptname, int fdscript)
1963 /* do we need to emulate setuid on scripts? */
1965 /* This code is for those BSD systems that have setuid #! scripts disabled
1966 * in the kernel because of a security problem. Merely defining DOSUID
1967 * in perl will not fix that problem, but if you have disabled setuid
1968 * scripts in the kernel, this will attempt to emulate setuid and setgid
1969 * on scripts that have those now-otherwise-useless bits set. The setuid
1970 * root version must be called suidperl or sperlN.NNN. If regular perl
1971 * discovers that it has opened a setuid script, it calls suidperl with
1972 * the same argv that it had. If suidperl finds that the script it has
1973 * just opened is NOT setuid root, it sets the effective uid back to the
1974 * uid. We don't just make perl setuid root because that loses the
1975 * effective uid we had before invoking perl, if it was different from the
1978 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
1979 * be defined in suidperl only. suidperl must be setuid root. The
1980 * Configure script will set this up for you if you want it.
1987 if (PerlLIO_fstat(PerlIO_fileno(rsfp),&statbuf) < 0) /* normal stat is insecure */
1988 croak("Can't stat script \"%s\"",origfilename);
1989 if (fdscript < 0 && statbuf.st_mode & (S_ISUID|S_ISGID)) {
1993 #ifndef HAS_SETREUID
1994 /* On this access check to make sure the directories are readable,
1995 * there is actually a small window that the user could use to make
1996 * filename point to an accessible directory. So there is a faint
1997 * chance that someone could execute a setuid script down in a
1998 * non-accessible directory. I don't know what to do about that.
1999 * But I don't think it's too important. The manual lies when
2000 * it says access() is useful in setuid programs.
2002 if (PerlLIO_access(SvPVX(GvSV(curcop->cop_filegv)),1)) /*double check*/
2003 croak("Permission denied");
2005 /* If we can swap euid and uid, then we can determine access rights
2006 * with a simple stat of the file, and then compare device and
2007 * inode to make sure we did stat() on the same file we opened.
2008 * Then we just have to make sure he or she can execute it.
2011 struct stat tmpstatbuf;
2015 setreuid(euid,uid) < 0
2018 setresuid(euid,uid,(Uid_t)-1) < 0
2021 || PerlProc_getuid() != euid || PerlProc_geteuid() != uid)
2022 croak("Can't swap uid and euid"); /* really paranoid */
2023 if (PerlLIO_stat(SvPVX(GvSV(curcop->cop_filegv)),&tmpstatbuf) < 0)
2024 croak("Permission denied"); /* testing full pathname here */
2025 if (tmpstatbuf.st_dev != statbuf.st_dev ||
2026 tmpstatbuf.st_ino != statbuf.st_ino) {
2027 (void)PerlIO_close(rsfp);
2028 if (rsfp = PerlProc_popen("/bin/mail root","w")) { /* heh, heh */
2030 "User %ld tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
2031 (Filename of set-id script was %s, uid %ld gid %ld.)\n\nSincerely,\nperl\n",
2032 (long)uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
2033 (long)statbuf.st_dev, (long)statbuf.st_ino,
2034 SvPVX(GvSV(curcop->cop_filegv)),
2035 (long)statbuf.st_uid, (long)statbuf.st_gid);
2036 (void)PerlProc_pclose(rsfp);
2038 croak("Permission denied\n");
2042 setreuid(uid,euid) < 0
2044 # if defined(HAS_SETRESUID)
2045 setresuid(uid,euid,(Uid_t)-1) < 0
2048 || PerlProc_getuid() != uid || PerlProc_geteuid() != euid)
2049 croak("Can't reswap uid and euid");
2050 if (!cando(S_IXUSR,FALSE,&statbuf)) /* can real uid exec? */
2051 croak("Permission denied\n");
2053 #endif /* HAS_SETREUID */
2054 #endif /* IAMSUID */
2056 if (!S_ISREG(statbuf.st_mode))
2057 croak("Permission denied");
2058 if (statbuf.st_mode & S_IWOTH)
2059 croak("Setuid/gid script is writable by world");
2060 doswitches = FALSE; /* -s is insecure in suid */
2062 if (sv_gets(linestr, rsfp, 0) == Nullch ||
2063 strnNE(SvPV(linestr,na),"#!",2) ) /* required even on Sys V */
2064 croak("No #! line");
2065 s = SvPV(linestr,na)+2;
2067 while (!isSPACE(*s)) s++;
2068 for (s2 = s; (s2 > SvPV(linestr,na)+2 &&
2069 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
2070 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
2071 croak("Not a perl script");
2072 while (*s == ' ' || *s == '\t') s++;
2074 * #! arg must be what we saw above. They can invoke it by
2075 * mentioning suidperl explicitly, but they may not add any strange
2076 * arguments beyond what #! says if they do invoke suidperl that way.
2078 len = strlen(validarg);
2079 if (strEQ(validarg," PHOOEY ") ||
2080 strnNE(s,validarg,len) || !isSPACE(s[len]))
2081 croak("Args must match #! line");
2084 if (euid != uid && (statbuf.st_mode & S_ISUID) &&
2085 euid == statbuf.st_uid)
2087 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2088 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2089 #endif /* IAMSUID */
2091 if (euid) { /* oops, we're not the setuid root perl */
2092 (void)PerlIO_close(rsfp);
2095 PerlProc_execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
2097 croak("Can't do setuid\n");
2100 if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid) {
2102 (void)setegid(statbuf.st_gid);
2105 (void)setregid((Gid_t)-1,statbuf.st_gid);
2107 #ifdef HAS_SETRESGID
2108 (void)setresgid((Gid_t)-1,statbuf.st_gid,(Gid_t)-1);
2110 PerlProc_setgid(statbuf.st_gid);
2114 if (PerlProc_getegid() != statbuf.st_gid)
2115 croak("Can't do setegid!\n");
2117 if (statbuf.st_mode & S_ISUID) {
2118 if (statbuf.st_uid != euid)
2120 (void)seteuid(statbuf.st_uid); /* all that for this */
2123 (void)setreuid((Uid_t)-1,statbuf.st_uid);
2125 #ifdef HAS_SETRESUID
2126 (void)setresuid((Uid_t)-1,statbuf.st_uid,(Uid_t)-1);
2128 PerlProc_setuid(statbuf.st_uid);
2132 if (PerlProc_geteuid() != statbuf.st_uid)
2133 croak("Can't do seteuid!\n");
2135 else if (uid) { /* oops, mustn't run as root */
2137 (void)seteuid((Uid_t)uid);
2140 (void)setreuid((Uid_t)-1,(Uid_t)uid);
2142 #ifdef HAS_SETRESUID
2143 (void)setresuid((Uid_t)-1,(Uid_t)uid,(Uid_t)-1);
2145 PerlProc_setuid((Uid_t)uid);
2149 if (PerlProc_geteuid() != uid)
2150 croak("Can't do seteuid!\n");
2153 if (!cando(S_IXUSR,TRUE,&statbuf))
2154 croak("Permission denied\n"); /* they can't do this */
2157 else if (preprocess)
2158 croak("-P not allowed for setuid/setgid script\n");
2159 else if (fdscript >= 0)
2160 croak("fd script not allowed in suidperl\n");
2162 croak("Script is not setuid/setgid in suidperl\n");
2164 /* We absolutely must clear out any saved ids here, so we */
2165 /* exec the real perl, substituting fd script for scriptname. */
2166 /* (We pass script name as "subdir" of fd, which perl will grok.) */
2167 PerlIO_rewind(rsfp);
2168 PerlLIO_lseek(PerlIO_fileno(rsfp),(Off_t)0,0); /* just in case rewind didn't */
2169 for (which = 1; origargv[which] && origargv[which] != scriptname; which++) ;
2170 if (!origargv[which])
2171 croak("Permission denied");
2172 origargv[which] = savepv(form("/dev/fd/%d/%s",
2173 PerlIO_fileno(rsfp), origargv[which]));
2174 #if defined(HAS_FCNTL) && defined(F_SETFD)
2175 fcntl(PerlIO_fileno(rsfp),F_SETFD,0); /* ensure no close-on-exec */
2177 PerlProc_execv(form("%s/perl%s", BIN_EXP, patchlevel), origargv); /* try again */
2178 croak("Can't do setuid\n");
2179 #endif /* IAMSUID */
2181 if (euid != uid || egid != gid) { /* (suidperl doesn't exist, in fact) */
2182 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
2184 PerlLIO_fstat(PerlIO_fileno(rsfp),&statbuf); /* may be either wrapped or real suid */
2185 if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
2187 (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
2190 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2191 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2192 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
2193 /* not set-id, must be wrapped */
2199 find_beginning(void)
2201 register char *s, *s2;
2203 /* skip forward in input to the real script? */
2207 if ((s = sv_gets(linestr, rsfp, 0)) == Nullch)
2208 croak("No Perl script found in input\n");
2209 if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
2210 PerlIO_ungetc(rsfp, '\n'); /* to keep line count right */
2212 while (*s && !(isSPACE (*s) || *s == '#')) s++;
2214 while (*s == ' ' || *s == '\t') s++;
2216 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
2217 if (strnEQ(s2-4,"perl",4))
2219 while (s = moreswitches(s)) ;
2221 if (cddir && PerlDir_chdir(cddir) < 0)
2222 croak("Can't chdir to %s",cddir);
2231 uid = (int)PerlProc_getuid();
2232 euid = (int)PerlProc_geteuid();
2233 gid = (int)PerlProc_getgid();
2234 egid = (int)PerlProc_getegid();
2239 tainting |= (uid && (euid != uid || egid != gid));
2243 forbid_setid(char *s)
2246 croak("No %s allowed while running setuid", s);
2248 croak("No %s allowed while running setgid", s);
2255 curstash = debstash;
2256 dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
2258 DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
2259 DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
2260 DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
2261 DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
2262 sv_setiv(DBsingle, 0);
2263 DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
2264 sv_setiv(DBtrace, 0);
2265 DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
2266 sv_setiv(DBsignal, 0);
2267 curstash = defstash;
2270 #ifndef STRESS_REALLOC
2271 #define REASONABLE(size) (size)
2273 #define REASONABLE(size) (1) /* unreasonable */
2277 init_stacks(ARGSproto)
2279 /* start with 128-item stack and 8K cxstack */
2280 curstackinfo = new_stackinfo(REASONABLE(128),
2281 REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
2282 curstackinfo->si_type = SI_MAIN;
2283 curstack = curstackinfo->si_stack;
2284 mainstack = curstack; /* remember in case we switch stacks */
2286 stack_base = AvARRAY(curstack);
2287 stack_sp = stack_base;
2288 stack_max = stack_base + AvMAX(curstack);
2290 New(50,tmps_stack,REASONABLE(128),SV*);
2293 tmps_max = REASONABLE(128);
2296 * The following stacks almost certainly should be per-interpreter,
2297 * but for now they're not. XXX
2301 markstack_ptr = markstack;
2303 New(54,markstack,REASONABLE(32),I32);
2304 markstack_ptr = markstack;
2305 markstack_max = markstack + REASONABLE(32);
2313 New(54,scopestack,REASONABLE(32),I32);
2315 scopestack_max = REASONABLE(32);
2321 New(54,savestack,REASONABLE(128),ANY);
2323 savestack_max = REASONABLE(128);
2329 New(54,retstack,REASONABLE(16),OP*);
2331 retstack_max = REASONABLE(16);
2341 while (curstackinfo->si_next)
2342 curstackinfo = curstackinfo->si_next;
2343 while (curstackinfo) {
2344 PERL_SI *p = curstackinfo->si_prev;
2345 /* curstackinfo->si_stack got nuked by sv_free_arenas() */
2346 Safefree(curstackinfo->si_cxstack);
2347 Safefree(curstackinfo);
2350 Safefree(tmps_stack);
2358 static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
2371 subname = newSVpv("main",4);
2375 init_predump_symbols(void)
2381 sv_setpvn(perl_get_sv("\"", TRUE), " ", 1);
2382 stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
2383 GvMULTI_on(stdingv);
2384 IoIFP(GvIOp(stdingv)) = PerlIO_stdin();
2385 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
2387 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(stdingv));
2389 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
2391 IoOFP(GvIOp(tmpgv)) = IoIFP(GvIOp(tmpgv)) = PerlIO_stdout();
2393 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
2395 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(defoutgv));
2397 othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
2398 GvMULTI_on(othergv);
2399 IoOFP(GvIOp(othergv)) = IoIFP(GvIOp(othergv)) = PerlIO_stderr();
2400 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
2402 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(othergv));
2404 statname = NEWSV(66,0); /* last filename we did stat on */
2407 osname = savepv(OSNAME);
2411 init_postdump_symbols(register int argc, register char **argv, register char **env)
2418 argc--,argv++; /* skip name of script */
2420 for (; argc > 0 && **argv == '-'; argc--,argv++) {
2423 if (argv[0][1] == '-') {
2427 if (s = strchr(argv[0], '=')) {
2429 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
2432 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
2435 toptarget = NEWSV(0,0);
2436 sv_upgrade(toptarget, SVt_PVFM);
2437 sv_setpvn(toptarget, "", 0);
2438 bodytarget = NEWSV(0,0);
2439 sv_upgrade(bodytarget, SVt_PVFM);
2440 sv_setpvn(bodytarget, "", 0);
2441 formtarget = bodytarget;
2444 if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
2445 sv_setpv(GvSV(tmpgv),origfilename);
2446 magicname("0", "0", 1);
2448 if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
2449 sv_setpv(GvSV(tmpgv),origargv[0]);
2450 if (argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
2452 (void)gv_AVadd(argvgv);
2453 av_clear(GvAVn(argvgv));
2454 for (; argc > 0; argc--,argv++) {
2455 av_push(GvAVn(argvgv),newSVpv(argv[0],0));
2458 if (envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
2462 hv_magic(hv, envgv, 'E');
2463 #ifndef VMS /* VMS doesn't have environ array */
2464 /* Note that if the supplied env parameter is actually a copy
2465 of the global environ then it may now point to free'd memory
2466 if the environment has been modified since. To avoid this
2467 problem we treat env==NULL as meaning 'use the default'
2472 environ[0] = Nullch;
2473 for (; *env; env++) {
2474 if (!(s = strchr(*env,'=')))
2480 sv = newSVpv(s--,0);
2481 (void)hv_store(hv, *env, s - *env, sv, 0);
2483 #if defined(__BORLANDC__) && defined(USE_WIN32_RTL_ENV)
2484 /* Sins of the RTL. See note in my_setenv(). */
2485 (void)PerlEnv_putenv(savepv(*env));
2489 #ifdef DYNAMIC_ENV_FETCH
2490 HvNAME(hv) = savepv(ENV_HV_NAME);
2494 if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
2495 sv_setiv(GvSV(tmpgv), (IV)getpid());
2504 s = PerlEnv_getenv("PERL5LIB");
2508 incpush(PerlEnv_getenv("PERLLIB"), FALSE);
2510 /* Treat PERL5?LIB as a possible search list logical name -- the
2511 * "natural" VMS idiom for a Unix path string. We allow each
2512 * element to be a set of |-separated directories for compatibility.
2516 if (my_trnlnm("PERL5LIB",buf,0))
2517 do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
2519 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE);
2523 /* Use the ~-expanded versions of APPLLIB (undocumented),
2524 ARCHLIB PRIVLIB SITEARCH and SITELIB
2527 incpush(APPLLIB_EXP, TRUE);
2531 incpush(ARCHLIB_EXP, FALSE);
2534 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
2537 incpush(PRIVLIB_EXP, TRUE);
2539 incpush(PRIVLIB_EXP, FALSE);
2543 incpush(SITEARCH_EXP, FALSE);
2547 incpush(SITELIB_EXP, TRUE);
2549 incpush(SITELIB_EXP, FALSE);
2553 incpush(".", FALSE);
2557 # define PERLLIB_SEP ';'
2560 # define PERLLIB_SEP '|'
2562 # define PERLLIB_SEP ':'
2565 #ifndef PERLLIB_MANGLE
2566 # define PERLLIB_MANGLE(s,n) (s)
2570 incpush(char *p, int addsubdirs)
2572 SV *subdir = Nullsv;
2578 subdir = NEWSV(55,0);
2579 if (!archpat_auto) {
2580 STRLEN len = (sizeof(ARCHNAME) + strlen(patchlevel)
2581 + sizeof("//auto"));
2582 New(55, archpat_auto, len, char);
2583 sprintf(archpat_auto, "/%s/%s/auto", ARCHNAME, patchlevel);
2585 for (len = sizeof(ARCHNAME) + 2;
2586 archpat_auto[len] != '\0' && archpat_auto[len] != '/'; len++)
2587 if (archpat_auto[len] == '.') archpat_auto[len] = '_';
2592 /* Break at all separators */
2594 SV *libdir = NEWSV(55,0);
2597 /* skip any consecutive separators */
2598 while ( *p == PERLLIB_SEP ) {
2599 /* Uncomment the next line for PATH semantics */
2600 /* av_push(GvAVn(incgv), newSVpv(".", 1)); */
2604 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
2605 sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
2610 sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
2611 p = Nullch; /* break out */
2615 * BEFORE pushing libdir onto @INC we may first push version- and
2616 * archname-specific sub-directories.
2619 struct stat tmpstatbuf;
2624 if ((unix = tounixspec_ts(SvPV(libdir,na),Nullch)) != Nullch) {
2626 while (unix[len-1] == '/') len--; /* Cosmetic */
2627 sv_usepvn(libdir,unix,len);
2630 PerlIO_printf(PerlIO_stderr(),
2631 "Failed to unixify @INC element \"%s\"\n",
2634 /* .../archname/version if -d .../archname/version/auto */
2635 sv_setsv(subdir, libdir);
2636 sv_catpv(subdir, archpat_auto);
2637 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2638 S_ISDIR(tmpstatbuf.st_mode))
2639 av_push(GvAVn(incgv),
2640 newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2642 /* .../archname if -d .../archname/auto */
2643 sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME),
2644 strlen(patchlevel) + 1, "", 0);
2645 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2646 S_ISDIR(tmpstatbuf.st_mode))
2647 av_push(GvAVn(incgv),
2648 newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2651 /* finally push this lib directory on the end of @INC */
2652 av_push(GvAVn(incgv), libdir);
2655 SvREFCNT_dec(subdir);
2659 STATIC struct perl_thread *
2662 struct perl_thread *thr;
2665 Newz(53, thr, 1, struct perl_thread);
2666 curcop = &compiling;
2667 thr->cvcache = newHV();
2668 thr->threadsv = newAV();
2669 /* thr->threadsvp is set when find_threadsv is called */
2670 thr->specific = newAV();
2671 thr->errhv = newHV();
2672 thr->flags = THRf_R_JOINABLE;
2673 MUTEX_INIT(&thr->mutex);
2674 /* Handcraft thrsv similarly to mess_sv */
2675 New(53, thrsv, 1, SV);
2676 Newz(53, xpv, 1, XPV);
2677 SvFLAGS(thrsv) = SVt_PV;
2678 SvANY(thrsv) = (void*)xpv;
2679 SvREFCNT(thrsv) = 1 << 30; /* practically infinite */
2680 SvPVX(thrsv) = (char*)thr;
2681 SvCUR_set(thrsv, sizeof(thr));
2682 SvLEN_set(thrsv, sizeof(thr));
2683 *SvEND(thrsv) = '\0'; /* in the trailing_nul field */
2687 MUTEX_LOCK(&threads_mutex);
2692 MUTEX_UNLOCK(&threads_mutex);
2694 #ifdef HAVE_THREAD_INTERN
2695 init_thread_intern(thr);
2698 #ifdef SET_THREAD_SELF
2699 SET_THREAD_SELF(thr);
2701 thr->self = pthread_self();
2702 #endif /* SET_THREAD_SELF */
2706 * These must come after the SET_THR because sv_setpvn does
2707 * SvTAINT and the taint fields require dTHR.
2709 toptarget = NEWSV(0,0);
2710 sv_upgrade(toptarget, SVt_PVFM);
2711 sv_setpvn(toptarget, "", 0);
2712 bodytarget = NEWSV(0,0);
2713 sv_upgrade(bodytarget, SVt_PVFM);
2714 sv_setpvn(bodytarget, "", 0);
2715 formtarget = bodytarget;
2716 thr->errsv = newSVpv("", 0);
2717 (void) find_threadsv("@"); /* Ensure $@ is initialised early */
2720 #endif /* USE_THREADS */
2723 call_list(I32 oldscope, AV *paramList)
2726 line_t oldline = curcop->cop_line;
2731 while (AvFILL(paramList) >= 0) {
2732 CV *cv = (CV*)av_shift(paramList);
2741 perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
2742 (void)SvPV(atsv, len);
2745 curcop = &compiling;
2746 curcop->cop_line = oldline;
2747 if (paramList == beginav)
2748 sv_catpv(atsv, "BEGIN failed--compilation aborted");
2750 sv_catpv(atsv, "END failed--cleanup aborted");
2751 while (scopestack_ix > oldscope)
2753 croak("%s", SvPVX(atsv));
2761 /* my_exit() was called */
2762 while (scopestack_ix > oldscope)
2765 curstash = defstash;
2767 call_list(oldscope, endav);
2769 curcop = &compiling;
2770 curcop->cop_line = oldline;
2772 if (paramList == beginav)
2773 croak("BEGIN failed--compilation aborted");
2775 croak("END failed--cleanup aborted");
2781 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
2786 curcop = &compiling;
2787 curcop->cop_line = oldline;
2800 DEBUG_L(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
2801 thr, (unsigned long) status));
2802 #endif /* USE_THREADS */
2811 STATUS_NATIVE_SET(status);
2818 my_failure_exit(void)
2821 if (vaxc$errno & 1) {
2822 if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
2823 STATUS_NATIVE_SET(44);
2826 if (!vaxc$errno && errno) /* unlikely */
2827 STATUS_NATIVE_SET(44);
2829 STATUS_NATIVE_SET(vaxc$errno);
2834 STATUS_POSIX_SET(errno);
2836 exitstatus = STATUS_POSIX >> 8;
2837 if (exitstatus & 255)
2838 STATUS_POSIX_SET(exitstatus);
2840 STATUS_POSIX_SET(255);
2850 register PERL_CONTEXT *cx;
2855 SvREFCNT_dec(e_script);
2859 POPSTACK_TO(mainstack);
2860 if (cxstack_ix >= 0) {
2875 read_e_script(CPerlObj *pPerl, int idx, SV *buf_sv, int maxlen)
2877 read_e_script(int idx, SV *buf_sv, int maxlen)
2881 p = SvPVX(e_script);
2882 nl = strchr(p, '\n');
2883 nl = (nl) ? nl+1 : SvEND(e_script);
2886 sv_catpvn(buf_sv, p, nl-p);
2887 sv_chop(e_script, nl);