3 * Copyright (c) 1987-1998 Larry Wall
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
11 * "A ship then new they built for him/of mithril and of elven glass" --Bilbo
16 #include "patchlevel.h"
18 /* XXX If this causes problems, set i_unistd=undef in the hint file. */
23 #if !defined(STANDARD_C) && !defined(HAS_GETENV_PROTOTYPE)
24 char *getenv _((char *)); /* Usually in <stdlib.h> */
34 dEXTCONST char rcsid[] = "perl.c\nPatch level: ###\n";
42 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
52 curcop = &compiling; \
59 laststype = OP_STAT; \
61 maxsysfd = MAXSYSFD; \
68 laststype = OP_STAT; \
72 static void find_beginning _((void));
73 static void forbid_setid _((char *));
74 static void incpush _((char *, int));
75 static void init_ids _((void));
76 static void init_debugger _((void));
77 static void init_lexer _((void));
78 static void init_main_stash _((void));
80 static struct perl_thread * init_main_thread _((void));
81 #endif /* USE_THREADS */
82 static void init_perllib _((void));
83 static void init_postdump_symbols _((int, char **, char **));
84 static void init_predump_symbols _((void));
85 static void my_exit_jump _((void)) __attribute__((noreturn));
86 static void nuke_stacks _((void));
87 static void open_script _((char *, bool, SV *));
88 static void usage _((char *));
89 static void validate_suid _((char *, char*));
91 static int fdscript = -1;
96 PerlInterpreter *sv_interp;
99 New(53, sv_interp, 1, PerlInterpreter);
104 perl_construct(register PerlInterpreter *sv_interp)
109 struct perl_thread *thr;
110 #endif /* FAKE_THREADS */
111 #endif /* USE_THREADS */
113 if (!(curinterp = sv_interp))
117 Zero(sv_interp, 1, PerlInterpreter);
120 /* Init the real globals (and main thread)? */
125 #ifdef ALLOC_THREAD_KEY
128 if (pthread_key_create(&thr_key, 0))
129 croak("panic: pthread_key_create");
131 MUTEX_INIT(&sv_mutex);
133 * Safe to use basic SV functions from now on (though
134 * not things like mortals or tainting yet).
136 MUTEX_INIT(&eval_mutex);
137 COND_INIT(&eval_cond);
138 MUTEX_INIT(&threads_mutex);
139 COND_INIT(&nthreads_cond);
140 #ifdef EMULATE_ATOMIC_REFCOUNTS
141 MUTEX_INIT(&svref_mutex);
142 #endif /* EMULATE_ATOMIC_REFCOUNTS */
144 thr = init_main_thread();
145 #endif /* USE_THREADS */
147 linestr = NEWSV(65,80);
148 sv_upgrade(linestr,SVt_PVIV);
150 if (!SvREADONLY(&sv_undef)) {
151 SvREADONLY_on(&sv_undef);
155 SvREADONLY_on(&sv_no);
157 sv_setpv(&sv_yes,Yes);
159 SvREADONLY_on(&sv_yes);
162 nrs = newSVpv("\n", 1);
163 rs = SvREFCNT_inc(nrs);
165 sighandlerp = sighandler;
170 * There is no way we can refer to them from Perl so close them to save
171 * space. The other alternative would be to provide STDAUX and STDPRN
174 (void)fclose(stdaux);
175 (void)fclose(stdprn);
181 perl_destruct_level = 1;
183 if(perl_destruct_level > 0)
188 lex_state = LEX_NOTPARSING;
190 start_env.je_prev = NULL;
191 start_env.je_ret = -1;
192 start_env.je_mustcatch = TRUE;
193 top_env = &start_env;
196 SET_NUMERIC_STANDARD();
197 #if defined(SUBVERSION) && SUBVERSION > 0
198 sprintf(patchlevel, "%7.5f", (double) 5
199 + ((double) PATCHLEVEL / (double) 1000)
200 + ((double) SUBVERSION / (double) 100000));
202 sprintf(patchlevel, "%5.3f", (double) 5 +
203 ((double) PATCHLEVEL / (double) 1000));
206 #if defined(LOCAL_PATCH_COUNT)
207 localpatches = local_patches; /* For possible -v */
210 PerlIO_init(); /* Hook to IO system */
212 fdpid = newAV(); /* for remembering popen pids by fd */
216 New(51,debname,128,char);
217 New(52,debdelim,128,char);
224 perl_destruct(register PerlInterpreter *sv_interp)
227 int destruct_level; /* 0=none, 1=full, 2=full with checks */
232 #endif /* USE_THREADS */
234 if (!(curinterp = sv_interp))
239 /* Pass 1 on any remaining threads: detach joinables, join zombies */
241 MUTEX_LOCK(&threads_mutex);
242 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
243 "perl_destruct: waiting for %d threads...\n",
245 for (t = thr->next; t != thr; t = t->next) {
246 MUTEX_LOCK(&t->mutex);
247 switch (ThrSTATE(t)) {
250 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
251 "perl_destruct: joining zombie %p\n", t));
252 ThrSETSTATE(t, THRf_DEAD);
253 MUTEX_UNLOCK(&t->mutex);
256 * The SvREFCNT_dec below may take a long time (e.g. av
257 * may contain an object scalar whose destructor gets
258 * called) so we have to unlock threads_mutex and start
261 MUTEX_UNLOCK(&threads_mutex);
263 SvREFCNT_dec((SV*)av);
264 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
265 "perl_destruct: joined zombie %p OK\n", t));
267 case THRf_R_JOINABLE:
268 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
269 "perl_destruct: detaching thread %p\n", t));
270 ThrSETSTATE(t, THRf_R_DETACHED);
272 * We unlock threads_mutex and t->mutex in the opposite order
273 * from which we locked them just so that DETACH won't
274 * deadlock if it panics. It's only a breach of good style
275 * not a bug since they are unlocks not locks.
277 MUTEX_UNLOCK(&threads_mutex);
279 MUTEX_UNLOCK(&t->mutex);
282 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
283 "perl_destruct: ignoring %p (state %u)\n",
285 MUTEX_UNLOCK(&t->mutex);
286 /* fall through and out */
289 /* We leave the above "Pass 1" loop with threads_mutex still locked */
291 /* Pass 2 on remaining threads: wait for the thread count to drop to one */
294 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
295 "perl_destruct: final wait for %d threads\n",
297 COND_WAIT(&nthreads_cond, &threads_mutex);
299 /* At this point, we're the last thread */
300 MUTEX_UNLOCK(&threads_mutex);
301 DEBUG_L(PerlIO_printf(PerlIO_stderr(), "perl_destruct: armageddon has arrived\n"));
302 MUTEX_DESTROY(&threads_mutex);
303 COND_DESTROY(&nthreads_cond);
304 #endif /* !defined(FAKE_THREADS) */
305 #endif /* USE_THREADS */
307 destruct_level = perl_destruct_level;
311 if (s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL")) {
313 if (destruct_level < i)
322 /* We must account for everything. */
324 /* Destroy the main CV and syntax tree */
326 curpad = AvARRAY(comppad);
331 SvREFCNT_dec(main_cv);
336 * Try to destruct global references. We do this first so that the
337 * destructors and destructees still exist. Some sv's might remain.
338 * Non-referenced objects are on their own.
345 /* unhook hooks which will soon be, or use, destroyed data */
346 SvREFCNT_dec(warnhook);
348 SvREFCNT_dec(diehook);
350 SvREFCNT_dec(parsehook);
353 if (destruct_level == 0){
355 DEBUG_P(debprofdump());
357 /* The exit() function will do everything that needs doing. */
361 /* loosen bonds of global variables */
364 (void)PerlIO_close(rsfp);
368 /* Filters for program text */
369 SvREFCNT_dec(rsfp_filters);
370 rsfp_filters = Nullav;
382 sawampersand = FALSE; /* must save all match strings */
383 sawstudy = FALSE; /* do fbm_instr on all strings */
398 /* magical thingies */
400 Safefree(ofs); /* $, */
403 Safefree(ors); /* $\ */
406 SvREFCNT_dec(nrs); /* $\ helper */
409 multiline = 0; /* $* */
411 SvREFCNT_dec(statname);
415 /* defgv, aka *_ should be taken care of elsewhere */
417 /* clean up after study() */
418 SvREFCNT_dec(lastscream);
420 Safefree(screamfirst);
422 Safefree(screamnext);
425 /* startup and shutdown function lists */
426 SvREFCNT_dec(beginav);
428 SvREFCNT_dec(initav);
433 /* temp stack during pp_sort() */
434 SvREFCNT_dec(sortstack);
437 /* shortcuts just get cleared */
447 /* reset so print() ends up where we expect */
450 /* Prepare to destruct main symbol table. */
457 if (destruct_level >= 2) {
458 if (scopestack_ix != 0)
459 warn("Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
460 (long)scopestack_ix);
461 if (savestack_ix != 0)
462 warn("Unbalanced saves: %ld more saves than restores\n",
464 if (tmps_floor != -1)
465 warn("Unbalanced tmps: %ld more allocs than frees\n",
466 (long)tmps_floor + 1);
467 if (cxstack_ix != -1)
468 warn("Unbalanced context: %ld more PUSHes than POPs\n",
469 (long)cxstack_ix + 1);
472 /* Now absolutely destruct everything, somehow or other, loops or no. */
474 SvFLAGS(strtab) |= SVTYPEMASK; /* don't clean out strtab now */
475 while (sv_count != 0 && sv_count != last_sv_count) {
476 last_sv_count = sv_count;
479 SvFLAGS(strtab) &= ~SVTYPEMASK;
480 SvFLAGS(strtab) |= SVt_PVHV;
482 /* Destruct the global string table. */
484 /* Yell and reset the HeVAL() slots that are still holding refcounts,
485 * so that sv_free() won't fail on them.
494 array = HvARRAY(strtab);
498 warn("Unbalanced string table refcount: (%d) for \"%s\"",
499 HeVAL(hent) - Nullsv, HeKEY(hent));
500 HeVAL(hent) = Nullsv;
510 SvREFCNT_dec(strtab);
513 warn("Scalars leaked: %ld\n", (long)sv_count);
517 /* No SVs have survived, need to clean out */
521 Safefree(origfilename);
523 hints = 0; /* Reset hints. Should hints be per-interpreter ? */
525 DEBUG_P(debprofdump());
527 MUTEX_DESTROY(&sv_mutex);
528 MUTEX_DESTROY(&eval_mutex);
529 COND_DESTROY(&eval_cond);
531 /* As the penultimate thing, free the non-arena SV for thrsv */
532 Safefree(SvPVX(thrsv));
533 Safefree(SvANY(thrsv));
536 #endif /* USE_THREADS */
538 /* As the absolutely last thing, free the non-arena SV for mess() */
541 /* we know that type >= SVt_PV */
543 Safefree(SvPVX(mess_sv));
544 Safefree(SvANY(mess_sv));
551 perl_free(PerlInterpreter *sv_interp)
553 if (!(curinterp = sv_interp))
559 perl_parse(PerlInterpreter *sv_interp, void (*xsinit) (void), int argc, char **argv, char **env)
564 char *scriptname = NULL;
565 VOL bool dosearch = FALSE;
573 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
576 croak("suidperl is no longer needed since the kernel can now execute\n\
577 setuid perl scripts securely.\n");
581 if (!(curinterp = sv_interp))
584 #if defined(NeXT) && defined(__DYNAMIC__)
585 _dyld_lookup_and_bind
586 ("__environ", (unsigned long *) &environ_pointer, NULL);
591 #ifndef VMS /* VMS doesn't have environ array */
592 origenviron = environ;
598 /* Come here if running an undumped a.out. */
600 origfilename = savepv(argv[0]);
602 cxstack_ix = -1; /* start label stack again */
604 init_postdump_symbols(argc,argv,env);
609 curpad = AvARRAY(comppad);
614 SvREFCNT_dec(main_cv);
618 oldscope = scopestack_ix;
626 /* my_exit() was called */
627 while (scopestack_ix > oldscope)
632 call_list(oldscope, endav);
634 return STATUS_NATIVE_EXPORT;
637 PerlIO_printf(PerlIO_stderr(), "panic: top_env\n");
641 sv_setpvn(linestr,"",0);
642 sv = newSVpv("",0); /* first used for -I flags */
646 for (argc--,argv++; argc > 0; argc--,argv++) {
647 if (argv[0][0] != '-' || !argv[0][1])
651 validarg = " PHOOEY ";
676 if (s = moreswitches(s))
686 if (euid != uid || egid != gid)
687 croak("No -e allowed in setuid scripts");
690 int oldumask = PerlLIO_umask(0177);
692 e_tmpname = savepv(TMPPATH);
694 e_tmpfd = PerlLIO_mkstemp(e_tmpname);
695 #else /* use mktemp() */
696 (void)PerlLIO_mktemp(e_tmpname);
698 croak("Cannot generate temporary filename");
699 # if defined(HAS_OPEN3) && defined(O_EXCL)
700 e_tmpfd = open(e_tmpname,
701 O_WRONLY | O_CREAT | O_EXCL,
704 (void)UNLINK(e_tmpname);
705 /* Yes, potential race. But at least we can say we tried. */
706 e_fp = PerlIO_open(e_tmpname,"w");
708 #endif /* ifdef HAS_MKSTEMP */
709 #if defined(HAS_MKSTEMP) || (defined(HAS_OPEN3) && defined(O_EXCL))
711 croak("Cannot create temporary file \"%s\"", e_tmpname);
712 e_fp = PerlIO_fdopen(e_tmpfd,"w");
715 croak("Cannot create temporary file \"%s\"", e_tmpname);
717 (void)PerlLIO_umask(oldumask);
723 PerlIO_puts(e_fp,argv[1]);
727 croak("No code specified for -e");
728 (void)PerlIO_putc(e_fp,'\n');
730 case 'I': /* -I handled both here and in moreswitches() */
732 if (!*++s && (s=argv[1]) != Nullch) {
735 while (s && isSPACE(*s))
739 for (e = s; *e && !isSPACE(*e); e++) ;
746 } /* XXX else croak? */
760 preambleav = newAV();
761 av_push(preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
763 Sv = newSVpv("print myconfig();",0);
765 sv_catpv(Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
767 sv_catpv(Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
769 #if defined(DEBUGGING) || defined(NO_EMBED) || defined(MULTIPLICITY)
770 sv_catpv(Sv,"\" Compile-time options:");
772 sv_catpv(Sv," DEBUGGING");
775 sv_catpv(Sv," NO_EMBED");
778 sv_catpv(Sv," MULTIPLICITY");
780 sv_catpv(Sv,"\\n\",");
782 #if defined(LOCAL_PATCH_COUNT)
783 if (LOCAL_PATCH_COUNT > 0) {
785 sv_catpv(Sv,"\" Locally applied patches:\\n\",");
786 for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
788 sv_catpvf(Sv,"\" \\t%s\\n\",",localpatches[i]);
792 sv_catpvf(Sv,"\" Built under %s\\n\"",OSNAME);
795 sv_catpvf(Sv,",\" Compiled at %s %s\\n\"",__DATE__,__TIME__);
797 sv_catpvf(Sv,",\" Compiled on %s\\n\"",__DATE__);
802 @env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; \
803 print \" \\%ENV:\\n @env\\n\" if @env; \
804 print \" \\@INC:\\n @INC\\n\";");
807 Sv = newSVpv("config_vars(qw(",0);
812 av_push(preambleav, Sv);
813 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
824 if (!*++s || isSPACE(*s)) {
828 /* catch use of gnu style long options */
829 if (strEQ(s, "version")) {
833 if (strEQ(s, "help")) {
840 croak("Unrecognized switch: -%s (-h will show valid options)",s);
845 if (!tainting && (s = PerlEnv_getenv("PERL5OPT"))) {
856 if (!strchr("DIMUdmw", *s))
857 croak("Illegal switch in PERL5OPT: -%c", *s);
863 scriptname = argv[0];
865 if (PerlIO_flush(e_fp) || PerlIO_error(e_fp) || PerlIO_close(e_fp)) {
867 warn("Did you forget to compile with -DMULTIPLICITY?");
869 croak("Can't write to temp file for -e: %s", Strerror(errno));
873 scriptname = e_tmpname;
875 else if (scriptname == Nullch) {
877 if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) )
885 open_script(scriptname,dosearch,sv);
887 validate_suid(validarg, scriptname);
892 main_cv = compcv = (CV*)NEWSV(1104,0);
893 sv_upgrade((SV *)compcv, SVt_PVCV);
897 av_push(comppad, Nullsv);
898 curpad = AvARRAY(comppad);
899 comppad_name = newAV();
900 comppad_name_fill = 0;
901 min_intro_pending = 0;
904 av_store(comppad_name, 0, newSVpv("@_", 2));
905 curpad[0] = (SV*)newAV();
906 SvPADMY_on(curpad[0]); /* XXX Needed? */
908 New(666, CvMUTEXP(compcv), 1, perl_mutex);
909 MUTEX_INIT(CvMUTEXP(compcv));
910 #endif /* USE_THREADS */
912 comppadlist = newAV();
913 AvREAL_off(comppadlist);
914 av_store(comppadlist, 0, (SV*)comppad_name);
915 av_store(comppadlist, 1, (SV*)comppad);
916 CvPADLIST(compcv) = comppadlist;
918 boot_core_UNIVERSAL();
920 (*xsinit)(); /* in case linked C routines want magical variables */
921 #if defined(VMS) || defined(WIN32) || defined(DJGPP)
925 init_predump_symbols();
927 init_postdump_symbols(argc,argv,env);
931 /* now parse the script */
933 SETERRNO(0,SS$_NORMAL);
935 if (yyparse() || error_count) {
937 croak("%s had compilation errors.\n", origfilename);
939 croak("Execution of %s aborted due to compilation errors.\n",
943 curcop->cop_line = 0;
947 (void)UNLINK(e_tmpname);
953 /* now that script is parsed, we can modify record separator */
955 rs = SvREFCNT_inc(nrs);
956 sv_setsv(perl_get_sv("/", TRUE), rs);
967 if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
968 dump_mstats("after compilation:");
978 perl_run(PerlInterpreter *sv_interp)
985 if (!(curinterp = sv_interp))
988 oldscope = scopestack_ix;
993 cxstack_ix = -1; /* start context stack again */
996 /* my_exit() was called */
997 while (scopestack_ix > oldscope)
1000 curstash = defstash;
1002 call_list(oldscope, endav);
1004 if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
1005 dump_mstats("after execution: ");
1008 return STATUS_NATIVE_EXPORT;
1011 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
1016 if (curstack != mainstack) {
1018 SWITCHSTACK(curstack, mainstack);
1023 DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
1024 sawampersand ? "Enabling" : "Omitting"));
1027 DEBUG_x(dump_all());
1028 DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
1030 DEBUG_L(PerlIO_printf(Perl_debug_log, "main thread is 0x%lx\n",
1031 (unsigned long) thr));
1032 #endif /* USE_THREADS */
1035 PerlIO_printf(PerlIO_stderr(), "%s syntax OK\n", origfilename);
1038 if (PERLDB_SINGLE && DBsingle)
1039 sv_setiv(DBsingle, 1);
1041 call_list(oldscope, initav);
1051 else if (main_start) {
1052 CvDEPTH(main_cv) = 1;
1063 perl_get_sv(char *name, I32 create)
1067 if (name[1] == '\0' && !isALPHA(name[0])) {
1068 PADOFFSET tmp = find_threadsv(name);
1069 if (tmp != NOT_IN_PAD) {
1071 return THREADSV(tmp);
1074 #endif /* USE_THREADS */
1075 gv = gv_fetchpv(name, create, SVt_PV);
1082 perl_get_av(char *name, I32 create)
1084 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
1093 perl_get_hv(char *name, I32 create)
1095 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
1104 perl_get_cv(char *name, I32 create)
1106 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
1107 if (create && !GvCVu(gv))
1108 return newSUB(start_subparse(FALSE, 0),
1109 newSVOP(OP_CONST, 0, newSVpv(name,0)),
1117 /* Be sure to refetch the stack pointer after calling these routines. */
1120 perl_call_argv(char *sub_name, I32 flags, register char **argv)
1122 /* See G_* flags in cop.h */
1123 /* null terminated arg list */
1130 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
1135 return perl_call_pv(sub_name, flags);
1139 perl_call_pv(char *sub_name, I32 flags)
1140 /* name of the subroutine */
1141 /* See G_* flags in cop.h */
1143 return perl_call_sv((SV*)perl_get_cv(sub_name, TRUE), flags);
1147 perl_call_method(char *methname, I32 flags)
1148 /* name of the subroutine */
1149 /* See G_* flags in cop.h */
1155 XPUSHs(sv_2mortal(newSVpv(methname,0)));
1158 return perl_call_sv(*stack_sp--, flags);
1161 /* May be called with any of a CV, a GV, or an SV containing the name. */
1163 perl_call_sv(SV *sv, I32 flags)
1165 /* See G_* flags in cop.h */
1168 LOGOP myop; /* fake syntax tree node */
1173 bool oldcatch = CATCH_GET;
1178 if (flags & G_DISCARD) {
1183 Zero(&myop, 1, LOGOP);
1184 myop.op_next = Nullop;
1185 if (!(flags & G_NOARGS))
1186 myop.op_flags |= OPf_STACKED;
1187 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1188 (flags & G_ARRAY) ? OPf_WANT_LIST :
1193 EXTEND(stack_sp, 1);
1196 oldscope = scopestack_ix;
1198 if (PERLDB_SUB && curstash != debstash
1199 /* Handle first BEGIN of -d. */
1200 && (DBcv || (DBcv = GvCV(DBsub)))
1201 /* Try harder, since this may have been a sighandler, thus
1202 * curstash may be meaningless. */
1203 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != debstash))
1204 op->op_private |= OPpENTERSUB_DB;
1206 if (flags & G_EVAL) {
1207 cLOGOP->op_other = op;
1209 /* we're trying to emulate pp_entertry() here */
1211 register PERL_CONTEXT *cx;
1212 I32 gimme = GIMME_V;
1217 push_return(op->op_next);
1218 PUSHBLOCK(cx, CXt_EVAL, stack_sp);
1220 eval_root = op; /* Only needed so that goto works right. */
1223 if (flags & G_KEEPERR)
1238 /* my_exit() was called */
1239 curstash = defstash;
1243 croak("Callback called exit");
1252 stack_sp = stack_base + oldmark;
1253 if (flags & G_ARRAY)
1257 *++stack_sp = &sv_undef;
1265 if (op == (OP*)&myop)
1266 op = pp_entersub(ARGS);
1269 retval = stack_sp - (stack_base + oldmark);
1270 if ((flags & G_EVAL) && !(flags & G_KEEPERR))
1274 if (flags & G_EVAL) {
1275 if (scopestack_ix > oldscope) {
1279 register PERL_CONTEXT *cx;
1291 CATCH_SET(oldcatch);
1293 if (flags & G_DISCARD) {
1294 stack_sp = stack_base + oldmark;
1303 /* Eval a string. The G_EVAL flag is always assumed. */
1306 perl_eval_sv(SV *sv, I32 flags)
1308 /* See G_* flags in cop.h */
1311 UNOP myop; /* fake syntax tree node */
1312 I32 oldmark = SP - stack_base;
1319 if (flags & G_DISCARD) {
1327 EXTEND(stack_sp, 1);
1329 oldscope = scopestack_ix;
1331 if (!(flags & G_NOARGS))
1332 myop.op_flags = OPf_STACKED;
1333 myop.op_next = Nullop;
1334 myop.op_type = OP_ENTEREVAL;
1335 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1336 (flags & G_ARRAY) ? OPf_WANT_LIST :
1338 if (flags & G_KEEPERR)
1339 myop.op_flags |= OPf_SPECIAL;
1349 /* my_exit() was called */
1350 curstash = defstash;
1354 croak("Callback called exit");
1363 stack_sp = stack_base + oldmark;
1364 if (flags & G_ARRAY)
1368 *++stack_sp = &sv_undef;
1373 if (op == (OP*)&myop)
1374 op = pp_entereval(ARGS);
1377 retval = stack_sp - (stack_base + oldmark);
1378 if (!(flags & G_KEEPERR))
1383 if (flags & G_DISCARD) {
1384 stack_sp = stack_base + oldmark;
1394 perl_eval_pv(char *p, I32 croak_on_error)
1397 SV* sv = newSVpv(p, 0);
1400 perl_eval_sv(sv, G_SCALAR);
1407 if (croak_on_error && SvTRUE(ERRSV))
1408 croak(SvPVx(ERRSV, na));
1413 /* Require a module. */
1416 perl_require_pv(char *pv)
1418 SV* sv = sv_newmortal();
1419 sv_setpv(sv, "require '");
1422 perl_eval_sv(sv, G_DISCARD);
1426 magicname(char *sym, char *name, I32 namlen)
1430 if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
1431 sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
1435 usage(char *name) /* XXX move this out into a module ? */
1438 /* This message really ought to be max 23 lines.
1439 * Removed -h because the user already knows that opton. Others? */
1441 static char *usage[] = {
1442 "-0[octal] specify record separator (\\0, if no argument)",
1443 "-a autosplit mode with -n or -p (splits $_ into @F)",
1444 "-c check syntax only (runs BEGIN and END blocks)",
1445 "-d[:debugger] run scripts under debugger",
1446 "-D[number/list] set debugging flags (argument is a bit mask or flags)",
1447 "-e 'command' one line of script. Several -e's allowed. Omit [programfile].",
1448 "-F/pattern/ split() pattern for autosplit (-a). The //'s are optional.",
1449 "-i[extension] edit <> files in place (make backup if extension supplied)",
1450 "-Idirectory specify @INC/#include directory (may be used more than once)",
1451 "-l[octal] enable line ending processing, specifies line terminator",
1452 "-[mM][-]module.. executes `use/no module...' before executing your script.",
1453 "-n assume 'while (<>) { ... }' loop around your script",
1454 "-p assume loop like -n but print line also like sed",
1455 "-P run script through C preprocessor before compilation",
1456 "-s enable some switch parsing for switches after script name",
1457 "-S look for the script using PATH environment variable",
1458 "-T turn on tainting checks",
1459 "-u dump core after parsing script",
1460 "-U allow unsafe operations",
1461 "-v print version number and patchlevel of perl",
1462 "-V[:variable] print perl configuration information",
1463 "-w TURN WARNINGS ON FOR COMPILATION OF YOUR SCRIPT. Recommended.",
1464 "-x[directory] strip off text before #!perl line and perhaps cd to directory",
1470 printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
1472 printf("\n %s", *p++);
1475 /* This routine handles any switches that can be given during run */
1478 moreswitches(char *s)
1487 rschar = scan_oct(s, 4, &numlen);
1489 if (rschar & ~((U8)~0))
1491 else if (!rschar && numlen >= 2)
1492 nrs = newSVpv("", 0);
1495 nrs = newSVpv(&ch, 1);
1501 splitstr = savepv(s + 1);
1515 if (*s == ':' || *s == '=') {
1516 my_setenv("PERL5DB", form("use Devel::%s;", ++s));
1520 perldb = PERLDB_ALL;
1527 if (isALPHA(s[1])) {
1528 static char debopts[] = "psltocPmfrxuLHXD";
1531 for (s++; *s && (d = strchr(debopts,*s)); s++)
1532 debug |= 1 << (d - debopts);
1536 for (s++; isDIGIT(*s); s++) ;
1538 debug |= 0x80000000;
1540 warn("Recompile perl with -DDEBUGGING to use -D switch\n");
1541 for (s++; isALNUM(*s); s++) ;
1551 inplace = savepv(s+1);
1553 for (s = inplace; *s && !isSPACE(*s); s++) ;
1557 case 'I': /* -I handled both here and in parse_perl() */
1560 while (*s && isSPACE(*s))
1564 for (e = s; *e && !isSPACE(*e); e++) ;
1565 p = savepvn(s, e-s);
1571 croak("No space allowed after -I");
1581 *ors = scan_oct(s, 3 + (*s == '0'), &numlen);
1591 ors = SvPV(nrs, orslen);
1592 ors = savepvn(ors, orslen);
1596 forbid_setid("-M"); /* XXX ? */
1599 forbid_setid("-m"); /* XXX ? */
1604 /* -M-foo == 'no foo' */
1605 if (*s == '-') { use = "no "; ++s; }
1606 sv = newSVpv(use,0);
1608 /* We allow -M'Module qw(Foo Bar)' */
1609 while(isALNUM(*s) || *s==':') ++s;
1611 sv_catpv(sv, start);
1612 if (*(start-1) == 'm') {
1614 croak("Can't use '%c' after -mname", *s);
1615 sv_catpv( sv, " ()");
1618 sv_catpvn(sv, start, s-start);
1619 sv_catpv(sv, " split(/,/,q{");
1624 if (preambleav == NULL)
1625 preambleav = newAV();
1626 av_push(preambleav, sv);
1629 croak("No space allowed after -%c", *(s-1));
1646 croak("Too late for \"-T\" option");
1658 #if defined(SUBVERSION) && SUBVERSION > 0
1659 printf("\nThis is perl, version 5.%03d_%02d built for %s",
1660 PATCHLEVEL, SUBVERSION, ARCHNAME);
1662 printf("\nThis is perl, version %s built for %s",
1663 patchlevel, ARCHNAME);
1665 #if defined(LOCAL_PATCH_COUNT)
1666 if (LOCAL_PATCH_COUNT > 0)
1667 printf("\n(with %d registered patch%s, see perl -V for more detail)",
1668 LOCAL_PATCH_COUNT, (LOCAL_PATCH_COUNT!=1) ? "es" : "");
1671 printf("\n\nCopyright 1987-1998, Larry Wall\n");
1673 printf("\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
1676 printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n");
1677 printf("djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1998\n");
1680 printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
1681 "Version 5 port Copyright (c) 1994-1998, Andreas Kaiser, Ilya Zakharevich\n");
1684 printf("atariST series port, ++jrb bammi@cadence.com\n");
1687 Perl may be copied only under the terms of either the Artistic License or the\n\
1688 GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n");
1696 if (s[1] == '-') /* Additional switches on #! line. */
1707 #ifdef ALTERNATE_SHEBANG
1708 case 'S': /* OS/2 needs -S on "extproc" line. */
1716 croak("Can't emulate -%.1s on #! line",s);
1721 /* compliments of Tom Christiansen */
1723 /* unexec() can be found in the Gnu emacs distribution */
1734 prog = newSVpv(BIN_EXP);
1735 sv_catpv(prog, "/perl");
1736 file = newSVpv(origfilename);
1737 sv_catpv(file, ".perldump");
1739 status = unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
1741 PerlIO_printf(PerlIO_stderr(), "unexec of %s into %s failed!\n",
1742 SvPVX(prog), SvPVX(file));
1743 PerlProc_exit(status);
1746 # include <lib$routines.h>
1747 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
1749 ABORT(); /* for use with undump */
1755 init_main_stash(void)
1760 /* Note that strtab is a rather special HV. Assumptions are made
1761 about not iterating on it, and not adding tie magic to it.
1762 It is properly deallocated in perl_destruct() */
1764 HvSHAREKEYS_off(strtab); /* mandatory */
1765 Newz(506,((XPVHV*)SvANY(strtab))->xhv_array,
1766 sizeof(HE*) * (((XPVHV*)SvANY(strtab))->xhv_max + 1), char);
1768 curstash = defstash = newHV();
1769 curstname = newSVpv("main",4);
1770 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
1771 SvREFCNT_dec(GvHV(gv));
1772 GvHV(gv) = (HV*)SvREFCNT_inc(defstash);
1774 HvNAME(defstash) = savepv("main");
1775 incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
1777 defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
1778 errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
1780 (void)form("%240s",""); /* Preallocate temp - for immediate signals. */
1781 sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */
1782 sv_setpvn(ERRSV, "", 0);
1783 curstash = defstash;
1784 compiling.cop_stash = defstash;
1785 debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
1786 globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
1787 /* We must init $/ before switches are processed. */
1788 sv_setpvn(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), "\n", 1);
1792 open_script(char *scriptname, bool dosearch, SV *sv)
1795 char *xfound = Nullch;
1796 char *xfailed = Nullch;
1800 #if defined(DOSISH) && !defined(OS2) && !defined(atarist)
1801 # define SEARCH_EXTS ".bat", ".cmd", NULL
1802 # define MAX_EXT_LEN 4
1805 # define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL
1806 # define MAX_EXT_LEN 4
1809 # define SEARCH_EXTS ".pl", ".com", NULL
1810 # define MAX_EXT_LEN 4
1812 /* additional extensions to try in each dir if scriptname not found */
1814 char *ext[] = { SEARCH_EXTS };
1815 int extidx = 0, i = 0;
1816 char *curext = Nullch;
1818 # define MAX_EXT_LEN 0
1822 * If dosearch is true and if scriptname does not contain path
1823 * delimiters, search the PATH for scriptname.
1825 * If SEARCH_EXTS is also defined, will look for each
1826 * scriptname{SEARCH_EXTS} whenever scriptname is not found
1827 * while searching the PATH.
1829 * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
1830 * proceeds as follows:
1831 * If DOSISH or VMSISH:
1832 * + look for ./scriptname{,.foo,.bar}
1833 * + search the PATH for scriptname{,.foo,.bar}
1836 * + look *only* in the PATH for scriptname{,.foo,.bar} (note
1837 * this will not look in '.' if it's not in the PATH)
1841 # ifdef ALWAYS_DEFTYPES
1842 len = strlen(scriptname);
1843 if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') {
1844 int hasdir, idx = 0, deftypes = 1;
1847 hasdir = !dosearch || (strpbrk(scriptname,":[</") != Nullch) ;
1850 int hasdir, idx = 0, deftypes = 1;
1853 hasdir = (strpbrk(scriptname,":[</") != Nullch) ;
1855 /* The first time through, just add SEARCH_EXTS to whatever we
1856 * already have, so we can check for default file types. */
1858 (!hasdir && my_trnlnm("DCL$PATH",tokenbuf,idx++)) )
1864 if ((strlen(tokenbuf) + strlen(scriptname)
1865 + MAX_EXT_LEN) >= sizeof tokenbuf)
1866 continue; /* don't search dir with too-long name */
1867 strcat(tokenbuf, scriptname);
1871 if (strEQ(scriptname, "-"))
1873 if (dosearch) { /* Look in '.' first. */
1874 char *cur = scriptname;
1876 if ((curext = strrchr(scriptname,'.'))) /* possible current ext */
1878 if (strEQ(ext[i++],curext)) {
1879 extidx = -1; /* already has an ext */
1884 DEBUG_p(PerlIO_printf(Perl_debug_log,
1885 "Looking for %s\n",cur));
1886 if (PerlLIO_stat(cur,&statbuf) >= 0) {
1894 if (cur == scriptname) {
1895 len = strlen(scriptname);
1896 if (len+MAX_EXT_LEN+1 >= sizeof(tokenbuf))
1898 cur = strcpy(tokenbuf, scriptname);
1900 } while (extidx >= 0 && ext[extidx] /* try an extension? */
1901 && strcpy(tokenbuf+len, ext[extidx++]));
1906 if (dosearch && !strchr(scriptname, '/')
1908 && !strchr(scriptname, '\\')
1910 && (s = PerlEnv_getenv("PATH"))) {
1913 bufend = s + strlen(s);
1914 while (s < bufend) {
1915 #if defined(atarist) || defined(DOSISH)
1920 && *s != ';'; len++, s++) {
1921 if (len < sizeof tokenbuf)
1924 if (len < sizeof tokenbuf)
1925 tokenbuf[len] = '\0';
1926 #else /* ! (atarist || DOSISH) */
1927 s = delimcpy(tokenbuf, tokenbuf + sizeof tokenbuf, s, bufend,
1930 #endif /* ! (atarist || DOSISH) */
1933 if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tokenbuf)
1934 continue; /* don't search dir with too-long name */
1936 #if defined(atarist) || defined(DOSISH)
1937 && tokenbuf[len - 1] != '/'
1938 && tokenbuf[len - 1] != '\\'
1941 tokenbuf[len++] = '/';
1942 if (len == 2 && tokenbuf[0] == '.')
1944 (void)strcpy(tokenbuf + len, scriptname);
1948 len = strlen(tokenbuf);
1949 if (extidx > 0) /* reset after previous loop */
1953 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tokenbuf));
1954 retval = PerlLIO_stat(tokenbuf,&statbuf);
1956 } while ( retval < 0 /* not there */
1957 && extidx>=0 && ext[extidx] /* try an extension? */
1958 && strcpy(tokenbuf+len, ext[extidx++])
1963 if (S_ISREG(statbuf.st_mode)
1964 && cando(S_IRUSR,TRUE,&statbuf)
1966 && cando(S_IXUSR,TRUE,&statbuf)
1970 xfound = tokenbuf; /* bingo! */
1974 xfailed = savepv(tokenbuf);
1977 if (!xfound && !seen_dot && !xfailed && (PerlLIO_stat(scriptname,&statbuf) < 0))
1979 seen_dot = 1; /* Disable message. */
1981 croak("Can't %s %s%s%s",
1982 (xfailed ? "execute" : "find"),
1983 (xfailed ? xfailed : scriptname),
1984 (xfailed ? "" : " on PATH"),
1985 (xfailed || seen_dot) ? "" : ", '.' not in PATH");
1988 scriptname = xfound;
1991 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
1992 char *s = scriptname + 8;
2001 origfilename = savepv(e_tmpname ? "-e" : scriptname);
2002 curcop->cop_filegv = gv_fetchfile(origfilename);
2003 if (strEQ(origfilename,"-"))
2005 if (fdscript >= 0) {
2006 rsfp = PerlIO_fdopen(fdscript,PERL_SCRIPT_MODE);
2007 #if defined(HAS_FCNTL) && defined(F_SETFD)
2009 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
2012 else if (preprocess) {
2013 char *cpp_cfg = CPPSTDIN;
2014 SV *cpp = NEWSV(0,0);
2015 SV *cmd = NEWSV(0,0);
2017 if (strEQ(cpp_cfg, "cppstdin"))
2018 sv_catpvf(cpp, "%s/", BIN_EXP);
2019 sv_catpv(cpp, cpp_cfg);
2022 sv_catpv(sv,PRIVLIB_EXP);
2026 sed %s -e \"/^[^#]/b\" \
2027 -e \"/^#[ ]*include[ ]/b\" \
2028 -e \"/^#[ ]*define[ ]/b\" \
2029 -e \"/^#[ ]*if[ ]/b\" \
2030 -e \"/^#[ ]*ifdef[ ]/b\" \
2031 -e \"/^#[ ]*ifndef[ ]/b\" \
2032 -e \"/^#[ ]*else/b\" \
2033 -e \"/^#[ ]*elif[ ]/b\" \
2034 -e \"/^#[ ]*undef[ ]/b\" \
2035 -e \"/^#[ ]*endif/b\" \
2038 (doextract ? "-e \"1,/^#/d\n\"" : ""),
2041 %s %s -e '/^[^#]/b' \
2042 -e '/^#[ ]*include[ ]/b' \
2043 -e '/^#[ ]*define[ ]/b' \
2044 -e '/^#[ ]*if[ ]/b' \
2045 -e '/^#[ ]*ifdef[ ]/b' \
2046 -e '/^#[ ]*ifndef[ ]/b' \
2047 -e '/^#[ ]*else/b' \
2048 -e '/^#[ ]*elif[ ]/b' \
2049 -e '/^#[ ]*undef[ ]/b' \
2050 -e '/^#[ ]*endif/b' \
2058 (doextract ? "-e '1,/^#/d\n'" : ""),
2060 scriptname, cpp, sv, CPPMINUS);
2062 #ifdef IAMSUID /* actually, this is caught earlier */
2063 if (euid != uid && !euid) { /* if running suidperl */
2065 (void)seteuid(uid); /* musn't stay setuid root */
2068 (void)setreuid((Uid_t)-1, uid);
2070 #ifdef HAS_SETRESUID
2071 (void)setresuid((Uid_t)-1, uid, (Uid_t)-1);
2077 if (geteuid() != uid)
2078 croak("Can't do seteuid!\n");
2080 #endif /* IAMSUID */
2081 rsfp = PerlProc_popen(SvPVX(cmd), "r");
2085 else if (!*scriptname) {
2086 forbid_setid("program input from stdin");
2087 rsfp = PerlIO_stdin();
2090 rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
2091 #if defined(HAS_FCNTL) && defined(F_SETFD)
2093 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
2101 #ifndef IAMSUID /* in case script is not readable before setuid */
2102 if (euid && PerlLIO_stat(SvPVX(GvSV(curcop->cop_filegv)),&statbuf) >= 0 &&
2103 statbuf.st_mode & (S_ISUID|S_ISGID)) {
2105 PerlProc_execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
2106 croak("Can't do setuid\n");
2110 croak("Can't open perl script \"%s\": %s\n",
2111 SvPVX(GvSV(curcop->cop_filegv)), Strerror(errno));
2116 validate_suid(char *validarg, char *scriptname)
2120 /* do we need to emulate setuid on scripts? */
2122 /* This code is for those BSD systems that have setuid #! scripts disabled
2123 * in the kernel because of a security problem. Merely defining DOSUID
2124 * in perl will not fix that problem, but if you have disabled setuid
2125 * scripts in the kernel, this will attempt to emulate setuid and setgid
2126 * on scripts that have those now-otherwise-useless bits set. The setuid
2127 * root version must be called suidperl or sperlN.NNN. If regular perl
2128 * discovers that it has opened a setuid script, it calls suidperl with
2129 * the same argv that it had. If suidperl finds that the script it has
2130 * just opened is NOT setuid root, it sets the effective uid back to the
2131 * uid. We don't just make perl setuid root because that loses the
2132 * effective uid we had before invoking perl, if it was different from the
2135 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
2136 * be defined in suidperl only. suidperl must be setuid root. The
2137 * Configure script will set this up for you if you want it.
2144 if (PerlLIO_fstat(PerlIO_fileno(rsfp),&statbuf) < 0) /* normal stat is insecure */
2145 croak("Can't stat script \"%s\"",origfilename);
2146 if (fdscript < 0 && statbuf.st_mode & (S_ISUID|S_ISGID)) {
2150 #ifndef HAS_SETREUID
2151 /* On this access check to make sure the directories are readable,
2152 * there is actually a small window that the user could use to make
2153 * filename point to an accessible directory. So there is a faint
2154 * chance that someone could execute a setuid script down in a
2155 * non-accessible directory. I don't know what to do about that.
2156 * But I don't think it's too important. The manual lies when
2157 * it says access() is useful in setuid programs.
2159 if (PerlLIO_access(SvPVX(GvSV(curcop->cop_filegv)),1)) /*double check*/
2160 croak("Permission denied");
2162 /* If we can swap euid and uid, then we can determine access rights
2163 * with a simple stat of the file, and then compare device and
2164 * inode to make sure we did stat() on the same file we opened.
2165 * Then we just have to make sure he or she can execute it.
2168 struct stat tmpstatbuf;
2172 setreuid(euid,uid) < 0
2175 setresuid(euid,uid,(Uid_t)-1) < 0
2178 || getuid() != euid || geteuid() != uid)
2179 croak("Can't swap uid and euid"); /* really paranoid */
2180 if (PerlLIO_stat(SvPVX(GvSV(curcop->cop_filegv)),&tmpstatbuf) < 0)
2181 croak("Permission denied"); /* testing full pathname here */
2182 if (tmpstatbuf.st_dev != statbuf.st_dev ||
2183 tmpstatbuf.st_ino != statbuf.st_ino) {
2184 (void)PerlIO_close(rsfp);
2185 if (rsfp = PerlProc_popen("/bin/mail root","w")) { /* heh, heh */
2187 "User %ld tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
2188 (Filename of set-id script was %s, uid %ld gid %ld.)\n\nSincerely,\nperl\n",
2189 (long)uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
2190 (long)statbuf.st_dev, (long)statbuf.st_ino,
2191 SvPVX(GvSV(curcop->cop_filegv)),
2192 (long)statbuf.st_uid, (long)statbuf.st_gid);
2193 (void)PerlProc_pclose(rsfp);
2195 croak("Permission denied\n");
2199 setreuid(uid,euid) < 0
2201 # if defined(HAS_SETRESUID)
2202 setresuid(uid,euid,(Uid_t)-1) < 0
2205 || getuid() != uid || geteuid() != euid)
2206 croak("Can't reswap uid and euid");
2207 if (!cando(S_IXUSR,FALSE,&statbuf)) /* can real uid exec? */
2208 croak("Permission denied\n");
2210 #endif /* HAS_SETREUID */
2211 #endif /* IAMSUID */
2213 if (!S_ISREG(statbuf.st_mode))
2214 croak("Permission denied");
2215 if (statbuf.st_mode & S_IWOTH)
2216 croak("Setuid/gid script is writable by world");
2217 doswitches = FALSE; /* -s is insecure in suid */
2219 if (sv_gets(linestr, rsfp, 0) == Nullch ||
2220 strnNE(SvPV(linestr,na),"#!",2) ) /* required even on Sys V */
2221 croak("No #! line");
2222 s = SvPV(linestr,na)+2;
2224 while (!isSPACE(*s)) s++;
2225 for (s2 = s; (s2 > SvPV(linestr,na)+2 &&
2226 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
2227 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
2228 croak("Not a perl script");
2229 while (*s == ' ' || *s == '\t') s++;
2231 * #! arg must be what we saw above. They can invoke it by
2232 * mentioning suidperl explicitly, but they may not add any strange
2233 * arguments beyond what #! says if they do invoke suidperl that way.
2235 len = strlen(validarg);
2236 if (strEQ(validarg," PHOOEY ") ||
2237 strnNE(s,validarg,len) || !isSPACE(s[len]))
2238 croak("Args must match #! line");
2241 if (euid != uid && (statbuf.st_mode & S_ISUID) &&
2242 euid == statbuf.st_uid)
2244 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2245 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2246 #endif /* IAMSUID */
2248 if (euid) { /* oops, we're not the setuid root perl */
2249 (void)PerlIO_close(rsfp);
2252 PerlProc_execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
2254 croak("Can't do setuid\n");
2257 if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid) {
2259 (void)setegid(statbuf.st_gid);
2262 (void)setregid((Gid_t)-1,statbuf.st_gid);
2264 #ifdef HAS_SETRESGID
2265 (void)setresgid((Gid_t)-1,statbuf.st_gid,(Gid_t)-1);
2267 setgid(statbuf.st_gid);
2271 if (getegid() != statbuf.st_gid)
2272 croak("Can't do setegid!\n");
2274 if (statbuf.st_mode & S_ISUID) {
2275 if (statbuf.st_uid != euid)
2277 (void)seteuid(statbuf.st_uid); /* all that for this */
2280 (void)setreuid((Uid_t)-1,statbuf.st_uid);
2282 #ifdef HAS_SETRESUID
2283 (void)setresuid((Uid_t)-1,statbuf.st_uid,(Uid_t)-1);
2285 setuid(statbuf.st_uid);
2289 if (geteuid() != statbuf.st_uid)
2290 croak("Can't do seteuid!\n");
2292 else if (uid) { /* oops, mustn't run as root */
2294 (void)seteuid((Uid_t)uid);
2297 (void)setreuid((Uid_t)-1,(Uid_t)uid);
2299 #ifdef HAS_SETRESUID
2300 (void)setresuid((Uid_t)-1,(Uid_t)uid,(Uid_t)-1);
2306 if (geteuid() != uid)
2307 croak("Can't do seteuid!\n");
2310 if (!cando(S_IXUSR,TRUE,&statbuf))
2311 croak("Permission denied\n"); /* they can't do this */
2314 else if (preprocess)
2315 croak("-P not allowed for setuid/setgid script\n");
2316 else if (fdscript >= 0)
2317 croak("fd script not allowed in suidperl\n");
2319 croak("Script is not setuid/setgid in suidperl\n");
2321 /* We absolutely must clear out any saved ids here, so we */
2322 /* exec the real perl, substituting fd script for scriptname. */
2323 /* (We pass script name as "subdir" of fd, which perl will grok.) */
2324 PerlIO_rewind(rsfp);
2325 PerlLIO_lseek(PerlIO_fileno(rsfp),(Off_t)0,0); /* just in case rewind didn't */
2326 for (which = 1; origargv[which] && origargv[which] != scriptname; which++) ;
2327 if (!origargv[which])
2328 croak("Permission denied");
2329 origargv[which] = savepv(form("/dev/fd/%d/%s",
2330 PerlIO_fileno(rsfp), origargv[which]));
2331 #if defined(HAS_FCNTL) && defined(F_SETFD)
2332 fcntl(PerlIO_fileno(rsfp),F_SETFD,0); /* ensure no close-on-exec */
2334 PerlProc_execv(form("%s/perl%s", BIN_EXP, patchlevel), origargv); /* try again */
2335 croak("Can't do setuid\n");
2336 #endif /* IAMSUID */
2338 if (euid != uid || egid != gid) { /* (suidperl doesn't exist, in fact) */
2339 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
2341 PerlLIO_fstat(PerlIO_fileno(rsfp),&statbuf); /* may be either wrapped or real suid */
2342 if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
2344 (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
2347 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2348 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2349 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
2350 /* not set-id, must be wrapped */
2356 find_beginning(void)
2358 register char *s, *s2;
2360 /* skip forward in input to the real script? */
2364 if ((s = sv_gets(linestr, rsfp, 0)) == Nullch)
2365 croak("No Perl script found in input\n");
2366 if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
2367 PerlIO_ungetc(rsfp, '\n'); /* to keep line count right */
2369 while (*s && !(isSPACE (*s) || *s == '#')) s++;
2371 while (*s == ' ' || *s == '\t') s++;
2373 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
2374 if (strnEQ(s2-4,"perl",4))
2376 while (s = moreswitches(s)) ;
2378 if (cddir && PerlDir_chdir(cddir) < 0)
2379 croak("Can't chdir to %s",cddir);
2387 uid = (int)getuid();
2388 euid = (int)geteuid();
2389 gid = (int)getgid();
2390 egid = (int)getegid();
2395 tainting |= (uid && (euid != uid || egid != gid));
2399 forbid_setid(char *s)
2402 croak("No %s allowed while running setuid", s);
2404 croak("No %s allowed while running setgid", s);
2411 curstash = debstash;
2412 dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
2414 DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
2415 DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
2416 DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
2417 DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
2418 sv_setiv(DBsingle, 0);
2419 DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
2420 sv_setiv(DBtrace, 0);
2421 DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
2422 sv_setiv(DBsignal, 0);
2423 curstash = defstash;
2426 #ifndef STRESS_REALLOC
2427 #define REASONABLE(size) (size)
2429 #define REASONABLE(size) (1) /* unreasonable */
2433 init_stacks(ARGSproto)
2436 mainstack = curstack; /* remember in case we switch stacks */
2437 AvREAL_off(curstack); /* not a real array */
2438 av_extend(curstack,REASONABLE(127));
2440 stack_base = AvARRAY(curstack);
2441 stack_sp = stack_base;
2442 stack_max = stack_base + REASONABLE(127);
2444 /* Use most of 8K. */
2445 cxstack_max = REASONABLE(8192 / sizeof(PERL_CONTEXT) - 2);
2446 New(50,cxstack,cxstack_max + 1,PERL_CONTEXT);
2449 New(50,tmps_stack,REASONABLE(128),SV*);
2452 tmps_max = REASONABLE(128);
2455 * The following stacks almost certainly should be per-interpreter,
2456 * but for now they're not. XXX
2460 markstack_ptr = markstack;
2462 New(54,markstack,REASONABLE(32),I32);
2463 markstack_ptr = markstack;
2464 markstack_max = markstack + REASONABLE(32);
2470 New(54,scopestack,REASONABLE(32),I32);
2472 scopestack_max = REASONABLE(32);
2478 New(54,savestack,REASONABLE(128),ANY);
2480 savestack_max = REASONABLE(128);
2486 New(54,retstack,REASONABLE(16),OP*);
2488 retstack_max = REASONABLE(16);
2499 Safefree(tmps_stack);
2506 static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
2515 subname = newSVpv("main",4);
2519 init_predump_symbols(void)
2525 sv_setpvn(perl_get_sv("\"", TRUE), " ", 1);
2526 stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
2527 GvMULTI_on(stdingv);
2528 IoIFP(GvIOp(stdingv)) = PerlIO_stdin();
2529 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
2531 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(stdingv));
2533 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
2535 IoOFP(GvIOp(tmpgv)) = IoIFP(GvIOp(tmpgv)) = PerlIO_stdout();
2537 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
2539 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(defoutgv));
2541 othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
2542 GvMULTI_on(othergv);
2543 IoOFP(GvIOp(othergv)) = IoIFP(GvIOp(othergv)) = PerlIO_stderr();
2544 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
2546 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(othergv));
2548 statname = NEWSV(66,0); /* last filename we did stat on */
2551 osname = savepv(OSNAME);
2555 init_postdump_symbols(register int argc, register char **argv, register char **env)
2562 argc--,argv++; /* skip name of script */
2564 for (; argc > 0 && **argv == '-'; argc--,argv++) {
2567 if (argv[0][1] == '-') {
2571 if (s = strchr(argv[0], '=')) {
2573 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
2576 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
2579 toptarget = NEWSV(0,0);
2580 sv_upgrade(toptarget, SVt_PVFM);
2581 sv_setpvn(toptarget, "", 0);
2582 bodytarget = NEWSV(0,0);
2583 sv_upgrade(bodytarget, SVt_PVFM);
2584 sv_setpvn(bodytarget, "", 0);
2585 formtarget = bodytarget;
2588 if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
2589 sv_setpv(GvSV(tmpgv),origfilename);
2590 magicname("0", "0", 1);
2592 if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
2593 sv_setpv(GvSV(tmpgv),origargv[0]);
2594 if (argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
2596 (void)gv_AVadd(argvgv);
2597 av_clear(GvAVn(argvgv));
2598 for (; argc > 0; argc--,argv++) {
2599 av_push(GvAVn(argvgv),newSVpv(argv[0],0));
2602 if (envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
2606 hv_magic(hv, envgv, 'E');
2607 #ifndef VMS /* VMS doesn't have environ array */
2608 /* Note that if the supplied env parameter is actually a copy
2609 of the global environ then it may now point to free'd memory
2610 if the environment has been modified since. To avoid this
2611 problem we treat env==NULL as meaning 'use the default'
2616 environ[0] = Nullch;
2617 for (; *env; env++) {
2618 if (!(s = strchr(*env,'=')))
2621 #if defined(WIN32) || defined(MSDOS)
2624 sv = newSVpv(s--,0);
2625 (void)hv_store(hv, *env, s - *env, sv, 0);
2627 #if defined(__BORLANDC__) && defined(USE_WIN32_RTL_ENV)
2628 /* Sins of the RTL. See note in my_setenv(). */
2629 (void)PerlEnv_putenv(savepv(*env));
2633 #ifdef DYNAMIC_ENV_FETCH
2634 HvNAME(hv) = savepv(ENV_HV_NAME);
2638 if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
2639 sv_setiv(GvSV(tmpgv), (IV)getpid());
2648 s = PerlEnv_getenv("PERL5LIB");
2652 incpush(PerlEnv_getenv("PERLLIB"), FALSE);
2654 /* Treat PERL5?LIB as a possible search list logical name -- the
2655 * "natural" VMS idiom for a Unix path string. We allow each
2656 * element to be a set of |-separated directories for compatibility.
2660 if (my_trnlnm("PERL5LIB",buf,0))
2661 do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
2663 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE);
2667 /* Use the ~-expanded versions of APPLLIB (undocumented),
2668 ARCHLIB PRIVLIB SITEARCH and SITELIB
2671 incpush(APPLLIB_EXP, FALSE);
2675 incpush(ARCHLIB_EXP, FALSE);
2678 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
2680 incpush(PRIVLIB_EXP, FALSE);
2683 incpush(SITEARCH_EXP, FALSE);
2686 incpush(SITELIB_EXP, FALSE);
2689 incpush(".", FALSE);
2693 # define PERLLIB_SEP ';'
2696 # define PERLLIB_SEP '|'
2698 # define PERLLIB_SEP ':'
2701 #ifndef PERLLIB_MANGLE
2702 # define PERLLIB_MANGLE(s,n) (s)
2706 incpush(char *p, int addsubdirs)
2708 SV *subdir = Nullsv;
2709 static char *archpat_auto;
2715 subdir = NEWSV(55,0);
2716 if (!archpat_auto) {
2717 STRLEN len = (sizeof(ARCHNAME) + strlen(patchlevel)
2718 + sizeof("//auto"));
2719 New(55, archpat_auto, len, char);
2720 sprintf(archpat_auto, "/%s/%s/auto", ARCHNAME, patchlevel);
2722 for (len = sizeof(ARCHNAME) + 2;
2723 archpat_auto[len] != '\0' && archpat_auto[len] != '/'; len++)
2724 if (archpat_auto[len] == '.') archpat_auto[len] = '_';
2729 /* Break at all separators */
2731 SV *libdir = NEWSV(55,0);
2734 /* skip any consecutive separators */
2735 while ( *p == PERLLIB_SEP ) {
2736 /* Uncomment the next line for PATH semantics */
2737 /* av_push(GvAVn(incgv), newSVpv(".", 1)); */
2741 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
2742 sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
2747 sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
2748 p = Nullch; /* break out */
2752 * BEFORE pushing libdir onto @INC we may first push version- and
2753 * archname-specific sub-directories.
2756 struct stat tmpstatbuf;
2761 if ((unix = tounixspec_ts(SvPV(libdir,na),Nullch)) != Nullch) {
2763 while (unix[len-1] == '/') len--; /* Cosmetic */
2764 sv_usepvn(libdir,unix,len);
2767 PerlIO_printf(PerlIO_stderr(),
2768 "Failed to unixify @INC element \"%s\"\n",
2771 /* .../archname/version if -d .../archname/version/auto */
2772 sv_setsv(subdir, libdir);
2773 sv_catpv(subdir, archpat_auto);
2774 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2775 S_ISDIR(tmpstatbuf.st_mode))
2776 av_push(GvAVn(incgv),
2777 newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2779 /* .../archname if -d .../archname/auto */
2780 sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME),
2781 strlen(patchlevel) + 1, "", 0);
2782 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2783 S_ISDIR(tmpstatbuf.st_mode))
2784 av_push(GvAVn(incgv),
2785 newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2788 /* finally push this lib directory on the end of @INC */
2789 av_push(GvAVn(incgv), libdir);
2792 SvREFCNT_dec(subdir);
2796 static struct perl_thread *
2799 struct perl_thread *thr;
2802 Newz(53, thr, 1, struct perl_thread);
2803 curcop = &compiling;
2804 thr->cvcache = newHV();
2805 thr->threadsv = newAV();
2806 /* thr->threadsvp is set when find_threadsv is called */
2807 thr->specific = newAV();
2808 thr->errhv = newHV();
2809 thr->flags = THRf_R_JOINABLE;
2810 MUTEX_INIT(&thr->mutex);
2811 /* Handcraft thrsv similarly to mess_sv */
2812 New(53, thrsv, 1, SV);
2813 Newz(53, xpv, 1, XPV);
2814 SvFLAGS(thrsv) = SVt_PV;
2815 SvANY(thrsv) = (void*)xpv;
2816 SvREFCNT(thrsv) = 1 << 30; /* practically infinite */
2817 SvPVX(thrsv) = (char*)thr;
2818 SvCUR_set(thrsv, sizeof(thr));
2819 SvLEN_set(thrsv, sizeof(thr));
2820 *SvEND(thrsv) = '\0'; /* in the trailing_nul field */
2822 curcop = &compiling;
2825 MUTEX_LOCK(&threads_mutex);
2830 MUTEX_UNLOCK(&threads_mutex);
2832 #ifdef HAVE_THREAD_INTERN
2833 init_thread_intern(thr);
2836 #ifdef SET_THREAD_SELF
2837 SET_THREAD_SELF(thr);
2839 thr->self = pthread_self();
2840 #endif /* SET_THREAD_SELF */
2844 * These must come after the SET_THR because sv_setpvn does
2845 * SvTAINT and the taint fields require dTHR.
2847 toptarget = NEWSV(0,0);
2848 sv_upgrade(toptarget, SVt_PVFM);
2849 sv_setpvn(toptarget, "", 0);
2850 bodytarget = NEWSV(0,0);
2851 sv_upgrade(bodytarget, SVt_PVFM);
2852 sv_setpvn(bodytarget, "", 0);
2853 formtarget = bodytarget;
2854 thr->errsv = newSVpv("", 0);
2855 (void) find_threadsv("@"); /* Ensure $@ is initialised early */
2858 #endif /* USE_THREADS */
2861 call_list(I32 oldscope, AV *list)
2864 line_t oldline = curcop->cop_line;
2869 while (AvFILL(list) >= 0) {
2870 CV *cv = (CV*)av_shift(list);
2879 perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
2880 (void)SvPV(atsv, len);
2883 curcop = &compiling;
2884 curcop->cop_line = oldline;
2885 if (list == beginav)
2886 sv_catpv(atsv, "BEGIN failed--compilation aborted");
2888 sv_catpv(atsv, "END failed--cleanup aborted");
2889 while (scopestack_ix > oldscope)
2891 croak("%s", SvPVX(atsv));
2899 /* my_exit() was called */
2900 while (scopestack_ix > oldscope)
2903 curstash = defstash;
2905 call_list(oldscope, endav);
2907 curcop = &compiling;
2908 curcop->cop_line = oldline;
2910 if (list == beginav)
2911 croak("BEGIN failed--compilation aborted");
2913 croak("END failed--cleanup aborted");
2919 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
2924 curcop = &compiling;
2925 curcop->cop_line = oldline;
2938 DEBUG_L(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
2939 thr, (unsigned long) status));
2940 #endif /* USE_THREADS */
2949 STATUS_NATIVE_SET(status);
2956 my_failure_exit(void)
2959 if (vaxc$errno & 1) {
2960 if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
2961 STATUS_NATIVE_SET(44);
2964 if (!vaxc$errno && errno) /* unlikely */
2965 STATUS_NATIVE_SET(44);
2967 STATUS_NATIVE_SET(vaxc$errno);
2971 STATUS_POSIX_SET(errno);
2972 else if (STATUS_POSIX == 0)
2973 STATUS_POSIX_SET(255);
2982 register PERL_CONTEXT *cx;
2991 (void)UNLINK(e_tmpname);
2992 Safefree(e_tmpname);
2996 if (cxstack_ix >= 0) {