3 * Copyright (c) 1987-1998 Larry Wall
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
11 * "A ship then new they built for him/of mithril and of elven glass" --Bilbo
16 #include "patchlevel.h"
18 /* XXX If this causes problems, set i_unistd=undef in the hint file. */
23 #if !defined(STANDARD_C) && !defined(HAS_GETENV_PROTOTYPE)
24 char *getenv _((char *)); /* Usually in <stdlib.h> */
27 dEXTCONST char rcsid[] = "perl.c\nPatch level: ###\n";
35 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
45 curcop = &compiling; \
52 laststype = OP_STAT; \
54 maxsysfd = MAXSYSFD; \
61 laststype = OP_STAT; \
66 static void find_beginning _((void));
67 static void forbid_setid _((char *));
68 static void incpush _((char *, int));
69 static void init_ids _((void));
70 static void init_debugger _((void));
71 static void init_lexer _((void));
72 static void init_main_stash _((void));
74 static struct perl_thread * init_main_thread _((void));
75 #endif /* USE_THREADS */
76 static void init_perllib _((void));
77 static void init_postdump_symbols _((int, char **, char **));
78 static void init_predump_symbols _((void));
79 static void my_exit_jump _((void)) __attribute__((noreturn));
80 static void nuke_stacks _((void));
81 static void open_script _((char *, bool, SV *, int *fd));
82 static void usage _((char *));
83 static void validate_suid _((char *, char*, int));
87 CPerlObj* perl_alloc(IPerlMem* ipM, IPerlEnv* ipE, IPerlStdIO* ipStd,
88 IPerlLIO* ipLIO, IPerlDir* ipD, IPerlSock* ipS, IPerlProc* ipP)
90 CPerlObj* pPerl = new(ipM) CPerlObj(ipM, ipE, ipStd, ipLIO, ipD, ipS, ipP);
100 PerlInterpreter *sv_interp;
103 New(53, sv_interp, 1, PerlInterpreter);
106 #endif /* PERL_OBJECT */
110 CPerlObj::perl_construct(void)
112 perl_construct(register PerlInterpreter *sv_interp)
118 struct perl_thread *thr;
119 #endif /* FAKE_THREADS */
120 #endif /* USE_THREADS */
123 if (!(curinterp = sv_interp))
128 Zero(sv_interp, 1, PerlInterpreter);
131 /* Init the real globals (and main thread)? */
136 #ifdef ALLOC_THREAD_KEY
139 if (pthread_key_create(&thr_key, 0))
140 croak("panic: pthread_key_create");
142 MUTEX_INIT(&sv_mutex);
144 * Safe to use basic SV functions from now on (though
145 * not things like mortals or tainting yet).
147 MUTEX_INIT(&eval_mutex);
148 COND_INIT(&eval_cond);
149 MUTEX_INIT(&threads_mutex);
150 COND_INIT(&nthreads_cond);
151 #ifdef EMULATE_ATOMIC_REFCOUNTS
152 MUTEX_INIT(&svref_mutex);
153 #endif /* EMULATE_ATOMIC_REFCOUNTS */
155 thr = init_main_thread();
156 #endif /* USE_THREADS */
158 linestr = NEWSV(65,80);
159 sv_upgrade(linestr,SVt_PVIV);
161 if (!SvREADONLY(&sv_undef)) {
162 SvREADONLY_on(&sv_undef);
166 SvREADONLY_on(&sv_no);
168 sv_setpv(&sv_yes,Yes);
170 SvREADONLY_on(&sv_yes);
173 nrs = newSVpv("\n", 1);
174 rs = SvREFCNT_inc(nrs);
178 /* sighandlerp = sighandler; */
180 sighandlerp = sighandler;
186 * There is no way we can refer to them from Perl so close them to save
187 * space. The other alternative would be to provide STDAUX and STDPRN
190 (void)fclose(stdaux);
191 (void)fclose(stdprn);
197 perl_destruct_level = 1;
199 if(perl_destruct_level > 0)
204 lex_state = LEX_NOTPARSING;
206 start_env.je_prev = NULL;
207 start_env.je_ret = -1;
208 start_env.je_mustcatch = TRUE;
209 top_env = &start_env;
212 SET_NUMERIC_STANDARD();
213 #if defined(SUBVERSION) && SUBVERSION > 0
214 sprintf(patchlevel, "%7.5f", (double) 5
215 + ((double) PATCHLEVEL / (double) 1000)
216 + ((double) SUBVERSION / (double) 100000));
218 sprintf(patchlevel, "%5.3f", (double) 5 +
219 ((double) PATCHLEVEL / (double) 1000));
222 #if defined(LOCAL_PATCH_COUNT)
223 localpatches = local_patches; /* For possible -v */
226 PerlIO_init(); /* Hook to IO system */
228 fdpid = newAV(); /* for remembering popen pids by fd */
232 New(51,debname,128,char);
233 New(52,debdelim,128,char);
241 CPerlObj::perl_destruct(void)
243 perl_destruct(register PerlInterpreter *sv_interp)
247 int destruct_level; /* 0=none, 1=full, 2=full with checks */
252 #endif /* USE_THREADS */
255 if (!(curinterp = sv_interp))
261 /* Pass 1 on any remaining threads: detach joinables, join zombies */
263 MUTEX_LOCK(&threads_mutex);
264 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
265 "perl_destruct: waiting for %d threads...\n",
267 for (t = thr->next; t != thr; t = t->next) {
268 MUTEX_LOCK(&t->mutex);
269 switch (ThrSTATE(t)) {
272 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
273 "perl_destruct: joining zombie %p\n", t));
274 ThrSETSTATE(t, THRf_DEAD);
275 MUTEX_UNLOCK(&t->mutex);
278 * The SvREFCNT_dec below may take a long time (e.g. av
279 * may contain an object scalar whose destructor gets
280 * called) so we have to unlock threads_mutex and start
283 MUTEX_UNLOCK(&threads_mutex);
285 SvREFCNT_dec((SV*)av);
286 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
287 "perl_destruct: joined zombie %p OK\n", t));
289 case THRf_R_JOINABLE:
290 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
291 "perl_destruct: detaching thread %p\n", t));
292 ThrSETSTATE(t, THRf_R_DETACHED);
294 * We unlock threads_mutex and t->mutex in the opposite order
295 * from which we locked them just so that DETACH won't
296 * deadlock if it panics. It's only a breach of good style
297 * not a bug since they are unlocks not locks.
299 MUTEX_UNLOCK(&threads_mutex);
301 MUTEX_UNLOCK(&t->mutex);
304 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
305 "perl_destruct: ignoring %p (state %u)\n",
307 MUTEX_UNLOCK(&t->mutex);
308 /* fall through and out */
311 /* We leave the above "Pass 1" loop with threads_mutex still locked */
313 /* Pass 2 on remaining threads: wait for the thread count to drop to one */
316 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
317 "perl_destruct: final wait for %d threads\n",
319 COND_WAIT(&nthreads_cond, &threads_mutex);
321 /* At this point, we're the last thread */
322 MUTEX_UNLOCK(&threads_mutex);
323 DEBUG_L(PerlIO_printf(PerlIO_stderr(), "perl_destruct: armageddon has arrived\n"));
324 MUTEX_DESTROY(&threads_mutex);
325 COND_DESTROY(&nthreads_cond);
326 #endif /* !defined(FAKE_THREADS) */
327 #endif /* USE_THREADS */
329 destruct_level = perl_destruct_level;
333 if (s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL")) {
335 if (destruct_level < i)
344 /* We must account for everything. */
346 /* Destroy the main CV and syntax tree */
348 curpad = AvARRAY(comppad);
353 SvREFCNT_dec(main_cv);
358 * Try to destruct global references. We do this first so that the
359 * destructors and destructees still exist. Some sv's might remain.
360 * Non-referenced objects are on their own.
367 /* unhook hooks which will soon be, or use, destroyed data */
368 SvREFCNT_dec(warnhook);
370 SvREFCNT_dec(diehook);
372 SvREFCNT_dec(parsehook);
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 */
420 /* magical thingies */
422 Safefree(ofs); /* $, */
425 Safefree(ors); /* $\ */
428 SvREFCNT_dec(nrs); /* $\ helper */
431 multiline = 0; /* $* */
433 SvREFCNT_dec(statname);
437 /* defgv, aka *_ should be taken care of elsewhere */
439 /* clean up after study() */
440 SvREFCNT_dec(lastscream);
442 Safefree(screamfirst);
444 Safefree(screamnext);
447 /* startup and shutdown function lists */
448 SvREFCNT_dec(beginav);
450 SvREFCNT_dec(initav);
455 /* temp stack during pp_sort() */
456 SvREFCNT_dec(sortstack);
459 /* shortcuts just get cleared */
469 /* reset so print() ends up where we expect */
472 /* Prepare to destruct main symbol table. */
479 if (destruct_level >= 2) {
480 if (scopestack_ix != 0)
481 warn("Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
482 (long)scopestack_ix);
483 if (savestack_ix != 0)
484 warn("Unbalanced saves: %ld more saves than restores\n",
486 if (tmps_floor != -1)
487 warn("Unbalanced tmps: %ld more allocs than frees\n",
488 (long)tmps_floor + 1);
489 if (cxstack_ix != -1)
490 warn("Unbalanced context: %ld more PUSHes than POPs\n",
491 (long)cxstack_ix + 1);
494 /* Now absolutely destruct everything, somehow or other, loops or no. */
496 SvFLAGS(strtab) |= SVTYPEMASK; /* don't clean out strtab now */
497 while (sv_count != 0 && sv_count != last_sv_count) {
498 last_sv_count = sv_count;
501 SvFLAGS(strtab) &= ~SVTYPEMASK;
502 SvFLAGS(strtab) |= SVt_PVHV;
504 /* Destruct the global string table. */
506 /* Yell and reset the HeVAL() slots that are still holding refcounts,
507 * so that sv_free() won't fail on them.
516 array = HvARRAY(strtab);
520 warn("Unbalanced string table refcount: (%d) for \"%s\"",
521 HeVAL(hent) - Nullsv, HeKEY(hent));
522 HeVAL(hent) = Nullsv;
532 SvREFCNT_dec(strtab);
535 warn("Scalars leaked: %ld\n", (long)sv_count);
539 /* No SVs have survived, need to clean out */
543 Safefree(origfilename);
545 hints = 0; /* Reset hints. Should hints be per-interpreter ? */
547 DEBUG_P(debprofdump());
549 MUTEX_DESTROY(&sv_mutex);
550 MUTEX_DESTROY(&eval_mutex);
551 COND_DESTROY(&eval_cond);
553 /* As the penultimate thing, free the non-arena SV for thrsv */
554 Safefree(SvPVX(thrsv));
555 Safefree(SvANY(thrsv));
558 #endif /* USE_THREADS */
560 /* As the absolutely last thing, free the non-arena SV for mess() */
563 /* we know that type >= SVt_PV */
565 Safefree(SvPVX(mess_sv));
566 Safefree(SvANY(mess_sv));
574 CPerlObj::perl_free(void)
576 perl_free(PerlInterpreter *sv_interp)
582 if (!(curinterp = sv_interp))
590 CPerlObj::perl_parse(void (*xsinit) (CPerlObj*), int argc, char **argv, char **env)
592 perl_parse(PerlInterpreter *sv_interp, void (*xsinit) (void), int argc, char **argv, char **env)
598 char *scriptname = NULL;
599 VOL bool dosearch = FALSE;
607 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
610 croak("suidperl is no longer needed since the kernel can now execute\n\
611 setuid perl scripts securely.\n");
616 if (!(curinterp = sv_interp))
620 #if defined(NeXT) && defined(__DYNAMIC__)
621 _dyld_lookup_and_bind
622 ("__environ", (unsigned long *) &environ_pointer, NULL);
627 #ifndef VMS /* VMS doesn't have environ array */
628 origenviron = environ;
634 /* Come here if running an undumped a.out. */
636 origfilename = savepv(argv[0]);
638 cxstack_ix = -1; /* start label stack again */
640 init_postdump_symbols(argc,argv,env);
645 curpad = AvARRAY(comppad);
650 SvREFCNT_dec(main_cv);
654 oldscope = scopestack_ix;
662 /* my_exit() was called */
663 while (scopestack_ix > oldscope)
668 call_list(oldscope, endav);
670 return STATUS_NATIVE_EXPORT;
673 PerlIO_printf(PerlIO_stderr(), "panic: top_env\n");
677 sv_setpvn(linestr,"",0);
678 sv = newSVpv("",0); /* first used for -I flags */
682 for (argc--,argv++; argc > 0; argc--,argv++) {
683 if (argv[0][0] != '-' || !argv[0][1])
687 validarg = " PHOOEY ";
712 if (s = moreswitches(s))
722 if (euid != uid || egid != gid)
723 croak("No -e allowed in setuid scripts");
725 e_tmpname = savepv(TMPPATH);
726 (void)PerlLIO_mktemp(e_tmpname);
728 croak("Can't mktemp()");
729 e_fp = PerlIO_open(e_tmpname,"w");
731 croak("Cannot open temporary file");
736 PerlIO_puts(e_fp,argv[1]);
740 croak("No code specified for -e");
741 (void)PerlIO_putc(e_fp,'\n');
743 case 'I': /* -I handled both here and in moreswitches() */
745 if (!*++s && (s=argv[1]) != Nullch) {
748 while (s && isSPACE(*s))
752 for (e = s; *e && !isSPACE(*e); e++) ;
759 } /* XXX else croak? */
773 preambleav = newAV();
774 av_push(preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
776 Sv = newSVpv("print myconfig();",0);
778 sv_catpv(Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
780 sv_catpv(Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
782 #if defined(DEBUGGING) || defined(NO_EMBED) || defined(MULTIPLICITY)
783 sv_catpv(Sv,"\" Compile-time options:");
785 sv_catpv(Sv," DEBUGGING");
788 sv_catpv(Sv," NO_EMBED");
791 sv_catpv(Sv," MULTIPLICITY");
793 sv_catpv(Sv,"\\n\",");
795 #if defined(LOCAL_PATCH_COUNT)
796 if (LOCAL_PATCH_COUNT > 0) {
798 sv_catpv(Sv,"\" Locally applied patches:\\n\",");
799 for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
801 sv_catpvf(Sv,"\" \\t%s\\n\",",localpatches[i]);
805 sv_catpvf(Sv,"\" Built under %s\\n\"",OSNAME);
808 sv_catpvf(Sv,",\" Compiled at %s %s\\n\"",__DATE__,__TIME__);
810 sv_catpvf(Sv,",\" Compiled on %s\\n\"",__DATE__);
815 @env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; \
816 print \" \\%ENV:\\n @env\\n\" if @env; \
817 print \" \\@INC:\\n @INC\\n\";");
820 Sv = newSVpv("config_vars(qw(",0);
825 av_push(preambleav, Sv);
826 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
837 if (!*++s || isSPACE(*s)) {
841 /* catch use of gnu style long options */
842 if (strEQ(s, "version")) {
846 if (strEQ(s, "help")) {
853 croak("Unrecognized switch: -%s (-h will show valid options)",s);
858 if (!tainting && (s = PerlEnv_getenv("PERL5OPT"))) {
869 if (!strchr("DIMUdmw", *s))
870 croak("Illegal switch in PERL5OPT: -%c", *s);
876 scriptname = argv[0];
878 if (PerlIO_flush(e_fp) || PerlIO_error(e_fp) || PerlIO_close(e_fp)) {
880 warn("Did you forget to compile with -DMULTIPLICITY?");
882 croak("Can't write to temp file for -e: %s", Strerror(errno));
886 scriptname = e_tmpname;
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)(THIS); /* in case linked C routines want magical variables */
935 #if defined(VMS) || defined(WIN32) || defined(DJGPP)
939 init_predump_symbols();
941 init_postdump_symbols(argc,argv,env);
945 /* now parse the script */
947 SETERRNO(0,SS$_NORMAL);
949 if (yyparse() || error_count) {
951 croak("%s had compilation errors.\n", origfilename);
953 croak("Execution of %s aborted due to compilation errors.\n",
957 curcop->cop_line = 0;
961 (void)UNLINK(e_tmpname);
966 /* now that script is parsed, we can modify record separator */
968 rs = SvREFCNT_inc(nrs);
969 sv_setsv(perl_get_sv("/", TRUE), rs);
980 if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
981 dump_mstats("after compilation:");
992 CPerlObj::perl_run(void)
994 perl_run(PerlInterpreter *sv_interp)
1003 if (!(curinterp = sv_interp))
1007 oldscope = scopestack_ix;
1012 cxstack_ix = -1; /* start context stack again */
1015 /* my_exit() was called */
1016 while (scopestack_ix > oldscope)
1019 curstash = defstash;
1021 call_list(oldscope, endav);
1023 if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
1024 dump_mstats("after execution: ");
1027 return STATUS_NATIVE_EXPORT;
1030 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
1035 if (curstack != mainstack) {
1037 SWITCHSTACK(curstack, mainstack);
1042 DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
1043 sawampersand ? "Enabling" : "Omitting"));
1046 DEBUG_x(dump_all());
1047 DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
1049 DEBUG_L(PerlIO_printf(Perl_debug_log, "main thread is 0x%lx\n",
1050 (unsigned long) thr));
1051 #endif /* USE_THREADS */
1054 PerlIO_printf(PerlIO_stderr(), "%s syntax OK\n", origfilename);
1057 if (PERLDB_SINGLE && DBsingle)
1058 sv_setiv(DBsingle, 1);
1060 call_list(oldscope, initav);
1070 else if (main_start) {
1071 CvDEPTH(main_cv) = 1;
1082 perl_get_sv(char *name, I32 create)
1086 if (name[1] == '\0' && !isALPHA(name[0])) {
1087 PADOFFSET tmp = find_threadsv(name);
1088 if (tmp != NOT_IN_PAD) {
1090 return THREADSV(tmp);
1093 #endif /* USE_THREADS */
1094 gv = gv_fetchpv(name, create, SVt_PV);
1101 perl_get_av(char *name, I32 create)
1103 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
1112 perl_get_hv(char *name, I32 create)
1114 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
1123 perl_get_cv(char *name, I32 create)
1125 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
1126 if (create && !GvCVu(gv))
1127 return newSUB(start_subparse(FALSE, 0),
1128 newSVOP(OP_CONST, 0, newSVpv(name,0)),
1136 /* Be sure to refetch the stack pointer after calling these routines. */
1139 perl_call_argv(char *sub_name, I32 flags, register char **argv)
1141 /* See G_* flags in cop.h */
1142 /* null terminated arg list */
1149 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
1154 return perl_call_pv(sub_name, flags);
1158 perl_call_pv(char *sub_name, I32 flags)
1159 /* name of the subroutine */
1160 /* See G_* flags in cop.h */
1162 return perl_call_sv((SV*)perl_get_cv(sub_name, TRUE), flags);
1166 perl_call_method(char *methname, I32 flags)
1167 /* name of the subroutine */
1168 /* See G_* flags in cop.h */
1174 XPUSHs(sv_2mortal(newSVpv(methname,0)));
1177 return perl_call_sv(*stack_sp--, flags);
1180 /* May be called with any of a CV, a GV, or an SV containing the name. */
1182 perl_call_sv(SV *sv, I32 flags)
1184 /* See G_* flags in cop.h */
1187 LOGOP myop; /* fake syntax tree node */
1191 bool oldcatch = CATCH_GET;
1196 if (flags & G_DISCARD) {
1201 Zero(&myop, 1, LOGOP);
1202 myop.op_next = Nullop;
1203 if (!(flags & G_NOARGS))
1204 myop.op_flags |= OPf_STACKED;
1205 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1206 (flags & G_ARRAY) ? OPf_WANT_LIST :
1211 EXTEND(stack_sp, 1);
1214 oldscope = scopestack_ix;
1216 if (PERLDB_SUB && curstash != debstash
1217 /* Handle first BEGIN of -d. */
1218 && (DBcv || (DBcv = GvCV(DBsub)))
1219 /* Try harder, since this may have been a sighandler, thus
1220 * curstash may be meaningless. */
1221 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != debstash))
1222 op->op_private |= OPpENTERSUB_DB;
1224 if (flags & G_EVAL) {
1225 cLOGOP->op_other = op;
1227 /* we're trying to emulate pp_entertry() here */
1229 register PERL_CONTEXT *cx;
1230 I32 gimme = GIMME_V;
1235 push_return(op->op_next);
1236 PUSHBLOCK(cx, CXt_EVAL, stack_sp);
1238 eval_root = op; /* Only needed so that goto works right. */
1241 if (flags & G_KEEPERR)
1256 /* my_exit() was called */
1257 curstash = defstash;
1261 croak("Callback called exit");
1270 stack_sp = stack_base + oldmark;
1271 if (flags & G_ARRAY)
1275 *++stack_sp = &sv_undef;
1283 if (op == (OP*)&myop)
1284 op = pp_entersub(ARGS);
1287 retval = stack_sp - (stack_base + oldmark);
1288 if ((flags & G_EVAL) && !(flags & G_KEEPERR))
1292 if (flags & G_EVAL) {
1293 if (scopestack_ix > oldscope) {
1297 register PERL_CONTEXT *cx;
1309 CATCH_SET(oldcatch);
1311 if (flags & G_DISCARD) {
1312 stack_sp = stack_base + oldmark;
1321 /* Eval a string. The G_EVAL flag is always assumed. */
1324 perl_eval_sv(SV *sv, I32 flags)
1326 /* See G_* flags in cop.h */
1329 UNOP myop; /* fake syntax tree node */
1330 I32 oldmark = SP - stack_base;
1337 if (flags & G_DISCARD) {
1345 EXTEND(stack_sp, 1);
1347 oldscope = scopestack_ix;
1349 if (!(flags & G_NOARGS))
1350 myop.op_flags = OPf_STACKED;
1351 myop.op_next = Nullop;
1352 myop.op_type = OP_ENTEREVAL;
1353 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1354 (flags & G_ARRAY) ? OPf_WANT_LIST :
1356 if (flags & G_KEEPERR)
1357 myop.op_flags |= OPf_SPECIAL;
1367 /* my_exit() was called */
1368 curstash = defstash;
1372 croak("Callback called exit");
1381 stack_sp = stack_base + oldmark;
1382 if (flags & G_ARRAY)
1386 *++stack_sp = &sv_undef;
1391 if (op == (OP*)&myop)
1392 op = pp_entereval(ARGS);
1395 retval = stack_sp - (stack_base + oldmark);
1396 if (!(flags & G_KEEPERR))
1401 if (flags & G_DISCARD) {
1402 stack_sp = stack_base + oldmark;
1412 perl_eval_pv(char *p, I32 croak_on_error)
1415 SV* sv = newSVpv(p, 0);
1418 perl_eval_sv(sv, G_SCALAR);
1425 if (croak_on_error && SvTRUE(ERRSV))
1426 croak(SvPVx(ERRSV, na));
1431 /* Require a module. */
1434 perl_require_pv(char *pv)
1436 SV* sv = sv_newmortal();
1437 sv_setpv(sv, "require '");
1440 perl_eval_sv(sv, G_DISCARD);
1444 magicname(char *sym, char *name, I32 namlen)
1448 if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
1449 sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
1453 usage(char *name) /* XXX move this out into a module ? */
1456 /* This message really ought to be max 23 lines.
1457 * Removed -h because the user already knows that opton. Others? */
1459 static char *usage_msg[] = {
1460 "-0[octal] specify record separator (\\0, if no argument)",
1461 "-a autosplit mode with -n or -p (splits $_ into @F)",
1462 "-c check syntax only (runs BEGIN and END blocks)",
1463 "-d[:debugger] run scripts under debugger",
1464 "-D[number/list] set debugging flags (argument is a bit mask or flags)",
1465 "-e 'command' one line of script. Several -e's allowed. Omit [programfile].",
1466 "-F/pattern/ split() pattern for autosplit (-a). The //'s are optional.",
1467 "-i[extension] edit <> files in place (make backup if extension supplied)",
1468 "-Idirectory specify @INC/#include directory (may be used more than once)",
1469 "-l[octal] enable line ending processing, specifies line terminator",
1470 "-[mM][-]module.. executes `use/no module...' before executing your script.",
1471 "-n assume 'while (<>) { ... }' loop around your script",
1472 "-p assume loop like -n but print line also like sed",
1473 "-P run script through C preprocessor before compilation",
1474 "-s enable some switch parsing for switches after script name",
1475 "-S look for the script using PATH environment variable",
1476 "-T turn on tainting checks",
1477 "-u dump core after parsing script",
1478 "-U allow unsafe operations",
1479 "-v print version number and patchlevel of perl",
1480 "-V[:variable] print perl configuration information",
1481 "-w TURN WARNINGS ON FOR COMPILATION OF YOUR SCRIPT. Recommended.",
1482 "-x[directory] strip off text before #!perl line and perhaps cd to directory",
1486 char **p = usage_msg;
1488 printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
1490 printf("\n %s", *p++);
1493 /* This routine handles any switches that can be given during run */
1496 moreswitches(char *s)
1505 rschar = scan_oct(s, 4, &numlen);
1507 if (rschar & ~((U8)~0))
1509 else if (!rschar && numlen >= 2)
1510 nrs = newSVpv("", 0);
1513 nrs = newSVpv(&ch, 1);
1519 splitstr = savepv(s + 1);
1533 if (*s == ':' || *s == '=') {
1534 my_setenv("PERL5DB", form("use Devel::%s;", ++s));
1538 perldb = PERLDB_ALL;
1545 if (isALPHA(s[1])) {
1546 static char debopts[] = "psltocPmfrxuLHXD";
1549 for (s++; *s && (d = strchr(debopts,*s)); s++)
1550 debug |= 1 << (d - debopts);
1554 for (s++; isDIGIT(*s); s++) ;
1556 debug |= 0x80000000;
1558 warn("Recompile perl with -DDEBUGGING to use -D switch\n");
1559 for (s++; isALNUM(*s); s++) ;
1569 inplace = savepv(s+1);
1571 for (s = inplace; *s && !isSPACE(*s); s++) ;
1575 case 'I': /* -I handled both here and in parse_perl() */
1578 while (*s && isSPACE(*s))
1582 for (e = s; *e && !isSPACE(*e); e++) ;
1583 p = savepvn(s, e-s);
1589 croak("No space allowed after -I");
1599 *ors = scan_oct(s, 3 + (*s == '0'), &numlen);
1609 ors = SvPV(nrs, orslen);
1610 ors = savepvn(ors, orslen);
1614 forbid_setid("-M"); /* XXX ? */
1617 forbid_setid("-m"); /* XXX ? */
1622 /* -M-foo == 'no foo' */
1623 if (*s == '-') { use = "no "; ++s; }
1624 sv = newSVpv(use,0);
1626 /* We allow -M'Module qw(Foo Bar)' */
1627 while(isALNUM(*s) || *s==':') ++s;
1629 sv_catpv(sv, start);
1630 if (*(start-1) == 'm') {
1632 croak("Can't use '%c' after -mname", *s);
1633 sv_catpv( sv, " ()");
1636 sv_catpvn(sv, start, s-start);
1637 sv_catpv(sv, " split(/,/,q{");
1642 if (preambleav == NULL)
1643 preambleav = newAV();
1644 av_push(preambleav, sv);
1647 croak("No space allowed after -%c", *(s-1));
1664 croak("Too late for \"-T\" option");
1676 #if defined(SUBVERSION) && SUBVERSION > 0
1677 printf("\nThis is perl, version 5.%03d_%02d built for %s",
1678 PATCHLEVEL, SUBVERSION, ARCHNAME);
1680 printf("\nThis is perl, version %s built for %s",
1681 patchlevel, ARCHNAME);
1683 #if defined(LOCAL_PATCH_COUNT)
1684 if (LOCAL_PATCH_COUNT > 0)
1685 printf("\n(with %d registered patch%s, see perl -V for more detail)",
1686 LOCAL_PATCH_COUNT, (LOCAL_PATCH_COUNT!=1) ? "es" : "");
1689 printf("\n\nCopyright 1987-1998, Larry Wall\n");
1691 printf("\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
1694 printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n");
1695 printf("djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1998\n");
1698 printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
1699 "Version 5 port Copyright (c) 1994-1998, Andreas Kaiser, Ilya Zakharevich\n");
1702 printf("atariST series port, ++jrb bammi@cadence.com\n");
1705 Perl may be copied only under the terms of either the Artistic License or the\n\
1706 GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n");
1714 if (s[1] == '-') /* Additional switches on #! line. */
1725 #ifdef ALTERNATE_SHEBANG
1726 case 'S': /* OS/2 needs -S on "extproc" line. */
1734 croak("Can't emulate -%.1s on #! line",s);
1739 /* compliments of Tom Christiansen */
1741 /* unexec() can be found in the Gnu emacs distribution */
1752 prog = newSVpv(BIN_EXP);
1753 sv_catpv(prog, "/perl");
1754 file = newSVpv(origfilename);
1755 sv_catpv(file, ".perldump");
1757 status = unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
1759 PerlIO_printf(PerlIO_stderr(), "unexec of %s into %s failed!\n",
1760 SvPVX(prog), SvPVX(file));
1761 PerlProc_exit(status);
1764 # include <lib$routines.h>
1765 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
1767 ABORT(); /* for use with undump */
1773 init_main_stash(void)
1778 /* Note that strtab is a rather special HV. Assumptions are made
1779 about not iterating on it, and not adding tie magic to it.
1780 It is properly deallocated in perl_destruct() */
1782 HvSHAREKEYS_off(strtab); /* mandatory */
1783 Newz(506,((XPVHV*)SvANY(strtab))->xhv_array,
1784 sizeof(HE*) * (((XPVHV*)SvANY(strtab))->xhv_max + 1), char);
1786 curstash = defstash = newHV();
1787 curstname = newSVpv("main",4);
1788 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
1789 SvREFCNT_dec(GvHV(gv));
1790 GvHV(gv) = (HV*)SvREFCNT_inc(defstash);
1792 HvNAME(defstash) = savepv("main");
1793 incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
1795 defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
1796 errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
1798 (void)form("%240s",""); /* Preallocate temp - for immediate signals. */
1799 sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */
1800 sv_setpvn(ERRSV, "", 0);
1801 curstash = defstash;
1802 compiling.cop_stash = defstash;
1803 debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
1804 globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
1805 /* We must init $/ before switches are processed. */
1806 sv_setpvn(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), "\n", 1);
1810 open_script(char *scriptname, bool dosearch, SV *sv, int *fdscript)
1813 char *xfound = Nullch;
1814 char *xfailed = Nullch;
1818 #if defined(DOSISH) && !defined(OS2) && !defined(atarist)
1819 # define SEARCH_EXTS ".bat", ".cmd", NULL
1820 # define MAX_EXT_LEN 4
1823 # define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL
1824 # define MAX_EXT_LEN 4
1827 # define SEARCH_EXTS ".pl", ".com", NULL
1828 # define MAX_EXT_LEN 4
1830 /* additional extensions to try in each dir if scriptname not found */
1832 char *ext[] = { SEARCH_EXTS };
1833 int extidx = 0, i = 0;
1834 char *curext = Nullch;
1836 # define MAX_EXT_LEN 0
1840 * If dosearch is true and if scriptname does not contain path
1841 * delimiters, search the PATH for scriptname.
1843 * If SEARCH_EXTS is also defined, will look for each
1844 * scriptname{SEARCH_EXTS} whenever scriptname is not found
1845 * while searching the PATH.
1847 * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
1848 * proceeds as follows:
1849 * If DOSISH or VMSISH:
1850 * + look for ./scriptname{,.foo,.bar}
1851 * + search the PATH for scriptname{,.foo,.bar}
1854 * + look *only* in the PATH for scriptname{,.foo,.bar} (note
1855 * this will not look in '.' if it's not in the PATH)
1859 # ifdef ALWAYS_DEFTYPES
1860 len = strlen(scriptname);
1861 if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') {
1862 int hasdir, idx = 0, deftypes = 1;
1865 hasdir = !dosearch || (strpbrk(scriptname,":[</") != Nullch) ;
1868 int hasdir, idx = 0, deftypes = 1;
1871 hasdir = (strpbrk(scriptname,":[</") != Nullch) ;
1873 /* The first time through, just add SEARCH_EXTS to whatever we
1874 * already have, so we can check for default file types. */
1876 (!hasdir && my_trnlnm("DCL$PATH",tokenbuf,idx++)) )
1882 if ((strlen(tokenbuf) + strlen(scriptname)
1883 + MAX_EXT_LEN) >= sizeof tokenbuf)
1884 continue; /* don't search dir with too-long name */
1885 strcat(tokenbuf, scriptname);
1889 if (strEQ(scriptname, "-"))
1891 if (dosearch) { /* Look in '.' first. */
1892 char *cur = scriptname;
1894 if ((curext = strrchr(scriptname,'.'))) /* possible current ext */
1896 if (strEQ(ext[i++],curext)) {
1897 extidx = -1; /* already has an ext */
1902 DEBUG_p(PerlIO_printf(Perl_debug_log,
1903 "Looking for %s\n",cur));
1904 if (PerlLIO_stat(cur,&statbuf) >= 0) {
1912 if (cur == scriptname) {
1913 len = strlen(scriptname);
1914 if (len+MAX_EXT_LEN+1 >= sizeof(tokenbuf))
1916 cur = strcpy(tokenbuf, scriptname);
1918 } while (extidx >= 0 && ext[extidx] /* try an extension? */
1919 && strcpy(tokenbuf+len, ext[extidx++]));
1924 if (dosearch && !strchr(scriptname, '/')
1926 && !strchr(scriptname, '\\')
1928 && (s = PerlEnv_getenv("PATH"))) {
1931 bufend = s + strlen(s);
1932 while (s < bufend) {
1933 #if defined(atarist) || defined(DOSISH)
1938 && *s != ';'; len++, s++) {
1939 if (len < sizeof tokenbuf)
1942 if (len < sizeof tokenbuf)
1943 tokenbuf[len] = '\0';
1944 #else /* ! (atarist || DOSISH) */
1945 s = delimcpy(tokenbuf, tokenbuf + sizeof tokenbuf, s, bufend,
1948 #endif /* ! (atarist || DOSISH) */
1951 if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tokenbuf)
1952 continue; /* don't search dir with too-long name */
1954 #if defined(atarist) || defined(DOSISH)
1955 && tokenbuf[len - 1] != '/'
1956 && tokenbuf[len - 1] != '\\'
1959 tokenbuf[len++] = '/';
1960 if (len == 2 && tokenbuf[0] == '.')
1962 (void)strcpy(tokenbuf + len, scriptname);
1966 len = strlen(tokenbuf);
1967 if (extidx > 0) /* reset after previous loop */
1971 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tokenbuf));
1972 retval = PerlLIO_stat(tokenbuf,&statbuf);
1974 } while ( retval < 0 /* not there */
1975 && extidx>=0 && ext[extidx] /* try an extension? */
1976 && strcpy(tokenbuf+len, ext[extidx++])
1981 if (S_ISREG(statbuf.st_mode)
1982 && cando(S_IRUSR,TRUE,&statbuf)
1984 && cando(S_IXUSR,TRUE,&statbuf)
1988 xfound = tokenbuf; /* bingo! */
1992 xfailed = savepv(tokenbuf);
1995 if (!xfound && !seen_dot && !xfailed && (PerlLIO_stat(scriptname,&statbuf) < 0))
1997 seen_dot = 1; /* Disable message. */
1999 croak("Can't %s %s%s%s",
2000 (xfailed ? "execute" : "find"),
2001 (xfailed ? xfailed : scriptname),
2002 (xfailed ? "" : " on PATH"),
2003 (xfailed || seen_dot) ? "" : ", '.' not in PATH");
2006 scriptname = xfound;
2009 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
2010 char *s = scriptname + 8;
2011 *fdscript = atoi(s);
2019 origfilename = savepv(e_tmpname ? "-e" : scriptname);
2020 curcop->cop_filegv = gv_fetchfile(origfilename);
2021 if (strEQ(origfilename,"-"))
2023 if (*fdscript >= 0) {
2024 rsfp = PerlIO_fdopen(*fdscript,PERL_SCRIPT_MODE);
2025 #if defined(HAS_FCNTL) && defined(F_SETFD)
2027 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
2030 else if (preprocess) {
2031 char *cpp_cfg = CPPSTDIN;
2032 SV *cpp = NEWSV(0,0);
2033 SV *cmd = NEWSV(0,0);
2035 if (strEQ(cpp_cfg, "cppstdin"))
2036 sv_catpvf(cpp, "%s/", BIN_EXP);
2037 sv_catpv(cpp, cpp_cfg);
2040 sv_catpv(sv,PRIVLIB_EXP);
2044 sed %s -e \"/^[^#]/b\" \
2045 -e \"/^#[ ]*include[ ]/b\" \
2046 -e \"/^#[ ]*define[ ]/b\" \
2047 -e \"/^#[ ]*if[ ]/b\" \
2048 -e \"/^#[ ]*ifdef[ ]/b\" \
2049 -e \"/^#[ ]*ifndef[ ]/b\" \
2050 -e \"/^#[ ]*else/b\" \
2051 -e \"/^#[ ]*elif[ ]/b\" \
2052 -e \"/^#[ ]*undef[ ]/b\" \
2053 -e \"/^#[ ]*endif/b\" \
2056 (doextract ? "-e \"1,/^#/d\n\"" : ""),
2059 %s %s -e '/^[^#]/b' \
2060 -e '/^#[ ]*include[ ]/b' \
2061 -e '/^#[ ]*define[ ]/b' \
2062 -e '/^#[ ]*if[ ]/b' \
2063 -e '/^#[ ]*ifdef[ ]/b' \
2064 -e '/^#[ ]*ifndef[ ]/b' \
2065 -e '/^#[ ]*else/b' \
2066 -e '/^#[ ]*elif[ ]/b' \
2067 -e '/^#[ ]*undef[ ]/b' \
2068 -e '/^#[ ]*endif/b' \
2076 (doextract ? "-e '1,/^#/d\n'" : ""),
2078 scriptname, cpp, sv, CPPMINUS);
2080 #ifdef IAMSUID /* actually, this is caught earlier */
2081 if (euid != uid && !euid) { /* if running suidperl */
2083 (void)seteuid(uid); /* musn't stay setuid root */
2086 (void)setreuid((Uid_t)-1, uid);
2088 #ifdef HAS_SETRESUID
2089 (void)setresuid((Uid_t)-1, uid, (Uid_t)-1);
2091 PerlProc_setuid(uid);
2095 if (PerlProc_geteuid() != uid)
2096 croak("Can't do seteuid!\n");
2098 #endif /* IAMSUID */
2099 rsfp = PerlProc_popen(SvPVX(cmd), "r");
2103 else if (!*scriptname) {
2104 forbid_setid("program input from stdin");
2105 rsfp = PerlIO_stdin();
2108 rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
2109 #if defined(HAS_FCNTL) && defined(F_SETFD)
2111 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
2119 #ifndef IAMSUID /* in case script is not readable before setuid */
2120 if (euid && PerlLIO_stat(SvPVX(GvSV(curcop->cop_filegv)),&statbuf) >= 0 &&
2121 statbuf.st_mode & (S_ISUID|S_ISGID)) {
2123 PerlProc_execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
2124 croak("Can't do setuid\n");
2128 croak("Can't open perl script \"%s\": %s\n",
2129 SvPVX(GvSV(curcop->cop_filegv)), Strerror(errno));
2134 validate_suid(char *validarg, char *scriptname, int fdscript)
2138 /* do we need to emulate setuid on scripts? */
2140 /* This code is for those BSD systems that have setuid #! scripts disabled
2141 * in the kernel because of a security problem. Merely defining DOSUID
2142 * in perl will not fix that problem, but if you have disabled setuid
2143 * scripts in the kernel, this will attempt to emulate setuid and setgid
2144 * on scripts that have those now-otherwise-useless bits set. The setuid
2145 * root version must be called suidperl or sperlN.NNN. If regular perl
2146 * discovers that it has opened a setuid script, it calls suidperl with
2147 * the same argv that it had. If suidperl finds that the script it has
2148 * just opened is NOT setuid root, it sets the effective uid back to the
2149 * uid. We don't just make perl setuid root because that loses the
2150 * effective uid we had before invoking perl, if it was different from the
2153 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
2154 * be defined in suidperl only. suidperl must be setuid root. The
2155 * Configure script will set this up for you if you want it.
2162 if (PerlLIO_fstat(PerlIO_fileno(rsfp),&statbuf) < 0) /* normal stat is insecure */
2163 croak("Can't stat script \"%s\"",origfilename);
2164 if (fdscript < 0 && statbuf.st_mode & (S_ISUID|S_ISGID)) {
2168 #ifndef HAS_SETREUID
2169 /* On this access check to make sure the directories are readable,
2170 * there is actually a small window that the user could use to make
2171 * filename point to an accessible directory. So there is a faint
2172 * chance that someone could execute a setuid script down in a
2173 * non-accessible directory. I don't know what to do about that.
2174 * But I don't think it's too important. The manual lies when
2175 * it says access() is useful in setuid programs.
2177 if (PerlLIO_access(SvPVX(GvSV(curcop->cop_filegv)),1)) /*double check*/
2178 croak("Permission denied");
2180 /* If we can swap euid and uid, then we can determine access rights
2181 * with a simple stat of the file, and then compare device and
2182 * inode to make sure we did stat() on the same file we opened.
2183 * Then we just have to make sure he or she can execute it.
2186 struct stat tmpstatbuf;
2190 setreuid(euid,uid) < 0
2193 setresuid(euid,uid,(Uid_t)-1) < 0
2196 || PerlProc_getuid() != euid || PerlProc_geteuid() != uid)
2197 croak("Can't swap uid and euid"); /* really paranoid */
2198 if (PerlLIO_stat(SvPVX(GvSV(curcop->cop_filegv)),&tmpstatbuf) < 0)
2199 croak("Permission denied"); /* testing full pathname here */
2200 if (tmpstatbuf.st_dev != statbuf.st_dev ||
2201 tmpstatbuf.st_ino != statbuf.st_ino) {
2202 (void)PerlIO_close(rsfp);
2203 if (rsfp = PerlProc_popen("/bin/mail root","w")) { /* heh, heh */
2205 "User %ld tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
2206 (Filename of set-id script was %s, uid %ld gid %ld.)\n\nSincerely,\nperl\n",
2207 (long)uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
2208 (long)statbuf.st_dev, (long)statbuf.st_ino,
2209 SvPVX(GvSV(curcop->cop_filegv)),
2210 (long)statbuf.st_uid, (long)statbuf.st_gid);
2211 (void)PerlProc_pclose(rsfp);
2213 croak("Permission denied\n");
2217 setreuid(uid,euid) < 0
2219 # if defined(HAS_SETRESUID)
2220 setresuid(uid,euid,(Uid_t)-1) < 0
2223 || PerlProc_getuid() != uid || PerlProc_geteuid() != euid)
2224 croak("Can't reswap uid and euid");
2225 if (!cando(S_IXUSR,FALSE,&statbuf)) /* can real uid exec? */
2226 croak("Permission denied\n");
2228 #endif /* HAS_SETREUID */
2229 #endif /* IAMSUID */
2231 if (!S_ISREG(statbuf.st_mode))
2232 croak("Permission denied");
2233 if (statbuf.st_mode & S_IWOTH)
2234 croak("Setuid/gid script is writable by world");
2235 doswitches = FALSE; /* -s is insecure in suid */
2237 if (sv_gets(linestr, rsfp, 0) == Nullch ||
2238 strnNE(SvPV(linestr,na),"#!",2) ) /* required even on Sys V */
2239 croak("No #! line");
2240 s = SvPV(linestr,na)+2;
2242 while (!isSPACE(*s)) s++;
2243 for (s2 = s; (s2 > SvPV(linestr,na)+2 &&
2244 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
2245 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
2246 croak("Not a perl script");
2247 while (*s == ' ' || *s == '\t') s++;
2249 * #! arg must be what we saw above. They can invoke it by
2250 * mentioning suidperl explicitly, but they may not add any strange
2251 * arguments beyond what #! says if they do invoke suidperl that way.
2253 len = strlen(validarg);
2254 if (strEQ(validarg," PHOOEY ") ||
2255 strnNE(s,validarg,len) || !isSPACE(s[len]))
2256 croak("Args must match #! line");
2259 if (euid != uid && (statbuf.st_mode & S_ISUID) &&
2260 euid == statbuf.st_uid)
2262 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2263 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2264 #endif /* IAMSUID */
2266 if (euid) { /* oops, we're not the setuid root perl */
2267 (void)PerlIO_close(rsfp);
2270 PerlProc_execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
2272 croak("Can't do setuid\n");
2275 if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid) {
2277 (void)setegid(statbuf.st_gid);
2280 (void)setregid((Gid_t)-1,statbuf.st_gid);
2282 #ifdef HAS_SETRESGID
2283 (void)setresgid((Gid_t)-1,statbuf.st_gid,(Gid_t)-1);
2285 PerlProc_setgid(statbuf.st_gid);
2289 if (PerlProc_getegid() != statbuf.st_gid)
2290 croak("Can't do setegid!\n");
2292 if (statbuf.st_mode & S_ISUID) {
2293 if (statbuf.st_uid != euid)
2295 (void)seteuid(statbuf.st_uid); /* all that for this */
2298 (void)setreuid((Uid_t)-1,statbuf.st_uid);
2300 #ifdef HAS_SETRESUID
2301 (void)setresuid((Uid_t)-1,statbuf.st_uid,(Uid_t)-1);
2303 PerlProc_setuid(statbuf.st_uid);
2307 if (PerlProc_geteuid() != statbuf.st_uid)
2308 croak("Can't do seteuid!\n");
2310 else if (uid) { /* oops, mustn't run as root */
2312 (void)seteuid((Uid_t)uid);
2315 (void)setreuid((Uid_t)-1,(Uid_t)uid);
2317 #ifdef HAS_SETRESUID
2318 (void)setresuid((Uid_t)-1,(Uid_t)uid,(Uid_t)-1);
2320 PerlProc_setuid((Uid_t)uid);
2324 if (PerlProc_geteuid() != uid)
2325 croak("Can't do seteuid!\n");
2328 if (!cando(S_IXUSR,TRUE,&statbuf))
2329 croak("Permission denied\n"); /* they can't do this */
2332 else if (preprocess)
2333 croak("-P not allowed for setuid/setgid script\n");
2334 else if (fdscript >= 0)
2335 croak("fd script not allowed in suidperl\n");
2337 croak("Script is not setuid/setgid in suidperl\n");
2339 /* We absolutely must clear out any saved ids here, so we */
2340 /* exec the real perl, substituting fd script for scriptname. */
2341 /* (We pass script name as "subdir" of fd, which perl will grok.) */
2342 PerlIO_rewind(rsfp);
2343 PerlLIO_lseek(PerlIO_fileno(rsfp),(Off_t)0,0); /* just in case rewind didn't */
2344 for (which = 1; origargv[which] && origargv[which] != scriptname; which++) ;
2345 if (!origargv[which])
2346 croak("Permission denied");
2347 origargv[which] = savepv(form("/dev/fd/%d/%s",
2348 PerlIO_fileno(rsfp), origargv[which]));
2349 #if defined(HAS_FCNTL) && defined(F_SETFD)
2350 fcntl(PerlIO_fileno(rsfp),F_SETFD,0); /* ensure no close-on-exec */
2352 PerlProc_execv(form("%s/perl%s", BIN_EXP, patchlevel), origargv); /* try again */
2353 croak("Can't do setuid\n");
2354 #endif /* IAMSUID */
2356 if (euid != uid || egid != gid) { /* (suidperl doesn't exist, in fact) */
2357 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
2359 PerlLIO_fstat(PerlIO_fileno(rsfp),&statbuf); /* may be either wrapped or real suid */
2360 if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
2362 (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
2365 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2366 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2367 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
2368 /* not set-id, must be wrapped */
2374 find_beginning(void)
2376 register char *s, *s2;
2378 /* skip forward in input to the real script? */
2382 if ((s = sv_gets(linestr, rsfp, 0)) == Nullch)
2383 croak("No Perl script found in input\n");
2384 if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
2385 PerlIO_ungetc(rsfp, '\n'); /* to keep line count right */
2387 while (*s && !(isSPACE (*s) || *s == '#')) s++;
2389 while (*s == ' ' || *s == '\t') s++;
2391 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
2392 if (strnEQ(s2-4,"perl",4))
2394 while (s = moreswitches(s)) ;
2396 if (cddir && PerlDir_chdir(cddir) < 0)
2397 croak("Can't chdir to %s",cddir);
2405 uid = (int)PerlProc_getuid();
2406 euid = (int)PerlProc_geteuid();
2407 gid = (int)PerlProc_getgid();
2408 egid = (int)PerlProc_getegid();
2413 tainting |= (uid && (euid != uid || egid != gid));
2417 forbid_setid(char *s)
2420 croak("No %s allowed while running setuid", s);
2422 croak("No %s allowed while running setgid", s);
2429 curstash = debstash;
2430 dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
2432 DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
2433 DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
2434 DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
2435 DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
2436 sv_setiv(DBsingle, 0);
2437 DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
2438 sv_setiv(DBtrace, 0);
2439 DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
2440 sv_setiv(DBsignal, 0);
2441 curstash = defstash;
2445 init_stacks(ARGSproto)
2448 mainstack = curstack; /* remember in case we switch stacks */
2449 AvREAL_off(curstack); /* not a real array */
2450 av_extend(curstack,127);
2452 stack_base = AvARRAY(curstack);
2453 stack_sp = stack_base;
2454 stack_max = stack_base + 127;
2456 cxstack_max = 8192 / sizeof(PERL_CONTEXT) - 2; /* Use most of 8K. */
2457 New(50,cxstack,cxstack_max + 1,PERL_CONTEXT);
2460 New(50,tmps_stack,128,SV*);
2466 * The following stacks almost certainly should be per-interpreter,
2467 * but for now they're not. XXX
2471 markstack_ptr = markstack;
2473 New(54,markstack,64,I32);
2474 markstack_ptr = markstack;
2475 markstack_max = markstack + 64;
2481 New(54,scopestack,32,I32);
2483 scopestack_max = 32;
2489 New(54,savestack,128,ANY);
2491 savestack_max = 128;
2497 New(54,retstack,16,OP*);
2508 Safefree(tmps_stack);
2516 static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
2529 subname = newSVpv("main",4);
2533 init_predump_symbols(void)
2539 sv_setpvn(perl_get_sv("\"", TRUE), " ", 1);
2540 stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
2541 GvMULTI_on(stdingv);
2542 IoIFP(GvIOp(stdingv)) = PerlIO_stdin();
2543 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
2545 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(stdingv));
2547 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
2549 IoOFP(GvIOp(tmpgv)) = IoIFP(GvIOp(tmpgv)) = PerlIO_stdout();
2551 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
2553 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(defoutgv));
2555 othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
2556 GvMULTI_on(othergv);
2557 IoOFP(GvIOp(othergv)) = IoIFP(GvIOp(othergv)) = PerlIO_stderr();
2558 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
2560 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(othergv));
2562 statname = NEWSV(66,0); /* last filename we did stat on */
2565 osname = savepv(OSNAME);
2569 init_postdump_symbols(register int argc, register char **argv, register char **env)
2576 argc--,argv++; /* skip name of script */
2578 for (; argc > 0 && **argv == '-'; argc--,argv++) {
2581 if (argv[0][1] == '-') {
2585 if (s = strchr(argv[0], '=')) {
2587 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
2590 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
2593 toptarget = NEWSV(0,0);
2594 sv_upgrade(toptarget, SVt_PVFM);
2595 sv_setpvn(toptarget, "", 0);
2596 bodytarget = NEWSV(0,0);
2597 sv_upgrade(bodytarget, SVt_PVFM);
2598 sv_setpvn(bodytarget, "", 0);
2599 formtarget = bodytarget;
2602 if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
2603 sv_setpv(GvSV(tmpgv),origfilename);
2604 magicname("0", "0", 1);
2606 if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
2607 sv_setpv(GvSV(tmpgv),origargv[0]);
2608 if (argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
2610 (void)gv_AVadd(argvgv);
2611 av_clear(GvAVn(argvgv));
2612 for (; argc > 0; argc--,argv++) {
2613 av_push(GvAVn(argvgv),newSVpv(argv[0],0));
2616 if (envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
2620 hv_magic(hv, envgv, 'E');
2621 #ifndef VMS /* VMS doesn't have environ array */
2622 /* Note that if the supplied env parameter is actually a copy
2623 of the global environ then it may now point to free'd memory
2624 if the environment has been modified since. To avoid this
2625 problem we treat env==NULL as meaning 'use the default'
2630 environ[0] = Nullch;
2631 for (; *env; env++) {
2632 if (!(s = strchr(*env,'=')))
2635 #if defined(WIN32) || defined(MSDOS)
2638 sv = newSVpv(s--,0);
2639 (void)hv_store(hv, *env, s - *env, sv, 0);
2641 #if defined(__BORLANDC__) && defined(USE_WIN32_RTL_ENV)
2642 /* Sins of the RTL. See note in my_setenv(). */
2643 (void)PerlEnv_putenv(savepv(*env));
2647 #ifdef DYNAMIC_ENV_FETCH
2648 HvNAME(hv) = savepv(ENV_HV_NAME);
2652 if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
2653 sv_setiv(GvSV(tmpgv), (IV)getpid());
2662 s = PerlEnv_getenv("PERL5LIB");
2666 incpush(PerlEnv_getenv("PERLLIB"), FALSE);
2668 /* Treat PERL5?LIB as a possible search list logical name -- the
2669 * "natural" VMS idiom for a Unix path string. We allow each
2670 * element to be a set of |-separated directories for compatibility.
2674 if (my_trnlnm("PERL5LIB",buf,0))
2675 do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
2677 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE);
2681 /* Use the ~-expanded versions of APPLLIB (undocumented),
2682 ARCHLIB PRIVLIB SITEARCH and SITELIB
2685 incpush(APPLLIB_EXP, FALSE);
2689 incpush(ARCHLIB_EXP, FALSE);
2692 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
2694 incpush(PRIVLIB_EXP, FALSE);
2697 incpush(SITEARCH_EXP, FALSE);
2700 incpush(SITELIB_EXP, FALSE);
2703 incpush(".", FALSE);
2707 # define PERLLIB_SEP ';'
2710 # define PERLLIB_SEP '|'
2712 # define PERLLIB_SEP ':'
2715 #ifndef PERLLIB_MANGLE
2716 # define PERLLIB_MANGLE(s,n) (s)
2720 incpush(char *p, int addsubdirs)
2722 SV *subdir = Nullsv;
2728 subdir = NEWSV(55,0);
2729 if (!archpat_auto) {
2730 STRLEN len = (sizeof(ARCHNAME) + strlen(patchlevel)
2731 + sizeof("//auto"));
2732 New(55, archpat_auto, len, char);
2733 sprintf(archpat_auto, "/%s/%s/auto", ARCHNAME, patchlevel);
2735 for (len = sizeof(ARCHNAME) + 2;
2736 archpat_auto[len] != '\0' && archpat_auto[len] != '/'; len++)
2737 if (archpat_auto[len] == '.') archpat_auto[len] = '_';
2742 /* Break at all separators */
2744 SV *libdir = NEWSV(55,0);
2747 /* skip any consecutive separators */
2748 while ( *p == PERLLIB_SEP ) {
2749 /* Uncomment the next line for PATH semantics */
2750 /* av_push(GvAVn(incgv), newSVpv(".", 1)); */
2754 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
2755 sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
2760 sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
2761 p = Nullch; /* break out */
2765 * BEFORE pushing libdir onto @INC we may first push version- and
2766 * archname-specific sub-directories.
2769 struct stat tmpstatbuf;
2774 if ((unix = tounixspec_ts(SvPV(libdir,na),Nullch)) != Nullch) {
2776 while (unix[len-1] == '/') len--; /* Cosmetic */
2777 sv_usepvn(libdir,unix,len);
2780 PerlIO_printf(PerlIO_stderr(),
2781 "Failed to unixify @INC element \"%s\"\n",
2784 /* .../archname/version if -d .../archname/version/auto */
2785 sv_setsv(subdir, libdir);
2786 sv_catpv(subdir, archpat_auto);
2787 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2788 S_ISDIR(tmpstatbuf.st_mode))
2789 av_push(GvAVn(incgv),
2790 newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2792 /* .../archname if -d .../archname/auto */
2793 sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME),
2794 strlen(patchlevel) + 1, "", 0);
2795 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2796 S_ISDIR(tmpstatbuf.st_mode))
2797 av_push(GvAVn(incgv),
2798 newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2801 /* finally push this lib directory on the end of @INC */
2802 av_push(GvAVn(incgv), libdir);
2805 SvREFCNT_dec(subdir);
2809 STATIC struct perl_thread *
2812 struct perl_thread *thr;
2815 Newz(53, thr, 1, struct perl_thread);
2816 curcop = &compiling;
2817 thr->cvcache = newHV();
2818 thr->threadsv = newAV();
2819 /* thr->threadsvp is set when find_threadsv is called */
2820 thr->specific = newAV();
2821 thr->errhv = newHV();
2822 thr->flags = THRf_R_JOINABLE;
2823 MUTEX_INIT(&thr->mutex);
2824 /* Handcraft thrsv similarly to mess_sv */
2825 New(53, thrsv, 1, SV);
2826 Newz(53, xpv, 1, XPV);
2827 SvFLAGS(thrsv) = SVt_PV;
2828 SvANY(thrsv) = (void*)xpv;
2829 SvREFCNT(thrsv) = 1 << 30; /* practically infinite */
2830 SvPVX(thrsv) = (char*)thr;
2831 SvCUR_set(thrsv, sizeof(thr));
2832 SvLEN_set(thrsv, sizeof(thr));
2833 *SvEND(thrsv) = '\0'; /* in the trailing_nul field */
2835 curcop = &compiling;
2838 MUTEX_LOCK(&threads_mutex);
2843 MUTEX_UNLOCK(&threads_mutex);
2845 #ifdef HAVE_THREAD_INTERN
2846 init_thread_intern(thr);
2849 #ifdef SET_THREAD_SELF
2850 SET_THREAD_SELF(thr);
2852 thr->self = pthread_self();
2853 #endif /* SET_THREAD_SELF */
2857 * These must come after the SET_THR because sv_setpvn does
2858 * SvTAINT and the taint fields require dTHR.
2860 toptarget = NEWSV(0,0);
2861 sv_upgrade(toptarget, SVt_PVFM);
2862 sv_setpvn(toptarget, "", 0);
2863 bodytarget = NEWSV(0,0);
2864 sv_upgrade(bodytarget, SVt_PVFM);
2865 sv_setpvn(bodytarget, "", 0);
2866 formtarget = bodytarget;
2867 thr->errsv = newSVpv("", 0);
2868 (void) find_threadsv("@"); /* Ensure $@ is initialised early */
2871 #endif /* USE_THREADS */
2874 call_list(I32 oldscope, AV *paramList)
2877 line_t oldline = curcop->cop_line;
2882 while (AvFILL(paramList) >= 0) {
2883 CV *cv = (CV*)av_shift(paramList);
2892 perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
2893 (void)SvPV(atsv, len);
2896 curcop = &compiling;
2897 curcop->cop_line = oldline;
2898 if (paramList == beginav)
2899 sv_catpv(atsv, "BEGIN failed--compilation aborted");
2901 sv_catpv(atsv, "END failed--cleanup aborted");
2902 while (scopestack_ix > oldscope)
2904 croak("%s", SvPVX(atsv));
2912 /* my_exit() was called */
2913 while (scopestack_ix > oldscope)
2916 curstash = defstash;
2918 call_list(oldscope, endav);
2920 curcop = &compiling;
2921 curcop->cop_line = oldline;
2923 if (paramList == beginav)
2924 croak("BEGIN failed--compilation aborted");
2926 croak("END failed--cleanup aborted");
2932 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
2937 curcop = &compiling;
2938 curcop->cop_line = oldline;
2951 DEBUG_L(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
2952 thr, (unsigned long) status));
2953 #endif /* USE_THREADS */
2962 STATUS_NATIVE_SET(status);
2969 my_failure_exit(void)
2972 if (vaxc$errno & 1) {
2973 if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
2974 STATUS_NATIVE_SET(44);
2977 if (!vaxc$errno && errno) /* unlikely */
2978 STATUS_NATIVE_SET(44);
2980 STATUS_NATIVE_SET(vaxc$errno);
2984 STATUS_POSIX_SET(errno);
2985 else if (STATUS_POSIX == 0)
2986 STATUS_POSIX_SET(255);
2995 register PERL_CONTEXT *cx;
3004 (void)UNLINK(e_tmpname);
3005 Safefree(e_tmpname);
3009 if (cxstack_ix >= 0) {