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 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)
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 #if 0 /* just about all regexp stuff, seems to be ok */
423 /* shortcuts to regexp stuff */
428 SAVEFREEOP(oldlastpm); /* for saving regexp context during debugger */
430 regprecomp = NULL; /* uncompiled string. */
431 regparse = NULL; /* Input-scan pointer. */
432 regxend = NULL; /* End of input for compile */
433 regnpar = 0; /* () count. */
434 regcode = NULL; /* Code-emit pointer; ®dummy = don't. */
435 regsize = 0; /* Code size. */
436 regnaughty = 0; /* How bad is this pattern? */
437 regsawback = 0; /* Did we see \1, ...? */
439 reginput = NULL; /* String-input pointer. */
440 regbol = NULL; /* Beginning of input, for ^ check. */
441 regeol = NULL; /* End of input, for $ check. */
442 regstartp = (char **)NULL; /* Pointer to startp array. */
443 regendp = (char **)NULL; /* Ditto for endp. */
444 reglastparen = 0; /* Similarly for lastparen. */
445 regtill = NULL; /* How far we are required to go. */
446 regflags = 0; /* are we folding, multilining? */
447 regprev = (char)NULL; /* char before regbol, \n if none */
451 /* clean up after study() */
452 SvREFCNT_dec(lastscream);
454 Safefree(screamfirst);
456 Safefree(screamnext);
459 /* startup and shutdown function lists */
460 SvREFCNT_dec(beginav);
462 SvREFCNT_dec(initav);
467 /* temp stack during pp_sort() */
468 SvREFCNT_dec(sortstack);
471 /* shortcuts just get cleared */
481 /* reset so print() ends up where we expect */
484 /* Prepare to destruct main symbol table. */
491 if (destruct_level >= 2) {
492 if (scopestack_ix != 0)
493 warn("Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
494 (long)scopestack_ix);
495 if (savestack_ix != 0)
496 warn("Unbalanced saves: %ld more saves than restores\n",
498 if (tmps_floor != -1)
499 warn("Unbalanced tmps: %ld more allocs than frees\n",
500 (long)tmps_floor + 1);
501 if (cxstack_ix != -1)
502 warn("Unbalanced context: %ld more PUSHes than POPs\n",
503 (long)cxstack_ix + 1);
506 /* Now absolutely destruct everything, somehow or other, loops or no. */
508 SvFLAGS(strtab) |= SVTYPEMASK; /* don't clean out strtab now */
509 while (sv_count != 0 && sv_count != last_sv_count) {
510 last_sv_count = sv_count;
513 SvFLAGS(strtab) &= ~SVTYPEMASK;
514 SvFLAGS(strtab) |= SVt_PVHV;
516 /* Destruct the global string table. */
518 /* Yell and reset the HeVAL() slots that are still holding refcounts,
519 * so that sv_free() won't fail on them.
528 array = HvARRAY(strtab);
532 warn("Unbalanced string table refcount: (%d) for \"%s\"",
533 HeVAL(hent) - Nullsv, HeKEY(hent));
534 HeVAL(hent) = Nullsv;
544 SvREFCNT_dec(strtab);
547 warn("Scalars leaked: %ld\n", (long)sv_count);
551 /* No SVs have survived, need to clean out */
555 Safefree(origfilename);
557 hints = 0; /* Reset hints. Should hints be per-interpreter ? */
559 DEBUG_P(debprofdump());
561 MUTEX_DESTROY(&sv_mutex);
562 MUTEX_DESTROY(&malloc_mutex);
563 MUTEX_DESTROY(&eval_mutex);
564 COND_DESTROY(&eval_cond);
566 /* As the penultimate thing, free the non-arena SV for thrsv */
567 Safefree(SvPVX(thrsv));
568 Safefree(SvANY(thrsv));
571 #endif /* USE_THREADS */
573 /* As the absolutely last thing, free the non-arena SV for mess() */
576 /* we know that type >= SVt_PV */
578 Safefree(SvPVX(mess_sv));
579 Safefree(SvANY(mess_sv));
586 perl_free(PerlInterpreter *sv_interp)
588 if (!(curinterp = sv_interp))
594 perl_parse(PerlInterpreter *sv_interp, void (*xsinit) (void), int argc, char **argv, char **env)
599 char *scriptname = NULL;
600 VOL bool dosearch = FALSE;
607 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
610 croak("suidperl is no longer needed since the kernel can now execute\n\
611 setuid perl scripts securely.\n");
615 if (!(curinterp = sv_interp))
618 #if defined(NeXT) && defined(__DYNAMIC__)
619 _dyld_lookup_and_bind
620 ("__environ", (unsigned long *) &environ_pointer, NULL);
625 #ifndef VMS /* VMS doesn't have environ array */
626 origenviron = environ;
632 /* Come here if running an undumped a.out. */
634 origfilename = savepv(argv[0]);
636 cxstack_ix = -1; /* start label stack again */
638 init_postdump_symbols(argc,argv,env);
643 curpad = AvARRAY(comppad);
648 SvREFCNT_dec(main_cv);
652 oldscope = scopestack_ix;
660 /* my_exit() was called */
661 while (scopestack_ix > oldscope)
666 call_list(oldscope, endav);
668 return STATUS_NATIVE_EXPORT;
671 PerlIO_printf(PerlIO_stderr(), "panic: top_env\n");
675 sv_setpvn(linestr,"",0);
676 sv = newSVpv("",0); /* first used for -I flags */
680 for (argc--,argv++; argc > 0; argc--,argv++) {
681 if (argv[0][0] != '-' || !argv[0][1])
685 validarg = " PHOOEY ";
710 if (s = moreswitches(s))
720 if (euid != uid || egid != gid)
721 croak("No -e allowed in setuid scripts");
723 e_tmpname = savepv(TMPPATH);
724 (void)mktemp(e_tmpname);
726 croak("Can't mktemp()");
727 e_fp = PerlIO_open(e_tmpname,"w");
729 croak("Cannot open temporary file");
734 PerlIO_puts(e_fp,argv[1]);
738 croak("No code specified for -e");
739 (void)PerlIO_putc(e_fp,'\n');
741 case 'I': /* -I handled both here and in moreswitches() */
743 if (!*++s && (s=argv[1]) != Nullch) {
746 while (s && isSPACE(*s))
750 for (e = s; *e && !isSPACE(*e); e++) ;
757 } /* XXX else croak? */
771 preambleav = newAV();
772 av_push(preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
774 Sv = newSVpv("print myconfig();",0);
776 sv_catpv(Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
778 sv_catpv(Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
780 #if defined(DEBUGGING) || defined(NO_EMBED) || defined(MULTIPLICITY)
781 sv_catpv(Sv,"\" Compile-time options:");
783 sv_catpv(Sv," DEBUGGING");
786 sv_catpv(Sv," NO_EMBED");
789 sv_catpv(Sv," MULTIPLICITY");
791 sv_catpv(Sv,"\\n\",");
793 #if defined(LOCAL_PATCH_COUNT)
794 if (LOCAL_PATCH_COUNT > 0) {
796 sv_catpv(Sv,"\" Locally applied patches:\\n\",");
797 for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
799 sv_catpvf(Sv,"\" \\t%s\\n\",",localpatches[i]);
803 sv_catpvf(Sv,"\" Built under %s\\n\"",OSNAME);
806 sv_catpvf(Sv,",\" Compiled at %s %s\\n\"",__DATE__,__TIME__);
808 sv_catpvf(Sv,",\" Compiled on %s\\n\"",__DATE__);
813 @env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; \
814 print \" \\%ENV:\\n @env\\n\" if @env; \
815 print \" \\@INC:\\n @INC\\n\";");
818 Sv = newSVpv("config_vars(qw(",0);
823 av_push(preambleav, Sv);
824 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
835 if (!*++s || isSPACE(*s)) {
839 /* catch use of gnu style long options */
840 if (strEQ(s, "version")) {
844 if (strEQ(s, "help")) {
851 croak("Unrecognized switch: -%s (-h will show valid options)",s);
856 if (!tainting && (s = getenv("PERL5OPT"))) {
867 if (!strchr("DIMUdmw", *s))
868 croak("Illegal switch in PERL5OPT: -%c", *s);
874 scriptname = argv[0];
876 if (PerlIO_flush(e_fp) || PerlIO_error(e_fp) || PerlIO_close(e_fp)) {
878 warn("Did you forget to compile with -DMULTIPLICITY?");
880 croak("Can't write to temp file for -e: %s", Strerror(errno));
884 scriptname = e_tmpname;
886 else if (scriptname == Nullch) {
888 if ( isatty(PerlIO_fileno(PerlIO_stdin())) )
896 open_script(scriptname,dosearch,sv);
898 validate_suid(validarg, scriptname);
903 main_cv = compcv = (CV*)NEWSV(1104,0);
904 sv_upgrade((SV *)compcv, SVt_PVCV);
908 av_push(comppad, Nullsv);
909 curpad = AvARRAY(comppad);
910 comppad_name = newAV();
911 comppad_name_fill = 0;
912 min_intro_pending = 0;
915 av_store(comppad_name, 0, newSVpv("@_", 2));
916 curpad[0] = (SV*)newAV();
917 SvPADMY_on(curpad[0]); /* XXX Needed? */
919 New(666, CvMUTEXP(compcv), 1, perl_mutex);
920 MUTEX_INIT(CvMUTEXP(compcv));
921 #endif /* USE_THREADS */
923 comppadlist = newAV();
924 AvREAL_off(comppadlist);
925 av_store(comppadlist, 0, (SV*)comppad_name);
926 av_store(comppadlist, 1, (SV*)comppad);
927 CvPADLIST(compcv) = comppadlist;
929 boot_core_UNIVERSAL();
931 (*xsinit)(); /* in case linked C routines want magical variables */
932 #if defined(VMS) || defined(WIN32)
936 #if defined(DEBUGGING) && defined(USE_THREADS) && defined(__linux__)
937 DEBUG_L(signal(SIGSEGV, (void(*)(int))catch_sigsegv););
940 init_predump_symbols();
942 init_postdump_symbols(argc,argv,env);
946 /* now parse the script */
949 if (yyparse() || error_count) {
951 croak("%s had compilation errors.\n", origfilename);
953 croak("Execution of %s aborted due to compilation errors.\n",
957 curcop->cop_line = 0;
961 (void)UNLINK(e_tmpname);
966 /* now that script is parsed, we can modify record separator */
968 rs = SvREFCNT_inc(nrs);
970 sv_setsv(*av_fetch(thr->magicals, find_thread_magical("/"), FALSE), rs);
972 sv_setsv(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), rs);
973 #endif /* USE_THREADS */
984 if ((s=getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
985 dump_mstats("after compilation:");
995 perl_run(PerlInterpreter *sv_interp)
1002 if (!(curinterp = sv_interp))
1005 oldscope = scopestack_ix;
1010 cxstack_ix = -1; /* start context stack again */
1013 /* my_exit() was called */
1014 while (scopestack_ix > oldscope)
1017 curstash = defstash;
1019 call_list(oldscope, endav);
1021 if (getenv("PERL_DEBUG_MSTATS"))
1022 dump_mstats("after execution: ");
1025 return STATUS_NATIVE_EXPORT;
1028 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
1033 if (curstack != mainstack) {
1035 SWITCHSTACK(curstack, mainstack);
1040 DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
1041 sawampersand ? "Enabling" : "Omitting"));
1044 DEBUG_x(dump_all());
1045 DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
1047 DEBUG_L(PerlIO_printf(Perl_debug_log, "main thread is 0x%lx\n",
1048 (unsigned long) thr));
1049 #endif /* USE_THREADS */
1052 PerlIO_printf(PerlIO_stderr(), "%s syntax OK\n", origfilename);
1055 if (PERLDB_SINGLE && DBsingle)
1056 sv_setiv(DBsingle, 1);
1058 call_list(oldscope, initav);
1068 else if (main_start) {
1069 CvDEPTH(main_cv) = 1;
1080 perl_get_sv(char *name, I32 create)
1084 if (name[1] == '\0' && !isALPHA(name[0])) {
1085 PADOFFSET tmp = find_thread_magical(name);
1086 if (tmp != NOT_IN_PAD) {
1088 return *av_fetch(thr->magicals, tmp, FALSE);
1091 #endif /* USE_THREADS */
1092 gv = gv_fetchpv(name, create, SVt_PV);
1099 perl_get_av(char *name, I32 create)
1101 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
1110 perl_get_hv(char *name, I32 create)
1112 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
1121 perl_get_cv(char *name, I32 create)
1123 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
1124 if (create && !GvCVu(gv))
1125 return newSUB(start_subparse(FALSE, 0),
1126 newSVOP(OP_CONST, 0, newSVpv(name,0)),
1134 /* Be sure to refetch the stack pointer after calling these routines. */
1137 perl_call_argv(char *subname, I32 flags, register char **argv)
1139 /* See G_* flags in cop.h */
1140 /* null terminated arg list */
1147 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
1152 return perl_call_pv(subname, flags);
1156 perl_call_pv(char *subname, I32 flags)
1157 /* name of the subroutine */
1158 /* See G_* flags in cop.h */
1160 return perl_call_sv((SV*)perl_get_cv(subname, TRUE), flags);
1164 perl_call_method(char *methname, I32 flags)
1165 /* name of the subroutine */
1166 /* See G_* flags in cop.h */
1172 XPUSHs(sv_2mortal(newSVpv(methname,0)));
1175 return perl_call_sv(*stack_sp--, flags);
1178 /* May be called with any of a CV, a GV, or an SV containing the name. */
1180 perl_call_sv(SV *sv, I32 flags)
1182 /* See G_* flags in cop.h */
1185 LOGOP myop; /* fake syntax tree node */
1191 bool oldcatch = CATCH_GET;
1196 if (flags & G_DISCARD) {
1201 Zero(&myop, 1, LOGOP);
1202 myop.op_next = Nullop;
1203 if (!(flags & G_NOARGS))
1204 myop.op_flags |= OPf_STACKED;
1205 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1206 (flags & G_ARRAY) ? OPf_WANT_LIST :
1211 EXTEND(stack_sp, 1);
1214 oldscope = scopestack_ix;
1216 if (PERLDB_SUB && curstash != debstash
1217 /* Handle first BEGIN of -d. */
1218 && (DBcv || (DBcv = GvCV(DBsub)))
1219 /* Try harder, since this may have been a sighandler, thus
1220 * curstash may be meaningless. */
1221 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != debstash))
1222 op->op_private |= OPpENTERSUB_DB;
1224 if (flags & G_EVAL) {
1225 cLOGOP->op_other = op;
1227 /* we're trying to emulate pp_entertry() here */
1229 register CONTEXT *cx;
1230 I32 gimme = GIMME_V;
1235 push_return(op->op_next);
1236 PUSHBLOCK(cx, CXt_EVAL, stack_sp);
1238 eval_root = op; /* Only needed so that goto works right. */
1241 if (flags & G_KEEPERR)
1256 /* my_exit() was called */
1257 curstash = defstash;
1261 croak("Callback called exit");
1270 stack_sp = stack_base + oldmark;
1271 if (flags & G_ARRAY)
1275 *++stack_sp = &sv_undef;
1283 if (op == (OP*)&myop)
1284 op = pp_entersub(ARGS);
1287 retval = stack_sp - (stack_base + oldmark);
1288 if ((flags & G_EVAL) && !(flags & G_KEEPERR))
1292 if (flags & G_EVAL) {
1293 if (scopestack_ix > oldscope) {
1297 register CONTEXT *cx;
1309 CATCH_SET(oldcatch);
1311 if (flags & G_DISCARD) {
1312 stack_sp = stack_base + oldmark;
1321 /* Eval a string. The G_EVAL flag is always assumed. */
1324 perl_eval_sv(SV *sv, I32 flags)
1326 /* See G_* flags in cop.h */
1329 UNOP myop; /* fake syntax tree node */
1331 I32 oldmark = sp - stack_base;
1338 if (flags & G_DISCARD) {
1346 EXTEND(stack_sp, 1);
1348 oldscope = scopestack_ix;
1350 if (!(flags & G_NOARGS))
1351 myop.op_flags = OPf_STACKED;
1352 myop.op_next = Nullop;
1353 myop.op_type = OP_ENTEREVAL;
1354 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1355 (flags & G_ARRAY) ? OPf_WANT_LIST :
1357 if (flags & G_KEEPERR)
1358 myop.op_flags |= OPf_SPECIAL;
1368 /* my_exit() was called */
1369 curstash = defstash;
1373 croak("Callback called exit");
1382 stack_sp = stack_base + oldmark;
1383 if (flags & G_ARRAY)
1387 *++stack_sp = &sv_undef;
1392 if (op == (OP*)&myop)
1393 op = pp_entereval(ARGS);
1396 retval = stack_sp - (stack_base + oldmark);
1397 if (!(flags & G_KEEPERR))
1402 if (flags & G_DISCARD) {
1403 stack_sp = stack_base + oldmark;
1413 perl_eval_pv(char *p, I32 croak_on_error)
1416 SV* sv = newSVpv(p, 0);
1419 perl_eval_sv(sv, G_SCALAR);
1426 if (croak_on_error && SvTRUE(ERRSV))
1427 croak(SvPVx(ERRSV, na));
1432 /* Require a module. */
1435 perl_require_pv(char *pv)
1437 SV* sv = sv_newmortal();
1438 sv_setpv(sv, "require '");
1441 perl_eval_sv(sv, G_DISCARD);
1445 magicname(char *sym, char *name, I32 namlen)
1449 if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
1450 sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
1454 usage(char *name) /* XXX move this out into a module ? */
1457 /* This message really ought to be max 23 lines.
1458 * Removed -h because the user already knows that opton. Others? */
1460 static char *usage[] = {
1461 "-0[octal] specify record separator (\\0, if no argument)",
1462 "-a autosplit mode with -n or -p (splits $_ into @F)",
1463 "-c check syntax only (runs BEGIN and END blocks)",
1464 "-d[:debugger] run scripts under debugger",
1465 "-D[number/list] set debugging flags (argument is a bit mask or flags)",
1466 "-e 'command' one line of script. Several -e's allowed. Omit [programfile].",
1467 "-F/pattern/ split() pattern for autosplit (-a). The //'s are optional.",
1468 "-i[extension] edit <> files in place (make backup if extension supplied)",
1469 "-Idirectory specify @INC/#include directory (may be used more than once)",
1470 "-l[octal] enable line ending processing, specifies line terminator",
1471 "-[mM][-]module.. executes `use/no module...' before executing your script.",
1472 "-n assume 'while (<>) { ... }' loop around your script",
1473 "-p assume loop like -n but print line also like sed",
1474 "-P run script through C preprocessor before compilation",
1475 "-s enable some switch parsing for switches after script name",
1476 "-S look for the script using PATH environment variable",
1477 "-T turn on tainting checks",
1478 "-u dump core after parsing script",
1479 "-U allow unsafe operations",
1480 "-v print version number and patchlevel of perl",
1481 "-V[:variable] print perl configuration information",
1482 "-w TURN WARNINGS ON FOR COMPILATION OF YOUR SCRIPT. Recommended.",
1483 "-x[directory] strip off text before #!perl line and perhaps cd to directory",
1489 printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
1491 printf("\n %s", *p++);
1494 /* This routine handles any switches that can be given during run */
1497 moreswitches(char *s)
1506 rschar = scan_oct(s, 4, &numlen);
1508 if (rschar & ~((U8)~0))
1510 else if (!rschar && numlen >= 2)
1511 nrs = newSVpv("", 0);
1514 nrs = newSVpv(&ch, 1);
1520 splitstr = savepv(s + 1);
1534 if (*s == ':' || *s == '=') {
1535 my_setenv("PERL5DB", form("use Devel::%s;", ++s));
1539 perldb = PERLDB_ALL;
1546 if (isALPHA(s[1])) {
1547 static char debopts[] = "psltocPmfrxuLHXD";
1550 for (s++; *s && (d = strchr(debopts,*s)); s++)
1551 debug |= 1 << (d - debopts);
1555 for (s++; isDIGIT(*s); s++) ;
1557 debug |= 0x80000000;
1559 warn("Recompile perl with -DDEBUGGING to use -D switch\n");
1560 for (s++; isALNUM(*s); s++) ;
1570 inplace = savepv(s+1);
1572 for (s = inplace; *s && !isSPACE(*s); s++) ;
1576 case 'I': /* -I handled both here and in parse_perl() */
1579 while (*s && isSPACE(*s))
1583 for (e = s; *e && !isSPACE(*e); e++) ;
1584 p = savepvn(s, e-s);
1590 croak("No space allowed after -I");
1600 *ors = scan_oct(s, 3 + (*s == '0'), &numlen);
1610 ors = SvPV(nrs, orslen);
1611 ors = savepvn(ors, orslen);
1615 forbid_setid("-M"); /* XXX ? */
1618 forbid_setid("-m"); /* XXX ? */
1623 /* -M-foo == 'no foo' */
1624 if (*s == '-') { use = "no "; ++s; }
1625 sv = newSVpv(use,0);
1627 /* We allow -M'Module qw(Foo Bar)' */
1628 while(isALNUM(*s) || *s==':') ++s;
1630 sv_catpv(sv, start);
1631 if (*(start-1) == 'm') {
1633 croak("Can't use '%c' after -mname", *s);
1634 sv_catpv( sv, " ()");
1637 sv_catpvn(sv, start, s-start);
1638 sv_catpv(sv, " split(/,/,q{");
1643 if (preambleav == NULL)
1644 preambleav = newAV();
1645 av_push(preambleav, sv);
1648 croak("No space allowed after -%c", *(s-1));
1665 croak("Too late for \"-T\" option");
1677 #if defined(SUBVERSION) && SUBVERSION > 0
1678 printf("\nThis is perl, version 5.%03d_%02d built for %s",
1679 PATCHLEVEL, SUBVERSION, ARCHNAME);
1681 printf("\nThis is perl, version %s built for %s",
1682 patchlevel, ARCHNAME);
1684 #if defined(LOCAL_PATCH_COUNT)
1685 if (LOCAL_PATCH_COUNT > 0)
1686 printf("\n(with %d registered patch%s, see perl -V for more detail)",
1687 LOCAL_PATCH_COUNT, (LOCAL_PATCH_COUNT!=1) ? "es" : "");
1690 printf("\n\nCopyright 1987-1997, Larry Wall\n");
1692 printf("\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
1695 printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n");
1698 printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
1699 "Version 5 port Copyright (c) 1994-1997, Andreas Kaiser, Ilya Zakharevich\n");
1702 printf("atariST series port, ++jrb bammi@cadence.com\n");
1705 Perl may be copied only under the terms of either the Artistic License or the\n\
1706 GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n");
1714 if (s[1] == '-') /* Additional switches on #! line. */
1722 #ifdef ALTERNATE_SHEBANG
1723 case 'S': /* OS/2 needs -S on "extproc" line. */
1731 croak("Can't emulate -%.1s on #! line",s);
1736 /* compliments of Tom Christiansen */
1738 /* unexec() can be found in the Gnu emacs distribution */
1749 prog = newSVpv(BIN_EXP);
1750 sv_catpv(prog, "/perl");
1751 file = newSVpv(origfilename);
1752 sv_catpv(file, ".perldump");
1754 status = unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
1756 PerlIO_printf(PerlIO_stderr(), "unexec of %s into %s failed!\n",
1757 SvPVX(prog), SvPVX(file));
1761 # include <lib$routines.h>
1762 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
1764 ABORT(); /* for use with undump */
1770 init_main_stash(void)
1775 /* Note that strtab is a rather special HV. Assumptions are made
1776 about not iterating on it, and not adding tie magic to it.
1777 It is properly deallocated in perl_destruct() */
1779 HvSHAREKEYS_off(strtab); /* mandatory */
1780 Newz(506,((XPVHV*)SvANY(strtab))->xhv_array,
1781 sizeof(HE*) * (((XPVHV*)SvANY(strtab))->xhv_max + 1), char);
1783 curstash = defstash = newHV();
1784 curstname = newSVpv("main",4);
1785 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
1786 SvREFCNT_dec(GvHV(gv));
1787 GvHV(gv) = (HV*)SvREFCNT_inc(defstash);
1789 HvNAME(defstash) = savepv("main");
1790 incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
1792 defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
1793 errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
1795 (void)form("%240s",""); /* Preallocate temp - for immediate signals. */
1796 sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */
1797 sv_setpvn(ERRSV, "", 0);
1798 curstash = defstash;
1799 compiling.cop_stash = defstash;
1800 debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
1801 /* We must init $/ before switches are processed. */
1802 sv_setpvn(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), "\n", 1);
1805 #ifdef CAN_PROTOTYPE
1807 open_script(char *scriptname, bool dosearch, SV *sv)
1810 open_script(scriptname,dosearch,sv)
1817 char *xfound = Nullch;
1818 char *xfailed = Nullch;
1822 #if defined(DOSISH) && !defined(OS2) && !defined(atarist)
1823 # define SEARCH_EXTS ".bat", ".cmd", NULL
1824 # define MAX_EXT_LEN 4
1827 # define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL
1828 # define MAX_EXT_LEN 4
1831 # define SEARCH_EXTS ".pl", ".com", NULL
1832 # define MAX_EXT_LEN 4
1834 /* additional extensions to try in each dir if scriptname not found */
1836 char *ext[] = { SEARCH_EXTS };
1837 int extidx = 0, i = 0;
1838 char *curext = Nullch;
1840 # define MAX_EXT_LEN 0
1844 * If dosearch is true and if scriptname does not contain path
1845 * delimiters, search the PATH for scriptname.
1847 * If SEARCH_EXTS is also defined, will look for each
1848 * scriptname{SEARCH_EXTS} whenever scriptname is not found
1849 * while searching the PATH.
1851 * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
1852 * proceeds as follows:
1854 * + look for ./scriptname{,.foo,.bar}
1855 * + search the PATH for scriptname{,.foo,.bar}
1858 * + look *only* in the PATH for scriptname{,.foo,.bar} (note
1859 * this will not look in '.' if it's not in the PATH)
1864 int hasdir, idx = 0, deftypes = 1;
1867 hasdir = (strpbrk(scriptname,":[</") != Nullch) ;
1868 /* The first time through, just add SEARCH_EXTS to whatever we
1869 * already have, so we can check for default file types. */
1871 (!hasdir && my_trnlnm("DCL$PATH",tokenbuf,idx++)) )
1877 if ((strlen(tokenbuf) + strlen(scriptname)
1878 + MAX_EXT_LEN) >= sizeof tokenbuf)
1879 continue; /* don't search dir with too-long name */
1880 strcat(tokenbuf, scriptname);
1884 if (strEQ(scriptname, "-"))
1886 if (dosearch) { /* Look in '.' first. */
1887 char *cur = scriptname;
1889 if ((curext = strrchr(scriptname,'.'))) /* possible current ext */
1891 if (strEQ(ext[i++],curext)) {
1892 extidx = -1; /* already has an ext */
1897 DEBUG_p(PerlIO_printf(Perl_debug_log,
1898 "Looking for %s\n",cur));
1899 if (Stat(cur,&statbuf) >= 0) {
1907 if (cur == scriptname) {
1908 len = strlen(scriptname);
1909 if (len+MAX_EXT_LEN+1 >= sizeof(tokenbuf))
1911 cur = strcpy(tokenbuf, scriptname);
1913 } while (extidx >= 0 && ext[extidx] /* try an extension? */
1914 && strcpy(tokenbuf+len, ext[extidx++]));
1919 if (dosearch && !strchr(scriptname, '/')
1921 && !strchr(scriptname, '\\')
1923 && (s = getenv("PATH"))) {
1926 bufend = s + strlen(s);
1927 while (s < bufend) {
1928 #if defined(atarist) || defined(DOSISH)
1933 && *s != ';'; len++, s++) {
1934 if (len < sizeof tokenbuf)
1937 if (len < sizeof tokenbuf)
1938 tokenbuf[len] = '\0';
1939 #else /* ! (atarist || DOSISH) */
1940 s = delimcpy(tokenbuf, tokenbuf + sizeof tokenbuf, s, bufend,
1943 #endif /* ! (atarist || DOSISH) */
1946 if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tokenbuf)
1947 continue; /* don't search dir with too-long name */
1949 #if defined(atarist) || defined(DOSISH)
1950 && tokenbuf[len - 1] != '/'
1951 && tokenbuf[len - 1] != '\\'
1954 tokenbuf[len++] = '/';
1955 if (len == 2 && tokenbuf[0] == '.')
1957 (void)strcpy(tokenbuf + len, scriptname);
1961 len = strlen(tokenbuf);
1962 if (extidx > 0) /* reset after previous loop */
1966 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tokenbuf));
1967 retval = Stat(tokenbuf,&statbuf);
1969 } while ( retval < 0 /* not there */
1970 && extidx>=0 && ext[extidx] /* try an extension? */
1971 && strcpy(tokenbuf+len, ext[extidx++])
1976 if (S_ISREG(statbuf.st_mode)
1977 && cando(S_IRUSR,TRUE,&statbuf)
1979 && cando(S_IXUSR,TRUE,&statbuf)
1983 xfound = tokenbuf; /* bingo! */
1987 xfailed = savepv(tokenbuf);
1990 if (!xfound && !seen_dot && !xfailed && (Stat(scriptname,&statbuf) < 0))
1992 seen_dot = 1; /* Disable message. */
1994 croak("Can't %s %s%s%s",
1995 (xfailed ? "execute" : "find"),
1996 (xfailed ? xfailed : scriptname),
1997 (xfailed ? "" : " on PATH"),
1998 (xfailed || seen_dot) ? "" : ", '.' not in PATH");
2001 scriptname = xfound;
2004 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
2005 char *s = scriptname + 8;
2014 origfilename = savepv(e_tmpname ? "-e" : scriptname);
2015 curcop->cop_filegv = gv_fetchfile(origfilename);
2016 if (strEQ(origfilename,"-"))
2018 if (fdscript >= 0) {
2019 rsfp = PerlIO_fdopen(fdscript,"r");
2020 #if defined(HAS_FCNTL) && defined(F_SETFD)
2022 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
2025 else if (preprocess) {
2026 char *cpp_cfg = CPPSTDIN;
2027 SV *cpp = NEWSV(0,0);
2028 SV *cmd = NEWSV(0,0);
2030 if (strEQ(cpp_cfg, "cppstdin"))
2031 sv_catpvf(cpp, "%s/", BIN_EXP);
2032 sv_catpv(cpp, cpp_cfg);
2035 sv_catpv(sv,PRIVLIB_EXP);
2039 sed %s -e \"/^[^#]/b\" \
2040 -e \"/^#[ ]*include[ ]/b\" \
2041 -e \"/^#[ ]*define[ ]/b\" \
2042 -e \"/^#[ ]*if[ ]/b\" \
2043 -e \"/^#[ ]*ifdef[ ]/b\" \
2044 -e \"/^#[ ]*ifndef[ ]/b\" \
2045 -e \"/^#[ ]*else/b\" \
2046 -e \"/^#[ ]*elif[ ]/b\" \
2047 -e \"/^#[ ]*undef[ ]/b\" \
2048 -e \"/^#[ ]*endif/b\" \
2051 (doextract ? "-e \"1,/^#/d\n\"" : ""),
2054 %s %s -e '/^[^#]/b' \
2055 -e '/^#[ ]*include[ ]/b' \
2056 -e '/^#[ ]*define[ ]/b' \
2057 -e '/^#[ ]*if[ ]/b' \
2058 -e '/^#[ ]*ifdef[ ]/b' \
2059 -e '/^#[ ]*ifndef[ ]/b' \
2060 -e '/^#[ ]*else/b' \
2061 -e '/^#[ ]*elif[ ]/b' \
2062 -e '/^#[ ]*undef[ ]/b' \
2063 -e '/^#[ ]*endif/b' \
2071 (doextract ? "-e '1,/^#/d\n'" : ""),
2073 scriptname, cpp, sv, CPPMINUS);
2075 #ifdef IAMSUID /* actually, this is caught earlier */
2076 if (euid != uid && !euid) { /* if running suidperl */
2078 (void)seteuid(uid); /* musn't stay setuid root */
2081 (void)setreuid((Uid_t)-1, uid);
2083 #ifdef HAS_SETRESUID
2084 (void)setresuid((Uid_t)-1, uid, (Uid_t)-1);
2090 if (geteuid() != uid)
2091 croak("Can't do seteuid!\n");
2093 #endif /* IAMSUID */
2094 rsfp = my_popen(SvPVX(cmd), "r");
2098 else if (!*scriptname) {
2099 forbid_setid("program input from stdin");
2100 rsfp = PerlIO_stdin();
2103 rsfp = PerlIO_open(scriptname,"r");
2104 #if defined(HAS_FCNTL) && defined(F_SETFD)
2106 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
2114 #ifndef IAMSUID /* in case script is not readable before setuid */
2115 if (euid && Stat(SvPVX(GvSV(curcop->cop_filegv)),&statbuf) >= 0 &&
2116 statbuf.st_mode & (S_ISUID|S_ISGID)) {
2118 execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
2119 croak("Can't do setuid\n");
2123 croak("Can't open perl script \"%s\": %s\n",
2124 SvPVX(GvSV(curcop->cop_filegv)), Strerror(errno));
2129 validate_suid(char *validarg, char *scriptname)
2133 /* do we need to emulate setuid on scripts? */
2135 /* This code is for those BSD systems that have setuid #! scripts disabled
2136 * in the kernel because of a security problem. Merely defining DOSUID
2137 * in perl will not fix that problem, but if you have disabled setuid
2138 * scripts in the kernel, this will attempt to emulate setuid and setgid
2139 * on scripts that have those now-otherwise-useless bits set. The setuid
2140 * root version must be called suidperl or sperlN.NNN. If regular perl
2141 * discovers that it has opened a setuid script, it calls suidperl with
2142 * the same argv that it had. If suidperl finds that the script it has
2143 * just opened is NOT setuid root, it sets the effective uid back to the
2144 * uid. We don't just make perl setuid root because that loses the
2145 * effective uid we had before invoking perl, if it was different from the
2148 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
2149 * be defined in suidperl only. suidperl must be setuid root. The
2150 * Configure script will set this up for you if you want it.
2157 if (Fstat(PerlIO_fileno(rsfp),&statbuf) < 0) /* normal stat is insecure */
2158 croak("Can't stat script \"%s\"",origfilename);
2159 if (fdscript < 0 && statbuf.st_mode & (S_ISUID|S_ISGID)) {
2163 #ifndef HAS_SETREUID
2164 /* On this access check to make sure the directories are readable,
2165 * there is actually a small window that the user could use to make
2166 * filename point to an accessible directory. So there is a faint
2167 * chance that someone could execute a setuid script down in a
2168 * non-accessible directory. I don't know what to do about that.
2169 * But I don't think it's too important. The manual lies when
2170 * it says access() is useful in setuid programs.
2172 if (access(SvPVX(GvSV(curcop->cop_filegv)),1)) /*double check*/
2173 croak("Permission denied");
2175 /* If we can swap euid and uid, then we can determine access rights
2176 * with a simple stat of the file, and then compare device and
2177 * inode to make sure we did stat() on the same file we opened.
2178 * Then we just have to make sure he or she can execute it.
2181 struct stat tmpstatbuf;
2185 setreuid(euid,uid) < 0
2188 setresuid(euid,uid,(Uid_t)-1) < 0
2191 || getuid() != euid || geteuid() != uid)
2192 croak("Can't swap uid and euid"); /* really paranoid */
2193 if (Stat(SvPVX(GvSV(curcop->cop_filegv)),&tmpstatbuf) < 0)
2194 croak("Permission denied"); /* testing full pathname here */
2195 if (tmpstatbuf.st_dev != statbuf.st_dev ||
2196 tmpstatbuf.st_ino != statbuf.st_ino) {
2197 (void)PerlIO_close(rsfp);
2198 if (rsfp = my_popen("/bin/mail root","w")) { /* heh, heh */
2200 "User %ld tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
2201 (Filename of set-id script was %s, uid %ld gid %ld.)\n\nSincerely,\nperl\n",
2202 (long)uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
2203 (long)statbuf.st_dev, (long)statbuf.st_ino,
2204 SvPVX(GvSV(curcop->cop_filegv)),
2205 (long)statbuf.st_uid, (long)statbuf.st_gid);
2206 (void)my_pclose(rsfp);
2208 croak("Permission denied\n");
2212 setreuid(uid,euid) < 0
2214 # if defined(HAS_SETRESUID)
2215 setresuid(uid,euid,(Uid_t)-1) < 0
2218 || getuid() != uid || geteuid() != euid)
2219 croak("Can't reswap uid and euid");
2220 if (!cando(S_IXUSR,FALSE,&statbuf)) /* can real uid exec? */
2221 croak("Permission denied\n");
2223 #endif /* HAS_SETREUID */
2224 #endif /* IAMSUID */
2226 if (!S_ISREG(statbuf.st_mode))
2227 croak("Permission denied");
2228 if (statbuf.st_mode & S_IWOTH)
2229 croak("Setuid/gid script is writable by world");
2230 doswitches = FALSE; /* -s is insecure in suid */
2232 if (sv_gets(linestr, rsfp, 0) == Nullch ||
2233 strnNE(SvPV(linestr,na),"#!",2) ) /* required even on Sys V */
2234 croak("No #! line");
2235 s = SvPV(linestr,na)+2;
2237 while (!isSPACE(*s)) s++;
2238 for (s2 = s; (s2 > SvPV(linestr,na)+2 &&
2239 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
2240 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
2241 croak("Not a perl script");
2242 while (*s == ' ' || *s == '\t') s++;
2244 * #! arg must be what we saw above. They can invoke it by
2245 * mentioning suidperl explicitly, but they may not add any strange
2246 * arguments beyond what #! says if they do invoke suidperl that way.
2248 len = strlen(validarg);
2249 if (strEQ(validarg," PHOOEY ") ||
2250 strnNE(s,validarg,len) || !isSPACE(s[len]))
2251 croak("Args must match #! line");
2254 if (euid != uid && (statbuf.st_mode & S_ISUID) &&
2255 euid == statbuf.st_uid)
2257 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2258 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2259 #endif /* IAMSUID */
2261 if (euid) { /* oops, we're not the setuid root perl */
2262 (void)PerlIO_close(rsfp);
2265 execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
2267 croak("Can't do setuid\n");
2270 if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid) {
2272 (void)setegid(statbuf.st_gid);
2275 (void)setregid((Gid_t)-1,statbuf.st_gid);
2277 #ifdef HAS_SETRESGID
2278 (void)setresgid((Gid_t)-1,statbuf.st_gid,(Gid_t)-1);
2280 setgid(statbuf.st_gid);
2284 if (getegid() != statbuf.st_gid)
2285 croak("Can't do setegid!\n");
2287 if (statbuf.st_mode & S_ISUID) {
2288 if (statbuf.st_uid != euid)
2290 (void)seteuid(statbuf.st_uid); /* all that for this */
2293 (void)setreuid((Uid_t)-1,statbuf.st_uid);
2295 #ifdef HAS_SETRESUID
2296 (void)setresuid((Uid_t)-1,statbuf.st_uid,(Uid_t)-1);
2298 setuid(statbuf.st_uid);
2302 if (geteuid() != statbuf.st_uid)
2303 croak("Can't do seteuid!\n");
2305 else if (uid) { /* oops, mustn't run as root */
2307 (void)seteuid((Uid_t)uid);
2310 (void)setreuid((Uid_t)-1,(Uid_t)uid);
2312 #ifdef HAS_SETRESUID
2313 (void)setresuid((Uid_t)-1,(Uid_t)uid,(Uid_t)-1);
2319 if (geteuid() != uid)
2320 croak("Can't do seteuid!\n");
2323 if (!cando(S_IXUSR,TRUE,&statbuf))
2324 croak("Permission denied\n"); /* they can't do this */
2327 else if (preprocess)
2328 croak("-P not allowed for setuid/setgid script\n");
2329 else if (fdscript >= 0)
2330 croak("fd script not allowed in suidperl\n");
2332 croak("Script is not setuid/setgid in suidperl\n");
2334 /* We absolutely must clear out any saved ids here, so we */
2335 /* exec the real perl, substituting fd script for scriptname. */
2336 /* (We pass script name as "subdir" of fd, which perl will grok.) */
2337 PerlIO_rewind(rsfp);
2338 lseek(PerlIO_fileno(rsfp),(Off_t)0,0); /* just in case rewind didn't */
2339 for (which = 1; origargv[which] && origargv[which] != scriptname; which++) ;
2340 if (!origargv[which])
2341 croak("Permission denied");
2342 origargv[which] = savepv(form("/dev/fd/%d/%s",
2343 PerlIO_fileno(rsfp), origargv[which]));
2344 #if defined(HAS_FCNTL) && defined(F_SETFD)
2345 fcntl(PerlIO_fileno(rsfp),F_SETFD,0); /* ensure no close-on-exec */
2347 execv(form("%s/perl%s", BIN_EXP, patchlevel), origargv); /* try again */
2348 croak("Can't do setuid\n");
2349 #endif /* IAMSUID */
2351 if (euid != uid || egid != gid) { /* (suidperl doesn't exist, in fact) */
2352 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
2354 Fstat(PerlIO_fileno(rsfp),&statbuf); /* may be either wrapped or real suid */
2355 if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
2357 (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
2360 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2361 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2362 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
2363 /* not set-id, must be wrapped */
2369 find_beginning(void)
2371 register char *s, *s2;
2373 /* skip forward in input to the real script? */
2377 if ((s = sv_gets(linestr, rsfp, 0)) == Nullch)
2378 croak("No Perl script found in input\n");
2379 if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
2380 PerlIO_ungetc(rsfp, '\n'); /* to keep line count right */
2382 while (*s && !(isSPACE (*s) || *s == '#')) s++;
2384 while (*s == ' ' || *s == '\t') s++;
2386 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
2387 if (strnEQ(s2-4,"perl",4))
2389 while (s = moreswitches(s)) ;
2391 if (cddir && chdir(cddir) < 0)
2392 croak("Can't chdir to %s",cddir);
2400 uid = (int)getuid();
2401 euid = (int)geteuid();
2402 gid = (int)getgid();
2403 egid = (int)getegid();
2408 tainting |= (uid && (euid != uid || egid != gid));
2412 forbid_setid(char *s)
2415 croak("No %s allowed while running setuid", s);
2417 croak("No %s allowed while running setgid", s);
2424 curstash = debstash;
2425 dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
2427 DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
2428 DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
2429 DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
2430 DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
2431 sv_setiv(DBsingle, 0);
2432 DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
2433 sv_setiv(DBtrace, 0);
2434 DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
2435 sv_setiv(DBsignal, 0);
2436 curstash = defstash;
2440 init_stacks(ARGSproto)
2443 mainstack = curstack; /* remember in case we switch stacks */
2444 AvREAL_off(curstack); /* not a real array */
2445 av_extend(curstack,127);
2447 stack_base = AvARRAY(curstack);
2448 stack_sp = stack_base;
2449 stack_max = stack_base + 127;
2451 cxstack_max = 8192 / sizeof(CONTEXT) - 2; /* Use most of 8K. */
2452 New(50,cxstack,cxstack_max + 1,CONTEXT);
2455 New(50,tmps_stack,128,SV*);
2461 * The following stacks almost certainly should be per-interpreter,
2462 * but for now they're not. XXX
2466 markstack_ptr = markstack;
2468 New(54,markstack,64,I32);
2469 markstack_ptr = markstack;
2470 markstack_max = markstack + 64;
2476 New(54,scopestack,32,I32);
2478 scopestack_max = 32;
2484 New(54,savestack,128,ANY);
2486 savestack_max = 128;
2492 New(54,retstack,16,OP*);
2503 Safefree(tmps_stack);
2510 static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
2519 subname = newSVpv("main",4);
2523 init_predump_symbols(void)
2530 sv_setpvn(*av_fetch(thr->magicals,find_thread_magical("\""),FALSE)," ", 1);
2532 sv_setpvn(GvSV(gv_fetchpv("\"", TRUE, SVt_PV)), " ", 1);
2533 #endif /* USE_THREADS */
2535 stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
2536 GvMULTI_on(stdingv);
2537 IoIFP(GvIOp(stdingv)) = PerlIO_stdin();
2538 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
2540 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(stdingv));
2542 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
2544 IoOFP(GvIOp(tmpgv)) = IoIFP(GvIOp(tmpgv)) = PerlIO_stdout();
2546 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
2548 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(defoutgv));
2550 othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
2551 GvMULTI_on(othergv);
2552 IoOFP(GvIOp(othergv)) = IoIFP(GvIOp(othergv)) = PerlIO_stderr();
2553 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
2555 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(othergv));
2557 statname = NEWSV(66,0); /* last filename we did stat on */
2560 osname = savepv(OSNAME);
2564 init_postdump_symbols(register int argc, register char **argv, register char **env)
2571 argc--,argv++; /* skip name of script */
2573 for (; argc > 0 && **argv == '-'; argc--,argv++) {
2576 if (argv[0][1] == '-') {
2580 if (s = strchr(argv[0], '=')) {
2582 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
2585 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
2588 toptarget = NEWSV(0,0);
2589 sv_upgrade(toptarget, SVt_PVFM);
2590 sv_setpvn(toptarget, "", 0);
2591 bodytarget = NEWSV(0,0);
2592 sv_upgrade(bodytarget, SVt_PVFM);
2593 sv_setpvn(bodytarget, "", 0);
2594 formtarget = bodytarget;
2597 if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
2598 sv_setpv(GvSV(tmpgv),origfilename);
2599 magicname("0", "0", 1);
2601 if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
2602 sv_setpv(GvSV(tmpgv),origargv[0]);
2603 if (argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
2605 (void)gv_AVadd(argvgv);
2606 av_clear(GvAVn(argvgv));
2607 for (; argc > 0; argc--,argv++) {
2608 av_push(GvAVn(argvgv),newSVpv(argv[0],0));
2611 if (envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
2615 hv_magic(hv, envgv, 'E');
2616 #ifndef VMS /* VMS doesn't have environ array */
2617 /* Note that if the supplied env parameter is actually a copy
2618 of the global environ then it may now point to free'd memory
2619 if the environment has been modified since. To avoid this
2620 problem we treat env==NULL as meaning 'use the default'
2625 environ[0] = Nullch;
2626 for (; *env; env++) {
2627 if (!(s = strchr(*env,'=')))
2633 sv = newSVpv(s--,0);
2634 (void)hv_store(hv, *env, s - *env, sv, 0);
2636 #if defined(__BORLANDC__) && defined(USE_WIN32_RTL_ENV)
2637 /* Sins of the RTL. See note in my_setenv(). */
2638 (void)putenv(savepv(*env));
2642 #ifdef DYNAMIC_ENV_FETCH
2643 HvNAME(hv) = savepv(ENV_HV_NAME);
2647 if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
2648 sv_setiv(GvSV(tmpgv), (IV)getpid());
2657 s = getenv("PERL5LIB");
2661 incpush(getenv("PERLLIB"), FALSE);
2663 /* Treat PERL5?LIB as a possible search list logical name -- the
2664 * "natural" VMS idiom for a Unix path string. We allow each
2665 * element to be a set of |-separated directories for compatibility.
2669 if (my_trnlnm("PERL5LIB",buf,0))
2670 do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
2672 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE);
2676 /* Use the ~-expanded versions of APPLLIB (undocumented),
2677 ARCHLIB PRIVLIB SITEARCH SITELIB and OLDARCHLIB
2680 incpush(APPLLIB_EXP, FALSE);
2684 incpush(ARCHLIB_EXP, FALSE);
2687 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
2689 incpush(PRIVLIB_EXP, FALSE);
2692 incpush(SITEARCH_EXP, FALSE);
2695 incpush(SITELIB_EXP, FALSE);
2697 #ifdef OLDARCHLIB_EXP /* 5.00[01] compatibility */
2698 incpush(OLDARCHLIB_EXP, FALSE);
2702 incpush(".", FALSE);
2706 # define PERLLIB_SEP ';'
2709 # define PERLLIB_SEP '|'
2711 # define PERLLIB_SEP ':'
2714 #ifndef PERLLIB_MANGLE
2715 # define PERLLIB_MANGLE(s,n) (s)
2719 incpush(char *p, int addsubdirs)
2721 SV *subdir = Nullsv;
2722 static char *archpat_auto;
2729 if (!archpat_auto) {
2730 STRLEN len = (sizeof(ARCHNAME) + strlen(patchlevel)
2731 + sizeof("//auto"));
2732 New(55, archpat_auto, len, char);
2733 sprintf(archpat_auto, "/%s/%s/auto", ARCHNAME, patchlevel);
2735 for (len = sizeof(ARCHNAME) + 2;
2736 archpat_auto[len] != '\0' && archpat_auto[len] != '/'; len++)
2737 if (archpat_auto[len] == '.') archpat_auto[len] = '_';
2742 /* Break at all separators */
2744 SV *libdir = newSV(0);
2747 /* skip any consecutive separators */
2748 while ( *p == PERLLIB_SEP ) {
2749 /* Uncomment the next line for PATH semantics */
2750 /* av_push(GvAVn(incgv), newSVpv(".", 1)); */
2754 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
2755 sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
2760 sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
2761 p = Nullch; /* break out */
2765 * BEFORE pushing libdir onto @INC we may first push version- and
2766 * archname-specific sub-directories.
2769 struct stat tmpstatbuf;
2774 if ((unix = tounixspec_ts(SvPV(libdir,na),Nullch)) != Nullch) {
2776 while (unix[len-1] == '/') len--; /* Cosmetic */
2777 sv_usepvn(libdir,unix,len);
2780 PerlIO_printf(PerlIO_stderr(),
2781 "Failed to unixify @INC element \"%s\"\n",
2784 /* .../archname/version if -d .../archname/version/auto */
2785 sv_setsv(subdir, libdir);
2786 sv_catpv(subdir, archpat_auto);
2787 if (Stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2788 S_ISDIR(tmpstatbuf.st_mode))
2789 av_push(GvAVn(incgv),
2790 newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2792 /* .../archname if -d .../archname/auto */
2793 sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME),
2794 strlen(patchlevel) + 1, "", 0);
2795 if (Stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2796 S_ISDIR(tmpstatbuf.st_mode))
2797 av_push(GvAVn(incgv),
2798 newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2801 /* finally push this lib directory on the end of @INC */
2802 av_push(GvAVn(incgv), libdir);
2805 SvREFCNT_dec(subdir);
2809 static struct thread *
2815 Newz(53, thr, 1, struct thread);
2816 curcop = &compiling;
2817 thr->cvcache = newHV();
2818 thr->magicals = newAV();
2819 thr->specific = newAV();
2820 thr->errhv = newHV();
2821 thr->flags = THRf_R_JOINABLE;
2822 MUTEX_INIT(&thr->mutex);
2823 /* Handcraft thrsv similarly to mess_sv */
2824 New(53, thrsv, 1, SV);
2825 Newz(53, xpv, 1, XPV);
2826 SvFLAGS(thrsv) = SVt_PV;
2827 SvANY(thrsv) = (void*)xpv;
2828 SvREFCNT(thrsv) = 1 << 30; /* practically infinite */
2829 SvPVX(thrsv) = (char*)thr;
2830 SvCUR_set(thrsv, sizeof(thr));
2831 SvLEN_set(thrsv, sizeof(thr));
2832 *SvEND(thrsv) = '\0'; /* in the trailing_nul field */
2834 curcop = &compiling;
2837 MUTEX_LOCK(&threads_mutex);
2842 MUTEX_UNLOCK(&threads_mutex);
2844 #ifdef HAVE_THREAD_INTERN
2845 init_thread_intern(thr);
2847 thr->self = pthread_self();
2848 #endif /* HAVE_THREAD_INTERN */
2852 * These must come after the SET_THR because sv_setpvn does
2853 * SvTAINT and the taint fields require dTHR.
2855 toptarget = NEWSV(0,0);
2856 sv_upgrade(toptarget, SVt_PVFM);
2857 sv_setpvn(toptarget, "", 0);
2858 bodytarget = NEWSV(0,0);
2859 sv_upgrade(bodytarget, SVt_PVFM);
2860 sv_setpvn(bodytarget, "", 0);
2861 formtarget = bodytarget;
2862 thr->errsv = newSVpv("", 0);
2865 #endif /* USE_THREADS */
2868 call_list(I32 oldscope, AV *list)
2871 line_t oldline = curcop->cop_line;
2876 while (AvFILL(list) >= 0) {
2877 CV *cv = (CV*)av_shift(list);
2886 perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
2887 (void)SvPV(atsv, len);
2890 curcop = &compiling;
2891 curcop->cop_line = oldline;
2892 if (list == beginav)
2893 sv_catpv(atsv, "BEGIN failed--compilation aborted");
2895 sv_catpv(atsv, "END failed--cleanup aborted");
2896 while (scopestack_ix > oldscope)
2898 croak("%s", SvPVX(atsv));
2906 /* my_exit() was called */
2907 while (scopestack_ix > oldscope)
2910 curstash = defstash;
2912 call_list(oldscope, endav);
2914 curcop = &compiling;
2915 curcop->cop_line = oldline;
2917 if (list == beginav)
2918 croak("BEGIN failed--compilation aborted");
2920 croak("END failed--cleanup aborted");
2926 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
2931 curcop = &compiling;
2932 curcop->cop_line = oldline;
2945 DEBUG_L(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
2946 thr, (unsigned long) status));
2947 #endif /* USE_THREADS */
2956 STATUS_NATIVE_SET(status);
2963 my_failure_exit(void)
2966 if (vaxc$errno & 1) {
2967 if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
2968 STATUS_NATIVE_SET(44);
2971 if (!vaxc$errno && errno) /* unlikely */
2972 STATUS_NATIVE_SET(44);
2974 STATUS_NATIVE_SET(vaxc$errno);
2978 STATUS_POSIX_SET(errno);
2979 else if (STATUS_POSIX == 0)
2980 STATUS_POSIX_SET(255);
2989 register CONTEXT *cx;
2998 (void)UNLINK(e_tmpname);
2999 Safefree(e_tmpname);
3003 if (cxstack_ix >= 0) {