3 * Copyright (c) 1987-1997 Larry Wall
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
11 * "A ship then new they built for him/of mithril and of elven glass" --Bilbo
16 #include "patchlevel.h"
18 /* XXX If this causes problems, set i_unistd=undef in the hint file. */
23 #if !defined(STANDARD_C) && !defined(HAS_GETENV_PROTOTYPE)
24 char *getenv _((char *)); /* Usually in <stdlib.h> */
27 dEXTCONST char rcsid[] = "perl.c\nPatch level: ###\n";
35 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
45 curcop = &compiling; \
52 laststype = OP_STAT; \
54 maxsysfd = MAXSYSFD; \
61 laststype = OP_STAT; \
65 static void find_beginning _((void));
66 static void forbid_setid _((char *));
67 static void incpush _((char *, int));
68 static void init_ids _((void));
69 static void init_debugger _((void));
70 static void init_lexer _((void));
71 static void init_main_stash _((void));
73 static struct thread * init_main_thread _((void));
74 #endif /* USE_THREADS */
75 static void init_perllib _((void));
76 static void init_postdump_symbols _((int, char **, char **));
77 static void init_predump_symbols _((void));
78 static void my_exit_jump _((void)) __attribute__((noreturn));
79 static void nuke_stacks _((void));
80 static void open_script _((char *, bool, SV *));
81 static void usage _((char *));
82 static void validate_suid _((char *, char*));
84 static int fdscript = -1;
86 #if defined(DEBUGGING) && defined(USE_THREADS) && defined(__linux__)
87 #include <asm/sigcontext.h>
89 catch_sigsegv(int signo, struct sigcontext_struct sc)
91 signal(SIGSEGV, SIG_DFL);
92 fprintf(stderr, "Segmentation fault dereferencing 0x%lx\n"
93 "return_address = 0x%lx, eip = 0x%lx\n",
94 sc.cr2, __builtin_return_address(0), sc.eip);
95 fprintf(stderr, "thread = 0x%lx\n", (unsigned long)THR);
102 PerlInterpreter *sv_interp;
105 New(53, sv_interp, 1, PerlInterpreter);
110 perl_construct( sv_interp )
111 register PerlInterpreter *sv_interp;
117 #endif /* FAKE_THREADS */
118 #endif /* USE_THREADS */
120 if (!(curinterp = sv_interp))
124 Zero(sv_interp, 1, PerlInterpreter);
127 /* Init the real globals (and main thread)? */
132 if (pthread_key_create(&thr_key, 0))
133 croak("panic: pthread_key_create");
134 MUTEX_INIT(&malloc_mutex);
135 MUTEX_INIT(&sv_mutex);
137 * Safe to use basic SV functions from now on (though
138 * not things like mortals or tainting yet).
140 MUTEX_INIT(&eval_mutex);
141 COND_INIT(&eval_cond);
142 MUTEX_INIT(&threads_mutex);
143 COND_INIT(&nthreads_cond);
145 thr = init_main_thread();
146 #endif /* USE_THREADS */
148 linestr = NEWSV(65,80);
149 sv_upgrade(linestr,SVt_PVIV);
151 if (!SvREADONLY(&sv_undef)) {
152 SvREADONLY_on(&sv_undef);
156 SvREADONLY_on(&sv_no);
158 sv_setpv(&sv_yes,Yes);
160 SvREADONLY_on(&sv_yes);
163 nrs = newSVpv("\n", 1);
164 rs = SvREFCNT_inc(nrs);
166 sighandlerp = sighandler;
171 * There is no way we can refer to them from Perl so close them to save
172 * space. The other alternative would be to provide STDAUX and STDPRN
175 (void)fclose(stdaux);
176 (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 */
217 New(51,debname,128,char);
218 New(52,debdelim,128,char);
225 perl_destruct(sv_interp)
226 register PerlInterpreter *sv_interp;
229 int destruct_level; /* 0=none, 1=full, 2=full with checks */
234 #endif /* USE_THREADS */
236 if (!(curinterp = sv_interp))
241 /* Pass 1 on any remaining threads: detach joinables, join zombies */
243 MUTEX_LOCK(&threads_mutex);
244 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
245 "perl_destruct: waiting for %d threads...\n",
247 for (t = thr->next; t != thr; t = t->next) {
248 MUTEX_LOCK(&t->mutex);
249 switch (ThrSTATE(t)) {
252 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
253 "perl_destruct: joining zombie %p\n", t));
254 ThrSETSTATE(t, THRf_DEAD);
255 MUTEX_UNLOCK(&t->mutex);
258 * The SvREFCNT_dec below may take a long time (e.g. av
259 * may contain an object scalar whose destructor gets
260 * called) so we have to unlock threads_mutex and start
263 MUTEX_UNLOCK(&threads_mutex);
265 SvREFCNT_dec((SV*)av);
266 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
267 "perl_destruct: joined zombie %p OK\n", t));
269 case THRf_R_JOINABLE:
270 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
271 "perl_destruct: detaching thread %p\n", t));
272 ThrSETSTATE(t, THRf_R_DETACHED);
274 * We unlock threads_mutex and t->mutex in the opposite order
275 * from which we locked them just so that DETACH won't
276 * deadlock if it panics. It's only a breach of good style
277 * not a bug since they are unlocks not locks.
279 MUTEX_UNLOCK(&threads_mutex);
281 MUTEX_UNLOCK(&t->mutex);
284 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
285 "perl_destruct: ignoring %p (state %u)\n",
287 MUTEX_UNLOCK(&t->mutex);
288 /* fall through and out */
291 /* We leave the above "Pass 1" loop with threads_mutex still locked */
293 /* Pass 2 on remaining threads: wait for the thread count to drop to one */
296 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
297 "perl_destruct: final wait for %d threads\n",
299 COND_WAIT(&nthreads_cond, &threads_mutex);
301 /* At this point, we're the last thread */
302 MUTEX_UNLOCK(&threads_mutex);
303 DEBUG_L(PerlIO_printf(PerlIO_stderr(), "perl_destruct: armageddon has arrived\n"));
304 MUTEX_DESTROY(&threads_mutex);
305 COND_DESTROY(&nthreads_cond);
306 #endif /* !defined(FAKE_THREADS) */
307 #endif /* USE_THREADS */
309 destruct_level = perl_destruct_level;
313 if (s = getenv("PERL_DESTRUCT_LEVEL")) {
315 if (destruct_level < i)
324 /* We must account for everything. */
326 /* Destroy the main CV and syntax tree */
328 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 if (destruct_level == 0){
357 DEBUG_P(debprofdump());
359 /* The exit() function will do everything that needs doing. */
363 /* loosen bonds of global variables */
366 (void)PerlIO_close(rsfp);
370 /* Filters for program text */
371 SvREFCNT_dec(rsfp_filters);
372 rsfp_filters = Nullav;
384 sawampersand = FALSE; /* must save all match strings */
385 sawstudy = FALSE; /* do fbm_instr on all strings */
400 /* magical thingies */
402 Safefree(ofs); /* $, */
405 Safefree(ors); /* $\ */
408 SvREFCNT_dec(nrs); /* $\ helper */
411 multiline = 0; /* $* */
413 SvREFCNT_dec(statname);
417 /* defgv, aka *_ should be taken care of elsewhere */
419 #if 0 /* just about all regexp stuff, seems to be ok */
421 /* shortcuts to regexp stuff */
426 SAVEFREEOP(oldlastpm); /* for saving regexp context during debugger */
428 regprecomp = NULL; /* uncompiled string. */
429 regparse = NULL; /* Input-scan pointer. */
430 regxend = NULL; /* End of input for compile */
431 regnpar = 0; /* () count. */
432 regcode = NULL; /* Code-emit pointer; ®dummy = don't. */
433 regsize = 0; /* Code size. */
434 regnaughty = 0; /* How bad is this pattern? */
435 regsawback = 0; /* Did we see \1, ...? */
437 reginput = NULL; /* String-input pointer. */
438 regbol = NULL; /* Beginning of input, for ^ check. */
439 regeol = NULL; /* End of input, for $ check. */
440 regstartp = (char **)NULL; /* Pointer to startp array. */
441 regendp = (char **)NULL; /* Ditto for endp. */
442 reglastparen = 0; /* Similarly for lastparen. */
443 regtill = NULL; /* How far we are required to go. */
444 regflags = 0; /* are we folding, multilining? */
445 regprev = (char)NULL; /* char before regbol, \n if none */
449 /* clean up after study() */
450 SvREFCNT_dec(lastscream);
452 Safefree(screamfirst);
454 Safefree(screamnext);
457 /* startup and shutdown function lists */
458 SvREFCNT_dec(beginav);
460 SvREFCNT_dec(initav);
465 /* temp stack during pp_sort() */
466 SvREFCNT_dec(sortstack);
469 /* shortcuts just get cleared */
480 /* reset so print() ends up where we expect */
483 /* Prepare to destruct main symbol table. */
490 if (destruct_level >= 2) {
491 if (scopestack_ix != 0)
492 warn("Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
493 (long)scopestack_ix);
494 if (savestack_ix != 0)
495 warn("Unbalanced saves: %ld more saves than restores\n",
497 if (tmps_floor != -1)
498 warn("Unbalanced tmps: %ld more allocs than frees\n",
499 (long)tmps_floor + 1);
500 if (cxstack_ix != -1)
501 warn("Unbalanced context: %ld more PUSHes than POPs\n",
502 (long)cxstack_ix + 1);
505 /* Now absolutely destruct everything, somehow or other, loops or no. */
507 SvFLAGS(strtab) |= SVTYPEMASK; /* don't clean out strtab now */
508 while (sv_count != 0 && sv_count != last_sv_count) {
509 last_sv_count = sv_count;
512 SvFLAGS(strtab) &= ~SVTYPEMASK;
513 SvFLAGS(strtab) |= SVt_PVHV;
515 /* Destruct the global string table. */
517 /* Yell and reset the HeVAL() slots that are still holding refcounts,
518 * so that sv_free() won't fail on them.
527 array = HvARRAY(strtab);
531 warn("Unbalanced string table refcount: (%d) for \"%s\"",
532 HeVAL(hent) - Nullsv, HeKEY(hent));
533 HeVAL(hent) = Nullsv;
543 SvREFCNT_dec(strtab);
546 warn("Scalars leaked: %ld\n", (long)sv_count);
550 /* No SVs have survived, need to clean out */
554 Safefree(origfilename);
556 hints = 0; /* Reset hints. Should hints be per-interpreter ? */
558 DEBUG_P(debprofdump());
560 MUTEX_DESTROY(&sv_mutex);
561 MUTEX_DESTROY(&malloc_mutex);
562 MUTEX_DESTROY(&eval_mutex);
563 COND_DESTROY(&eval_cond);
565 /* As the penultimate thing, free the non-arena SV for thrsv */
566 Safefree(SvPVX(thrsv));
567 Safefree(SvANY(thrsv));
570 #endif /* USE_THREADS */
572 /* As the absolutely last thing, free the non-arena SV for mess() */
575 /* we know that type >= SVt_PV */
577 Safefree(SvPVX(mess_sv));
578 Safefree(SvANY(mess_sv));
586 PerlInterpreter *sv_interp;
588 if (!(curinterp = sv_interp))
594 perl_parse(sv_interp, xsinit, argc, argv, env)
595 PerlInterpreter *sv_interp;
596 void (*xsinit)_((void));
604 char *scriptname = NULL;
605 VOL bool dosearch = FALSE;
612 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
615 croak("suidperl is no longer needed since the kernel can now execute\n\
616 setuid perl scripts securely.\n");
620 if (!(curinterp = sv_interp))
623 #if defined(NeXT) && defined(__DYNAMIC__)
624 _dyld_lookup_and_bind
625 ("__environ", (unsigned long *) &environ_pointer, NULL);
630 #ifndef VMS /* VMS doesn't have environ array */
631 origenviron = environ;
637 /* Come here if running an undumped a.out. */
639 origfilename = savepv(argv[0]);
641 cxstack_ix = -1; /* start label stack again */
643 init_postdump_symbols(argc,argv,env);
648 curpad = AvARRAY(comppad);
653 SvREFCNT_dec(main_cv);
657 oldscope = scopestack_ix;
665 /* my_exit() was called */
666 while (scopestack_ix > oldscope)
671 call_list(oldscope, endav);
673 return STATUS_NATIVE_EXPORT;
676 PerlIO_printf(PerlIO_stderr(), "panic: top_env\n");
680 sv_setpvn(linestr,"",0);
681 sv = newSVpv("",0); /* first used for -I flags */
685 for (argc--,argv++; argc > 0; argc--,argv++) {
686 if (argv[0][0] != '-' || !argv[0][1])
690 validarg = " PHOOEY ";
715 if (s = moreswitches(s))
725 if (euid != uid || egid != gid)
726 croak("No -e allowed in setuid scripts");
728 e_tmpname = savepv(TMPPATH);
729 (void)mktemp(e_tmpname);
731 croak("Can't mktemp()");
732 e_fp = PerlIO_open(e_tmpname,"w");
734 croak("Cannot open temporary file");
739 PerlIO_puts(e_fp,argv[1]);
743 croak("No code specified for -e");
744 (void)PerlIO_putc(e_fp,'\n');
746 case 'I': /* -I handled both here and in moreswitches() */
748 if (!*++s && (s=argv[1]) != Nullch) {
751 while (s && isSPACE(*s))
755 for (e = s; *e && !isSPACE(*e); e++) ;
762 } /* XXX else croak? */
776 preambleav = newAV();
777 av_push(preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
779 Sv = newSVpv("print myconfig();",0);
781 sv_catpv(Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
783 sv_catpv(Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
785 #if defined(DEBUGGING) || defined(NO_EMBED) || defined(MULTIPLICITY)
786 sv_catpv(Sv,"\" Compile-time options:");
788 sv_catpv(Sv," DEBUGGING");
791 sv_catpv(Sv," NO_EMBED");
794 sv_catpv(Sv," MULTIPLICITY");
796 sv_catpv(Sv,"\\n\",");
798 #if defined(LOCAL_PATCH_COUNT)
799 if (LOCAL_PATCH_COUNT > 0) {
801 sv_catpv(Sv,"\" Locally applied patches:\\n\",");
802 for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
804 sv_catpvf(Sv,"\" \\t%s\\n\",",localpatches[i]);
808 sv_catpvf(Sv,"\" Built under %s\\n\"",OSNAME);
811 sv_catpvf(Sv,",\" Compiled at %s %s\\n\"",__DATE__,__TIME__);
813 sv_catpvf(Sv,",\" Compiled on %s\\n\"",__DATE__);
818 @env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; \
819 print \" \\%ENV:\\n @env\\n\" if @env; \
820 print \" \\@INC:\\n @INC\\n\";");
823 Sv = newSVpv("config_vars(qw(",0);
828 av_push(preambleav, Sv);
829 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
840 if (!*++s || isSPACE(*s)) {
844 /* catch use of gnu style long options */
845 if (strEQ(s, "version")) {
849 if (strEQ(s, "help")) {
856 croak("Unrecognized switch: -%s (-h will show valid options)",s);
861 if (!tainting && (s = getenv("PERL5OPT"))) {
872 if (!strchr("DIMUdmw", *s))
873 croak("Illegal switch in PERL5OPT: -%c", *s);
879 scriptname = argv[0];
881 if (PerlIO_flush(e_fp) || PerlIO_error(e_fp) || PerlIO_close(e_fp)) {
883 warn("Did you forget to compile with -DMULTIPLICITY?");
885 croak("Can't write to temp file for -e: %s", Strerror(errno));
889 scriptname = e_tmpname;
891 else if (scriptname == Nullch) {
893 if ( isatty(PerlIO_fileno(PerlIO_stdin())) )
901 open_script(scriptname,dosearch,sv);
903 validate_suid(validarg, scriptname);
908 main_cv = compcv = (CV*)NEWSV(1104,0);
909 sv_upgrade((SV *)compcv, SVt_PVCV);
913 av_push(comppad, Nullsv);
914 curpad = AvARRAY(comppad);
915 comppad_name = newAV();
916 comppad_name_fill = 0;
917 min_intro_pending = 0;
920 av_store(comppad_name, 0, newSVpv("@_", 2));
921 curpad[0] = (SV*)newAV();
922 SvPADMY_on(curpad[0]); /* XXX Needed? */
924 New(666, CvMUTEXP(compcv), 1, perl_mutex);
925 MUTEX_INIT(CvMUTEXP(compcv));
926 #endif /* USE_THREADS */
928 comppadlist = newAV();
929 AvREAL_off(comppadlist);
930 av_store(comppadlist, 0, (SV*)comppad_name);
931 av_store(comppadlist, 1, (SV*)comppad);
932 CvPADLIST(compcv) = comppadlist;
934 boot_core_UNIVERSAL();
936 (*xsinit)(); /* in case linked C routines want magical variables */
937 #if defined(VMS) || defined(WIN32)
941 #if defined(DEBUGGING) && defined(USE_THREADS) && defined(__linux__)
942 DEBUG_L(signal(SIGSEGV, (void(*)(int))catch_sigsegv););
945 init_predump_symbols();
947 init_postdump_symbols(argc,argv,env);
951 /* now parse the script */
954 if (yyparse() || error_count) {
956 croak("%s had compilation errors.\n", origfilename);
958 croak("Execution of %s aborted due to compilation errors.\n",
962 curcop->cop_line = 0;
966 (void)UNLINK(e_tmpname);
971 /* now that script is parsed, we can modify record separator */
973 rs = SvREFCNT_inc(nrs);
975 sv_setsv(*av_fetch(thr->magicals, find_thread_magical("/"), FALSE), rs);
977 sv_setsv(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), rs);
978 #endif /* USE_THREADS */
989 if ((s=getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
990 dump_mstats("after compilation:");
1001 PerlInterpreter *sv_interp;
1008 if (!(curinterp = sv_interp))
1011 oldscope = scopestack_ix;
1016 cxstack_ix = -1; /* start context stack again */
1019 /* my_exit() was called */
1020 while (scopestack_ix > oldscope)
1023 curstash = defstash;
1025 call_list(oldscope, endav);
1027 if (getenv("PERL_DEBUG_MSTATS"))
1028 dump_mstats("after execution: ");
1031 return STATUS_NATIVE_EXPORT;
1034 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
1039 if (curstack != mainstack) {
1041 SWITCHSTACK(curstack, mainstack);
1046 DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
1047 sawampersand ? "Enabling" : "Omitting"));
1050 DEBUG_x(dump_all());
1051 DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
1053 DEBUG_L(PerlIO_printf(Perl_debug_log, "main thread is 0x%lx\n",
1054 (unsigned long) thr));
1055 #endif /* USE_THREADS */
1058 PerlIO_printf(PerlIO_stderr(), "%s syntax OK\n", origfilename);
1061 if (PERLDB_SINGLE && DBsingle)
1062 sv_setiv(DBsingle, 1);
1064 call_list(oldscope, initav);
1074 else if (main_start) {
1075 CvDEPTH(main_cv) = 1;
1086 perl_get_sv(name, create)
1090 GV* gv = gv_fetchpv(name, create, SVt_PV);
1097 perl_get_av(name, create)
1101 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
1110 perl_get_hv(name, create)
1114 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
1123 perl_get_cv(name, create)
1127 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
1128 if (create && !GvCVu(gv))
1129 return newSUB(start_subparse(FALSE, 0),
1130 newSVOP(OP_CONST, 0, newSVpv(name,0)),
1138 /* Be sure to refetch the stack pointer after calling these routines. */
1141 perl_call_argv(subname, flags, argv)
1143 I32 flags; /* See G_* flags in cop.h */
1144 register char **argv; /* null terminated arg list */
1152 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
1157 return perl_call_pv(subname, flags);
1161 perl_call_pv(subname, flags)
1162 char *subname; /* name of the subroutine */
1163 I32 flags; /* See G_* flags in cop.h */
1165 return perl_call_sv((SV*)perl_get_cv(subname, TRUE), flags);
1169 perl_call_method(methname, flags)
1170 char *methname; /* name of the subroutine */
1171 I32 flags; /* See G_* flags in cop.h */
1178 XPUSHs(sv_2mortal(newSVpv(methname,0)));
1181 return perl_call_sv(*stack_sp--, flags);
1184 /* May be called with any of a CV, a GV, or an SV containing the name. */
1186 perl_call_sv(sv, flags)
1188 I32 flags; /* See G_* flags in cop.h */
1191 LOGOP myop; /* fake syntax tree node */
1197 bool oldcatch = CATCH_GET;
1202 if (flags & G_DISCARD) {
1207 Zero(&myop, 1, LOGOP);
1208 myop.op_next = Nullop;
1209 if (!(flags & G_NOARGS))
1210 myop.op_flags |= OPf_STACKED;
1211 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1212 (flags & G_ARRAY) ? OPf_WANT_LIST :
1217 EXTEND(stack_sp, 1);
1220 oldscope = scopestack_ix;
1222 if (PERLDB_SUB && curstash != debstash
1223 /* Handle first BEGIN of -d. */
1224 && (DBcv || (DBcv = GvCV(DBsub)))
1225 /* Try harder, since this may have been a sighandler, thus
1226 * curstash may be meaningless. */
1227 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != debstash))
1228 op->op_private |= OPpENTERSUB_DB;
1230 if (flags & G_EVAL) {
1231 cLOGOP->op_other = op;
1233 /* we're trying to emulate pp_entertry() here */
1235 register CONTEXT *cx;
1236 I32 gimme = GIMME_V;
1241 push_return(op->op_next);
1242 PUSHBLOCK(cx, CXt_EVAL, stack_sp);
1244 eval_root = op; /* Only needed so that goto works right. */
1247 if (flags & G_KEEPERR)
1262 /* my_exit() was called */
1263 curstash = defstash;
1267 croak("Callback called exit");
1276 stack_sp = stack_base + oldmark;
1277 if (flags & G_ARRAY)
1281 *++stack_sp = &sv_undef;
1289 if (op == (OP*)&myop)
1290 op = pp_entersub(ARGS);
1293 retval = stack_sp - (stack_base + oldmark);
1294 if ((flags & G_EVAL) && !(flags & G_KEEPERR))
1298 if (flags & G_EVAL) {
1299 if (scopestack_ix > oldscope) {
1303 register CONTEXT *cx;
1315 CATCH_SET(oldcatch);
1317 if (flags & G_DISCARD) {
1318 stack_sp = stack_base + oldmark;
1327 /* Eval a string. The G_EVAL flag is always assumed. */
1330 perl_eval_sv(sv, flags)
1332 I32 flags; /* See G_* flags in cop.h */
1335 UNOP myop; /* fake syntax tree node */
1337 I32 oldmark = sp - stack_base;
1344 if (flags & G_DISCARD) {
1352 EXTEND(stack_sp, 1);
1354 oldscope = scopestack_ix;
1356 if (!(flags & G_NOARGS))
1357 myop.op_flags = OPf_STACKED;
1358 myop.op_next = Nullop;
1359 myop.op_type = OP_ENTEREVAL;
1360 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1361 (flags & G_ARRAY) ? OPf_WANT_LIST :
1363 if (flags & G_KEEPERR)
1364 myop.op_flags |= OPf_SPECIAL;
1374 /* my_exit() was called */
1375 curstash = defstash;
1379 croak("Callback called exit");
1388 stack_sp = stack_base + oldmark;
1389 if (flags & G_ARRAY)
1393 *++stack_sp = &sv_undef;
1398 if (op == (OP*)&myop)
1399 op = pp_entereval(ARGS);
1402 retval = stack_sp - (stack_base + oldmark);
1403 if (!(flags & G_KEEPERR))
1408 if (flags & G_DISCARD) {
1409 stack_sp = stack_base + oldmark;
1419 perl_eval_pv(p, croak_on_error)
1425 SV* sv = newSVpv(p, 0);
1428 perl_eval_sv(sv, G_SCALAR);
1435 if (croak_on_error && SvTRUE(errsv))
1436 croak(SvPV(errsv, na));
1441 /* Require a module. */
1447 SV* sv = sv_newmortal();
1448 sv_setpv(sv, "require '");
1451 perl_eval_sv(sv, G_DISCARD);
1455 magicname(sym,name,namlen)
1462 if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
1463 sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
1467 usage(name) /* XXX move this out into a module ? */
1470 /* This message really ought to be max 23 lines.
1471 * Removed -h because the user already knows that opton. Others? */
1473 static char *usage[] = {
1474 "-0[octal] specify record separator (\\0, if no argument)",
1475 "-a autosplit mode with -n or -p (splits $_ into @F)",
1476 "-c check syntax only (runs BEGIN and END blocks)",
1477 "-d[:debugger] run scripts under debugger",
1478 "-D[number/list] set debugging flags (argument is a bit mask or flags)",
1479 "-e 'command' one line of script. Several -e's allowed. Omit [programfile].",
1480 "-F/pattern/ split() pattern for autosplit (-a). The //'s are optional.",
1481 "-i[extension] edit <> files in place (make backup if extension supplied)",
1482 "-Idirectory specify @INC/#include directory (may be used more than once)",
1483 "-l[octal] enable line ending processing, specifies line terminator",
1484 "-[mM][-]module.. executes `use/no module...' before executing your script.",
1485 "-n assume 'while (<>) { ... }' loop around your script",
1486 "-p assume loop like -n but print line also like sed",
1487 "-P run script through C preprocessor before compilation",
1488 "-s enable some switch parsing for switches after script name",
1489 "-S look for the script using PATH environment variable",
1490 "-T turn on tainting checks",
1491 "-u dump core after parsing script",
1492 "-U allow unsafe operations",
1493 "-v print version number and patchlevel of perl",
1494 "-V[:variable] print perl configuration information",
1495 "-w TURN WARNINGS ON FOR COMPILATION OF YOUR SCRIPT. Recommended.",
1496 "-x[directory] strip off text before #!perl line and perhaps cd to directory",
1502 printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
1504 printf("\n %s", *p++);
1507 /* This routine handles any switches that can be given during run */
1520 rschar = scan_oct(s, 4, &numlen);
1522 if (rschar & ~((U8)~0))
1524 else if (!rschar && numlen >= 2)
1525 nrs = newSVpv("", 0);
1528 nrs = newSVpv(&ch, 1);
1534 splitstr = savepv(s + 1);
1548 if (*s == ':' || *s == '=') {
1549 my_setenv("PERL5DB", form("use Devel::%s;", ++s));
1553 perldb = PERLDB_ALL;
1560 if (isALPHA(s[1])) {
1561 static char debopts[] = "psltocPmfrxuLHXD";
1564 for (s++; *s && (d = strchr(debopts,*s)); s++)
1565 debug |= 1 << (d - debopts);
1569 for (s++; isDIGIT(*s); s++) ;
1571 debug |= 0x80000000;
1573 warn("Recompile perl with -DDEBUGGING to use -D switch\n");
1574 for (s++; isALNUM(*s); s++) ;
1584 inplace = savepv(s+1);
1586 for (s = inplace; *s && !isSPACE(*s); s++) ;
1590 case 'I': /* -I handled both here and in parse_perl() */
1593 while (*s && isSPACE(*s))
1597 for (e = s; *e && !isSPACE(*e); e++) ;
1598 p = savepvn(s, e-s);
1604 croak("No space allowed after -I");
1614 *ors = scan_oct(s, 3 + (*s == '0'), &numlen);
1624 ors = SvPV(nrs, orslen);
1625 ors = savepvn(ors, orslen);
1629 forbid_setid("-M"); /* XXX ? */
1632 forbid_setid("-m"); /* XXX ? */
1637 /* -M-foo == 'no foo' */
1638 if (*s == '-') { use = "no "; ++s; }
1639 sv = newSVpv(use,0);
1641 /* We allow -M'Module qw(Foo Bar)' */
1642 while(isALNUM(*s) || *s==':') ++s;
1644 sv_catpv(sv, start);
1645 if (*(start-1) == 'm') {
1647 croak("Can't use '%c' after -mname", *s);
1648 sv_catpv( sv, " ()");
1651 sv_catpvn(sv, start, s-start);
1652 sv_catpv(sv, " split(/,/,q{");
1657 if (preambleav == NULL)
1658 preambleav = newAV();
1659 av_push(preambleav, sv);
1662 croak("No space allowed after -%c", *(s-1));
1679 croak("Too late for \"-T\" option");
1691 #if defined(SUBVERSION) && SUBVERSION > 0
1692 printf("\nThis is perl, version 5.%03d_%02d built for %s",
1693 PATCHLEVEL, SUBVERSION, ARCHNAME);
1695 printf("\nThis is perl, version %s built for %s",
1696 patchlevel, ARCHNAME);
1698 #if defined(LOCAL_PATCH_COUNT)
1699 if (LOCAL_PATCH_COUNT > 0)
1700 printf("\n(with %d registered patch%s, see perl -V for more detail)",
1701 LOCAL_PATCH_COUNT, (LOCAL_PATCH_COUNT!=1) ? "es" : "");
1704 printf("\n\nCopyright 1987-1997, Larry Wall\n");
1706 printf("\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
1709 printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n");
1712 printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
1713 "Version 5 port Copyright (c) 1994-1997, Andreas Kaiser, Ilya Zakharevich\n");
1716 printf("atariST series port, ++jrb bammi@cadence.com\n");
1719 Perl may be copied only under the terms of either the Artistic License or the\n\
1720 GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n");
1728 if (s[1] == '-') /* Additional switches on #! line. */
1736 #ifdef ALTERNATE_SHEBANG
1737 case 'S': /* OS/2 needs -S on "extproc" line. */
1745 croak("Can't emulate -%.1s on #! line",s);
1750 /* compliments of Tom Christiansen */
1752 /* unexec() can be found in the Gnu emacs distribution */
1763 prog = newSVpv(BIN_EXP);
1764 sv_catpv(prog, "/perl");
1765 file = newSVpv(origfilename);
1766 sv_catpv(file, ".perldump");
1768 status = unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
1770 PerlIO_printf(PerlIO_stderr(), "unexec of %s into %s failed!\n",
1771 SvPVX(prog), SvPVX(file));
1775 # include <lib$routines.h>
1776 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
1778 ABORT(); /* for use with undump */
1789 /* Note that strtab is a rather special HV. Assumptions are made
1790 about not iterating on it, and not adding tie magic to it.
1791 It is properly deallocated in perl_destruct() */
1793 HvSHAREKEYS_off(strtab); /* mandatory */
1794 Newz(506,((XPVHV*)SvANY(strtab))->xhv_array,
1795 sizeof(HE*) * (((XPVHV*)SvANY(strtab))->xhv_max + 1), char);
1797 curstash = defstash = newHV();
1798 curstname = newSVpv("main",4);
1799 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
1800 SvREFCNT_dec(GvHV(gv));
1801 GvHV(gv) = (HV*)SvREFCNT_inc(defstash);
1803 HvNAME(defstash) = savepv("main");
1804 incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
1806 defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
1807 errsv = newSVpv("", 0);
1809 (void)form("%240s",""); /* Preallocate temp - for immediate signals. */
1810 sv_grow(errsv, 240); /* Preallocate - for immediate signals. */
1811 sv_setpvn(errsv, "", 0);
1812 curstash = defstash;
1813 compiling.cop_stash = defstash;
1814 debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
1815 /* We must init $/ before switches are processed. */
1816 sv_setpvn(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), "\n", 1);
1819 #ifdef CAN_PROTOTYPE
1821 open_script(char *scriptname, bool dosearch, SV *sv)
1824 open_script(scriptname,dosearch,sv)
1831 char *xfound = Nullch;
1832 char *xfailed = Nullch;
1836 #if defined(DOSISH) && !defined(OS2) && !defined(atarist)
1837 # define SEARCH_EXTS ".bat", ".cmd", NULL
1838 # define MAX_EXT_LEN 4
1841 # define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL
1842 # define MAX_EXT_LEN 4
1845 # define SEARCH_EXTS ".pl", ".com", NULL
1846 # define MAX_EXT_LEN 4
1848 /* additional extensions to try in each dir if scriptname not found */
1850 char *ext[] = { SEARCH_EXTS };
1851 int extidx = 0, i = 0;
1852 char *curext = Nullch;
1854 # define MAX_EXT_LEN 0
1858 * If dosearch is true and if scriptname does not contain path
1859 * delimiters, search the PATH for scriptname.
1861 * If SEARCH_EXTS is also defined, will look for each
1862 * scriptname{SEARCH_EXTS} whenever scriptname is not found
1863 * while searching the PATH.
1865 * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
1866 * proceeds as follows:
1868 * + look for ./scriptname{,.foo,.bar}
1869 * + search the PATH for scriptname{,.foo,.bar}
1872 * + look *only* in the PATH for scriptname{,.foo,.bar} (note
1873 * this will not look in '.' if it's not in the PATH)
1878 int hasdir, idx = 0, deftypes = 1;
1881 hasdir = (strpbrk(scriptname,":[</") != Nullch) ;
1882 /* The first time through, just add SEARCH_EXTS to whatever we
1883 * already have, so we can check for default file types. */
1885 (!hasdir && my_trnlnm("DCL$PATH",tokenbuf,idx++)) )
1891 if ((strlen(tokenbuf) + strlen(scriptname)
1892 + MAX_EXT_LEN) >= sizeof tokenbuf)
1893 continue; /* don't search dir with too-long name */
1894 strcat(tokenbuf, scriptname);
1898 if (strEQ(scriptname, "-"))
1900 if (dosearch) { /* Look in '.' first. */
1901 char *cur = scriptname;
1903 if ((curext = strrchr(scriptname,'.'))) /* possible current ext */
1905 if (strEQ(ext[i++],curext)) {
1906 extidx = -1; /* already has an ext */
1911 DEBUG_p(PerlIO_printf(Perl_debug_log,
1912 "Looking for %s\n",cur));
1913 if (Stat(cur,&statbuf) >= 0) {
1921 if (cur == scriptname) {
1922 len = strlen(scriptname);
1923 if (len+MAX_EXT_LEN+1 >= sizeof(tokenbuf))
1925 cur = strcpy(tokenbuf, scriptname);
1927 } while (extidx >= 0 && ext[extidx] /* try an extension? */
1928 && strcpy(tokenbuf+len, ext[extidx++]));
1933 if (dosearch && !strchr(scriptname, '/')
1935 && !strchr(scriptname, '\\')
1937 && (s = getenv("PATH"))) {
1940 bufend = s + strlen(s);
1941 while (s < bufend) {
1942 #if defined(atarist) || defined(DOSISH)
1947 && *s != ';'; len++, s++) {
1948 if (len < sizeof tokenbuf)
1951 if (len < sizeof tokenbuf)
1952 tokenbuf[len] = '\0';
1953 #else /* ! (atarist || DOSISH) */
1954 s = delimcpy(tokenbuf, tokenbuf + sizeof tokenbuf, s, bufend,
1957 #endif /* ! (atarist || DOSISH) */
1960 if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tokenbuf)
1961 continue; /* don't search dir with too-long name */
1963 #if defined(atarist) || defined(DOSISH)
1964 && tokenbuf[len - 1] != '/'
1965 && tokenbuf[len - 1] != '\\'
1968 tokenbuf[len++] = '/';
1969 if (len == 2 && tokenbuf[0] == '.')
1971 (void)strcpy(tokenbuf + len, scriptname);
1975 len = strlen(tokenbuf);
1976 if (extidx > 0) /* reset after previous loop */
1980 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tokenbuf));
1981 retval = Stat(tokenbuf,&statbuf);
1983 } while ( retval < 0 /* not there */
1984 && extidx>=0 && ext[extidx] /* try an extension? */
1985 && strcpy(tokenbuf+len, ext[extidx++])
1990 if (S_ISREG(statbuf.st_mode)
1991 && cando(S_IRUSR,TRUE,&statbuf)
1993 && cando(S_IXUSR,TRUE,&statbuf)
1997 xfound = tokenbuf; /* bingo! */
2001 xfailed = savepv(tokenbuf);
2004 if (!xfound && !seen_dot && !xfailed && (Stat(scriptname,&statbuf) < 0))
2006 seen_dot = 1; /* Disable message. */
2008 croak("Can't %s %s%s%s",
2009 (xfailed ? "execute" : "find"),
2010 (xfailed ? xfailed : scriptname),
2011 (xfailed ? "" : " on PATH"),
2012 (xfailed || seen_dot) ? "" : ", '.' not in PATH");
2015 scriptname = xfound;
2018 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
2019 char *s = scriptname + 8;
2028 origfilename = savepv(e_tmpname ? "-e" : scriptname);
2029 curcop->cop_filegv = gv_fetchfile(origfilename);
2030 if (strEQ(origfilename,"-"))
2032 if (fdscript >= 0) {
2033 rsfp = PerlIO_fdopen(fdscript,"r");
2034 #if defined(HAS_FCNTL) && defined(F_SETFD)
2036 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
2039 else if (preprocess) {
2040 char *cpp_cfg = CPPSTDIN;
2041 SV *cpp = NEWSV(0,0);
2042 SV *cmd = NEWSV(0,0);
2044 if (strEQ(cpp_cfg, "cppstdin"))
2045 sv_catpvf(cpp, "%s/", BIN_EXP);
2046 sv_catpv(cpp, cpp_cfg);
2049 sv_catpv(sv,PRIVLIB_EXP);
2053 sed %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\" \
2065 (doextract ? "-e \"1,/^#/d\n\"" : ""),
2068 %s %s -e '/^[^#]/b' \
2069 -e '/^#[ ]*include[ ]/b' \
2070 -e '/^#[ ]*define[ ]/b' \
2071 -e '/^#[ ]*if[ ]/b' \
2072 -e '/^#[ ]*ifdef[ ]/b' \
2073 -e '/^#[ ]*ifndef[ ]/b' \
2074 -e '/^#[ ]*else/b' \
2075 -e '/^#[ ]*elif[ ]/b' \
2076 -e '/^#[ ]*undef[ ]/b' \
2077 -e '/^#[ ]*endif/b' \
2085 (doextract ? "-e '1,/^#/d\n'" : ""),
2087 scriptname, cpp, sv, CPPMINUS);
2089 #ifdef IAMSUID /* actually, this is caught earlier */
2090 if (euid != uid && !euid) { /* if running suidperl */
2092 (void)seteuid(uid); /* musn't stay setuid root */
2095 (void)setreuid((Uid_t)-1, uid);
2097 #ifdef HAS_SETRESUID
2098 (void)setresuid((Uid_t)-1, uid, (Uid_t)-1);
2104 if (geteuid() != uid)
2105 croak("Can't do seteuid!\n");
2107 #endif /* IAMSUID */
2108 rsfp = my_popen(SvPVX(cmd), "r");
2112 else if (!*scriptname) {
2113 forbid_setid("program input from stdin");
2114 rsfp = PerlIO_stdin();
2117 rsfp = PerlIO_open(scriptname,"r");
2118 #if defined(HAS_FCNTL) && defined(F_SETFD)
2120 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
2128 #ifndef IAMSUID /* in case script is not readable before setuid */
2129 if (euid && Stat(SvPVX(GvSV(curcop->cop_filegv)),&statbuf) >= 0 &&
2130 statbuf.st_mode & (S_ISUID|S_ISGID)) {
2132 execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
2133 croak("Can't do setuid\n");
2137 croak("Can't open perl script \"%s\": %s\n",
2138 SvPVX(GvSV(curcop->cop_filegv)), Strerror(errno));
2143 validate_suid(validarg, scriptname)
2149 /* do we need to emulate setuid on scripts? */
2151 /* This code is for those BSD systems that have setuid #! scripts disabled
2152 * in the kernel because of a security problem. Merely defining DOSUID
2153 * in perl will not fix that problem, but if you have disabled setuid
2154 * scripts in the kernel, this will attempt to emulate setuid and setgid
2155 * on scripts that have those now-otherwise-useless bits set. The setuid
2156 * root version must be called suidperl or sperlN.NNN. If regular perl
2157 * discovers that it has opened a setuid script, it calls suidperl with
2158 * the same argv that it had. If suidperl finds that the script it has
2159 * just opened is NOT setuid root, it sets the effective uid back to the
2160 * uid. We don't just make perl setuid root because that loses the
2161 * effective uid we had before invoking perl, if it was different from the
2164 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
2165 * be defined in suidperl only. suidperl must be setuid root. The
2166 * Configure script will set this up for you if you want it.
2173 if (Fstat(PerlIO_fileno(rsfp),&statbuf) < 0) /* normal stat is insecure */
2174 croak("Can't stat script \"%s\"",origfilename);
2175 if (fdscript < 0 && statbuf.st_mode & (S_ISUID|S_ISGID)) {
2179 #ifndef HAS_SETREUID
2180 /* On this access check to make sure the directories are readable,
2181 * there is actually a small window that the user could use to make
2182 * filename point to an accessible directory. So there is a faint
2183 * chance that someone could execute a setuid script down in a
2184 * non-accessible directory. I don't know what to do about that.
2185 * But I don't think it's too important. The manual lies when
2186 * it says access() is useful in setuid programs.
2188 if (access(SvPVX(GvSV(curcop->cop_filegv)),1)) /*double check*/
2189 croak("Permission denied");
2191 /* If we can swap euid and uid, then we can determine access rights
2192 * with a simple stat of the file, and then compare device and
2193 * inode to make sure we did stat() on the same file we opened.
2194 * Then we just have to make sure he or she can execute it.
2197 struct stat tmpstatbuf;
2201 setreuid(euid,uid) < 0
2204 setresuid(euid,uid,(Uid_t)-1) < 0
2207 || getuid() != euid || geteuid() != uid)
2208 croak("Can't swap uid and euid"); /* really paranoid */
2209 if (Stat(SvPVX(GvSV(curcop->cop_filegv)),&tmpstatbuf) < 0)
2210 croak("Permission denied"); /* testing full pathname here */
2211 if (tmpstatbuf.st_dev != statbuf.st_dev ||
2212 tmpstatbuf.st_ino != statbuf.st_ino) {
2213 (void)PerlIO_close(rsfp);
2214 if (rsfp = my_popen("/bin/mail root","w")) { /* heh, heh */
2216 "User %ld tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
2217 (Filename of set-id script was %s, uid %ld gid %ld.)\n\nSincerely,\nperl\n",
2218 (long)uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
2219 (long)statbuf.st_dev, (long)statbuf.st_ino,
2220 SvPVX(GvSV(curcop->cop_filegv)),
2221 (long)statbuf.st_uid, (long)statbuf.st_gid);
2222 (void)my_pclose(rsfp);
2224 croak("Permission denied\n");
2228 setreuid(uid,euid) < 0
2230 # if defined(HAS_SETRESUID)
2231 setresuid(uid,euid,(Uid_t)-1) < 0
2234 || getuid() != uid || geteuid() != euid)
2235 croak("Can't reswap uid and euid");
2236 if (!cando(S_IXUSR,FALSE,&statbuf)) /* can real uid exec? */
2237 croak("Permission denied\n");
2239 #endif /* HAS_SETREUID */
2240 #endif /* IAMSUID */
2242 if (!S_ISREG(statbuf.st_mode))
2243 croak("Permission denied");
2244 if (statbuf.st_mode & S_IWOTH)
2245 croak("Setuid/gid script is writable by world");
2246 doswitches = FALSE; /* -s is insecure in suid */
2248 if (sv_gets(linestr, rsfp, 0) == Nullch ||
2249 strnNE(SvPV(linestr,na),"#!",2) ) /* required even on Sys V */
2250 croak("No #! line");
2251 s = SvPV(linestr,na)+2;
2253 while (!isSPACE(*s)) s++;
2254 for (s2 = s; (s2 > SvPV(linestr,na)+2 &&
2255 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
2256 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
2257 croak("Not a perl script");
2258 while (*s == ' ' || *s == '\t') s++;
2260 * #! arg must be what we saw above. They can invoke it by
2261 * mentioning suidperl explicitly, but they may not add any strange
2262 * arguments beyond what #! says if they do invoke suidperl that way.
2264 len = strlen(validarg);
2265 if (strEQ(validarg," PHOOEY ") ||
2266 strnNE(s,validarg,len) || !isSPACE(s[len]))
2267 croak("Args must match #! line");
2270 if (euid != uid && (statbuf.st_mode & S_ISUID) &&
2271 euid == statbuf.st_uid)
2273 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2274 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2275 #endif /* IAMSUID */
2277 if (euid) { /* oops, we're not the setuid root perl */
2278 (void)PerlIO_close(rsfp);
2281 execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
2283 croak("Can't do setuid\n");
2286 if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid) {
2288 (void)setegid(statbuf.st_gid);
2291 (void)setregid((Gid_t)-1,statbuf.st_gid);
2293 #ifdef HAS_SETRESGID
2294 (void)setresgid((Gid_t)-1,statbuf.st_gid,(Gid_t)-1);
2296 setgid(statbuf.st_gid);
2300 if (getegid() != statbuf.st_gid)
2301 croak("Can't do setegid!\n");
2303 if (statbuf.st_mode & S_ISUID) {
2304 if (statbuf.st_uid != euid)
2306 (void)seteuid(statbuf.st_uid); /* all that for this */
2309 (void)setreuid((Uid_t)-1,statbuf.st_uid);
2311 #ifdef HAS_SETRESUID
2312 (void)setresuid((Uid_t)-1,statbuf.st_uid,(Uid_t)-1);
2314 setuid(statbuf.st_uid);
2318 if (geteuid() != statbuf.st_uid)
2319 croak("Can't do seteuid!\n");
2321 else if (uid) { /* oops, mustn't run as root */
2323 (void)seteuid((Uid_t)uid);
2326 (void)setreuid((Uid_t)-1,(Uid_t)uid);
2328 #ifdef HAS_SETRESUID
2329 (void)setresuid((Uid_t)-1,(Uid_t)uid,(Uid_t)-1);
2335 if (geteuid() != uid)
2336 croak("Can't do seteuid!\n");
2339 if (!cando(S_IXUSR,TRUE,&statbuf))
2340 croak("Permission denied\n"); /* they can't do this */
2343 else if (preprocess)
2344 croak("-P not allowed for setuid/setgid script\n");
2345 else if (fdscript >= 0)
2346 croak("fd script not allowed in suidperl\n");
2348 croak("Script is not setuid/setgid in suidperl\n");
2350 /* We absolutely must clear out any saved ids here, so we */
2351 /* exec the real perl, substituting fd script for scriptname. */
2352 /* (We pass script name as "subdir" of fd, which perl will grok.) */
2353 PerlIO_rewind(rsfp);
2354 lseek(PerlIO_fileno(rsfp),(Off_t)0,0); /* just in case rewind didn't */
2355 for (which = 1; origargv[which] && origargv[which] != scriptname; which++) ;
2356 if (!origargv[which])
2357 croak("Permission denied");
2358 origargv[which] = savepv(form("/dev/fd/%d/%s",
2359 PerlIO_fileno(rsfp), origargv[which]));
2360 #if defined(HAS_FCNTL) && defined(F_SETFD)
2361 fcntl(PerlIO_fileno(rsfp),F_SETFD,0); /* ensure no close-on-exec */
2363 execv(form("%s/perl%s", BIN_EXP, patchlevel), origargv); /* try again */
2364 croak("Can't do setuid\n");
2365 #endif /* IAMSUID */
2367 if (euid != uid || egid != gid) { /* (suidperl doesn't exist, in fact) */
2368 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
2370 Fstat(PerlIO_fileno(rsfp),&statbuf); /* may be either wrapped or real suid */
2371 if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
2373 (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
2376 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2377 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2378 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
2379 /* not set-id, must be wrapped */
2387 register char *s, *s2;
2389 /* skip forward in input to the real script? */
2393 if ((s = sv_gets(linestr, rsfp, 0)) == Nullch)
2394 croak("No Perl script found in input\n");
2395 if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
2396 PerlIO_ungetc(rsfp, '\n'); /* to keep line count right */
2398 while (*s && !(isSPACE (*s) || *s == '#')) s++;
2400 while (*s == ' ' || *s == '\t') s++;
2402 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
2403 if (strnEQ(s2-4,"perl",4))
2405 while (s = moreswitches(s)) ;
2407 if (cddir && chdir(cddir) < 0)
2408 croak("Can't chdir to %s",cddir);
2416 uid = (int)getuid();
2417 euid = (int)geteuid();
2418 gid = (int)getgid();
2419 egid = (int)getegid();
2424 tainting |= (uid && (euid != uid || egid != gid));
2432 croak("No %s allowed while running setuid", s);
2434 croak("No %s allowed while running setgid", s);
2441 curstash = debstash;
2442 dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
2444 DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
2445 DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
2446 DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
2447 DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
2448 sv_setiv(DBsingle, 0);
2449 DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
2450 sv_setiv(DBtrace, 0);
2451 DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
2452 sv_setiv(DBsignal, 0);
2453 curstash = defstash;
2461 mainstack = curstack; /* remember in case we switch stacks */
2462 AvREAL_off(curstack); /* not a real array */
2463 av_extend(curstack,127);
2465 stack_base = AvARRAY(curstack);
2466 stack_sp = stack_base;
2467 stack_max = stack_base + 127;
2469 cxstack_max = 8192 / sizeof(CONTEXT) - 2; /* Use most of 8K. */
2470 New(50,cxstack,cxstack_max + 1,CONTEXT);
2473 New(50,tmps_stack,128,SV*);
2479 * The following stacks almost certainly should be per-interpreter,
2480 * but for now they're not. XXX
2484 markstack_ptr = markstack;
2486 New(54,markstack,64,I32);
2487 markstack_ptr = markstack;
2488 markstack_max = markstack + 64;
2494 New(54,scopestack,32,I32);
2496 scopestack_max = 32;
2502 New(54,savestack,128,ANY);
2504 savestack_max = 128;
2510 New(54,retstack,16,OP*);
2521 Safefree(tmps_stack);
2528 static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
2537 subname = newSVpv("main",4);
2541 init_predump_symbols()
2548 sv_setpvn(*av_fetch(thr->magicals,find_thread_magical("\""),FALSE)," ", 1);
2550 sv_setpvn(GvSV(gv_fetchpv("\"", TRUE, SVt_PV)), " ", 1);
2551 #endif /* USE_THREADS */
2553 stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
2554 GvMULTI_on(stdingv);
2555 IoIFP(GvIOp(stdingv)) = PerlIO_stdin();
2556 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
2558 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(stdingv));
2560 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
2562 IoOFP(GvIOp(tmpgv)) = IoIFP(GvIOp(tmpgv)) = PerlIO_stdout();
2564 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
2566 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(defoutgv));
2568 othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
2569 GvMULTI_on(othergv);
2570 IoOFP(GvIOp(othergv)) = IoIFP(GvIOp(othergv)) = PerlIO_stderr();
2571 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
2573 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(othergv));
2575 statname = NEWSV(66,0); /* last filename we did stat on */
2578 osname = savepv(OSNAME);
2582 init_postdump_symbols(argc,argv,env)
2584 register char **argv;
2585 register char **env;
2592 argc--,argv++; /* skip name of script */
2594 for (; argc > 0 && **argv == '-'; argc--,argv++) {
2597 if (argv[0][1] == '-') {
2601 if (s = strchr(argv[0], '=')) {
2603 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
2606 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
2609 toptarget = NEWSV(0,0);
2610 sv_upgrade(toptarget, SVt_PVFM);
2611 sv_setpvn(toptarget, "", 0);
2612 bodytarget = NEWSV(0,0);
2613 sv_upgrade(bodytarget, SVt_PVFM);
2614 sv_setpvn(bodytarget, "", 0);
2615 formtarget = bodytarget;
2618 if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
2619 sv_setpv(GvSV(tmpgv),origfilename);
2620 magicname("0", "0", 1);
2622 if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
2623 sv_setpv(GvSV(tmpgv),origargv[0]);
2624 if (argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
2626 (void)gv_AVadd(argvgv);
2627 av_clear(GvAVn(argvgv));
2628 for (; argc > 0; argc--,argv++) {
2629 av_push(GvAVn(argvgv),newSVpv(argv[0],0));
2632 if (envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
2636 hv_magic(hv, envgv, 'E');
2637 #ifndef VMS /* VMS doesn't have environ array */
2638 /* Note that if the supplied env parameter is actually a copy
2639 of the global environ then it may now point to free'd memory
2640 if the environment has been modified since. To avoid this
2641 problem we treat env==NULL as meaning 'use the default'
2646 environ[0] = Nullch;
2647 for (; *env; env++) {
2648 if (!(s = strchr(*env,'=')))
2654 sv = newSVpv(s--,0);
2655 (void)hv_store(hv, *env, s - *env, sv, 0);
2657 #if defined(__BORLANDC__) && defined(USE_WIN32_RTL_ENV)
2658 /* Sins of the RTL. See note in my_setenv(). */
2659 (void)putenv(savepv(*env));
2663 #ifdef DYNAMIC_ENV_FETCH
2664 HvNAME(hv) = savepv(ENV_HV_NAME);
2668 if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
2669 sv_setiv(GvSV(tmpgv), (IV)getpid());
2678 s = getenv("PERL5LIB");
2682 incpush(getenv("PERLLIB"), FALSE);
2684 /* Treat PERL5?LIB as a possible search list logical name -- the
2685 * "natural" VMS idiom for a Unix path string. We allow each
2686 * element to be a set of |-separated directories for compatibility.
2690 if (my_trnlnm("PERL5LIB",buf,0))
2691 do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
2693 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE);
2697 /* Use the ~-expanded versions of APPLLIB (undocumented),
2698 ARCHLIB PRIVLIB SITEARCH SITELIB and OLDARCHLIB
2701 incpush(APPLLIB_EXP, FALSE);
2705 incpush(ARCHLIB_EXP, FALSE);
2708 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
2710 incpush(PRIVLIB_EXP, FALSE);
2713 incpush(SITEARCH_EXP, FALSE);
2716 incpush(SITELIB_EXP, FALSE);
2718 #ifdef OLDARCHLIB_EXP /* 5.00[01] compatibility */
2719 incpush(OLDARCHLIB_EXP, FALSE);
2723 incpush(".", FALSE);
2727 # define PERLLIB_SEP ';'
2730 # define PERLLIB_SEP '|'
2732 # define PERLLIB_SEP ':'
2735 #ifndef PERLLIB_MANGLE
2736 # define PERLLIB_MANGLE(s,n) (s)
2740 incpush(p, addsubdirs)
2744 SV *subdir = Nullsv;
2745 static char *archpat_auto;
2752 if (!archpat_auto) {
2753 STRLEN len = (sizeof(ARCHNAME) + strlen(patchlevel)
2754 + sizeof("//auto"));
2755 New(55, archpat_auto, len, char);
2756 sprintf(archpat_auto, "/%s/%s/auto", ARCHNAME, patchlevel);
2758 for (len = sizeof(ARCHNAME) + 2;
2759 archpat_auto[len] != '\0' && archpat_auto[len] != '/'; len++)
2760 if (archpat_auto[len] == '.') archpat_auto[len] = '_';
2765 /* Break at all separators */
2767 SV *libdir = newSV(0);
2770 /* skip any consecutive separators */
2771 while ( *p == PERLLIB_SEP ) {
2772 /* Uncomment the next line for PATH semantics */
2773 /* av_push(GvAVn(incgv), newSVpv(".", 1)); */
2777 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
2778 sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
2783 sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
2784 p = Nullch; /* break out */
2788 * BEFORE pushing libdir onto @INC we may first push version- and
2789 * archname-specific sub-directories.
2792 struct stat tmpstatbuf;
2797 if ((unix = tounixspec_ts(SvPV(libdir,na),Nullch)) != Nullch) {
2799 while (unix[len-1] == '/') len--; /* Cosmetic */
2800 sv_usepvn(libdir,unix,len);
2803 PerlIO_printf(PerlIO_stderr(),
2804 "Failed to unixify @INC element \"%s\"\n",
2807 /* .../archname/version if -d .../archname/version/auto */
2808 sv_setsv(subdir, libdir);
2809 sv_catpv(subdir, archpat_auto);
2810 if (Stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2811 S_ISDIR(tmpstatbuf.st_mode))
2812 av_push(GvAVn(incgv),
2813 newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2815 /* .../archname if -d .../archname/auto */
2816 sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME),
2817 strlen(patchlevel) + 1, "", 0);
2818 if (Stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2819 S_ISDIR(tmpstatbuf.st_mode))
2820 av_push(GvAVn(incgv),
2821 newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2824 /* finally push this lib directory on the end of @INC */
2825 av_push(GvAVn(incgv), libdir);
2828 SvREFCNT_dec(subdir);
2832 static struct thread *
2838 Newz(53, thr, 1, struct thread);
2839 curcop = &compiling;
2840 thr->cvcache = newHV();
2841 thr->magicals = newAV();
2842 thr->specific = newAV();
2843 thr->flags = THRf_R_JOINABLE;
2844 MUTEX_INIT(&thr->mutex);
2845 /* Handcraft thrsv similarly to mess_sv */
2846 New(53, thrsv, 1, SV);
2847 Newz(53, xpv, 1, XPV);
2848 SvFLAGS(thrsv) = SVt_PV;
2849 SvANY(thrsv) = (void*)xpv;
2850 SvREFCNT(thrsv) = 1 << 30; /* practically infinite */
2851 SvPVX(thrsv) = (char*)thr;
2852 SvCUR_set(thrsv, sizeof(thr));
2853 SvLEN_set(thrsv, sizeof(thr));
2854 *SvEND(thrsv) = '\0'; /* in the trailing_nul field */
2856 curcop = &compiling;
2859 MUTEX_LOCK(&threads_mutex);
2864 MUTEX_UNLOCK(&threads_mutex);
2866 #ifdef HAVE_THREAD_INTERN
2867 init_thread_intern(thr);
2869 thr->self = pthread_self();
2870 #endif /* HAVE_THREAD_INTERN */
2874 * These must come after the SET_THR because sv_setpvn does
2875 * SvTAINT and the taint fields require dTHR.
2877 toptarget = NEWSV(0,0);
2878 sv_upgrade(toptarget, SVt_PVFM);
2879 sv_setpvn(toptarget, "", 0);
2880 bodytarget = NEWSV(0,0);
2881 sv_upgrade(bodytarget, SVt_PVFM);
2882 sv_setpvn(bodytarget, "", 0);
2883 formtarget = bodytarget;
2886 #endif /* USE_THREADS */
2889 call_list(oldscope, list)
2894 line_t oldline = curcop->cop_line;
2899 while (AvFILL(list) >= 0) {
2900 CV *cv = (CV*)av_shift(list);
2908 perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
2909 (void)SvPV(errsv, len);
2912 curcop = &compiling;
2913 curcop->cop_line = oldline;
2914 if (list == beginav)
2915 sv_catpv(errsv, "BEGIN failed--compilation aborted");
2917 sv_catpv(errsv, "END failed--cleanup aborted");
2918 while (scopestack_ix > oldscope)
2920 croak("%s", SvPVX(errsv));
2928 /* my_exit() was called */
2929 while (scopestack_ix > oldscope)
2932 curstash = defstash;
2934 call_list(oldscope, endav);
2936 curcop = &compiling;
2937 curcop->cop_line = oldline;
2939 if (list == beginav)
2940 croak("BEGIN failed--compilation aborted");
2942 croak("END failed--cleanup aborted");
2948 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
2953 curcop = &compiling;
2954 curcop->cop_line = oldline;
2968 DEBUG_L(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
2969 thr, (unsigned long) status));
2970 #endif /* USE_THREADS */
2979 STATUS_NATIVE_SET(status);
2989 if (vaxc$errno & 1) {
2990 if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
2991 STATUS_NATIVE_SET(44);
2994 if (!vaxc$errno && errno) /* unlikely */
2995 STATUS_NATIVE_SET(44);
2997 STATUS_NATIVE_SET(vaxc$errno);
3001 STATUS_POSIX_SET(errno);
3002 else if (STATUS_POSIX == 0)
3003 STATUS_POSIX_SET(255);
3012 register CONTEXT *cx;
3021 (void)UNLINK(e_tmpname);
3022 Safefree(e_tmpname);
3026 if (cxstack_ix >= 0) {