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
49 static I32 read_e_script _((CPerlObj* pPerl, int idx, SV *buf_sv, int maxlen));
51 static void find_beginning _((void));
52 static void forbid_setid _((char *));
53 static void incpush _((char *, int));
54 static void init_interp _((void));
55 static void init_ids _((void));
56 static void init_debugger _((void));
57 static void init_lexer _((void));
58 static void init_main_stash _((void));
60 static struct perl_thread * init_main_thread _((void));
61 #endif /* USE_THREADS */
62 static void init_perllib _((void));
63 static void init_postdump_symbols _((int, char **, char **));
64 static void init_predump_symbols _((void));
65 static void my_exit_jump _((void)) __attribute__((noreturn));
66 static void nuke_stacks _((void));
67 static void open_script _((char *, bool, SV *, int *fd));
68 static void usage _((char *));
69 static void validate_suid _((char *, char*, int));
70 static I32 read_e_script _((int idx, SV *buf_sv, int maxlen));
74 CPerlObj* perl_alloc(IPerlMem* ipM, IPerlEnv* ipE, IPerlStdIO* ipStd,
75 IPerlLIO* ipLIO, IPerlDir* ipD, IPerlSock* ipS, IPerlProc* ipP)
77 CPerlObj* pPerl = new(ipM) CPerlObj(ipM, ipE, ipStd, ipLIO, ipD, ipS, ipP);
87 PerlInterpreter *sv_interp;
90 New(53, sv_interp, 1, PerlInterpreter);
93 #endif /* PERL_OBJECT */
97 CPerlObj::perl_construct(void)
99 perl_construct(register PerlInterpreter *sv_interp)
105 struct perl_thread *thr;
106 #endif /* FAKE_THREADS */
107 #endif /* USE_THREADS */
110 if (!(curinterp = sv_interp))
116 Zero(sv_interp, 1, PerlInterpreter);
119 /* Init the real globals (and main thread)? */
124 #ifdef ALLOC_THREAD_KEY
127 if (pthread_key_create(&thr_key, 0))
128 croak("panic: pthread_key_create");
130 MUTEX_INIT(&sv_mutex);
132 * Safe to use basic SV functions from now on (though
133 * not things like mortals or tainting yet).
135 MUTEX_INIT(&eval_mutex);
136 COND_INIT(&eval_cond);
137 MUTEX_INIT(&threads_mutex);
138 COND_INIT(&nthreads_cond);
139 #ifdef EMULATE_ATOMIC_REFCOUNTS
140 MUTEX_INIT(&svref_mutex);
141 #endif /* EMULATE_ATOMIC_REFCOUNTS */
143 thr = init_main_thread();
144 #endif /* USE_THREADS */
146 linestr = NEWSV(65,79);
147 sv_upgrade(linestr,SVt_PVIV);
149 if (!SvREADONLY(&sv_undef)) {
150 SvREADONLY_on(&sv_undef);
154 SvREADONLY_on(&sv_no);
156 sv_setpv(&sv_yes,Yes);
158 SvREADONLY_on(&sv_yes);
161 nrs = newSVpv("\n", 1);
162 rs = SvREFCNT_inc(nrs);
166 /* sighandlerp = sighandler; */
168 sighandlerp = sighandler;
174 * There is no way we can refer to them from Perl so close them to save
175 * space. The other alternative would be to provide STDAUX and STDPRN
178 (void)fclose(stdaux);
179 (void)fclose(stdprn);
186 perl_destruct_level = 1;
188 if (perl_destruct_level > 0)
193 lex_state = LEX_NOTPARSING;
195 start_env.je_prev = NULL;
196 start_env.je_ret = -1;
197 start_env.je_mustcatch = TRUE;
198 top_env = &start_env;
201 SET_NUMERIC_STANDARD();
202 #if defined(SUBVERSION) && SUBVERSION > 0
203 sprintf(patchlevel, "%7.5f", (double) 5
204 + ((double) PATCHLEVEL / (double) 1000)
205 + ((double) SUBVERSION / (double) 100000));
207 sprintf(patchlevel, "%5.3f", (double) 5 +
208 ((double) PATCHLEVEL / (double) 1000));
211 #if defined(LOCAL_PATCH_COUNT)
212 localpatches = local_patches; /* For possible -v */
215 PerlIO_init(); /* Hook to IO system */
217 fdpid = newAV(); /* for remembering popen pids by fd */
218 modglobal = newHV(); /* pointers to per-interpreter module globals */
221 New(51,debname,128,char);
222 New(52,debdelim,128,char);
230 CPerlObj::perl_destruct(void)
232 perl_destruct(register PerlInterpreter *sv_interp)
236 int destruct_level; /* 0=none, 1=full, 2=full with checks */
241 #endif /* USE_THREADS */
244 if (!(curinterp = sv_interp))
250 /* Pass 1 on any remaining threads: detach joinables, join zombies */
252 MUTEX_LOCK(&threads_mutex);
253 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
254 "perl_destruct: waiting for %d threads...\n",
256 for (t = thr->next; t != thr; t = t->next) {
257 MUTEX_LOCK(&t->mutex);
258 switch (ThrSTATE(t)) {
261 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
262 "perl_destruct: joining zombie %p\n", t));
263 ThrSETSTATE(t, THRf_DEAD);
264 MUTEX_UNLOCK(&t->mutex);
267 * The SvREFCNT_dec below may take a long time (e.g. av
268 * may contain an object scalar whose destructor gets
269 * called) so we have to unlock threads_mutex and start
272 MUTEX_UNLOCK(&threads_mutex);
274 SvREFCNT_dec((SV*)av);
275 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
276 "perl_destruct: joined zombie %p OK\n", t));
278 case THRf_R_JOINABLE:
279 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
280 "perl_destruct: detaching thread %p\n", t));
281 ThrSETSTATE(t, THRf_R_DETACHED);
283 * We unlock threads_mutex and t->mutex in the opposite order
284 * from which we locked them just so that DETACH won't
285 * deadlock if it panics. It's only a breach of good style
286 * not a bug since they are unlocks not locks.
288 MUTEX_UNLOCK(&threads_mutex);
290 MUTEX_UNLOCK(&t->mutex);
293 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
294 "perl_destruct: ignoring %p (state %u)\n",
296 MUTEX_UNLOCK(&t->mutex);
297 /* fall through and out */
300 /* We leave the above "Pass 1" loop with threads_mutex still locked */
302 /* Pass 2 on remaining threads: wait for the thread count to drop to one */
305 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
306 "perl_destruct: final wait for %d threads\n",
308 COND_WAIT(&nthreads_cond, &threads_mutex);
310 /* At this point, we're the last thread */
311 MUTEX_UNLOCK(&threads_mutex);
312 DEBUG_L(PerlIO_printf(PerlIO_stderr(), "perl_destruct: armageddon has arrived\n"));
313 MUTEX_DESTROY(&threads_mutex);
314 COND_DESTROY(&nthreads_cond);
315 #endif /* !defined(FAKE_THREADS) */
316 #endif /* USE_THREADS */
318 destruct_level = perl_destruct_level;
322 if (s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL")) {
324 if (destruct_level < i)
337 /* We must account for everything. */
339 /* Destroy the main CV and syntax tree */
341 curpad = AvARRAY(comppad);
347 SvREFCNT_dec(main_cv);
352 * Try to destruct global references. We do this first so that the
353 * destructors and destructees still exist. Some sv's might remain.
354 * Non-referenced objects are on their own.
361 /* unhook hooks which will soon be, or use, destroyed data */
362 SvREFCNT_dec(warnhook);
364 SvREFCNT_dec(diehook);
366 SvREFCNT_dec(parsehook);
369 /* call exit list functions */
370 while (exitlistlen-- > 0)
371 exitlist[exitlistlen].fn(PERL_OBJECT_THIS_ exitlist[exitlistlen].ptr);
375 if (destruct_level == 0){
377 DEBUG_P(debprofdump());
379 /* The exit() function will do everything that needs doing. */
383 /* loosen bonds of global variables */
386 (void)PerlIO_close(rsfp);
390 /* Filters for program text */
391 SvREFCNT_dec(rsfp_filters);
392 rsfp_filters = Nullav;
404 sawampersand = FALSE; /* must save all match strings */
405 sawstudy = FALSE; /* do fbm_instr on all strings */
413 SvREFCNT_dec(e_script);
417 /* magical thingies */
419 Safefree(ofs); /* $, */
422 Safefree(ors); /* $\ */
425 SvREFCNT_dec(nrs); /* $\ helper */
428 multiline = 0; /* $* */
430 SvREFCNT_dec(statname);
434 /* defgv, aka *_ should be taken care of elsewhere */
436 /* clean up after study() */
437 SvREFCNT_dec(lastscream);
439 Safefree(screamfirst);
441 Safefree(screamnext);
444 /* startup and shutdown function lists */
445 SvREFCNT_dec(beginav);
447 SvREFCNT_dec(initav);
452 /* shortcuts just get cleared */
464 /* reset so print() ends up where we expect */
467 /* Prepare to destruct main symbol table. */
474 if (destruct_level >= 2) {
475 if (scopestack_ix != 0)
476 warn("Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
477 (long)scopestack_ix);
478 if (savestack_ix != 0)
479 warn("Unbalanced saves: %ld more saves than restores\n",
481 if (tmps_floor != -1)
482 warn("Unbalanced tmps: %ld more allocs than frees\n",
483 (long)tmps_floor + 1);
484 if (cxstack_ix != -1)
485 warn("Unbalanced context: %ld more PUSHes than POPs\n",
486 (long)cxstack_ix + 1);
489 /* Now absolutely destruct everything, somehow or other, loops or no. */
491 SvFLAGS(strtab) |= SVTYPEMASK; /* don't clean out strtab now */
492 while (sv_count != 0 && sv_count != last_sv_count) {
493 last_sv_count = sv_count;
496 SvFLAGS(strtab) &= ~SVTYPEMASK;
497 SvFLAGS(strtab) |= SVt_PVHV;
499 /* Destruct the global string table. */
501 /* Yell and reset the HeVAL() slots that are still holding refcounts,
502 * so that sv_free() won't fail on them.
511 array = HvARRAY(strtab);
515 warn("Unbalanced string table refcount: (%d) for \"%s\"",
516 HeVAL(hent) - Nullsv, HeKEY(hent));
517 HeVAL(hent) = Nullsv;
527 SvREFCNT_dec(strtab);
530 warn("Scalars leaked: %ld\n", (long)sv_count);
534 /* No SVs have survived, need to clean out */
537 Safefree(origfilename);
538 Safefree(archpat_auto);
539 Safefree(reg_start_tmp);
540 Safefree(HeKEY_hek(&hv_fetch_ent_mh));
543 hints = 0; /* Reset hints. Should hints be per-interpreter ? */
545 DEBUG_P(debprofdump());
547 MUTEX_DESTROY(&sv_mutex);
548 MUTEX_DESTROY(&eval_mutex);
549 COND_DESTROY(&eval_cond);
551 /* As the penultimate thing, free the non-arena SV for thrsv */
552 Safefree(SvPVX(thrsv));
553 Safefree(SvANY(thrsv));
556 #endif /* USE_THREADS */
558 /* As the absolutely last thing, free the non-arena SV for mess() */
561 /* we know that type >= SVt_PV */
563 Safefree(SvPVX(mess_sv));
564 Safefree(SvANY(mess_sv));
572 CPerlObj::perl_free(void)
574 perl_free(PerlInterpreter *sv_interp)
580 if (!(curinterp = sv_interp))
588 CPerlObj::perl_atexit(void (*fn) (CPerlObj*,void *), void *ptr)
590 perl_atexit(void (*fn) (void *), void *ptr)
593 Renew(exitlist, exitlistlen+1, PerlExitListEntry);
594 exitlist[exitlistlen].fn = fn;
595 exitlist[exitlistlen].ptr = ptr;
601 CPerlObj::perl_parse(void (*xsinit) (CPerlObj*), int argc, char **argv, char **env)
603 perl_parse(PerlInterpreter *sv_interp, void (*xsinit) (void), int argc, char **argv, char **env)
609 char *scriptname = NULL;
610 VOL bool dosearch = FALSE;
618 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
621 croak("suidperl is no longer needed since the kernel can now execute\n\
622 setuid perl scripts securely.\n");
627 if (!(curinterp = sv_interp))
631 #if defined(NeXT) && defined(__DYNAMIC__)
632 _dyld_lookup_and_bind
633 ("__environ", (unsigned long *) &environ_pointer, NULL);
638 #ifndef VMS /* VMS doesn't have environ array */
639 origenviron = environ;
644 /* Come here if running an undumped a.out. */
646 origfilename = savepv(argv[0]);
648 cxstack_ix = -1; /* start label stack again */
650 init_postdump_symbols(argc,argv,env);
655 curpad = AvARRAY(comppad);
660 SvREFCNT_dec(main_cv);
664 oldscope = scopestack_ix;
672 /* my_exit() was called */
673 while (scopestack_ix > oldscope)
678 call_list(oldscope, endav);
680 return STATUS_NATIVE_EXPORT;
683 PerlIO_printf(PerlIO_stderr(), "panic: top_env\n");
687 sv_setpvn(linestr,"",0);
688 sv = newSVpv("",0); /* first used for -I flags */
692 for (argc--,argv++; argc > 0; argc--,argv++) {
693 if (argv[0][0] != '-' || !argv[0][1])
697 validarg = " PHOOEY ";
723 if (s = moreswitches(s))
733 if (euid != uid || egid != gid)
734 croak("No -e allowed in setuid scripts");
736 e_script = newSVpv("",0);
737 filter_add(read_e_script, NULL);
740 sv_catpv(e_script, s);
742 sv_catpv(e_script, argv[1]);
746 croak("No code specified for -e");
747 sv_catpv(e_script, "\n");
750 case 'I': /* -I handled both here and in moreswitches() */
752 if (!*++s && (s=argv[1]) != Nullch) {
755 while (s && isSPACE(*s))
759 for (e = s; *e && !isSPACE(*e); e++) ;
766 } /* XXX else croak? */
780 preambleav = newAV();
781 av_push(preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
783 Sv = newSVpv("print myconfig();",0);
785 sv_catpv(Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
787 sv_catpv(Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
789 #if defined(DEBUGGING) || defined(NO_EMBED) || defined(MULTIPLICITY)
790 sv_catpv(Sv,"\" Compile-time options:");
792 sv_catpv(Sv," DEBUGGING");
795 sv_catpv(Sv," NO_EMBED");
798 sv_catpv(Sv," MULTIPLICITY");
800 sv_catpv(Sv,"\\n\",");
802 #if defined(LOCAL_PATCH_COUNT)
803 if (LOCAL_PATCH_COUNT > 0) {
805 sv_catpv(Sv,"\" Locally applied patches:\\n\",");
806 for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
808 sv_catpvf(Sv,"\" \\t%s\\n\",",localpatches[i]);
812 sv_catpvf(Sv,"\" Built under %s\\n\"",OSNAME);
815 sv_catpvf(Sv,",\" Compiled at %s %s\\n\"",__DATE__,__TIME__);
817 sv_catpvf(Sv,",\" Compiled on %s\\n\"",__DATE__);
822 @env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; \
823 print \" \\%ENV:\\n @env\\n\" if @env; \
824 print \" \\@INC:\\n @INC\\n\";");
827 Sv = newSVpv("config_vars(qw(",0);
832 av_push(preambleav, Sv);
833 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
844 if (!*++s || isSPACE(*s)) {
848 /* catch use of gnu style long options */
849 if (strEQ(s, "version")) {
853 if (strEQ(s, "help")) {
860 croak("Unrecognized switch: -%s (-h will show valid options)",s);
865 if (!tainting && (s = PerlEnv_getenv("PERL5OPT"))) {
876 if (!strchr("DIMUdmw", *s))
877 croak("Illegal switch in PERL5OPT: -%c", *s);
883 scriptname = argv[0];
886 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
888 else if (scriptname == Nullch) {
890 if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) )
898 open_script(scriptname,dosearch,sv,&fdscript);
900 validate_suid(validarg, scriptname,fdscript);
905 main_cv = compcv = (CV*)NEWSV(1104,0);
906 sv_upgrade((SV *)compcv, SVt_PVCV);
910 av_push(comppad, Nullsv);
911 curpad = AvARRAY(comppad);
912 comppad_name = newAV();
913 comppad_name_fill = 0;
914 min_intro_pending = 0;
917 av_store(comppad_name, 0, newSVpv("@_", 2));
918 curpad[0] = (SV*)newAV();
919 SvPADMY_on(curpad[0]); /* XXX Needed? */
921 New(666, CvMUTEXP(compcv), 1, perl_mutex);
922 MUTEX_INIT(CvMUTEXP(compcv));
923 #endif /* USE_THREADS */
925 comppadlist = newAV();
926 AvREAL_off(comppadlist);
927 av_store(comppadlist, 0, (SV*)comppad_name);
928 av_store(comppadlist, 1, (SV*)comppad);
929 CvPADLIST(compcv) = comppadlist;
931 boot_core_UNIVERSAL();
934 (*xsinit)(PERL_OBJECT_THIS); /* in case linked C routines want magical variables */
935 #if defined(VMS) || defined(WIN32) || defined(DJGPP)
939 init_predump_symbols();
940 /* init_postdump_symbols not currently designed to be called */
941 /* more than once (ENV isn't cleared first, for example) */
942 /* But running with -u leaves %ENV & @ARGV undefined! XXX */
944 init_postdump_symbols(argc,argv,env);
948 /* now parse the script */
950 SETERRNO(0,SS$_NORMAL);
952 if (yyparse() || error_count) {
954 croak("%s had compilation errors.\n", origfilename);
956 croak("Execution of %s aborted due to compilation errors.\n",
960 curcop->cop_line = 0;
964 SvREFCNT_dec(e_script);
968 /* now that script is parsed, we can modify record separator */
970 rs = SvREFCNT_inc(nrs);
971 sv_setsv(perl_get_sv("/", TRUE), rs);
982 if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
983 dump_mstats("after compilation:");
994 CPerlObj::perl_run(void)
996 perl_run(PerlInterpreter *sv_interp)
1005 if (!(curinterp = sv_interp))
1009 oldscope = scopestack_ix;
1014 cxstack_ix = -1; /* start context stack again */
1017 /* my_exit() was called */
1018 while (scopestack_ix > oldscope)
1021 curstash = defstash;
1023 call_list(oldscope, endav);
1025 if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
1026 dump_mstats("after execution: ");
1029 return STATUS_NATIVE_EXPORT;
1032 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
1037 POPSTACK_TO(mainstack);
1041 DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
1042 sawampersand ? "Enabling" : "Omitting"));
1045 DEBUG_x(dump_all());
1046 DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
1048 DEBUG_L(PerlIO_printf(Perl_debug_log, "main thread is 0x%lx\n",
1049 (unsigned long) thr));
1050 #endif /* USE_THREADS */
1053 PerlIO_printf(PerlIO_stderr(), "%s syntax OK\n", origfilename);
1056 if (PERLDB_SINGLE && DBsingle)
1057 sv_setiv(DBsingle, 1);
1059 call_list(oldscope, initav);
1069 else if (main_start) {
1070 CvDEPTH(main_cv) = 1;
1081 perl_get_sv(char *name, I32 create)
1085 if (name[1] == '\0' && !isALPHA(name[0])) {
1086 PADOFFSET tmp = find_threadsv(name);
1087 if (tmp != NOT_IN_PAD) {
1089 return THREADSV(tmp);
1092 #endif /* USE_THREADS */
1093 gv = gv_fetchpv(name, create, SVt_PV);
1100 perl_get_av(char *name, I32 create)
1102 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
1111 perl_get_hv(char *name, I32 create)
1113 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
1122 perl_get_cv(char *name, I32 create)
1124 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
1125 if (create && !GvCVu(gv))
1126 return newSUB(start_subparse(FALSE, 0),
1127 newSVOP(OP_CONST, 0, newSVpv(name,0)),
1135 /* Be sure to refetch the stack pointer after calling these routines. */
1138 perl_call_argv(char *sub_name, I32 flags, register char **argv)
1140 /* See G_* flags in cop.h */
1141 /* null terminated arg list */
1148 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
1153 return perl_call_pv(sub_name, flags);
1157 perl_call_pv(char *sub_name, I32 flags)
1158 /* name of the subroutine */
1159 /* See G_* flags in cop.h */
1161 return perl_call_sv((SV*)perl_get_cv(sub_name, TRUE), flags);
1165 perl_call_method(char *methname, I32 flags)
1166 /* name of the subroutine */
1167 /* See G_* flags in cop.h */
1173 XPUSHs(sv_2mortal(newSVpv(methname,0)));
1178 return perl_call_sv(*stack_sp--, flags);
1181 /* May be called with any of a CV, a GV, or an SV containing the name. */
1183 perl_call_sv(SV *sv, I32 flags)
1185 /* See G_* flags in cop.h */
1188 LOGOP myop; /* fake syntax tree node */
1192 bool oldcatch = CATCH_GET;
1197 if (flags & G_DISCARD) {
1202 Zero(&myop, 1, LOGOP);
1203 myop.op_next = Nullop;
1204 if (!(flags & G_NOARGS))
1205 myop.op_flags |= OPf_STACKED;
1206 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1207 (flags & G_ARRAY) ? OPf_WANT_LIST :
1212 EXTEND(stack_sp, 1);
1215 oldscope = scopestack_ix;
1217 if (PERLDB_SUB && curstash != debstash
1218 /* Handle first BEGIN of -d. */
1219 && (DBcv || (DBcv = GvCV(DBsub)))
1220 /* Try harder, since this may have been a sighandler, thus
1221 * curstash may be meaningless. */
1222 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != debstash)
1223 && !(flags & G_NODEBUG))
1224 op->op_private |= OPpENTERSUB_DB;
1226 if (flags & G_EVAL) {
1227 cLOGOP->op_other = op;
1229 /* we're trying to emulate pp_entertry() here */
1231 register PERL_CONTEXT *cx;
1232 I32 gimme = GIMME_V;
1237 push_return(op->op_next);
1238 PUSHBLOCK(cx, CXt_EVAL, stack_sp);
1240 eval_root = op; /* Only needed so that goto works right. */
1243 if (flags & G_KEEPERR)
1258 /* my_exit() was called */
1259 curstash = defstash;
1263 croak("Callback called exit");
1272 stack_sp = stack_base + oldmark;
1273 if (flags & G_ARRAY)
1277 *++stack_sp = &sv_undef;
1285 if (op == (OP*)&myop)
1286 op = pp_entersub(ARGS);
1289 retval = stack_sp - (stack_base + oldmark);
1290 if ((flags & G_EVAL) && !(flags & G_KEEPERR))
1294 if (flags & G_EVAL) {
1295 if (scopestack_ix > oldscope) {
1299 register PERL_CONTEXT *cx;
1311 CATCH_SET(oldcatch);
1313 if (flags & G_DISCARD) {
1314 stack_sp = stack_base + oldmark;
1323 /* Eval a string. The G_EVAL flag is always assumed. */
1326 perl_eval_sv(SV *sv, I32 flags)
1328 /* See G_* flags in cop.h */
1331 UNOP myop; /* fake syntax tree node */
1332 I32 oldmark = SP - stack_base;
1339 if (flags & G_DISCARD) {
1347 EXTEND(stack_sp, 1);
1349 oldscope = scopestack_ix;
1351 if (!(flags & G_NOARGS))
1352 myop.op_flags = OPf_STACKED;
1353 myop.op_next = Nullop;
1354 myop.op_type = OP_ENTEREVAL;
1355 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1356 (flags & G_ARRAY) ? OPf_WANT_LIST :
1358 if (flags & G_KEEPERR)
1359 myop.op_flags |= OPf_SPECIAL;
1369 /* my_exit() was called */
1370 curstash = defstash;
1374 croak("Callback called exit");
1383 stack_sp = stack_base + oldmark;
1384 if (flags & G_ARRAY)
1388 *++stack_sp = &sv_undef;
1393 if (op == (OP*)&myop)
1394 op = pp_entereval(ARGS);
1397 retval = stack_sp - (stack_base + oldmark);
1398 if (!(flags & G_KEEPERR))
1403 if (flags & G_DISCARD) {
1404 stack_sp = stack_base + oldmark;
1414 perl_eval_pv(char *p, I32 croak_on_error)
1417 SV* sv = newSVpv(p, 0);
1420 perl_eval_sv(sv, G_SCALAR);
1427 if (croak_on_error && SvTRUE(ERRSV))
1428 croak(SvPVx(ERRSV, na));
1433 /* Require a module. */
1436 perl_require_pv(char *pv)
1440 PUSHSTACKi(SI_REQUIRE);
1442 sv = sv_newmortal();
1443 sv_setpv(sv, "require '");
1446 perl_eval_sv(sv, G_DISCARD);
1452 magicname(char *sym, char *name, I32 namlen)
1456 if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
1457 sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
1461 usage(char *name) /* XXX move this out into a module ? */
1464 /* This message really ought to be max 23 lines.
1465 * Removed -h because the user already knows that opton. Others? */
1467 static char *usage_msg[] = {
1468 "-0[octal] specify record separator (\\0, if no argument)",
1469 "-a autosplit mode with -n or -p (splits $_ into @F)",
1470 "-c check syntax only (runs BEGIN and END blocks)",
1471 "-d[:debugger] run scripts under debugger",
1472 "-D[number/list] set debugging flags (argument is a bit mask or flags)",
1473 "-e 'command' one line of script. Several -e's allowed. Omit [programfile].",
1474 "-F/pattern/ split() pattern for autosplit (-a). The //'s are optional.",
1475 "-i[extension] edit <> files in place (make backup if extension supplied)",
1476 "-Idirectory specify @INC/#include directory (may be used more than once)",
1477 "-l[octal] enable line ending processing, specifies line terminator",
1478 "-[mM][-]module.. executes `use/no module...' before executing your script.",
1479 "-n assume 'while (<>) { ... }' loop around your script",
1480 "-p assume loop like -n but print line also like sed",
1481 "-P run script through C preprocessor before compilation",
1482 "-s enable some switch parsing for switches after script name",
1483 "-S look for the script using PATH environment variable",
1484 "-T turn on tainting checks",
1485 "-u dump core after parsing script",
1486 "-U allow unsafe operations",
1487 "-v print version number, patchlevel plus VERY IMPORTANT perl info",
1488 "-V[:variable] print perl configuration information",
1489 "-w TURN WARNINGS ON FOR COMPILATION OF YOUR SCRIPT. Recommended.",
1490 "-x[directory] strip off text before #!perl line and perhaps cd to directory",
1494 char **p = usage_msg;
1496 printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
1498 printf("\n %s", *p++);
1501 /* This routine handles any switches that can be given during run */
1504 moreswitches(char *s)
1513 rschar = scan_oct(s, 4, &numlen);
1515 if (rschar & ~((U8)~0))
1517 else if (!rschar && numlen >= 2)
1518 nrs = newSVpv("", 0);
1521 nrs = newSVpv(&ch, 1);
1527 splitstr = savepv(s + 1);
1541 if (*s == ':' || *s == '=') {
1542 my_setenv("PERL5DB", form("use Devel::%s;", ++s));
1546 perldb = PERLDB_ALL;
1553 if (isALPHA(s[1])) {
1554 static char debopts[] = "psltocPmfrxuLHXD";
1557 for (s++; *s && (d = strchr(debopts,*s)); s++)
1558 debug |= 1 << (d - debopts);
1562 for (s++; isDIGIT(*s); s++) ;
1564 debug |= 0x80000000;
1566 warn("Recompile perl with -DDEBUGGING to use -D switch\n");
1567 for (s++; isALNUM(*s); s++) ;
1577 inplace = savepv(s+1);
1579 for (s = inplace; *s && !isSPACE(*s); s++) ;
1582 if (*s == '-') /* Additional switches on #! line. */
1586 case 'I': /* -I handled both here and in parse_perl() */
1589 while (*s && isSPACE(*s))
1593 for (e = s; *e && !isSPACE(*e); e++) ;
1594 p = savepvn(s, e-s);
1600 croak("No space allowed after -I");
1610 *ors = scan_oct(s, 3 + (*s == '0'), &numlen);
1620 ors = SvPV(nrs, orslen);
1621 ors = savepvn(ors, orslen);
1625 forbid_setid("-M"); /* XXX ? */
1628 forbid_setid("-m"); /* XXX ? */
1633 /* -M-foo == 'no foo' */
1634 if (*s == '-') { use = "no "; ++s; }
1635 sv = newSVpv(use,0);
1637 /* We allow -M'Module qw(Foo Bar)' */
1638 while(isALNUM(*s) || *s==':') ++s;
1640 sv_catpv(sv, start);
1641 if (*(start-1) == 'm') {
1643 croak("Can't use '%c' after -mname", *s);
1644 sv_catpv( sv, " ()");
1647 sv_catpvn(sv, start, s-start);
1648 sv_catpv(sv, " split(/,/,q{");
1653 if (preambleav == NULL)
1654 preambleav = newAV();
1655 av_push(preambleav, sv);
1658 croak("No space allowed after -%c", *(s-1));
1675 croak("Too late for \"-T\" option");
1687 #if defined(SUBVERSION) && SUBVERSION > 0
1688 printf("\nThis is perl, version 5.%03d_%02d built for %s",
1689 PATCHLEVEL, SUBVERSION, ARCHNAME);
1691 printf("\nThis is perl, version %s built for %s",
1692 patchlevel, ARCHNAME);
1694 #if defined(LOCAL_PATCH_COUNT)
1695 if (LOCAL_PATCH_COUNT > 0)
1696 printf("\n(with %d registered patch%s, see perl -V for more detail)",
1697 LOCAL_PATCH_COUNT, (LOCAL_PATCH_COUNT!=1) ? "es" : "");
1700 printf("\n\nCopyright 1987-1998, Larry Wall\n");
1702 printf("\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
1705 printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n");
1706 printf("djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1998\n");
1709 printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
1710 "Version 5 port Copyright (c) 1994-1998, Andreas Kaiser, Ilya Zakharevich\n");
1713 printf("atariST series port, ++jrb bammi@cadence.com\n");
1716 Perl may be copied only under the terms of either the Artistic License or the\n\
1717 GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n\
1718 Complete documentation for Perl, including FAQ lists, should be found on\n\
1719 this system using `man perl' or `perldoc perl'. If you have access to the\n\
1720 Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n");
1728 if (s[1] == '-') /* Additional switches on #! line. */
1739 #ifdef ALTERNATE_SHEBANG
1740 case 'S': /* OS/2 needs -S on "extproc" line. */
1748 croak("Can't emulate -%.1s on #! line",s);
1753 /* compliments of Tom Christiansen */
1755 /* unexec() can be found in the Gnu emacs distribution */
1756 /* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
1767 prog = newSVpv(BIN_EXP, 0);
1768 sv_catpv(prog, "/perl");
1769 file = newSVpv(origfilename, 0);
1770 sv_catpv(file, ".perldump");
1772 unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
1773 /* unexec prints msg to stderr in case of failure */
1774 PerlProc_exit(status);
1777 # include <lib$routines.h>
1778 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
1780 ABORT(); /* for use with undump */
1785 /* initialize curinterp */
1790 #ifdef PERL_OBJECT /* XXX kludge */
1795 curcop = &compiling; \
1800 laststype = OP_STAT; \
1802 maxsysfd = MAXSYSFD; \
1803 statname = Nullsv; \
1809 laststype = OP_STAT; \
1816 in_clean_objs = FALSE; \
1817 in_clean_all= FALSE; \
1818 profiledata = NULL; \
1820 rsfp_filters= Nullav; \
1824 # ifdef MULTIPLICITY
1825 # define PERLVAR(var,type)
1826 # define PERLVARI(var,type,init) curinterp->var = init;
1827 # define PERLVARIC(var,type,init) curinterp->var = init;
1828 # include "intrpvar.h"
1829 # ifndef USE_THREADS
1830 # include "thrdvar.h"
1836 # define PERLVAR(var,type)
1837 # define PERLVARI(var,type,init) var = init;
1838 # define PERLVARIC(var,type,init) var = init;
1839 # include "intrpvar.h"
1840 # ifndef USE_THREADS
1841 # include "thrdvar.h"
1852 init_main_stash(void)
1857 /* Note that strtab is a rather special HV. Assumptions are made
1858 about not iterating on it, and not adding tie magic to it.
1859 It is properly deallocated in perl_destruct() */
1861 HvSHAREKEYS_off(strtab); /* mandatory */
1862 Newz(506,((XPVHV*)SvANY(strtab))->xhv_array,
1863 sizeof(HE*) * (((XPVHV*)SvANY(strtab))->xhv_max + 1), char);
1865 curstash = defstash = newHV();
1866 curstname = newSVpv("main",4);
1867 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
1868 SvREFCNT_dec(GvHV(gv));
1869 GvHV(gv) = (HV*)SvREFCNT_inc(defstash);
1871 HvNAME(defstash) = savepv("main");
1872 incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
1874 hintgv = gv_fetchpv("\010",TRUE, SVt_PV); /* ^H */
1876 defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
1877 errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
1879 replgv = gv_fetchpv("\022", TRUE, SVt_PV); /* ^R */
1881 (void)form("%240s",""); /* Preallocate temp - for immediate signals. */
1882 sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */
1883 sv_setpvn(ERRSV, "", 0);
1884 curstash = defstash;
1885 compiling.cop_stash = defstash;
1886 debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
1887 globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
1888 /* We must init $/ before switches are processed. */
1889 sv_setpvn(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), "\n", 1);
1893 open_script(char *scriptname, bool dosearch, SV *sv, int *fdscript)
1898 /* scriptname will be non-NULL if find_script() returns */
1899 scriptname = find_script(scriptname, dosearch, NULL, 1);
1901 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
1902 char *s = scriptname + 8;
1903 *fdscript = atoi(s);
1911 origfilename = (e_script ? savepv("-e") : scriptname);
1912 curcop->cop_filegv = gv_fetchfile(origfilename);
1913 if (strEQ(origfilename,"-"))
1915 if (*fdscript >= 0) {
1916 rsfp = PerlIO_fdopen(*fdscript,PERL_SCRIPT_MODE);
1917 #if defined(HAS_FCNTL) && defined(F_SETFD)
1919 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
1922 else if (preprocess) {
1923 char *cpp_cfg = CPPSTDIN;
1924 SV *cpp = newSVpv("",0);
1925 SV *cmd = NEWSV(0,0);
1927 if (strEQ(cpp_cfg, "cppstdin"))
1928 sv_catpvf(cpp, "%s/", BIN_EXP);
1929 sv_catpv(cpp, cpp_cfg);
1932 sv_catpv(sv,PRIVLIB_EXP);
1936 sed %s -e \"/^[^#]/b\" \
1937 -e \"/^#[ ]*include[ ]/b\" \
1938 -e \"/^#[ ]*define[ ]/b\" \
1939 -e \"/^#[ ]*if[ ]/b\" \
1940 -e \"/^#[ ]*ifdef[ ]/b\" \
1941 -e \"/^#[ ]*ifndef[ ]/b\" \
1942 -e \"/^#[ ]*else/b\" \
1943 -e \"/^#[ ]*elif[ ]/b\" \
1944 -e \"/^#[ ]*undef[ ]/b\" \
1945 -e \"/^#[ ]*endif/b\" \
1948 (doextract ? "-e \"1,/^#/d\n\"" : ""),
1951 %s %s -e '/^[^#]/b' \
1952 -e '/^#[ ]*include[ ]/b' \
1953 -e '/^#[ ]*define[ ]/b' \
1954 -e '/^#[ ]*if[ ]/b' \
1955 -e '/^#[ ]*ifdef[ ]/b' \
1956 -e '/^#[ ]*ifndef[ ]/b' \
1957 -e '/^#[ ]*else/b' \
1958 -e '/^#[ ]*elif[ ]/b' \
1959 -e '/^#[ ]*undef[ ]/b' \
1960 -e '/^#[ ]*endif/b' \
1968 (doextract ? "-e '1,/^#/d\n'" : ""),
1970 scriptname, cpp, sv, CPPMINUS);
1972 #ifdef IAMSUID /* actually, this is caught earlier */
1973 if (euid != uid && !euid) { /* if running suidperl */
1975 (void)seteuid(uid); /* musn't stay setuid root */
1978 (void)setreuid((Uid_t)-1, uid);
1980 #ifdef HAS_SETRESUID
1981 (void)setresuid((Uid_t)-1, uid, (Uid_t)-1);
1983 PerlProc_setuid(uid);
1987 if (PerlProc_geteuid() != uid)
1988 croak("Can't do seteuid!\n");
1990 #endif /* IAMSUID */
1991 rsfp = PerlProc_popen(SvPVX(cmd), "r");
1995 else if (!*scriptname) {
1996 forbid_setid("program input from stdin");
1997 rsfp = PerlIO_stdin();
2000 rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
2001 #if defined(HAS_FCNTL) && defined(F_SETFD)
2003 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
2008 #ifndef IAMSUID /* in case script is not readable before setuid */
2009 if (euid && PerlLIO_stat(SvPVX(GvSV(curcop->cop_filegv)),&statbuf) >= 0 &&
2010 statbuf.st_mode & (S_ISUID|S_ISGID)) {
2012 PerlProc_execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
2013 croak("Can't do setuid\n");
2017 croak("Can't open perl script \"%s\": %s\n",
2018 SvPVX(GvSV(curcop->cop_filegv)), Strerror(errno));
2023 validate_suid(char *validarg, char *scriptname, int fdscript)
2027 /* do we need to emulate setuid on scripts? */
2029 /* This code is for those BSD systems that have setuid #! scripts disabled
2030 * in the kernel because of a security problem. Merely defining DOSUID
2031 * in perl will not fix that problem, but if you have disabled setuid
2032 * scripts in the kernel, this will attempt to emulate setuid and setgid
2033 * on scripts that have those now-otherwise-useless bits set. The setuid
2034 * root version must be called suidperl or sperlN.NNN. If regular perl
2035 * discovers that it has opened a setuid script, it calls suidperl with
2036 * the same argv that it had. If suidperl finds that the script it has
2037 * just opened is NOT setuid root, it sets the effective uid back to the
2038 * uid. We don't just make perl setuid root because that loses the
2039 * effective uid we had before invoking perl, if it was different from the
2042 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
2043 * be defined in suidperl only. suidperl must be setuid root. The
2044 * Configure script will set this up for you if you want it.
2051 if (PerlLIO_fstat(PerlIO_fileno(rsfp),&statbuf) < 0) /* normal stat is insecure */
2052 croak("Can't stat script \"%s\"",origfilename);
2053 if (fdscript < 0 && statbuf.st_mode & (S_ISUID|S_ISGID)) {
2057 #ifndef HAS_SETREUID
2058 /* On this access check to make sure the directories are readable,
2059 * there is actually a small window that the user could use to make
2060 * filename point to an accessible directory. So there is a faint
2061 * chance that someone could execute a setuid script down in a
2062 * non-accessible directory. I don't know what to do about that.
2063 * But I don't think it's too important. The manual lies when
2064 * it says access() is useful in setuid programs.
2066 if (PerlLIO_access(SvPVX(GvSV(curcop->cop_filegv)),1)) /*double check*/
2067 croak("Permission denied");
2069 /* If we can swap euid and uid, then we can determine access rights
2070 * with a simple stat of the file, and then compare device and
2071 * inode to make sure we did stat() on the same file we opened.
2072 * Then we just have to make sure he or she can execute it.
2075 struct stat tmpstatbuf;
2079 setreuid(euid,uid) < 0
2082 setresuid(euid,uid,(Uid_t)-1) < 0
2085 || PerlProc_getuid() != euid || PerlProc_geteuid() != uid)
2086 croak("Can't swap uid and euid"); /* really paranoid */
2087 if (PerlLIO_stat(SvPVX(GvSV(curcop->cop_filegv)),&tmpstatbuf) < 0)
2088 croak("Permission denied"); /* testing full pathname here */
2089 if (tmpstatbuf.st_dev != statbuf.st_dev ||
2090 tmpstatbuf.st_ino != statbuf.st_ino) {
2091 (void)PerlIO_close(rsfp);
2092 if (rsfp = PerlProc_popen("/bin/mail root","w")) { /* heh, heh */
2094 "User %ld tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
2095 (Filename of set-id script was %s, uid %ld gid %ld.)\n\nSincerely,\nperl\n",
2096 (long)uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
2097 (long)statbuf.st_dev, (long)statbuf.st_ino,
2098 SvPVX(GvSV(curcop->cop_filegv)),
2099 (long)statbuf.st_uid, (long)statbuf.st_gid);
2100 (void)PerlProc_pclose(rsfp);
2102 croak("Permission denied\n");
2106 setreuid(uid,euid) < 0
2108 # if defined(HAS_SETRESUID)
2109 setresuid(uid,euid,(Uid_t)-1) < 0
2112 || PerlProc_getuid() != uid || PerlProc_geteuid() != euid)
2113 croak("Can't reswap uid and euid");
2114 if (!cando(S_IXUSR,FALSE,&statbuf)) /* can real uid exec? */
2115 croak("Permission denied\n");
2117 #endif /* HAS_SETREUID */
2118 #endif /* IAMSUID */
2120 if (!S_ISREG(statbuf.st_mode))
2121 croak("Permission denied");
2122 if (statbuf.st_mode & S_IWOTH)
2123 croak("Setuid/gid script is writable by world");
2124 doswitches = FALSE; /* -s is insecure in suid */
2126 if (sv_gets(linestr, rsfp, 0) == Nullch ||
2127 strnNE(SvPV(linestr,na),"#!",2) ) /* required even on Sys V */
2128 croak("No #! line");
2129 s = SvPV(linestr,na)+2;
2131 while (!isSPACE(*s)) s++;
2132 for (s2 = s; (s2 > SvPV(linestr,na)+2 &&
2133 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
2134 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
2135 croak("Not a perl script");
2136 while (*s == ' ' || *s == '\t') s++;
2138 * #! arg must be what we saw above. They can invoke it by
2139 * mentioning suidperl explicitly, but they may not add any strange
2140 * arguments beyond what #! says if they do invoke suidperl that way.
2142 len = strlen(validarg);
2143 if (strEQ(validarg," PHOOEY ") ||
2144 strnNE(s,validarg,len) || !isSPACE(s[len]))
2145 croak("Args must match #! line");
2148 if (euid != uid && (statbuf.st_mode & S_ISUID) &&
2149 euid == statbuf.st_uid)
2151 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2152 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2153 #endif /* IAMSUID */
2155 if (euid) { /* oops, we're not the setuid root perl */
2156 (void)PerlIO_close(rsfp);
2159 PerlProc_execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
2161 croak("Can't do setuid\n");
2164 if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid) {
2166 (void)setegid(statbuf.st_gid);
2169 (void)setregid((Gid_t)-1,statbuf.st_gid);
2171 #ifdef HAS_SETRESGID
2172 (void)setresgid((Gid_t)-1,statbuf.st_gid,(Gid_t)-1);
2174 PerlProc_setgid(statbuf.st_gid);
2178 if (PerlProc_getegid() != statbuf.st_gid)
2179 croak("Can't do setegid!\n");
2181 if (statbuf.st_mode & S_ISUID) {
2182 if (statbuf.st_uid != euid)
2184 (void)seteuid(statbuf.st_uid); /* all that for this */
2187 (void)setreuid((Uid_t)-1,statbuf.st_uid);
2189 #ifdef HAS_SETRESUID
2190 (void)setresuid((Uid_t)-1,statbuf.st_uid,(Uid_t)-1);
2192 PerlProc_setuid(statbuf.st_uid);
2196 if (PerlProc_geteuid() != statbuf.st_uid)
2197 croak("Can't do seteuid!\n");
2199 else if (uid) { /* oops, mustn't run as root */
2201 (void)seteuid((Uid_t)uid);
2204 (void)setreuid((Uid_t)-1,(Uid_t)uid);
2206 #ifdef HAS_SETRESUID
2207 (void)setresuid((Uid_t)-1,(Uid_t)uid,(Uid_t)-1);
2209 PerlProc_setuid((Uid_t)uid);
2213 if (PerlProc_geteuid() != uid)
2214 croak("Can't do seteuid!\n");
2217 if (!cando(S_IXUSR,TRUE,&statbuf))
2218 croak("Permission denied\n"); /* they can't do this */
2221 else if (preprocess)
2222 croak("-P not allowed for setuid/setgid script\n");
2223 else if (fdscript >= 0)
2224 croak("fd script not allowed in suidperl\n");
2226 croak("Script is not setuid/setgid in suidperl\n");
2228 /* We absolutely must clear out any saved ids here, so we */
2229 /* exec the real perl, substituting fd script for scriptname. */
2230 /* (We pass script name as "subdir" of fd, which perl will grok.) */
2231 PerlIO_rewind(rsfp);
2232 PerlLIO_lseek(PerlIO_fileno(rsfp),(Off_t)0,0); /* just in case rewind didn't */
2233 for (which = 1; origargv[which] && origargv[which] != scriptname; which++) ;
2234 if (!origargv[which])
2235 croak("Permission denied");
2236 origargv[which] = savepv(form("/dev/fd/%d/%s",
2237 PerlIO_fileno(rsfp), origargv[which]));
2238 #if defined(HAS_FCNTL) && defined(F_SETFD)
2239 fcntl(PerlIO_fileno(rsfp),F_SETFD,0); /* ensure no close-on-exec */
2241 PerlProc_execv(form("%s/perl%s", BIN_EXP, patchlevel), origargv); /* try again */
2242 croak("Can't do setuid\n");
2243 #endif /* IAMSUID */
2245 if (euid != uid || egid != gid) { /* (suidperl doesn't exist, in fact) */
2246 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
2248 PerlLIO_fstat(PerlIO_fileno(rsfp),&statbuf); /* may be either wrapped or real suid */
2249 if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
2251 (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
2254 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2255 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2256 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
2257 /* not set-id, must be wrapped */
2263 find_beginning(void)
2265 register char *s, *s2;
2267 /* skip forward in input to the real script? */
2271 if ((s = sv_gets(linestr, rsfp, 0)) == Nullch)
2272 croak("No Perl script found in input\n");
2273 if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
2274 PerlIO_ungetc(rsfp, '\n'); /* to keep line count right */
2276 while (*s && !(isSPACE (*s) || *s == '#')) s++;
2278 while (*s == ' ' || *s == '\t') s++;
2280 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
2281 if (strnEQ(s2-4,"perl",4))
2283 while (s = moreswitches(s)) ;
2285 if (cddir && PerlDir_chdir(cddir) < 0)
2286 croak("Can't chdir to %s",cddir);
2295 uid = (int)PerlProc_getuid();
2296 euid = (int)PerlProc_geteuid();
2297 gid = (int)PerlProc_getgid();
2298 egid = (int)PerlProc_getegid();
2303 tainting |= (uid && (euid != uid || egid != gid));
2307 forbid_setid(char *s)
2310 croak("No %s allowed while running setuid", s);
2312 croak("No %s allowed while running setgid", s);
2319 curstash = debstash;
2320 dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
2322 DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
2323 DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
2324 DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
2325 DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
2326 sv_setiv(DBsingle, 0);
2327 DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
2328 sv_setiv(DBtrace, 0);
2329 DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
2330 sv_setiv(DBsignal, 0);
2331 curstash = defstash;
2334 #ifndef STRESS_REALLOC
2335 #define REASONABLE(size) (size)
2337 #define REASONABLE(size) (1) /* unreasonable */
2341 init_stacks(ARGSproto)
2343 /* start with 128-item stack and 8K cxstack */
2344 curstackinfo = new_stackinfo(REASONABLE(128),
2345 REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
2346 curstackinfo->si_type = SI_MAIN;
2347 curstack = curstackinfo->si_stack;
2348 mainstack = curstack; /* remember in case we switch stacks */
2350 stack_base = AvARRAY(curstack);
2351 stack_sp = stack_base;
2352 stack_max = stack_base + AvMAX(curstack);
2354 New(50,tmps_stack,REASONABLE(128),SV*);
2357 tmps_max = REASONABLE(128);
2359 New(54,markstack,REASONABLE(32),I32);
2360 markstack_ptr = markstack;
2361 markstack_max = markstack + REASONABLE(32);
2365 New(54,scopestack,REASONABLE(32),I32);
2367 scopestack_max = REASONABLE(32);
2369 New(54,savestack,REASONABLE(128),ANY);
2371 savestack_max = REASONABLE(128);
2373 New(54,retstack,REASONABLE(16),OP*);
2375 retstack_max = REASONABLE(16);
2384 while (curstackinfo->si_next)
2385 curstackinfo = curstackinfo->si_next;
2386 while (curstackinfo) {
2387 PERL_SI *p = curstackinfo->si_prev;
2388 /* curstackinfo->si_stack got nuked by sv_free_arenas() */
2389 Safefree(curstackinfo->si_cxstack);
2390 Safefree(curstackinfo);
2393 Safefree(tmps_stack);
2394 Safefree(markstack);
2395 Safefree(scopestack);
2396 Safefree(savestack);
2405 static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
2418 subname = newSVpv("main",4);
2422 init_predump_symbols(void)
2428 sv_setpvn(perl_get_sv("\"", TRUE), " ", 1);
2429 stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
2430 GvMULTI_on(stdingv);
2431 IoIFP(GvIOp(stdingv)) = PerlIO_stdin();
2432 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
2434 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(stdingv));
2436 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
2438 IoOFP(GvIOp(tmpgv)) = IoIFP(GvIOp(tmpgv)) = PerlIO_stdout();
2440 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
2442 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(defoutgv));
2444 othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
2445 GvMULTI_on(othergv);
2446 IoOFP(GvIOp(othergv)) = IoIFP(GvIOp(othergv)) = PerlIO_stderr();
2447 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
2449 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(othergv));
2451 statname = NEWSV(66,0); /* last filename we did stat on */
2454 osname = savepv(OSNAME);
2458 init_postdump_symbols(register int argc, register char **argv, register char **env)
2465 argc--,argv++; /* skip name of script */
2467 for (; argc > 0 && **argv == '-'; argc--,argv++) {
2470 if (argv[0][1] == '-') {
2474 if (s = strchr(argv[0], '=')) {
2476 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
2479 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
2482 toptarget = NEWSV(0,0);
2483 sv_upgrade(toptarget, SVt_PVFM);
2484 sv_setpvn(toptarget, "", 0);
2485 bodytarget = NEWSV(0,0);
2486 sv_upgrade(bodytarget, SVt_PVFM);
2487 sv_setpvn(bodytarget, "", 0);
2488 formtarget = bodytarget;
2491 if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
2492 sv_setpv(GvSV(tmpgv),origfilename);
2493 magicname("0", "0", 1);
2495 if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
2496 sv_setpv(GvSV(tmpgv),origargv[0]);
2497 if (argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
2499 (void)gv_AVadd(argvgv);
2500 av_clear(GvAVn(argvgv));
2501 for (; argc > 0; argc--,argv++) {
2502 av_push(GvAVn(argvgv),newSVpv(argv[0],0));
2505 if (envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
2509 hv_magic(hv, envgv, 'E');
2510 #ifndef VMS /* VMS doesn't have environ array */
2511 /* Note that if the supplied env parameter is actually a copy
2512 of the global environ then it may now point to free'd memory
2513 if the environment has been modified since. To avoid this
2514 problem we treat env==NULL as meaning 'use the default'
2519 environ[0] = Nullch;
2520 for (; *env; env++) {
2521 if (!(s = strchr(*env,'=')))
2527 sv = newSVpv(s--,0);
2528 (void)hv_store(hv, *env, s - *env, sv, 0);
2530 #if defined(__BORLANDC__) && defined(USE_WIN32_RTL_ENV)
2531 /* Sins of the RTL. See note in my_setenv(). */
2532 (void)PerlEnv_putenv(savepv(*env));
2536 #ifdef DYNAMIC_ENV_FETCH
2537 HvNAME(hv) = savepv(ENV_HV_NAME);
2541 if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
2542 sv_setiv(GvSV(tmpgv), (IV)getpid());
2551 s = PerlEnv_getenv("PERL5LIB");
2555 incpush(PerlEnv_getenv("PERLLIB"), FALSE);
2557 /* Treat PERL5?LIB as a possible search list logical name -- the
2558 * "natural" VMS idiom for a Unix path string. We allow each
2559 * element to be a set of |-separated directories for compatibility.
2563 if (my_trnlnm("PERL5LIB",buf,0))
2564 do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
2566 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE);
2570 /* Use the ~-expanded versions of APPLLIB (undocumented),
2571 ARCHLIB PRIVLIB SITEARCH and SITELIB
2574 incpush(APPLLIB_EXP, TRUE);
2578 incpush(ARCHLIB_EXP, FALSE);
2581 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
2584 incpush(PRIVLIB_EXP, TRUE);
2586 incpush(PRIVLIB_EXP, FALSE);
2590 incpush(SITEARCH_EXP, FALSE);
2594 incpush(SITELIB_EXP, TRUE);
2596 incpush(SITELIB_EXP, FALSE);
2600 incpush(".", FALSE);
2604 # define PERLLIB_SEP ';'
2607 # define PERLLIB_SEP '|'
2609 # define PERLLIB_SEP ':'
2612 #ifndef PERLLIB_MANGLE
2613 # define PERLLIB_MANGLE(s,n) (s)
2617 incpush(char *p, int addsubdirs)
2619 SV *subdir = Nullsv;
2625 subdir = sv_newmortal();
2626 if (!archpat_auto) {
2627 STRLEN len = (sizeof(ARCHNAME) + strlen(patchlevel)
2628 + sizeof("//auto"));
2629 New(55, archpat_auto, len, char);
2630 sprintf(archpat_auto, "/%s/%s/auto", ARCHNAME, patchlevel);
2632 for (len = sizeof(ARCHNAME) + 2;
2633 archpat_auto[len] != '\0' && archpat_auto[len] != '/'; len++)
2634 if (archpat_auto[len] == '.') archpat_auto[len] = '_';
2639 /* Break at all separators */
2641 SV *libdir = NEWSV(55,0);
2644 /* skip any consecutive separators */
2645 while ( *p == PERLLIB_SEP ) {
2646 /* Uncomment the next line for PATH semantics */
2647 /* av_push(GvAVn(incgv), newSVpv(".", 1)); */
2651 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
2652 sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
2657 sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
2658 p = Nullch; /* break out */
2662 * BEFORE pushing libdir onto @INC we may first push version- and
2663 * archname-specific sub-directories.
2666 struct stat tmpstatbuf;
2671 if ((unix = tounixspec_ts(SvPV(libdir,na),Nullch)) != Nullch) {
2673 while (unix[len-1] == '/') len--; /* Cosmetic */
2674 sv_usepvn(libdir,unix,len);
2677 PerlIO_printf(PerlIO_stderr(),
2678 "Failed to unixify @INC element \"%s\"\n",
2681 /* .../archname/version if -d .../archname/version/auto */
2682 sv_setsv(subdir, libdir);
2683 sv_catpv(subdir, archpat_auto);
2684 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2685 S_ISDIR(tmpstatbuf.st_mode))
2686 av_push(GvAVn(incgv),
2687 newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2689 /* .../archname if -d .../archname/auto */
2690 sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME),
2691 strlen(patchlevel) + 1, "", 0);
2692 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2693 S_ISDIR(tmpstatbuf.st_mode))
2694 av_push(GvAVn(incgv),
2695 newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2698 /* finally push this lib directory on the end of @INC */
2699 av_push(GvAVn(incgv), libdir);
2704 STATIC struct perl_thread *
2707 struct perl_thread *thr;
2710 Newz(53, thr, 1, struct perl_thread);
2711 curcop = &compiling;
2712 thr->cvcache = newHV();
2713 thr->threadsv = newAV();
2714 /* thr->threadsvp is set when find_threadsv is called */
2715 thr->specific = newAV();
2716 thr->errhv = newHV();
2717 thr->flags = THRf_R_JOINABLE;
2718 MUTEX_INIT(&thr->mutex);
2719 /* Handcraft thrsv similarly to mess_sv */
2720 New(53, thrsv, 1, SV);
2721 Newz(53, xpv, 1, XPV);
2722 SvFLAGS(thrsv) = SVt_PV;
2723 SvANY(thrsv) = (void*)xpv;
2724 SvREFCNT(thrsv) = 1 << 30; /* practically infinite */
2725 SvPVX(thrsv) = (char*)thr;
2726 SvCUR_set(thrsv, sizeof(thr));
2727 SvLEN_set(thrsv, sizeof(thr));
2728 *SvEND(thrsv) = '\0'; /* in the trailing_nul field */
2732 MUTEX_LOCK(&threads_mutex);
2737 MUTEX_UNLOCK(&threads_mutex);
2739 #ifdef HAVE_THREAD_INTERN
2740 init_thread_intern(thr);
2743 #ifdef SET_THREAD_SELF
2744 SET_THREAD_SELF(thr);
2746 thr->self = pthread_self();
2747 #endif /* SET_THREAD_SELF */
2751 * These must come after the SET_THR because sv_setpvn does
2752 * SvTAINT and the taint fields require dTHR.
2754 toptarget = NEWSV(0,0);
2755 sv_upgrade(toptarget, SVt_PVFM);
2756 sv_setpvn(toptarget, "", 0);
2757 bodytarget = NEWSV(0,0);
2758 sv_upgrade(bodytarget, SVt_PVFM);
2759 sv_setpvn(bodytarget, "", 0);
2760 formtarget = bodytarget;
2761 thr->errsv = newSVpv("", 0);
2762 (void) find_threadsv("@"); /* Ensure $@ is initialised early */
2765 #endif /* USE_THREADS */
2768 call_list(I32 oldscope, AV *paramList)
2771 line_t oldline = curcop->cop_line;
2776 while (AvFILL(paramList) >= 0) {
2777 CV *cv = (CV*)av_shift(paramList);
2786 perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
2787 (void)SvPV(atsv, len);
2790 curcop = &compiling;
2791 curcop->cop_line = oldline;
2792 if (paramList == beginav)
2793 sv_catpv(atsv, "BEGIN failed--compilation aborted");
2795 sv_catpv(atsv, "END failed--cleanup aborted");
2796 while (scopestack_ix > oldscope)
2798 croak("%s", SvPVX(atsv));
2806 /* my_exit() was called */
2807 while (scopestack_ix > oldscope)
2810 curstash = defstash;
2812 call_list(oldscope, endav);
2814 curcop = &compiling;
2815 curcop->cop_line = oldline;
2817 if (paramList == beginav)
2818 croak("BEGIN failed--compilation aborted");
2820 croak("END failed--cleanup aborted");
2826 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
2831 curcop = &compiling;
2832 curcop->cop_line = oldline;
2845 DEBUG_L(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
2846 thr, (unsigned long) status));
2847 #endif /* USE_THREADS */
2856 STATUS_NATIVE_SET(status);
2863 my_failure_exit(void)
2866 if (vaxc$errno & 1) {
2867 if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
2868 STATUS_NATIVE_SET(44);
2871 if (!vaxc$errno && errno) /* unlikely */
2872 STATUS_NATIVE_SET(44);
2874 STATUS_NATIVE_SET(vaxc$errno);
2879 STATUS_POSIX_SET(errno);
2881 exitstatus = STATUS_POSIX >> 8;
2882 if (exitstatus & 255)
2883 STATUS_POSIX_SET(exitstatus);
2885 STATUS_POSIX_SET(255);
2895 register PERL_CONTEXT *cx;
2900 SvREFCNT_dec(e_script);
2904 POPSTACK_TO(mainstack);
2905 if (cxstack_ix >= 0) {
2920 read_e_script(CPerlObj *pPerl, int idx, SV *buf_sv, int maxlen)
2922 read_e_script(int idx, SV *buf_sv, int maxlen)
2926 p = SvPVX(e_script);
2927 nl = strchr(p, '\n');
2928 nl = (nl) ? nl+1 : SvEND(e_script);
2931 sv_catpvn(buf_sv, p, nl-p);
2932 sv_chop(e_script, nl);