3 * Copyright (c) 1987-1997 Larry Wall
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
11 * "A ship then new they built for him/of mithril and of elven glass" --Bilbo
16 #include "patchlevel.h"
18 /* XXX If this causes problems, set i_unistd=undef in the hint file. */
23 #if !defined(STANDARD_C) && !defined(HAS_GETENV_PROTOTYPE)
24 char *getenv _((char *)); /* Usually in <stdlib.h> */
27 dEXTCONST char rcsid[] = "perl.c\nPatch level: ###\n";
35 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
45 curcop = &compiling; \
52 laststype = OP_STAT; \
54 maxsysfd = MAXSYSFD; \
61 laststype = OP_STAT; \
65 static void find_beginning _((void));
66 static void forbid_setid _((char *));
67 static void incpush _((char *, int));
68 static void init_ids _((void));
69 static void init_debugger _((void));
70 static void init_lexer _((void));
71 static void init_main_stash _((void));
73 static struct perl_thread * init_main_thread _((void));
74 #endif /* USE_THREADS */
75 static void init_perllib _((void));
76 static void init_postdump_symbols _((int, char **, char **));
77 static void init_predump_symbols _((void));
78 static void my_exit_jump _((void)) __attribute__((noreturn));
79 static void nuke_stacks _((void));
80 static void open_script _((char *, bool, SV *));
81 static void usage _((char *));
82 static void validate_suid _((char *, char*));
84 static int fdscript = -1;
86 #if defined(DEBUGGING) && defined(USE_THREADS) && defined(__linux__)
87 #include <asm/sigcontext.h>
89 catch_sigsegv(int signo, struct sigcontext_struct sc)
91 signal(SIGSEGV, SIG_DFL);
92 fprintf(stderr, "Segmentation fault dereferencing 0x%lx\n"
93 "return_address = 0x%lx, eip = 0x%lx\n",
94 sc.cr2, __builtin_return_address(0), sc.eip);
95 fprintf(stderr, "thread = 0x%lx\n", (unsigned long)THR);
102 PerlInterpreter *sv_interp;
105 New(53, sv_interp, 1, PerlInterpreter);
110 perl_construct(register PerlInterpreter *sv_interp)
115 struct perl_thread *thr;
116 #endif /* FAKE_THREADS */
117 #endif /* USE_THREADS */
119 if (!(curinterp = sv_interp))
123 Zero(sv_interp, 1, PerlInterpreter);
126 /* Init the real globals (and main thread)? */
131 #ifdef ALLOC_THREAD_KEY
134 if (pthread_key_create(&thr_key, 0))
135 croak("panic: pthread_key_create");
137 MUTEX_INIT(&malloc_mutex);
138 MUTEX_INIT(&sv_mutex);
140 * Safe to use basic SV functions from now on (though
141 * not things like mortals or tainting yet).
143 MUTEX_INIT(&eval_mutex);
144 COND_INIT(&eval_cond);
145 MUTEX_INIT(&threads_mutex);
146 COND_INIT(&nthreads_cond);
148 thr = init_main_thread();
149 #endif /* USE_THREADS */
151 linestr = NEWSV(65,80);
152 sv_upgrade(linestr,SVt_PVIV);
154 if (!SvREADONLY(&sv_undef)) {
155 SvREADONLY_on(&sv_undef);
159 SvREADONLY_on(&sv_no);
161 sv_setpv(&sv_yes,Yes);
163 SvREADONLY_on(&sv_yes);
166 nrs = newSVpv("\n", 1);
167 rs = SvREFCNT_inc(nrs);
169 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);
185 perl_destruct_level = 1;
187 if(perl_destruct_level > 0)
192 lex_state = LEX_NOTPARSING;
194 start_env.je_prev = NULL;
195 start_env.je_ret = -1;
196 start_env.je_mustcatch = TRUE;
197 top_env = &start_env;
200 SET_NUMERIC_STANDARD();
201 #if defined(SUBVERSION) && SUBVERSION > 0
202 sprintf(patchlevel, "%7.5f", (double) 5
203 + ((double) PATCHLEVEL / (double) 1000)
204 + ((double) SUBVERSION / (double) 100000));
206 sprintf(patchlevel, "%5.3f", (double) 5 +
207 ((double) PATCHLEVEL / (double) 1000));
210 #if defined(LOCAL_PATCH_COUNT)
211 localpatches = local_patches; /* For possible -v */
214 PerlIO_init(); /* Hook to IO system */
216 fdpid = newAV(); /* for remembering popen pids by fd */
220 New(51,debname,128,char);
221 New(52,debdelim,128,char);
228 perl_destruct(register PerlInterpreter *sv_interp)
231 int destruct_level; /* 0=none, 1=full, 2=full with checks */
236 #endif /* USE_THREADS */
238 if (!(curinterp = sv_interp))
243 /* Pass 1 on any remaining threads: detach joinables, join zombies */
245 MUTEX_LOCK(&threads_mutex);
246 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
247 "perl_destruct: waiting for %d threads...\n",
249 for (t = thr->next; t != thr; t = t->next) {
250 MUTEX_LOCK(&t->mutex);
251 switch (ThrSTATE(t)) {
254 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
255 "perl_destruct: joining zombie %p\n", t));
256 ThrSETSTATE(t, THRf_DEAD);
257 MUTEX_UNLOCK(&t->mutex);
260 * The SvREFCNT_dec below may take a long time (e.g. av
261 * may contain an object scalar whose destructor gets
262 * called) so we have to unlock threads_mutex and start
265 MUTEX_UNLOCK(&threads_mutex);
267 SvREFCNT_dec((SV*)av);
268 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
269 "perl_destruct: joined zombie %p OK\n", t));
271 case THRf_R_JOINABLE:
272 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
273 "perl_destruct: detaching thread %p\n", t));
274 ThrSETSTATE(t, THRf_R_DETACHED);
276 * We unlock threads_mutex and t->mutex in the opposite order
277 * from which we locked them just so that DETACH won't
278 * deadlock if it panics. It's only a breach of good style
279 * not a bug since they are unlocks not locks.
281 MUTEX_UNLOCK(&threads_mutex);
283 MUTEX_UNLOCK(&t->mutex);
286 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
287 "perl_destruct: ignoring %p (state %u)\n",
289 MUTEX_UNLOCK(&t->mutex);
290 /* fall through and out */
293 /* We leave the above "Pass 1" loop with threads_mutex still locked */
295 /* Pass 2 on remaining threads: wait for the thread count to drop to one */
298 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
299 "perl_destruct: final wait for %d threads\n",
301 COND_WAIT(&nthreads_cond, &threads_mutex);
303 /* At this point, we're the last thread */
304 MUTEX_UNLOCK(&threads_mutex);
305 DEBUG_L(PerlIO_printf(PerlIO_stderr(), "perl_destruct: armageddon has arrived\n"));
306 MUTEX_DESTROY(&threads_mutex);
307 COND_DESTROY(&nthreads_cond);
308 #endif /* !defined(FAKE_THREADS) */
309 #endif /* USE_THREADS */
311 destruct_level = perl_destruct_level;
315 if (s = getenv("PERL_DESTRUCT_LEVEL")) {
317 if (destruct_level < i)
326 /* We must account for everything. */
328 /* Destroy the main CV and syntax tree */
330 curpad = AvARRAY(comppad);
335 SvREFCNT_dec(main_cv);
340 * Try to destruct global references. We do this first so that the
341 * destructors and destructees still exist. Some sv's might remain.
342 * Non-referenced objects are on their own.
349 /* unhook hooks which will soon be, or use, destroyed data */
350 SvREFCNT_dec(warnhook);
352 SvREFCNT_dec(diehook);
354 SvREFCNT_dec(parsehook);
357 if (destruct_level == 0){
359 DEBUG_P(debprofdump());
361 /* The exit() function will do everything that needs doing. */
365 /* loosen bonds of global variables */
368 (void)PerlIO_close(rsfp);
372 /* Filters for program text */
373 SvREFCNT_dec(rsfp_filters);
374 rsfp_filters = Nullav;
386 sawampersand = FALSE; /* must save all match strings */
387 sawstudy = FALSE; /* do fbm_instr on all strings */
402 /* magical thingies */
404 Safefree(ofs); /* $, */
407 Safefree(ors); /* $\ */
410 SvREFCNT_dec(nrs); /* $\ helper */
413 multiline = 0; /* $* */
415 SvREFCNT_dec(statname);
419 /* defgv, aka *_ should be taken care of elsewhere */
421 /* clean up after study() */
422 SvREFCNT_dec(lastscream);
424 Safefree(screamfirst);
426 Safefree(screamnext);
429 /* startup and shutdown function lists */
430 SvREFCNT_dec(beginav);
432 SvREFCNT_dec(initav);
437 /* temp stack during pp_sort() */
438 SvREFCNT_dec(sortstack);
441 /* shortcuts just get cleared */
451 /* reset so print() ends up where we expect */
454 /* Prepare to destruct main symbol table. */
461 if (destruct_level >= 2) {
462 if (scopestack_ix != 0)
463 warn("Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
464 (long)scopestack_ix);
465 if (savestack_ix != 0)
466 warn("Unbalanced saves: %ld more saves than restores\n",
468 if (tmps_floor != -1)
469 warn("Unbalanced tmps: %ld more allocs than frees\n",
470 (long)tmps_floor + 1);
471 if (cxstack_ix != -1)
472 warn("Unbalanced context: %ld more PUSHes than POPs\n",
473 (long)cxstack_ix + 1);
476 /* Now absolutely destruct everything, somehow or other, loops or no. */
478 SvFLAGS(strtab) |= SVTYPEMASK; /* don't clean out strtab now */
479 while (sv_count != 0 && sv_count != last_sv_count) {
480 last_sv_count = sv_count;
483 SvFLAGS(strtab) &= ~SVTYPEMASK;
484 SvFLAGS(strtab) |= SVt_PVHV;
486 /* Destruct the global string table. */
488 /* Yell and reset the HeVAL() slots that are still holding refcounts,
489 * so that sv_free() won't fail on them.
498 array = HvARRAY(strtab);
502 warn("Unbalanced string table refcount: (%d) for \"%s\"",
503 HeVAL(hent) - Nullsv, HeKEY(hent));
504 HeVAL(hent) = Nullsv;
514 SvREFCNT_dec(strtab);
517 warn("Scalars leaked: %ld\n", (long)sv_count);
521 /* No SVs have survived, need to clean out */
525 Safefree(origfilename);
527 hints = 0; /* Reset hints. Should hints be per-interpreter ? */
529 DEBUG_P(debprofdump());
531 MUTEX_DESTROY(&sv_mutex);
532 MUTEX_DESTROY(&malloc_mutex);
533 MUTEX_DESTROY(&eval_mutex);
534 COND_DESTROY(&eval_cond);
536 /* As the penultimate thing, free the non-arena SV for thrsv */
537 Safefree(SvPVX(thrsv));
538 Safefree(SvANY(thrsv));
541 #endif /* USE_THREADS */
543 /* As the absolutely last thing, free the non-arena SV for mess() */
546 /* we know that type >= SVt_PV */
548 Safefree(SvPVX(mess_sv));
549 Safefree(SvANY(mess_sv));
556 perl_free(PerlInterpreter *sv_interp)
558 if (!(curinterp = sv_interp))
564 perl_parse(PerlInterpreter *sv_interp, void (*xsinit) (void), int argc, char **argv, char **env)
569 char *scriptname = NULL;
570 VOL bool dosearch = FALSE;
577 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
580 croak("suidperl is no longer needed since the kernel can now execute\n\
581 setuid perl scripts securely.\n");
585 if (!(curinterp = sv_interp))
588 #if defined(NeXT) && defined(__DYNAMIC__)
589 _dyld_lookup_and_bind
590 ("__environ", (unsigned long *) &environ_pointer, NULL);
595 #ifndef VMS /* VMS doesn't have environ array */
596 origenviron = environ;
602 /* Come here if running an undumped a.out. */
604 origfilename = savepv(argv[0]);
606 cxstack_ix = -1; /* start label stack again */
608 init_postdump_symbols(argc,argv,env);
613 curpad = AvARRAY(comppad);
618 SvREFCNT_dec(main_cv);
622 oldscope = scopestack_ix;
630 /* my_exit() was called */
631 while (scopestack_ix > oldscope)
636 call_list(oldscope, endav);
638 return STATUS_NATIVE_EXPORT;
641 PerlIO_printf(PerlIO_stderr(), "panic: top_env\n");
645 sv_setpvn(linestr,"",0);
646 sv = newSVpv("",0); /* first used for -I flags */
650 for (argc--,argv++; argc > 0; argc--,argv++) {
651 if (argv[0][0] != '-' || !argv[0][1])
655 validarg = " PHOOEY ";
680 if (s = moreswitches(s))
690 if (euid != uid || egid != gid)
691 croak("No -e allowed in setuid scripts");
693 e_tmpname = savepv(TMPPATH);
694 (void)mktemp(e_tmpname);
696 croak("Can't mktemp()");
697 e_fp = PerlIO_open(e_tmpname,"w");
699 croak("Cannot open temporary file");
704 PerlIO_puts(e_fp,argv[1]);
708 croak("No code specified for -e");
709 (void)PerlIO_putc(e_fp,'\n');
711 case 'I': /* -I handled both here and in moreswitches() */
713 if (!*++s && (s=argv[1]) != Nullch) {
716 while (s && isSPACE(*s))
720 for (e = s; *e && !isSPACE(*e); e++) ;
727 } /* XXX else croak? */
741 preambleav = newAV();
742 av_push(preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
744 Sv = newSVpv("print myconfig();",0);
746 sv_catpv(Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
748 sv_catpv(Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
750 #if defined(DEBUGGING) || defined(NO_EMBED) || defined(MULTIPLICITY)
751 sv_catpv(Sv,"\" Compile-time options:");
753 sv_catpv(Sv," DEBUGGING");
756 sv_catpv(Sv," NO_EMBED");
759 sv_catpv(Sv," MULTIPLICITY");
761 sv_catpv(Sv,"\\n\",");
763 #if defined(LOCAL_PATCH_COUNT)
764 if (LOCAL_PATCH_COUNT > 0) {
766 sv_catpv(Sv,"\" Locally applied patches:\\n\",");
767 for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
769 sv_catpvf(Sv,"\" \\t%s\\n\",",localpatches[i]);
773 sv_catpvf(Sv,"\" Built under %s\\n\"",OSNAME);
776 sv_catpvf(Sv,",\" Compiled at %s %s\\n\"",__DATE__,__TIME__);
778 sv_catpvf(Sv,",\" Compiled on %s\\n\"",__DATE__);
783 @env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; \
784 print \" \\%ENV:\\n @env\\n\" if @env; \
785 print \" \\@INC:\\n @INC\\n\";");
788 Sv = newSVpv("config_vars(qw(",0);
793 av_push(preambleav, Sv);
794 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
805 if (!*++s || isSPACE(*s)) {
809 /* catch use of gnu style long options */
810 if (strEQ(s, "version")) {
814 if (strEQ(s, "help")) {
821 croak("Unrecognized switch: -%s (-h will show valid options)",s);
826 if (!tainting && (s = getenv("PERL5OPT"))) {
837 if (!strchr("DIMUdmw", *s))
838 croak("Illegal switch in PERL5OPT: -%c", *s);
844 scriptname = argv[0];
846 if (PerlIO_flush(e_fp) || PerlIO_error(e_fp) || PerlIO_close(e_fp)) {
848 warn("Did you forget to compile with -DMULTIPLICITY?");
850 croak("Can't write to temp file for -e: %s", Strerror(errno));
854 scriptname = e_tmpname;
856 else if (scriptname == Nullch) {
858 if ( isatty(PerlIO_fileno(PerlIO_stdin())) )
866 open_script(scriptname,dosearch,sv);
868 validate_suid(validarg, scriptname);
873 main_cv = compcv = (CV*)NEWSV(1104,0);
874 sv_upgrade((SV *)compcv, SVt_PVCV);
878 av_push(comppad, Nullsv);
879 curpad = AvARRAY(comppad);
880 comppad_name = newAV();
881 comppad_name_fill = 0;
882 min_intro_pending = 0;
885 av_store(comppad_name, 0, newSVpv("@_", 2));
886 curpad[0] = (SV*)newAV();
887 SvPADMY_on(curpad[0]); /* XXX Needed? */
889 New(666, CvMUTEXP(compcv), 1, perl_mutex);
890 MUTEX_INIT(CvMUTEXP(compcv));
891 #endif /* USE_THREADS */
893 comppadlist = newAV();
894 AvREAL_off(comppadlist);
895 av_store(comppadlist, 0, (SV*)comppad_name);
896 av_store(comppadlist, 1, (SV*)comppad);
897 CvPADLIST(compcv) = comppadlist;
899 boot_core_UNIVERSAL();
901 (*xsinit)(); /* in case linked C routines want magical variables */
902 #if defined(VMS) || defined(WIN32)
906 #if defined(DEBUGGING) && defined(USE_THREADS) && defined(__linux__)
907 DEBUG_L(signal(SIGSEGV, (void(*)(int))catch_sigsegv););
910 init_predump_symbols();
912 init_postdump_symbols(argc,argv,env);
916 /* now parse the script */
919 if (yyparse() || error_count) {
921 croak("%s had compilation errors.\n", origfilename);
923 croak("Execution of %s aborted due to compilation errors.\n",
927 curcop->cop_line = 0;
931 (void)UNLINK(e_tmpname);
936 /* now that script is parsed, we can modify record separator */
938 rs = SvREFCNT_inc(nrs);
940 sv_setsv(*av_fetch(thr->threadsv, find_threadsv("/"), FALSE), rs);
942 sv_setsv(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), rs);
943 #endif /* USE_THREADS */
954 if ((s=getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
955 dump_mstats("after compilation:");
965 perl_run(PerlInterpreter *sv_interp)
972 if (!(curinterp = sv_interp))
975 oldscope = scopestack_ix;
980 cxstack_ix = -1; /* start context stack again */
983 /* my_exit() was called */
984 while (scopestack_ix > oldscope)
989 call_list(oldscope, endav);
991 if (getenv("PERL_DEBUG_MSTATS"))
992 dump_mstats("after execution: ");
995 return STATUS_NATIVE_EXPORT;
998 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
1003 if (curstack != mainstack) {
1005 SWITCHSTACK(curstack, mainstack);
1010 DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
1011 sawampersand ? "Enabling" : "Omitting"));
1014 DEBUG_x(dump_all());
1015 DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
1017 DEBUG_L(PerlIO_printf(Perl_debug_log, "main thread is 0x%lx\n",
1018 (unsigned long) thr));
1019 #endif /* USE_THREADS */
1022 PerlIO_printf(PerlIO_stderr(), "%s syntax OK\n", origfilename);
1025 if (PERLDB_SINGLE && DBsingle)
1026 sv_setiv(DBsingle, 1);
1028 call_list(oldscope, initav);
1038 else if (main_start) {
1039 CvDEPTH(main_cv) = 1;
1050 perl_get_sv(char *name, I32 create)
1054 if (name[1] == '\0' && !isALPHA(name[0])) {
1055 PADOFFSET tmp = find_threadsv(name);
1056 if (tmp != NOT_IN_PAD) {
1058 return *av_fetch(thr->threadsv, tmp, FALSE);
1061 #endif /* USE_THREADS */
1062 gv = gv_fetchpv(name, create, SVt_PV);
1069 perl_get_av(char *name, I32 create)
1071 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
1080 perl_get_hv(char *name, I32 create)
1082 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
1091 perl_get_cv(char *name, I32 create)
1093 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
1094 if (create && !GvCVu(gv))
1095 return newSUB(start_subparse(FALSE, 0),
1096 newSVOP(OP_CONST, 0, newSVpv(name,0)),
1104 /* Be sure to refetch the stack pointer after calling these routines. */
1107 perl_call_argv(char *subname, I32 flags, register char **argv)
1109 /* See G_* flags in cop.h */
1110 /* null terminated arg list */
1117 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
1122 return perl_call_pv(subname, flags);
1126 perl_call_pv(char *subname, I32 flags)
1127 /* name of the subroutine */
1128 /* See G_* flags in cop.h */
1130 return perl_call_sv((SV*)perl_get_cv(subname, TRUE), flags);
1134 perl_call_method(char *methname, I32 flags)
1135 /* name of the subroutine */
1136 /* See G_* flags in cop.h */
1142 XPUSHs(sv_2mortal(newSVpv(methname,0)));
1145 return perl_call_sv(*stack_sp--, flags);
1148 /* May be called with any of a CV, a GV, or an SV containing the name. */
1150 perl_call_sv(SV *sv, I32 flags)
1152 /* See G_* flags in cop.h */
1155 LOGOP myop; /* fake syntax tree node */
1161 bool oldcatch = CATCH_GET;
1166 if (flags & G_DISCARD) {
1171 Zero(&myop, 1, LOGOP);
1172 myop.op_next = Nullop;
1173 if (!(flags & G_NOARGS))
1174 myop.op_flags |= OPf_STACKED;
1175 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1176 (flags & G_ARRAY) ? OPf_WANT_LIST :
1181 EXTEND(stack_sp, 1);
1184 oldscope = scopestack_ix;
1186 if (PERLDB_SUB && curstash != debstash
1187 /* Handle first BEGIN of -d. */
1188 && (DBcv || (DBcv = GvCV(DBsub)))
1189 /* Try harder, since this may have been a sighandler, thus
1190 * curstash may be meaningless. */
1191 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != debstash))
1192 op->op_private |= OPpENTERSUB_DB;
1194 if (flags & G_EVAL) {
1195 cLOGOP->op_other = op;
1197 /* we're trying to emulate pp_entertry() here */
1199 register PERL_CONTEXT *cx;
1200 I32 gimme = GIMME_V;
1205 push_return(op->op_next);
1206 PUSHBLOCK(cx, CXt_EVAL, stack_sp);
1208 eval_root = op; /* Only needed so that goto works right. */
1211 if (flags & G_KEEPERR)
1226 /* my_exit() was called */
1227 curstash = defstash;
1231 croak("Callback called exit");
1240 stack_sp = stack_base + oldmark;
1241 if (flags & G_ARRAY)
1245 *++stack_sp = &sv_undef;
1253 if (op == (OP*)&myop)
1254 op = pp_entersub(ARGS);
1257 retval = stack_sp - (stack_base + oldmark);
1258 if ((flags & G_EVAL) && !(flags & G_KEEPERR))
1262 if (flags & G_EVAL) {
1263 if (scopestack_ix > oldscope) {
1267 register PERL_CONTEXT *cx;
1279 CATCH_SET(oldcatch);
1281 if (flags & G_DISCARD) {
1282 stack_sp = stack_base + oldmark;
1291 /* Eval a string. The G_EVAL flag is always assumed. */
1294 perl_eval_sv(SV *sv, I32 flags)
1296 /* See G_* flags in cop.h */
1299 UNOP myop; /* fake syntax tree node */
1301 I32 oldmark = sp - stack_base;
1308 if (flags & G_DISCARD) {
1316 EXTEND(stack_sp, 1);
1318 oldscope = scopestack_ix;
1320 if (!(flags & G_NOARGS))
1321 myop.op_flags = OPf_STACKED;
1322 myop.op_next = Nullop;
1323 myop.op_type = OP_ENTEREVAL;
1324 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1325 (flags & G_ARRAY) ? OPf_WANT_LIST :
1327 if (flags & G_KEEPERR)
1328 myop.op_flags |= OPf_SPECIAL;
1338 /* my_exit() was called */
1339 curstash = defstash;
1343 croak("Callback called exit");
1352 stack_sp = stack_base + oldmark;
1353 if (flags & G_ARRAY)
1357 *++stack_sp = &sv_undef;
1362 if (op == (OP*)&myop)
1363 op = pp_entereval(ARGS);
1366 retval = stack_sp - (stack_base + oldmark);
1367 if (!(flags & G_KEEPERR))
1372 if (flags & G_DISCARD) {
1373 stack_sp = stack_base + oldmark;
1383 perl_eval_pv(char *p, I32 croak_on_error)
1386 SV* sv = newSVpv(p, 0);
1389 perl_eval_sv(sv, G_SCALAR);
1396 if (croak_on_error && SvTRUE(ERRSV))
1397 croak(SvPVx(ERRSV, na));
1402 /* Require a module. */
1405 perl_require_pv(char *pv)
1407 SV* sv = sv_newmortal();
1408 sv_setpv(sv, "require '");
1411 perl_eval_sv(sv, G_DISCARD);
1415 magicname(char *sym, char *name, I32 namlen)
1419 if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
1420 sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
1424 usage(char *name) /* XXX move this out into a module ? */
1427 /* This message really ought to be max 23 lines.
1428 * Removed -h because the user already knows that opton. Others? */
1430 static char *usage[] = {
1431 "-0[octal] specify record separator (\\0, if no argument)",
1432 "-a autosplit mode with -n or -p (splits $_ into @F)",
1433 "-c check syntax only (runs BEGIN and END blocks)",
1434 "-d[:debugger] run scripts under debugger",
1435 "-D[number/list] set debugging flags (argument is a bit mask or flags)",
1436 "-e 'command' one line of script. Several -e's allowed. Omit [programfile].",
1437 "-F/pattern/ split() pattern for autosplit (-a). The //'s are optional.",
1438 "-i[extension] edit <> files in place (make backup if extension supplied)",
1439 "-Idirectory specify @INC/#include directory (may be used more than once)",
1440 "-l[octal] enable line ending processing, specifies line terminator",
1441 "-[mM][-]module.. executes `use/no module...' before executing your script.",
1442 "-n assume 'while (<>) { ... }' loop around your script",
1443 "-p assume loop like -n but print line also like sed",
1444 "-P run script through C preprocessor before compilation",
1445 "-s enable some switch parsing for switches after script name",
1446 "-S look for the script using PATH environment variable",
1447 "-T turn on tainting checks",
1448 "-u dump core after parsing script",
1449 "-U allow unsafe operations",
1450 "-v print version number and patchlevel of perl",
1451 "-V[:variable] print perl configuration information",
1452 "-w TURN WARNINGS ON FOR COMPILATION OF YOUR SCRIPT. Recommended.",
1453 "-x[directory] strip off text before #!perl line and perhaps cd to directory",
1459 printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
1461 printf("\n %s", *p++);
1464 /* This routine handles any switches that can be given during run */
1467 moreswitches(char *s)
1476 rschar = scan_oct(s, 4, &numlen);
1478 if (rschar & ~((U8)~0))
1480 else if (!rschar && numlen >= 2)
1481 nrs = newSVpv("", 0);
1484 nrs = newSVpv(&ch, 1);
1490 splitstr = savepv(s + 1);
1504 if (*s == ':' || *s == '=') {
1505 my_setenv("PERL5DB", form("use Devel::%s;", ++s));
1509 perldb = PERLDB_ALL;
1516 if (isALPHA(s[1])) {
1517 static char debopts[] = "psltocPmfrxuLHXD";
1520 for (s++; *s && (d = strchr(debopts,*s)); s++)
1521 debug |= 1 << (d - debopts);
1525 for (s++; isDIGIT(*s); s++) ;
1527 debug |= 0x80000000;
1529 warn("Recompile perl with -DDEBUGGING to use -D switch\n");
1530 for (s++; isALNUM(*s); s++) ;
1540 inplace = savepv(s+1);
1542 for (s = inplace; *s && !isSPACE(*s); s++) ;
1546 case 'I': /* -I handled both here and in parse_perl() */
1549 while (*s && isSPACE(*s))
1553 for (e = s; *e && !isSPACE(*e); e++) ;
1554 p = savepvn(s, e-s);
1560 croak("No space allowed after -I");
1570 *ors = scan_oct(s, 3 + (*s == '0'), &numlen);
1580 ors = SvPV(nrs, orslen);
1581 ors = savepvn(ors, orslen);
1585 forbid_setid("-M"); /* XXX ? */
1588 forbid_setid("-m"); /* XXX ? */
1593 /* -M-foo == 'no foo' */
1594 if (*s == '-') { use = "no "; ++s; }
1595 sv = newSVpv(use,0);
1597 /* We allow -M'Module qw(Foo Bar)' */
1598 while(isALNUM(*s) || *s==':') ++s;
1600 sv_catpv(sv, start);
1601 if (*(start-1) == 'm') {
1603 croak("Can't use '%c' after -mname", *s);
1604 sv_catpv( sv, " ()");
1607 sv_catpvn(sv, start, s-start);
1608 sv_catpv(sv, " split(/,/,q{");
1613 if (preambleav == NULL)
1614 preambleav = newAV();
1615 av_push(preambleav, sv);
1618 croak("No space allowed after -%c", *(s-1));
1635 croak("Too late for \"-T\" option");
1647 #if defined(SUBVERSION) && SUBVERSION > 0
1648 printf("\nThis is perl, version 5.%03d_%02d built for %s",
1649 PATCHLEVEL, SUBVERSION, ARCHNAME);
1651 printf("\nThis is perl, version %s built for %s",
1652 patchlevel, ARCHNAME);
1654 #if defined(LOCAL_PATCH_COUNT)
1655 if (LOCAL_PATCH_COUNT > 0)
1656 printf("\n(with %d registered patch%s, see perl -V for more detail)",
1657 LOCAL_PATCH_COUNT, (LOCAL_PATCH_COUNT!=1) ? "es" : "");
1660 printf("\n\nCopyright 1987-1997, Larry Wall\n");
1662 printf("\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
1665 printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n");
1668 printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
1669 "Version 5 port Copyright (c) 1994-1997, Andreas Kaiser, Ilya Zakharevich\n");
1672 printf("atariST series port, ++jrb bammi@cadence.com\n");
1675 Perl may be copied only under the terms of either the Artistic License or the\n\
1676 GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n");
1684 if (s[1] == '-') /* Additional switches on #! line. */
1692 #ifdef ALTERNATE_SHEBANG
1693 case 'S': /* OS/2 needs -S on "extproc" line. */
1701 croak("Can't emulate -%.1s on #! line",s);
1706 /* compliments of Tom Christiansen */
1708 /* unexec() can be found in the Gnu emacs distribution */
1719 prog = newSVpv(BIN_EXP);
1720 sv_catpv(prog, "/perl");
1721 file = newSVpv(origfilename);
1722 sv_catpv(file, ".perldump");
1724 status = unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
1726 PerlIO_printf(PerlIO_stderr(), "unexec of %s into %s failed!\n",
1727 SvPVX(prog), SvPVX(file));
1731 # include <lib$routines.h>
1732 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
1734 ABORT(); /* for use with undump */
1740 init_main_stash(void)
1745 /* Note that strtab is a rather special HV. Assumptions are made
1746 about not iterating on it, and not adding tie magic to it.
1747 It is properly deallocated in perl_destruct() */
1749 HvSHAREKEYS_off(strtab); /* mandatory */
1750 Newz(506,((XPVHV*)SvANY(strtab))->xhv_array,
1751 sizeof(HE*) * (((XPVHV*)SvANY(strtab))->xhv_max + 1), char);
1753 curstash = defstash = newHV();
1754 curstname = newSVpv("main",4);
1755 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
1756 SvREFCNT_dec(GvHV(gv));
1757 GvHV(gv) = (HV*)SvREFCNT_inc(defstash);
1759 HvNAME(defstash) = savepv("main");
1760 incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
1762 defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
1763 errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
1765 (void)form("%240s",""); /* Preallocate temp - for immediate signals. */
1766 sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */
1767 sv_setpvn(ERRSV, "", 0);
1768 curstash = defstash;
1769 compiling.cop_stash = defstash;
1770 debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
1771 globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
1772 /* We must init $/ before switches are processed. */
1773 sv_setpvn(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), "\n", 1);
1776 #ifdef CAN_PROTOTYPE
1778 open_script(char *scriptname, bool dosearch, SV *sv)
1781 open_script(scriptname,dosearch,sv)
1788 char *xfound = Nullch;
1789 char *xfailed = Nullch;
1793 #if defined(DOSISH) && !defined(OS2) && !defined(atarist)
1794 # define SEARCH_EXTS ".bat", ".cmd", NULL
1795 # define MAX_EXT_LEN 4
1798 # define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL
1799 # define MAX_EXT_LEN 4
1802 # define SEARCH_EXTS ".pl", ".com", NULL
1803 # define MAX_EXT_LEN 4
1805 /* additional extensions to try in each dir if scriptname not found */
1807 char *ext[] = { SEARCH_EXTS };
1808 int extidx = 0, i = 0;
1809 char *curext = Nullch;
1811 # define MAX_EXT_LEN 0
1815 * If dosearch is true and if scriptname does not contain path
1816 * delimiters, search the PATH for scriptname.
1818 * If SEARCH_EXTS is also defined, will look for each
1819 * scriptname{SEARCH_EXTS} whenever scriptname is not found
1820 * while searching the PATH.
1822 * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
1823 * proceeds as follows:
1825 * + look for ./scriptname{,.foo,.bar}
1826 * + search the PATH for scriptname{,.foo,.bar}
1829 * + look *only* in the PATH for scriptname{,.foo,.bar} (note
1830 * this will not look in '.' if it's not in the PATH)
1835 int hasdir, idx = 0, deftypes = 1;
1838 hasdir = (strpbrk(scriptname,":[</") != Nullch) ;
1839 /* The first time through, just add SEARCH_EXTS to whatever we
1840 * already have, so we can check for default file types. */
1842 (!hasdir && my_trnlnm("DCL$PATH",tokenbuf,idx++)) )
1848 if ((strlen(tokenbuf) + strlen(scriptname)
1849 + MAX_EXT_LEN) >= sizeof tokenbuf)
1850 continue; /* don't search dir with too-long name */
1851 strcat(tokenbuf, scriptname);
1855 if (strEQ(scriptname, "-"))
1857 if (dosearch) { /* Look in '.' first. */
1858 char *cur = scriptname;
1860 if ((curext = strrchr(scriptname,'.'))) /* possible current ext */
1862 if (strEQ(ext[i++],curext)) {
1863 extidx = -1; /* already has an ext */
1868 DEBUG_p(PerlIO_printf(Perl_debug_log,
1869 "Looking for %s\n",cur));
1870 if (Stat(cur,&statbuf) >= 0) {
1878 if (cur == scriptname) {
1879 len = strlen(scriptname);
1880 if (len+MAX_EXT_LEN+1 >= sizeof(tokenbuf))
1882 cur = strcpy(tokenbuf, scriptname);
1884 } while (extidx >= 0 && ext[extidx] /* try an extension? */
1885 && strcpy(tokenbuf+len, ext[extidx++]));
1890 if (dosearch && !strchr(scriptname, '/')
1892 && !strchr(scriptname, '\\')
1894 && (s = getenv("PATH"))) {
1897 bufend = s + strlen(s);
1898 while (s < bufend) {
1899 #if defined(atarist) || defined(DOSISH)
1904 && *s != ';'; len++, s++) {
1905 if (len < sizeof tokenbuf)
1908 if (len < sizeof tokenbuf)
1909 tokenbuf[len] = '\0';
1910 #else /* ! (atarist || DOSISH) */
1911 s = delimcpy(tokenbuf, tokenbuf + sizeof tokenbuf, s, bufend,
1914 #endif /* ! (atarist || DOSISH) */
1917 if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tokenbuf)
1918 continue; /* don't search dir with too-long name */
1920 #if defined(atarist) || defined(DOSISH)
1921 && tokenbuf[len - 1] != '/'
1922 && tokenbuf[len - 1] != '\\'
1925 tokenbuf[len++] = '/';
1926 if (len == 2 && tokenbuf[0] == '.')
1928 (void)strcpy(tokenbuf + len, scriptname);
1932 len = strlen(tokenbuf);
1933 if (extidx > 0) /* reset after previous loop */
1937 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tokenbuf));
1938 retval = Stat(tokenbuf,&statbuf);
1940 } while ( retval < 0 /* not there */
1941 && extidx>=0 && ext[extidx] /* try an extension? */
1942 && strcpy(tokenbuf+len, ext[extidx++])
1947 if (S_ISREG(statbuf.st_mode)
1948 && cando(S_IRUSR,TRUE,&statbuf)
1950 && cando(S_IXUSR,TRUE,&statbuf)
1954 xfound = tokenbuf; /* bingo! */
1958 xfailed = savepv(tokenbuf);
1961 if (!xfound && !seen_dot && !xfailed && (Stat(scriptname,&statbuf) < 0))
1963 seen_dot = 1; /* Disable message. */
1965 croak("Can't %s %s%s%s",
1966 (xfailed ? "execute" : "find"),
1967 (xfailed ? xfailed : scriptname),
1968 (xfailed ? "" : " on PATH"),
1969 (xfailed || seen_dot) ? "" : ", '.' not in PATH");
1972 scriptname = xfound;
1975 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
1976 char *s = scriptname + 8;
1985 origfilename = savepv(e_tmpname ? "-e" : scriptname);
1986 curcop->cop_filegv = gv_fetchfile(origfilename);
1987 if (strEQ(origfilename,"-"))
1989 if (fdscript >= 0) {
1990 rsfp = PerlIO_fdopen(fdscript,"r");
1991 #if defined(HAS_FCNTL) && defined(F_SETFD)
1993 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
1996 else if (preprocess) {
1997 char *cpp_cfg = CPPSTDIN;
1998 SV *cpp = NEWSV(0,0);
1999 SV *cmd = NEWSV(0,0);
2001 if (strEQ(cpp_cfg, "cppstdin"))
2002 sv_catpvf(cpp, "%s/", BIN_EXP);
2003 sv_catpv(cpp, cpp_cfg);
2006 sv_catpv(sv,PRIVLIB_EXP);
2010 sed %s -e \"/^[^#]/b\" \
2011 -e \"/^#[ ]*include[ ]/b\" \
2012 -e \"/^#[ ]*define[ ]/b\" \
2013 -e \"/^#[ ]*if[ ]/b\" \
2014 -e \"/^#[ ]*ifdef[ ]/b\" \
2015 -e \"/^#[ ]*ifndef[ ]/b\" \
2016 -e \"/^#[ ]*else/b\" \
2017 -e \"/^#[ ]*elif[ ]/b\" \
2018 -e \"/^#[ ]*undef[ ]/b\" \
2019 -e \"/^#[ ]*endif/b\" \
2022 (doextract ? "-e \"1,/^#/d\n\"" : ""),
2025 %s %s -e '/^[^#]/b' \
2026 -e '/^#[ ]*include[ ]/b' \
2027 -e '/^#[ ]*define[ ]/b' \
2028 -e '/^#[ ]*if[ ]/b' \
2029 -e '/^#[ ]*ifdef[ ]/b' \
2030 -e '/^#[ ]*ifndef[ ]/b' \
2031 -e '/^#[ ]*else/b' \
2032 -e '/^#[ ]*elif[ ]/b' \
2033 -e '/^#[ ]*undef[ ]/b' \
2034 -e '/^#[ ]*endif/b' \
2042 (doextract ? "-e '1,/^#/d\n'" : ""),
2044 scriptname, cpp, sv, CPPMINUS);
2046 #ifdef IAMSUID /* actually, this is caught earlier */
2047 if (euid != uid && !euid) { /* if running suidperl */
2049 (void)seteuid(uid); /* musn't stay setuid root */
2052 (void)setreuid((Uid_t)-1, uid);
2054 #ifdef HAS_SETRESUID
2055 (void)setresuid((Uid_t)-1, uid, (Uid_t)-1);
2061 if (geteuid() != uid)
2062 croak("Can't do seteuid!\n");
2064 #endif /* IAMSUID */
2065 rsfp = my_popen(SvPVX(cmd), "r");
2069 else if (!*scriptname) {
2070 forbid_setid("program input from stdin");
2071 rsfp = PerlIO_stdin();
2074 rsfp = PerlIO_open(scriptname,"r");
2075 #if defined(HAS_FCNTL) && defined(F_SETFD)
2077 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
2085 #ifndef IAMSUID /* in case script is not readable before setuid */
2086 if (euid && Stat(SvPVX(GvSV(curcop->cop_filegv)),&statbuf) >= 0 &&
2087 statbuf.st_mode & (S_ISUID|S_ISGID)) {
2089 execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
2090 croak("Can't do setuid\n");
2094 croak("Can't open perl script \"%s\": %s\n",
2095 SvPVX(GvSV(curcop->cop_filegv)), Strerror(errno));
2100 validate_suid(char *validarg, char *scriptname)
2104 /* do we need to emulate setuid on scripts? */
2106 /* This code is for those BSD systems that have setuid #! scripts disabled
2107 * in the kernel because of a security problem. Merely defining DOSUID
2108 * in perl will not fix that problem, but if you have disabled setuid
2109 * scripts in the kernel, this will attempt to emulate setuid and setgid
2110 * on scripts that have those now-otherwise-useless bits set. The setuid
2111 * root version must be called suidperl or sperlN.NNN. If regular perl
2112 * discovers that it has opened a setuid script, it calls suidperl with
2113 * the same argv that it had. If suidperl finds that the script it has
2114 * just opened is NOT setuid root, it sets the effective uid back to the
2115 * uid. We don't just make perl setuid root because that loses the
2116 * effective uid we had before invoking perl, if it was different from the
2119 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
2120 * be defined in suidperl only. suidperl must be setuid root. The
2121 * Configure script will set this up for you if you want it.
2128 if (Fstat(PerlIO_fileno(rsfp),&statbuf) < 0) /* normal stat is insecure */
2129 croak("Can't stat script \"%s\"",origfilename);
2130 if (fdscript < 0 && statbuf.st_mode & (S_ISUID|S_ISGID)) {
2134 #ifndef HAS_SETREUID
2135 /* On this access check to make sure the directories are readable,
2136 * there is actually a small window that the user could use to make
2137 * filename point to an accessible directory. So there is a faint
2138 * chance that someone could execute a setuid script down in a
2139 * non-accessible directory. I don't know what to do about that.
2140 * But I don't think it's too important. The manual lies when
2141 * it says access() is useful in setuid programs.
2143 if (access(SvPVX(GvSV(curcop->cop_filegv)),1)) /*double check*/
2144 croak("Permission denied");
2146 /* If we can swap euid and uid, then we can determine access rights
2147 * with a simple stat of the file, and then compare device and
2148 * inode to make sure we did stat() on the same file we opened.
2149 * Then we just have to make sure he or she can execute it.
2152 struct stat tmpstatbuf;
2156 setreuid(euid,uid) < 0
2159 setresuid(euid,uid,(Uid_t)-1) < 0
2162 || getuid() != euid || geteuid() != uid)
2163 croak("Can't swap uid and euid"); /* really paranoid */
2164 if (Stat(SvPVX(GvSV(curcop->cop_filegv)),&tmpstatbuf) < 0)
2165 croak("Permission denied"); /* testing full pathname here */
2166 if (tmpstatbuf.st_dev != statbuf.st_dev ||
2167 tmpstatbuf.st_ino != statbuf.st_ino) {
2168 (void)PerlIO_close(rsfp);
2169 if (rsfp = my_popen("/bin/mail root","w")) { /* heh, heh */
2171 "User %ld tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
2172 (Filename of set-id script was %s, uid %ld gid %ld.)\n\nSincerely,\nperl\n",
2173 (long)uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
2174 (long)statbuf.st_dev, (long)statbuf.st_ino,
2175 SvPVX(GvSV(curcop->cop_filegv)),
2176 (long)statbuf.st_uid, (long)statbuf.st_gid);
2177 (void)my_pclose(rsfp);
2179 croak("Permission denied\n");
2183 setreuid(uid,euid) < 0
2185 # if defined(HAS_SETRESUID)
2186 setresuid(uid,euid,(Uid_t)-1) < 0
2189 || getuid() != uid || geteuid() != euid)
2190 croak("Can't reswap uid and euid");
2191 if (!cando(S_IXUSR,FALSE,&statbuf)) /* can real uid exec? */
2192 croak("Permission denied\n");
2194 #endif /* HAS_SETREUID */
2195 #endif /* IAMSUID */
2197 if (!S_ISREG(statbuf.st_mode))
2198 croak("Permission denied");
2199 if (statbuf.st_mode & S_IWOTH)
2200 croak("Setuid/gid script is writable by world");
2201 doswitches = FALSE; /* -s is insecure in suid */
2203 if (sv_gets(linestr, rsfp, 0) == Nullch ||
2204 strnNE(SvPV(linestr,na),"#!",2) ) /* required even on Sys V */
2205 croak("No #! line");
2206 s = SvPV(linestr,na)+2;
2208 while (!isSPACE(*s)) s++;
2209 for (s2 = s; (s2 > SvPV(linestr,na)+2 &&
2210 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
2211 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
2212 croak("Not a perl script");
2213 while (*s == ' ' || *s == '\t') s++;
2215 * #! arg must be what we saw above. They can invoke it by
2216 * mentioning suidperl explicitly, but they may not add any strange
2217 * arguments beyond what #! says if they do invoke suidperl that way.
2219 len = strlen(validarg);
2220 if (strEQ(validarg," PHOOEY ") ||
2221 strnNE(s,validarg,len) || !isSPACE(s[len]))
2222 croak("Args must match #! line");
2225 if (euid != uid && (statbuf.st_mode & S_ISUID) &&
2226 euid == statbuf.st_uid)
2228 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2229 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2230 #endif /* IAMSUID */
2232 if (euid) { /* oops, we're not the setuid root perl */
2233 (void)PerlIO_close(rsfp);
2236 execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
2238 croak("Can't do setuid\n");
2241 if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid) {
2243 (void)setegid(statbuf.st_gid);
2246 (void)setregid((Gid_t)-1,statbuf.st_gid);
2248 #ifdef HAS_SETRESGID
2249 (void)setresgid((Gid_t)-1,statbuf.st_gid,(Gid_t)-1);
2251 setgid(statbuf.st_gid);
2255 if (getegid() != statbuf.st_gid)
2256 croak("Can't do setegid!\n");
2258 if (statbuf.st_mode & S_ISUID) {
2259 if (statbuf.st_uid != euid)
2261 (void)seteuid(statbuf.st_uid); /* all that for this */
2264 (void)setreuid((Uid_t)-1,statbuf.st_uid);
2266 #ifdef HAS_SETRESUID
2267 (void)setresuid((Uid_t)-1,statbuf.st_uid,(Uid_t)-1);
2269 setuid(statbuf.st_uid);
2273 if (geteuid() != statbuf.st_uid)
2274 croak("Can't do seteuid!\n");
2276 else if (uid) { /* oops, mustn't run as root */
2278 (void)seteuid((Uid_t)uid);
2281 (void)setreuid((Uid_t)-1,(Uid_t)uid);
2283 #ifdef HAS_SETRESUID
2284 (void)setresuid((Uid_t)-1,(Uid_t)uid,(Uid_t)-1);
2290 if (geteuid() != uid)
2291 croak("Can't do seteuid!\n");
2294 if (!cando(S_IXUSR,TRUE,&statbuf))
2295 croak("Permission denied\n"); /* they can't do this */
2298 else if (preprocess)
2299 croak("-P not allowed for setuid/setgid script\n");
2300 else if (fdscript >= 0)
2301 croak("fd script not allowed in suidperl\n");
2303 croak("Script is not setuid/setgid in suidperl\n");
2305 /* We absolutely must clear out any saved ids here, so we */
2306 /* exec the real perl, substituting fd script for scriptname. */
2307 /* (We pass script name as "subdir" of fd, which perl will grok.) */
2308 PerlIO_rewind(rsfp);
2309 lseek(PerlIO_fileno(rsfp),(Off_t)0,0); /* just in case rewind didn't */
2310 for (which = 1; origargv[which] && origargv[which] != scriptname; which++) ;
2311 if (!origargv[which])
2312 croak("Permission denied");
2313 origargv[which] = savepv(form("/dev/fd/%d/%s",
2314 PerlIO_fileno(rsfp), origargv[which]));
2315 #if defined(HAS_FCNTL) && defined(F_SETFD)
2316 fcntl(PerlIO_fileno(rsfp),F_SETFD,0); /* ensure no close-on-exec */
2318 execv(form("%s/perl%s", BIN_EXP, patchlevel), origargv); /* try again */
2319 croak("Can't do setuid\n");
2320 #endif /* IAMSUID */
2322 if (euid != uid || egid != gid) { /* (suidperl doesn't exist, in fact) */
2323 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
2325 Fstat(PerlIO_fileno(rsfp),&statbuf); /* may be either wrapped or real suid */
2326 if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
2328 (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
2331 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2332 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2333 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
2334 /* not set-id, must be wrapped */
2340 find_beginning(void)
2342 register char *s, *s2;
2344 /* skip forward in input to the real script? */
2348 if ((s = sv_gets(linestr, rsfp, 0)) == Nullch)
2349 croak("No Perl script found in input\n");
2350 if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
2351 PerlIO_ungetc(rsfp, '\n'); /* to keep line count right */
2353 while (*s && !(isSPACE (*s) || *s == '#')) s++;
2355 while (*s == ' ' || *s == '\t') s++;
2357 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
2358 if (strnEQ(s2-4,"perl",4))
2360 while (s = moreswitches(s)) ;
2362 if (cddir && chdir(cddir) < 0)
2363 croak("Can't chdir to %s",cddir);
2371 uid = (int)getuid();
2372 euid = (int)geteuid();
2373 gid = (int)getgid();
2374 egid = (int)getegid();
2379 tainting |= (uid && (euid != uid || egid != gid));
2383 forbid_setid(char *s)
2386 croak("No %s allowed while running setuid", s);
2388 croak("No %s allowed while running setgid", s);
2395 curstash = debstash;
2396 dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
2398 DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
2399 DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
2400 DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
2401 DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
2402 sv_setiv(DBsingle, 0);
2403 DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
2404 sv_setiv(DBtrace, 0);
2405 DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
2406 sv_setiv(DBsignal, 0);
2407 curstash = defstash;
2411 init_stacks(ARGSproto)
2414 mainstack = curstack; /* remember in case we switch stacks */
2415 AvREAL_off(curstack); /* not a real array */
2416 av_extend(curstack,127);
2418 stack_base = AvARRAY(curstack);
2419 stack_sp = stack_base;
2420 stack_max = stack_base + 127;
2422 cxstack_max = 8192 / sizeof(PERL_CONTEXT) - 2; /* Use most of 8K. */
2423 New(50,cxstack,cxstack_max + 1,PERL_CONTEXT);
2426 New(50,tmps_stack,128,SV*);
2432 * The following stacks almost certainly should be per-interpreter,
2433 * but for now they're not. XXX
2437 markstack_ptr = markstack;
2439 New(54,markstack,64,I32);
2440 markstack_ptr = markstack;
2441 markstack_max = markstack + 64;
2447 New(54,scopestack,32,I32);
2449 scopestack_max = 32;
2455 New(54,savestack,128,ANY);
2457 savestack_max = 128;
2463 New(54,retstack,16,OP*);
2474 Safefree(tmps_stack);
2481 static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
2490 subname = newSVpv("main",4);
2494 init_predump_symbols(void)
2501 sv_setpvn(*av_fetch(thr->threadsv,find_threadsv("\""),FALSE)," ", 1);
2503 sv_setpvn(GvSV(gv_fetchpv("\"", TRUE, SVt_PV)), " ", 1);
2504 #endif /* USE_THREADS */
2506 stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
2507 GvMULTI_on(stdingv);
2508 IoIFP(GvIOp(stdingv)) = PerlIO_stdin();
2509 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
2511 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(stdingv));
2513 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
2515 IoOFP(GvIOp(tmpgv)) = IoIFP(GvIOp(tmpgv)) = PerlIO_stdout();
2517 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
2519 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(defoutgv));
2521 othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
2522 GvMULTI_on(othergv);
2523 IoOFP(GvIOp(othergv)) = IoIFP(GvIOp(othergv)) = PerlIO_stderr();
2524 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
2526 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(othergv));
2528 statname = NEWSV(66,0); /* last filename we did stat on */
2531 osname = savepv(OSNAME);
2535 init_postdump_symbols(register int argc, register char **argv, register char **env)
2542 argc--,argv++; /* skip name of script */
2544 for (; argc > 0 && **argv == '-'; argc--,argv++) {
2547 if (argv[0][1] == '-') {
2551 if (s = strchr(argv[0], '=')) {
2553 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
2556 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
2559 toptarget = NEWSV(0,0);
2560 sv_upgrade(toptarget, SVt_PVFM);
2561 sv_setpvn(toptarget, "", 0);
2562 bodytarget = NEWSV(0,0);
2563 sv_upgrade(bodytarget, SVt_PVFM);
2564 sv_setpvn(bodytarget, "", 0);
2565 formtarget = bodytarget;
2568 if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
2569 sv_setpv(GvSV(tmpgv),origfilename);
2570 magicname("0", "0", 1);
2572 if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
2573 sv_setpv(GvSV(tmpgv),origargv[0]);
2574 if (argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
2576 (void)gv_AVadd(argvgv);
2577 av_clear(GvAVn(argvgv));
2578 for (; argc > 0; argc--,argv++) {
2579 av_push(GvAVn(argvgv),newSVpv(argv[0],0));
2582 if (envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
2586 hv_magic(hv, envgv, 'E');
2587 #ifndef VMS /* VMS doesn't have environ array */
2588 /* Note that if the supplied env parameter is actually a copy
2589 of the global environ then it may now point to free'd memory
2590 if the environment has been modified since. To avoid this
2591 problem we treat env==NULL as meaning 'use the default'
2596 environ[0] = Nullch;
2597 for (; *env; env++) {
2598 if (!(s = strchr(*env,'=')))
2604 sv = newSVpv(s--,0);
2605 (void)hv_store(hv, *env, s - *env, sv, 0);
2607 #if defined(__BORLANDC__) && defined(USE_WIN32_RTL_ENV)
2608 /* Sins of the RTL. See note in my_setenv(). */
2609 (void)putenv(savepv(*env));
2613 #ifdef DYNAMIC_ENV_FETCH
2614 HvNAME(hv) = savepv(ENV_HV_NAME);
2618 if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
2619 sv_setiv(GvSV(tmpgv), (IV)getpid());
2628 s = getenv("PERL5LIB");
2632 incpush(getenv("PERLLIB"), FALSE);
2634 /* Treat PERL5?LIB as a possible search list logical name -- the
2635 * "natural" VMS idiom for a Unix path string. We allow each
2636 * element to be a set of |-separated directories for compatibility.
2640 if (my_trnlnm("PERL5LIB",buf,0))
2641 do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
2643 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE);
2647 /* Use the ~-expanded versions of APPLLIB (undocumented),
2648 ARCHLIB PRIVLIB SITEARCH SITELIB and OLDARCHLIB
2651 incpush(APPLLIB_EXP, FALSE);
2655 incpush(ARCHLIB_EXP, FALSE);
2658 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
2660 incpush(PRIVLIB_EXP, FALSE);
2663 incpush(SITEARCH_EXP, FALSE);
2666 incpush(SITELIB_EXP, FALSE);
2668 #ifdef OLDARCHLIB_EXP /* 5.00[01] compatibility */
2669 incpush(OLDARCHLIB_EXP, FALSE);
2673 incpush(".", FALSE);
2677 # define PERLLIB_SEP ';'
2680 # define PERLLIB_SEP '|'
2682 # define PERLLIB_SEP ':'
2685 #ifndef PERLLIB_MANGLE
2686 # define PERLLIB_MANGLE(s,n) (s)
2690 incpush(char *p, int addsubdirs)
2692 SV *subdir = Nullsv;
2693 static char *archpat_auto;
2700 if (!archpat_auto) {
2701 STRLEN len = (sizeof(ARCHNAME) + strlen(patchlevel)
2702 + sizeof("//auto"));
2703 New(55, archpat_auto, len, char);
2704 sprintf(archpat_auto, "/%s/%s/auto", ARCHNAME, patchlevel);
2706 for (len = sizeof(ARCHNAME) + 2;
2707 archpat_auto[len] != '\0' && archpat_auto[len] != '/'; len++)
2708 if (archpat_auto[len] == '.') archpat_auto[len] = '_';
2713 /* Break at all separators */
2715 SV *libdir = newSV(0);
2718 /* skip any consecutive separators */
2719 while ( *p == PERLLIB_SEP ) {
2720 /* Uncomment the next line for PATH semantics */
2721 /* av_push(GvAVn(incgv), newSVpv(".", 1)); */
2725 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
2726 sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
2731 sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
2732 p = Nullch; /* break out */
2736 * BEFORE pushing libdir onto @INC we may first push version- and
2737 * archname-specific sub-directories.
2740 struct stat tmpstatbuf;
2745 if ((unix = tounixspec_ts(SvPV(libdir,na),Nullch)) != Nullch) {
2747 while (unix[len-1] == '/') len--; /* Cosmetic */
2748 sv_usepvn(libdir,unix,len);
2751 PerlIO_printf(PerlIO_stderr(),
2752 "Failed to unixify @INC element \"%s\"\n",
2755 /* .../archname/version if -d .../archname/version/auto */
2756 sv_setsv(subdir, libdir);
2757 sv_catpv(subdir, archpat_auto);
2758 if (Stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2759 S_ISDIR(tmpstatbuf.st_mode))
2760 av_push(GvAVn(incgv),
2761 newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2763 /* .../archname if -d .../archname/auto */
2764 sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME),
2765 strlen(patchlevel) + 1, "", 0);
2766 if (Stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2767 S_ISDIR(tmpstatbuf.st_mode))
2768 av_push(GvAVn(incgv),
2769 newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2772 /* finally push this lib directory on the end of @INC */
2773 av_push(GvAVn(incgv), libdir);
2776 SvREFCNT_dec(subdir);
2780 static struct perl_thread *
2783 struct perl_thread *thr;
2786 Newz(53, thr, 1, struct perl_thread);
2787 curcop = &compiling;
2788 thr->cvcache = newHV();
2789 thr->threadsv = newAV();
2790 thr->specific = newAV();
2791 thr->errhv = newHV();
2792 thr->flags = THRf_R_JOINABLE;
2793 MUTEX_INIT(&thr->mutex);
2794 /* Handcraft thrsv similarly to mess_sv */
2795 New(53, thrsv, 1, SV);
2796 Newz(53, xpv, 1, XPV);
2797 SvFLAGS(thrsv) = SVt_PV;
2798 SvANY(thrsv) = (void*)xpv;
2799 SvREFCNT(thrsv) = 1 << 30; /* practically infinite */
2800 SvPVX(thrsv) = (char*)thr;
2801 SvCUR_set(thrsv, sizeof(thr));
2802 SvLEN_set(thrsv, sizeof(thr));
2803 *SvEND(thrsv) = '\0'; /* in the trailing_nul field */
2805 curcop = &compiling;
2808 MUTEX_LOCK(&threads_mutex);
2813 MUTEX_UNLOCK(&threads_mutex);
2815 #ifdef HAVE_THREAD_INTERN
2816 init_thread_intern(thr);
2819 #ifdef SET_THREAD_SELF
2820 SET_THREAD_SELF(thr);
2822 thr->self = pthread_self();
2823 #endif /* SET_THREAD_SELF */
2827 * These must come after the SET_THR because sv_setpvn does
2828 * SvTAINT and the taint fields require dTHR.
2830 toptarget = NEWSV(0,0);
2831 sv_upgrade(toptarget, SVt_PVFM);
2832 sv_setpvn(toptarget, "", 0);
2833 bodytarget = NEWSV(0,0);
2834 sv_upgrade(bodytarget, SVt_PVFM);
2835 sv_setpvn(bodytarget, "", 0);
2836 formtarget = bodytarget;
2837 thr->errsv = newSVpv("", 0);
2840 #endif /* USE_THREADS */
2843 call_list(I32 oldscope, AV *list)
2846 line_t oldline = curcop->cop_line;
2851 while (AvFILL(list) >= 0) {
2852 CV *cv = (CV*)av_shift(list);
2861 perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
2862 (void)SvPV(atsv, len);
2865 curcop = &compiling;
2866 curcop->cop_line = oldline;
2867 if (list == beginav)
2868 sv_catpv(atsv, "BEGIN failed--compilation aborted");
2870 sv_catpv(atsv, "END failed--cleanup aborted");
2871 while (scopestack_ix > oldscope)
2873 croak("%s", SvPVX(atsv));
2881 /* my_exit() was called */
2882 while (scopestack_ix > oldscope)
2885 curstash = defstash;
2887 call_list(oldscope, endav);
2889 curcop = &compiling;
2890 curcop->cop_line = oldline;
2892 if (list == beginav)
2893 croak("BEGIN failed--compilation aborted");
2895 croak("END failed--cleanup aborted");
2901 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
2906 curcop = &compiling;
2907 curcop->cop_line = oldline;
2920 DEBUG_L(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
2921 thr, (unsigned long) status));
2922 #endif /* USE_THREADS */
2931 STATUS_NATIVE_SET(status);
2938 my_failure_exit(void)
2941 if (vaxc$errno & 1) {
2942 if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
2943 STATUS_NATIVE_SET(44);
2946 if (!vaxc$errno && errno) /* unlikely */
2947 STATUS_NATIVE_SET(44);
2949 STATUS_NATIVE_SET(vaxc$errno);
2953 STATUS_POSIX_SET(errno);
2954 else if (STATUS_POSIX == 0)
2955 STATUS_POSIX_SET(255);
2964 register PERL_CONTEXT *cx;
2973 (void)UNLINK(e_tmpname);
2974 Safefree(e_tmpname);
2978 if (cxstack_ix >= 0) {