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(&sv_mutex);
139 * Safe to use basic SV functions from now on (though
140 * not things like mortals or tainting yet).
142 MUTEX_INIT(&eval_mutex);
143 COND_INIT(&eval_cond);
144 MUTEX_INIT(&threads_mutex);
145 COND_INIT(&nthreads_cond);
147 thr = init_main_thread();
148 #endif /* USE_THREADS */
150 linestr = NEWSV(65,80);
151 sv_upgrade(linestr,SVt_PVIV);
153 if (!SvREADONLY(&sv_undef)) {
154 SvREADONLY_on(&sv_undef);
158 SvREADONLY_on(&sv_no);
160 sv_setpv(&sv_yes,Yes);
162 SvREADONLY_on(&sv_yes);
165 nrs = newSVpv("\n", 1);
166 rs = SvREFCNT_inc(nrs);
168 sighandlerp = sighandler;
173 * There is no way we can refer to them from Perl so close them to save
174 * space. The other alternative would be to provide STDAUX and STDPRN
177 (void)fclose(stdaux);
178 (void)fclose(stdprn);
184 perl_destruct_level = 1;
186 if(perl_destruct_level > 0)
191 lex_state = LEX_NOTPARSING;
193 start_env.je_prev = NULL;
194 start_env.je_ret = -1;
195 start_env.je_mustcatch = TRUE;
196 top_env = &start_env;
199 SET_NUMERIC_STANDARD();
200 #if defined(SUBVERSION) && SUBVERSION > 0
201 sprintf(patchlevel, "%7.5f", (double) 5
202 + ((double) PATCHLEVEL / (double) 1000)
203 + ((double) SUBVERSION / (double) 100000));
205 sprintf(patchlevel, "%5.3f", (double) 5 +
206 ((double) PATCHLEVEL / (double) 1000));
209 #if defined(LOCAL_PATCH_COUNT)
210 localpatches = local_patches; /* For possible -v */
213 PerlIO_init(); /* Hook to IO system */
215 fdpid = newAV(); /* for remembering popen pids by fd */
219 New(51,debname,128,char);
220 New(52,debdelim,128,char);
227 perl_destruct(register PerlInterpreter *sv_interp)
230 int destruct_level; /* 0=none, 1=full, 2=full with checks */
235 #endif /* USE_THREADS */
237 if (!(curinterp = sv_interp))
242 /* Pass 1 on any remaining threads: detach joinables, join zombies */
244 MUTEX_LOCK(&threads_mutex);
245 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
246 "perl_destruct: waiting for %d threads...\n",
248 for (t = thr->next; t != thr; t = t->next) {
249 MUTEX_LOCK(&t->mutex);
250 switch (ThrSTATE(t)) {
253 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
254 "perl_destruct: joining zombie %p\n", t));
255 ThrSETSTATE(t, THRf_DEAD);
256 MUTEX_UNLOCK(&t->mutex);
259 * The SvREFCNT_dec below may take a long time (e.g. av
260 * may contain an object scalar whose destructor gets
261 * called) so we have to unlock threads_mutex and start
264 MUTEX_UNLOCK(&threads_mutex);
266 SvREFCNT_dec((SV*)av);
267 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
268 "perl_destruct: joined zombie %p OK\n", t));
270 case THRf_R_JOINABLE:
271 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
272 "perl_destruct: detaching thread %p\n", t));
273 ThrSETSTATE(t, THRf_R_DETACHED);
275 * We unlock threads_mutex and t->mutex in the opposite order
276 * from which we locked them just so that DETACH won't
277 * deadlock if it panics. It's only a breach of good style
278 * not a bug since they are unlocks not locks.
280 MUTEX_UNLOCK(&threads_mutex);
282 MUTEX_UNLOCK(&t->mutex);
285 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
286 "perl_destruct: ignoring %p (state %u)\n",
288 MUTEX_UNLOCK(&t->mutex);
289 /* fall through and out */
292 /* We leave the above "Pass 1" loop with threads_mutex still locked */
294 /* Pass 2 on remaining threads: wait for the thread count to drop to one */
297 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
298 "perl_destruct: final wait for %d threads\n",
300 COND_WAIT(&nthreads_cond, &threads_mutex);
302 /* At this point, we're the last thread */
303 MUTEX_UNLOCK(&threads_mutex);
304 DEBUG_L(PerlIO_printf(PerlIO_stderr(), "perl_destruct: armageddon has arrived\n"));
305 MUTEX_DESTROY(&threads_mutex);
306 COND_DESTROY(&nthreads_cond);
307 #endif /* !defined(FAKE_THREADS) */
308 #endif /* USE_THREADS */
310 destruct_level = perl_destruct_level;
314 if (s = getenv("PERL_DESTRUCT_LEVEL")) {
316 if (destruct_level < i)
325 /* We must account for everything. */
327 /* Destroy the main CV and syntax tree */
329 curpad = AvARRAY(comppad);
334 SvREFCNT_dec(main_cv);
339 * Try to destruct global references. We do this first so that the
340 * destructors and destructees still exist. Some sv's might remain.
341 * Non-referenced objects are on their own.
348 /* unhook hooks which will soon be, or use, destroyed data */
349 SvREFCNT_dec(warnhook);
351 SvREFCNT_dec(diehook);
353 SvREFCNT_dec(parsehook);
356 if (destruct_level == 0){
358 DEBUG_P(debprofdump());
360 /* The exit() function will do everything that needs doing. */
364 /* loosen bonds of global variables */
367 (void)PerlIO_close(rsfp);
371 /* Filters for program text */
372 SvREFCNT_dec(rsfp_filters);
373 rsfp_filters = Nullav;
385 sawampersand = FALSE; /* must save all match strings */
386 sawstudy = FALSE; /* do fbm_instr on all strings */
401 /* magical thingies */
403 Safefree(ofs); /* $, */
406 Safefree(ors); /* $\ */
409 SvREFCNT_dec(nrs); /* $\ helper */
412 multiline = 0; /* $* */
414 SvREFCNT_dec(statname);
418 /* defgv, aka *_ should be taken care of elsewhere */
420 /* clean up after study() */
421 SvREFCNT_dec(lastscream);
423 Safefree(screamfirst);
425 Safefree(screamnext);
428 /* startup and shutdown function lists */
429 SvREFCNT_dec(beginav);
431 SvREFCNT_dec(initav);
436 /* temp stack during pp_sort() */
437 SvREFCNT_dec(sortstack);
440 /* shortcuts just get cleared */
450 /* reset so print() ends up where we expect */
453 /* Prepare to destruct main symbol table. */
460 if (destruct_level >= 2) {
461 if (scopestack_ix != 0)
462 warn("Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
463 (long)scopestack_ix);
464 if (savestack_ix != 0)
465 warn("Unbalanced saves: %ld more saves than restores\n",
467 if (tmps_floor != -1)
468 warn("Unbalanced tmps: %ld more allocs than frees\n",
469 (long)tmps_floor + 1);
470 if (cxstack_ix != -1)
471 warn("Unbalanced context: %ld more PUSHes than POPs\n",
472 (long)cxstack_ix + 1);
475 /* Now absolutely destruct everything, somehow or other, loops or no. */
477 SvFLAGS(strtab) |= SVTYPEMASK; /* don't clean out strtab now */
478 while (sv_count != 0 && sv_count != last_sv_count) {
479 last_sv_count = sv_count;
482 SvFLAGS(strtab) &= ~SVTYPEMASK;
483 SvFLAGS(strtab) |= SVt_PVHV;
485 /* Destruct the global string table. */
487 /* Yell and reset the HeVAL() slots that are still holding refcounts,
488 * so that sv_free() won't fail on them.
497 array = HvARRAY(strtab);
501 warn("Unbalanced string table refcount: (%d) for \"%s\"",
502 HeVAL(hent) - Nullsv, HeKEY(hent));
503 HeVAL(hent) = Nullsv;
513 SvREFCNT_dec(strtab);
516 warn("Scalars leaked: %ld\n", (long)sv_count);
520 /* No SVs have survived, need to clean out */
524 Safefree(origfilename);
526 hints = 0; /* Reset hints. Should hints be per-interpreter ? */
528 DEBUG_P(debprofdump());
530 MUTEX_DESTROY(&sv_mutex);
531 MUTEX_DESTROY(&eval_mutex);
532 COND_DESTROY(&eval_cond);
534 /* As the penultimate thing, free the non-arena SV for thrsv */
535 Safefree(SvPVX(thrsv));
536 Safefree(SvANY(thrsv));
539 #endif /* USE_THREADS */
541 /* As the absolutely last thing, free the non-arena SV for mess() */
544 /* we know that type >= SVt_PV */
546 Safefree(SvPVX(mess_sv));
547 Safefree(SvANY(mess_sv));
554 perl_free(PerlInterpreter *sv_interp)
556 if (!(curinterp = sv_interp))
562 perl_parse(PerlInterpreter *sv_interp, void (*xsinit) (void), int argc, char **argv, char **env)
567 char *scriptname = NULL;
568 VOL bool dosearch = FALSE;
575 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
578 croak("suidperl is no longer needed since the kernel can now execute\n\
579 setuid perl scripts securely.\n");
583 if (!(curinterp = sv_interp))
586 #if defined(NeXT) && defined(__DYNAMIC__)
587 _dyld_lookup_and_bind
588 ("__environ", (unsigned long *) &environ_pointer, NULL);
593 #ifndef VMS /* VMS doesn't have environ array */
594 origenviron = environ;
600 /* Come here if running an undumped a.out. */
602 origfilename = savepv(argv[0]);
604 cxstack_ix = -1; /* start label stack again */
606 init_postdump_symbols(argc,argv,env);
611 curpad = AvARRAY(comppad);
616 SvREFCNT_dec(main_cv);
620 oldscope = scopestack_ix;
628 /* my_exit() was called */
629 while (scopestack_ix > oldscope)
634 call_list(oldscope, endav);
636 return STATUS_NATIVE_EXPORT;
639 PerlIO_printf(PerlIO_stderr(), "panic: top_env\n");
643 sv_setpvn(linestr,"",0);
644 sv = newSVpv("",0); /* first used for -I flags */
648 for (argc--,argv++; argc > 0; argc--,argv++) {
649 if (argv[0][0] != '-' || !argv[0][1])
653 validarg = " PHOOEY ";
678 if (s = moreswitches(s))
688 if (euid != uid || egid != gid)
689 croak("No -e allowed in setuid scripts");
691 e_tmpname = savepv(TMPPATH);
692 (void)mktemp(e_tmpname);
694 croak("Can't mktemp()");
695 e_fp = PerlIO_open(e_tmpname,"w");
697 croak("Cannot open temporary file");
702 PerlIO_puts(e_fp,argv[1]);
706 croak("No code specified for -e");
707 (void)PerlIO_putc(e_fp,'\n');
709 case 'I': /* -I handled both here and in moreswitches() */
711 if (!*++s && (s=argv[1]) != Nullch) {
714 while (s && isSPACE(*s))
718 for (e = s; *e && !isSPACE(*e); e++) ;
725 } /* XXX else croak? */
739 preambleav = newAV();
740 av_push(preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
742 Sv = newSVpv("print myconfig();",0);
744 sv_catpv(Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
746 sv_catpv(Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
748 #if defined(DEBUGGING) || defined(NO_EMBED) || defined(MULTIPLICITY)
749 sv_catpv(Sv,"\" Compile-time options:");
751 sv_catpv(Sv," DEBUGGING");
754 sv_catpv(Sv," NO_EMBED");
757 sv_catpv(Sv," MULTIPLICITY");
759 sv_catpv(Sv,"\\n\",");
761 #if defined(LOCAL_PATCH_COUNT)
762 if (LOCAL_PATCH_COUNT > 0) {
764 sv_catpv(Sv,"\" Locally applied patches:\\n\",");
765 for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
767 sv_catpvf(Sv,"\" \\t%s\\n\",",localpatches[i]);
771 sv_catpvf(Sv,"\" Built under %s\\n\"",OSNAME);
774 sv_catpvf(Sv,",\" Compiled at %s %s\\n\"",__DATE__,__TIME__);
776 sv_catpvf(Sv,",\" Compiled on %s\\n\"",__DATE__);
781 @env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; \
782 print \" \\%ENV:\\n @env\\n\" if @env; \
783 print \" \\@INC:\\n @INC\\n\";");
786 Sv = newSVpv("config_vars(qw(",0);
791 av_push(preambleav, Sv);
792 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
803 if (!*++s || isSPACE(*s)) {
807 /* catch use of gnu style long options */
808 if (strEQ(s, "version")) {
812 if (strEQ(s, "help")) {
819 croak("Unrecognized switch: -%s (-h will show valid options)",s);
824 if (!tainting && (s = getenv("PERL5OPT"))) {
835 if (!strchr("DIMUdmw", *s))
836 croak("Illegal switch in PERL5OPT: -%c", *s);
842 scriptname = argv[0];
844 if (PerlIO_flush(e_fp) || PerlIO_error(e_fp) || PerlIO_close(e_fp)) {
846 warn("Did you forget to compile with -DMULTIPLICITY?");
848 croak("Can't write to temp file for -e: %s", Strerror(errno));
852 scriptname = e_tmpname;
854 else if (scriptname == Nullch) {
856 if ( isatty(PerlIO_fileno(PerlIO_stdin())) )
864 open_script(scriptname,dosearch,sv);
866 validate_suid(validarg, scriptname);
871 main_cv = compcv = (CV*)NEWSV(1104,0);
872 sv_upgrade((SV *)compcv, SVt_PVCV);
876 av_push(comppad, Nullsv);
877 curpad = AvARRAY(comppad);
878 comppad_name = newAV();
879 comppad_name_fill = 0;
880 min_intro_pending = 0;
883 av_store(comppad_name, 0, newSVpv("@_", 2));
884 curpad[0] = (SV*)newAV();
885 SvPADMY_on(curpad[0]); /* XXX Needed? */
887 New(666, CvMUTEXP(compcv), 1, perl_mutex);
888 MUTEX_INIT(CvMUTEXP(compcv));
889 #endif /* USE_THREADS */
891 comppadlist = newAV();
892 AvREAL_off(comppadlist);
893 av_store(comppadlist, 0, (SV*)comppad_name);
894 av_store(comppadlist, 1, (SV*)comppad);
895 CvPADLIST(compcv) = comppadlist;
897 boot_core_UNIVERSAL();
899 (*xsinit)(); /* in case linked C routines want magical variables */
900 #if defined(VMS) || defined(WIN32) || defined(DJGPP)
904 #if defined(DEBUGGING) && defined(USE_THREADS) && defined(__linux__)
905 DEBUG_L(signal(SIGSEGV, (void(*)(int))catch_sigsegv););
908 init_predump_symbols();
910 init_postdump_symbols(argc,argv,env);
914 /* now parse the script */
917 if (yyparse() || error_count) {
919 croak("%s had compilation errors.\n", origfilename);
921 croak("Execution of %s aborted due to compilation errors.\n",
925 curcop->cop_line = 0;
929 (void)UNLINK(e_tmpname);
934 /* now that script is parsed, we can modify record separator */
936 rs = SvREFCNT_inc(nrs);
938 sv_setsv(*av_fetch(thr->threadsv, find_threadsv("/"), FALSE), rs);
940 sv_setsv(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), rs);
941 #endif /* USE_THREADS */
952 if ((s=getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
953 dump_mstats("after compilation:");
963 perl_run(PerlInterpreter *sv_interp)
970 if (!(curinterp = sv_interp))
973 oldscope = scopestack_ix;
978 cxstack_ix = -1; /* start context stack again */
981 /* my_exit() was called */
982 while (scopestack_ix > oldscope)
987 call_list(oldscope, endav);
989 if (getenv("PERL_DEBUG_MSTATS"))
990 dump_mstats("after execution: ");
993 return STATUS_NATIVE_EXPORT;
996 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
1001 if (curstack != mainstack) {
1003 SWITCHSTACK(curstack, mainstack);
1008 DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
1009 sawampersand ? "Enabling" : "Omitting"));
1012 DEBUG_x(dump_all());
1013 DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
1015 DEBUG_L(PerlIO_printf(Perl_debug_log, "main thread is 0x%lx\n",
1016 (unsigned long) thr));
1017 #endif /* USE_THREADS */
1020 PerlIO_printf(PerlIO_stderr(), "%s syntax OK\n", origfilename);
1023 if (PERLDB_SINGLE && DBsingle)
1024 sv_setiv(DBsingle, 1);
1026 call_list(oldscope, initav);
1036 else if (main_start) {
1037 CvDEPTH(main_cv) = 1;
1048 perl_get_sv(char *name, I32 create)
1052 if (name[1] == '\0' && !isALPHA(name[0])) {
1053 PADOFFSET tmp = find_threadsv(name);
1054 if (tmp != NOT_IN_PAD) {
1056 return *av_fetch(thr->threadsv, tmp, FALSE);
1059 #endif /* USE_THREADS */
1060 gv = gv_fetchpv(name, create, SVt_PV);
1067 perl_get_av(char *name, I32 create)
1069 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
1078 perl_get_hv(char *name, I32 create)
1080 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
1089 perl_get_cv(char *name, I32 create)
1091 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
1092 if (create && !GvCVu(gv))
1093 return newSUB(start_subparse(FALSE, 0),
1094 newSVOP(OP_CONST, 0, newSVpv(name,0)),
1102 /* Be sure to refetch the stack pointer after calling these routines. */
1105 perl_call_argv(char *sub_name, I32 flags, register char **argv)
1107 /* See G_* flags in cop.h */
1108 /* null terminated arg list */
1115 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
1120 return perl_call_pv(sub_name, flags);
1124 perl_call_pv(char *sub_name, I32 flags)
1125 /* name of the subroutine */
1126 /* See G_* flags in cop.h */
1128 return perl_call_sv((SV*)perl_get_cv(sub_name, TRUE), flags);
1132 perl_call_method(char *methname, I32 flags)
1133 /* name of the subroutine */
1134 /* See G_* flags in cop.h */
1140 XPUSHs(sv_2mortal(newSVpv(methname,0)));
1143 return perl_call_sv(*stack_sp--, flags);
1146 /* May be called with any of a CV, a GV, or an SV containing the name. */
1148 perl_call_sv(SV *sv, I32 flags)
1150 /* See G_* flags in cop.h */
1153 LOGOP myop; /* fake syntax tree node */
1159 bool oldcatch = CATCH_GET;
1164 if (flags & G_DISCARD) {
1169 Zero(&myop, 1, LOGOP);
1170 myop.op_next = Nullop;
1171 if (!(flags & G_NOARGS))
1172 myop.op_flags |= OPf_STACKED;
1173 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1174 (flags & G_ARRAY) ? OPf_WANT_LIST :
1179 EXTEND(stack_sp, 1);
1182 oldscope = scopestack_ix;
1184 if (PERLDB_SUB && curstash != debstash
1185 /* Handle first BEGIN of -d. */
1186 && (DBcv || (DBcv = GvCV(DBsub)))
1187 /* Try harder, since this may have been a sighandler, thus
1188 * curstash may be meaningless. */
1189 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != debstash))
1190 op->op_private |= OPpENTERSUB_DB;
1192 if (flags & G_EVAL) {
1193 cLOGOP->op_other = op;
1195 /* we're trying to emulate pp_entertry() here */
1197 register PERL_CONTEXT *cx;
1198 I32 gimme = GIMME_V;
1203 push_return(op->op_next);
1204 PUSHBLOCK(cx, CXt_EVAL, stack_sp);
1206 eval_root = op; /* Only needed so that goto works right. */
1209 if (flags & G_KEEPERR)
1224 /* my_exit() was called */
1225 curstash = defstash;
1229 croak("Callback called exit");
1238 stack_sp = stack_base + oldmark;
1239 if (flags & G_ARRAY)
1243 *++stack_sp = &sv_undef;
1251 if (op == (OP*)&myop)
1252 op = pp_entersub(ARGS);
1255 retval = stack_sp - (stack_base + oldmark);
1256 if ((flags & G_EVAL) && !(flags & G_KEEPERR))
1260 if (flags & G_EVAL) {
1261 if (scopestack_ix > oldscope) {
1265 register PERL_CONTEXT *cx;
1277 CATCH_SET(oldcatch);
1279 if (flags & G_DISCARD) {
1280 stack_sp = stack_base + oldmark;
1289 /* Eval a string. The G_EVAL flag is always assumed. */
1292 perl_eval_sv(SV *sv, I32 flags)
1294 /* See G_* flags in cop.h */
1297 UNOP myop; /* fake syntax tree node */
1299 I32 oldmark = sp - stack_base;
1306 if (flags & G_DISCARD) {
1314 EXTEND(stack_sp, 1);
1316 oldscope = scopestack_ix;
1318 if (!(flags & G_NOARGS))
1319 myop.op_flags = OPf_STACKED;
1320 myop.op_next = Nullop;
1321 myop.op_type = OP_ENTEREVAL;
1322 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1323 (flags & G_ARRAY) ? OPf_WANT_LIST :
1325 if (flags & G_KEEPERR)
1326 myop.op_flags |= OPf_SPECIAL;
1336 /* my_exit() was called */
1337 curstash = defstash;
1341 croak("Callback called exit");
1350 stack_sp = stack_base + oldmark;
1351 if (flags & G_ARRAY)
1355 *++stack_sp = &sv_undef;
1360 if (op == (OP*)&myop)
1361 op = pp_entereval(ARGS);
1364 retval = stack_sp - (stack_base + oldmark);
1365 if (!(flags & G_KEEPERR))
1370 if (flags & G_DISCARD) {
1371 stack_sp = stack_base + oldmark;
1381 perl_eval_pv(char *p, I32 croak_on_error)
1384 SV* sv = newSVpv(p, 0);
1387 perl_eval_sv(sv, G_SCALAR);
1394 if (croak_on_error && SvTRUE(ERRSV))
1395 croak(SvPVx(ERRSV, na));
1400 /* Require a module. */
1403 perl_require_pv(char *pv)
1405 SV* sv = sv_newmortal();
1406 sv_setpv(sv, "require '");
1409 perl_eval_sv(sv, G_DISCARD);
1413 magicname(char *sym, char *name, I32 namlen)
1417 if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
1418 sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
1422 usage(char *name) /* XXX move this out into a module ? */
1425 /* This message really ought to be max 23 lines.
1426 * Removed -h because the user already knows that opton. Others? */
1428 static char *usage[] = {
1429 "-0[octal] specify record separator (\\0, if no argument)",
1430 "-a autosplit mode with -n or -p (splits $_ into @F)",
1431 "-c check syntax only (runs BEGIN and END blocks)",
1432 "-d[:debugger] run scripts under debugger",
1433 "-D[number/list] set debugging flags (argument is a bit mask or flags)",
1434 "-e 'command' one line of script. Several -e's allowed. Omit [programfile].",
1435 "-F/pattern/ split() pattern for autosplit (-a). The //'s are optional.",
1436 "-i[extension] edit <> files in place (make backup if extension supplied)",
1437 "-Idirectory specify @INC/#include directory (may be used more than once)",
1438 "-l[octal] enable line ending processing, specifies line terminator",
1439 "-[mM][-]module.. executes `use/no module...' before executing your script.",
1440 "-n assume 'while (<>) { ... }' loop around your script",
1441 "-p assume loop like -n but print line also like sed",
1442 "-P run script through C preprocessor before compilation",
1443 "-s enable some switch parsing for switches after script name",
1444 "-S look for the script using PATH environment variable",
1445 "-T turn on tainting checks",
1446 "-u dump core after parsing script",
1447 "-U allow unsafe operations",
1448 "-v print version number and patchlevel of perl",
1449 "-V[:variable] print perl configuration information",
1450 "-w TURN WARNINGS ON FOR COMPILATION OF YOUR SCRIPT. Recommended.",
1451 "-x[directory] strip off text before #!perl line and perhaps cd to directory",
1457 printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
1459 printf("\n %s", *p++);
1462 /* This routine handles any switches that can be given during run */
1465 moreswitches(char *s)
1474 rschar = scan_oct(s, 4, &numlen);
1476 if (rschar & ~((U8)~0))
1478 else if (!rschar && numlen >= 2)
1479 nrs = newSVpv("", 0);
1482 nrs = newSVpv(&ch, 1);
1488 splitstr = savepv(s + 1);
1502 if (*s == ':' || *s == '=') {
1503 my_setenv("PERL5DB", form("use Devel::%s;", ++s));
1507 perldb = PERLDB_ALL;
1514 if (isALPHA(s[1])) {
1515 static char debopts[] = "psltocPmfrxuLHXD";
1518 for (s++; *s && (d = strchr(debopts,*s)); s++)
1519 debug |= 1 << (d - debopts);
1523 for (s++; isDIGIT(*s); s++) ;
1525 debug |= 0x80000000;
1527 warn("Recompile perl with -DDEBUGGING to use -D switch\n");
1528 for (s++; isALNUM(*s); s++) ;
1538 inplace = savepv(s+1);
1540 for (s = inplace; *s && !isSPACE(*s); s++) ;
1544 case 'I': /* -I handled both here and in parse_perl() */
1547 while (*s && isSPACE(*s))
1551 for (e = s; *e && !isSPACE(*e); e++) ;
1552 p = savepvn(s, e-s);
1558 croak("No space allowed after -I");
1568 *ors = scan_oct(s, 3 + (*s == '0'), &numlen);
1578 ors = SvPV(nrs, orslen);
1579 ors = savepvn(ors, orslen);
1583 forbid_setid("-M"); /* XXX ? */
1586 forbid_setid("-m"); /* XXX ? */
1591 /* -M-foo == 'no foo' */
1592 if (*s == '-') { use = "no "; ++s; }
1593 sv = newSVpv(use,0);
1595 /* We allow -M'Module qw(Foo Bar)' */
1596 while(isALNUM(*s) || *s==':') ++s;
1598 sv_catpv(sv, start);
1599 if (*(start-1) == 'm') {
1601 croak("Can't use '%c' after -mname", *s);
1602 sv_catpv( sv, " ()");
1605 sv_catpvn(sv, start, s-start);
1606 sv_catpv(sv, " split(/,/,q{");
1611 if (preambleav == NULL)
1612 preambleav = newAV();
1613 av_push(preambleav, sv);
1616 croak("No space allowed after -%c", *(s-1));
1633 croak("Too late for \"-T\" option");
1645 #if defined(SUBVERSION) && SUBVERSION > 0
1646 printf("\nThis is perl, version 5.%03d_%02d built for %s",
1647 PATCHLEVEL, SUBVERSION, ARCHNAME);
1649 printf("\nThis is perl, version %s built for %s",
1650 patchlevel, ARCHNAME);
1652 #if defined(LOCAL_PATCH_COUNT)
1653 if (LOCAL_PATCH_COUNT > 0)
1654 printf("\n(with %d registered patch%s, see perl -V for more detail)",
1655 LOCAL_PATCH_COUNT, (LOCAL_PATCH_COUNT!=1) ? "es" : "");
1658 printf("\n\nCopyright 1987-1997, Larry Wall\n");
1660 printf("\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
1663 printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n");
1664 printf("djgpp v2 port (perl5004) by Laszlo Molnar, 1997\n");
1667 printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
1668 "Version 5 port Copyright (c) 1994-1997, Andreas Kaiser, Ilya Zakharevich\n");
1671 printf("atariST series port, ++jrb bammi@cadence.com\n");
1674 Perl may be copied only under the terms of either the Artistic License or the\n\
1675 GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n");
1683 if (s[1] == '-') /* Additional switches on #! line. */
1694 #ifdef ALTERNATE_SHEBANG
1695 case 'S': /* OS/2 needs -S on "extproc" line. */
1703 croak("Can't emulate -%.1s on #! line",s);
1708 /* compliments of Tom Christiansen */
1710 /* unexec() can be found in the Gnu emacs distribution */
1721 prog = newSVpv(BIN_EXP);
1722 sv_catpv(prog, "/perl");
1723 file = newSVpv(origfilename);
1724 sv_catpv(file, ".perldump");
1726 status = unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
1728 PerlIO_printf(PerlIO_stderr(), "unexec of %s into %s failed!\n",
1729 SvPVX(prog), SvPVX(file));
1733 # include <lib$routines.h>
1734 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
1736 ABORT(); /* for use with undump */
1742 init_main_stash(void)
1747 /* Note that strtab is a rather special HV. Assumptions are made
1748 about not iterating on it, and not adding tie magic to it.
1749 It is properly deallocated in perl_destruct() */
1751 HvSHAREKEYS_off(strtab); /* mandatory */
1752 Newz(506,((XPVHV*)SvANY(strtab))->xhv_array,
1753 sizeof(HE*) * (((XPVHV*)SvANY(strtab))->xhv_max + 1), char);
1755 curstash = defstash = newHV();
1756 curstname = newSVpv("main",4);
1757 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
1758 SvREFCNT_dec(GvHV(gv));
1759 GvHV(gv) = (HV*)SvREFCNT_inc(defstash);
1761 HvNAME(defstash) = savepv("main");
1762 incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
1764 defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
1765 errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
1767 (void)form("%240s",""); /* Preallocate temp - for immediate signals. */
1768 sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */
1769 sv_setpvn(ERRSV, "", 0);
1770 curstash = defstash;
1771 compiling.cop_stash = defstash;
1772 debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
1773 globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
1774 /* We must init $/ before switches are processed. */
1775 sv_setpvn(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), "\n", 1);
1778 #ifdef CAN_PROTOTYPE
1780 open_script(char *scriptname, bool dosearch, SV *sv)
1783 open_script(scriptname,dosearch,sv)
1790 char *xfound = Nullch;
1791 char *xfailed = Nullch;
1795 #if defined(DOSISH) && !defined(OS2) && !defined(atarist)
1796 # define SEARCH_EXTS ".bat", ".cmd", NULL
1797 # define MAX_EXT_LEN 4
1800 # define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL
1801 # define MAX_EXT_LEN 4
1804 # define SEARCH_EXTS ".pl", ".com", NULL
1805 # define MAX_EXT_LEN 4
1807 /* additional extensions to try in each dir if scriptname not found */
1809 char *ext[] = { SEARCH_EXTS };
1810 int extidx = 0, i = 0;
1811 char *curext = Nullch;
1813 # define MAX_EXT_LEN 0
1817 * If dosearch is true and if scriptname does not contain path
1818 * delimiters, search the PATH for scriptname.
1820 * If SEARCH_EXTS is also defined, will look for each
1821 * scriptname{SEARCH_EXTS} whenever scriptname is not found
1822 * while searching the PATH.
1824 * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
1825 * proceeds as follows:
1827 * + look for ./scriptname{,.foo,.bar}
1828 * + search the PATH for scriptname{,.foo,.bar}
1831 * + look *only* in the PATH for scriptname{,.foo,.bar} (note
1832 * this will not look in '.' if it's not in the PATH)
1837 int hasdir, idx = 0, deftypes = 1;
1840 hasdir = (strpbrk(scriptname,":[</") != Nullch) ;
1841 /* The first time through, just add SEARCH_EXTS to whatever we
1842 * already have, so we can check for default file types. */
1844 (!hasdir && my_trnlnm("DCL$PATH",tokenbuf,idx++)) )
1850 if ((strlen(tokenbuf) + strlen(scriptname)
1851 + MAX_EXT_LEN) >= sizeof tokenbuf)
1852 continue; /* don't search dir with too-long name */
1853 strcat(tokenbuf, scriptname);
1857 if (strEQ(scriptname, "-"))
1859 if (dosearch) { /* Look in '.' first. */
1860 char *cur = scriptname;
1862 if ((curext = strrchr(scriptname,'.'))) /* possible current ext */
1864 if (strEQ(ext[i++],curext)) {
1865 extidx = -1; /* already has an ext */
1870 DEBUG_p(PerlIO_printf(Perl_debug_log,
1871 "Looking for %s\n",cur));
1872 if (Stat(cur,&statbuf) >= 0) {
1880 if (cur == scriptname) {
1881 len = strlen(scriptname);
1882 if (len+MAX_EXT_LEN+1 >= sizeof(tokenbuf))
1884 cur = strcpy(tokenbuf, scriptname);
1886 } while (extidx >= 0 && ext[extidx] /* try an extension? */
1887 && strcpy(tokenbuf+len, ext[extidx++]));
1892 if (dosearch && !strchr(scriptname, '/')
1894 && !strchr(scriptname, '\\')
1896 && (s = getenv("PATH"))) {
1899 bufend = s + strlen(s);
1900 while (s < bufend) {
1901 #if defined(atarist) || defined(DOSISH)
1906 && *s != ';'; len++, s++) {
1907 if (len < sizeof tokenbuf)
1910 if (len < sizeof tokenbuf)
1911 tokenbuf[len] = '\0';
1912 #else /* ! (atarist || DOSISH) */
1913 s = delimcpy(tokenbuf, tokenbuf + sizeof tokenbuf, s, bufend,
1916 #endif /* ! (atarist || DOSISH) */
1919 if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tokenbuf)
1920 continue; /* don't search dir with too-long name */
1922 #if defined(atarist) || defined(DOSISH)
1923 && tokenbuf[len - 1] != '/'
1924 && tokenbuf[len - 1] != '\\'
1927 tokenbuf[len++] = '/';
1928 if (len == 2 && tokenbuf[0] == '.')
1930 (void)strcpy(tokenbuf + len, scriptname);
1934 len = strlen(tokenbuf);
1935 if (extidx > 0) /* reset after previous loop */
1939 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tokenbuf));
1940 retval = Stat(tokenbuf,&statbuf);
1942 } while ( retval < 0 /* not there */
1943 && extidx>=0 && ext[extidx] /* try an extension? */
1944 && strcpy(tokenbuf+len, ext[extidx++])
1949 if (S_ISREG(statbuf.st_mode)
1950 && cando(S_IRUSR,TRUE,&statbuf)
1952 && cando(S_IXUSR,TRUE,&statbuf)
1956 xfound = tokenbuf; /* bingo! */
1960 xfailed = savepv(tokenbuf);
1963 if (!xfound && !seen_dot && !xfailed && (Stat(scriptname,&statbuf) < 0))
1965 seen_dot = 1; /* Disable message. */
1967 croak("Can't %s %s%s%s",
1968 (xfailed ? "execute" : "find"),
1969 (xfailed ? xfailed : scriptname),
1970 (xfailed ? "" : " on PATH"),
1971 (xfailed || seen_dot) ? "" : ", '.' not in PATH");
1974 scriptname = xfound;
1977 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
1978 char *s = scriptname + 8;
1987 origfilename = savepv(e_tmpname ? "-e" : scriptname);
1988 curcop->cop_filegv = gv_fetchfile(origfilename);
1989 if (strEQ(origfilename,"-"))
1991 if (fdscript >= 0) {
1992 rsfp = PerlIO_fdopen(fdscript,PERL_SCRIPT_MODE);
1993 #if defined(HAS_FCNTL) && defined(F_SETFD)
1995 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
1998 else if (preprocess) {
1999 char *cpp_cfg = CPPSTDIN;
2000 SV *cpp = NEWSV(0,0);
2001 SV *cmd = NEWSV(0,0);
2003 if (strEQ(cpp_cfg, "cppstdin"))
2004 sv_catpvf(cpp, "%s/", BIN_EXP);
2005 sv_catpv(cpp, cpp_cfg);
2008 sv_catpv(sv,PRIVLIB_EXP);
2012 sed %s -e \"/^[^#]/b\" \
2013 -e \"/^#[ ]*include[ ]/b\" \
2014 -e \"/^#[ ]*define[ ]/b\" \
2015 -e \"/^#[ ]*if[ ]/b\" \
2016 -e \"/^#[ ]*ifdef[ ]/b\" \
2017 -e \"/^#[ ]*ifndef[ ]/b\" \
2018 -e \"/^#[ ]*else/b\" \
2019 -e \"/^#[ ]*elif[ ]/b\" \
2020 -e \"/^#[ ]*undef[ ]/b\" \
2021 -e \"/^#[ ]*endif/b\" \
2024 (doextract ? "-e \"1,/^#/d\n\"" : ""),
2027 %s %s -e '/^[^#]/b' \
2028 -e '/^#[ ]*include[ ]/b' \
2029 -e '/^#[ ]*define[ ]/b' \
2030 -e '/^#[ ]*if[ ]/b' \
2031 -e '/^#[ ]*ifdef[ ]/b' \
2032 -e '/^#[ ]*ifndef[ ]/b' \
2033 -e '/^#[ ]*else/b' \
2034 -e '/^#[ ]*elif[ ]/b' \
2035 -e '/^#[ ]*undef[ ]/b' \
2036 -e '/^#[ ]*endif/b' \
2044 (doextract ? "-e '1,/^#/d\n'" : ""),
2046 scriptname, cpp, sv, CPPMINUS);
2048 #ifdef IAMSUID /* actually, this is caught earlier */
2049 if (euid != uid && !euid) { /* if running suidperl */
2051 (void)seteuid(uid); /* musn't stay setuid root */
2054 (void)setreuid((Uid_t)-1, uid);
2056 #ifdef HAS_SETRESUID
2057 (void)setresuid((Uid_t)-1, uid, (Uid_t)-1);
2063 if (geteuid() != uid)
2064 croak("Can't do seteuid!\n");
2066 #endif /* IAMSUID */
2067 rsfp = my_popen(SvPVX(cmd), "r");
2071 else if (!*scriptname) {
2072 forbid_setid("program input from stdin");
2073 rsfp = PerlIO_stdin();
2076 rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
2077 #if defined(HAS_FCNTL) && defined(F_SETFD)
2079 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
2087 #ifndef IAMSUID /* in case script is not readable before setuid */
2088 if (euid && Stat(SvPVX(GvSV(curcop->cop_filegv)),&statbuf) >= 0 &&
2089 statbuf.st_mode & (S_ISUID|S_ISGID)) {
2091 execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
2092 croak("Can't do setuid\n");
2096 croak("Can't open perl script \"%s\": %s\n",
2097 SvPVX(GvSV(curcop->cop_filegv)), Strerror(errno));
2102 validate_suid(char *validarg, char *scriptname)
2106 /* do we need to emulate setuid on scripts? */
2108 /* This code is for those BSD systems that have setuid #! scripts disabled
2109 * in the kernel because of a security problem. Merely defining DOSUID
2110 * in perl will not fix that problem, but if you have disabled setuid
2111 * scripts in the kernel, this will attempt to emulate setuid and setgid
2112 * on scripts that have those now-otherwise-useless bits set. The setuid
2113 * root version must be called suidperl or sperlN.NNN. If regular perl
2114 * discovers that it has opened a setuid script, it calls suidperl with
2115 * the same argv that it had. If suidperl finds that the script it has
2116 * just opened is NOT setuid root, it sets the effective uid back to the
2117 * uid. We don't just make perl setuid root because that loses the
2118 * effective uid we had before invoking perl, if it was different from the
2121 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
2122 * be defined in suidperl only. suidperl must be setuid root. The
2123 * Configure script will set this up for you if you want it.
2130 if (Fstat(PerlIO_fileno(rsfp),&statbuf) < 0) /* normal stat is insecure */
2131 croak("Can't stat script \"%s\"",origfilename);
2132 if (fdscript < 0 && statbuf.st_mode & (S_ISUID|S_ISGID)) {
2136 #ifndef HAS_SETREUID
2137 /* On this access check to make sure the directories are readable,
2138 * there is actually a small window that the user could use to make
2139 * filename point to an accessible directory. So there is a faint
2140 * chance that someone could execute a setuid script down in a
2141 * non-accessible directory. I don't know what to do about that.
2142 * But I don't think it's too important. The manual lies when
2143 * it says access() is useful in setuid programs.
2145 if (access(SvPVX(GvSV(curcop->cop_filegv)),1)) /*double check*/
2146 croak("Permission denied");
2148 /* If we can swap euid and uid, then we can determine access rights
2149 * with a simple stat of the file, and then compare device and
2150 * inode to make sure we did stat() on the same file we opened.
2151 * Then we just have to make sure he or she can execute it.
2154 struct stat tmpstatbuf;
2158 setreuid(euid,uid) < 0
2161 setresuid(euid,uid,(Uid_t)-1) < 0
2164 || getuid() != euid || geteuid() != uid)
2165 croak("Can't swap uid and euid"); /* really paranoid */
2166 if (Stat(SvPVX(GvSV(curcop->cop_filegv)),&tmpstatbuf) < 0)
2167 croak("Permission denied"); /* testing full pathname here */
2168 if (tmpstatbuf.st_dev != statbuf.st_dev ||
2169 tmpstatbuf.st_ino != statbuf.st_ino) {
2170 (void)PerlIO_close(rsfp);
2171 if (rsfp = my_popen("/bin/mail root","w")) { /* heh, heh */
2173 "User %ld tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
2174 (Filename of set-id script was %s, uid %ld gid %ld.)\n\nSincerely,\nperl\n",
2175 (long)uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
2176 (long)statbuf.st_dev, (long)statbuf.st_ino,
2177 SvPVX(GvSV(curcop->cop_filegv)),
2178 (long)statbuf.st_uid, (long)statbuf.st_gid);
2179 (void)my_pclose(rsfp);
2181 croak("Permission denied\n");
2185 setreuid(uid,euid) < 0
2187 # if defined(HAS_SETRESUID)
2188 setresuid(uid,euid,(Uid_t)-1) < 0
2191 || getuid() != uid || geteuid() != euid)
2192 croak("Can't reswap uid and euid");
2193 if (!cando(S_IXUSR,FALSE,&statbuf)) /* can real uid exec? */
2194 croak("Permission denied\n");
2196 #endif /* HAS_SETREUID */
2197 #endif /* IAMSUID */
2199 if (!S_ISREG(statbuf.st_mode))
2200 croak("Permission denied");
2201 if (statbuf.st_mode & S_IWOTH)
2202 croak("Setuid/gid script is writable by world");
2203 doswitches = FALSE; /* -s is insecure in suid */
2205 if (sv_gets(linestr, rsfp, 0) == Nullch ||
2206 strnNE(SvPV(linestr,na),"#!",2) ) /* required even on Sys V */
2207 croak("No #! line");
2208 s = SvPV(linestr,na)+2;
2210 while (!isSPACE(*s)) s++;
2211 for (s2 = s; (s2 > SvPV(linestr,na)+2 &&
2212 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
2213 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
2214 croak("Not a perl script");
2215 while (*s == ' ' || *s == '\t') s++;
2217 * #! arg must be what we saw above. They can invoke it by
2218 * mentioning suidperl explicitly, but they may not add any strange
2219 * arguments beyond what #! says if they do invoke suidperl that way.
2221 len = strlen(validarg);
2222 if (strEQ(validarg," PHOOEY ") ||
2223 strnNE(s,validarg,len) || !isSPACE(s[len]))
2224 croak("Args must match #! line");
2227 if (euid != uid && (statbuf.st_mode & S_ISUID) &&
2228 euid == statbuf.st_uid)
2230 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2231 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2232 #endif /* IAMSUID */
2234 if (euid) { /* oops, we're not the setuid root perl */
2235 (void)PerlIO_close(rsfp);
2238 execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
2240 croak("Can't do setuid\n");
2243 if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid) {
2245 (void)setegid(statbuf.st_gid);
2248 (void)setregid((Gid_t)-1,statbuf.st_gid);
2250 #ifdef HAS_SETRESGID
2251 (void)setresgid((Gid_t)-1,statbuf.st_gid,(Gid_t)-1);
2253 setgid(statbuf.st_gid);
2257 if (getegid() != statbuf.st_gid)
2258 croak("Can't do setegid!\n");
2260 if (statbuf.st_mode & S_ISUID) {
2261 if (statbuf.st_uid != euid)
2263 (void)seteuid(statbuf.st_uid); /* all that for this */
2266 (void)setreuid((Uid_t)-1,statbuf.st_uid);
2268 #ifdef HAS_SETRESUID
2269 (void)setresuid((Uid_t)-1,statbuf.st_uid,(Uid_t)-1);
2271 setuid(statbuf.st_uid);
2275 if (geteuid() != statbuf.st_uid)
2276 croak("Can't do seteuid!\n");
2278 else if (uid) { /* oops, mustn't run as root */
2280 (void)seteuid((Uid_t)uid);
2283 (void)setreuid((Uid_t)-1,(Uid_t)uid);
2285 #ifdef HAS_SETRESUID
2286 (void)setresuid((Uid_t)-1,(Uid_t)uid,(Uid_t)-1);
2292 if (geteuid() != uid)
2293 croak("Can't do seteuid!\n");
2296 if (!cando(S_IXUSR,TRUE,&statbuf))
2297 croak("Permission denied\n"); /* they can't do this */
2300 else if (preprocess)
2301 croak("-P not allowed for setuid/setgid script\n");
2302 else if (fdscript >= 0)
2303 croak("fd script not allowed in suidperl\n");
2305 croak("Script is not setuid/setgid in suidperl\n");
2307 /* We absolutely must clear out any saved ids here, so we */
2308 /* exec the real perl, substituting fd script for scriptname. */
2309 /* (We pass script name as "subdir" of fd, which perl will grok.) */
2310 PerlIO_rewind(rsfp);
2311 lseek(PerlIO_fileno(rsfp),(Off_t)0,0); /* just in case rewind didn't */
2312 for (which = 1; origargv[which] && origargv[which] != scriptname; which++) ;
2313 if (!origargv[which])
2314 croak("Permission denied");
2315 origargv[which] = savepv(form("/dev/fd/%d/%s",
2316 PerlIO_fileno(rsfp), origargv[which]));
2317 #if defined(HAS_FCNTL) && defined(F_SETFD)
2318 fcntl(PerlIO_fileno(rsfp),F_SETFD,0); /* ensure no close-on-exec */
2320 execv(form("%s/perl%s", BIN_EXP, patchlevel), origargv); /* try again */
2321 croak("Can't do setuid\n");
2322 #endif /* IAMSUID */
2324 if (euid != uid || egid != gid) { /* (suidperl doesn't exist, in fact) */
2325 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
2327 Fstat(PerlIO_fileno(rsfp),&statbuf); /* may be either wrapped or real suid */
2328 if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
2330 (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
2333 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2334 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2335 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
2336 /* not set-id, must be wrapped */
2342 find_beginning(void)
2344 register char *s, *s2;
2346 /* skip forward in input to the real script? */
2350 if ((s = sv_gets(linestr, rsfp, 0)) == Nullch)
2351 croak("No Perl script found in input\n");
2352 if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
2353 PerlIO_ungetc(rsfp, '\n'); /* to keep line count right */
2355 while (*s && !(isSPACE (*s) || *s == '#')) s++;
2357 while (*s == ' ' || *s == '\t') s++;
2359 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
2360 if (strnEQ(s2-4,"perl",4))
2362 while (s = moreswitches(s)) ;
2364 if (cddir && chdir(cddir) < 0)
2365 croak("Can't chdir to %s",cddir);
2373 uid = (int)getuid();
2374 euid = (int)geteuid();
2375 gid = (int)getgid();
2376 egid = (int)getegid();
2381 tainting |= (uid && (euid != uid || egid != gid));
2385 forbid_setid(char *s)
2388 croak("No %s allowed while running setuid", s);
2390 croak("No %s allowed while running setgid", s);
2397 curstash = debstash;
2398 dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
2400 DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
2401 DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
2402 DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
2403 DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
2404 sv_setiv(DBsingle, 0);
2405 DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
2406 sv_setiv(DBtrace, 0);
2407 DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
2408 sv_setiv(DBsignal, 0);
2409 curstash = defstash;
2413 init_stacks(ARGSproto)
2416 mainstack = curstack; /* remember in case we switch stacks */
2417 AvREAL_off(curstack); /* not a real array */
2418 av_extend(curstack,127);
2420 stack_base = AvARRAY(curstack);
2421 stack_sp = stack_base;
2422 stack_max = stack_base + 127;
2424 cxstack_max = 8192 / sizeof(PERL_CONTEXT) - 2; /* Use most of 8K. */
2425 New(50,cxstack,cxstack_max + 1,PERL_CONTEXT);
2428 New(50,tmps_stack,128,SV*);
2434 * The following stacks almost certainly should be per-interpreter,
2435 * but for now they're not. XXX
2439 markstack_ptr = markstack;
2441 New(54,markstack,64,I32);
2442 markstack_ptr = markstack;
2443 markstack_max = markstack + 64;
2449 New(54,scopestack,32,I32);
2451 scopestack_max = 32;
2457 New(54,savestack,128,ANY);
2459 savestack_max = 128;
2465 New(54,retstack,16,OP*);
2476 Safefree(tmps_stack);
2483 static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
2492 subname = newSVpv("main",4);
2496 init_predump_symbols(void)
2503 sv_setpvn(*av_fetch(thr->threadsv,find_threadsv("\""),FALSE)," ", 1);
2505 sv_setpvn(GvSV(gv_fetchpv("\"", TRUE, SVt_PV)), " ", 1);
2506 #endif /* USE_THREADS */
2508 stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
2509 GvMULTI_on(stdingv);
2510 IoIFP(GvIOp(stdingv)) = PerlIO_stdin();
2511 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
2513 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(stdingv));
2515 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
2517 IoOFP(GvIOp(tmpgv)) = IoIFP(GvIOp(tmpgv)) = PerlIO_stdout();
2519 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
2521 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(defoutgv));
2523 othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
2524 GvMULTI_on(othergv);
2525 IoOFP(GvIOp(othergv)) = IoIFP(GvIOp(othergv)) = PerlIO_stderr();
2526 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
2528 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(othergv));
2530 statname = NEWSV(66,0); /* last filename we did stat on */
2533 osname = savepv(OSNAME);
2537 init_postdump_symbols(register int argc, register char **argv, register char **env)
2544 argc--,argv++; /* skip name of script */
2546 for (; argc > 0 && **argv == '-'; argc--,argv++) {
2549 if (argv[0][1] == '-') {
2553 if (s = strchr(argv[0], '=')) {
2555 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
2558 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
2561 toptarget = NEWSV(0,0);
2562 sv_upgrade(toptarget, SVt_PVFM);
2563 sv_setpvn(toptarget, "", 0);
2564 bodytarget = NEWSV(0,0);
2565 sv_upgrade(bodytarget, SVt_PVFM);
2566 sv_setpvn(bodytarget, "", 0);
2567 formtarget = bodytarget;
2570 if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
2571 sv_setpv(GvSV(tmpgv),origfilename);
2572 magicname("0", "0", 1);
2574 if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
2575 sv_setpv(GvSV(tmpgv),origargv[0]);
2576 if (argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
2578 (void)gv_AVadd(argvgv);
2579 av_clear(GvAVn(argvgv));
2580 for (; argc > 0; argc--,argv++) {
2581 av_push(GvAVn(argvgv),newSVpv(argv[0],0));
2584 if (envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
2588 hv_magic(hv, envgv, 'E');
2589 #ifndef VMS /* VMS doesn't have environ array */
2590 /* Note that if the supplied env parameter is actually a copy
2591 of the global environ then it may now point to free'd memory
2592 if the environment has been modified since. To avoid this
2593 problem we treat env==NULL as meaning 'use the default'
2598 environ[0] = Nullch;
2599 for (; *env; env++) {
2600 if (!(s = strchr(*env,'=')))
2603 #if defined(WIN32) || defined(MSDOS)
2606 sv = newSVpv(s--,0);
2607 (void)hv_store(hv, *env, s - *env, sv, 0);
2609 #if defined(__BORLANDC__) && defined(USE_WIN32_RTL_ENV)
2610 /* Sins of the RTL. See note in my_setenv(). */
2611 (void)putenv(savepv(*env));
2615 #ifdef DYNAMIC_ENV_FETCH
2616 HvNAME(hv) = savepv(ENV_HV_NAME);
2620 if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
2621 sv_setiv(GvSV(tmpgv), (IV)getpid());
2630 s = getenv("PERL5LIB");
2634 incpush(getenv("PERLLIB"), FALSE);
2636 /* Treat PERL5?LIB as a possible search list logical name -- the
2637 * "natural" VMS idiom for a Unix path string. We allow each
2638 * element to be a set of |-separated directories for compatibility.
2642 if (my_trnlnm("PERL5LIB",buf,0))
2643 do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
2645 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE);
2649 /* Use the ~-expanded versions of APPLLIB (undocumented),
2650 ARCHLIB PRIVLIB SITEARCH SITELIB and OLDARCHLIB
2653 incpush(APPLLIB_EXP, FALSE);
2657 incpush(ARCHLIB_EXP, FALSE);
2660 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
2662 incpush(PRIVLIB_EXP, FALSE);
2665 incpush(SITEARCH_EXP, FALSE);
2668 incpush(SITELIB_EXP, FALSE);
2670 #ifdef OLDARCHLIB_EXP /* 5.00[01] compatibility */
2671 incpush(OLDARCHLIB_EXP, FALSE);
2675 incpush(".", FALSE);
2679 # define PERLLIB_SEP ';'
2682 # define PERLLIB_SEP '|'
2684 # define PERLLIB_SEP ':'
2687 #ifndef PERLLIB_MANGLE
2688 # define PERLLIB_MANGLE(s,n) (s)
2692 incpush(char *p, int addsubdirs)
2694 SV *subdir = Nullsv;
2695 static char *archpat_auto;
2702 if (!archpat_auto) {
2703 STRLEN len = (sizeof(ARCHNAME) + strlen(patchlevel)
2704 + sizeof("//auto"));
2705 New(55, archpat_auto, len, char);
2706 sprintf(archpat_auto, "/%s/%s/auto", ARCHNAME, patchlevel);
2708 for (len = sizeof(ARCHNAME) + 2;
2709 archpat_auto[len] != '\0' && archpat_auto[len] != '/'; len++)
2710 if (archpat_auto[len] == '.') archpat_auto[len] = '_';
2715 /* Break at all separators */
2717 SV *libdir = newSV(0);
2720 /* skip any consecutive separators */
2721 while ( *p == PERLLIB_SEP ) {
2722 /* Uncomment the next line for PATH semantics */
2723 /* av_push(GvAVn(incgv), newSVpv(".", 1)); */
2727 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
2728 sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
2733 sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
2734 p = Nullch; /* break out */
2738 * BEFORE pushing libdir onto @INC we may first push version- and
2739 * archname-specific sub-directories.
2742 struct stat tmpstatbuf;
2747 if ((unix = tounixspec_ts(SvPV(libdir,na),Nullch)) != Nullch) {
2749 while (unix[len-1] == '/') len--; /* Cosmetic */
2750 sv_usepvn(libdir,unix,len);
2753 PerlIO_printf(PerlIO_stderr(),
2754 "Failed to unixify @INC element \"%s\"\n",
2757 /* .../archname/version if -d .../archname/version/auto */
2758 sv_setsv(subdir, libdir);
2759 sv_catpv(subdir, archpat_auto);
2760 if (Stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2761 S_ISDIR(tmpstatbuf.st_mode))
2762 av_push(GvAVn(incgv),
2763 newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2765 /* .../archname if -d .../archname/auto */
2766 sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME),
2767 strlen(patchlevel) + 1, "", 0);
2768 if (Stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2769 S_ISDIR(tmpstatbuf.st_mode))
2770 av_push(GvAVn(incgv),
2771 newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2774 /* finally push this lib directory on the end of @INC */
2775 av_push(GvAVn(incgv), libdir);
2778 SvREFCNT_dec(subdir);
2782 static struct perl_thread *
2785 struct perl_thread *thr;
2788 Newz(53, thr, 1, struct perl_thread);
2789 curcop = &compiling;
2790 thr->cvcache = newHV();
2791 thr->threadsv = newAV();
2792 thr->specific = newAV();
2793 thr->errhv = newHV();
2794 thr->flags = THRf_R_JOINABLE;
2795 MUTEX_INIT(&thr->mutex);
2796 /* Handcraft thrsv similarly to mess_sv */
2797 New(53, thrsv, 1, SV);
2798 Newz(53, xpv, 1, XPV);
2799 SvFLAGS(thrsv) = SVt_PV;
2800 SvANY(thrsv) = (void*)xpv;
2801 SvREFCNT(thrsv) = 1 << 30; /* practically infinite */
2802 SvPVX(thrsv) = (char*)thr;
2803 SvCUR_set(thrsv, sizeof(thr));
2804 SvLEN_set(thrsv, sizeof(thr));
2805 *SvEND(thrsv) = '\0'; /* in the trailing_nul field */
2807 curcop = &compiling;
2810 MUTEX_LOCK(&threads_mutex);
2815 MUTEX_UNLOCK(&threads_mutex);
2817 #ifdef HAVE_THREAD_INTERN
2818 init_thread_intern(thr);
2821 #ifdef SET_THREAD_SELF
2822 SET_THREAD_SELF(thr);
2824 thr->self = pthread_self();
2825 #endif /* SET_THREAD_SELF */
2829 * These must come after the SET_THR because sv_setpvn does
2830 * SvTAINT and the taint fields require dTHR.
2832 toptarget = NEWSV(0,0);
2833 sv_upgrade(toptarget, SVt_PVFM);
2834 sv_setpvn(toptarget, "", 0);
2835 bodytarget = NEWSV(0,0);
2836 sv_upgrade(bodytarget, SVt_PVFM);
2837 sv_setpvn(bodytarget, "", 0);
2838 formtarget = bodytarget;
2839 thr->errsv = newSVpv("", 0);
2842 #endif /* USE_THREADS */
2845 call_list(I32 oldscope, AV *list)
2848 line_t oldline = curcop->cop_line;
2853 while (AvFILL(list) >= 0) {
2854 CV *cv = (CV*)av_shift(list);
2863 perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
2864 (void)SvPV(atsv, len);
2867 curcop = &compiling;
2868 curcop->cop_line = oldline;
2869 if (list == beginav)
2870 sv_catpv(atsv, "BEGIN failed--compilation aborted");
2872 sv_catpv(atsv, "END failed--cleanup aborted");
2873 while (scopestack_ix > oldscope)
2875 croak("%s", SvPVX(atsv));
2883 /* my_exit() was called */
2884 while (scopestack_ix > oldscope)
2887 curstash = defstash;
2889 call_list(oldscope, endav);
2891 curcop = &compiling;
2892 curcop->cop_line = oldline;
2894 if (list == beginav)
2895 croak("BEGIN failed--compilation aborted");
2897 croak("END failed--cleanup aborted");
2903 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
2908 curcop = &compiling;
2909 curcop->cop_line = oldline;
2922 DEBUG_L(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
2923 thr, (unsigned long) status));
2924 #endif /* USE_THREADS */
2933 STATUS_NATIVE_SET(status);
2940 my_failure_exit(void)
2943 if (vaxc$errno & 1) {
2944 if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
2945 STATUS_NATIVE_SET(44);
2948 if (!vaxc$errno && errno) /* unlikely */
2949 STATUS_NATIVE_SET(44);
2951 STATUS_NATIVE_SET(vaxc$errno);
2955 STATUS_POSIX_SET(errno);
2956 else if (STATUS_POSIX == 0)
2957 STATUS_POSIX_SET(255);
2966 register PERL_CONTEXT *cx;
2975 (void)UNLINK(e_tmpname);
2976 Safefree(e_tmpname);
2980 if (cxstack_ix >= 0) {