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);
182 perl_destruct_level = 1;
184 if(perl_destruct_level > 0)
189 lex_state = LEX_NOTPARSING;
191 start_env.je_prev = NULL;
192 start_env.je_ret = -1;
193 start_env.je_mustcatch = TRUE;
194 top_env = &start_env;
197 SET_NUMERIC_STANDARD();
198 #if defined(SUBVERSION) && SUBVERSION > 0
199 sprintf(patchlevel, "%7.5f", (double) 5
200 + ((double) PATCHLEVEL / (double) 1000)
201 + ((double) SUBVERSION / (double) 100000));
203 sprintf(patchlevel, "%5.3f", (double) 5 +
204 ((double) PATCHLEVEL / (double) 1000));
207 #if defined(LOCAL_PATCH_COUNT)
208 localpatches = local_patches; /* For possible -v */
211 PerlIO_init(); /* Hook to IO system */
213 fdpid = newAV(); /* for remembering popen pids by fd */
214 modglobal = newHV(); /* pointers to per-interpreter module globals */
217 New(51,debname,128,char);
218 New(52,debdelim,128,char);
225 perl_destruct(register PerlInterpreter *sv_interp)
228 int destruct_level; /* 0=none, 1=full, 2=full with checks */
233 #endif /* USE_THREADS */
235 if (!(curinterp = sv_interp))
240 /* Pass 1 on any remaining threads: detach joinables, join zombies */
242 MUTEX_LOCK(&threads_mutex);
243 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
244 "perl_destruct: waiting for %d threads...\n",
246 for (t = thr->next; t != thr; t = t->next) {
247 MUTEX_LOCK(&t->mutex);
248 switch (ThrSTATE(t)) {
251 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
252 "perl_destruct: joining zombie %p\n", t));
253 ThrSETSTATE(t, THRf_DEAD);
254 MUTEX_UNLOCK(&t->mutex);
257 * The SvREFCNT_dec below may take a long time (e.g. av
258 * may contain an object scalar whose destructor gets
259 * called) so we have to unlock threads_mutex and start
262 MUTEX_UNLOCK(&threads_mutex);
264 SvREFCNT_dec((SV*)av);
265 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
266 "perl_destruct: joined zombie %p OK\n", t));
268 case THRf_R_JOINABLE:
269 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
270 "perl_destruct: detaching thread %p\n", t));
271 ThrSETSTATE(t, THRf_R_DETACHED);
273 * We unlock threads_mutex and t->mutex in the opposite order
274 * from which we locked them just so that DETACH won't
275 * deadlock if it panics. It's only a breach of good style
276 * not a bug since they are unlocks not locks.
278 MUTEX_UNLOCK(&threads_mutex);
280 MUTEX_UNLOCK(&t->mutex);
283 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
284 "perl_destruct: ignoring %p (state %u)\n",
286 MUTEX_UNLOCK(&t->mutex);
287 /* fall through and out */
290 /* We leave the above "Pass 1" loop with threads_mutex still locked */
292 /* Pass 2 on remaining threads: wait for the thread count to drop to one */
295 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
296 "perl_destruct: final wait for %d threads\n",
298 COND_WAIT(&nthreads_cond, &threads_mutex);
300 /* At this point, we're the last thread */
301 MUTEX_UNLOCK(&threads_mutex);
302 DEBUG_L(PerlIO_printf(PerlIO_stderr(), "perl_destruct: armageddon has arrived\n"));
303 MUTEX_DESTROY(&threads_mutex);
304 COND_DESTROY(&nthreads_cond);
305 #endif /* !defined(FAKE_THREADS) */
306 #endif /* USE_THREADS */
308 destruct_level = perl_destruct_level;
312 if (s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL")) {
314 if (destruct_level < i)
323 /* We must account for everything. */
325 /* Destroy the main CV and syntax tree */
327 curpad = AvARRAY(comppad);
333 SvREFCNT_dec(main_cv);
338 * Try to destruct global references. We do this first so that the
339 * destructors and destructees still exist. Some sv's might remain.
340 * Non-referenced objects are on their own.
347 /* unhook hooks which will soon be, or use, destroyed data */
348 SvREFCNT_dec(warnhook);
350 SvREFCNT_dec(diehook);
352 SvREFCNT_dec(parsehook);
355 /* call exit list functions */
356 while (exitlistlen-- > 0)
357 exitlist[exitlistlen].fn(exitlist[exitlistlen].ptr);
361 if (destruct_level == 0){
363 DEBUG_P(debprofdump());
365 /* The exit() function will do everything that needs doing. */
369 /* loosen bonds of global variables */
372 (void)PerlIO_close(rsfp);
376 /* Filters for program text */
377 SvREFCNT_dec(rsfp_filters);
378 rsfp_filters = Nullav;
390 sawampersand = FALSE; /* must save all match strings */
391 sawstudy = FALSE; /* do fbm_instr on all strings */
406 /* magical thingies */
408 Safefree(ofs); /* $, */
411 Safefree(ors); /* $\ */
414 SvREFCNT_dec(nrs); /* $\ helper */
417 multiline = 0; /* $* */
419 SvREFCNT_dec(statname);
423 /* defgv, aka *_ should be taken care of elsewhere */
425 /* clean up after study() */
426 SvREFCNT_dec(lastscream);
428 Safefree(screamfirst);
430 Safefree(screamnext);
433 /* startup and shutdown function lists */
434 SvREFCNT_dec(beginav);
436 SvREFCNT_dec(initav);
441 /* shortcuts just get cleared */
451 /* reset so print() ends up where we expect */
454 /* Prepare to destruct main symbol table. */
461 if (destruct_level >= 2) {
462 if (scopestack_ix != 0)
463 warn("Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
464 (long)scopestack_ix);
465 if (savestack_ix != 0)
466 warn("Unbalanced saves: %ld more saves than restores\n",
468 if (tmps_floor != -1)
469 warn("Unbalanced tmps: %ld more allocs than frees\n",
470 (long)tmps_floor + 1);
471 if (cxstack_ix != -1)
472 warn("Unbalanced context: %ld more PUSHes than POPs\n",
473 (long)cxstack_ix + 1);
476 /* Now absolutely destruct everything, somehow or other, loops or no. */
478 SvFLAGS(strtab) |= SVTYPEMASK; /* don't clean out strtab now */
479 while (sv_count != 0 && sv_count != last_sv_count) {
480 last_sv_count = sv_count;
483 SvFLAGS(strtab) &= ~SVTYPEMASK;
484 SvFLAGS(strtab) |= SVt_PVHV;
486 /* Destruct the global string table. */
488 /* Yell and reset the HeVAL() slots that are still holding refcounts,
489 * so that sv_free() won't fail on them.
498 array = HvARRAY(strtab);
502 warn("Unbalanced string table refcount: (%d) for \"%s\"",
503 HeVAL(hent) - Nullsv, HeKEY(hent));
504 HeVAL(hent) = Nullsv;
514 SvREFCNT_dec(strtab);
517 warn("Scalars leaked: %ld\n", (long)sv_count);
521 /* No SVs have survived, need to clean out */
525 Safefree(origfilename);
527 hints = 0; /* Reset hints. Should hints be per-interpreter ? */
529 DEBUG_P(debprofdump());
531 MUTEX_DESTROY(&sv_mutex);
532 MUTEX_DESTROY(&eval_mutex);
533 COND_DESTROY(&eval_cond);
535 /* As the penultimate thing, free the non-arena SV for thrsv */
536 Safefree(SvPVX(thrsv));
537 Safefree(SvANY(thrsv));
540 #endif /* USE_THREADS */
542 /* As the absolutely last thing, free the non-arena SV for mess() */
545 /* we know that type >= SVt_PV */
547 Safefree(SvPVX(mess_sv));
548 Safefree(SvANY(mess_sv));
555 perl_free(PerlInterpreter *sv_interp)
557 if (!(curinterp = sv_interp))
563 perl_atexit(void (*fn) (void *), void *ptr)
565 Renew(exitlist, exitlistlen+1, PerlExitListEntry);
566 exitlist[exitlistlen].fn = fn;
567 exitlist[exitlistlen].ptr = ptr;
572 perl_parse(PerlInterpreter *sv_interp, void (*xsinit) (void), int argc, char **argv, char **env)
577 char *scriptname = NULL;
578 VOL bool dosearch = FALSE;
586 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
589 croak("suidperl is no longer needed since the kernel can now execute\n\
590 setuid perl scripts securely.\n");
594 if (!(curinterp = sv_interp))
597 #if defined(NeXT) && defined(__DYNAMIC__)
598 _dyld_lookup_and_bind
599 ("__environ", (unsigned long *) &environ_pointer, NULL);
604 #ifndef VMS /* VMS doesn't have environ array */
605 origenviron = environ;
611 /* Come here if running an undumped a.out. */
613 origfilename = savepv(argv[0]);
615 cxstack_ix = -1; /* start label stack again */
617 init_postdump_symbols(argc,argv,env);
622 curpad = AvARRAY(comppad);
627 SvREFCNT_dec(main_cv);
631 oldscope = scopestack_ix;
639 /* my_exit() was called */
640 while (scopestack_ix > oldscope)
645 call_list(oldscope, endav);
647 return STATUS_NATIVE_EXPORT;
650 PerlIO_printf(PerlIO_stderr(), "panic: top_env\n");
654 sv_setpvn(linestr,"",0);
655 sv = newSVpv("",0); /* first used for -I flags */
659 for (argc--,argv++; argc > 0; argc--,argv++) {
660 if (argv[0][0] != '-' || !argv[0][1])
664 validarg = " PHOOEY ";
689 if (s = moreswitches(s))
699 if (euid != uid || egid != gid)
700 croak("No -e allowed in setuid scripts");
703 int oldumask = PerlLIO_umask(0177);
705 e_tmpname = savepv(TMPPATH);
707 e_tmpfd = PerlLIO_mkstemp(e_tmpname);
708 #else /* use mktemp() */
709 (void)PerlLIO_mktemp(e_tmpname);
711 croak("Cannot generate temporary filename");
712 # if defined(HAS_OPEN3) && defined(O_EXCL)
713 e_tmpfd = open(e_tmpname,
714 O_WRONLY | O_CREAT | O_EXCL,
717 (void)UNLINK(e_tmpname);
718 /* Yes, potential race. But at least we can say we tried. */
719 e_fp = PerlIO_open(e_tmpname,"w");
721 #endif /* ifdef HAS_MKSTEMP */
722 #if defined(HAS_MKSTEMP) || (defined(HAS_OPEN3) && defined(O_EXCL))
724 croak("Cannot create temporary file \"%s\"", e_tmpname);
725 e_fp = PerlIO_fdopen(e_tmpfd,"w");
728 croak("Cannot create temporary file \"%s\"", e_tmpname);
730 (void)PerlLIO_umask(oldumask);
736 PerlIO_puts(e_fp,argv[1]);
740 croak("No code specified for -e");
741 (void)PerlIO_putc(e_fp,'\n');
743 case 'I': /* -I handled both here and in moreswitches() */
745 if (!*++s && (s=argv[1]) != Nullch) {
748 while (s && isSPACE(*s))
752 for (e = s; *e && !isSPACE(*e); e++) ;
759 } /* XXX else croak? */
773 preambleav = newAV();
774 av_push(preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
776 Sv = newSVpv("print myconfig();",0);
778 sv_catpv(Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
780 sv_catpv(Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
782 #if defined(DEBUGGING) || defined(NO_EMBED) || defined(MULTIPLICITY)
783 sv_catpv(Sv,"\" Compile-time options:");
785 sv_catpv(Sv," DEBUGGING");
788 sv_catpv(Sv," NO_EMBED");
791 sv_catpv(Sv," MULTIPLICITY");
793 sv_catpv(Sv,"\\n\",");
795 #if defined(LOCAL_PATCH_COUNT)
796 if (LOCAL_PATCH_COUNT > 0) {
798 sv_catpv(Sv,"\" Locally applied patches:\\n\",");
799 for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
801 sv_catpvf(Sv,"\" \\t%s\\n\",",localpatches[i]);
805 sv_catpvf(Sv,"\" Built under %s\\n\"",OSNAME);
808 sv_catpvf(Sv,",\" Compiled at %s %s\\n\"",__DATE__,__TIME__);
810 sv_catpvf(Sv,",\" Compiled on %s\\n\"",__DATE__);
815 @env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; \
816 print \" \\%ENV:\\n @env\\n\" if @env; \
817 print \" \\@INC:\\n @INC\\n\";");
820 Sv = newSVpv("config_vars(qw(",0);
825 av_push(preambleav, Sv);
826 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
837 if (!*++s || isSPACE(*s)) {
841 /* catch use of gnu style long options */
842 if (strEQ(s, "version")) {
846 if (strEQ(s, "help")) {
853 croak("Unrecognized switch: -%s (-h will show valid options)",s);
858 if (!tainting && (s = PerlEnv_getenv("PERL5OPT"))) {
869 if (!strchr("DIMUdmw", *s))
870 croak("Illegal switch in PERL5OPT: -%c", *s);
876 scriptname = argv[0];
878 if (PerlIO_flush(e_fp) || PerlIO_error(e_fp) || PerlIO_close(e_fp)) {
880 warn("Did you forget to compile with -DMULTIPLICITY?");
882 croak("Can't write to temp file for -e: %s", Strerror(errno));
886 scriptname = e_tmpname;
888 else if (scriptname == Nullch) {
890 if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) )
898 open_script(scriptname,dosearch,sv);
900 validate_suid(validarg, scriptname);
905 main_cv = compcv = (CV*)NEWSV(1104,0);
906 sv_upgrade((SV *)compcv, SVt_PVCV);
910 av_push(comppad, Nullsv);
911 curpad = AvARRAY(comppad);
912 comppad_name = newAV();
913 comppad_name_fill = 0;
914 min_intro_pending = 0;
917 av_store(comppad_name, 0, newSVpv("@_", 2));
918 curpad[0] = (SV*)newAV();
919 SvPADMY_on(curpad[0]); /* XXX Needed? */
921 New(666, CvMUTEXP(compcv), 1, perl_mutex);
922 MUTEX_INIT(CvMUTEXP(compcv));
923 #endif /* USE_THREADS */
925 comppadlist = newAV();
926 AvREAL_off(comppadlist);
927 av_store(comppadlist, 0, (SV*)comppad_name);
928 av_store(comppadlist, 1, (SV*)comppad);
929 CvPADLIST(compcv) = comppadlist;
931 boot_core_UNIVERSAL();
933 (*xsinit)(); /* in case linked C routines want magical variables */
934 #if defined(VMS) || defined(WIN32) || defined(DJGPP)
938 init_predump_symbols();
940 init_postdump_symbols(argc,argv,env);
944 /* now parse the script */
946 SETERRNO(0,SS$_NORMAL);
948 if (yyparse() || error_count) {
950 croak("%s had compilation errors.\n", origfilename);
952 croak("Execution of %s aborted due to compilation errors.\n",
956 curcop->cop_line = 0;
960 (void)UNLINK(e_tmpname);
966 /* now that script is parsed, we can modify record separator */
968 rs = SvREFCNT_inc(nrs);
969 sv_setsv(perl_get_sv("/", TRUE), rs);
980 if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
981 dump_mstats("after compilation:");
991 perl_run(PerlInterpreter *sv_interp)
998 if (!(curinterp = sv_interp))
1001 oldscope = scopestack_ix;
1006 cxstack_ix = -1; /* start context stack again */
1009 /* my_exit() was called */
1010 while (scopestack_ix > oldscope)
1013 curstash = defstash;
1015 call_list(oldscope, endav);
1017 if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
1018 dump_mstats("after execution: ");
1021 return STATUS_NATIVE_EXPORT;
1024 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
1029 POPSTACK_TO(mainstack);
1033 DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
1034 sawampersand ? "Enabling" : "Omitting"));
1037 DEBUG_x(dump_all());
1038 DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
1040 DEBUG_L(PerlIO_printf(Perl_debug_log, "main thread is 0x%lx\n",
1041 (unsigned long) thr));
1042 #endif /* USE_THREADS */
1045 PerlIO_printf(PerlIO_stderr(), "%s syntax OK\n", origfilename);
1048 if (PERLDB_SINGLE && DBsingle)
1049 sv_setiv(DBsingle, 1);
1051 call_list(oldscope, initav);
1061 else if (main_start) {
1062 CvDEPTH(main_cv) = 1;
1073 perl_get_sv(char *name, I32 create)
1077 if (name[1] == '\0' && !isALPHA(name[0])) {
1078 PADOFFSET tmp = find_threadsv(name);
1079 if (tmp != NOT_IN_PAD) {
1081 return THREADSV(tmp);
1084 #endif /* USE_THREADS */
1085 gv = gv_fetchpv(name, create, SVt_PV);
1092 perl_get_av(char *name, I32 create)
1094 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
1103 perl_get_hv(char *name, I32 create)
1105 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
1114 perl_get_cv(char *name, I32 create)
1116 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
1117 if (create && !GvCVu(gv))
1118 return newSUB(start_subparse(FALSE, 0),
1119 newSVOP(OP_CONST, 0, newSVpv(name,0)),
1127 /* Be sure to refetch the stack pointer after calling these routines. */
1130 perl_call_argv(char *sub_name, I32 flags, register char **argv)
1132 /* See G_* flags in cop.h */
1133 /* null terminated arg list */
1140 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
1145 return perl_call_pv(sub_name, flags);
1149 perl_call_pv(char *sub_name, I32 flags)
1150 /* name of the subroutine */
1151 /* See G_* flags in cop.h */
1153 return perl_call_sv((SV*)perl_get_cv(sub_name, TRUE), flags);
1157 perl_call_method(char *methname, I32 flags)
1158 /* name of the subroutine */
1159 /* See G_* flags in cop.h */
1165 XPUSHs(sv_2mortal(newSVpv(methname,0)));
1168 return perl_call_sv(*stack_sp--, flags);
1171 /* May be called with any of a CV, a GV, or an SV containing the name. */
1173 perl_call_sv(SV *sv, I32 flags)
1175 /* See G_* flags in cop.h */
1178 LOGOP myop; /* fake syntax tree node */
1183 bool oldcatch = CATCH_GET;
1188 if (flags & G_DISCARD) {
1193 Zero(&myop, 1, LOGOP);
1194 myop.op_next = Nullop;
1195 if (!(flags & G_NOARGS))
1196 myop.op_flags |= OPf_STACKED;
1197 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1198 (flags & G_ARRAY) ? OPf_WANT_LIST :
1203 EXTEND(stack_sp, 1);
1206 oldscope = scopestack_ix;
1208 if (PERLDB_SUB && curstash != debstash
1209 /* Handle first BEGIN of -d. */
1210 && (DBcv || (DBcv = GvCV(DBsub)))
1211 /* Try harder, since this may have been a sighandler, thus
1212 * curstash may be meaningless. */
1213 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != debstash))
1214 op->op_private |= OPpENTERSUB_DB;
1216 if (flags & G_EVAL) {
1217 cLOGOP->op_other = op;
1219 /* we're trying to emulate pp_entertry() here */
1221 register PERL_CONTEXT *cx;
1222 I32 gimme = GIMME_V;
1227 push_return(op->op_next);
1228 PUSHBLOCK(cx, CXt_EVAL, stack_sp);
1230 eval_root = op; /* Only needed so that goto works right. */
1233 if (flags & G_KEEPERR)
1248 /* my_exit() was called */
1249 curstash = defstash;
1253 croak("Callback called exit");
1262 stack_sp = stack_base + oldmark;
1263 if (flags & G_ARRAY)
1267 *++stack_sp = &sv_undef;
1275 if (op == (OP*)&myop)
1276 op = pp_entersub(ARGS);
1279 retval = stack_sp - (stack_base + oldmark);
1280 if ((flags & G_EVAL) && !(flags & G_KEEPERR))
1284 if (flags & G_EVAL) {
1285 if (scopestack_ix > oldscope) {
1289 register PERL_CONTEXT *cx;
1301 CATCH_SET(oldcatch);
1303 if (flags & G_DISCARD) {
1304 stack_sp = stack_base + oldmark;
1313 /* Eval a string. The G_EVAL flag is always assumed. */
1316 perl_eval_sv(SV *sv, I32 flags)
1318 /* See G_* flags in cop.h */
1321 UNOP myop; /* fake syntax tree node */
1322 I32 oldmark = SP - stack_base;
1329 if (flags & G_DISCARD) {
1337 EXTEND(stack_sp, 1);
1339 oldscope = scopestack_ix;
1341 if (!(flags & G_NOARGS))
1342 myop.op_flags = OPf_STACKED;
1343 myop.op_next = Nullop;
1344 myop.op_type = OP_ENTEREVAL;
1345 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1346 (flags & G_ARRAY) ? OPf_WANT_LIST :
1348 if (flags & G_KEEPERR)
1349 myop.op_flags |= OPf_SPECIAL;
1359 /* my_exit() was called */
1360 curstash = defstash;
1364 croak("Callback called exit");
1373 stack_sp = stack_base + oldmark;
1374 if (flags & G_ARRAY)
1378 *++stack_sp = &sv_undef;
1383 if (op == (OP*)&myop)
1384 op = pp_entereval(ARGS);
1387 retval = stack_sp - (stack_base + oldmark);
1388 if (!(flags & G_KEEPERR))
1393 if (flags & G_DISCARD) {
1394 stack_sp = stack_base + oldmark;
1404 perl_eval_pv(char *p, I32 croak_on_error)
1407 SV* sv = newSVpv(p, 0);
1410 perl_eval_sv(sv, G_SCALAR);
1417 if (croak_on_error && SvTRUE(ERRSV))
1418 croak(SvPVx(ERRSV, na));
1423 /* Require a module. */
1426 perl_require_pv(char *pv)
1428 SV* sv = sv_newmortal();
1429 sv_setpv(sv, "require '");
1432 perl_eval_sv(sv, G_DISCARD);
1436 magicname(char *sym, char *name, I32 namlen)
1440 if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
1441 sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
1445 usage(char *name) /* XXX move this out into a module ? */
1448 /* This message really ought to be max 23 lines.
1449 * Removed -h because the user already knows that opton. Others? */
1451 static char *usage[] = {
1452 "-0[octal] specify record separator (\\0, if no argument)",
1453 "-a autosplit mode with -n or -p (splits $_ into @F)",
1454 "-c check syntax only (runs BEGIN and END blocks)",
1455 "-d[:debugger] run scripts under debugger",
1456 "-D[number/list] set debugging flags (argument is a bit mask or flags)",
1457 "-e 'command' one line of script. Several -e's allowed. Omit [programfile].",
1458 "-F/pattern/ split() pattern for autosplit (-a). The //'s are optional.",
1459 "-i[extension] edit <> files in place (make backup if extension supplied)",
1460 "-Idirectory specify @INC/#include directory (may be used more than once)",
1461 "-l[octal] enable line ending processing, specifies line terminator",
1462 "-[mM][-]module.. executes `use/no module...' before executing your script.",
1463 "-n assume 'while (<>) { ... }' loop around your script",
1464 "-p assume loop like -n but print line also like sed",
1465 "-P run script through C preprocessor before compilation",
1466 "-s enable some switch parsing for switches after script name",
1467 "-S look for the script using PATH environment variable",
1468 "-T turn on tainting checks",
1469 "-u dump core after parsing script",
1470 "-U allow unsafe operations",
1471 "-v print version number and patchlevel of perl",
1472 "-V[:variable] print perl configuration information",
1473 "-w TURN WARNINGS ON FOR COMPILATION OF YOUR SCRIPT. Recommended.",
1474 "-x[directory] strip off text before #!perl line and perhaps cd to directory",
1480 printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
1482 printf("\n %s", *p++);
1485 /* This routine handles any switches that can be given during run */
1488 moreswitches(char *s)
1497 rschar = scan_oct(s, 4, &numlen);
1499 if (rschar & ~((U8)~0))
1501 else if (!rschar && numlen >= 2)
1502 nrs = newSVpv("", 0);
1505 nrs = newSVpv(&ch, 1);
1511 splitstr = savepv(s + 1);
1525 if (*s == ':' || *s == '=') {
1526 my_setenv("PERL5DB", form("use Devel::%s;", ++s));
1530 perldb = PERLDB_ALL;
1537 if (isALPHA(s[1])) {
1538 static char debopts[] = "psltocPmfrxuLHXD";
1541 for (s++; *s && (d = strchr(debopts,*s)); s++)
1542 debug |= 1 << (d - debopts);
1546 for (s++; isDIGIT(*s); s++) ;
1548 debug |= 0x80000000;
1550 warn("Recompile perl with -DDEBUGGING to use -D switch\n");
1551 for (s++; isALNUM(*s); s++) ;
1561 inplace = savepv(s+1);
1563 for (s = inplace; *s && !isSPACE(*s); s++) ;
1567 case 'I': /* -I handled both here and in parse_perl() */
1570 while (*s && isSPACE(*s))
1574 for (e = s; *e && !isSPACE(*e); e++) ;
1575 p = savepvn(s, e-s);
1581 croak("No space allowed after -I");
1591 *ors = scan_oct(s, 3 + (*s == '0'), &numlen);
1601 ors = SvPV(nrs, orslen);
1602 ors = savepvn(ors, orslen);
1606 forbid_setid("-M"); /* XXX ? */
1609 forbid_setid("-m"); /* XXX ? */
1614 /* -M-foo == 'no foo' */
1615 if (*s == '-') { use = "no "; ++s; }
1616 sv = newSVpv(use,0);
1618 /* We allow -M'Module qw(Foo Bar)' */
1619 while(isALNUM(*s) || *s==':') ++s;
1621 sv_catpv(sv, start);
1622 if (*(start-1) == 'm') {
1624 croak("Can't use '%c' after -mname", *s);
1625 sv_catpv( sv, " ()");
1628 sv_catpvn(sv, start, s-start);
1629 sv_catpv(sv, " split(/,/,q{");
1634 if (preambleav == NULL)
1635 preambleav = newAV();
1636 av_push(preambleav, sv);
1639 croak("No space allowed after -%c", *(s-1));
1656 croak("Too late for \"-T\" option");
1668 #if defined(SUBVERSION) && SUBVERSION > 0
1669 printf("\nThis is perl, version 5.%03d_%02d built for %s",
1670 PATCHLEVEL, SUBVERSION, ARCHNAME);
1672 printf("\nThis is perl, version %s built for %s",
1673 patchlevel, ARCHNAME);
1675 #if defined(LOCAL_PATCH_COUNT)
1676 if (LOCAL_PATCH_COUNT > 0)
1677 printf("\n(with %d registered patch%s, see perl -V for more detail)",
1678 LOCAL_PATCH_COUNT, (LOCAL_PATCH_COUNT!=1) ? "es" : "");
1681 printf("\n\nCopyright 1987-1998, Larry Wall\n");
1683 printf("\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
1686 printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n");
1687 printf("djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1998\n");
1690 printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
1691 "Version 5 port Copyright (c) 1994-1998, Andreas Kaiser, Ilya Zakharevich\n");
1694 printf("atariST series port, ++jrb bammi@cadence.com\n");
1697 Perl may be copied only under the terms of either the Artistic License or the\n\
1698 GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n");
1706 if (s[1] == '-') /* Additional switches on #! line. */
1717 #ifdef ALTERNATE_SHEBANG
1718 case 'S': /* OS/2 needs -S on "extproc" line. */
1726 croak("Can't emulate -%.1s on #! line",s);
1731 /* compliments of Tom Christiansen */
1733 /* unexec() can be found in the Gnu emacs distribution */
1744 prog = newSVpv(BIN_EXP);
1745 sv_catpv(prog, "/perl");
1746 file = newSVpv(origfilename);
1747 sv_catpv(file, ".perldump");
1749 status = unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
1751 PerlIO_printf(PerlIO_stderr(), "unexec of %s into %s failed!\n",
1752 SvPVX(prog), SvPVX(file));
1753 PerlProc_exit(status);
1756 # include <lib$routines.h>
1757 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
1759 ABORT(); /* for use with undump */
1765 init_main_stash(void)
1770 /* Note that strtab is a rather special HV. Assumptions are made
1771 about not iterating on it, and not adding tie magic to it.
1772 It is properly deallocated in perl_destruct() */
1774 HvSHAREKEYS_off(strtab); /* mandatory */
1775 Newz(506,((XPVHV*)SvANY(strtab))->xhv_array,
1776 sizeof(HE*) * (((XPVHV*)SvANY(strtab))->xhv_max + 1), char);
1778 curstash = defstash = newHV();
1779 curstname = newSVpv("main",4);
1780 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
1781 SvREFCNT_dec(GvHV(gv));
1782 GvHV(gv) = (HV*)SvREFCNT_inc(defstash);
1784 HvNAME(defstash) = savepv("main");
1785 incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
1787 defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
1788 errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
1790 (void)form("%240s",""); /* Preallocate temp - for immediate signals. */
1791 sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */
1792 sv_setpvn(ERRSV, "", 0);
1793 curstash = defstash;
1794 compiling.cop_stash = defstash;
1795 debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
1796 globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
1797 /* We must init $/ before switches are processed. */
1798 sv_setpvn(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), "\n", 1);
1802 open_script(char *scriptname, bool dosearch, SV *sv)
1805 char *xfound = Nullch;
1806 char *xfailed = Nullch;
1810 #if defined(DOSISH) && !defined(OS2) && !defined(atarist)
1811 # define SEARCH_EXTS ".bat", ".cmd", NULL
1812 # define MAX_EXT_LEN 4
1815 # define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL
1816 # define MAX_EXT_LEN 4
1819 # define SEARCH_EXTS ".pl", ".com", NULL
1820 # define MAX_EXT_LEN 4
1822 /* additional extensions to try in each dir if scriptname not found */
1824 char *ext[] = { SEARCH_EXTS };
1825 int extidx = 0, i = 0;
1826 char *curext = Nullch;
1828 # define MAX_EXT_LEN 0
1832 * If dosearch is true and if scriptname does not contain path
1833 * delimiters, search the PATH for scriptname.
1835 * If SEARCH_EXTS is also defined, will look for each
1836 * scriptname{SEARCH_EXTS} whenever scriptname is not found
1837 * while searching the PATH.
1839 * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
1840 * proceeds as follows:
1841 * If DOSISH or VMSISH:
1842 * + look for ./scriptname{,.foo,.bar}
1843 * + search the PATH for scriptname{,.foo,.bar}
1846 * + look *only* in the PATH for scriptname{,.foo,.bar} (note
1847 * this will not look in '.' if it's not in the PATH)
1851 # ifdef ALWAYS_DEFTYPES
1852 len = strlen(scriptname);
1853 if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') {
1854 int hasdir, idx = 0, deftypes = 1;
1857 hasdir = !dosearch || (strpbrk(scriptname,":[</") != Nullch) ;
1860 int hasdir, idx = 0, deftypes = 1;
1863 hasdir = (strpbrk(scriptname,":[</") != Nullch) ;
1865 /* The first time through, just add SEARCH_EXTS to whatever we
1866 * already have, so we can check for default file types. */
1868 (!hasdir && my_trnlnm("DCL$PATH",tokenbuf,idx++)) )
1874 if ((strlen(tokenbuf) + strlen(scriptname)
1875 + MAX_EXT_LEN) >= sizeof tokenbuf)
1876 continue; /* don't search dir with too-long name */
1877 strcat(tokenbuf, scriptname);
1881 if (strEQ(scriptname, "-"))
1883 if (dosearch) { /* Look in '.' first. */
1884 char *cur = scriptname;
1886 if ((curext = strrchr(scriptname,'.'))) /* possible current ext */
1888 if (strEQ(ext[i++],curext)) {
1889 extidx = -1; /* already has an ext */
1894 DEBUG_p(PerlIO_printf(Perl_debug_log,
1895 "Looking for %s\n",cur));
1896 if (PerlLIO_stat(cur,&statbuf) >= 0) {
1904 if (cur == scriptname) {
1905 len = strlen(scriptname);
1906 if (len+MAX_EXT_LEN+1 >= sizeof(tokenbuf))
1908 cur = strcpy(tokenbuf, scriptname);
1910 } while (extidx >= 0 && ext[extidx] /* try an extension? */
1911 && strcpy(tokenbuf+len, ext[extidx++]));
1916 if (dosearch && !strchr(scriptname, '/')
1918 && !strchr(scriptname, '\\')
1920 && (s = PerlEnv_getenv("PATH"))) {
1923 bufend = s + strlen(s);
1924 while (s < bufend) {
1925 #if defined(atarist) || defined(DOSISH)
1930 && *s != ';'; len++, s++) {
1931 if (len < sizeof tokenbuf)
1934 if (len < sizeof tokenbuf)
1935 tokenbuf[len] = '\0';
1936 #else /* ! (atarist || DOSISH) */
1937 s = delimcpy(tokenbuf, tokenbuf + sizeof tokenbuf, s, bufend,
1940 #endif /* ! (atarist || DOSISH) */
1943 if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tokenbuf)
1944 continue; /* don't search dir with too-long name */
1946 #if defined(atarist) || defined(DOSISH)
1947 && tokenbuf[len - 1] != '/'
1948 && tokenbuf[len - 1] != '\\'
1951 tokenbuf[len++] = '/';
1952 if (len == 2 && tokenbuf[0] == '.')
1954 (void)strcpy(tokenbuf + len, scriptname);
1958 len = strlen(tokenbuf);
1959 if (extidx > 0) /* reset after previous loop */
1963 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tokenbuf));
1964 retval = PerlLIO_stat(tokenbuf,&statbuf);
1966 } while ( retval < 0 /* not there */
1967 && extidx>=0 && ext[extidx] /* try an extension? */
1968 && strcpy(tokenbuf+len, ext[extidx++])
1973 if (S_ISREG(statbuf.st_mode)
1974 && cando(S_IRUSR,TRUE,&statbuf)
1976 && cando(S_IXUSR,TRUE,&statbuf)
1980 xfound = tokenbuf; /* bingo! */
1984 xfailed = savepv(tokenbuf);
1987 if (!xfound && !seen_dot && !xfailed && (PerlLIO_stat(scriptname,&statbuf) < 0))
1989 seen_dot = 1; /* Disable message. */
1991 croak("Can't %s %s%s%s",
1992 (xfailed ? "execute" : "find"),
1993 (xfailed ? xfailed : scriptname),
1994 (xfailed ? "" : " on PATH"),
1995 (xfailed || seen_dot) ? "" : ", '.' not in PATH");
1998 scriptname = xfound;
2001 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
2002 char *s = scriptname + 8;
2011 origfilename = savepv(e_tmpname ? "-e" : scriptname);
2012 curcop->cop_filegv = gv_fetchfile(origfilename);
2013 if (strEQ(origfilename,"-"))
2015 if (fdscript >= 0) {
2016 rsfp = PerlIO_fdopen(fdscript,PERL_SCRIPT_MODE);
2017 #if defined(HAS_FCNTL) && defined(F_SETFD)
2019 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
2022 else if (preprocess) {
2023 char *cpp_cfg = CPPSTDIN;
2024 SV *cpp = NEWSV(0,0);
2025 SV *cmd = NEWSV(0,0);
2027 if (strEQ(cpp_cfg, "cppstdin"))
2028 sv_catpvf(cpp, "%s/", BIN_EXP);
2029 sv_catpv(cpp, cpp_cfg);
2032 sv_catpv(sv,PRIVLIB_EXP);
2036 sed %s -e \"/^[^#]/b\" \
2037 -e \"/^#[ ]*include[ ]/b\" \
2038 -e \"/^#[ ]*define[ ]/b\" \
2039 -e \"/^#[ ]*if[ ]/b\" \
2040 -e \"/^#[ ]*ifdef[ ]/b\" \
2041 -e \"/^#[ ]*ifndef[ ]/b\" \
2042 -e \"/^#[ ]*else/b\" \
2043 -e \"/^#[ ]*elif[ ]/b\" \
2044 -e \"/^#[ ]*undef[ ]/b\" \
2045 -e \"/^#[ ]*endif/b\" \
2048 (doextract ? "-e \"1,/^#/d\n\"" : ""),
2051 %s %s -e '/^[^#]/b' \
2052 -e '/^#[ ]*include[ ]/b' \
2053 -e '/^#[ ]*define[ ]/b' \
2054 -e '/^#[ ]*if[ ]/b' \
2055 -e '/^#[ ]*ifdef[ ]/b' \
2056 -e '/^#[ ]*ifndef[ ]/b' \
2057 -e '/^#[ ]*else/b' \
2058 -e '/^#[ ]*elif[ ]/b' \
2059 -e '/^#[ ]*undef[ ]/b' \
2060 -e '/^#[ ]*endif/b' \
2068 (doextract ? "-e '1,/^#/d\n'" : ""),
2070 scriptname, cpp, sv, CPPMINUS);
2072 #ifdef IAMSUID /* actually, this is caught earlier */
2073 if (euid != uid && !euid) { /* if running suidperl */
2075 (void)seteuid(uid); /* musn't stay setuid root */
2078 (void)setreuid((Uid_t)-1, uid);
2080 #ifdef HAS_SETRESUID
2081 (void)setresuid((Uid_t)-1, uid, (Uid_t)-1);
2087 if (geteuid() != uid)
2088 croak("Can't do seteuid!\n");
2090 #endif /* IAMSUID */
2091 rsfp = PerlProc_popen(SvPVX(cmd), "r");
2095 else if (!*scriptname) {
2096 forbid_setid("program input from stdin");
2097 rsfp = PerlIO_stdin();
2100 rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
2101 #if defined(HAS_FCNTL) && defined(F_SETFD)
2103 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
2111 #ifndef IAMSUID /* in case script is not readable before setuid */
2112 if (euid && PerlLIO_stat(SvPVX(GvSV(curcop->cop_filegv)),&statbuf) >= 0 &&
2113 statbuf.st_mode & (S_ISUID|S_ISGID)) {
2115 PerlProc_execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
2116 croak("Can't do setuid\n");
2120 croak("Can't open perl script \"%s\": %s\n",
2121 SvPVX(GvSV(curcop->cop_filegv)), Strerror(errno));
2126 validate_suid(char *validarg, char *scriptname)
2130 /* do we need to emulate setuid on scripts? */
2132 /* This code is for those BSD systems that have setuid #! scripts disabled
2133 * in the kernel because of a security problem. Merely defining DOSUID
2134 * in perl will not fix that problem, but if you have disabled setuid
2135 * scripts in the kernel, this will attempt to emulate setuid and setgid
2136 * on scripts that have those now-otherwise-useless bits set. The setuid
2137 * root version must be called suidperl or sperlN.NNN. If regular perl
2138 * discovers that it has opened a setuid script, it calls suidperl with
2139 * the same argv that it had. If suidperl finds that the script it has
2140 * just opened is NOT setuid root, it sets the effective uid back to the
2141 * uid. We don't just make perl setuid root because that loses the
2142 * effective uid we had before invoking perl, if it was different from the
2145 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
2146 * be defined in suidperl only. suidperl must be setuid root. The
2147 * Configure script will set this up for you if you want it.
2154 if (PerlLIO_fstat(PerlIO_fileno(rsfp),&statbuf) < 0) /* normal stat is insecure */
2155 croak("Can't stat script \"%s\"",origfilename);
2156 if (fdscript < 0 && statbuf.st_mode & (S_ISUID|S_ISGID)) {
2160 #ifndef HAS_SETREUID
2161 /* On this access check to make sure the directories are readable,
2162 * there is actually a small window that the user could use to make
2163 * filename point to an accessible directory. So there is a faint
2164 * chance that someone could execute a setuid script down in a
2165 * non-accessible directory. I don't know what to do about that.
2166 * But I don't think it's too important. The manual lies when
2167 * it says access() is useful in setuid programs.
2169 if (PerlLIO_access(SvPVX(GvSV(curcop->cop_filegv)),1)) /*double check*/
2170 croak("Permission denied");
2172 /* If we can swap euid and uid, then we can determine access rights
2173 * with a simple stat of the file, and then compare device and
2174 * inode to make sure we did stat() on the same file we opened.
2175 * Then we just have to make sure he or she can execute it.
2178 struct stat tmpstatbuf;
2182 setreuid(euid,uid) < 0
2185 setresuid(euid,uid,(Uid_t)-1) < 0
2188 || getuid() != euid || geteuid() != uid)
2189 croak("Can't swap uid and euid"); /* really paranoid */
2190 if (PerlLIO_stat(SvPVX(GvSV(curcop->cop_filegv)),&tmpstatbuf) < 0)
2191 croak("Permission denied"); /* testing full pathname here */
2192 if (tmpstatbuf.st_dev != statbuf.st_dev ||
2193 tmpstatbuf.st_ino != statbuf.st_ino) {
2194 (void)PerlIO_close(rsfp);
2195 if (rsfp = PerlProc_popen("/bin/mail root","w")) { /* heh, heh */
2197 "User %ld tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
2198 (Filename of set-id script was %s, uid %ld gid %ld.)\n\nSincerely,\nperl\n",
2199 (long)uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
2200 (long)statbuf.st_dev, (long)statbuf.st_ino,
2201 SvPVX(GvSV(curcop->cop_filegv)),
2202 (long)statbuf.st_uid, (long)statbuf.st_gid);
2203 (void)PerlProc_pclose(rsfp);
2205 croak("Permission denied\n");
2209 setreuid(uid,euid) < 0
2211 # if defined(HAS_SETRESUID)
2212 setresuid(uid,euid,(Uid_t)-1) < 0
2215 || getuid() != uid || geteuid() != euid)
2216 croak("Can't reswap uid and euid");
2217 if (!cando(S_IXUSR,FALSE,&statbuf)) /* can real uid exec? */
2218 croak("Permission denied\n");
2220 #endif /* HAS_SETREUID */
2221 #endif /* IAMSUID */
2223 if (!S_ISREG(statbuf.st_mode))
2224 croak("Permission denied");
2225 if (statbuf.st_mode & S_IWOTH)
2226 croak("Setuid/gid script is writable by world");
2227 doswitches = FALSE; /* -s is insecure in suid */
2229 if (sv_gets(linestr, rsfp, 0) == Nullch ||
2230 strnNE(SvPV(linestr,na),"#!",2) ) /* required even on Sys V */
2231 croak("No #! line");
2232 s = SvPV(linestr,na)+2;
2234 while (!isSPACE(*s)) s++;
2235 for (s2 = s; (s2 > SvPV(linestr,na)+2 &&
2236 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
2237 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
2238 croak("Not a perl script");
2239 while (*s == ' ' || *s == '\t') s++;
2241 * #! arg must be what we saw above. They can invoke it by
2242 * mentioning suidperl explicitly, but they may not add any strange
2243 * arguments beyond what #! says if they do invoke suidperl that way.
2245 len = strlen(validarg);
2246 if (strEQ(validarg," PHOOEY ") ||
2247 strnNE(s,validarg,len) || !isSPACE(s[len]))
2248 croak("Args must match #! line");
2251 if (euid != uid && (statbuf.st_mode & S_ISUID) &&
2252 euid == statbuf.st_uid)
2254 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2255 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2256 #endif /* IAMSUID */
2258 if (euid) { /* oops, we're not the setuid root perl */
2259 (void)PerlIO_close(rsfp);
2262 PerlProc_execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
2264 croak("Can't do setuid\n");
2267 if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid) {
2269 (void)setegid(statbuf.st_gid);
2272 (void)setregid((Gid_t)-1,statbuf.st_gid);
2274 #ifdef HAS_SETRESGID
2275 (void)setresgid((Gid_t)-1,statbuf.st_gid,(Gid_t)-1);
2277 setgid(statbuf.st_gid);
2281 if (getegid() != statbuf.st_gid)
2282 croak("Can't do setegid!\n");
2284 if (statbuf.st_mode & S_ISUID) {
2285 if (statbuf.st_uid != euid)
2287 (void)seteuid(statbuf.st_uid); /* all that for this */
2290 (void)setreuid((Uid_t)-1,statbuf.st_uid);
2292 #ifdef HAS_SETRESUID
2293 (void)setresuid((Uid_t)-1,statbuf.st_uid,(Uid_t)-1);
2295 setuid(statbuf.st_uid);
2299 if (geteuid() != statbuf.st_uid)
2300 croak("Can't do seteuid!\n");
2302 else if (uid) { /* oops, mustn't run as root */
2304 (void)seteuid((Uid_t)uid);
2307 (void)setreuid((Uid_t)-1,(Uid_t)uid);
2309 #ifdef HAS_SETRESUID
2310 (void)setresuid((Uid_t)-1,(Uid_t)uid,(Uid_t)-1);
2316 if (geteuid() != uid)
2317 croak("Can't do seteuid!\n");
2320 if (!cando(S_IXUSR,TRUE,&statbuf))
2321 croak("Permission denied\n"); /* they can't do this */
2324 else if (preprocess)
2325 croak("-P not allowed for setuid/setgid script\n");
2326 else if (fdscript >= 0)
2327 croak("fd script not allowed in suidperl\n");
2329 croak("Script is not setuid/setgid in suidperl\n");
2331 /* We absolutely must clear out any saved ids here, so we */
2332 /* exec the real perl, substituting fd script for scriptname. */
2333 /* (We pass script name as "subdir" of fd, which perl will grok.) */
2334 PerlIO_rewind(rsfp);
2335 PerlLIO_lseek(PerlIO_fileno(rsfp),(Off_t)0,0); /* just in case rewind didn't */
2336 for (which = 1; origargv[which] && origargv[which] != scriptname; which++) ;
2337 if (!origargv[which])
2338 croak("Permission denied");
2339 origargv[which] = savepv(form("/dev/fd/%d/%s",
2340 PerlIO_fileno(rsfp), origargv[which]));
2341 #if defined(HAS_FCNTL) && defined(F_SETFD)
2342 fcntl(PerlIO_fileno(rsfp),F_SETFD,0); /* ensure no close-on-exec */
2344 PerlProc_execv(form("%s/perl%s", BIN_EXP, patchlevel), origargv); /* try again */
2345 croak("Can't do setuid\n");
2346 #endif /* IAMSUID */
2348 if (euid != uid || egid != gid) { /* (suidperl doesn't exist, in fact) */
2349 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
2351 PerlLIO_fstat(PerlIO_fileno(rsfp),&statbuf); /* may be either wrapped or real suid */
2352 if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
2354 (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
2357 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2358 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2359 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
2360 /* not set-id, must be wrapped */
2366 find_beginning(void)
2368 register char *s, *s2;
2370 /* skip forward in input to the real script? */
2374 if ((s = sv_gets(linestr, rsfp, 0)) == Nullch)
2375 croak("No Perl script found in input\n");
2376 if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
2377 PerlIO_ungetc(rsfp, '\n'); /* to keep line count right */
2379 while (*s && !(isSPACE (*s) || *s == '#')) s++;
2381 while (*s == ' ' || *s == '\t') s++;
2383 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
2384 if (strnEQ(s2-4,"perl",4))
2386 while (s = moreswitches(s)) ;
2388 if (cddir && PerlDir_chdir(cddir) < 0)
2389 croak("Can't chdir to %s",cddir);
2397 uid = (int)getuid();
2398 euid = (int)geteuid();
2399 gid = (int)getgid();
2400 egid = (int)getegid();
2405 tainting |= (uid && (euid != uid || egid != gid));
2409 forbid_setid(char *s)
2412 croak("No %s allowed while running setuid", s);
2414 croak("No %s allowed while running setgid", s);
2421 curstash = debstash;
2422 dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
2424 DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
2425 DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
2426 DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
2427 DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
2428 sv_setiv(DBsingle, 0);
2429 DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
2430 sv_setiv(DBtrace, 0);
2431 DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
2432 sv_setiv(DBsignal, 0);
2433 curstash = defstash;
2436 #ifndef STRESS_REALLOC
2437 #define REASONABLE(size) (size)
2439 #define REASONABLE(size) (1) /* unreasonable */
2443 init_stacks(ARGSproto)
2445 /* start with 128-item stack and 8K cxstack */
2446 curstackinfo = new_stackinfo(REASONABLE(128),
2447 REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
2448 curstackinfo->si_type = SI_MAIN;
2449 curstack = curstackinfo->si_stack;
2450 mainstack = curstack; /* remember in case we switch stacks */
2452 stack_base = AvARRAY(curstack);
2453 stack_sp = stack_base;
2454 stack_max = stack_base + AvMAX(curstack);
2456 New(50,tmps_stack,REASONABLE(128),SV*);
2459 tmps_max = REASONABLE(128);
2462 * The following stacks almost certainly should be per-interpreter,
2463 * but for now they're not. XXX
2467 markstack_ptr = markstack;
2469 New(54,markstack,REASONABLE(32),I32);
2470 markstack_ptr = markstack;
2471 markstack_max = markstack + REASONABLE(32);
2479 New(54,scopestack,REASONABLE(32),I32);
2481 scopestack_max = REASONABLE(32);
2487 New(54,savestack,REASONABLE(128),ANY);
2489 savestack_max = REASONABLE(128);
2495 New(54,retstack,REASONABLE(16),OP*);
2497 retstack_max = REASONABLE(16);
2507 while (curstackinfo->si_next)
2508 curstackinfo = curstackinfo->si_next;
2509 while (curstackinfo) {
2510 PERL_SI *p = curstackinfo->si_prev;
2511 /* curstackinfo->si_stack got nuked by sv_free_arenas() */
2512 Safefree(curstackinfo->si_cxstack);
2513 Safefree(curstackinfo);
2516 Safefree(tmps_stack);
2523 static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
2532 subname = newSVpv("main",4);
2536 init_predump_symbols(void)
2542 sv_setpvn(perl_get_sv("\"", TRUE), " ", 1);
2543 stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
2544 GvMULTI_on(stdingv);
2545 IoIFP(GvIOp(stdingv)) = PerlIO_stdin();
2546 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
2548 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(stdingv));
2550 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
2552 IoOFP(GvIOp(tmpgv)) = IoIFP(GvIOp(tmpgv)) = PerlIO_stdout();
2554 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
2556 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(defoutgv));
2558 othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
2559 GvMULTI_on(othergv);
2560 IoOFP(GvIOp(othergv)) = IoIFP(GvIOp(othergv)) = PerlIO_stderr();
2561 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
2563 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(othergv));
2565 statname = NEWSV(66,0); /* last filename we did stat on */
2568 osname = savepv(OSNAME);
2572 init_postdump_symbols(register int argc, register char **argv, register char **env)
2579 argc--,argv++; /* skip name of script */
2581 for (; argc > 0 && **argv == '-'; argc--,argv++) {
2584 if (argv[0][1] == '-') {
2588 if (s = strchr(argv[0], '=')) {
2590 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
2593 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
2596 toptarget = NEWSV(0,0);
2597 sv_upgrade(toptarget, SVt_PVFM);
2598 sv_setpvn(toptarget, "", 0);
2599 bodytarget = NEWSV(0,0);
2600 sv_upgrade(bodytarget, SVt_PVFM);
2601 sv_setpvn(bodytarget, "", 0);
2602 formtarget = bodytarget;
2605 if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
2606 sv_setpv(GvSV(tmpgv),origfilename);
2607 magicname("0", "0", 1);
2609 if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
2610 sv_setpv(GvSV(tmpgv),origargv[0]);
2611 if (argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
2613 (void)gv_AVadd(argvgv);
2614 av_clear(GvAVn(argvgv));
2615 for (; argc > 0; argc--,argv++) {
2616 av_push(GvAVn(argvgv),newSVpv(argv[0],0));
2619 if (envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
2623 hv_magic(hv, envgv, 'E');
2624 #ifndef VMS /* VMS doesn't have environ array */
2625 /* Note that if the supplied env parameter is actually a copy
2626 of the global environ then it may now point to free'd memory
2627 if the environment has been modified since. To avoid this
2628 problem we treat env==NULL as meaning 'use the default'
2633 environ[0] = Nullch;
2634 for (; *env; env++) {
2635 if (!(s = strchr(*env,'=')))
2638 #if defined(WIN32) || defined(MSDOS)
2641 sv = newSVpv(s--,0);
2642 (void)hv_store(hv, *env, s - *env, sv, 0);
2644 #if defined(__BORLANDC__) && defined(USE_WIN32_RTL_ENV)
2645 /* Sins of the RTL. See note in my_setenv(). */
2646 (void)PerlEnv_putenv(savepv(*env));
2650 #ifdef DYNAMIC_ENV_FETCH
2651 HvNAME(hv) = savepv(ENV_HV_NAME);
2655 if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
2656 sv_setiv(GvSV(tmpgv), (IV)getpid());
2665 s = PerlEnv_getenv("PERL5LIB");
2669 incpush(PerlEnv_getenv("PERLLIB"), FALSE);
2671 /* Treat PERL5?LIB as a possible search list logical name -- the
2672 * "natural" VMS idiom for a Unix path string. We allow each
2673 * element to be a set of |-separated directories for compatibility.
2677 if (my_trnlnm("PERL5LIB",buf,0))
2678 do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
2680 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE);
2684 /* Use the ~-expanded versions of APPLLIB (undocumented),
2685 ARCHLIB PRIVLIB SITEARCH and SITELIB
2688 incpush(APPLLIB_EXP, FALSE);
2692 incpush(ARCHLIB_EXP, FALSE);
2695 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
2697 incpush(PRIVLIB_EXP, FALSE);
2700 incpush(SITEARCH_EXP, FALSE);
2703 incpush(SITELIB_EXP, FALSE);
2706 incpush(".", FALSE);
2710 # define PERLLIB_SEP ';'
2713 # define PERLLIB_SEP '|'
2715 # define PERLLIB_SEP ':'
2718 #ifndef PERLLIB_MANGLE
2719 # define PERLLIB_MANGLE(s,n) (s)
2723 incpush(char *p, int addsubdirs)
2725 SV *subdir = Nullsv;
2726 static char *archpat_auto;
2732 subdir = NEWSV(55,0);
2733 if (!archpat_auto) {
2734 STRLEN len = (sizeof(ARCHNAME) + strlen(patchlevel)
2735 + sizeof("//auto"));
2736 New(55, archpat_auto, len, char);
2737 sprintf(archpat_auto, "/%s/%s/auto", ARCHNAME, patchlevel);
2739 for (len = sizeof(ARCHNAME) + 2;
2740 archpat_auto[len] != '\0' && archpat_auto[len] != '/'; len++)
2741 if (archpat_auto[len] == '.') archpat_auto[len] = '_';
2746 /* Break at all separators */
2748 SV *libdir = NEWSV(55,0);
2751 /* skip any consecutive separators */
2752 while ( *p == PERLLIB_SEP ) {
2753 /* Uncomment the next line for PATH semantics */
2754 /* av_push(GvAVn(incgv), newSVpv(".", 1)); */
2758 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
2759 sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
2764 sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
2765 p = Nullch; /* break out */
2769 * BEFORE pushing libdir onto @INC we may first push version- and
2770 * archname-specific sub-directories.
2773 struct stat tmpstatbuf;
2778 if ((unix = tounixspec_ts(SvPV(libdir,na),Nullch)) != Nullch) {
2780 while (unix[len-1] == '/') len--; /* Cosmetic */
2781 sv_usepvn(libdir,unix,len);
2784 PerlIO_printf(PerlIO_stderr(),
2785 "Failed to unixify @INC element \"%s\"\n",
2788 /* .../archname/version if -d .../archname/version/auto */
2789 sv_setsv(subdir, libdir);
2790 sv_catpv(subdir, archpat_auto);
2791 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2792 S_ISDIR(tmpstatbuf.st_mode))
2793 av_push(GvAVn(incgv),
2794 newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2796 /* .../archname if -d .../archname/auto */
2797 sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME),
2798 strlen(patchlevel) + 1, "", 0);
2799 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2800 S_ISDIR(tmpstatbuf.st_mode))
2801 av_push(GvAVn(incgv),
2802 newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2805 /* finally push this lib directory on the end of @INC */
2806 av_push(GvAVn(incgv), libdir);
2809 SvREFCNT_dec(subdir);
2813 static struct perl_thread *
2816 struct perl_thread *thr;
2819 Newz(53, thr, 1, struct perl_thread);
2820 curcop = &compiling;
2821 thr->cvcache = newHV();
2822 thr->threadsv = newAV();
2823 /* thr->threadsvp is set when find_threadsv is called */
2824 thr->specific = newAV();
2825 thr->errhv = newHV();
2826 thr->flags = THRf_R_JOINABLE;
2827 MUTEX_INIT(&thr->mutex);
2828 /* Handcraft thrsv similarly to mess_sv */
2829 New(53, thrsv, 1, SV);
2830 Newz(53, xpv, 1, XPV);
2831 SvFLAGS(thrsv) = SVt_PV;
2832 SvANY(thrsv) = (void*)xpv;
2833 SvREFCNT(thrsv) = 1 << 30; /* practically infinite */
2834 SvPVX(thrsv) = (char*)thr;
2835 SvCUR_set(thrsv, sizeof(thr));
2836 SvLEN_set(thrsv, sizeof(thr));
2837 *SvEND(thrsv) = '\0'; /* in the trailing_nul field */
2839 curcop = &compiling;
2842 MUTEX_LOCK(&threads_mutex);
2847 MUTEX_UNLOCK(&threads_mutex);
2849 #ifdef HAVE_THREAD_INTERN
2850 init_thread_intern(thr);
2853 #ifdef SET_THREAD_SELF
2854 SET_THREAD_SELF(thr);
2856 thr->self = pthread_self();
2857 #endif /* SET_THREAD_SELF */
2861 * These must come after the SET_THR because sv_setpvn does
2862 * SvTAINT and the taint fields require dTHR.
2864 toptarget = NEWSV(0,0);
2865 sv_upgrade(toptarget, SVt_PVFM);
2866 sv_setpvn(toptarget, "", 0);
2867 bodytarget = NEWSV(0,0);
2868 sv_upgrade(bodytarget, SVt_PVFM);
2869 sv_setpvn(bodytarget, "", 0);
2870 formtarget = bodytarget;
2871 thr->errsv = newSVpv("", 0);
2872 (void) find_threadsv("@"); /* Ensure $@ is initialised early */
2875 #endif /* USE_THREADS */
2878 call_list(I32 oldscope, AV *list)
2881 line_t oldline = curcop->cop_line;
2886 while (AvFILL(list) >= 0) {
2887 CV *cv = (CV*)av_shift(list);
2896 perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
2897 (void)SvPV(atsv, len);
2900 curcop = &compiling;
2901 curcop->cop_line = oldline;
2902 if (list == beginav)
2903 sv_catpv(atsv, "BEGIN failed--compilation aborted");
2905 sv_catpv(atsv, "END failed--cleanup aborted");
2906 while (scopestack_ix > oldscope)
2908 croak("%s", SvPVX(atsv));
2916 /* my_exit() was called */
2917 while (scopestack_ix > oldscope)
2920 curstash = defstash;
2922 call_list(oldscope, endav);
2924 curcop = &compiling;
2925 curcop->cop_line = oldline;
2927 if (list == beginav)
2928 croak("BEGIN failed--compilation aborted");
2930 croak("END failed--cleanup aborted");
2936 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
2941 curcop = &compiling;
2942 curcop->cop_line = oldline;
2955 DEBUG_L(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
2956 thr, (unsigned long) status));
2957 #endif /* USE_THREADS */
2966 STATUS_NATIVE_SET(status);
2973 my_failure_exit(void)
2976 if (vaxc$errno & 1) {
2977 if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
2978 STATUS_NATIVE_SET(44);
2981 if (!vaxc$errno && errno) /* unlikely */
2982 STATUS_NATIVE_SET(44);
2984 STATUS_NATIVE_SET(vaxc$errno);
2988 STATUS_POSIX_SET(errno);
2989 else if (STATUS_POSIX == 0)
2990 STATUS_POSIX_SET(255);
2999 register PERL_CONTEXT *cx;
3008 (void)UNLINK(e_tmpname);
3009 Safefree(e_tmpname);
3013 POPSTACK_TO(mainstack);
3014 if (cxstack_ix >= 0) {