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. */
1695 #ifdef ALTERNATE_SHEBANG
1696 case 'S': /* OS/2 needs -S on "extproc" line. */
1704 croak("Can't emulate -%.1s on #! line",s);
1709 /* compliments of Tom Christiansen */
1711 /* unexec() can be found in the Gnu emacs distribution */
1722 prog = newSVpv(BIN_EXP);
1723 sv_catpv(prog, "/perl");
1724 file = newSVpv(origfilename);
1725 sv_catpv(file, ".perldump");
1727 status = unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
1729 PerlIO_printf(PerlIO_stderr(), "unexec of %s into %s failed!\n",
1730 SvPVX(prog), SvPVX(file));
1734 # include <lib$routines.h>
1735 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
1737 ABORT(); /* for use with undump */
1743 init_main_stash(void)
1748 /* Note that strtab is a rather special HV. Assumptions are made
1749 about not iterating on it, and not adding tie magic to it.
1750 It is properly deallocated in perl_destruct() */
1752 HvSHAREKEYS_off(strtab); /* mandatory */
1753 Newz(506,((XPVHV*)SvANY(strtab))->xhv_array,
1754 sizeof(HE*) * (((XPVHV*)SvANY(strtab))->xhv_max + 1), char);
1756 curstash = defstash = newHV();
1757 curstname = newSVpv("main",4);
1758 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
1759 SvREFCNT_dec(GvHV(gv));
1760 GvHV(gv) = (HV*)SvREFCNT_inc(defstash);
1762 HvNAME(defstash) = savepv("main");
1763 incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
1765 defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
1766 errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
1768 (void)form("%240s",""); /* Preallocate temp - for immediate signals. */
1769 sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */
1770 sv_setpvn(ERRSV, "", 0);
1771 curstash = defstash;
1772 compiling.cop_stash = defstash;
1773 debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
1774 globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
1775 /* We must init $/ before switches are processed. */
1776 sv_setpvn(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), "\n", 1);
1779 #ifdef CAN_PROTOTYPE
1781 open_script(char *scriptname, bool dosearch, SV *sv)
1784 open_script(scriptname,dosearch,sv)
1791 char *xfound = Nullch;
1792 char *xfailed = Nullch;
1796 #if defined(DOSISH) && !defined(OS2) && !defined(atarist)
1797 # define SEARCH_EXTS ".bat", ".cmd", NULL
1798 # define MAX_EXT_LEN 4
1801 # define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL
1802 # define MAX_EXT_LEN 4
1805 # define SEARCH_EXTS ".pl", ".com", NULL
1806 # define MAX_EXT_LEN 4
1808 /* additional extensions to try in each dir if scriptname not found */
1810 char *ext[] = { SEARCH_EXTS };
1811 int extidx = 0, i = 0;
1812 char *curext = Nullch;
1814 # define MAX_EXT_LEN 0
1818 * If dosearch is true and if scriptname does not contain path
1819 * delimiters, search the PATH for scriptname.
1821 * If SEARCH_EXTS is also defined, will look for each
1822 * scriptname{SEARCH_EXTS} whenever scriptname is not found
1823 * while searching the PATH.
1825 * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
1826 * proceeds as follows:
1828 * + look for ./scriptname{,.foo,.bar}
1829 * + search the PATH for scriptname{,.foo,.bar}
1832 * + look *only* in the PATH for scriptname{,.foo,.bar} (note
1833 * this will not look in '.' if it's not in the PATH)
1838 int hasdir, idx = 0, deftypes = 1;
1841 hasdir = (strpbrk(scriptname,":[</") != Nullch) ;
1842 /* The first time through, just add SEARCH_EXTS to whatever we
1843 * already have, so we can check for default file types. */
1845 (!hasdir && my_trnlnm("DCL$PATH",tokenbuf,idx++)) )
1851 if ((strlen(tokenbuf) + strlen(scriptname)
1852 + MAX_EXT_LEN) >= sizeof tokenbuf)
1853 continue; /* don't search dir with too-long name */
1854 strcat(tokenbuf, scriptname);
1858 if (strEQ(scriptname, "-"))
1860 if (dosearch) { /* Look in '.' first. */
1861 char *cur = scriptname;
1863 if ((curext = strrchr(scriptname,'.'))) /* possible current ext */
1865 if (strEQ(ext[i++],curext)) {
1866 extidx = -1; /* already has an ext */
1871 DEBUG_p(PerlIO_printf(Perl_debug_log,
1872 "Looking for %s\n",cur));
1873 if (Stat(cur,&statbuf) >= 0) {
1881 if (cur == scriptname) {
1882 len = strlen(scriptname);
1883 if (len+MAX_EXT_LEN+1 >= sizeof(tokenbuf))
1885 cur = strcpy(tokenbuf, scriptname);
1887 } while (extidx >= 0 && ext[extidx] /* try an extension? */
1888 && strcpy(tokenbuf+len, ext[extidx++]));
1893 if (dosearch && !strchr(scriptname, '/')
1895 && !strchr(scriptname, '\\')
1897 && (s = getenv("PATH"))) {
1900 bufend = s + strlen(s);
1901 while (s < bufend) {
1902 #if defined(atarist) || defined(DOSISH)
1907 && *s != ';'; len++, s++) {
1908 if (len < sizeof tokenbuf)
1911 if (len < sizeof tokenbuf)
1912 tokenbuf[len] = '\0';
1913 #else /* ! (atarist || DOSISH) */
1914 s = delimcpy(tokenbuf, tokenbuf + sizeof tokenbuf, s, bufend,
1917 #endif /* ! (atarist || DOSISH) */
1920 if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tokenbuf)
1921 continue; /* don't search dir with too-long name */
1923 #if defined(atarist) || defined(DOSISH)
1924 && tokenbuf[len - 1] != '/'
1925 && tokenbuf[len - 1] != '\\'
1928 tokenbuf[len++] = '/';
1929 if (len == 2 && tokenbuf[0] == '.')
1931 (void)strcpy(tokenbuf + len, scriptname);
1935 len = strlen(tokenbuf);
1936 if (extidx > 0) /* reset after previous loop */
1940 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tokenbuf));
1941 retval = Stat(tokenbuf,&statbuf);
1943 } while ( retval < 0 /* not there */
1944 && extidx>=0 && ext[extidx] /* try an extension? */
1945 && strcpy(tokenbuf+len, ext[extidx++])
1950 if (S_ISREG(statbuf.st_mode)
1951 && cando(S_IRUSR,TRUE,&statbuf)
1953 && cando(S_IXUSR,TRUE,&statbuf)
1957 xfound = tokenbuf; /* bingo! */
1961 xfailed = savepv(tokenbuf);
1964 if (!xfound && !seen_dot && !xfailed && (Stat(scriptname,&statbuf) < 0))
1966 seen_dot = 1; /* Disable message. */
1968 croak("Can't %s %s%s%s",
1969 (xfailed ? "execute" : "find"),
1970 (xfailed ? xfailed : scriptname),
1971 (xfailed ? "" : " on PATH"),
1972 (xfailed || seen_dot) ? "" : ", '.' not in PATH");
1975 scriptname = xfound;
1978 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
1979 char *s = scriptname + 8;
1988 origfilename = savepv(e_tmpname ? "-e" : scriptname);
1989 curcop->cop_filegv = gv_fetchfile(origfilename);
1990 if (strEQ(origfilename,"-"))
1992 if (fdscript >= 0) {
1993 rsfp = PerlIO_fdopen(fdscript,PERL_SCRIPT_MODE);
1994 #if defined(HAS_FCNTL) && defined(F_SETFD)
1996 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
1999 else if (preprocess) {
2000 char *cpp_cfg = CPPSTDIN;
2001 SV *cpp = NEWSV(0,0);
2002 SV *cmd = NEWSV(0,0);
2004 if (strEQ(cpp_cfg, "cppstdin"))
2005 sv_catpvf(cpp, "%s/", BIN_EXP);
2006 sv_catpv(cpp, cpp_cfg);
2009 sv_catpv(sv,PRIVLIB_EXP);
2013 sed %s -e \"/^[^#]/b\" \
2014 -e \"/^#[ ]*include[ ]/b\" \
2015 -e \"/^#[ ]*define[ ]/b\" \
2016 -e \"/^#[ ]*if[ ]/b\" \
2017 -e \"/^#[ ]*ifdef[ ]/b\" \
2018 -e \"/^#[ ]*ifndef[ ]/b\" \
2019 -e \"/^#[ ]*else/b\" \
2020 -e \"/^#[ ]*elif[ ]/b\" \
2021 -e \"/^#[ ]*undef[ ]/b\" \
2022 -e \"/^#[ ]*endif/b\" \
2025 (doextract ? "-e \"1,/^#/d\n\"" : ""),
2028 %s %s -e '/^[^#]/b' \
2029 -e '/^#[ ]*include[ ]/b' \
2030 -e '/^#[ ]*define[ ]/b' \
2031 -e '/^#[ ]*if[ ]/b' \
2032 -e '/^#[ ]*ifdef[ ]/b' \
2033 -e '/^#[ ]*ifndef[ ]/b' \
2034 -e '/^#[ ]*else/b' \
2035 -e '/^#[ ]*elif[ ]/b' \
2036 -e '/^#[ ]*undef[ ]/b' \
2037 -e '/^#[ ]*endif/b' \
2045 (doextract ? "-e '1,/^#/d\n'" : ""),
2047 scriptname, cpp, sv, CPPMINUS);
2049 #ifdef IAMSUID /* actually, this is caught earlier */
2050 if (euid != uid && !euid) { /* if running suidperl */
2052 (void)seteuid(uid); /* musn't stay setuid root */
2055 (void)setreuid((Uid_t)-1, uid);
2057 #ifdef HAS_SETRESUID
2058 (void)setresuid((Uid_t)-1, uid, (Uid_t)-1);
2064 if (geteuid() != uid)
2065 croak("Can't do seteuid!\n");
2067 #endif /* IAMSUID */
2068 rsfp = my_popen(SvPVX(cmd), "r");
2072 else if (!*scriptname) {
2073 forbid_setid("program input from stdin");
2074 rsfp = PerlIO_stdin();
2077 rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
2078 #if defined(HAS_FCNTL) && defined(F_SETFD)
2080 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
2088 #ifndef IAMSUID /* in case script is not readable before setuid */
2089 if (euid && Stat(SvPVX(GvSV(curcop->cop_filegv)),&statbuf) >= 0 &&
2090 statbuf.st_mode & (S_ISUID|S_ISGID)) {
2092 execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
2093 croak("Can't do setuid\n");
2097 croak("Can't open perl script \"%s\": %s\n",
2098 SvPVX(GvSV(curcop->cop_filegv)), Strerror(errno));
2103 validate_suid(char *validarg, char *scriptname)
2107 /* do we need to emulate setuid on scripts? */
2109 /* This code is for those BSD systems that have setuid #! scripts disabled
2110 * in the kernel because of a security problem. Merely defining DOSUID
2111 * in perl will not fix that problem, but if you have disabled setuid
2112 * scripts in the kernel, this will attempt to emulate setuid and setgid
2113 * on scripts that have those now-otherwise-useless bits set. The setuid
2114 * root version must be called suidperl or sperlN.NNN. If regular perl
2115 * discovers that it has opened a setuid script, it calls suidperl with
2116 * the same argv that it had. If suidperl finds that the script it has
2117 * just opened is NOT setuid root, it sets the effective uid back to the
2118 * uid. We don't just make perl setuid root because that loses the
2119 * effective uid we had before invoking perl, if it was different from the
2122 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
2123 * be defined in suidperl only. suidperl must be setuid root. The
2124 * Configure script will set this up for you if you want it.
2131 if (Fstat(PerlIO_fileno(rsfp),&statbuf) < 0) /* normal stat is insecure */
2132 croak("Can't stat script \"%s\"",origfilename);
2133 if (fdscript < 0 && statbuf.st_mode & (S_ISUID|S_ISGID)) {
2137 #ifndef HAS_SETREUID
2138 /* On this access check to make sure the directories are readable,
2139 * there is actually a small window that the user could use to make
2140 * filename point to an accessible directory. So there is a faint
2141 * chance that someone could execute a setuid script down in a
2142 * non-accessible directory. I don't know what to do about that.
2143 * But I don't think it's too important. The manual lies when
2144 * it says access() is useful in setuid programs.
2146 if (access(SvPVX(GvSV(curcop->cop_filegv)),1)) /*double check*/
2147 croak("Permission denied");
2149 /* If we can swap euid and uid, then we can determine access rights
2150 * with a simple stat of the file, and then compare device and
2151 * inode to make sure we did stat() on the same file we opened.
2152 * Then we just have to make sure he or she can execute it.
2155 struct stat tmpstatbuf;
2159 setreuid(euid,uid) < 0
2162 setresuid(euid,uid,(Uid_t)-1) < 0
2165 || getuid() != euid || geteuid() != uid)
2166 croak("Can't swap uid and euid"); /* really paranoid */
2167 if (Stat(SvPVX(GvSV(curcop->cop_filegv)),&tmpstatbuf) < 0)
2168 croak("Permission denied"); /* testing full pathname here */
2169 if (tmpstatbuf.st_dev != statbuf.st_dev ||
2170 tmpstatbuf.st_ino != statbuf.st_ino) {
2171 (void)PerlIO_close(rsfp);
2172 if (rsfp = my_popen("/bin/mail root","w")) { /* heh, heh */
2174 "User %ld tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
2175 (Filename of set-id script was %s, uid %ld gid %ld.)\n\nSincerely,\nperl\n",
2176 (long)uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
2177 (long)statbuf.st_dev, (long)statbuf.st_ino,
2178 SvPVX(GvSV(curcop->cop_filegv)),
2179 (long)statbuf.st_uid, (long)statbuf.st_gid);
2180 (void)my_pclose(rsfp);
2182 croak("Permission denied\n");
2186 setreuid(uid,euid) < 0
2188 # if defined(HAS_SETRESUID)
2189 setresuid(uid,euid,(Uid_t)-1) < 0
2192 || getuid() != uid || geteuid() != euid)
2193 croak("Can't reswap uid and euid");
2194 if (!cando(S_IXUSR,FALSE,&statbuf)) /* can real uid exec? */
2195 croak("Permission denied\n");
2197 #endif /* HAS_SETREUID */
2198 #endif /* IAMSUID */
2200 if (!S_ISREG(statbuf.st_mode))
2201 croak("Permission denied");
2202 if (statbuf.st_mode & S_IWOTH)
2203 croak("Setuid/gid script is writable by world");
2204 doswitches = FALSE; /* -s is insecure in suid */
2206 if (sv_gets(linestr, rsfp, 0) == Nullch ||
2207 strnNE(SvPV(linestr,na),"#!",2) ) /* required even on Sys V */
2208 croak("No #! line");
2209 s = SvPV(linestr,na)+2;
2211 while (!isSPACE(*s)) s++;
2212 for (s2 = s; (s2 > SvPV(linestr,na)+2 &&
2213 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
2214 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
2215 croak("Not a perl script");
2216 while (*s == ' ' || *s == '\t') s++;
2218 * #! arg must be what we saw above. They can invoke it by
2219 * mentioning suidperl explicitly, but they may not add any strange
2220 * arguments beyond what #! says if they do invoke suidperl that way.
2222 len = strlen(validarg);
2223 if (strEQ(validarg," PHOOEY ") ||
2224 strnNE(s,validarg,len) || !isSPACE(s[len]))
2225 croak("Args must match #! line");
2228 if (euid != uid && (statbuf.st_mode & S_ISUID) &&
2229 euid == statbuf.st_uid)
2231 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2232 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2233 #endif /* IAMSUID */
2235 if (euid) { /* oops, we're not the setuid root perl */
2236 (void)PerlIO_close(rsfp);
2239 execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
2241 croak("Can't do setuid\n");
2244 if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid) {
2246 (void)setegid(statbuf.st_gid);
2249 (void)setregid((Gid_t)-1,statbuf.st_gid);
2251 #ifdef HAS_SETRESGID
2252 (void)setresgid((Gid_t)-1,statbuf.st_gid,(Gid_t)-1);
2254 setgid(statbuf.st_gid);
2258 if (getegid() != statbuf.st_gid)
2259 croak("Can't do setegid!\n");
2261 if (statbuf.st_mode & S_ISUID) {
2262 if (statbuf.st_uid != euid)
2264 (void)seteuid(statbuf.st_uid); /* all that for this */
2267 (void)setreuid((Uid_t)-1,statbuf.st_uid);
2269 #ifdef HAS_SETRESUID
2270 (void)setresuid((Uid_t)-1,statbuf.st_uid,(Uid_t)-1);
2272 setuid(statbuf.st_uid);
2276 if (geteuid() != statbuf.st_uid)
2277 croak("Can't do seteuid!\n");
2279 else if (uid) { /* oops, mustn't run as root */
2281 (void)seteuid((Uid_t)uid);
2284 (void)setreuid((Uid_t)-1,(Uid_t)uid);
2286 #ifdef HAS_SETRESUID
2287 (void)setresuid((Uid_t)-1,(Uid_t)uid,(Uid_t)-1);
2293 if (geteuid() != uid)
2294 croak("Can't do seteuid!\n");
2297 if (!cando(S_IXUSR,TRUE,&statbuf))
2298 croak("Permission denied\n"); /* they can't do this */
2301 else if (preprocess)
2302 croak("-P not allowed for setuid/setgid script\n");
2303 else if (fdscript >= 0)
2304 croak("fd script not allowed in suidperl\n");
2306 croak("Script is not setuid/setgid in suidperl\n");
2308 /* We absolutely must clear out any saved ids here, so we */
2309 /* exec the real perl, substituting fd script for scriptname. */
2310 /* (We pass script name as "subdir" of fd, which perl will grok.) */
2311 PerlIO_rewind(rsfp);
2312 lseek(PerlIO_fileno(rsfp),(Off_t)0,0); /* just in case rewind didn't */
2313 for (which = 1; origargv[which] && origargv[which] != scriptname; which++) ;
2314 if (!origargv[which])
2315 croak("Permission denied");
2316 origargv[which] = savepv(form("/dev/fd/%d/%s",
2317 PerlIO_fileno(rsfp), origargv[which]));
2318 #if defined(HAS_FCNTL) && defined(F_SETFD)
2319 fcntl(PerlIO_fileno(rsfp),F_SETFD,0); /* ensure no close-on-exec */
2321 execv(form("%s/perl%s", BIN_EXP, patchlevel), origargv); /* try again */
2322 croak("Can't do setuid\n");
2323 #endif /* IAMSUID */
2325 if (euid != uid || egid != gid) { /* (suidperl doesn't exist, in fact) */
2326 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
2328 Fstat(PerlIO_fileno(rsfp),&statbuf); /* may be either wrapped or real suid */
2329 if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
2331 (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
2334 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2335 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2336 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
2337 /* not set-id, must be wrapped */
2343 find_beginning(void)
2345 register char *s, *s2;
2347 /* skip forward in input to the real script? */
2351 if ((s = sv_gets(linestr, rsfp, 0)) == Nullch)
2352 croak("No Perl script found in input\n");
2353 if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
2354 PerlIO_ungetc(rsfp, '\n'); /* to keep line count right */
2356 while (*s && !(isSPACE (*s) || *s == '#')) s++;
2358 while (*s == ' ' || *s == '\t') s++;
2360 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
2361 if (strnEQ(s2-4,"perl",4))
2363 while (s = moreswitches(s)) ;
2365 if (cddir && chdir(cddir) < 0)
2366 croak("Can't chdir to %s",cddir);
2374 uid = (int)getuid();
2375 euid = (int)geteuid();
2376 gid = (int)getgid();
2377 egid = (int)getegid();
2382 tainting |= (uid && (euid != uid || egid != gid));
2386 forbid_setid(char *s)
2389 croak("No %s allowed while running setuid", s);
2391 croak("No %s allowed while running setgid", s);
2398 curstash = debstash;
2399 dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
2401 DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
2402 DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
2403 DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
2404 DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
2405 sv_setiv(DBsingle, 0);
2406 DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
2407 sv_setiv(DBtrace, 0);
2408 DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
2409 sv_setiv(DBsignal, 0);
2410 curstash = defstash;
2414 init_stacks(ARGSproto)
2417 mainstack = curstack; /* remember in case we switch stacks */
2418 AvREAL_off(curstack); /* not a real array */
2419 av_extend(curstack,127);
2421 stack_base = AvARRAY(curstack);
2422 stack_sp = stack_base;
2423 stack_max = stack_base + 127;
2425 cxstack_max = 8192 / sizeof(PERL_CONTEXT) - 2; /* Use most of 8K. */
2426 New(50,cxstack,cxstack_max + 1,PERL_CONTEXT);
2429 New(50,tmps_stack,128,SV*);
2435 * The following stacks almost certainly should be per-interpreter,
2436 * but for now they're not. XXX
2440 markstack_ptr = markstack;
2442 New(54,markstack,64,I32);
2443 markstack_ptr = markstack;
2444 markstack_max = markstack + 64;
2450 New(54,scopestack,32,I32);
2452 scopestack_max = 32;
2458 New(54,savestack,128,ANY);
2460 savestack_max = 128;
2466 New(54,retstack,16,OP*);
2477 Safefree(tmps_stack);
2484 static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
2493 subname = newSVpv("main",4);
2497 init_predump_symbols(void)
2504 sv_setpvn(*av_fetch(thr->threadsv,find_threadsv("\""),FALSE)," ", 1);
2506 sv_setpvn(GvSV(gv_fetchpv("\"", TRUE, SVt_PV)), " ", 1);
2507 #endif /* USE_THREADS */
2509 stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
2510 GvMULTI_on(stdingv);
2511 IoIFP(GvIOp(stdingv)) = PerlIO_stdin();
2512 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
2514 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(stdingv));
2516 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
2518 IoOFP(GvIOp(tmpgv)) = IoIFP(GvIOp(tmpgv)) = PerlIO_stdout();
2520 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
2522 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(defoutgv));
2524 othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
2525 GvMULTI_on(othergv);
2526 IoOFP(GvIOp(othergv)) = IoIFP(GvIOp(othergv)) = PerlIO_stderr();
2527 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
2529 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(othergv));
2531 statname = NEWSV(66,0); /* last filename we did stat on */
2534 osname = savepv(OSNAME);
2538 init_postdump_symbols(register int argc, register char **argv, register char **env)
2545 argc--,argv++; /* skip name of script */
2547 for (; argc > 0 && **argv == '-'; argc--,argv++) {
2550 if (argv[0][1] == '-') {
2554 if (s = strchr(argv[0], '=')) {
2556 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
2559 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
2562 toptarget = NEWSV(0,0);
2563 sv_upgrade(toptarget, SVt_PVFM);
2564 sv_setpvn(toptarget, "", 0);
2565 bodytarget = NEWSV(0,0);
2566 sv_upgrade(bodytarget, SVt_PVFM);
2567 sv_setpvn(bodytarget, "", 0);
2568 formtarget = bodytarget;
2571 if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
2572 sv_setpv(GvSV(tmpgv),origfilename);
2573 magicname("0", "0", 1);
2575 if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
2576 sv_setpv(GvSV(tmpgv),origargv[0]);
2577 if (argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
2579 (void)gv_AVadd(argvgv);
2580 av_clear(GvAVn(argvgv));
2581 for (; argc > 0; argc--,argv++) {
2582 av_push(GvAVn(argvgv),newSVpv(argv[0],0));
2585 if (envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
2589 hv_magic(hv, envgv, 'E');
2590 #ifndef VMS /* VMS doesn't have environ array */
2591 /* Note that if the supplied env parameter is actually a copy
2592 of the global environ then it may now point to free'd memory
2593 if the environment has been modified since. To avoid this
2594 problem we treat env==NULL as meaning 'use the default'
2599 environ[0] = Nullch;
2600 for (; *env; env++) {
2601 if (!(s = strchr(*env,'=')))
2607 sv = newSVpv(s--,0);
2608 (void)hv_store(hv, *env, s - *env, sv, 0);
2610 #if defined(__BORLANDC__) && defined(USE_WIN32_RTL_ENV)
2611 /* Sins of the RTL. See note in my_setenv(). */
2612 (void)putenv(savepv(*env));
2616 #ifdef DYNAMIC_ENV_FETCH
2617 HvNAME(hv) = savepv(ENV_HV_NAME);
2621 if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
2622 sv_setiv(GvSV(tmpgv), (IV)getpid());
2631 s = getenv("PERL5LIB");
2635 incpush(getenv("PERLLIB"), FALSE);
2637 /* Treat PERL5?LIB as a possible search list logical name -- the
2638 * "natural" VMS idiom for a Unix path string. We allow each
2639 * element to be a set of |-separated directories for compatibility.
2643 if (my_trnlnm("PERL5LIB",buf,0))
2644 do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
2646 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE);
2650 /* Use the ~-expanded versions of APPLLIB (undocumented),
2651 ARCHLIB PRIVLIB SITEARCH SITELIB and OLDARCHLIB
2654 incpush(APPLLIB_EXP, FALSE);
2658 incpush(ARCHLIB_EXP, FALSE);
2661 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
2663 incpush(PRIVLIB_EXP, FALSE);
2666 incpush(SITEARCH_EXP, FALSE);
2669 incpush(SITELIB_EXP, FALSE);
2671 #ifdef OLDARCHLIB_EXP /* 5.00[01] compatibility */
2672 incpush(OLDARCHLIB_EXP, FALSE);
2676 incpush(".", FALSE);
2680 # define PERLLIB_SEP ';'
2683 # define PERLLIB_SEP '|'
2685 # define PERLLIB_SEP ':'
2688 #ifndef PERLLIB_MANGLE
2689 # define PERLLIB_MANGLE(s,n) (s)
2693 incpush(char *p, int addsubdirs)
2695 SV *subdir = Nullsv;
2696 static char *archpat_auto;
2703 if (!archpat_auto) {
2704 STRLEN len = (sizeof(ARCHNAME) + strlen(patchlevel)
2705 + sizeof("//auto"));
2706 New(55, archpat_auto, len, char);
2707 sprintf(archpat_auto, "/%s/%s/auto", ARCHNAME, patchlevel);
2709 for (len = sizeof(ARCHNAME) + 2;
2710 archpat_auto[len] != '\0' && archpat_auto[len] != '/'; len++)
2711 if (archpat_auto[len] == '.') archpat_auto[len] = '_';
2716 /* Break at all separators */
2718 SV *libdir = newSV(0);
2721 /* skip any consecutive separators */
2722 while ( *p == PERLLIB_SEP ) {
2723 /* Uncomment the next line for PATH semantics */
2724 /* av_push(GvAVn(incgv), newSVpv(".", 1)); */
2728 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
2729 sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
2734 sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
2735 p = Nullch; /* break out */
2739 * BEFORE pushing libdir onto @INC we may first push version- and
2740 * archname-specific sub-directories.
2743 struct stat tmpstatbuf;
2748 if ((unix = tounixspec_ts(SvPV(libdir,na),Nullch)) != Nullch) {
2750 while (unix[len-1] == '/') len--; /* Cosmetic */
2751 sv_usepvn(libdir,unix,len);
2754 PerlIO_printf(PerlIO_stderr(),
2755 "Failed to unixify @INC element \"%s\"\n",
2758 /* .../archname/version if -d .../archname/version/auto */
2759 sv_setsv(subdir, libdir);
2760 sv_catpv(subdir, archpat_auto);
2761 if (Stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2762 S_ISDIR(tmpstatbuf.st_mode))
2763 av_push(GvAVn(incgv),
2764 newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2766 /* .../archname if -d .../archname/auto */
2767 sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME),
2768 strlen(patchlevel) + 1, "", 0);
2769 if (Stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2770 S_ISDIR(tmpstatbuf.st_mode))
2771 av_push(GvAVn(incgv),
2772 newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2775 /* finally push this lib directory on the end of @INC */
2776 av_push(GvAVn(incgv), libdir);
2779 SvREFCNT_dec(subdir);
2783 static struct perl_thread *
2786 struct perl_thread *thr;
2789 Newz(53, thr, 1, struct perl_thread);
2790 curcop = &compiling;
2791 thr->cvcache = newHV();
2792 thr->threadsv = newAV();
2793 thr->specific = newAV();
2794 thr->errhv = newHV();
2795 thr->flags = THRf_R_JOINABLE;
2796 MUTEX_INIT(&thr->mutex);
2797 /* Handcraft thrsv similarly to mess_sv */
2798 New(53, thrsv, 1, SV);
2799 Newz(53, xpv, 1, XPV);
2800 SvFLAGS(thrsv) = SVt_PV;
2801 SvANY(thrsv) = (void*)xpv;
2802 SvREFCNT(thrsv) = 1 << 30; /* practically infinite */
2803 SvPVX(thrsv) = (char*)thr;
2804 SvCUR_set(thrsv, sizeof(thr));
2805 SvLEN_set(thrsv, sizeof(thr));
2806 *SvEND(thrsv) = '\0'; /* in the trailing_nul field */
2808 curcop = &compiling;
2811 MUTEX_LOCK(&threads_mutex);
2816 MUTEX_UNLOCK(&threads_mutex);
2818 #ifdef HAVE_THREAD_INTERN
2819 init_thread_intern(thr);
2822 #ifdef SET_THREAD_SELF
2823 SET_THREAD_SELF(thr);
2825 thr->self = pthread_self();
2826 #endif /* SET_THREAD_SELF */
2830 * These must come after the SET_THR because sv_setpvn does
2831 * SvTAINT and the taint fields require dTHR.
2833 toptarget = NEWSV(0,0);
2834 sv_upgrade(toptarget, SVt_PVFM);
2835 sv_setpvn(toptarget, "", 0);
2836 bodytarget = NEWSV(0,0);
2837 sv_upgrade(bodytarget, SVt_PVFM);
2838 sv_setpvn(bodytarget, "", 0);
2839 formtarget = bodytarget;
2840 thr->errsv = newSVpv("", 0);
2843 #endif /* USE_THREADS */
2846 call_list(I32 oldscope, AV *list)
2849 line_t oldline = curcop->cop_line;
2854 while (AvFILL(list) >= 0) {
2855 CV *cv = (CV*)av_shift(list);
2864 perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
2865 (void)SvPV(atsv, len);
2868 curcop = &compiling;
2869 curcop->cop_line = oldline;
2870 if (list == beginav)
2871 sv_catpv(atsv, "BEGIN failed--compilation aborted");
2873 sv_catpv(atsv, "END failed--cleanup aborted");
2874 while (scopestack_ix > oldscope)
2876 croak("%s", SvPVX(atsv));
2884 /* my_exit() was called */
2885 while (scopestack_ix > oldscope)
2888 curstash = defstash;
2890 call_list(oldscope, endav);
2892 curcop = &compiling;
2893 curcop->cop_line = oldline;
2895 if (list == beginav)
2896 croak("BEGIN failed--compilation aborted");
2898 croak("END failed--cleanup aborted");
2904 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
2909 curcop = &compiling;
2910 curcop->cop_line = oldline;
2923 DEBUG_L(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
2924 thr, (unsigned long) status));
2925 #endif /* USE_THREADS */
2934 STATUS_NATIVE_SET(status);
2941 my_failure_exit(void)
2944 if (vaxc$errno & 1) {
2945 if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
2946 STATUS_NATIVE_SET(44);
2949 if (!vaxc$errno && errno) /* unlikely */
2950 STATUS_NATIVE_SET(44);
2952 STATUS_NATIVE_SET(vaxc$errno);
2956 STATUS_POSIX_SET(errno);
2957 else if (STATUS_POSIX == 0)
2958 STATUS_POSIX_SET(255);
2967 register PERL_CONTEXT *cx;
2976 (void)UNLINK(e_tmpname);
2977 Safefree(e_tmpname);
2981 if (cxstack_ix >= 0) {