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)? */
127 Newz(53, thr, 1, struct thread);
128 MUTEX_INIT(&malloc_mutex);
129 MUTEX_INIT(&sv_mutex);
130 /* Safe to use SVs from now on */
131 MUTEX_INIT(&eval_mutex);
132 COND_INIT(&eval_cond);
133 MUTEX_INIT(&threads_mutex);
134 COND_INIT(&nthreads_cond);
138 thr->flags = THRf_R_JOINABLE;
139 MUTEX_INIT(&thr->mutex);
144 /* Handcraft thrsv similarly to mess_sv */
145 New(53, thrsv, 1, SV);
146 Newz(53, xpv, 1, XPV);
147 SvFLAGS(thrsv) = SVt_PV;
148 SvANY(thrsv) = (void*)xpv;
149 SvREFCNT(thrsv) = 1 << 30; /* practically infinite */
150 SvPVX(thrsv) = (char*)thr;
151 SvCUR_set(thrsv, sizeof(thr));
152 SvLEN_set(thrsv, sizeof(thr));
153 *SvEND(thrsv) = '\0'; /* in the trailing_nul field */
155 #ifdef HAVE_THREAD_INTERN
156 init_thread_intern(thr);
159 DuplicateHandle(GetCurrentProcess(),
165 DUPLICATE_SAME_ACCESS);
166 if ((thr_key = TlsAlloc()) == TLS_OUT_OF_INDEXES)
167 croak("panic: pthread_key_create");
168 if (TlsSetValue(thr_key, (LPVOID) thr) != TRUE)
169 croak("panic: pthread_setspecific");
171 self = pthread_self();
172 if (pthread_key_create(&thr_key, 0))
173 croak("panic: pthread_key_create");
174 if (pthread_setspecific(thr_key, (void *) thr))
175 croak("panic: pthread_setspecific");
177 #endif /* FAKE_THREADS */
178 #endif /* USE_THREADS */
180 linestr = NEWSV(65,80);
181 sv_upgrade(linestr,SVt_PVIV);
183 if (!SvREADONLY(&sv_undef)) {
184 SvREADONLY_on(&sv_undef);
188 SvREADONLY_on(&sv_no);
190 sv_setpv(&sv_yes,Yes);
192 SvREADONLY_on(&sv_yes);
195 nrs = newSVpv("\n", 1);
196 rs = SvREFCNT_inc(nrs);
198 sighandlerp = sighandler;
203 * There is no way we can refer to them from Perl so close them to save
204 * space. The other alternative would be to provide STDAUX and STDPRN
207 (void)fclose(stdaux);
208 (void)fclose(stdprn);
214 perl_destruct_level = 1;
216 if(perl_destruct_level > 0)
221 lex_state = LEX_NOTPARSING;
223 start_env.je_prev = NULL;
224 start_env.je_ret = -1;
225 start_env.je_mustcatch = TRUE;
226 top_env = &start_env;
229 SET_NUMERIC_STANDARD();
230 #if defined(SUBVERSION) && SUBVERSION > 0
231 sprintf(patchlevel, "%7.5f", (double) 5
232 + ((double) PATCHLEVEL / (double) 1000)
233 + ((double) SUBVERSION / (double) 100000));
235 sprintf(patchlevel, "%5.3f", (double) 5 +
236 ((double) PATCHLEVEL / (double) 1000));
239 #if defined(LOCAL_PATCH_COUNT)
240 localpatches = local_patches; /* For possible -v */
243 PerlIO_init(); /* Hook to IO system */
245 fdpid = newAV(); /* for remembering popen pids by fd */
249 New(51,debname,128,char);
250 New(52,debdelim,128,char);
257 perl_destruct(sv_interp)
258 register PerlInterpreter *sv_interp;
261 int destruct_level; /* 0=none, 1=full, 2=full with checks */
266 #endif /* USE_THREADS */
268 if (!(curinterp = sv_interp))
273 /* Pass 1 on any remaining threads: detach joinables, join zombies */
275 MUTEX_LOCK(&threads_mutex);
276 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
277 "perl_destruct: waiting for %d threads...\n",
279 for (t = thr->next; t != thr; t = t->next) {
280 MUTEX_LOCK(&t->mutex);
281 switch (ThrSTATE(t)) {
284 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
285 "perl_destruct: joining zombie %p\n", t));
286 ThrSETSTATE(t, THRf_DEAD);
287 MUTEX_UNLOCK(&t->mutex);
290 * The SvREFCNT_dec below may take a long time (e.g. av
291 * may contain an object scalar whose destructor gets
292 * called) so we have to unlock threads_mutex and start
295 MUTEX_UNLOCK(&threads_mutex);
297 if ((WaitForSingleObject(t->Tself,INFINITE) == WAIT_FAILED)
298 || (GetExitCodeThread(t->Tself,(LPDWORD)&av) == 0))
300 if (pthread_join(t->Tself, (void**)&av))
302 croak("panic: pthread_join failed during global destruction");
303 SvREFCNT_dec((SV*)av);
304 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
305 "perl_destruct: joined zombie %p OK\n", t));
307 case THRf_R_JOINABLE:
308 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
309 "perl_destruct: detaching thread %p\n", t));
310 ThrSETSTATE(t, THRf_R_DETACHED);
312 * We unlock threads_mutex and t->mutex in the opposite order
313 * from which we locked them just so that DETACH won't
314 * deadlock if it panics. It's only a breach of good style
315 * not a bug since they are unlocks not locks.
317 MUTEX_UNLOCK(&threads_mutex);
319 MUTEX_UNLOCK(&t->mutex);
322 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
323 "perl_destruct: ignoring %p (state %u)\n",
325 MUTEX_UNLOCK(&t->mutex);
326 /* fall through and out */
329 /* We leave the above "Pass 1" loop with threads_mutex still locked */
331 /* Pass 2 on remaining threads: wait for the thread count to drop to one */
334 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
335 "perl_destruct: final wait for %d threads\n",
337 COND_WAIT(&nthreads_cond, &threads_mutex);
339 /* At this point, we're the last thread */
340 MUTEX_UNLOCK(&threads_mutex);
341 DEBUG_L(PerlIO_printf(PerlIO_stderr(), "perl_destruct: armageddon has arrived\n"));
342 MUTEX_DESTROY(&threads_mutex);
343 COND_DESTROY(&nthreads_cond);
344 #endif /* !defined(FAKE_THREADS) */
345 #endif /* USE_THREADS */
347 destruct_level = perl_destruct_level;
351 if (s = getenv("PERL_DESTRUCT_LEVEL")) {
353 if (destruct_level < i)
362 /* We must account for everything. */
364 /* Destroy the main CV and syntax tree */
366 curpad = AvARRAY(comppad);
371 SvREFCNT_dec(main_cv);
376 * Try to destruct global references. We do this first so that the
377 * destructors and destructees still exist. Some sv's might remain.
378 * Non-referenced objects are on their own.
385 /* unhook hooks which will soon be, or use, destroyed data */
386 SvREFCNT_dec(warnhook);
388 SvREFCNT_dec(diehook);
390 SvREFCNT_dec(parsehook);
393 if (destruct_level == 0){
395 DEBUG_P(debprofdump());
397 /* The exit() function will do everything that needs doing. */
401 /* loosen bonds of global variables */
404 (void)PerlIO_close(rsfp);
408 /* Filters for program text */
409 SvREFCNT_dec(rsfp_filters);
410 rsfp_filters = Nullav;
422 sawampersand = FALSE; /* must save all match strings */
423 sawstudy = FALSE; /* do fbm_instr on all strings */
438 /* magical thingies */
440 Safefree(ofs); /* $, */
443 Safefree(ors); /* $\ */
446 SvREFCNT_dec(nrs); /* $\ helper */
449 multiline = 0; /* $* */
451 SvREFCNT_dec(statname);
455 /* defgv, aka *_ should be taken care of elsewhere */
457 #if 0 /* just about all regexp stuff, seems to be ok */
459 /* shortcuts to regexp stuff */
464 SAVEFREEOP(oldlastpm); /* for saving regexp context during debugger */
466 regprecomp = NULL; /* uncompiled string. */
467 regparse = NULL; /* Input-scan pointer. */
468 regxend = NULL; /* End of input for compile */
469 regnpar = 0; /* () count. */
470 regcode = NULL; /* Code-emit pointer; ®dummy = don't. */
471 regsize = 0; /* Code size. */
472 regnaughty = 0; /* How bad is this pattern? */
473 regsawback = 0; /* Did we see \1, ...? */
475 reginput = NULL; /* String-input pointer. */
476 regbol = NULL; /* Beginning of input, for ^ check. */
477 regeol = NULL; /* End of input, for $ check. */
478 regstartp = (char **)NULL; /* Pointer to startp array. */
479 regendp = (char **)NULL; /* Ditto for endp. */
480 reglastparen = 0; /* Similarly for lastparen. */
481 regtill = NULL; /* How far we are required to go. */
482 regflags = 0; /* are we folding, multilining? */
483 regprev = (char)NULL; /* char before regbol, \n if none */
487 /* clean up after study() */
488 SvREFCNT_dec(lastscream);
490 Safefree(screamfirst);
492 Safefree(screamnext);
495 /* startup and shutdown function lists */
496 SvREFCNT_dec(beginav);
498 SvREFCNT_dec(initav);
503 /* temp stack during pp_sort() */
504 SvREFCNT_dec(sortstack);
507 /* shortcuts just get cleared */
517 /* reset so print() ends up where we expect */
520 /* Prepare to destruct main symbol table. */
527 if (destruct_level >= 2) {
528 if (scopestack_ix != 0)
529 warn("Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
530 (long)scopestack_ix);
531 if (savestack_ix != 0)
532 warn("Unbalanced saves: %ld more saves than restores\n",
534 if (tmps_floor != -1)
535 warn("Unbalanced tmps: %ld more allocs than frees\n",
536 (long)tmps_floor + 1);
537 if (cxstack_ix != -1)
538 warn("Unbalanced context: %ld more PUSHes than POPs\n",
539 (long)cxstack_ix + 1);
542 /* Now absolutely destruct everything, somehow or other, loops or no. */
544 SvFLAGS(strtab) |= SVTYPEMASK; /* don't clean out strtab now */
545 while (sv_count != 0 && sv_count != last_sv_count) {
546 last_sv_count = sv_count;
549 SvFLAGS(strtab) &= ~SVTYPEMASK;
550 SvFLAGS(strtab) |= SVt_PVHV;
552 /* Destruct the global string table. */
554 /* Yell and reset the HeVAL() slots that are still holding refcounts,
555 * so that sv_free() won't fail on them.
564 array = HvARRAY(strtab);
568 warn("Unbalanced string table refcount: (%d) for \"%s\"",
569 HeVAL(hent) - Nullsv, HeKEY(hent));
570 HeVAL(hent) = Nullsv;
580 SvREFCNT_dec(strtab);
583 warn("Scalars leaked: %ld\n", (long)sv_count);
587 /* No SVs have survived, need to clean out */
591 Safefree(origfilename);
593 hints = 0; /* Reset hints. Should hints be per-interpreter ? */
595 DEBUG_P(debprofdump());
597 MUTEX_DESTROY(&sv_mutex);
598 MUTEX_DESTROY(&malloc_mutex);
599 MUTEX_DESTROY(&eval_mutex);
600 COND_DESTROY(&eval_cond);
602 /* As the penultimate thing, free the non-arena SV for thrsv */
603 Safefree(SvPVX(thrsv));
604 Safefree(SvANY(thrsv));
607 #endif /* USE_THREADS */
609 /* As the absolutely last thing, free the non-arena SV for mess() */
612 /* we know that type >= SVt_PV */
614 Safefree(SvPVX(mess_sv));
615 Safefree(SvANY(mess_sv));
623 PerlInterpreter *sv_interp;
625 if (!(curinterp = sv_interp))
631 perl_parse(sv_interp, xsinit, argc, argv, env)
632 PerlInterpreter *sv_interp;
633 void (*xsinit)_((void));
641 char *scriptname = NULL;
642 VOL bool dosearch = FALSE;
649 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
652 croak("suidperl is no longer needed since the kernel can now execute\n\
653 setuid perl scripts securely.\n");
657 if (!(curinterp = sv_interp))
660 #if defined(NeXT) && defined(__DYNAMIC__)
661 _dyld_lookup_and_bind
662 ("__environ", (unsigned long *) &environ_pointer, NULL);
667 #ifndef VMS /* VMS doesn't have environ array */
668 origenviron = environ;
674 /* Come here if running an undumped a.out. */
676 origfilename = savepv(argv[0]);
678 cxstack_ix = -1; /* start label stack again */
680 init_postdump_symbols(argc,argv,env);
685 curpad = AvARRAY(comppad);
690 SvREFCNT_dec(main_cv);
694 oldscope = scopestack_ix;
702 /* my_exit() was called */
703 while (scopestack_ix > oldscope)
708 call_list(oldscope, endav);
710 return STATUS_NATIVE_EXPORT;
713 PerlIO_printf(PerlIO_stderr(), "panic: top_env\n");
717 sv_setpvn(linestr,"",0);
718 sv = newSVpv("",0); /* first used for -I flags */
722 for (argc--,argv++; argc > 0; argc--,argv++) {
723 if (argv[0][0] != '-' || !argv[0][1])
727 validarg = " PHOOEY ";
752 if (s = moreswitches(s))
762 if (euid != uid || egid != gid)
763 croak("No -e allowed in setuid scripts");
765 e_tmpname = savepv(TMPPATH);
766 (void)mktemp(e_tmpname);
768 croak("Can't mktemp()");
769 e_fp = PerlIO_open(e_tmpname,"w");
771 croak("Cannot open temporary file");
776 PerlIO_puts(e_fp,argv[1]);
780 croak("No code specified for -e");
781 (void)PerlIO_putc(e_fp,'\n');
783 case 'I': /* -I handled both here and in moreswitches() */
785 if (!*++s && (s=argv[1]) != Nullch) {
788 while (s && isSPACE(*s))
792 for (e = s; *e && !isSPACE(*e); e++) ;
799 } /* XXX else croak? */
813 preambleav = newAV();
814 av_push(preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
816 Sv = newSVpv("print myconfig();",0);
818 sv_catpv(Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
820 sv_catpv(Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
822 #if defined(DEBUGGING) || defined(NO_EMBED) || defined(MULTIPLICITY)
823 sv_catpv(Sv,"\" Compile-time options:");
825 sv_catpv(Sv," DEBUGGING");
828 sv_catpv(Sv," NO_EMBED");
831 sv_catpv(Sv," MULTIPLICITY");
833 sv_catpv(Sv,"\\n\",");
835 #if defined(LOCAL_PATCH_COUNT)
836 if (LOCAL_PATCH_COUNT > 0) {
838 sv_catpv(Sv,"\" Locally applied patches:\\n\",");
839 for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
841 sv_catpvf(Sv,"\" \\t%s\\n\",",localpatches[i]);
845 sv_catpvf(Sv,"\" Built under %s\\n\"",OSNAME);
848 sv_catpvf(Sv,",\" Compiled at %s %s\\n\"",__DATE__,__TIME__);
850 sv_catpvf(Sv,",\" Compiled on %s\\n\"",__DATE__);
855 @env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; \
856 print \" \\%ENV:\\n @env\\n\" if @env; \
857 print \" \\@INC:\\n @INC\\n\";");
860 Sv = newSVpv("config_vars(qw(",0);
865 av_push(preambleav, Sv);
866 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
877 if (!*++s || isSPACE(*s)) {
881 /* catch use of gnu style long options */
882 if (strEQ(s, "version")) {
886 if (strEQ(s, "help")) {
893 croak("Unrecognized switch: -%s (-h will show valid options)",s);
898 if (!tainting && (s = getenv("PERL5OPT"))) {
909 if (!strchr("DIMUdmw", *s))
910 croak("Illegal switch in PERL5OPT: -%c", *s);
916 scriptname = argv[0];
918 if (PerlIO_flush(e_fp) || PerlIO_error(e_fp) || PerlIO_close(e_fp)) {
920 warn("Did you forget to compile with -DMULTIPLICITY?");
922 croak("Can't write to temp file for -e: %s", Strerror(errno));
926 scriptname = e_tmpname;
928 else if (scriptname == Nullch) {
930 if ( isatty(PerlIO_fileno(PerlIO_stdin())) )
938 open_script(scriptname,dosearch,sv);
940 validate_suid(validarg, scriptname);
945 main_cv = compcv = (CV*)NEWSV(1104,0);
946 sv_upgrade((SV *)compcv, SVt_PVCV);
950 av_push(comppad, Nullsv);
951 curpad = AvARRAY(comppad);
952 comppad_name = newAV();
953 comppad_name_fill = 0;
954 min_intro_pending = 0;
957 av_store(comppad_name, 0, newSVpv("@_", 2));
958 curpad[0] = (SV*)newAV();
959 SvPADMY_on(curpad[0]); /* XXX Needed? */
961 New(666, CvMUTEXP(compcv), 1, perl_mutex);
962 MUTEX_INIT(CvMUTEXP(compcv));
963 #endif /* USE_THREADS */
965 comppadlist = newAV();
966 AvREAL_off(comppadlist);
967 av_store(comppadlist, 0, (SV*)comppad_name);
968 av_store(comppadlist, 1, (SV*)comppad);
969 CvPADLIST(compcv) = comppadlist;
971 boot_core_UNIVERSAL();
973 (*xsinit)(); /* in case linked C routines want magical variables */
974 #if defined(VMS) || defined(WIN32)
978 #if defined(DEBUGGING) && defined(USE_THREADS) && defined(__linux__)
979 DEBUG_L(signal(SIGSEGV, (void(*)(int))catch_sigsegv););
982 init_predump_symbols();
984 init_postdump_symbols(argc,argv,env);
988 /* now parse the script */
991 if (yyparse() || error_count) {
993 croak("%s had compilation errors.\n", origfilename);
995 croak("Execution of %s aborted due to compilation errors.\n",
999 curcop->cop_line = 0;
1000 curstash = defstash;
1003 (void)UNLINK(e_tmpname);
1004 Safefree(e_tmpname);
1008 /* now that script is parsed, we can modify record separator */
1010 rs = SvREFCNT_inc(nrs);
1011 sv_setsv(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), rs);
1023 if ((s=getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
1024 dump_mstats("after compilation:");
1035 PerlInterpreter *sv_interp;
1042 if (!(curinterp = sv_interp))
1045 oldscope = scopestack_ix;
1050 cxstack_ix = -1; /* start context stack again */
1053 /* my_exit() was called */
1054 while (scopestack_ix > oldscope)
1057 curstash = defstash;
1059 call_list(oldscope, endav);
1061 if (getenv("PERL_DEBUG_MSTATS"))
1062 dump_mstats("after execution: ");
1065 return STATUS_NATIVE_EXPORT;
1068 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
1073 if (curstack != mainstack) {
1075 SWITCHSTACK(curstack, mainstack);
1080 DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
1081 sawampersand ? "Enabling" : "Omitting"));
1084 DEBUG_x(dump_all());
1085 DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
1087 DEBUG_L(PerlIO_printf(Perl_debug_log, "main thread is 0x%lx\n",
1088 (unsigned long) thr));
1089 #endif /* USE_THREADS */
1092 PerlIO_printf(PerlIO_stderr(), "%s syntax OK\n", origfilename);
1095 if (PERLDB_SINGLE && DBsingle)
1096 sv_setiv(DBsingle, 1);
1098 call_list(oldscope, initav);
1108 else if (main_start) {
1109 CvDEPTH(main_cv) = 1;
1120 perl_get_sv(name, create)
1124 GV* gv = gv_fetchpv(name, create, SVt_PV);
1131 perl_get_av(name, create)
1135 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
1144 perl_get_hv(name, create)
1148 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
1157 perl_get_cv(name, create)
1161 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
1162 if (create && !GvCVu(gv))
1163 return newSUB(start_subparse(FALSE, 0),
1164 newSVOP(OP_CONST, 0, newSVpv(name,0)),
1172 /* Be sure to refetch the stack pointer after calling these routines. */
1175 perl_call_argv(subname, flags, argv)
1177 I32 flags; /* See G_* flags in cop.h */
1178 register char **argv; /* null terminated arg list */
1186 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
1191 return perl_call_pv(subname, flags);
1195 perl_call_pv(subname, flags)
1196 char *subname; /* name of the subroutine */
1197 I32 flags; /* See G_* flags in cop.h */
1199 return perl_call_sv((SV*)perl_get_cv(subname, TRUE), flags);
1203 perl_call_method(methname, flags)
1204 char *methname; /* name of the subroutine */
1205 I32 flags; /* See G_* flags in cop.h */
1212 XPUSHs(sv_2mortal(newSVpv(methname,0)));
1215 return perl_call_sv(*stack_sp--, flags);
1218 /* May be called with any of a CV, a GV, or an SV containing the name. */
1220 perl_call_sv(sv, flags)
1222 I32 flags; /* See G_* flags in cop.h */
1225 LOGOP myop; /* fake syntax tree node */
1231 bool oldcatch = CATCH_GET;
1236 if (flags & G_DISCARD) {
1241 Zero(&myop, 1, LOGOP);
1242 myop.op_next = Nullop;
1243 if (!(flags & G_NOARGS))
1244 myop.op_flags |= OPf_STACKED;
1245 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1246 (flags & G_ARRAY) ? OPf_WANT_LIST :
1251 EXTEND(stack_sp, 1);
1254 oldscope = scopestack_ix;
1256 if (PERLDB_SUB && curstash != debstash
1257 /* Handle first BEGIN of -d. */
1258 && (DBcv || (DBcv = GvCV(DBsub)))
1259 /* Try harder, since this may have been a sighandler, thus
1260 * curstash may be meaningless. */
1261 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != debstash))
1262 op->op_private |= OPpENTERSUB_DB;
1264 if (flags & G_EVAL) {
1265 cLOGOP->op_other = op;
1267 /* we're trying to emulate pp_entertry() here */
1269 register CONTEXT *cx;
1270 I32 gimme = GIMME_V;
1275 push_return(op->op_next);
1276 PUSHBLOCK(cx, CXt_EVAL, stack_sp);
1278 eval_root = op; /* Only needed so that goto works right. */
1281 if (flags & G_KEEPERR)
1284 sv_setpv(GvSV(errgv),"");
1296 /* my_exit() was called */
1297 curstash = defstash;
1301 croak("Callback called exit");
1310 stack_sp = stack_base + oldmark;
1311 if (flags & G_ARRAY)
1315 *++stack_sp = &sv_undef;
1323 if (op == (OP*)&myop)
1324 op = pp_entersub(ARGS);
1327 retval = stack_sp - (stack_base + oldmark);
1328 if ((flags & G_EVAL) && !(flags & G_KEEPERR))
1329 sv_setpv(GvSV(errgv),"");
1332 if (flags & G_EVAL) {
1333 if (scopestack_ix > oldscope) {
1337 register CONTEXT *cx;
1349 CATCH_SET(oldcatch);
1351 if (flags & G_DISCARD) {
1352 stack_sp = stack_base + oldmark;
1361 /* Eval a string. The G_EVAL flag is always assumed. */
1364 perl_eval_sv(sv, flags)
1366 I32 flags; /* See G_* flags in cop.h */
1369 UNOP myop; /* fake syntax tree node */
1371 I32 oldmark = sp - stack_base;
1378 if (flags & G_DISCARD) {
1386 EXTEND(stack_sp, 1);
1388 oldscope = scopestack_ix;
1390 if (!(flags & G_NOARGS))
1391 myop.op_flags = OPf_STACKED;
1392 myop.op_next = Nullop;
1393 myop.op_type = OP_ENTEREVAL;
1394 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1395 (flags & G_ARRAY) ? OPf_WANT_LIST :
1397 if (flags & G_KEEPERR)
1398 myop.op_flags |= OPf_SPECIAL;
1408 /* my_exit() was called */
1409 curstash = defstash;
1413 croak("Callback called exit");
1422 stack_sp = stack_base + oldmark;
1423 if (flags & G_ARRAY)
1427 *++stack_sp = &sv_undef;
1432 if (op == (OP*)&myop)
1433 op = pp_entereval(ARGS);
1436 retval = stack_sp - (stack_base + oldmark);
1437 if (!(flags & G_KEEPERR))
1438 sv_setpv(GvSV(errgv),"");
1442 if (flags & G_DISCARD) {
1443 stack_sp = stack_base + oldmark;
1453 perl_eval_pv(p, croak_on_error)
1459 SV* sv = newSVpv(p, 0);
1462 perl_eval_sv(sv, G_SCALAR);
1469 if (croak_on_error && SvTRUE(GvSV(errgv)))
1470 croak(SvPVx(GvSV(errgv), na));
1475 /* Require a module. */
1481 SV* sv = sv_newmortal();
1482 sv_setpv(sv, "require '");
1485 perl_eval_sv(sv, G_DISCARD);
1489 magicname(sym,name,namlen)
1496 if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
1497 sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
1501 usage(name) /* XXX move this out into a module ? */
1504 /* This message really ought to be max 23 lines.
1505 * Removed -h because the user already knows that opton. Others? */
1507 static char *usage[] = {
1508 "-0[octal] specify record separator (\\0, if no argument)",
1509 "-a autosplit mode with -n or -p (splits $_ into @F)",
1510 "-c check syntax only (runs BEGIN and END blocks)",
1511 "-d[:debugger] run scripts under debugger",
1512 "-D[number/list] set debugging flags (argument is a bit mask or flags)",
1513 "-e 'command' one line of script. Several -e's allowed. Omit [programfile].",
1514 "-F/pattern/ split() pattern for autosplit (-a). The //'s are optional.",
1515 "-i[extension] edit <> files in place (make backup if extension supplied)",
1516 "-Idirectory specify @INC/#include directory (may be used more than once)",
1517 "-l[octal] enable line ending processing, specifies line terminator",
1518 "-[mM][-]module.. executes `use/no module...' before executing your script.",
1519 "-n assume 'while (<>) { ... }' loop around your script",
1520 "-p assume loop like -n but print line also like sed",
1521 "-P run script through C preprocessor before compilation",
1522 "-s enable some switch parsing for switches after script name",
1523 "-S look for the script using PATH environment variable",
1524 "-T turn on tainting checks",
1525 "-u dump core after parsing script",
1526 "-U allow unsafe operations",
1527 "-v print version number and patchlevel of perl",
1528 "-V[:variable] print perl configuration information",
1529 "-w TURN WARNINGS ON FOR COMPILATION OF YOUR SCRIPT. Recommended.",
1530 "-x[directory] strip off text before #!perl line and perhaps cd to directory",
1536 printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
1538 printf("\n %s", *p++);
1541 /* This routine handles any switches that can be given during run */
1552 rschar = scan_oct(s, 4, &numlen);
1554 if (rschar & ~((U8)~0))
1556 else if (!rschar && numlen >= 2)
1557 nrs = newSVpv("", 0);
1560 nrs = newSVpv(&ch, 1);
1565 splitstr = savepv(s + 1);
1579 if (*s == ':' || *s == '=') {
1580 my_setenv("PERL5DB", form("use Devel::%s;", ++s));
1584 perldb = PERLDB_ALL;
1591 if (isALPHA(s[1])) {
1592 static char debopts[] = "psltocPmfrxuLHXD";
1595 for (s++; *s && (d = strchr(debopts,*s)); s++)
1596 debug |= 1 << (d - debopts);
1600 for (s++; isDIGIT(*s); s++) ;
1602 debug |= 0x80000000;
1604 warn("Recompile perl with -DDEBUGGING to use -D switch\n");
1605 for (s++; isALNUM(*s); s++) ;
1615 inplace = savepv(s+1);
1617 for (s = inplace; *s && !isSPACE(*s); s++) ;
1621 case 'I': /* -I handled both here and in parse_perl() */
1624 while (*s && isSPACE(*s))
1628 for (e = s; *e && !isSPACE(*e); e++) ;
1629 p = savepvn(s, e-s);
1635 croak("No space allowed after -I");
1645 *ors = scan_oct(s, 3 + (*s == '0'), &numlen);
1654 ors = SvPV(nrs, orslen);
1655 ors = savepvn(ors, orslen);
1659 forbid_setid("-M"); /* XXX ? */
1662 forbid_setid("-m"); /* XXX ? */
1667 /* -M-foo == 'no foo' */
1668 if (*s == '-') { use = "no "; ++s; }
1669 sv = newSVpv(use,0);
1671 /* We allow -M'Module qw(Foo Bar)' */
1672 while(isALNUM(*s) || *s==':') ++s;
1674 sv_catpv(sv, start);
1675 if (*(start-1) == 'm') {
1677 croak("Can't use '%c' after -mname", *s);
1678 sv_catpv( sv, " ()");
1681 sv_catpvn(sv, start, s-start);
1682 sv_catpv(sv, " split(/,/,q{");
1687 if (preambleav == NULL)
1688 preambleav = newAV();
1689 av_push(preambleav, sv);
1692 croak("No space allowed after -%c", *(s-1));
1709 croak("Too late for \"-T\" option");
1721 #if defined(SUBVERSION) && SUBVERSION > 0
1722 printf("\nThis is perl, version 5.%03d_%02d built for %s",
1723 PATCHLEVEL, SUBVERSION, ARCHNAME);
1725 printf("\nThis is perl, version %s built for %s",
1726 patchlevel, ARCHNAME);
1728 #if defined(LOCAL_PATCH_COUNT)
1729 if (LOCAL_PATCH_COUNT > 0)
1730 printf("\n(with %d registered patch%s, see perl -V for more detail)",
1731 LOCAL_PATCH_COUNT, (LOCAL_PATCH_COUNT!=1) ? "es" : "");
1734 printf("\n\nCopyright 1987-1997, Larry Wall\n");
1736 printf("\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
1739 printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n");
1742 printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
1743 "Version 5 port Copyright (c) 1994-1997, Andreas Kaiser, Ilya Zakharevich\n");
1746 printf("atariST series port, ++jrb bammi@cadence.com\n");
1749 Perl may be copied only under the terms of either the Artistic License or the\n\
1750 GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n");
1758 if (s[1] == '-') /* Additional switches on #! line. */
1766 #ifdef ALTERNATE_SHEBANG
1767 case 'S': /* OS/2 needs -S on "extproc" line. */
1775 croak("Can't emulate -%.1s on #! line",s);
1780 /* compliments of Tom Christiansen */
1782 /* unexec() can be found in the Gnu emacs distribution */
1793 prog = newSVpv(BIN_EXP);
1794 sv_catpv(prog, "/perl");
1795 file = newSVpv(origfilename);
1796 sv_catpv(file, ".perldump");
1798 status = unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
1800 PerlIO_printf(PerlIO_stderr(), "unexec of %s into %s failed!\n",
1801 SvPVX(prog), SvPVX(file));
1805 # include <lib$routines.h>
1806 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
1808 ABORT(); /* for use with undump */
1819 /* Note that strtab is a rather special HV. Assumptions are made
1820 about not iterating on it, and not adding tie magic to it.
1821 It is properly deallocated in perl_destruct() */
1823 HvSHAREKEYS_off(strtab); /* mandatory */
1824 Newz(506,((XPVHV*)SvANY(strtab))->xhv_array,
1825 sizeof(HE*) * (((XPVHV*)SvANY(strtab))->xhv_max + 1), char);
1827 curstash = defstash = newHV();
1828 curstname = newSVpv("main",4);
1829 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
1830 SvREFCNT_dec(GvHV(gv));
1831 GvHV(gv) = (HV*)SvREFCNT_inc(defstash);
1833 HvNAME(defstash) = savepv("main");
1834 incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
1836 defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
1837 errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
1839 (void)form("%240s",""); /* Preallocate temp - for immediate signals. */
1840 sv_grow(GvSV(errgv), 240); /* Preallocate - for immediate signals. */
1841 sv_setpvn(GvSV(errgv), "", 0);
1842 curstash = defstash;
1843 compiling.cop_stash = defstash;
1844 debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
1845 /* We must init $/ before switches are processed. */
1846 sv_setpvn(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), "\n", 1);
1849 #ifdef CAN_PROTOTYPE
1851 open_script(char *scriptname, bool dosearch, SV *sv)
1854 open_script(scriptname,dosearch,sv)
1861 char *xfound = Nullch;
1862 char *xfailed = Nullch;
1866 #if defined(DOSISH) && !defined(OS2) && !defined(atarist)
1867 # define SEARCH_EXTS ".bat", ".cmd", NULL
1868 # define MAX_EXT_LEN 4
1871 # define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL
1872 # define MAX_EXT_LEN 4
1875 # define SEARCH_EXTS ".pl", ".com", NULL
1876 # define MAX_EXT_LEN 4
1878 /* additional extensions to try in each dir if scriptname not found */
1880 char *ext[] = { SEARCH_EXTS };
1881 int extidx = 0, i = 0;
1882 char *curext = Nullch;
1884 # define MAX_EXT_LEN 0
1888 * If dosearch is true and if scriptname does not contain path
1889 * delimiters, search the PATH for scriptname.
1891 * If SEARCH_EXTS is also defined, will look for each
1892 * scriptname{SEARCH_EXTS} whenever scriptname is not found
1893 * while searching the PATH.
1895 * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
1896 * proceeds as follows:
1898 * + look for ./scriptname{,.foo,.bar}
1899 * + search the PATH for scriptname{,.foo,.bar}
1902 * + look *only* in the PATH for scriptname{,.foo,.bar} (note
1903 * this will not look in '.' if it's not in the PATH)
1908 int hasdir, idx = 0, deftypes = 1;
1911 hasdir = (strpbrk(scriptname,":[</") != Nullch) ;
1912 /* The first time through, just add SEARCH_EXTS to whatever we
1913 * already have, so we can check for default file types. */
1915 (!hasdir && my_trnlnm("DCL$PATH",tokenbuf,idx++)) )
1921 if ((strlen(tokenbuf) + strlen(scriptname)
1922 + MAX_EXT_LEN) >= sizeof tokenbuf)
1923 continue; /* don't search dir with too-long name */
1924 strcat(tokenbuf, scriptname);
1928 if (strEQ(scriptname, "-"))
1930 if (dosearch) { /* Look in '.' first. */
1931 char *cur = scriptname;
1933 if ((curext = strrchr(scriptname,'.'))) /* possible current ext */
1935 if (strEQ(ext[i++],curext)) {
1936 extidx = -1; /* already has an ext */
1941 DEBUG_p(PerlIO_printf(Perl_debug_log,
1942 "Looking for %s\n",cur));
1943 if (Stat(cur,&statbuf) >= 0) {
1951 if (cur == scriptname) {
1952 len = strlen(scriptname);
1953 if (len+MAX_EXT_LEN+1 >= sizeof(tokenbuf))
1955 cur = strcpy(tokenbuf, scriptname);
1957 } while (extidx >= 0 && ext[extidx] /* try an extension? */
1958 && strcpy(tokenbuf+len, ext[extidx++]));
1963 if (dosearch && !strchr(scriptname, '/')
1965 && !strchr(scriptname, '\\')
1967 && (s = getenv("PATH"))) {
1970 bufend = s + strlen(s);
1971 while (s < bufend) {
1972 #if defined(atarist) || defined(DOSISH)
1977 && *s != ';'; len++, s++) {
1978 if (len < sizeof tokenbuf)
1981 if (len < sizeof tokenbuf)
1982 tokenbuf[len] = '\0';
1983 #else /* ! (atarist || DOSISH) */
1984 s = delimcpy(tokenbuf, tokenbuf + sizeof tokenbuf, s, bufend,
1987 #endif /* ! (atarist || DOSISH) */
1990 if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tokenbuf)
1991 continue; /* don't search dir with too-long name */
1993 #if defined(atarist) || defined(DOSISH)
1994 && tokenbuf[len - 1] != '/'
1995 && tokenbuf[len - 1] != '\\'
1998 tokenbuf[len++] = '/';
1999 if (len == 2 && tokenbuf[0] == '.')
2001 (void)strcpy(tokenbuf + len, scriptname);
2005 len = strlen(tokenbuf);
2006 if (extidx > 0) /* reset after previous loop */
2010 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tokenbuf));
2011 retval = Stat(tokenbuf,&statbuf);
2013 } while ( retval < 0 /* not there */
2014 && extidx>=0 && ext[extidx] /* try an extension? */
2015 && strcpy(tokenbuf+len, ext[extidx++])
2020 if (S_ISREG(statbuf.st_mode)
2021 && cando(S_IRUSR,TRUE,&statbuf)
2023 && cando(S_IXUSR,TRUE,&statbuf)
2027 xfound = tokenbuf; /* bingo! */
2031 xfailed = savepv(tokenbuf);
2034 if (!xfound && !seen_dot && !xfailed && (Stat(scriptname,&statbuf) < 0))
2036 seen_dot = 1; /* Disable message. */
2038 croak("Can't %s %s%s%s",
2039 (xfailed ? "execute" : "find"),
2040 (xfailed ? xfailed : scriptname),
2041 (xfailed ? "" : " on PATH"),
2042 (xfailed || seen_dot) ? "" : ", '.' not in PATH");
2045 scriptname = xfound;
2048 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
2049 char *s = scriptname + 8;
2058 origfilename = savepv(e_tmpname ? "-e" : scriptname);
2059 curcop->cop_filegv = gv_fetchfile(origfilename);
2060 if (strEQ(origfilename,"-"))
2062 if (fdscript >= 0) {
2063 rsfp = PerlIO_fdopen(fdscript,"r");
2064 #if defined(HAS_FCNTL) && defined(F_SETFD)
2066 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
2069 else if (preprocess) {
2070 char *cpp_cfg = CPPSTDIN;
2071 SV *cpp = NEWSV(0,0);
2072 SV *cmd = NEWSV(0,0);
2074 if (strEQ(cpp_cfg, "cppstdin"))
2075 sv_catpvf(cpp, "%s/", BIN_EXP);
2076 sv_catpv(cpp, cpp_cfg);
2079 sv_catpv(sv,PRIVLIB_EXP);
2083 sed %s -e \"/^[^#]/b\" \
2084 -e \"/^#[ ]*include[ ]/b\" \
2085 -e \"/^#[ ]*define[ ]/b\" \
2086 -e \"/^#[ ]*if[ ]/b\" \
2087 -e \"/^#[ ]*ifdef[ ]/b\" \
2088 -e \"/^#[ ]*ifndef[ ]/b\" \
2089 -e \"/^#[ ]*else/b\" \
2090 -e \"/^#[ ]*elif[ ]/b\" \
2091 -e \"/^#[ ]*undef[ ]/b\" \
2092 -e \"/^#[ ]*endif/b\" \
2095 (doextract ? "-e \"1,/^#/d\n\"" : ""),
2098 %s %s -e '/^[^#]/b' \
2099 -e '/^#[ ]*include[ ]/b' \
2100 -e '/^#[ ]*define[ ]/b' \
2101 -e '/^#[ ]*if[ ]/b' \
2102 -e '/^#[ ]*ifdef[ ]/b' \
2103 -e '/^#[ ]*ifndef[ ]/b' \
2104 -e '/^#[ ]*else/b' \
2105 -e '/^#[ ]*elif[ ]/b' \
2106 -e '/^#[ ]*undef[ ]/b' \
2107 -e '/^#[ ]*endif/b' \
2115 (doextract ? "-e '1,/^#/d\n'" : ""),
2117 scriptname, cpp, sv, CPPMINUS);
2119 #ifdef IAMSUID /* actually, this is caught earlier */
2120 if (euid != uid && !euid) { /* if running suidperl */
2122 (void)seteuid(uid); /* musn't stay setuid root */
2125 (void)setreuid((Uid_t)-1, uid);
2127 #ifdef HAS_SETRESUID
2128 (void)setresuid((Uid_t)-1, uid, (Uid_t)-1);
2134 if (geteuid() != uid)
2135 croak("Can't do seteuid!\n");
2137 #endif /* IAMSUID */
2138 rsfp = my_popen(SvPVX(cmd), "r");
2142 else if (!*scriptname) {
2143 forbid_setid("program input from stdin");
2144 rsfp = PerlIO_stdin();
2147 rsfp = PerlIO_open(scriptname,"r");
2148 #if defined(HAS_FCNTL) && defined(F_SETFD)
2150 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
2158 #ifndef IAMSUID /* in case script is not readable before setuid */
2159 if (euid && Stat(SvPVX(GvSV(curcop->cop_filegv)),&statbuf) >= 0 &&
2160 statbuf.st_mode & (S_ISUID|S_ISGID)) {
2162 execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
2163 croak("Can't do setuid\n");
2167 croak("Can't open perl script \"%s\": %s\n",
2168 SvPVX(GvSV(curcop->cop_filegv)), Strerror(errno));
2173 validate_suid(validarg, scriptname)
2179 /* do we need to emulate setuid on scripts? */
2181 /* This code is for those BSD systems that have setuid #! scripts disabled
2182 * in the kernel because of a security problem. Merely defining DOSUID
2183 * in perl will not fix that problem, but if you have disabled setuid
2184 * scripts in the kernel, this will attempt to emulate setuid and setgid
2185 * on scripts that have those now-otherwise-useless bits set. The setuid
2186 * root version must be called suidperl or sperlN.NNN. If regular perl
2187 * discovers that it has opened a setuid script, it calls suidperl with
2188 * the same argv that it had. If suidperl finds that the script it has
2189 * just opened is NOT setuid root, it sets the effective uid back to the
2190 * uid. We don't just make perl setuid root because that loses the
2191 * effective uid we had before invoking perl, if it was different from the
2194 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
2195 * be defined in suidperl only. suidperl must be setuid root. The
2196 * Configure script will set this up for you if you want it.
2202 if (Fstat(PerlIO_fileno(rsfp),&statbuf) < 0) /* normal stat is insecure */
2203 croak("Can't stat script \"%s\"",origfilename);
2204 if (fdscript < 0 && statbuf.st_mode & (S_ISUID|S_ISGID)) {
2208 #ifndef HAS_SETREUID
2209 /* On this access check to make sure the directories are readable,
2210 * there is actually a small window that the user could use to make
2211 * filename point to an accessible directory. So there is a faint
2212 * chance that someone could execute a setuid script down in a
2213 * non-accessible directory. I don't know what to do about that.
2214 * But I don't think it's too important. The manual lies when
2215 * it says access() is useful in setuid programs.
2217 if (access(SvPVX(GvSV(curcop->cop_filegv)),1)) /*double check*/
2218 croak("Permission denied");
2220 /* If we can swap euid and uid, then we can determine access rights
2221 * with a simple stat of the file, and then compare device and
2222 * inode to make sure we did stat() on the same file we opened.
2223 * Then we just have to make sure he or she can execute it.
2226 struct stat tmpstatbuf;
2230 setreuid(euid,uid) < 0
2233 setresuid(euid,uid,(Uid_t)-1) < 0
2236 || getuid() != euid || geteuid() != uid)
2237 croak("Can't swap uid and euid"); /* really paranoid */
2238 if (Stat(SvPVX(GvSV(curcop->cop_filegv)),&tmpstatbuf) < 0)
2239 croak("Permission denied"); /* testing full pathname here */
2240 if (tmpstatbuf.st_dev != statbuf.st_dev ||
2241 tmpstatbuf.st_ino != statbuf.st_ino) {
2242 (void)PerlIO_close(rsfp);
2243 if (rsfp = my_popen("/bin/mail root","w")) { /* heh, heh */
2245 "User %ld tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
2246 (Filename of set-id script was %s, uid %ld gid %ld.)\n\nSincerely,\nperl\n",
2247 (long)uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
2248 (long)statbuf.st_dev, (long)statbuf.st_ino,
2249 SvPVX(GvSV(curcop->cop_filegv)),
2250 (long)statbuf.st_uid, (long)statbuf.st_gid);
2251 (void)my_pclose(rsfp);
2253 croak("Permission denied\n");
2257 setreuid(uid,euid) < 0
2259 # if defined(HAS_SETRESUID)
2260 setresuid(uid,euid,(Uid_t)-1) < 0
2263 || getuid() != uid || geteuid() != euid)
2264 croak("Can't reswap uid and euid");
2265 if (!cando(S_IXUSR,FALSE,&statbuf)) /* can real uid exec? */
2266 croak("Permission denied\n");
2268 #endif /* HAS_SETREUID */
2269 #endif /* IAMSUID */
2271 if (!S_ISREG(statbuf.st_mode))
2272 croak("Permission denied");
2273 if (statbuf.st_mode & S_IWOTH)
2274 croak("Setuid/gid script is writable by world");
2275 doswitches = FALSE; /* -s is insecure in suid */
2277 if (sv_gets(linestr, rsfp, 0) == Nullch ||
2278 strnNE(SvPV(linestr,na),"#!",2) ) /* required even on Sys V */
2279 croak("No #! line");
2280 s = SvPV(linestr,na)+2;
2282 while (!isSPACE(*s)) s++;
2283 for (s2 = s; (s2 > SvPV(linestr,na)+2 &&
2284 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
2285 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
2286 croak("Not a perl script");
2287 while (*s == ' ' || *s == '\t') s++;
2289 * #! arg must be what we saw above. They can invoke it by
2290 * mentioning suidperl explicitly, but they may not add any strange
2291 * arguments beyond what #! says if they do invoke suidperl that way.
2293 len = strlen(validarg);
2294 if (strEQ(validarg," PHOOEY ") ||
2295 strnNE(s,validarg,len) || !isSPACE(s[len]))
2296 croak("Args must match #! line");
2299 if (euid != uid && (statbuf.st_mode & S_ISUID) &&
2300 euid == statbuf.st_uid)
2302 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2303 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2304 #endif /* IAMSUID */
2306 if (euid) { /* oops, we're not the setuid root perl */
2307 (void)PerlIO_close(rsfp);
2310 execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
2312 croak("Can't do setuid\n");
2315 if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid) {
2317 (void)setegid(statbuf.st_gid);
2320 (void)setregid((Gid_t)-1,statbuf.st_gid);
2322 #ifdef HAS_SETRESGID
2323 (void)setresgid((Gid_t)-1,statbuf.st_gid,(Gid_t)-1);
2325 setgid(statbuf.st_gid);
2329 if (getegid() != statbuf.st_gid)
2330 croak("Can't do setegid!\n");
2332 if (statbuf.st_mode & S_ISUID) {
2333 if (statbuf.st_uid != euid)
2335 (void)seteuid(statbuf.st_uid); /* all that for this */
2338 (void)setreuid((Uid_t)-1,statbuf.st_uid);
2340 #ifdef HAS_SETRESUID
2341 (void)setresuid((Uid_t)-1,statbuf.st_uid,(Uid_t)-1);
2343 setuid(statbuf.st_uid);
2347 if (geteuid() != statbuf.st_uid)
2348 croak("Can't do seteuid!\n");
2350 else if (uid) { /* oops, mustn't run as root */
2352 (void)seteuid((Uid_t)uid);
2355 (void)setreuid((Uid_t)-1,(Uid_t)uid);
2357 #ifdef HAS_SETRESUID
2358 (void)setresuid((Uid_t)-1,(Uid_t)uid,(Uid_t)-1);
2364 if (geteuid() != uid)
2365 croak("Can't do seteuid!\n");
2368 if (!cando(S_IXUSR,TRUE,&statbuf))
2369 croak("Permission denied\n"); /* they can't do this */
2372 else if (preprocess)
2373 croak("-P not allowed for setuid/setgid script\n");
2374 else if (fdscript >= 0)
2375 croak("fd script not allowed in suidperl\n");
2377 croak("Script is not setuid/setgid in suidperl\n");
2379 /* We absolutely must clear out any saved ids here, so we */
2380 /* exec the real perl, substituting fd script for scriptname. */
2381 /* (We pass script name as "subdir" of fd, which perl will grok.) */
2382 PerlIO_rewind(rsfp);
2383 lseek(PerlIO_fileno(rsfp),(Off_t)0,0); /* just in case rewind didn't */
2384 for (which = 1; origargv[which] && origargv[which] != scriptname; which++) ;
2385 if (!origargv[which])
2386 croak("Permission denied");
2387 origargv[which] = savepv(form("/dev/fd/%d/%s",
2388 PerlIO_fileno(rsfp), origargv[which]));
2389 #if defined(HAS_FCNTL) && defined(F_SETFD)
2390 fcntl(PerlIO_fileno(rsfp),F_SETFD,0); /* ensure no close-on-exec */
2392 execv(form("%s/perl%s", BIN_EXP, patchlevel), origargv); /* try again */
2393 croak("Can't do setuid\n");
2394 #endif /* IAMSUID */
2396 if (euid != uid || egid != gid) { /* (suidperl doesn't exist, in fact) */
2397 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
2399 Fstat(PerlIO_fileno(rsfp),&statbuf); /* may be either wrapped or real suid */
2400 if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
2402 (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
2405 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2406 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2407 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
2408 /* not set-id, must be wrapped */
2416 register char *s, *s2;
2418 /* skip forward in input to the real script? */
2422 if ((s = sv_gets(linestr, rsfp, 0)) == Nullch)
2423 croak("No Perl script found in input\n");
2424 if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
2425 PerlIO_ungetc(rsfp, '\n'); /* to keep line count right */
2427 while (*s && !(isSPACE (*s) || *s == '#')) s++;
2429 while (*s == ' ' || *s == '\t') s++;
2431 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
2432 if (strnEQ(s2-4,"perl",4))
2434 while (s = moreswitches(s)) ;
2436 if (cddir && chdir(cddir) < 0)
2437 croak("Can't chdir to %s",cddir);
2445 uid = (int)getuid();
2446 euid = (int)geteuid();
2447 gid = (int)getgid();
2448 egid = (int)getegid();
2453 tainting |= (uid && (euid != uid || egid != gid));
2461 croak("No %s allowed while running setuid", s);
2463 croak("No %s allowed while running setgid", s);
2470 curstash = debstash;
2471 dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
2473 DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
2474 DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
2475 DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
2476 DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
2477 sv_setiv(DBsingle, 0);
2478 DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
2479 sv_setiv(DBtrace, 0);
2480 DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
2481 sv_setiv(DBsignal, 0);
2482 curstash = defstash;
2490 mainstack = curstack; /* remember in case we switch stacks */
2491 AvREAL_off(curstack); /* not a real array */
2492 av_extend(curstack,127);
2494 stack_base = AvARRAY(curstack);
2495 stack_sp = stack_base;
2496 stack_max = stack_base + 127;
2498 cxstack_max = 8192 / sizeof(CONTEXT) - 2; /* Use most of 8K. */
2499 New(50,cxstack,cxstack_max + 1,CONTEXT);
2502 New(50,tmps_stack,128,SV*);
2508 * The following stacks almost certainly should be per-interpreter,
2509 * but for now they're not. XXX
2513 markstack_ptr = markstack;
2515 New(54,markstack,64,I32);
2516 markstack_ptr = markstack;
2517 markstack_max = markstack + 64;
2523 New(54,scopestack,32,I32);
2525 scopestack_max = 32;
2531 New(54,savestack,128,ANY);
2533 savestack_max = 128;
2539 New(54,retstack,16,OP*);
2550 Safefree(tmps_stack);
2557 static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
2566 subname = newSVpv("main",4);
2570 init_predump_symbols()
2576 sv_setpvn(GvSV(gv_fetchpv("\"", TRUE, SVt_PV)), " ", 1);
2578 stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
2579 GvMULTI_on(stdingv);
2580 IoIFP(GvIOp(stdingv)) = PerlIO_stdin();
2581 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
2583 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(stdingv));
2585 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
2587 IoOFP(GvIOp(tmpgv)) = IoIFP(GvIOp(tmpgv)) = PerlIO_stdout();
2589 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
2591 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(defoutgv));
2593 othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
2594 GvMULTI_on(othergv);
2595 IoOFP(GvIOp(othergv)) = IoIFP(GvIOp(othergv)) = PerlIO_stderr();
2596 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
2598 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(othergv));
2600 statname = NEWSV(66,0); /* last filename we did stat on */
2603 osname = savepv(OSNAME);
2607 init_postdump_symbols(argc,argv,env)
2609 register char **argv;
2610 register char **env;
2616 argc--,argv++; /* skip name of script */
2618 for (; argc > 0 && **argv == '-'; argc--,argv++) {
2621 if (argv[0][1] == '-') {
2625 if (s = strchr(argv[0], '=')) {
2627 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
2630 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
2633 toptarget = NEWSV(0,0);
2634 sv_upgrade(toptarget, SVt_PVFM);
2635 sv_setpvn(toptarget, "", 0);
2636 bodytarget = NEWSV(0,0);
2637 sv_upgrade(bodytarget, SVt_PVFM);
2638 sv_setpvn(bodytarget, "", 0);
2639 formtarget = bodytarget;
2642 if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
2643 sv_setpv(GvSV(tmpgv),origfilename);
2644 magicname("0", "0", 1);
2646 if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
2647 sv_setpv(GvSV(tmpgv),origargv[0]);
2648 if (argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
2650 (void)gv_AVadd(argvgv);
2651 av_clear(GvAVn(argvgv));
2652 for (; argc > 0; argc--,argv++) {
2653 av_push(GvAVn(argvgv),newSVpv(argv[0],0));
2656 if (envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
2660 hv_magic(hv, envgv, 'E');
2661 #ifndef VMS /* VMS doesn't have environ array */
2662 /* Note that if the supplied env parameter is actually a copy
2663 of the global environ then it may now point to free'd memory
2664 if the environment has been modified since. To avoid this
2665 problem we treat env==NULL as meaning 'use the default'
2670 environ[0] = Nullch;
2671 for (; *env; env++) {
2672 if (!(s = strchr(*env,'=')))
2678 sv = newSVpv(s--,0);
2679 (void)hv_store(hv, *env, s - *env, sv, 0);
2681 #if defined(__BORLANDC__) && defined(USE_WIN32_RTL_ENV)
2682 /* Sins of the RTL. See note in my_setenv(). */
2683 (void)putenv(savepv(*env));
2687 #ifdef DYNAMIC_ENV_FETCH
2688 HvNAME(hv) = savepv(ENV_HV_NAME);
2692 if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
2693 sv_setiv(GvSV(tmpgv), (IV)getpid());
2702 s = getenv("PERL5LIB");
2706 incpush(getenv("PERLLIB"), FALSE);
2708 /* Treat PERL5?LIB as a possible search list logical name -- the
2709 * "natural" VMS idiom for a Unix path string. We allow each
2710 * element to be a set of |-separated directories for compatibility.
2714 if (my_trnlnm("PERL5LIB",buf,0))
2715 do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
2717 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE);
2721 /* Use the ~-expanded versions of APPLLIB (undocumented),
2722 ARCHLIB PRIVLIB SITEARCH SITELIB and OLDARCHLIB
2725 incpush(APPLLIB_EXP, FALSE);
2729 incpush(ARCHLIB_EXP, FALSE);
2732 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
2734 incpush(PRIVLIB_EXP, FALSE);
2737 incpush(SITEARCH_EXP, FALSE);
2740 incpush(SITELIB_EXP, FALSE);
2742 #ifdef OLDARCHLIB_EXP /* 5.00[01] compatibility */
2743 incpush(OLDARCHLIB_EXP, FALSE);
2747 incpush(".", FALSE);
2751 # define PERLLIB_SEP ';'
2754 # define PERLLIB_SEP '|'
2756 # define PERLLIB_SEP ':'
2759 #ifndef PERLLIB_MANGLE
2760 # define PERLLIB_MANGLE(s,n) (s)
2764 incpush(p, addsubdirs)
2768 SV *subdir = Nullsv;
2769 static char *archpat_auto;
2776 if (!archpat_auto) {
2777 STRLEN len = (sizeof(ARCHNAME) + strlen(patchlevel)
2778 + sizeof("//auto"));
2779 New(55, archpat_auto, len, char);
2780 sprintf(archpat_auto, "/%s/%s/auto", ARCHNAME, patchlevel);
2782 for (len = sizeof(ARCHNAME) + 2;
2783 archpat_auto[len] != '\0' && archpat_auto[len] != '/'; len++)
2784 if (archpat_auto[len] == '.') archpat_auto[len] = '_';
2789 /* Break at all separators */
2791 SV *libdir = newSV(0);
2794 /* skip any consecutive separators */
2795 while ( *p == PERLLIB_SEP ) {
2796 /* Uncomment the next line for PATH semantics */
2797 /* av_push(GvAVn(incgv), newSVpv(".", 1)); */
2801 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
2802 sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
2807 sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
2808 p = Nullch; /* break out */
2812 * BEFORE pushing libdir onto @INC we may first push version- and
2813 * archname-specific sub-directories.
2816 struct stat tmpstatbuf;
2821 if ((unix = tounixspec_ts(SvPV(libdir,na),Nullch)) != Nullch) {
2823 while (unix[len-1] == '/') len--; /* Cosmetic */
2824 sv_usepvn(libdir,unix,len);
2827 PerlIO_printf(PerlIO_stderr(),
2828 "Failed to unixify @INC element \"%s\"\n",
2831 /* .../archname/version if -d .../archname/version/auto */
2832 sv_setsv(subdir, libdir);
2833 sv_catpv(subdir, archpat_auto);
2834 if (Stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2835 S_ISDIR(tmpstatbuf.st_mode))
2836 av_push(GvAVn(incgv),
2837 newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2839 /* .../archname if -d .../archname/auto */
2840 sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME),
2841 strlen(patchlevel) + 1, "", 0);
2842 if (Stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2843 S_ISDIR(tmpstatbuf.st_mode))
2844 av_push(GvAVn(incgv),
2845 newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2848 /* finally push this lib directory on the end of @INC */
2849 av_push(GvAVn(incgv), libdir);
2852 SvREFCNT_dec(subdir);
2856 call_list(oldscope, list)
2861 line_t oldline = curcop->cop_line;
2866 while (AvFILL(list) >= 0) {
2867 CV *cv = (CV*)av_shift(list);
2874 SV* atsv = GvSV(errgv);
2876 perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
2877 (void)SvPV(atsv, len);
2880 curcop = &compiling;
2881 curcop->cop_line = oldline;
2882 if (list == beginav)
2883 sv_catpv(atsv, "BEGIN failed--compilation aborted");
2885 sv_catpv(atsv, "END failed--cleanup aborted");
2886 while (scopestack_ix > oldscope)
2888 croak("%s", SvPVX(atsv));
2896 /* my_exit() was called */
2897 while (scopestack_ix > oldscope)
2900 curstash = defstash;
2902 call_list(oldscope, endav);
2904 curcop = &compiling;
2905 curcop->cop_line = oldline;
2907 if (list == beginav)
2908 croak("BEGIN failed--compilation aborted");
2910 croak("END failed--cleanup aborted");
2916 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
2921 curcop = &compiling;
2922 curcop->cop_line = oldline;
2936 DEBUG_L(PerlIO_printf(Perl_debug_log, "my_exit: thread 0x%lx, status %lu\n",
2937 (unsigned long) thr, (unsigned long) status));
2938 #endif /* USE_THREADS */
2947 STATUS_NATIVE_SET(status);
2957 if (vaxc$errno & 1) {
2958 if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
2959 STATUS_NATIVE_SET(44);
2962 if (!vaxc$errno && errno) /* unlikely */
2963 STATUS_NATIVE_SET(44);
2965 STATUS_NATIVE_SET(vaxc$errno);
2969 STATUS_POSIX_SET(errno);
2970 else if (STATUS_POSIX == 0)
2971 STATUS_POSIX_SET(255);
2980 register CONTEXT *cx;
2989 (void)UNLINK(e_tmpname);
2990 Safefree(e_tmpname);
2994 if (cxstack_ix >= 0) {