3 * Copyright (c) 1987-1997 Larry Wall
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
11 * "A ship then new they built for him/of mithril and of elven glass" --Bilbo
16 #include "patchlevel.h"
18 /* XXX If this causes problems, set i_unistd=undef in the hint file. */
23 #if !defined(STANDARD_C) && !defined(HAS_GETENV_PROTOTYPE)
24 char *getenv _((char *)); /* Usually in <stdlib.h> */
27 dEXTCONST char rcsid[] = "perl.c\nPatch level: ###\n";
35 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
45 curcop = &compiling; \
52 laststype = OP_STAT; \
54 maxsysfd = MAXSYSFD; \
61 laststype = OP_STAT; \
65 static void find_beginning _((void));
66 static void forbid_setid _((char *));
67 static void incpush _((char *, int));
68 static void init_ids _((void));
69 static void init_debugger _((void));
70 static void init_lexer _((void));
71 static void init_main_stash _((void));
72 static void init_perllib _((void));
73 static void init_postdump_symbols _((int, char **, char **));
74 static void init_predump_symbols _((void));
75 static void my_exit_jump _((void)) __attribute__((noreturn));
76 static void nuke_stacks _((void));
77 static void open_script _((char *, bool, SV *));
78 static void usage _((char *));
79 static void validate_suid _((char *, char*));
81 static int fdscript = -1;
83 #if defined(DEBUGGING) && defined(USE_THREADS) && defined(__linux__)
84 #include <asm/sigcontext.h>
86 catch_sigsegv(int signo, struct sigcontext_struct sc)
88 signal(SIGSEGV, SIG_DFL);
89 fprintf(stderr, "Segmentation fault dereferencing 0x%lx\n"
90 "return_address = 0x%lx, eip = 0x%lx\n",
91 sc.cr2, __builtin_return_address(0), sc.eip);
92 fprintf(stderr, "thread = 0x%lx\n", (unsigned long)THR);
99 PerlInterpreter *sv_interp;
102 New(53, sv_interp, 1, PerlInterpreter);
107 perl_construct(register PerlInterpreter *sv_interp)
109 #if defined(USE_THREADS) && !defined(FAKE_THREADS)
113 if (!(curinterp = sv_interp))
117 Zero(sv_interp, 1, PerlInterpreter);
120 /* Init the real globals (and main thread)? */
126 Newz(53, thr, 1, struct thread);
127 MUTEX_INIT(&malloc_mutex);
128 MUTEX_INIT(&sv_mutex);
129 /* Safe to use SVs from now on */
130 MUTEX_INIT(&eval_mutex);
131 COND_INIT(&eval_cond);
132 MUTEX_INIT(&threads_mutex);
133 COND_INIT(&nthreads_cond);
137 thr->flags = THRf_R_JOINABLE;
138 MUTEX_INIT(&thr->mutex);
143 /* Handcraft thrsv similarly to mess_sv */
144 New(53, thrsv, 1, SV);
145 Newz(53, xpv, 1, XPV);
146 SvFLAGS(thrsv) = SVt_PV;
147 SvANY(thrsv) = (void*)xpv;
148 SvREFCNT(thrsv) = 1 << 30; /* practically infinite */
149 SvPVX(thrsv) = (char*)thr;
150 SvCUR_set(thrsv, sizeof(thr));
151 SvLEN_set(thrsv, sizeof(thr));
152 *SvEND(thrsv) = '\0'; /* in the trailing_nul field */
154 #ifdef HAVE_THREAD_INTERN
155 init_thread_intern(thr);
157 thr->self = pthread_self();
158 if (pthread_key_create(&thr_key, 0))
159 croak("panic: pthread_key_create");
160 #endif /* HAVE_THREAD_INTERN */
162 #endif /* USE_THREADS */
164 linestr = NEWSV(65,80);
165 sv_upgrade(linestr,SVt_PVIV);
167 if (!SvREADONLY(&sv_undef)) {
168 SvREADONLY_on(&sv_undef);
172 SvREADONLY_on(&sv_no);
174 sv_setpv(&sv_yes,Yes);
176 SvREADONLY_on(&sv_yes);
179 nrs = newSVpv("\n", 1);
180 rs = SvREFCNT_inc(nrs);
182 sighandlerp = sighandler;
187 * There is no way we can refer to them from Perl so close them to save
188 * space. The other alternative would be to provide STDAUX and STDPRN
191 (void)fclose(stdaux);
192 (void)fclose(stdprn);
198 perl_destruct_level = 1;
200 if(perl_destruct_level > 0)
205 lex_state = LEX_NOTPARSING;
207 start_env.je_prev = NULL;
208 start_env.je_ret = -1;
209 start_env.je_mustcatch = TRUE;
210 top_env = &start_env;
213 SET_NUMERIC_STANDARD();
214 #if defined(SUBVERSION) && SUBVERSION > 0
215 sprintf(patchlevel, "%7.5f", (double) 5
216 + ((double) PATCHLEVEL / (double) 1000)
217 + ((double) SUBVERSION / (double) 100000));
219 sprintf(patchlevel, "%5.3f", (double) 5 +
220 ((double) PATCHLEVEL / (double) 1000));
223 #if defined(LOCAL_PATCH_COUNT)
224 localpatches = local_patches; /* For possible -v */
227 PerlIO_init(); /* Hook to IO system */
229 fdpid = newAV(); /* for remembering popen pids by fd */
233 New(51,debname,128,char);
234 New(52,debdelim,128,char);
241 perl_destruct(register PerlInterpreter *sv_interp)
244 int destruct_level; /* 0=none, 1=full, 2=full with checks */
249 #endif /* USE_THREADS */
251 if (!(curinterp = sv_interp))
256 /* Pass 1 on any remaining threads: detach joinables, join zombies */
258 MUTEX_LOCK(&threads_mutex);
259 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
260 "perl_destruct: waiting for %d threads...\n",
262 for (t = thr->next; t != thr; t = t->next) {
263 MUTEX_LOCK(&t->mutex);
264 switch (ThrSTATE(t)) {
267 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
268 "perl_destruct: joining zombie %p\n", t));
269 ThrSETSTATE(t, THRf_DEAD);
270 MUTEX_UNLOCK(&t->mutex);
273 * The SvREFCNT_dec below may take a long time (e.g. av
274 * may contain an object scalar whose destructor gets
275 * called) so we have to unlock threads_mutex and start
278 MUTEX_UNLOCK(&threads_mutex);
280 SvREFCNT_dec((SV*)av);
281 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
282 "perl_destruct: joined zombie %p OK\n", t));
284 case THRf_R_JOINABLE:
285 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
286 "perl_destruct: detaching thread %p\n", t));
287 ThrSETSTATE(t, THRf_R_DETACHED);
289 * We unlock threads_mutex and t->mutex in the opposite order
290 * from which we locked them just so that DETACH won't
291 * deadlock if it panics. It's only a breach of good style
292 * not a bug since they are unlocks not locks.
294 MUTEX_UNLOCK(&threads_mutex);
296 MUTEX_UNLOCK(&t->mutex);
299 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
300 "perl_destruct: ignoring %p (state %u)\n",
302 MUTEX_UNLOCK(&t->mutex);
303 /* fall through and out */
306 /* We leave the above "Pass 1" loop with threads_mutex still locked */
308 /* Pass 2 on remaining threads: wait for the thread count to drop to one */
311 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
312 "perl_destruct: final wait for %d threads\n",
314 COND_WAIT(&nthreads_cond, &threads_mutex);
316 /* At this point, we're the last thread */
317 MUTEX_UNLOCK(&threads_mutex);
318 DEBUG_L(PerlIO_printf(PerlIO_stderr(), "perl_destruct: armageddon has arrived\n"));
319 MUTEX_DESTROY(&threads_mutex);
320 COND_DESTROY(&nthreads_cond);
321 #endif /* !defined(FAKE_THREADS) */
322 #endif /* USE_THREADS */
324 destruct_level = perl_destruct_level;
328 if (s = getenv("PERL_DESTRUCT_LEVEL")) {
330 if (destruct_level < i)
339 /* We must account for everything. */
341 /* Destroy the main CV and syntax tree */
343 curpad = AvARRAY(comppad);
348 SvREFCNT_dec(main_cv);
353 * Try to destruct global references. We do this first so that the
354 * destructors and destructees still exist. Some sv's might remain.
355 * Non-referenced objects are on their own.
362 /* unhook hooks which will soon be, or use, destroyed data */
363 SvREFCNT_dec(warnhook);
365 SvREFCNT_dec(diehook);
367 SvREFCNT_dec(parsehook);
370 if (destruct_level == 0){
372 DEBUG_P(debprofdump());
374 /* The exit() function will do everything that needs doing. */
378 /* loosen bonds of global variables */
381 (void)PerlIO_close(rsfp);
385 /* Filters for program text */
386 SvREFCNT_dec(rsfp_filters);
387 rsfp_filters = Nullav;
399 sawampersand = FALSE; /* must save all match strings */
400 sawstudy = FALSE; /* do fbm_instr on all strings */
415 /* magical thingies */
417 Safefree(ofs); /* $, */
420 Safefree(ors); /* $\ */
423 SvREFCNT_dec(nrs); /* $\ helper */
426 multiline = 0; /* $* */
428 SvREFCNT_dec(statname);
432 /* defgv, aka *_ should be taken care of elsewhere */
434 #if 0 /* just about all regexp stuff, seems to be ok */
436 /* shortcuts to regexp stuff */
441 SAVEFREEOP(oldlastpm); /* for saving regexp context during debugger */
443 regprecomp = NULL; /* uncompiled string. */
444 regparse = NULL; /* Input-scan pointer. */
445 regxend = NULL; /* End of input for compile */
446 regnpar = 0; /* () count. */
447 regcode = NULL; /* Code-emit pointer; ®dummy = don't. */
448 regsize = 0; /* Code size. */
449 regnaughty = 0; /* How bad is this pattern? */
450 regsawback = 0; /* Did we see \1, ...? */
452 reginput = NULL; /* String-input pointer. */
453 regbol = NULL; /* Beginning of input, for ^ check. */
454 regeol = NULL; /* End of input, for $ check. */
455 regstartp = (char **)NULL; /* Pointer to startp array. */
456 regendp = (char **)NULL; /* Ditto for endp. */
457 reglastparen = 0; /* Similarly for lastparen. */
458 regtill = NULL; /* How far we are required to go. */
459 regflags = 0; /* are we folding, multilining? */
460 regprev = (char)NULL; /* char before regbol, \n if none */
464 /* clean up after study() */
465 SvREFCNT_dec(lastscream);
467 Safefree(screamfirst);
469 Safefree(screamnext);
472 /* startup and shutdown function lists */
473 SvREFCNT_dec(beginav);
475 SvREFCNT_dec(initav);
480 /* temp stack during pp_sort() */
481 SvREFCNT_dec(sortstack);
484 /* shortcuts just get cleared */
494 /* reset so print() ends up where we expect */
497 /* Prepare to destruct main symbol table. */
504 if (destruct_level >= 2) {
505 if (scopestack_ix != 0)
506 warn("Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
507 (long)scopestack_ix);
508 if (savestack_ix != 0)
509 warn("Unbalanced saves: %ld more saves than restores\n",
511 if (tmps_floor != -1)
512 warn("Unbalanced tmps: %ld more allocs than frees\n",
513 (long)tmps_floor + 1);
514 if (cxstack_ix != -1)
515 warn("Unbalanced context: %ld more PUSHes than POPs\n",
516 (long)cxstack_ix + 1);
519 /* Now absolutely destruct everything, somehow or other, loops or no. */
521 SvFLAGS(strtab) |= SVTYPEMASK; /* don't clean out strtab now */
522 while (sv_count != 0 && sv_count != last_sv_count) {
523 last_sv_count = sv_count;
526 SvFLAGS(strtab) &= ~SVTYPEMASK;
527 SvFLAGS(strtab) |= SVt_PVHV;
529 /* Destruct the global string table. */
531 /* Yell and reset the HeVAL() slots that are still holding refcounts,
532 * so that sv_free() won't fail on them.
541 array = HvARRAY(strtab);
545 warn("Unbalanced string table refcount: (%d) for \"%s\"",
546 HeVAL(hent) - Nullsv, HeKEY(hent));
547 HeVAL(hent) = Nullsv;
557 SvREFCNT_dec(strtab);
560 warn("Scalars leaked: %ld\n", (long)sv_count);
564 /* No SVs have survived, need to clean out */
568 Safefree(origfilename);
570 hints = 0; /* Reset hints. Should hints be per-interpreter ? */
572 DEBUG_P(debprofdump());
574 MUTEX_DESTROY(&sv_mutex);
575 MUTEX_DESTROY(&malloc_mutex);
576 MUTEX_DESTROY(&eval_mutex);
577 COND_DESTROY(&eval_cond);
579 /* As the penultimate thing, free the non-arena SV for thrsv */
580 Safefree(SvPVX(thrsv));
581 Safefree(SvANY(thrsv));
584 #endif /* USE_THREADS */
586 /* As the absolutely last thing, free the non-arena SV for mess() */
589 /* we know that type >= SVt_PV */
591 Safefree(SvPVX(mess_sv));
592 Safefree(SvANY(mess_sv));
599 perl_free(PerlInterpreter *sv_interp)
601 if (!(curinterp = sv_interp))
607 perl_parse(PerlInterpreter *sv_interp, void (*xsinit) (void), int argc, char **argv, char **env)
612 char *scriptname = NULL;
613 VOL bool dosearch = FALSE;
620 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
623 croak("suidperl is no longer needed since the kernel can now execute\n\
624 setuid perl scripts securely.\n");
628 if (!(curinterp = sv_interp))
631 #if defined(NeXT) && defined(__DYNAMIC__)
632 _dyld_lookup_and_bind
633 ("__environ", (unsigned long *) &environ_pointer, NULL);
638 #ifndef VMS /* VMS doesn't have environ array */
639 origenviron = environ;
645 /* Come here if running an undumped a.out. */
647 origfilename = savepv(argv[0]);
649 cxstack_ix = -1; /* start label stack again */
651 init_postdump_symbols(argc,argv,env);
656 curpad = AvARRAY(comppad);
661 SvREFCNT_dec(main_cv);
665 oldscope = scopestack_ix;
673 /* my_exit() was called */
674 while (scopestack_ix > oldscope)
679 call_list(oldscope, endav);
681 return STATUS_NATIVE_EXPORT;
684 PerlIO_printf(PerlIO_stderr(), "panic: top_env\n");
688 sv_setpvn(linestr,"",0);
689 sv = newSVpv("",0); /* first used for -I flags */
693 for (argc--,argv++; argc > 0; argc--,argv++) {
694 if (argv[0][0] != '-' || !argv[0][1])
698 validarg = " PHOOEY ";
723 if (s = moreswitches(s))
733 if (euid != uid || egid != gid)
734 croak("No -e allowed in setuid scripts");
736 e_tmpname = savepv(TMPPATH);
737 (void)mktemp(e_tmpname);
739 croak("Can't mktemp()");
740 e_fp = PerlIO_open(e_tmpname,"w");
742 croak("Cannot open temporary file");
747 PerlIO_puts(e_fp,argv[1]);
751 croak("No code specified for -e");
752 (void)PerlIO_putc(e_fp,'\n');
754 case 'I': /* -I handled both here and in moreswitches() */
756 if (!*++s && (s=argv[1]) != Nullch) {
759 while (s && isSPACE(*s))
763 for (e = s; *e && !isSPACE(*e); e++) ;
770 } /* XXX else croak? */
784 preambleav = newAV();
785 av_push(preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
787 Sv = newSVpv("print myconfig();",0);
789 sv_catpv(Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
791 sv_catpv(Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
793 #if defined(DEBUGGING) || defined(NO_EMBED) || defined(MULTIPLICITY)
794 sv_catpv(Sv,"\" Compile-time options:");
796 sv_catpv(Sv," DEBUGGING");
799 sv_catpv(Sv," NO_EMBED");
802 sv_catpv(Sv," MULTIPLICITY");
804 sv_catpv(Sv,"\\n\",");
806 #if defined(LOCAL_PATCH_COUNT)
807 if (LOCAL_PATCH_COUNT > 0) {
809 sv_catpv(Sv,"\" Locally applied patches:\\n\",");
810 for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
812 sv_catpvf(Sv,"\" \\t%s\\n\",",localpatches[i]);
816 sv_catpvf(Sv,"\" Built under %s\\n\"",OSNAME);
819 sv_catpvf(Sv,",\" Compiled at %s %s\\n\"",__DATE__,__TIME__);
821 sv_catpvf(Sv,",\" Compiled on %s\\n\"",__DATE__);
826 @env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; \
827 print \" \\%ENV:\\n @env\\n\" if @env; \
828 print \" \\@INC:\\n @INC\\n\";");
831 Sv = newSVpv("config_vars(qw(",0);
836 av_push(preambleav, Sv);
837 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
848 if (!*++s || isSPACE(*s)) {
852 /* catch use of gnu style long options */
853 if (strEQ(s, "version")) {
857 if (strEQ(s, "help")) {
864 croak("Unrecognized switch: -%s (-h will show valid options)",s);
869 if (!tainting && (s = getenv("PERL5OPT"))) {
880 if (!strchr("DIMUdmw", *s))
881 croak("Illegal switch in PERL5OPT: -%c", *s);
887 scriptname = argv[0];
889 if (PerlIO_flush(e_fp) || PerlIO_error(e_fp) || PerlIO_close(e_fp)) {
891 warn("Did you forget to compile with -DMULTIPLICITY?");
893 croak("Can't write to temp file for -e: %s", Strerror(errno));
897 scriptname = e_tmpname;
899 else if (scriptname == Nullch) {
901 if ( isatty(PerlIO_fileno(PerlIO_stdin())) )
909 open_script(scriptname,dosearch,sv);
911 validate_suid(validarg, scriptname);
916 main_cv = compcv = (CV*)NEWSV(1104,0);
917 sv_upgrade((SV *)compcv, SVt_PVCV);
921 av_push(comppad, Nullsv);
922 curpad = AvARRAY(comppad);
923 comppad_name = newAV();
924 comppad_name_fill = 0;
925 min_intro_pending = 0;
928 av_store(comppad_name, 0, newSVpv("@_", 2));
929 curpad[0] = (SV*)newAV();
930 SvPADMY_on(curpad[0]); /* XXX Needed? */
932 New(666, CvMUTEXP(compcv), 1, perl_mutex);
933 MUTEX_INIT(CvMUTEXP(compcv));
934 #endif /* USE_THREADS */
936 comppadlist = newAV();
937 AvREAL_off(comppadlist);
938 av_store(comppadlist, 0, (SV*)comppad_name);
939 av_store(comppadlist, 1, (SV*)comppad);
940 CvPADLIST(compcv) = comppadlist;
942 boot_core_UNIVERSAL();
944 (*xsinit)(); /* in case linked C routines want magical variables */
945 #if defined(VMS) || defined(WIN32)
949 #if defined(DEBUGGING) && defined(USE_THREADS) && defined(__linux__)
950 DEBUG_L(signal(SIGSEGV, (void(*)(int))catch_sigsegv););
953 init_predump_symbols();
955 init_postdump_symbols(argc,argv,env);
959 /* now parse the script */
962 if (yyparse() || error_count) {
964 croak("%s had compilation errors.\n", origfilename);
966 croak("Execution of %s aborted due to compilation errors.\n",
970 curcop->cop_line = 0;
974 (void)UNLINK(e_tmpname);
979 /* now that script is parsed, we can modify record separator */
981 rs = SvREFCNT_inc(nrs);
982 sv_setsv(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), rs);
994 if ((s=getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
995 dump_mstats("after compilation:");
1005 perl_run(PerlInterpreter *sv_interp)
1012 if (!(curinterp = sv_interp))
1015 oldscope = scopestack_ix;
1020 cxstack_ix = -1; /* start context stack again */
1023 /* my_exit() was called */
1024 while (scopestack_ix > oldscope)
1027 curstash = defstash;
1029 call_list(oldscope, endav);
1031 if (getenv("PERL_DEBUG_MSTATS"))
1032 dump_mstats("after execution: ");
1035 return STATUS_NATIVE_EXPORT;
1038 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
1043 if (curstack != mainstack) {
1045 SWITCHSTACK(curstack, mainstack);
1050 DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
1051 sawampersand ? "Enabling" : "Omitting"));
1054 DEBUG_x(dump_all());
1055 DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
1057 DEBUG_L(PerlIO_printf(Perl_debug_log, "main thread is 0x%lx\n",
1058 (unsigned long) thr));
1059 #endif /* USE_THREADS */
1062 PerlIO_printf(PerlIO_stderr(), "%s syntax OK\n", origfilename);
1065 if (PERLDB_SINGLE && DBsingle)
1066 sv_setiv(DBsingle, 1);
1068 call_list(oldscope, initav);
1078 else if (main_start) {
1079 CvDEPTH(main_cv) = 1;
1090 perl_get_sv(char *name, I32 create)
1092 GV* gv = gv_fetchpv(name, create, SVt_PV);
1099 perl_get_av(char *name, I32 create)
1101 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
1110 perl_get_hv(char *name, I32 create)
1112 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
1121 perl_get_cv(char *name, I32 create)
1123 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
1124 if (create && !GvCVu(gv))
1125 return newSUB(start_subparse(FALSE, 0),
1126 newSVOP(OP_CONST, 0, newSVpv(name,0)),
1134 /* Be sure to refetch the stack pointer after calling these routines. */
1137 perl_call_argv(char *subname, I32 flags, register char **argv)
1139 /* See G_* flags in cop.h */
1140 /* null terminated arg list */
1148 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
1153 return perl_call_pv(subname, flags);
1157 perl_call_pv(char *subname, I32 flags)
1158 /* name of the subroutine */
1159 /* See G_* flags in cop.h */
1161 return perl_call_sv((SV*)perl_get_cv(subname, TRUE), flags);
1165 perl_call_method(char *methname, I32 flags)
1166 /* name of the subroutine */
1167 /* See G_* flags in cop.h */
1174 XPUSHs(sv_2mortal(newSVpv(methname,0)));
1177 return perl_call_sv(*stack_sp--, flags);
1180 /* May be called with any of a CV, a GV, or an SV containing the name. */
1182 perl_call_sv(SV *sv, I32 flags)
1184 /* See G_* flags in cop.h */
1187 LOGOP myop; /* fake syntax tree node */
1193 bool oldcatch = CATCH_GET;
1198 if (flags & G_DISCARD) {
1203 Zero(&myop, 1, LOGOP);
1204 myop.op_next = Nullop;
1205 if (!(flags & G_NOARGS))
1206 myop.op_flags |= OPf_STACKED;
1207 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1208 (flags & G_ARRAY) ? OPf_WANT_LIST :
1213 EXTEND(stack_sp, 1);
1216 oldscope = scopestack_ix;
1218 if (PERLDB_SUB && curstash != debstash
1219 /* Handle first BEGIN of -d. */
1220 && (DBcv || (DBcv = GvCV(DBsub)))
1221 /* Try harder, since this may have been a sighandler, thus
1222 * curstash may be meaningless. */
1223 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != debstash))
1224 op->op_private |= OPpENTERSUB_DB;
1226 if (flags & G_EVAL) {
1227 cLOGOP->op_other = op;
1229 /* we're trying to emulate pp_entertry() here */
1231 register CONTEXT *cx;
1232 I32 gimme = GIMME_V;
1237 push_return(op->op_next);
1238 PUSHBLOCK(cx, CXt_EVAL, stack_sp);
1240 eval_root = op; /* Only needed so that goto works right. */
1243 if (flags & G_KEEPERR)
1246 sv_setpv(GvSV(errgv),"");
1258 /* my_exit() was called */
1259 curstash = defstash;
1263 croak("Callback called exit");
1272 stack_sp = stack_base + oldmark;
1273 if (flags & G_ARRAY)
1277 *++stack_sp = &sv_undef;
1285 if (op == (OP*)&myop)
1286 op = pp_entersub(ARGS);
1289 retval = stack_sp - (stack_base + oldmark);
1290 if ((flags & G_EVAL) && !(flags & G_KEEPERR))
1291 sv_setpv(GvSV(errgv),"");
1294 if (flags & G_EVAL) {
1295 if (scopestack_ix > oldscope) {
1299 register CONTEXT *cx;
1311 CATCH_SET(oldcatch);
1313 if (flags & G_DISCARD) {
1314 stack_sp = stack_base + oldmark;
1323 /* Eval a string. The G_EVAL flag is always assumed. */
1326 perl_eval_sv(SV *sv, I32 flags)
1328 /* See G_* flags in cop.h */
1331 UNOP myop; /* fake syntax tree node */
1333 I32 oldmark = sp - stack_base;
1340 if (flags & G_DISCARD) {
1348 EXTEND(stack_sp, 1);
1350 oldscope = scopestack_ix;
1352 if (!(flags & G_NOARGS))
1353 myop.op_flags = OPf_STACKED;
1354 myop.op_next = Nullop;
1355 myop.op_type = OP_ENTEREVAL;
1356 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1357 (flags & G_ARRAY) ? OPf_WANT_LIST :
1359 if (flags & G_KEEPERR)
1360 myop.op_flags |= OPf_SPECIAL;
1370 /* my_exit() was called */
1371 curstash = defstash;
1375 croak("Callback called exit");
1384 stack_sp = stack_base + oldmark;
1385 if (flags & G_ARRAY)
1389 *++stack_sp = &sv_undef;
1394 if (op == (OP*)&myop)
1395 op = pp_entereval(ARGS);
1398 retval = stack_sp - (stack_base + oldmark);
1399 if (!(flags & G_KEEPERR))
1400 sv_setpv(GvSV(errgv),"");
1404 if (flags & G_DISCARD) {
1405 stack_sp = stack_base + oldmark;
1415 perl_eval_pv(char *p, I32 croak_on_error)
1419 SV* sv = newSVpv(p, 0);
1422 perl_eval_sv(sv, G_SCALAR);
1429 if (croak_on_error && SvTRUE(GvSV(errgv)))
1430 croak(SvPVx(GvSV(errgv), na));
1435 /* Require a module. */
1438 perl_require_pv(char *pv)
1440 SV* sv = sv_newmortal();
1441 sv_setpv(sv, "require '");
1444 perl_eval_sv(sv, G_DISCARD);
1448 magicname(char *sym, char *name, I32 namlen)
1452 if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
1453 sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
1457 usage(char *name) /* XXX move this out into a module ? */
1460 /* This message really ought to be max 23 lines.
1461 * Removed -h because the user already knows that opton. Others? */
1463 static char *usage[] = {
1464 "-0[octal] specify record separator (\\0, if no argument)",
1465 "-a autosplit mode with -n or -p (splits $_ into @F)",
1466 "-c check syntax only (runs BEGIN and END blocks)",
1467 "-d[:debugger] run scripts under debugger",
1468 "-D[number/list] set debugging flags (argument is a bit mask or flags)",
1469 "-e 'command' one line of script. Several -e's allowed. Omit [programfile].",
1470 "-F/pattern/ split() pattern for autosplit (-a). The //'s are optional.",
1471 "-i[extension] edit <> files in place (make backup if extension supplied)",
1472 "-Idirectory specify @INC/#include directory (may be used more than once)",
1473 "-l[octal] enable line ending processing, specifies line terminator",
1474 "-[mM][-]module.. executes `use/no module...' before executing your script.",
1475 "-n assume 'while (<>) { ... }' loop around your script",
1476 "-p assume loop like -n but print line also like sed",
1477 "-P run script through C preprocessor before compilation",
1478 "-s enable some switch parsing for switches after script name",
1479 "-S look for the script using PATH environment variable",
1480 "-T turn on tainting checks",
1481 "-u dump core after parsing script",
1482 "-U allow unsafe operations",
1483 "-v print version number and patchlevel of perl",
1484 "-V[:variable] print perl configuration information",
1485 "-w TURN WARNINGS ON FOR COMPILATION OF YOUR SCRIPT. Recommended.",
1486 "-x[directory] strip off text before #!perl line and perhaps cd to directory",
1492 printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
1494 printf("\n %s", *p++);
1497 /* This routine handles any switches that can be given during run */
1500 moreswitches(char *s)
1507 rschar = scan_oct(s, 4, &numlen);
1509 if (rschar & ~((U8)~0))
1511 else if (!rschar && numlen >= 2)
1512 nrs = newSVpv("", 0);
1515 nrs = newSVpv(&ch, 1);
1520 splitstr = savepv(s + 1);
1534 if (*s == ':' || *s == '=') {
1535 my_setenv("PERL5DB", form("use Devel::%s;", ++s));
1539 perldb = PERLDB_ALL;
1546 if (isALPHA(s[1])) {
1547 static char debopts[] = "psltocPmfrxuLHXD";
1550 for (s++; *s && (d = strchr(debopts,*s)); s++)
1551 debug |= 1 << (d - debopts);
1555 for (s++; isDIGIT(*s); s++) ;
1557 debug |= 0x80000000;
1559 warn("Recompile perl with -DDEBUGGING to use -D switch\n");
1560 for (s++; isALNUM(*s); s++) ;
1570 inplace = savepv(s+1);
1572 for (s = inplace; *s && !isSPACE(*s); s++) ;
1576 case 'I': /* -I handled both here and in parse_perl() */
1579 while (*s && isSPACE(*s))
1583 for (e = s; *e && !isSPACE(*e); e++) ;
1584 p = savepvn(s, e-s);
1590 croak("No space allowed after -I");
1600 *ors = scan_oct(s, 3 + (*s == '0'), &numlen);
1609 ors = SvPV(nrs, orslen);
1610 ors = savepvn(ors, orslen);
1614 forbid_setid("-M"); /* XXX ? */
1617 forbid_setid("-m"); /* XXX ? */
1622 /* -M-foo == 'no foo' */
1623 if (*s == '-') { use = "no "; ++s; }
1624 sv = newSVpv(use,0);
1626 /* We allow -M'Module qw(Foo Bar)' */
1627 while(isALNUM(*s) || *s==':') ++s;
1629 sv_catpv(sv, start);
1630 if (*(start-1) == 'm') {
1632 croak("Can't use '%c' after -mname", *s);
1633 sv_catpv( sv, " ()");
1636 sv_catpvn(sv, start, s-start);
1637 sv_catpv(sv, " split(/,/,q{");
1642 if (preambleav == NULL)
1643 preambleav = newAV();
1644 av_push(preambleav, sv);
1647 croak("No space allowed after -%c", *(s-1));
1664 croak("Too late for \"-T\" option");
1676 #if defined(SUBVERSION) && SUBVERSION > 0
1677 printf("\nThis is perl, version 5.%03d_%02d built for %s",
1678 PATCHLEVEL, SUBVERSION, ARCHNAME);
1680 printf("\nThis is perl, version %s built for %s",
1681 patchlevel, ARCHNAME);
1683 #if defined(LOCAL_PATCH_COUNT)
1684 if (LOCAL_PATCH_COUNT > 0)
1685 printf("\n(with %d registered patch%s, see perl -V for more detail)",
1686 LOCAL_PATCH_COUNT, (LOCAL_PATCH_COUNT!=1) ? "es" : "");
1689 printf("\n\nCopyright 1987-1997, Larry Wall\n");
1691 printf("\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
1694 printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n");
1697 printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
1698 "Version 5 port Copyright (c) 1994-1997, Andreas Kaiser, Ilya Zakharevich\n");
1701 printf("atariST series port, ++jrb bammi@cadence.com\n");
1704 Perl may be copied only under the terms of either the Artistic License or the\n\
1705 GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n");
1713 if (s[1] == '-') /* Additional switches on #! line. */
1721 #ifdef ALTERNATE_SHEBANG
1722 case 'S': /* OS/2 needs -S on "extproc" line. */
1730 croak("Can't emulate -%.1s on #! line",s);
1735 /* compliments of Tom Christiansen */
1737 /* unexec() can be found in the Gnu emacs distribution */
1748 prog = newSVpv(BIN_EXP);
1749 sv_catpv(prog, "/perl");
1750 file = newSVpv(origfilename);
1751 sv_catpv(file, ".perldump");
1753 status = unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
1755 PerlIO_printf(PerlIO_stderr(), "unexec of %s into %s failed!\n",
1756 SvPVX(prog), SvPVX(file));
1760 # include <lib$routines.h>
1761 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
1763 ABORT(); /* for use with undump */
1769 init_main_stash(void)
1774 /* Note that strtab is a rather special HV. Assumptions are made
1775 about not iterating on it, and not adding tie magic to it.
1776 It is properly deallocated in perl_destruct() */
1778 HvSHAREKEYS_off(strtab); /* mandatory */
1779 Newz(506,((XPVHV*)SvANY(strtab))->xhv_array,
1780 sizeof(HE*) * (((XPVHV*)SvANY(strtab))->xhv_max + 1), char);
1782 curstash = defstash = newHV();
1783 curstname = newSVpv("main",4);
1784 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
1785 SvREFCNT_dec(GvHV(gv));
1786 GvHV(gv) = (HV*)SvREFCNT_inc(defstash);
1788 HvNAME(defstash) = savepv("main");
1789 incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
1791 defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
1792 errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
1794 (void)form("%240s",""); /* Preallocate temp - for immediate signals. */
1795 sv_grow(GvSV(errgv), 240); /* Preallocate - for immediate signals. */
1796 sv_setpvn(GvSV(errgv), "", 0);
1797 curstash = defstash;
1798 compiling.cop_stash = defstash;
1799 debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
1800 /* We must init $/ before switches are processed. */
1801 sv_setpvn(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), "\n", 1);
1804 #ifdef CAN_PROTOTYPE
1806 open_script(char *scriptname, bool dosearch, SV *sv)
1809 open_script(scriptname,dosearch,sv)
1816 char *xfound = Nullch;
1817 char *xfailed = Nullch;
1821 #if defined(DOSISH) && !defined(OS2) && !defined(atarist)
1822 # define SEARCH_EXTS ".bat", ".cmd", NULL
1823 # define MAX_EXT_LEN 4
1826 # define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL
1827 # define MAX_EXT_LEN 4
1830 # define SEARCH_EXTS ".pl", ".com", NULL
1831 # define MAX_EXT_LEN 4
1833 /* additional extensions to try in each dir if scriptname not found */
1835 char *ext[] = { SEARCH_EXTS };
1836 int extidx = 0, i = 0;
1837 char *curext = Nullch;
1839 # define MAX_EXT_LEN 0
1843 * If dosearch is true and if scriptname does not contain path
1844 * delimiters, search the PATH for scriptname.
1846 * If SEARCH_EXTS is also defined, will look for each
1847 * scriptname{SEARCH_EXTS} whenever scriptname is not found
1848 * while searching the PATH.
1850 * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
1851 * proceeds as follows:
1853 * + look for ./scriptname{,.foo,.bar}
1854 * + search the PATH for scriptname{,.foo,.bar}
1857 * + look *only* in the PATH for scriptname{,.foo,.bar} (note
1858 * this will not look in '.' if it's not in the PATH)
1863 int hasdir, idx = 0, deftypes = 1;
1866 hasdir = (strpbrk(scriptname,":[</") != Nullch) ;
1867 /* The first time through, just add SEARCH_EXTS to whatever we
1868 * already have, so we can check for default file types. */
1870 (!hasdir && my_trnlnm("DCL$PATH",tokenbuf,idx++)) )
1876 if ((strlen(tokenbuf) + strlen(scriptname)
1877 + MAX_EXT_LEN) >= sizeof tokenbuf)
1878 continue; /* don't search dir with too-long name */
1879 strcat(tokenbuf, scriptname);
1883 if (strEQ(scriptname, "-"))
1885 if (dosearch) { /* Look in '.' first. */
1886 char *cur = scriptname;
1888 if ((curext = strrchr(scriptname,'.'))) /* possible current ext */
1890 if (strEQ(ext[i++],curext)) {
1891 extidx = -1; /* already has an ext */
1896 DEBUG_p(PerlIO_printf(Perl_debug_log,
1897 "Looking for %s\n",cur));
1898 if (Stat(cur,&statbuf) >= 0) {
1906 if (cur == scriptname) {
1907 len = strlen(scriptname);
1908 if (len+MAX_EXT_LEN+1 >= sizeof(tokenbuf))
1910 cur = strcpy(tokenbuf, scriptname);
1912 } while (extidx >= 0 && ext[extidx] /* try an extension? */
1913 && strcpy(tokenbuf+len, ext[extidx++]));
1918 if (dosearch && !strchr(scriptname, '/')
1920 && !strchr(scriptname, '\\')
1922 && (s = getenv("PATH"))) {
1925 bufend = s + strlen(s);
1926 while (s < bufend) {
1927 #if defined(atarist) || defined(DOSISH)
1932 && *s != ';'; len++, s++) {
1933 if (len < sizeof tokenbuf)
1936 if (len < sizeof tokenbuf)
1937 tokenbuf[len] = '\0';
1938 #else /* ! (atarist || DOSISH) */
1939 s = delimcpy(tokenbuf, tokenbuf + sizeof tokenbuf, s, bufend,
1942 #endif /* ! (atarist || DOSISH) */
1945 if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tokenbuf)
1946 continue; /* don't search dir with too-long name */
1948 #if defined(atarist) || defined(DOSISH)
1949 && tokenbuf[len - 1] != '/'
1950 && tokenbuf[len - 1] != '\\'
1953 tokenbuf[len++] = '/';
1954 if (len == 2 && tokenbuf[0] == '.')
1956 (void)strcpy(tokenbuf + len, scriptname);
1960 len = strlen(tokenbuf);
1961 if (extidx > 0) /* reset after previous loop */
1965 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tokenbuf));
1966 retval = Stat(tokenbuf,&statbuf);
1968 } while ( retval < 0 /* not there */
1969 && extidx>=0 && ext[extidx] /* try an extension? */
1970 && strcpy(tokenbuf+len, ext[extidx++])
1975 if (S_ISREG(statbuf.st_mode)
1976 && cando(S_IRUSR,TRUE,&statbuf)
1978 && cando(S_IXUSR,TRUE,&statbuf)
1982 xfound = tokenbuf; /* bingo! */
1986 xfailed = savepv(tokenbuf);
1989 if (!xfound && !seen_dot && !xfailed && (Stat(scriptname,&statbuf) < 0))
1991 seen_dot = 1; /* Disable message. */
1993 croak("Can't %s %s%s%s",
1994 (xfailed ? "execute" : "find"),
1995 (xfailed ? xfailed : scriptname),
1996 (xfailed ? "" : " on PATH"),
1997 (xfailed || seen_dot) ? "" : ", '.' not in PATH");
2000 scriptname = xfound;
2003 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
2004 char *s = scriptname + 8;
2013 origfilename = savepv(e_tmpname ? "-e" : scriptname);
2014 curcop->cop_filegv = gv_fetchfile(origfilename);
2015 if (strEQ(origfilename,"-"))
2017 if (fdscript >= 0) {
2018 rsfp = PerlIO_fdopen(fdscript,"r");
2019 #if defined(HAS_FCNTL) && defined(F_SETFD)
2021 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
2024 else if (preprocess) {
2025 char *cpp_cfg = CPPSTDIN;
2026 SV *cpp = NEWSV(0,0);
2027 SV *cmd = NEWSV(0,0);
2029 if (strEQ(cpp_cfg, "cppstdin"))
2030 sv_catpvf(cpp, "%s/", BIN_EXP);
2031 sv_catpv(cpp, cpp_cfg);
2034 sv_catpv(sv,PRIVLIB_EXP);
2038 sed %s -e \"/^[^#]/b\" \
2039 -e \"/^#[ ]*include[ ]/b\" \
2040 -e \"/^#[ ]*define[ ]/b\" \
2041 -e \"/^#[ ]*if[ ]/b\" \
2042 -e \"/^#[ ]*ifdef[ ]/b\" \
2043 -e \"/^#[ ]*ifndef[ ]/b\" \
2044 -e \"/^#[ ]*else/b\" \
2045 -e \"/^#[ ]*elif[ ]/b\" \
2046 -e \"/^#[ ]*undef[ ]/b\" \
2047 -e \"/^#[ ]*endif/b\" \
2050 (doextract ? "-e \"1,/^#/d\n\"" : ""),
2053 %s %s -e '/^[^#]/b' \
2054 -e '/^#[ ]*include[ ]/b' \
2055 -e '/^#[ ]*define[ ]/b' \
2056 -e '/^#[ ]*if[ ]/b' \
2057 -e '/^#[ ]*ifdef[ ]/b' \
2058 -e '/^#[ ]*ifndef[ ]/b' \
2059 -e '/^#[ ]*else/b' \
2060 -e '/^#[ ]*elif[ ]/b' \
2061 -e '/^#[ ]*undef[ ]/b' \
2062 -e '/^#[ ]*endif/b' \
2070 (doextract ? "-e '1,/^#/d\n'" : ""),
2072 scriptname, cpp, sv, CPPMINUS);
2074 #ifdef IAMSUID /* actually, this is caught earlier */
2075 if (euid != uid && !euid) { /* if running suidperl */
2077 (void)seteuid(uid); /* musn't stay setuid root */
2080 (void)setreuid((Uid_t)-1, uid);
2082 #ifdef HAS_SETRESUID
2083 (void)setresuid((Uid_t)-1, uid, (Uid_t)-1);
2089 if (geteuid() != uid)
2090 croak("Can't do seteuid!\n");
2092 #endif /* IAMSUID */
2093 rsfp = my_popen(SvPVX(cmd), "r");
2097 else if (!*scriptname) {
2098 forbid_setid("program input from stdin");
2099 rsfp = PerlIO_stdin();
2102 rsfp = PerlIO_open(scriptname,"r");
2103 #if defined(HAS_FCNTL) && defined(F_SETFD)
2105 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
2113 #ifndef IAMSUID /* in case script is not readable before setuid */
2114 if (euid && Stat(SvPVX(GvSV(curcop->cop_filegv)),&statbuf) >= 0 &&
2115 statbuf.st_mode & (S_ISUID|S_ISGID)) {
2117 execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
2118 croak("Can't do setuid\n");
2122 croak("Can't open perl script \"%s\": %s\n",
2123 SvPVX(GvSV(curcop->cop_filegv)), Strerror(errno));
2128 validate_suid(char *validarg, char *scriptname)
2132 /* do we need to emulate setuid on scripts? */
2134 /* This code is for those BSD systems that have setuid #! scripts disabled
2135 * in the kernel because of a security problem. Merely defining DOSUID
2136 * in perl will not fix that problem, but if you have disabled setuid
2137 * scripts in the kernel, this will attempt to emulate setuid and setgid
2138 * on scripts that have those now-otherwise-useless bits set. The setuid
2139 * root version must be called suidperl or sperlN.NNN. If regular perl
2140 * discovers that it has opened a setuid script, it calls suidperl with
2141 * the same argv that it had. If suidperl finds that the script it has
2142 * just opened is NOT setuid root, it sets the effective uid back to the
2143 * uid. We don't just make perl setuid root because that loses the
2144 * effective uid we had before invoking perl, if it was different from the
2147 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
2148 * be defined in suidperl only. suidperl must be setuid root. The
2149 * Configure script will set this up for you if you want it.
2156 if (Fstat(PerlIO_fileno(rsfp),&statbuf) < 0) /* normal stat is insecure */
2157 croak("Can't stat script \"%s\"",origfilename);
2158 if (fdscript < 0 && statbuf.st_mode & (S_ISUID|S_ISGID)) {
2162 #ifndef HAS_SETREUID
2163 /* On this access check to make sure the directories are readable,
2164 * there is actually a small window that the user could use to make
2165 * filename point to an accessible directory. So there is a faint
2166 * chance that someone could execute a setuid script down in a
2167 * non-accessible directory. I don't know what to do about that.
2168 * But I don't think it's too important. The manual lies when
2169 * it says access() is useful in setuid programs.
2171 if (access(SvPVX(GvSV(curcop->cop_filegv)),1)) /*double check*/
2172 croak("Permission denied");
2174 /* If we can swap euid and uid, then we can determine access rights
2175 * with a simple stat of the file, and then compare device and
2176 * inode to make sure we did stat() on the same file we opened.
2177 * Then we just have to make sure he or she can execute it.
2180 struct stat tmpstatbuf;
2184 setreuid(euid,uid) < 0
2187 setresuid(euid,uid,(Uid_t)-1) < 0
2190 || getuid() != euid || geteuid() != uid)
2191 croak("Can't swap uid and euid"); /* really paranoid */
2192 if (Stat(SvPVX(GvSV(curcop->cop_filegv)),&tmpstatbuf) < 0)
2193 croak("Permission denied"); /* testing full pathname here */
2194 if (tmpstatbuf.st_dev != statbuf.st_dev ||
2195 tmpstatbuf.st_ino != statbuf.st_ino) {
2196 (void)PerlIO_close(rsfp);
2197 if (rsfp = my_popen("/bin/mail root","w")) { /* heh, heh */
2199 "User %ld tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
2200 (Filename of set-id script was %s, uid %ld gid %ld.)\n\nSincerely,\nperl\n",
2201 (long)uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
2202 (long)statbuf.st_dev, (long)statbuf.st_ino,
2203 SvPVX(GvSV(curcop->cop_filegv)),
2204 (long)statbuf.st_uid, (long)statbuf.st_gid);
2205 (void)my_pclose(rsfp);
2207 croak("Permission denied\n");
2211 setreuid(uid,euid) < 0
2213 # if defined(HAS_SETRESUID)
2214 setresuid(uid,euid,(Uid_t)-1) < 0
2217 || getuid() != uid || geteuid() != euid)
2218 croak("Can't reswap uid and euid");
2219 if (!cando(S_IXUSR,FALSE,&statbuf)) /* can real uid exec? */
2220 croak("Permission denied\n");
2222 #endif /* HAS_SETREUID */
2223 #endif /* IAMSUID */
2225 if (!S_ISREG(statbuf.st_mode))
2226 croak("Permission denied");
2227 if (statbuf.st_mode & S_IWOTH)
2228 croak("Setuid/gid script is writable by world");
2229 doswitches = FALSE; /* -s is insecure in suid */
2231 if (sv_gets(linestr, rsfp, 0) == Nullch ||
2232 strnNE(SvPV(linestr,na),"#!",2) ) /* required even on Sys V */
2233 croak("No #! line");
2234 s = SvPV(linestr,na)+2;
2236 while (!isSPACE(*s)) s++;
2237 for (s2 = s; (s2 > SvPV(linestr,na)+2 &&
2238 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
2239 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
2240 croak("Not a perl script");
2241 while (*s == ' ' || *s == '\t') s++;
2243 * #! arg must be what we saw above. They can invoke it by
2244 * mentioning suidperl explicitly, but they may not add any strange
2245 * arguments beyond what #! says if they do invoke suidperl that way.
2247 len = strlen(validarg);
2248 if (strEQ(validarg," PHOOEY ") ||
2249 strnNE(s,validarg,len) || !isSPACE(s[len]))
2250 croak("Args must match #! line");
2253 if (euid != uid && (statbuf.st_mode & S_ISUID) &&
2254 euid == statbuf.st_uid)
2256 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2257 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2258 #endif /* IAMSUID */
2260 if (euid) { /* oops, we're not the setuid root perl */
2261 (void)PerlIO_close(rsfp);
2264 execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
2266 croak("Can't do setuid\n");
2269 if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid) {
2271 (void)setegid(statbuf.st_gid);
2274 (void)setregid((Gid_t)-1,statbuf.st_gid);
2276 #ifdef HAS_SETRESGID
2277 (void)setresgid((Gid_t)-1,statbuf.st_gid,(Gid_t)-1);
2279 setgid(statbuf.st_gid);
2283 if (getegid() != statbuf.st_gid)
2284 croak("Can't do setegid!\n");
2286 if (statbuf.st_mode & S_ISUID) {
2287 if (statbuf.st_uid != euid)
2289 (void)seteuid(statbuf.st_uid); /* all that for this */
2292 (void)setreuid((Uid_t)-1,statbuf.st_uid);
2294 #ifdef HAS_SETRESUID
2295 (void)setresuid((Uid_t)-1,statbuf.st_uid,(Uid_t)-1);
2297 setuid(statbuf.st_uid);
2301 if (geteuid() != statbuf.st_uid)
2302 croak("Can't do seteuid!\n");
2304 else if (uid) { /* oops, mustn't run as root */
2306 (void)seteuid((Uid_t)uid);
2309 (void)setreuid((Uid_t)-1,(Uid_t)uid);
2311 #ifdef HAS_SETRESUID
2312 (void)setresuid((Uid_t)-1,(Uid_t)uid,(Uid_t)-1);
2318 if (geteuid() != uid)
2319 croak("Can't do seteuid!\n");
2322 if (!cando(S_IXUSR,TRUE,&statbuf))
2323 croak("Permission denied\n"); /* they can't do this */
2326 else if (preprocess)
2327 croak("-P not allowed for setuid/setgid script\n");
2328 else if (fdscript >= 0)
2329 croak("fd script not allowed in suidperl\n");
2331 croak("Script is not setuid/setgid in suidperl\n");
2333 /* We absolutely must clear out any saved ids here, so we */
2334 /* exec the real perl, substituting fd script for scriptname. */
2335 /* (We pass script name as "subdir" of fd, which perl will grok.) */
2336 PerlIO_rewind(rsfp);
2337 lseek(PerlIO_fileno(rsfp),(Off_t)0,0); /* just in case rewind didn't */
2338 for (which = 1; origargv[which] && origargv[which] != scriptname; which++) ;
2339 if (!origargv[which])
2340 croak("Permission denied");
2341 origargv[which] = savepv(form("/dev/fd/%d/%s",
2342 PerlIO_fileno(rsfp), origargv[which]));
2343 #if defined(HAS_FCNTL) && defined(F_SETFD)
2344 fcntl(PerlIO_fileno(rsfp),F_SETFD,0); /* ensure no close-on-exec */
2346 execv(form("%s/perl%s", BIN_EXP, patchlevel), origargv); /* try again */
2347 croak("Can't do setuid\n");
2348 #endif /* IAMSUID */
2350 if (euid != uid || egid != gid) { /* (suidperl doesn't exist, in fact) */
2351 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
2353 Fstat(PerlIO_fileno(rsfp),&statbuf); /* may be either wrapped or real suid */
2354 if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
2356 (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
2359 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2360 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2361 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
2362 /* not set-id, must be wrapped */
2368 find_beginning(void)
2370 register char *s, *s2;
2372 /* skip forward in input to the real script? */
2376 if ((s = sv_gets(linestr, rsfp, 0)) == Nullch)
2377 croak("No Perl script found in input\n");
2378 if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
2379 PerlIO_ungetc(rsfp, '\n'); /* to keep line count right */
2381 while (*s && !(isSPACE (*s) || *s == '#')) s++;
2383 while (*s == ' ' || *s == '\t') s++;
2385 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
2386 if (strnEQ(s2-4,"perl",4))
2388 while (s = moreswitches(s)) ;
2390 if (cddir && chdir(cddir) < 0)
2391 croak("Can't chdir to %s",cddir);
2399 uid = (int)getuid();
2400 euid = (int)geteuid();
2401 gid = (int)getgid();
2402 egid = (int)getegid();
2407 tainting |= (uid && (euid != uid || egid != gid));
2411 forbid_setid(char *s)
2414 croak("No %s allowed while running setuid", s);
2416 croak("No %s allowed while running setgid", s);
2423 curstash = debstash;
2424 dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
2426 DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
2427 DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
2428 DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
2429 DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
2430 sv_setiv(DBsingle, 0);
2431 DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
2432 sv_setiv(DBtrace, 0);
2433 DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
2434 sv_setiv(DBsignal, 0);
2435 curstash = defstash;
2439 init_stacks(ARGSproto)
2442 mainstack = curstack; /* remember in case we switch stacks */
2443 AvREAL_off(curstack); /* not a real array */
2444 av_extend(curstack,127);
2446 stack_base = AvARRAY(curstack);
2447 stack_sp = stack_base;
2448 stack_max = stack_base + 127;
2450 cxstack_max = 8192 / sizeof(CONTEXT) - 2; /* Use most of 8K. */
2451 New(50,cxstack,cxstack_max + 1,CONTEXT);
2454 New(50,tmps_stack,128,SV*);
2460 * The following stacks almost certainly should be per-interpreter,
2461 * but for now they're not. XXX
2465 markstack_ptr = markstack;
2467 New(54,markstack,64,I32);
2468 markstack_ptr = markstack;
2469 markstack_max = markstack + 64;
2475 New(54,scopestack,32,I32);
2477 scopestack_max = 32;
2483 New(54,savestack,128,ANY);
2485 savestack_max = 128;
2491 New(54,retstack,16,OP*);
2502 Safefree(tmps_stack);
2509 static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
2518 subname = newSVpv("main",4);
2522 init_predump_symbols(void)
2528 sv_setpvn(GvSV(gv_fetchpv("\"", TRUE, SVt_PV)), " ", 1);
2530 stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
2531 GvMULTI_on(stdingv);
2532 IoIFP(GvIOp(stdingv)) = PerlIO_stdin();
2533 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
2535 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(stdingv));
2537 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
2539 IoOFP(GvIOp(tmpgv)) = IoIFP(GvIOp(tmpgv)) = PerlIO_stdout();
2541 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
2543 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(defoutgv));
2545 othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
2546 GvMULTI_on(othergv);
2547 IoOFP(GvIOp(othergv)) = IoIFP(GvIOp(othergv)) = PerlIO_stderr();
2548 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
2550 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(othergv));
2552 statname = NEWSV(66,0); /* last filename we did stat on */
2555 osname = savepv(OSNAME);
2559 init_postdump_symbols(register int argc, register char **argv, register char **env)
2565 argc--,argv++; /* skip name of script */
2567 for (; argc > 0 && **argv == '-'; argc--,argv++) {
2570 if (argv[0][1] == '-') {
2574 if (s = strchr(argv[0], '=')) {
2576 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
2579 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
2582 toptarget = NEWSV(0,0);
2583 sv_upgrade(toptarget, SVt_PVFM);
2584 sv_setpvn(toptarget, "", 0);
2585 bodytarget = NEWSV(0,0);
2586 sv_upgrade(bodytarget, SVt_PVFM);
2587 sv_setpvn(bodytarget, "", 0);
2588 formtarget = bodytarget;
2591 if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
2592 sv_setpv(GvSV(tmpgv),origfilename);
2593 magicname("0", "0", 1);
2595 if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
2596 sv_setpv(GvSV(tmpgv),origargv[0]);
2597 if (argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
2599 (void)gv_AVadd(argvgv);
2600 av_clear(GvAVn(argvgv));
2601 for (; argc > 0; argc--,argv++) {
2602 av_push(GvAVn(argvgv),newSVpv(argv[0],0));
2605 if (envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
2609 hv_magic(hv, envgv, 'E');
2610 #ifndef VMS /* VMS doesn't have environ array */
2611 /* Note that if the supplied env parameter is actually a copy
2612 of the global environ then it may now point to free'd memory
2613 if the environment has been modified since. To avoid this
2614 problem we treat env==NULL as meaning 'use the default'
2619 environ[0] = Nullch;
2620 for (; *env; env++) {
2621 if (!(s = strchr(*env,'=')))
2627 sv = newSVpv(s--,0);
2628 (void)hv_store(hv, *env, s - *env, sv, 0);
2630 #if defined(__BORLANDC__) && defined(USE_WIN32_RTL_ENV)
2631 /* Sins of the RTL. See note in my_setenv(). */
2632 (void)putenv(savepv(*env));
2636 #ifdef DYNAMIC_ENV_FETCH
2637 HvNAME(hv) = savepv(ENV_HV_NAME);
2641 if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
2642 sv_setiv(GvSV(tmpgv), (IV)getpid());
2651 s = getenv("PERL5LIB");
2655 incpush(getenv("PERLLIB"), FALSE);
2657 /* Treat PERL5?LIB as a possible search list logical name -- the
2658 * "natural" VMS idiom for a Unix path string. We allow each
2659 * element to be a set of |-separated directories for compatibility.
2663 if (my_trnlnm("PERL5LIB",buf,0))
2664 do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
2666 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE);
2670 /* Use the ~-expanded versions of APPLLIB (undocumented),
2671 ARCHLIB PRIVLIB SITEARCH SITELIB and OLDARCHLIB
2674 incpush(APPLLIB_EXP, FALSE);
2678 incpush(ARCHLIB_EXP, FALSE);
2681 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
2683 incpush(PRIVLIB_EXP, FALSE);
2686 incpush(SITEARCH_EXP, FALSE);
2689 incpush(SITELIB_EXP, FALSE);
2691 #ifdef OLDARCHLIB_EXP /* 5.00[01] compatibility */
2692 incpush(OLDARCHLIB_EXP, FALSE);
2696 incpush(".", FALSE);
2700 # define PERLLIB_SEP ';'
2703 # define PERLLIB_SEP '|'
2705 # define PERLLIB_SEP ':'
2708 #ifndef PERLLIB_MANGLE
2709 # define PERLLIB_MANGLE(s,n) (s)
2713 incpush(char *p, int addsubdirs)
2715 SV *subdir = Nullsv;
2716 static char *archpat_auto;
2723 if (!archpat_auto) {
2724 STRLEN len = (sizeof(ARCHNAME) + strlen(patchlevel)
2725 + sizeof("//auto"));
2726 New(55, archpat_auto, len, char);
2727 sprintf(archpat_auto, "/%s/%s/auto", ARCHNAME, patchlevel);
2729 for (len = sizeof(ARCHNAME) + 2;
2730 archpat_auto[len] != '\0' && archpat_auto[len] != '/'; len++)
2731 if (archpat_auto[len] == '.') archpat_auto[len] = '_';
2736 /* Break at all separators */
2738 SV *libdir = newSV(0);
2741 /* skip any consecutive separators */
2742 while ( *p == PERLLIB_SEP ) {
2743 /* Uncomment the next line for PATH semantics */
2744 /* av_push(GvAVn(incgv), newSVpv(".", 1)); */
2748 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
2749 sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
2754 sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
2755 p = Nullch; /* break out */
2759 * BEFORE pushing libdir onto @INC we may first push version- and
2760 * archname-specific sub-directories.
2763 struct stat tmpstatbuf;
2768 if ((unix = tounixspec_ts(SvPV(libdir,na),Nullch)) != Nullch) {
2770 while (unix[len-1] == '/') len--; /* Cosmetic */
2771 sv_usepvn(libdir,unix,len);
2774 PerlIO_printf(PerlIO_stderr(),
2775 "Failed to unixify @INC element \"%s\"\n",
2778 /* .../archname/version if -d .../archname/version/auto */
2779 sv_setsv(subdir, libdir);
2780 sv_catpv(subdir, archpat_auto);
2781 if (Stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2782 S_ISDIR(tmpstatbuf.st_mode))
2783 av_push(GvAVn(incgv),
2784 newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2786 /* .../archname if -d .../archname/auto */
2787 sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME),
2788 strlen(patchlevel) + 1, "", 0);
2789 if (Stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2790 S_ISDIR(tmpstatbuf.st_mode))
2791 av_push(GvAVn(incgv),
2792 newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2795 /* finally push this lib directory on the end of @INC */
2796 av_push(GvAVn(incgv), libdir);
2799 SvREFCNT_dec(subdir);
2803 call_list(I32 oldscope, AV *list)
2806 line_t oldline = curcop->cop_line;
2811 while (AvFILL(list) >= 0) {
2812 CV *cv = (CV*)av_shift(list);
2819 SV* atsv = GvSV(errgv);
2821 perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
2822 (void)SvPV(atsv, len);
2825 curcop = &compiling;
2826 curcop->cop_line = oldline;
2827 if (list == beginav)
2828 sv_catpv(atsv, "BEGIN failed--compilation aborted");
2830 sv_catpv(atsv, "END failed--cleanup aborted");
2831 while (scopestack_ix > oldscope)
2833 croak("%s", SvPVX(atsv));
2841 /* my_exit() was called */
2842 while (scopestack_ix > oldscope)
2845 curstash = defstash;
2847 call_list(oldscope, endav);
2849 curcop = &compiling;
2850 curcop->cop_line = oldline;
2852 if (list == beginav)
2853 croak("BEGIN failed--compilation aborted");
2855 croak("END failed--cleanup aborted");
2861 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
2866 curcop = &compiling;
2867 curcop->cop_line = oldline;
2880 DEBUG_L(PerlIO_printf(Perl_debug_log, "my_exit: thread 0x%lx, status %lu\n",
2881 (unsigned long) thr, (unsigned long) status));
2882 #endif /* USE_THREADS */
2891 STATUS_NATIVE_SET(status);
2898 my_failure_exit(void)
2901 if (vaxc$errno & 1) {
2902 if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
2903 STATUS_NATIVE_SET(44);
2906 if (!vaxc$errno && errno) /* unlikely */
2907 STATUS_NATIVE_SET(44);
2909 STATUS_NATIVE_SET(vaxc$errno);
2913 STATUS_POSIX_SET(errno);
2914 else if (STATUS_POSIX == 0)
2915 STATUS_POSIX_SET(255);
2924 register CONTEXT *cx;
2933 (void)UNLINK(e_tmpname);
2934 Safefree(e_tmpname);
2938 if (cxstack_ix >= 0) {