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( sv_interp )
108 register PerlInterpreter *sv_interp;
110 #if defined(USE_THREADS) && !defined(FAKE_THREADS)
114 if (!(curinterp = sv_interp))
118 Zero(sv_interp, 1, PerlInterpreter);
121 /* Init the real globals (and main thread)? */
125 Newz(53, thr, 1, struct thread);
126 MUTEX_INIT(&malloc_mutex);
127 MUTEX_INIT(&sv_mutex);
128 MUTEX_INIT(&eval_mutex);
129 COND_INIT(&eval_cond);
130 MUTEX_INIT(&threads_mutex);
131 COND_INIT(&nthreads_cond);
135 thr->flags = THRf_R_JOINABLE;
136 MUTEX_INIT(&thr->mutex);
140 #ifdef HAVE_THREAD_INTERN
141 init_thread_intern(thr);
144 DuplicateHandle(GetCurrentProcess(),
150 DUPLICATE_SAME_ACCESS);
151 /* XXX TlsAlloc() should probably be done in the DLL entry
154 if ((thr_key = TlsAlloc()) == TLS_OUT_OF_INDEXES)
155 croak("panic: pthread_key_create");
156 if (TlsSetValue(thr_key, (LPVOID) thr) != TRUE)
157 croak("panic: pthread_setspecific");
159 self = pthread_self();
160 if (pthread_key_create(&thr_key, 0))
161 croak("panic: pthread_key_create");
162 if (pthread_setspecific(thr_key, (void *) thr))
163 croak("panic: pthread_setspecific");
165 #endif /* FAKE_THREADS */
166 #endif /* USE_THREADS */
168 linestr = NEWSV(65,80);
169 sv_upgrade(linestr,SVt_PVIV);
171 if (!SvREADONLY(&sv_undef)) {
172 SvREADONLY_on(&sv_undef);
176 SvREADONLY_on(&sv_no);
178 sv_setpv(&sv_yes,Yes);
180 SvREADONLY_on(&sv_yes);
183 nrs = newSVpv("\n", 1);
184 rs = SvREFCNT_inc(nrs);
186 sighandlerp = sighandler;
191 * There is no way we can refer to them from Perl so close them to save
192 * space. The other alternative would be to provide STDAUX and STDPRN
195 (void)fclose(stdaux);
196 (void)fclose(stdprn);
202 perl_destruct_level = 1;
204 if(perl_destruct_level > 0)
210 start_env.je_prev = NULL;
211 start_env.je_ret = -1;
212 start_env.je_mustcatch = TRUE;
213 top_env = &start_env;
216 SET_NUMERIC_STANDARD();
217 #if defined(SUBVERSION) && SUBVERSION > 0
218 sprintf(patchlevel, "%7.5f", (double) 5
219 + ((double) PATCHLEVEL / (double) 1000)
220 + ((double) SUBVERSION / (double) 100000));
222 sprintf(patchlevel, "%5.3f", (double) 5 +
223 ((double) PATCHLEVEL / (double) 1000));
226 #if defined(LOCAL_PATCH_COUNT)
227 localpatches = local_patches; /* For possible -v */
230 PerlIO_init(); /* Hook to IO system */
232 fdpid = newAV(); /* for remembering popen pids by fd */
236 New(51,debname,128,char);
237 New(52,debdelim,128,char);
244 perl_destruct(sv_interp)
245 register PerlInterpreter *sv_interp;
248 int destruct_level; /* 0=none, 1=full, 2=full with checks */
253 if (!(curinterp = sv_interp))
258 /* Join with any remaining non-detached threads */
259 MUTEX_LOCK(&threads_mutex);
260 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
261 "perl_destruct: waiting for %d threads...\n",
263 for (t = thr->next; t != thr; t = t->next) {
264 MUTEX_LOCK(&t->mutex);
265 switch (ThrSTATE(t)) {
268 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
269 "perl_destruct: joining zombie %p\n", t));
270 ThrSETSTATE(t, THRf_DEAD);
271 MUTEX_UNLOCK(&t->mutex);
273 MUTEX_UNLOCK(&threads_mutex);
274 if (pthread_join(t->Tself, (void**)&av))
275 croak("panic: pthread_join failed during global destruction");
276 SvREFCNT_dec((SV*)av);
277 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
278 "perl_destruct: joined zombie %p OK\n", t));
280 case THRf_R_JOINABLE:
281 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
282 "perl_destruct: detaching thread %p\n", t));
283 ThrSETSTATE(t, THRf_R_DETACHED);
285 * We unlock threads_mutex and t->mutex in the opposite order
286 * from which we locked them just so that DETACH won't
287 * deadlock if it panics. It's only a breach of good style
288 * not a bug since they are unlocks not locks.
290 MUTEX_UNLOCK(&threads_mutex);
292 MUTEX_UNLOCK(&t->mutex);
295 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
296 "perl_destruct: ignoring %p (state %u)\n",
298 MUTEX_UNLOCK(&t->mutex);
299 MUTEX_UNLOCK(&threads_mutex);
300 /* fall through and out */
303 /* Now wait for the thread count nthreads to drop to one */
306 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
307 "perl_destruct: final wait for %d threads\n",
309 COND_WAIT(&nthreads_cond, &threads_mutex);
311 /* At this point, we're the last thread */
312 MUTEX_UNLOCK(&threads_mutex);
313 DEBUG_L(PerlIO_printf(PerlIO_stderr(), "perl_destruct: armageddon has arrived\n"));
314 MUTEX_DESTROY(&threads_mutex);
315 COND_DESTROY(&nthreads_cond);
316 #endif /* !defined(FAKE_THREADS) */
317 #endif /* USE_THREADS */
319 destruct_level = perl_destruct_level;
323 if (s = getenv("PERL_DESTRUCT_LEVEL")) {
325 if (destruct_level < i)
334 /* We must account for everything. */
336 /* Destroy the main CV and syntax tree */
338 curpad = AvARRAY(comppad);
343 SvREFCNT_dec(main_cv);
348 * Try to destruct global references. We do this first so that the
349 * destructors and destructees still exist. Some sv's might remain.
350 * Non-referenced objects are on their own.
357 /* unhook hooks which will soon be, or use, destroyed data */
358 SvREFCNT_dec(warnhook);
360 SvREFCNT_dec(diehook);
362 SvREFCNT_dec(parsehook);
365 if (destruct_level == 0){
367 DEBUG_P(debprofdump());
369 /* The exit() function will do everything that needs doing. */
373 /* loosen bonds of global variables */
376 (void)PerlIO_close(rsfp);
380 /* Filters for program text */
381 SvREFCNT_dec(rsfp_filters);
382 rsfp_filters = Nullav;
394 sawampersand = FALSE; /* must save all match strings */
395 sawstudy = FALSE; /* do fbm_instr on all strings */
410 /* magical thingies */
412 Safefree(ofs); /* $, */
415 Safefree(ors); /* $\ */
418 SvREFCNT_dec(nrs); /* $\ helper */
421 multiline = 0; /* $* */
423 SvREFCNT_dec(statname);
427 /* defgv, aka *_ should be taken care of elsewhere */
429 #if 0 /* just about all regexp stuff, seems to be ok */
431 /* shortcuts to regexp stuff */
436 SAVEFREEOP(oldlastpm); /* for saving regexp context during debugger */
438 regprecomp = NULL; /* uncompiled string. */
439 regparse = NULL; /* Input-scan pointer. */
440 regxend = NULL; /* End of input for compile */
441 regnpar = 0; /* () count. */
442 regcode = NULL; /* Code-emit pointer; ®dummy = don't. */
443 regsize = 0; /* Code size. */
444 regnaughty = 0; /* How bad is this pattern? */
445 regsawback = 0; /* Did we see \1, ...? */
447 reginput = NULL; /* String-input pointer. */
448 regbol = NULL; /* Beginning of input, for ^ check. */
449 regeol = NULL; /* End of input, for $ check. */
450 regstartp = (char **)NULL; /* Pointer to startp array. */
451 regendp = (char **)NULL; /* Ditto for endp. */
452 reglastparen = 0; /* Similarly for lastparen. */
453 regtill = NULL; /* How far we are required to go. */
454 regflags = 0; /* are we folding, multilining? */
455 regprev = (char)NULL; /* char before regbol, \n if none */
459 /* clean up after study() */
460 SvREFCNT_dec(lastscream);
462 Safefree(screamfirst);
464 Safefree(screamnext);
467 /* startup and shutdown function lists */
468 SvREFCNT_dec(beginav);
470 SvREFCNT_dec(initav);
475 /* temp stack during pp_sort() */
476 SvREFCNT_dec(sortstack);
479 /* shortcuts just get cleared */
489 /* reset so print() ends up where we expect */
492 /* Prepare to destruct main symbol table. */
499 if (destruct_level >= 2) {
500 if (scopestack_ix != 0)
501 warn("Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
502 (long)scopestack_ix);
503 if (savestack_ix != 0)
504 warn("Unbalanced saves: %ld more saves than restores\n",
506 if (tmps_floor != -1)
507 warn("Unbalanced tmps: %ld more allocs than frees\n",
508 (long)tmps_floor + 1);
509 if (cxstack_ix != -1)
510 warn("Unbalanced context: %ld more PUSHes than POPs\n",
511 (long)cxstack_ix + 1);
514 /* Now absolutely destruct everything, somehow or other, loops or no. */
516 SvFLAGS(strtab) |= SVTYPEMASK; /* don't clean out strtab now */
517 while (sv_count != 0 && sv_count != last_sv_count) {
518 last_sv_count = sv_count;
521 SvFLAGS(strtab) &= ~SVTYPEMASK;
522 SvFLAGS(strtab) |= SVt_PVHV;
524 /* Destruct the global string table. */
526 /* Yell and reset the HeVAL() slots that are still holding refcounts,
527 * so that sv_free() won't fail on them.
536 array = HvARRAY(strtab);
540 warn("Unbalanced string table refcount: (%d) for \"%s\"",
541 HeVAL(hent) - Nullsv, HeKEY(hent));
542 HeVAL(hent) = Nullsv;
552 SvREFCNT_dec(strtab);
555 warn("Scalars leaked: %ld\n", (long)sv_count);
559 /* No SVs have survived, need to clean out */
563 Safefree(origfilename);
565 hints = 0; /* Reset hints. Should hints be per-interpreter ? */
567 DEBUG_P(debprofdump());
569 MUTEX_DESTROY(&sv_mutex);
570 MUTEX_DESTROY(&malloc_mutex);
571 MUTEX_DESTROY(&eval_mutex);
572 COND_DESTROY(&eval_cond);
573 #endif /* USE_THREADS */
575 /* As the absolutely last thing, free the non-arena SV for mess() */
578 /* we know that type >= SVt_PV */
580 Safefree(SvPVX(mess_sv));
581 Safefree(SvANY(mess_sv));
589 PerlInterpreter *sv_interp;
591 if (!(curinterp = sv_interp))
597 perl_parse(sv_interp, xsinit, argc, argv, env)
598 PerlInterpreter *sv_interp;
599 void (*xsinit)_((void));
607 char *scriptname = NULL;
608 VOL bool dosearch = FALSE;
615 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
618 croak("suidperl is no longer needed since the kernel can now execute\n\
619 setuid perl scripts securely.\n");
623 if (!(curinterp = sv_interp))
626 #if defined(NeXT) && defined(__DYNAMIC__)
627 _dyld_lookup_and_bind
628 ("__environ", (unsigned long *) &environ_pointer, NULL);
633 #ifndef VMS /* VMS doesn't have environ array */
634 origenviron = environ;
640 /* Come here if running an undumped a.out. */
642 origfilename = savepv(argv[0]);
644 cxstack_ix = -1; /* start label stack again */
646 init_postdump_symbols(argc,argv,env);
651 curpad = AvARRAY(comppad);
656 SvREFCNT_dec(main_cv);
660 oldscope = scopestack_ix;
668 /* my_exit() was called */
669 while (scopestack_ix > oldscope)
674 call_list(oldscope, endav);
676 return STATUS_NATIVE_EXPORT;
679 PerlIO_printf(PerlIO_stderr(), "panic: top_env\n");
683 sv_setpvn(linestr,"",0);
684 sv = newSVpv("",0); /* first used for -I flags */
688 for (argc--,argv++; argc > 0; argc--,argv++) {
689 if (argv[0][0] != '-' || !argv[0][1])
693 validarg = " PHOOEY ";
718 if (s = moreswitches(s))
728 if (euid != uid || egid != gid)
729 croak("No -e allowed in setuid scripts");
731 e_tmpname = savepv(TMPPATH);
732 (void)mktemp(e_tmpname);
734 croak("Can't mktemp()");
735 e_fp = PerlIO_open(e_tmpname,"w");
737 croak("Cannot open temporary file");
742 PerlIO_puts(e_fp,argv[1]);
746 croak("No code specified for -e");
747 (void)PerlIO_putc(e_fp,'\n');
758 incpush(argv[1], TRUE);
759 sv_catpv(sv,argv[1]);
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 */
838 if (*++s) { /* catch use of gnu style long options */
839 if (strEQ(s, "version")) {
843 if (strEQ(s, "help")) {
847 croak("Unrecognized switch: --%s (-h will show valid options)",s);
854 croak("Unrecognized switch: -%s (-h will show valid options)",s);
859 if (!tainting && (s = getenv("PERL5OPT"))) {
870 if (!strchr("DIMUdmw", *s))
871 croak("Illegal switch in PERL5OPT: -%c", *s);
877 scriptname = argv[0];
879 if (PerlIO_flush(e_fp) || PerlIO_error(e_fp) || PerlIO_close(e_fp)) {
881 warn("Did you forget to compile with -DMULTIPLICITY?");
883 croak("Can't write to temp file for -e: %s", Strerror(errno));
887 scriptname = e_tmpname;
889 else if (scriptname == Nullch) {
891 if ( isatty(PerlIO_fileno(PerlIO_stdin())) )
899 open_script(scriptname,dosearch,sv);
901 validate_suid(validarg, scriptname);
906 main_cv = compcv = (CV*)NEWSV(1104,0);
907 sv_upgrade((SV *)compcv, SVt_PVCV);
911 av_push(comppad, Nullsv);
912 curpad = AvARRAY(comppad);
913 comppad_name = newAV();
914 comppad_name_fill = 0;
915 min_intro_pending = 0;
918 av_store(comppad_name, 0, newSVpv("@_", 2));
919 curpad[0] = (SV*)newAV();
920 SvPADMY_on(curpad[0]); /* XXX Needed? */
922 New(666, CvMUTEXP(compcv), 1, perl_mutex);
923 MUTEX_INIT(CvMUTEXP(compcv));
924 #endif /* USE_THREADS */
926 comppadlist = newAV();
927 AvREAL_off(comppadlist);
928 av_store(comppadlist, 0, (SV*)comppad_name);
929 av_store(comppadlist, 1, (SV*)comppad);
930 CvPADLIST(compcv) = comppadlist;
932 boot_core_UNIVERSAL();
934 (*xsinit)(); /* in case linked C routines want magical variables */
935 #if defined(VMS) || defined(WIN32)
939 #if defined(DEBUGGING) && defined(USE_THREADS) && defined(__linux__)
940 DEBUG_L(signal(SIGSEGV, (void(*)(int))catch_sigsegv););
943 init_predump_symbols();
945 init_postdump_symbols(argc,argv,env);
949 /* now parse the script */
952 if (yyparse() || error_count) {
954 croak("%s had compilation errors.\n", origfilename);
956 croak("Execution of %s aborted due to compilation errors.\n",
960 curcop->cop_line = 0;
964 (void)UNLINK(e_tmpname);
969 /* now that script is parsed, we can modify record separator */
971 rs = SvREFCNT_inc(nrs);
972 sv_setsv(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), rs);
984 if ((s=getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
985 dump_mstats("after compilation:");
996 PerlInterpreter *sv_interp;
1003 if (!(curinterp = sv_interp))
1006 oldscope = scopestack_ix;
1011 cxstack_ix = -1; /* start context stack again */
1014 /* my_exit() was called */
1015 while (scopestack_ix > oldscope)
1018 curstash = defstash;
1020 call_list(oldscope, endav);
1022 if (getenv("PERL_DEBUG_MSTATS"))
1023 dump_mstats("after execution: ");
1026 return STATUS_NATIVE_EXPORT;
1029 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
1034 if (curstack != mainstack) {
1036 SWITCHSTACK(curstack, mainstack);
1041 DEBUG_r(PerlIO_printf(PerlIO_stderr(), "%s $` $& $' support.\n",
1042 sawampersand ? "Enabling" : "Omitting"));
1045 DEBUG_x(dump_all());
1046 DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
1048 DEBUG_L(PerlIO_printf(Perl_debug_log, "main thread is 0x%lx\n",
1049 (unsigned long) thr));
1050 #endif /* USE_THREADS */
1053 PerlIO_printf(PerlIO_stderr(), "%s syntax OK\n", origfilename);
1056 if (PERLDB_SINGLE && DBsingle)
1057 sv_setiv(DBsingle, 1);
1059 call_list(oldscope, initav);
1069 else if (main_start) {
1070 CvDEPTH(main_cv) = 1;
1081 perl_get_sv(name, create)
1085 GV* gv = gv_fetchpv(name, create, SVt_PV);
1092 perl_get_av(name, create)
1096 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
1105 perl_get_hv(name, create)
1109 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
1118 perl_get_cv(name, create)
1122 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
1123 if (create && !GvCVu(gv))
1124 return newSUB(start_subparse(FALSE, 0),
1125 newSVOP(OP_CONST, 0, newSVpv(name,0)),
1133 /* Be sure to refetch the stack pointer after calling these routines. */
1136 perl_call_argv(subname, flags, argv)
1138 I32 flags; /* See G_* flags in cop.h */
1139 register char **argv; /* null terminated arg list */
1147 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
1152 return perl_call_pv(subname, flags);
1156 perl_call_pv(subname, flags)
1157 char *subname; /* name of the subroutine */
1158 I32 flags; /* See G_* flags in cop.h */
1160 return perl_call_sv((SV*)perl_get_cv(subname, TRUE), flags);
1164 perl_call_method(methname, flags)
1165 char *methname; /* name of the subroutine */
1166 I32 flags; /* See G_* flags in cop.h */
1173 XPUSHs(sv_2mortal(newSVpv(methname,0)));
1176 return perl_call_sv(*stack_sp--, flags);
1179 /* May be called with any of a CV, a GV, or an SV containing the name. */
1181 perl_call_sv(sv, flags)
1183 I32 flags; /* See G_* flags in cop.h */
1186 LOGOP myop; /* fake syntax tree node */
1192 bool oldcatch = CATCH_GET;
1197 if (flags & G_DISCARD) {
1202 Zero(&myop, 1, LOGOP);
1203 myop.op_next = Nullop;
1204 if (!(flags & G_NOARGS))
1205 myop.op_flags |= OPf_STACKED;
1206 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1207 (flags & G_ARRAY) ? OPf_WANT_LIST :
1212 EXTEND(stack_sp, 1);
1215 oldscope = scopestack_ix;
1217 if (PERLDB_SUB && curstash != debstash
1218 /* Handle first BEGIN of -d. */
1219 && (DBcv || (DBcv = GvCV(DBsub)))
1220 /* Try harder, since this may have been a sighandler, thus
1221 * curstash may be meaningless. */
1222 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != debstash))
1223 op->op_private |= OPpENTERSUB_DB;
1225 if (flags & G_EVAL) {
1226 cLOGOP->op_other = op;
1228 /* we're trying to emulate pp_entertry() here */
1230 register CONTEXT *cx;
1231 I32 gimme = GIMME_V;
1236 push_return(op->op_next);
1237 PUSHBLOCK(cx, CXt_EVAL, stack_sp);
1239 eval_root = op; /* Only needed so that goto works right. */
1242 if (flags & G_KEEPERR)
1245 sv_setpv(GvSV(errgv),"");
1257 /* my_exit() was called */
1258 curstash = defstash;
1262 croak("Callback called exit");
1271 stack_sp = stack_base + oldmark;
1272 if (flags & G_ARRAY)
1276 *++stack_sp = &sv_undef;
1284 if (op == (OP*)&myop)
1285 op = pp_entersub(ARGS);
1288 retval = stack_sp - (stack_base + oldmark);
1289 if ((flags & G_EVAL) && !(flags & G_KEEPERR))
1290 sv_setpv(GvSV(errgv),"");
1293 if (flags & G_EVAL) {
1294 if (scopestack_ix > oldscope) {
1298 register CONTEXT *cx;
1310 CATCH_SET(oldcatch);
1312 if (flags & G_DISCARD) {
1313 stack_sp = stack_base + oldmark;
1322 /* Eval a string. The G_EVAL flag is always assumed. */
1325 perl_eval_sv(sv, flags)
1327 I32 flags; /* See G_* flags in cop.h */
1330 UNOP myop; /* fake syntax tree node */
1332 I32 oldmark = sp - stack_base;
1339 if (flags & G_DISCARD) {
1347 EXTEND(stack_sp, 1);
1349 oldscope = scopestack_ix;
1351 if (!(flags & G_NOARGS))
1352 myop.op_flags = OPf_STACKED;
1353 myop.op_next = Nullop;
1354 myop.op_type = OP_ENTEREVAL;
1355 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1356 (flags & G_ARRAY) ? OPf_WANT_LIST :
1358 if (flags & G_KEEPERR)
1359 myop.op_flags |= OPf_SPECIAL;
1369 /* my_exit() was called */
1370 curstash = defstash;
1374 croak("Callback called exit");
1383 stack_sp = stack_base + oldmark;
1384 if (flags & G_ARRAY)
1388 *++stack_sp = &sv_undef;
1393 if (op == (OP*)&myop)
1394 op = pp_entereval(ARGS);
1397 retval = stack_sp - (stack_base + oldmark);
1398 if (!(flags & G_KEEPERR))
1399 sv_setpv(GvSV(errgv),"");
1403 if (flags & G_DISCARD) {
1404 stack_sp = stack_base + oldmark;
1414 perl_eval_pv(p, croak_on_error)
1420 SV* sv = newSVpv(p, 0);
1423 perl_eval_sv(sv, G_SCALAR);
1430 if (croak_on_error && SvTRUE(GvSV(errgv)))
1431 croak(SvPVx(GvSV(errgv), na));
1436 /* Require a module. */
1442 SV* sv = sv_newmortal();
1443 sv_setpv(sv, "require '");
1446 perl_eval_sv(sv, G_DISCARD);
1450 magicname(sym,name,namlen)
1457 if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
1458 sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
1462 usage(name) /* XXX move this out into a module ? */
1465 /* This message really ought to be max 23 lines.
1466 * Removed -h because the user already knows that opton. Others? */
1467 printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
1468 printf("\n -0[octal] specify record separator (\\0, if no argument)");
1469 printf("\n -a autosplit mode with -n or -p (splits $_ into @F)");
1470 printf("\n -c check syntax only (runs BEGIN and END blocks)");
1471 printf("\n -d[:debugger] run scripts under debugger");
1472 printf("\n -D[number/list] set debugging flags (argument is a bit mask or flags)");
1473 printf("\n -e 'command' one line of script. Several -e's allowed. Omit [programfile].");
1474 printf("\n -F/pattern/ split() pattern for autosplit (-a). The //'s are optional.");
1475 printf("\n -i[extension] edit <> files in place (make backup if extension supplied)");
1476 printf("\n -Idirectory specify @INC/#include directory (may be used more than once)");
1477 printf("\n -l[octal] enable line ending processing, specifies line terminator");
1478 printf("\n -[mM][-]module.. executes `use/no module...' before executing your script.");
1479 printf("\n -n assume 'while (<>) { ... }' loop around your script");
1480 printf("\n -p assume loop like -n but print line also like sed");
1481 printf("\n -P run script through C preprocessor before compilation");
1482 printf("\n -s enable some switch parsing for switches after script name");
1483 printf("\n -S look for the script using PATH environment variable");
1484 printf("\n -T turn on tainting checks");
1485 printf("\n -u dump core after parsing script");
1486 printf("\n -U allow unsafe operations");
1487 printf("\n -v print version number and patchlevel of perl");
1488 printf("\n -V[:variable] print perl configuration information");
1489 printf("\n -w TURN WARNINGS ON FOR COMPILATION OF YOUR SCRIPT. Recommended.");
1490 printf("\n -x[directory] strip off text before #!perl line and perhaps cd to directory\n");
1493 /* This routine handles any switches that can be given during run */
1504 rschar = scan_oct(s, 4, &numlen);
1506 if (rschar & ~((U8)~0))
1508 else if (!rschar && numlen >= 2)
1509 nrs = newSVpv("", 0);
1512 nrs = newSVpv(&ch, 1);
1517 splitstr = savepv(s + 1);
1531 if (*s == ':' || *s == '=') {
1532 my_setenv("PERL5DB", form("use Devel::%s;", ++s));
1536 perldb = PERLDB_ALL;
1543 if (isALPHA(s[1])) {
1544 static char debopts[] = "psltocPmfrxuLHXD";
1547 for (s++; *s && (d = strchr(debopts,*s)); s++)
1548 debug |= 1 << (d - debopts);
1552 for (s++; isDIGIT(*s); s++) ;
1554 debug |= 0x80000000;
1556 warn("Recompile perl with -DDEBUGGING to use -D switch\n");
1557 for (s++; isALNUM(*s); s++) ;
1567 inplace = savepv(s+1);
1569 for (s = inplace; *s && !isSPACE(*s); s++) ;
1576 for (e = s; *e && !isSPACE(*e); e++) ;
1577 p = savepvn(s, e-s);
1584 croak("No space allowed after -I");
1594 *ors = scan_oct(s, 3 + (*s == '0'), &numlen);
1603 ors = SvPV(nrs, orslen);
1604 ors = savepvn(ors, orslen);
1608 forbid_setid("-M"); /* XXX ? */
1611 forbid_setid("-m"); /* XXX ? */
1616 /* -M-foo == 'no foo' */
1617 if (*s == '-') { use = "no "; ++s; }
1618 sv = newSVpv(use,0);
1620 /* We allow -M'Module qw(Foo Bar)' */
1621 while(isALNUM(*s) || *s==':') ++s;
1623 sv_catpv(sv, start);
1624 if (*(start-1) == 'm') {
1626 croak("Can't use '%c' after -mname", *s);
1627 sv_catpv( sv, " ()");
1630 sv_catpvn(sv, start, s-start);
1631 sv_catpv(sv, " split(/,/,q{");
1636 if (preambleav == NULL)
1637 preambleav = newAV();
1638 av_push(preambleav, sv);
1641 croak("No space allowed after -%c", *(s-1));
1658 croak("Too late for \"-T\" option");
1670 #if defined(SUBVERSION) && SUBVERSION > 0
1671 printf("\nThis is perl, version 5.%03d_%02d", PATCHLEVEL, SUBVERSION);
1673 printf("\nThis is perl, version %s",patchlevel);
1676 printf("\n\nCopyright 1987-1997, Larry Wall\n");
1678 printf("\n\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
1681 printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n");
1684 printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
1685 "Version 5 port Copyright (c) 1994-1997, Andreas Kaiser, Ilya Zakharevich\n");
1688 printf("atariST series port, ++jrb bammi@cadence.com\n");
1691 Perl may be copied only under the terms of either the Artistic License or the\n\
1692 GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n");
1700 if (s[1] == '-') /* Additional switches on #! line. */
1708 #ifdef ALTERNATE_SHEBANG
1709 case 'S': /* OS/2 needs -S on "extproc" line. */
1717 croak("Can't emulate -%.1s on #! line",s);
1722 /* compliments of Tom Christiansen */
1724 /* unexec() can be found in the Gnu emacs distribution */
1735 prog = newSVpv(BIN_EXP);
1736 sv_catpv(prog, "/perl");
1737 file = newSVpv(origfilename);
1738 sv_catpv(file, ".perldump");
1740 status = unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
1742 PerlIO_printf(PerlIO_stderr(), "unexec of %s into %s failed!\n",
1743 SvPVX(prog), SvPVX(file));
1747 # include <lib$routines.h>
1748 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
1750 ABORT(); /* for use with undump */
1761 /* Note that strtab is a rather special HV. Assumptions are made
1762 about not iterating on it, and not adding tie magic to it.
1763 It is properly deallocated in perl_destruct() */
1765 HvSHAREKEYS_off(strtab); /* mandatory */
1766 Newz(506,((XPVHV*)SvANY(strtab))->xhv_array,
1767 sizeof(HE*) * (((XPVHV*)SvANY(strtab))->xhv_max + 1), char);
1769 curstash = defstash = newHV();
1770 curstname = newSVpv("main",4);
1771 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
1772 SvREFCNT_dec(GvHV(gv));
1773 GvHV(gv) = (HV*)SvREFCNT_inc(defstash);
1775 HvNAME(defstash) = savepv("main");
1776 incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
1778 defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
1779 errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
1781 (void)form("%240s",""); /* Preallocate temp - for immediate signals. */
1782 sv_grow(GvSV(errgv), 240); /* Preallocate - for immediate signals. */
1783 sv_setpvn(GvSV(errgv), "", 0);
1784 curstash = defstash;
1785 compiling.cop_stash = defstash;
1786 debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
1787 /* We must init $/ before switches are processed. */
1788 sv_setpvn(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), "\n", 1);
1791 #ifdef CAN_PROTOTYPE
1793 open_script(char *scriptname, bool dosearch, SV *sv)
1796 open_script(scriptname,dosearch,sv)
1803 char *xfound = Nullch;
1804 char *xfailed = Nullch;
1808 #if defined(DOSISH) && !defined(OS2) && !defined(atarist)
1809 # define SEARCH_EXTS ".bat", ".cmd", NULL
1810 # define MAX_EXT_LEN 4
1813 # define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL
1814 # define MAX_EXT_LEN 4
1817 # define SEARCH_EXTS ".pl", ".com", NULL
1818 # define MAX_EXT_LEN 4
1820 /* additional extensions to try in each dir if scriptname not found */
1822 char *ext[] = { SEARCH_EXTS };
1823 int extidx = 0, i = 0;
1824 char *curext = Nullch;
1826 # define MAX_EXT_LEN 0
1830 * If dosearch is true and if scriptname does not contain path
1831 * delimiters, search the PATH for scriptname.
1833 * If SEARCH_EXTS is also defined, will look for each
1834 * scriptname{SEARCH_EXTS} whenever scriptname is not found
1835 * while searching the PATH.
1837 * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
1838 * proceeds as follows:
1840 * + look for ./scriptname{,.foo,.bar}
1841 * + search the PATH for scriptname{,.foo,.bar}
1844 * + look *only* in the PATH for scriptname{,.foo,.bar} (note
1845 * this will not look in '.' if it's not in the PATH)
1850 int hasdir, idx = 0, deftypes = 1;
1853 hasdir = (strpbrk(scriptname,":[</") != Nullch) ;
1854 /* The first time through, just add SEARCH_EXTS to whatever we
1855 * already have, so we can check for default file types. */
1857 (!hasdir && my_trnlnm("DCL$PATH",tokenbuf,idx++)) )
1863 if ((strlen(tokenbuf) + strlen(scriptname)
1864 + MAX_EXT_LEN) >= sizeof tokenbuf)
1865 continue; /* don't search dir with too-long name */
1866 strcat(tokenbuf, scriptname);
1870 if (strEQ(scriptname, "-"))
1872 if (dosearch) { /* Look in '.' first. */
1873 char *cur = scriptname;
1875 if ((curext = strrchr(scriptname,'.'))) /* possible current ext */
1877 if (strEQ(ext[i++],curext)) {
1878 extidx = -1; /* already has an ext */
1883 DEBUG_p(PerlIO_printf(Perl_debug_log,
1884 "Looking for %s\n",cur));
1885 if (Stat(cur,&statbuf) >= 0) {
1893 if (cur == scriptname) {
1894 len = strlen(scriptname);
1895 if (len+MAX_EXT_LEN+1 >= sizeof(tokenbuf))
1897 cur = strcpy(tokenbuf, scriptname);
1899 } while (extidx >= 0 && ext[extidx] /* try an extension? */
1900 && strcpy(tokenbuf+len, ext[extidx++]));
1905 if (dosearch && !strchr(scriptname, '/')
1907 && !strchr(scriptname, '\\')
1909 && (s = getenv("PATH"))) {
1912 bufend = s + strlen(s);
1913 while (s < bufend) {
1914 #if defined(atarist) || defined(DOSISH)
1919 && *s != ';'; len++, s++) {
1920 if (len < sizeof tokenbuf)
1923 if (len < sizeof tokenbuf)
1924 tokenbuf[len] = '\0';
1925 #else /* ! (atarist || DOSISH) */
1926 s = delimcpy(tokenbuf, tokenbuf + sizeof tokenbuf, s, bufend,
1929 #endif /* ! (atarist || DOSISH) */
1932 if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tokenbuf)
1933 continue; /* don't search dir with too-long name */
1935 #if defined(atarist) || defined(DOSISH)
1936 && tokenbuf[len - 1] != '/'
1937 && tokenbuf[len - 1] != '\\'
1940 tokenbuf[len++] = '/';
1941 if (len == 2 && tokenbuf[0] == '.')
1943 (void)strcpy(tokenbuf + len, scriptname);
1947 len = strlen(tokenbuf);
1948 if (extidx > 0) /* reset after previous loop */
1952 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tokenbuf));
1953 retval = Stat(tokenbuf,&statbuf);
1955 } while ( retval < 0 /* not there */
1956 && extidx>=0 && ext[extidx] /* try an extension? */
1957 && strcpy(tokenbuf+len, ext[extidx++])
1962 if (S_ISREG(statbuf.st_mode)
1963 && cando(S_IRUSR,TRUE,&statbuf)
1965 && cando(S_IXUSR,TRUE,&statbuf)
1969 xfound = tokenbuf; /* bingo! */
1973 xfailed = savepv(tokenbuf);
1976 if (!xfound && !seen_dot && !xfailed && (Stat(scriptname,&statbuf) < 0))
1978 seen_dot = 1; /* Disable message. */
1980 croak("Can't %s %s%s%s",
1981 (xfailed ? "execute" : "find"),
1982 (xfailed ? xfailed : scriptname),
1983 (xfailed ? "" : " on PATH"),
1984 (xfailed || seen_dot) ? "" : ", '.' not in PATH");
1987 scriptname = xfound;
1990 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
1991 char *s = scriptname + 8;
2000 origfilename = savepv(e_tmpname ? "-e" : scriptname);
2001 curcop->cop_filegv = gv_fetchfile(origfilename);
2002 if (strEQ(origfilename,"-"))
2004 if (fdscript >= 0) {
2005 rsfp = PerlIO_fdopen(fdscript,"r");
2006 #if defined(HAS_FCNTL) && defined(F_SETFD)
2008 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
2011 else if (preprocess) {
2012 char *cpp_cfg = CPPSTDIN;
2013 SV *cpp = NEWSV(0,0);
2014 SV *cmd = NEWSV(0,0);
2016 if (strEQ(cpp_cfg, "cppstdin"))
2017 sv_catpvf(cpp, "%s/", BIN_EXP);
2018 sv_catpv(cpp, cpp_cfg);
2021 sv_catpv(sv,PRIVLIB_EXP);
2025 sed %s -e \"/^[^#]/b\" \
2026 -e \"/^#[ ]*include[ ]/b\" \
2027 -e \"/^#[ ]*define[ ]/b\" \
2028 -e \"/^#[ ]*if[ ]/b\" \
2029 -e \"/^#[ ]*ifdef[ ]/b\" \
2030 -e \"/^#[ ]*ifndef[ ]/b\" \
2031 -e \"/^#[ ]*else/b\" \
2032 -e \"/^#[ ]*elif[ ]/b\" \
2033 -e \"/^#[ ]*undef[ ]/b\" \
2034 -e \"/^#[ ]*endif/b\" \
2037 (doextract ? "-e \"1,/^#/d\n\"" : ""),
2040 %s %s -e '/^[^#]/b' \
2041 -e '/^#[ ]*include[ ]/b' \
2042 -e '/^#[ ]*define[ ]/b' \
2043 -e '/^#[ ]*if[ ]/b' \
2044 -e '/^#[ ]*ifdef[ ]/b' \
2045 -e '/^#[ ]*ifndef[ ]/b' \
2046 -e '/^#[ ]*else/b' \
2047 -e '/^#[ ]*elif[ ]/b' \
2048 -e '/^#[ ]*undef[ ]/b' \
2049 -e '/^#[ ]*endif/b' \
2057 (doextract ? "-e '1,/^#/d\n'" : ""),
2059 scriptname, cpp, sv, CPPMINUS);
2061 #ifdef IAMSUID /* actually, this is caught earlier */
2062 if (euid != uid && !euid) { /* if running suidperl */
2064 (void)seteuid(uid); /* musn't stay setuid root */
2067 (void)setreuid((Uid_t)-1, uid);
2069 #ifdef HAS_SETRESUID
2070 (void)setresuid((Uid_t)-1, uid, (Uid_t)-1);
2076 if (geteuid() != uid)
2077 croak("Can't do seteuid!\n");
2079 #endif /* IAMSUID */
2080 rsfp = my_popen(SvPVX(cmd), "r");
2084 else if (!*scriptname) {
2085 forbid_setid("program input from stdin");
2086 rsfp = PerlIO_stdin();
2089 rsfp = PerlIO_open(scriptname,"r");
2090 #if defined(HAS_FCNTL) && defined(F_SETFD)
2092 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
2100 #ifndef IAMSUID /* in case script is not readable before setuid */
2101 if (euid && Stat(SvPVX(GvSV(curcop->cop_filegv)),&statbuf) >= 0 &&
2102 statbuf.st_mode & (S_ISUID|S_ISGID)) {
2104 execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
2105 croak("Can't do setuid\n");
2109 croak("Can't open perl script \"%s\": %s\n",
2110 SvPVX(GvSV(curcop->cop_filegv)), Strerror(errno));
2115 validate_suid(validarg, scriptname)
2121 /* do we need to emulate setuid on scripts? */
2123 /* This code is for those BSD systems that have setuid #! scripts disabled
2124 * in the kernel because of a security problem. Merely defining DOSUID
2125 * in perl will not fix that problem, but if you have disabled setuid
2126 * scripts in the kernel, this will attempt to emulate setuid and setgid
2127 * on scripts that have those now-otherwise-useless bits set. The setuid
2128 * root version must be called suidperl or sperlN.NNN. If regular perl
2129 * discovers that it has opened a setuid script, it calls suidperl with
2130 * the same argv that it had. If suidperl finds that the script it has
2131 * just opened is NOT setuid root, it sets the effective uid back to the
2132 * uid. We don't just make perl setuid root because that loses the
2133 * effective uid we had before invoking perl, if it was different from the
2136 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
2137 * be defined in suidperl only. suidperl must be setuid root. The
2138 * Configure script will set this up for you if you want it.
2144 if (Fstat(PerlIO_fileno(rsfp),&statbuf) < 0) /* normal stat is insecure */
2145 croak("Can't stat script \"%s\"",origfilename);
2146 if (fdscript < 0 && statbuf.st_mode & (S_ISUID|S_ISGID)) {
2150 #ifndef HAS_SETREUID
2151 /* On this access check to make sure the directories are readable,
2152 * there is actually a small window that the user could use to make
2153 * filename point to an accessible directory. So there is a faint
2154 * chance that someone could execute a setuid script down in a
2155 * non-accessible directory. I don't know what to do about that.
2156 * But I don't think it's too important. The manual lies when
2157 * it says access() is useful in setuid programs.
2159 if (access(SvPVX(GvSV(curcop->cop_filegv)),1)) /*double check*/
2160 croak("Permission denied");
2162 /* If we can swap euid and uid, then we can determine access rights
2163 * with a simple stat of the file, and then compare device and
2164 * inode to make sure we did stat() on the same file we opened.
2165 * Then we just have to make sure he or she can execute it.
2168 struct stat tmpstatbuf;
2172 setreuid(euid,uid) < 0
2175 setresuid(euid,uid,(Uid_t)-1) < 0
2178 || getuid() != euid || geteuid() != uid)
2179 croak("Can't swap uid and euid"); /* really paranoid */
2180 if (Stat(SvPVX(GvSV(curcop->cop_filegv)),&tmpstatbuf) < 0)
2181 croak("Permission denied"); /* testing full pathname here */
2182 if (tmpstatbuf.st_dev != statbuf.st_dev ||
2183 tmpstatbuf.st_ino != statbuf.st_ino) {
2184 (void)PerlIO_close(rsfp);
2185 if (rsfp = my_popen("/bin/mail root","w")) { /* heh, heh */
2187 "User %ld tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
2188 (Filename of set-id script was %s, uid %ld gid %ld.)\n\nSincerely,\nperl\n",
2189 (long)uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
2190 (long)statbuf.st_dev, (long)statbuf.st_ino,
2191 SvPVX(GvSV(curcop->cop_filegv)),
2192 (long)statbuf.st_uid, (long)statbuf.st_gid);
2193 (void)my_pclose(rsfp);
2195 croak("Permission denied\n");
2199 setreuid(uid,euid) < 0
2201 # if defined(HAS_SETRESUID)
2202 setresuid(uid,euid,(Uid_t)-1) < 0
2205 || getuid() != uid || geteuid() != euid)
2206 croak("Can't reswap uid and euid");
2207 if (!cando(S_IXUSR,FALSE,&statbuf)) /* can real uid exec? */
2208 croak("Permission denied\n");
2210 #endif /* HAS_SETREUID */
2211 #endif /* IAMSUID */
2213 if (!S_ISREG(statbuf.st_mode))
2214 croak("Permission denied");
2215 if (statbuf.st_mode & S_IWOTH)
2216 croak("Setuid/gid script is writable by world");
2217 doswitches = FALSE; /* -s is insecure in suid */
2219 if (sv_gets(linestr, rsfp, 0) == Nullch ||
2220 strnNE(SvPV(linestr,na),"#!",2) ) /* required even on Sys V */
2221 croak("No #! line");
2222 s = SvPV(linestr,na)+2;
2224 while (!isSPACE(*s)) s++;
2225 for (s2 = s; (s2 > SvPV(linestr,na)+2 &&
2226 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
2227 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
2228 croak("Not a perl script");
2229 while (*s == ' ' || *s == '\t') s++;
2231 * #! arg must be what we saw above. They can invoke it by
2232 * mentioning suidperl explicitly, but they may not add any strange
2233 * arguments beyond what #! says if they do invoke suidperl that way.
2235 len = strlen(validarg);
2236 if (strEQ(validarg," PHOOEY ") ||
2237 strnNE(s,validarg,len) || !isSPACE(s[len]))
2238 croak("Args must match #! line");
2241 if (euid != uid && (statbuf.st_mode & S_ISUID) &&
2242 euid == statbuf.st_uid)
2244 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2245 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2246 #endif /* IAMSUID */
2248 if (euid) { /* oops, we're not the setuid root perl */
2249 (void)PerlIO_close(rsfp);
2252 execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
2254 croak("Can't do setuid\n");
2257 if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid) {
2259 (void)setegid(statbuf.st_gid);
2262 (void)setregid((Gid_t)-1,statbuf.st_gid);
2264 #ifdef HAS_SETRESGID
2265 (void)setresgid((Gid_t)-1,statbuf.st_gid,(Gid_t)-1);
2267 setgid(statbuf.st_gid);
2271 if (getegid() != statbuf.st_gid)
2272 croak("Can't do setegid!\n");
2274 if (statbuf.st_mode & S_ISUID) {
2275 if (statbuf.st_uid != euid)
2277 (void)seteuid(statbuf.st_uid); /* all that for this */
2280 (void)setreuid((Uid_t)-1,statbuf.st_uid);
2282 #ifdef HAS_SETRESUID
2283 (void)setresuid((Uid_t)-1,statbuf.st_uid,(Uid_t)-1);
2285 setuid(statbuf.st_uid);
2289 if (geteuid() != statbuf.st_uid)
2290 croak("Can't do seteuid!\n");
2292 else if (uid) { /* oops, mustn't run as root */
2294 (void)seteuid((Uid_t)uid);
2297 (void)setreuid((Uid_t)-1,(Uid_t)uid);
2299 #ifdef HAS_SETRESUID
2300 (void)setresuid((Uid_t)-1,(Uid_t)uid,(Uid_t)-1);
2306 if (geteuid() != uid)
2307 croak("Can't do seteuid!\n");
2310 if (!cando(S_IXUSR,TRUE,&statbuf))
2311 croak("Permission denied\n"); /* they can't do this */
2314 else if (preprocess)
2315 croak("-P not allowed for setuid/setgid script\n");
2316 else if (fdscript >= 0)
2317 croak("fd script not allowed in suidperl\n");
2319 croak("Script is not setuid/setgid in suidperl\n");
2321 /* We absolutely must clear out any saved ids here, so we */
2322 /* exec the real perl, substituting fd script for scriptname. */
2323 /* (We pass script name as "subdir" of fd, which perl will grok.) */
2324 PerlIO_rewind(rsfp);
2325 lseek(PerlIO_fileno(rsfp),(Off_t)0,0); /* just in case rewind didn't */
2326 for (which = 1; origargv[which] && origargv[which] != scriptname; which++) ;
2327 if (!origargv[which])
2328 croak("Permission denied");
2329 origargv[which] = savepv(form("/dev/fd/%d/%s",
2330 PerlIO_fileno(rsfp), origargv[which]));
2331 #if defined(HAS_FCNTL) && defined(F_SETFD)
2332 fcntl(PerlIO_fileno(rsfp),F_SETFD,0); /* ensure no close-on-exec */
2334 execv(form("%s/perl%s", BIN_EXP, patchlevel), origargv); /* try again */
2335 croak("Can't do setuid\n");
2336 #endif /* IAMSUID */
2338 if (euid != uid || egid != gid) { /* (suidperl doesn't exist, in fact) */
2339 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
2341 Fstat(PerlIO_fileno(rsfp),&statbuf); /* may be either wrapped or real suid */
2342 if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
2344 (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
2347 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2348 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2349 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
2350 /* not set-id, must be wrapped */
2358 register char *s, *s2;
2360 /* skip forward in input to the real script? */
2364 if ((s = sv_gets(linestr, rsfp, 0)) == Nullch)
2365 croak("No Perl script found in input\n");
2366 if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
2367 PerlIO_ungetc(rsfp, '\n'); /* to keep line count right */
2369 while (*s && !(isSPACE (*s) || *s == '#')) s++;
2371 while (*s == ' ' || *s == '\t') s++;
2373 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
2374 if (strnEQ(s2-4,"perl",4))
2376 while (s = moreswitches(s)) ;
2378 if (cddir && chdir(cddir) < 0)
2379 croak("Can't chdir to %s",cddir);
2387 uid = (int)getuid();
2388 euid = (int)geteuid();
2389 gid = (int)getgid();
2390 egid = (int)getegid();
2395 tainting |= (uid && (euid != uid || egid != gid));
2403 croak("No %s allowed while running setuid", s);
2405 croak("No %s allowed while running setgid", s);
2412 curstash = debstash;
2413 dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
2415 DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
2416 DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
2417 DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
2418 DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
2419 sv_setiv(DBsingle, 0);
2420 DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
2421 sv_setiv(DBtrace, 0);
2422 DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
2423 sv_setiv(DBsignal, 0);
2424 curstash = defstash;
2432 mainstack = curstack; /* remember in case we switch stacks */
2433 AvREAL_off(curstack); /* not a real array */
2434 av_extend(curstack,127);
2436 stack_base = AvARRAY(curstack);
2437 stack_sp = stack_base;
2438 stack_max = stack_base + 127;
2440 cxstack_max = 8192 / sizeof(CONTEXT) - 2; /* Use most of 8K. */
2441 New(50,cxstack,cxstack_max + 1,CONTEXT);
2444 New(50,tmps_stack,128,SV*);
2450 * The following stacks almost certainly should be per-interpreter,
2451 * but for now they're not. XXX
2455 markstack_ptr = markstack;
2457 New(54,markstack,64,I32);
2458 markstack_ptr = markstack;
2459 markstack_max = markstack + 64;
2465 New(54,scopestack,32,I32);
2467 scopestack_max = 32;
2473 New(54,savestack,128,ANY);
2475 savestack_max = 128;
2481 New(54,retstack,16,OP*);
2492 Safefree(tmps_stack);
2499 static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
2508 subname = newSVpv("main",4);
2512 init_predump_symbols()
2518 sv_setpvn(GvSV(gv_fetchpv("\"", TRUE, SVt_PV)), " ", 1);
2520 stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
2521 GvMULTI_on(stdingv);
2522 IoIFP(GvIOp(stdingv)) = PerlIO_stdin();
2523 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
2525 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(stdingv));
2527 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
2529 IoOFP(GvIOp(tmpgv)) = IoIFP(GvIOp(tmpgv)) = PerlIO_stdout();
2531 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
2533 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(defoutgv));
2535 othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
2536 GvMULTI_on(othergv);
2537 IoOFP(GvIOp(othergv)) = IoIFP(GvIOp(othergv)) = PerlIO_stderr();
2538 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
2540 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(othergv));
2542 statname = NEWSV(66,0); /* last filename we did stat on */
2545 osname = savepv(OSNAME);
2549 init_postdump_symbols(argc,argv,env)
2551 register char **argv;
2552 register char **env;
2558 argc--,argv++; /* skip name of script */
2560 for (; argc > 0 && **argv == '-'; argc--,argv++) {
2563 if (argv[0][1] == '-') {
2567 if (s = strchr(argv[0], '=')) {
2569 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
2572 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
2575 toptarget = NEWSV(0,0);
2576 sv_upgrade(toptarget, SVt_PVFM);
2577 sv_setpvn(toptarget, "", 0);
2578 bodytarget = NEWSV(0,0);
2579 sv_upgrade(bodytarget, SVt_PVFM);
2580 sv_setpvn(bodytarget, "", 0);
2581 formtarget = bodytarget;
2584 if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
2585 sv_setpv(GvSV(tmpgv),origfilename);
2586 magicname("0", "0", 1);
2588 if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
2589 sv_setpv(GvSV(tmpgv),origargv[0]);
2590 if (argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
2592 (void)gv_AVadd(argvgv);
2593 av_clear(GvAVn(argvgv));
2594 for (; argc > 0; argc--,argv++) {
2595 av_push(GvAVn(argvgv),newSVpv(argv[0],0));
2598 if (envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
2602 hv_magic(hv, envgv, 'E');
2603 #ifndef VMS /* VMS doesn't have environ array */
2604 /* Note that if the supplied env parameter is actually a copy
2605 of the global environ then it may now point to free'd memory
2606 if the environment has been modified since. To avoid this
2607 problem we treat env==NULL as meaning 'use the default'
2612 environ[0] = Nullch;
2613 for (; *env; env++) {
2614 if (!(s = strchr(*env,'=')))
2620 sv = newSVpv(s--,0);
2621 (void)hv_store(hv, *env, s - *env, sv, 0);
2623 #if defined(__BORLANDC__) && defined(USE_WIN32_RTL_ENV)
2624 /* Sins of the RTL. See note in my_setenv(). */
2625 (void)putenv(savepv(*env));
2629 #ifdef DYNAMIC_ENV_FETCH
2630 HvNAME(hv) = savepv(ENV_HV_NAME);
2634 if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
2635 sv_setiv(GvSV(tmpgv), (IV)getpid());
2644 s = getenv("PERL5LIB");
2648 incpush(getenv("PERLLIB"), FALSE);
2650 /* Treat PERL5?LIB as a possible search list logical name -- the
2651 * "natural" VMS idiom for a Unix path string. We allow each
2652 * element to be a set of |-separated directories for compatibility.
2656 if (my_trnlnm("PERL5LIB",buf,0))
2657 do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
2659 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE);
2663 /* Use the ~-expanded versions of APPLLIB (undocumented),
2664 ARCHLIB PRIVLIB SITEARCH SITELIB and OLDARCHLIB
2667 incpush(APPLLIB_EXP, FALSE);
2671 incpush(ARCHLIB_EXP, FALSE);
2674 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
2676 incpush(PRIVLIB_EXP, FALSE);
2679 incpush(SITEARCH_EXP, FALSE);
2682 incpush(SITELIB_EXP, FALSE);
2684 #ifdef OLDARCHLIB_EXP /* 5.00[01] compatibility */
2685 incpush(OLDARCHLIB_EXP, FALSE);
2689 incpush(".", FALSE);
2693 # define PERLLIB_SEP ';'
2696 # define PERLLIB_SEP '|'
2698 # define PERLLIB_SEP ':'
2701 #ifndef PERLLIB_MANGLE
2702 # define PERLLIB_MANGLE(s,n) (s)
2706 incpush(p, addsubdirs)
2710 SV *subdir = Nullsv;
2711 static char *archpat_auto;
2718 if (!archpat_auto) {
2719 STRLEN len = (sizeof(ARCHNAME) + strlen(patchlevel)
2720 + sizeof("//auto"));
2721 New(55, archpat_auto, len, char);
2722 sprintf(archpat_auto, "/%s/%s/auto", ARCHNAME, patchlevel);
2724 for (len = sizeof(ARCHNAME) + 2;
2725 archpat_auto[len] != '\0' && archpat_auto[len] != '/'; len++)
2726 if (archpat_auto[len] == '.') archpat_auto[len] = '_';
2731 /* Break at all separators */
2733 SV *libdir = newSV(0);
2736 /* skip any consecutive separators */
2737 while ( *p == PERLLIB_SEP ) {
2738 /* Uncomment the next line for PATH semantics */
2739 /* av_push(GvAVn(incgv), newSVpv(".", 1)); */
2743 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
2744 sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
2749 sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
2750 p = Nullch; /* break out */
2754 * BEFORE pushing libdir onto @INC we may first push version- and
2755 * archname-specific sub-directories.
2758 struct stat tmpstatbuf;
2763 if ((unix = tounixspec_ts(SvPV(libdir,na),Nullch)) != Nullch) {
2765 while (unix[len-1] == '/') len--; /* Cosmetic */
2766 sv_usepvn(libdir,unix,len);
2769 PerlIO_printf(PerlIO_stderr(),
2770 "Failed to unixify @INC element \"%s\"\n",
2773 /* .../archname/version if -d .../archname/version/auto */
2774 sv_setsv(subdir, libdir);
2775 sv_catpv(subdir, archpat_auto);
2776 if (Stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2777 S_ISDIR(tmpstatbuf.st_mode))
2778 av_push(GvAVn(incgv),
2779 newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2781 /* .../archname if -d .../archname/auto */
2782 sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME),
2783 strlen(patchlevel) + 1, "", 0);
2784 if (Stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2785 S_ISDIR(tmpstatbuf.st_mode))
2786 av_push(GvAVn(incgv),
2787 newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2790 /* finally push this lib directory on the end of @INC */
2791 av_push(GvAVn(incgv), libdir);
2794 SvREFCNT_dec(subdir);
2798 call_list(oldscope, list)
2803 line_t oldline = curcop->cop_line;
2808 while (AvFILL(list) >= 0) {
2809 CV *cv = (CV*)av_shift(list);
2816 SV* atsv = GvSV(errgv);
2818 perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
2819 (void)SvPV(atsv, len);
2822 curcop = &compiling;
2823 curcop->cop_line = oldline;
2824 if (list == beginav)
2825 sv_catpv(atsv, "BEGIN failed--compilation aborted");
2827 sv_catpv(atsv, "END failed--cleanup aborted");
2828 while (scopestack_ix > oldscope)
2830 croak("%s", SvPVX(atsv));
2838 /* my_exit() was called */
2839 while (scopestack_ix > oldscope)
2842 curstash = defstash;
2844 call_list(oldscope, endav);
2846 curcop = &compiling;
2847 curcop->cop_line = oldline;
2849 if (list == beginav)
2850 croak("BEGIN failed--compilation aborted");
2852 croak("END failed--cleanup aborted");
2858 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
2863 curcop = &compiling;
2864 curcop->cop_line = oldline;
2878 DEBUG_L(PerlIO_printf(Perl_debug_log, "my_exit: thread 0x%lx, status %lu\n",
2879 (unsigned long) thr, (unsigned long) status));
2880 #endif /* USE_THREADS */
2889 STATUS_NATIVE_SET(status);
2899 if (vaxc$errno & 1) {
2900 if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
2901 STATUS_NATIVE_SET(44);
2904 if (!vaxc$errno && errno) /* unlikely */
2905 STATUS_NATIVE_SET(44);
2907 STATUS_NATIVE_SET(vaxc$errno);
2911 STATUS_POSIX_SET(errno);
2912 else if (STATUS_POSIX == 0)
2913 STATUS_POSIX_SET(255);
2922 register CONTEXT *cx;
2931 (void)UNLINK(e_tmpname);
2932 Safefree(e_tmpname);
2936 if (cxstack_ix >= 0) {