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 New(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);
158 self = pthread_self();
159 if (pthread_key_create(&thr_key, 0))
160 croak("panic: pthread_key_create");
161 if (pthread_setspecific(thr_key, (void *) thr))
162 croak("panic: pthread_setspecific");
163 #endif /* FAKE_THREADS */
164 #endif /* USE_THREADS */
166 linestr = NEWSV(65,80);
167 sv_upgrade(linestr,SVt_PVIV);
169 if (!SvREADONLY(&sv_undef)) {
170 SvREADONLY_on(&sv_undef);
174 SvREADONLY_on(&sv_no);
176 sv_setpv(&sv_yes,Yes);
178 SvREADONLY_on(&sv_yes);
181 nrs = newSVpv("\n", 1);
182 rs = SvREFCNT_inc(nrs);
184 sighandlerp = sighandler;
189 * There is no way we can refer to them from Perl so close them to save
190 * space. The other alternative would be to provide STDAUX and STDPRN
193 (void)fclose(stdaux);
194 (void)fclose(stdprn);
200 perl_destruct_level = 1;
202 if(perl_destruct_level > 0)
207 lex_state = LEX_NOTPARSING;
209 start_env.je_prev = NULL;
210 start_env.je_ret = -1;
211 start_env.je_mustcatch = TRUE;
212 top_env = &start_env;
215 SET_NUMERIC_STANDARD();
216 #if defined(SUBVERSION) && SUBVERSION > 0
217 sprintf(patchlevel, "%7.5f", (double) 5
218 + ((double) PATCHLEVEL / (double) 1000)
219 + ((double) SUBVERSION / (double) 100000));
221 sprintf(patchlevel, "%5.3f", (double) 5 +
222 ((double) PATCHLEVEL / (double) 1000));
225 #if defined(LOCAL_PATCH_COUNT)
226 localpatches = local_patches; /* For possible -v */
229 PerlIO_init(); /* Hook to IO system */
231 fdpid = newAV(); /* for remembering popen pids by fd */
235 New(51,debname,128,char);
236 New(52,debdelim,128,char);
243 perl_destruct(sv_interp)
244 register PerlInterpreter *sv_interp;
247 int destruct_level; /* 0=none, 1=full, 2=full with checks */
252 #endif /* USE_THREADS */
254 if (!(curinterp = sv_interp))
259 /* Pass 1 on any remaining threads: detach joinables, join zombies */
261 MUTEX_LOCK(&threads_mutex);
262 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
263 "perl_destruct: waiting for %d threads...\n",
265 for (t = thr->next; t != thr; t = t->next) {
266 MUTEX_LOCK(&t->mutex);
267 switch (ThrSTATE(t)) {
270 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
271 "perl_destruct: joining zombie %p\n", t));
272 ThrSETSTATE(t, THRf_DEAD);
273 MUTEX_UNLOCK(&t->mutex);
276 * The SvREFCNT_dec below may take a long time (e.g. av
277 * may contain an object scalar whose destructor gets
278 * called) so we have to unlock threads_mutex and start
281 MUTEX_UNLOCK(&threads_mutex);
282 if (pthread_join(t->Tself, (void**)&av))
283 croak("panic: pthread_join failed during global destruction");
284 SvREFCNT_dec((SV*)av);
285 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
286 "perl_destruct: joined zombie %p OK\n", t));
288 case THRf_R_JOINABLE:
289 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
290 "perl_destruct: detaching thread %p\n", t));
291 ThrSETSTATE(t, THRf_R_DETACHED);
293 * We unlock threads_mutex and t->mutex in the opposite order
294 * from which we locked them just so that DETACH won't
295 * deadlock if it panics. It's only a breach of good style
296 * not a bug since they are unlocks not locks.
298 MUTEX_UNLOCK(&threads_mutex);
300 MUTEX_UNLOCK(&t->mutex);
303 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
304 "perl_destruct: ignoring %p (state %u)\n",
306 MUTEX_UNLOCK(&t->mutex);
307 /* fall through and out */
310 /* We leave the above "Pass 1" loop with threads_mutex still locked */
312 /* Pass 2 on remaining threads: wait for the thread count to drop to one */
315 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
316 "perl_destruct: final wait for %d threads\n",
318 COND_WAIT(&nthreads_cond, &threads_mutex);
320 /* At this point, we're the last thread */
321 MUTEX_UNLOCK(&threads_mutex);
322 DEBUG_L(PerlIO_printf(PerlIO_stderr(), "perl_destruct: armageddon has arrived\n"));
323 MUTEX_DESTROY(&threads_mutex);
324 COND_DESTROY(&nthreads_cond);
325 #endif /* !defined(FAKE_THREADS) */
326 #endif /* USE_THREADS */
328 destruct_level = perl_destruct_level;
332 if (s = getenv("PERL_DESTRUCT_LEVEL")) {
334 if (destruct_level < i)
343 /* We must account for everything. */
345 /* Destroy the main CV and syntax tree */
347 curpad = AvARRAY(comppad);
352 SvREFCNT_dec(main_cv);
357 * Try to destruct global references. We do this first so that the
358 * destructors and destructees still exist. Some sv's might remain.
359 * Non-referenced objects are on their own.
366 /* unhook hooks which will soon be, or use, destroyed data */
367 SvREFCNT_dec(warnhook);
369 SvREFCNT_dec(diehook);
371 SvREFCNT_dec(parsehook);
374 if (destruct_level == 0){
376 DEBUG_P(debprofdump());
378 /* The exit() function will do everything that needs doing. */
382 /* loosen bonds of global variables */
385 (void)PerlIO_close(rsfp);
389 /* Filters for program text */
390 SvREFCNT_dec(rsfp_filters);
391 rsfp_filters = Nullav;
403 sawampersand = FALSE; /* must save all match strings */
404 sawstudy = FALSE; /* do fbm_instr on all strings */
419 /* magical thingies */
421 Safefree(ofs); /* $, */
424 Safefree(ors); /* $\ */
427 SvREFCNT_dec(nrs); /* $\ helper */
430 multiline = 0; /* $* */
432 SvREFCNT_dec(statname);
436 /* defgv, aka *_ should be taken care of elsewhere */
438 #if 0 /* just about all regexp stuff, seems to be ok */
440 /* shortcuts to regexp stuff */
445 SAVEFREEOP(oldlastpm); /* for saving regexp context during debugger */
447 regprecomp = NULL; /* uncompiled string. */
448 regparse = NULL; /* Input-scan pointer. */
449 regxend = NULL; /* End of input for compile */
450 regnpar = 0; /* () count. */
451 regcode = NULL; /* Code-emit pointer; ®dummy = don't. */
452 regsize = 0; /* Code size. */
453 regnaughty = 0; /* How bad is this pattern? */
454 regsawback = 0; /* Did we see \1, ...? */
456 reginput = NULL; /* String-input pointer. */
457 regbol = NULL; /* Beginning of input, for ^ check. */
458 regeol = NULL; /* End of input, for $ check. */
459 regstartp = (char **)NULL; /* Pointer to startp array. */
460 regendp = (char **)NULL; /* Ditto for endp. */
461 reglastparen = 0; /* Similarly for lastparen. */
462 regtill = NULL; /* How far we are required to go. */
463 regflags = 0; /* are we folding, multilining? */
464 regprev = (char)NULL; /* char before regbol, \n if none */
468 /* clean up after study() */
469 SvREFCNT_dec(lastscream);
471 Safefree(screamfirst);
473 Safefree(screamnext);
476 /* startup and shutdown function lists */
477 SvREFCNT_dec(beginav);
479 SvREFCNT_dec(initav);
484 /* temp stack during pp_sort() */
485 SvREFCNT_dec(sortstack);
488 /* shortcuts just get cleared */
498 /* reset so print() ends up where we expect */
501 /* Prepare to destruct main symbol table. */
508 if (destruct_level >= 2) {
509 if (scopestack_ix != 0)
510 warn("Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
511 (long)scopestack_ix);
512 if (savestack_ix != 0)
513 warn("Unbalanced saves: %ld more saves than restores\n",
515 if (tmps_floor != -1)
516 warn("Unbalanced tmps: %ld more allocs than frees\n",
517 (long)tmps_floor + 1);
518 if (cxstack_ix != -1)
519 warn("Unbalanced context: %ld more PUSHes than POPs\n",
520 (long)cxstack_ix + 1);
523 /* Now absolutely destruct everything, somehow or other, loops or no. */
525 SvFLAGS(strtab) |= SVTYPEMASK; /* don't clean out strtab now */
526 while (sv_count != 0 && sv_count != last_sv_count) {
527 last_sv_count = sv_count;
530 SvFLAGS(strtab) &= ~SVTYPEMASK;
531 SvFLAGS(strtab) |= SVt_PVHV;
533 /* Destruct the global string table. */
535 /* Yell and reset the HeVAL() slots that are still holding refcounts,
536 * so that sv_free() won't fail on them.
545 array = HvARRAY(strtab);
549 warn("Unbalanced string table refcount: (%d) for \"%s\"",
550 HeVAL(hent) - Nullsv, HeKEY(hent));
551 HeVAL(hent) = Nullsv;
561 SvREFCNT_dec(strtab);
564 warn("Scalars leaked: %ld\n", (long)sv_count);
568 /* No SVs have survived, need to clean out */
572 Safefree(origfilename);
574 hints = 0; /* Reset hints. Should hints be per-interpreter ? */
576 DEBUG_P(debprofdump());
578 MUTEX_DESTROY(&sv_mutex);
579 MUTEX_DESTROY(&malloc_mutex);
580 MUTEX_DESTROY(&eval_mutex);
581 COND_DESTROY(&eval_cond);
583 /* As the penultimate thing, free the non-arena SV for thrsv */
584 Safefree(SvPVX(thrsv));
585 Safefree(SvANY(thrsv));
588 #endif /* USE_THREADS */
590 /* As the absolutely last thing, free the non-arena SV for mess() */
593 /* we know that type >= SVt_PV */
595 Safefree(SvPVX(mess_sv));
596 Safefree(SvANY(mess_sv));
604 PerlInterpreter *sv_interp;
606 if (!(curinterp = sv_interp))
612 perl_parse(sv_interp, xsinit, argc, argv, env)
613 PerlInterpreter *sv_interp;
614 void (*xsinit)_((void));
622 char *scriptname = NULL;
623 VOL bool dosearch = FALSE;
630 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
633 croak("suidperl is no longer needed since the kernel can now execute\n\
634 setuid perl scripts securely.\n");
638 if (!(curinterp = sv_interp))
641 #if defined(NeXT) && defined(__DYNAMIC__)
642 _dyld_lookup_and_bind
643 ("__environ", (unsigned long *) &environ_pointer, NULL);
648 #ifndef VMS /* VMS doesn't have environ array */
649 origenviron = environ;
655 /* Come here if running an undumped a.out. */
657 origfilename = savepv(argv[0]);
659 cxstack_ix = -1; /* start label stack again */
661 init_postdump_symbols(argc,argv,env);
666 curpad = AvARRAY(comppad);
671 SvREFCNT_dec(main_cv);
675 oldscope = scopestack_ix;
683 /* my_exit() was called */
684 while (scopestack_ix > oldscope)
689 call_list(oldscope, endav);
691 return STATUS_NATIVE_EXPORT;
694 PerlIO_printf(PerlIO_stderr(), "panic: top_env\n");
698 sv_setpvn(linestr,"",0);
699 sv = newSVpv("",0); /* first used for -I flags */
703 for (argc--,argv++; argc > 0; argc--,argv++) {
704 if (argv[0][0] != '-' || !argv[0][1])
708 validarg = " PHOOEY ";
733 if (s = moreswitches(s))
743 if (euid != uid || egid != gid)
744 croak("No -e allowed in setuid scripts");
746 e_tmpname = savepv(TMPPATH);
747 (void)mktemp(e_tmpname);
749 croak("Can't mktemp()");
750 e_fp = PerlIO_open(e_tmpname,"w");
752 croak("Cannot open temporary file");
757 PerlIO_puts(e_fp,argv[1]);
761 croak("No code specified for -e");
762 (void)PerlIO_putc(e_fp,'\n');
764 case 'I': /* -I handled both here and in moreswitches() */
766 if (!*++s && (s=argv[1]) != Nullch) {
769 while (s && isSPACE(*s))
773 for (e = s; *e && !isSPACE(*e); e++) ;
780 } /* XXX else croak? */
794 preambleav = newAV();
795 av_push(preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
797 Sv = newSVpv("print myconfig();",0);
799 sv_catpv(Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
801 sv_catpv(Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
803 #if defined(DEBUGGING) || defined(NO_EMBED) || defined(MULTIPLICITY)
804 sv_catpv(Sv,"\" Compile-time options:");
806 sv_catpv(Sv," DEBUGGING");
809 sv_catpv(Sv," NO_EMBED");
812 sv_catpv(Sv," MULTIPLICITY");
814 sv_catpv(Sv,"\\n\",");
816 #if defined(LOCAL_PATCH_COUNT)
817 if (LOCAL_PATCH_COUNT > 0) {
819 sv_catpv(Sv,"\" Locally applied patches:\\n\",");
820 for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
822 sv_catpvf(Sv,"\" \\t%s\\n\",",localpatches[i]);
826 sv_catpvf(Sv,"\" Built under %s\\n\"",OSNAME);
829 sv_catpvf(Sv,",\" Compiled at %s %s\\n\"",__DATE__,__TIME__);
831 sv_catpvf(Sv,",\" Compiled on %s\\n\"",__DATE__);
836 @env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; \
837 print \" \\%ENV:\\n @env\\n\" if @env; \
838 print \" \\@INC:\\n @INC\\n\";");
841 Sv = newSVpv("config_vars(qw(",0);
846 av_push(preambleav, Sv);
847 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
858 if (!*++s || isSPACE(*s)) {
862 /* catch use of gnu style long options */
863 if (strEQ(s, "version")) {
867 if (strEQ(s, "help")) {
874 croak("Unrecognized switch: -%s (-h will show valid options)",s);
879 if (!tainting && (s = getenv("PERL5OPT"))) {
890 if (!strchr("DIMUdmw", *s))
891 croak("Illegal switch in PERL5OPT: -%c", *s);
897 scriptname = argv[0];
899 if (PerlIO_flush(e_fp) || PerlIO_error(e_fp) || PerlIO_close(e_fp)) {
901 warn("Did you forget to compile with -DMULTIPLICITY?");
903 croak("Can't write to temp file for -e: %s", Strerror(errno));
907 scriptname = e_tmpname;
909 else if (scriptname == Nullch) {
911 if ( isatty(PerlIO_fileno(PerlIO_stdin())) )
919 open_script(scriptname,dosearch,sv);
921 validate_suid(validarg, scriptname);
926 main_cv = compcv = (CV*)NEWSV(1104,0);
927 sv_upgrade((SV *)compcv, SVt_PVCV);
931 av_push(comppad, Nullsv);
932 curpad = AvARRAY(comppad);
933 comppad_name = newAV();
934 comppad_name_fill = 0;
935 min_intro_pending = 0;
938 av_store(comppad_name, 0, newSVpv("@_", 2));
939 curpad[0] = (SV*)newAV();
940 SvPADMY_on(curpad[0]); /* XXX Needed? */
942 New(666, CvMUTEXP(compcv), 1, perl_mutex);
943 MUTEX_INIT(CvMUTEXP(compcv));
944 #endif /* USE_THREADS */
946 comppadlist = newAV();
947 AvREAL_off(comppadlist);
948 av_store(comppadlist, 0, (SV*)comppad_name);
949 av_store(comppadlist, 1, (SV*)comppad);
950 CvPADLIST(compcv) = comppadlist;
952 boot_core_UNIVERSAL();
954 (*xsinit)(); /* in case linked C routines want magical variables */
955 #if defined(VMS) || defined(WIN32)
959 #if defined(DEBUGGING) && defined(USE_THREADS) && defined(__linux__)
960 DEBUG_L(signal(SIGSEGV, (void(*)(int))catch_sigsegv););
963 init_predump_symbols();
965 init_postdump_symbols(argc,argv,env);
969 /* now parse the script */
972 if (yyparse() || error_count) {
974 croak("%s had compilation errors.\n", origfilename);
976 croak("Execution of %s aborted due to compilation errors.\n",
980 curcop->cop_line = 0;
984 (void)UNLINK(e_tmpname);
989 /* now that script is parsed, we can modify record separator */
991 rs = SvREFCNT_inc(nrs);
992 sv_setsv(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), rs);
1004 if ((s=getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
1005 dump_mstats("after compilation:");
1016 PerlInterpreter *sv_interp;
1023 if (!(curinterp = sv_interp))
1026 oldscope = scopestack_ix;
1031 cxstack_ix = -1; /* start context stack again */
1034 /* my_exit() was called */
1035 while (scopestack_ix > oldscope)
1038 curstash = defstash;
1040 call_list(oldscope, endav);
1042 if (getenv("PERL_DEBUG_MSTATS"))
1043 dump_mstats("after execution: ");
1046 return STATUS_NATIVE_EXPORT;
1049 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
1054 if (curstack != mainstack) {
1056 SWITCHSTACK(curstack, mainstack);
1061 DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
1062 sawampersand ? "Enabling" : "Omitting"));
1065 DEBUG_x(dump_all());
1066 DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
1068 DEBUG_L(PerlIO_printf(Perl_debug_log, "main thread is 0x%lx\n",
1069 (unsigned long) thr));
1070 #endif /* USE_THREADS */
1073 PerlIO_printf(PerlIO_stderr(), "%s syntax OK\n", origfilename);
1076 if (PERLDB_SINGLE && DBsingle)
1077 sv_setiv(DBsingle, 1);
1079 call_list(oldscope, initav);
1089 else if (main_start) {
1090 CvDEPTH(main_cv) = 1;
1101 perl_get_sv(name, create)
1105 GV* gv = gv_fetchpv(name, create, SVt_PV);
1112 perl_get_av(name, create)
1116 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
1125 perl_get_hv(name, create)
1129 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
1138 perl_get_cv(name, create)
1142 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
1143 if (create && !GvCVu(gv))
1144 return newSUB(start_subparse(FALSE, 0),
1145 newSVOP(OP_CONST, 0, newSVpv(name,0)),
1153 /* Be sure to refetch the stack pointer after calling these routines. */
1156 perl_call_argv(subname, flags, argv)
1158 I32 flags; /* See G_* flags in cop.h */
1159 register char **argv; /* null terminated arg list */
1167 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
1172 return perl_call_pv(subname, flags);
1176 perl_call_pv(subname, flags)
1177 char *subname; /* name of the subroutine */
1178 I32 flags; /* See G_* flags in cop.h */
1180 return perl_call_sv((SV*)perl_get_cv(subname, TRUE), flags);
1184 perl_call_method(methname, flags)
1185 char *methname; /* name of the subroutine */
1186 I32 flags; /* See G_* flags in cop.h */
1193 XPUSHs(sv_2mortal(newSVpv(methname,0)));
1196 return perl_call_sv(*stack_sp--, flags);
1199 /* May be called with any of a CV, a GV, or an SV containing the name. */
1201 perl_call_sv(sv, flags)
1203 I32 flags; /* See G_* flags in cop.h */
1206 LOGOP myop; /* fake syntax tree node */
1212 bool oldcatch = CATCH_GET;
1217 if (flags & G_DISCARD) {
1222 Zero(&myop, 1, LOGOP);
1223 myop.op_next = Nullop;
1224 if (!(flags & G_NOARGS))
1225 myop.op_flags |= OPf_STACKED;
1226 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1227 (flags & G_ARRAY) ? OPf_WANT_LIST :
1232 EXTEND(stack_sp, 1);
1235 oldscope = scopestack_ix;
1237 if (PERLDB_SUB && curstash != debstash
1238 /* Handle first BEGIN of -d. */
1239 && (DBcv || (DBcv = GvCV(DBsub)))
1240 /* Try harder, since this may have been a sighandler, thus
1241 * curstash may be meaningless. */
1242 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != debstash))
1243 op->op_private |= OPpENTERSUB_DB;
1245 if (flags & G_EVAL) {
1246 cLOGOP->op_other = op;
1248 /* we're trying to emulate pp_entertry() here */
1250 register CONTEXT *cx;
1251 I32 gimme = GIMME_V;
1256 push_return(op->op_next);
1257 PUSHBLOCK(cx, CXt_EVAL, stack_sp);
1259 eval_root = op; /* Only needed so that goto works right. */
1262 if (flags & G_KEEPERR)
1265 sv_setpv(GvSV(errgv),"");
1277 /* my_exit() was called */
1278 curstash = defstash;
1282 croak("Callback called exit");
1291 stack_sp = stack_base + oldmark;
1292 if (flags & G_ARRAY)
1296 *++stack_sp = &sv_undef;
1304 if (op == (OP*)&myop)
1305 op = pp_entersub(ARGS);
1308 retval = stack_sp - (stack_base + oldmark);
1309 if ((flags & G_EVAL) && !(flags & G_KEEPERR))
1310 sv_setpv(GvSV(errgv),"");
1313 if (flags & G_EVAL) {
1314 if (scopestack_ix > oldscope) {
1318 register CONTEXT *cx;
1330 CATCH_SET(oldcatch);
1332 if (flags & G_DISCARD) {
1333 stack_sp = stack_base + oldmark;
1342 /* Eval a string. The G_EVAL flag is always assumed. */
1345 perl_eval_sv(sv, flags)
1347 I32 flags; /* See G_* flags in cop.h */
1350 UNOP myop; /* fake syntax tree node */
1352 I32 oldmark = sp - stack_base;
1359 if (flags & G_DISCARD) {
1367 EXTEND(stack_sp, 1);
1369 oldscope = scopestack_ix;
1371 if (!(flags & G_NOARGS))
1372 myop.op_flags = OPf_STACKED;
1373 myop.op_next = Nullop;
1374 myop.op_type = OP_ENTEREVAL;
1375 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1376 (flags & G_ARRAY) ? OPf_WANT_LIST :
1378 if (flags & G_KEEPERR)
1379 myop.op_flags |= OPf_SPECIAL;
1389 /* my_exit() was called */
1390 curstash = defstash;
1394 croak("Callback called exit");
1403 stack_sp = stack_base + oldmark;
1404 if (flags & G_ARRAY)
1408 *++stack_sp = &sv_undef;
1413 if (op == (OP*)&myop)
1414 op = pp_entereval(ARGS);
1417 retval = stack_sp - (stack_base + oldmark);
1418 if (!(flags & G_KEEPERR))
1419 sv_setpv(GvSV(errgv),"");
1423 if (flags & G_DISCARD) {
1424 stack_sp = stack_base + oldmark;
1434 perl_eval_pv(p, croak_on_error)
1440 SV* sv = newSVpv(p, 0);
1443 perl_eval_sv(sv, G_SCALAR);
1450 if (croak_on_error && SvTRUE(GvSV(errgv)))
1451 croak(SvPVx(GvSV(errgv), na));
1456 /* Require a module. */
1462 SV* sv = sv_newmortal();
1463 sv_setpv(sv, "require '");
1466 perl_eval_sv(sv, G_DISCARD);
1470 magicname(sym,name,namlen)
1477 if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
1478 sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
1482 usage(name) /* XXX move this out into a module ? */
1485 /* This message really ought to be max 23 lines.
1486 * Removed -h because the user already knows that opton. Others? */
1488 static char *usage[] = {
1489 "-0[octal] specify record separator (\\0, if no argument)",
1490 "-a autosplit mode with -n or -p (splits $_ into @F)",
1491 "-c check syntax only (runs BEGIN and END blocks)",
1492 "-d[:debugger] run scripts under debugger",
1493 "-D[number/list] set debugging flags (argument is a bit mask or flags)",
1494 "-e 'command' one line of script. Several -e's allowed. Omit [programfile].",
1495 "-F/pattern/ split() pattern for autosplit (-a). The //'s are optional.",
1496 "-i[extension] edit <> files in place (make backup if extension supplied)",
1497 "-Idirectory specify @INC/#include directory (may be used more than once)",
1498 "-l[octal] enable line ending processing, specifies line terminator",
1499 "-[mM][-]module.. executes `use/no module...' before executing your script.",
1500 "-n assume 'while (<>) { ... }' loop around your script",
1501 "-p assume loop like -n but print line also like sed",
1502 "-P run script through C preprocessor before compilation",
1503 "-s enable some switch parsing for switches after script name",
1504 "-S look for the script using PATH environment variable",
1505 "-T turn on tainting checks",
1506 "-u dump core after parsing script",
1507 "-U allow unsafe operations",
1508 "-v print version number and patchlevel of perl",
1509 "-V[:variable] print perl configuration information",
1510 "-w TURN WARNINGS ON FOR COMPILATION OF YOUR SCRIPT. Recommended.",
1511 "-x[directory] strip off text before #!perl line and perhaps cd to directory",
1517 printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
1519 printf("\n %s", *p++);
1522 /* This routine handles any switches that can be given during run */
1533 rschar = scan_oct(s, 4, &numlen);
1535 if (rschar & ~((U8)~0))
1537 else if (!rschar && numlen >= 2)
1538 nrs = newSVpv("", 0);
1541 nrs = newSVpv(&ch, 1);
1546 splitstr = savepv(s + 1);
1560 if (*s == ':' || *s == '=') {
1561 my_setenv("PERL5DB", form("use Devel::%s;", ++s));
1565 perldb = PERLDB_ALL;
1572 if (isALPHA(s[1])) {
1573 static char debopts[] = "psltocPmfrxuLHXD";
1576 for (s++; *s && (d = strchr(debopts,*s)); s++)
1577 debug |= 1 << (d - debopts);
1581 for (s++; isDIGIT(*s); s++) ;
1583 debug |= 0x80000000;
1585 warn("Recompile perl with -DDEBUGGING to use -D switch\n");
1586 for (s++; isALNUM(*s); s++) ;
1596 inplace = savepv(s+1);
1598 for (s = inplace; *s && !isSPACE(*s); s++) ;
1602 case 'I': /* -I handled both here and in parse_perl() */
1605 while (*s && isSPACE(*s))
1609 for (e = s; *e && !isSPACE(*e); e++) ;
1610 p = savepvn(s, e-s);
1616 croak("No space allowed after -I");
1626 *ors = scan_oct(s, 3 + (*s == '0'), &numlen);
1635 ors = SvPV(nrs, orslen);
1636 ors = savepvn(ors, orslen);
1640 forbid_setid("-M"); /* XXX ? */
1643 forbid_setid("-m"); /* XXX ? */
1648 /* -M-foo == 'no foo' */
1649 if (*s == '-') { use = "no "; ++s; }
1650 sv = newSVpv(use,0);
1652 /* We allow -M'Module qw(Foo Bar)' */
1653 while(isALNUM(*s) || *s==':') ++s;
1655 sv_catpv(sv, start);
1656 if (*(start-1) == 'm') {
1658 croak("Can't use '%c' after -mname", *s);
1659 sv_catpv( sv, " ()");
1662 sv_catpvn(sv, start, s-start);
1663 sv_catpv(sv, " split(/,/,q{");
1668 if (preambleav == NULL)
1669 preambleav = newAV();
1670 av_push(preambleav, sv);
1673 croak("No space allowed after -%c", *(s-1));
1690 croak("Too late for \"-T\" option");
1702 #if defined(SUBVERSION) && SUBVERSION > 0
1703 printf("\nThis is perl, version 5.%03d_%02d built for %s",
1704 PATCHLEVEL, SUBVERSION, ARCHNAME);
1706 printf("\nThis is perl, version %s built for %s",
1707 patchlevel, ARCHNAME);
1709 #if defined(LOCAL_PATCH_COUNT)
1710 if (LOCAL_PATCH_COUNT > 0)
1711 printf("\n(with %d registered patch%s, see perl -V for more detail)",
1712 LOCAL_PATCH_COUNT, (LOCAL_PATCH_COUNT!=1) ? "es" : "");
1715 printf("\n\nCopyright 1987-1997, Larry Wall\n");
1717 printf("\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
1720 printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n");
1723 printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
1724 "Version 5 port Copyright (c) 1994-1997, Andreas Kaiser, Ilya Zakharevich\n");
1727 printf("atariST series port, ++jrb bammi@cadence.com\n");
1730 Perl may be copied only under the terms of either the Artistic License or the\n\
1731 GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n");
1739 if (s[1] == '-') /* Additional switches on #! line. */
1747 #ifdef ALTERNATE_SHEBANG
1748 case 'S': /* OS/2 needs -S on "extproc" line. */
1756 croak("Can't emulate -%.1s on #! line",s);
1761 /* compliments of Tom Christiansen */
1763 /* unexec() can be found in the Gnu emacs distribution */
1774 prog = newSVpv(BIN_EXP);
1775 sv_catpv(prog, "/perl");
1776 file = newSVpv(origfilename);
1777 sv_catpv(file, ".perldump");
1779 status = unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
1781 PerlIO_printf(PerlIO_stderr(), "unexec of %s into %s failed!\n",
1782 SvPVX(prog), SvPVX(file));
1786 # include <lib$routines.h>
1787 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
1789 ABORT(); /* for use with undump */
1800 /* Note that strtab is a rather special HV. Assumptions are made
1801 about not iterating on it, and not adding tie magic to it.
1802 It is properly deallocated in perl_destruct() */
1804 HvSHAREKEYS_off(strtab); /* mandatory */
1805 Newz(506,((XPVHV*)SvANY(strtab))->xhv_array,
1806 sizeof(HE*) * (((XPVHV*)SvANY(strtab))->xhv_max + 1), char);
1808 curstash = defstash = newHV();
1809 curstname = newSVpv("main",4);
1810 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
1811 SvREFCNT_dec(GvHV(gv));
1812 GvHV(gv) = (HV*)SvREFCNT_inc(defstash);
1814 HvNAME(defstash) = savepv("main");
1815 incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
1817 defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
1818 errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
1820 (void)form("%240s",""); /* Preallocate temp - for immediate signals. */
1821 sv_grow(GvSV(errgv), 240); /* Preallocate - for immediate signals. */
1822 sv_setpvn(GvSV(errgv), "", 0);
1823 curstash = defstash;
1824 compiling.cop_stash = defstash;
1825 debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
1826 /* We must init $/ before switches are processed. */
1827 sv_setpvn(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), "\n", 1);
1830 #ifdef CAN_PROTOTYPE
1832 open_script(char *scriptname, bool dosearch, SV *sv)
1835 open_script(scriptname,dosearch,sv)
1842 char *xfound = Nullch;
1843 char *xfailed = Nullch;
1847 #if defined(DOSISH) && !defined(OS2) && !defined(atarist)
1848 # define SEARCH_EXTS ".bat", ".cmd", NULL
1849 # define MAX_EXT_LEN 4
1852 # define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL
1853 # define MAX_EXT_LEN 4
1856 # define SEARCH_EXTS ".pl", ".com", NULL
1857 # define MAX_EXT_LEN 4
1859 /* additional extensions to try in each dir if scriptname not found */
1861 char *ext[] = { SEARCH_EXTS };
1862 int extidx = 0, i = 0;
1863 char *curext = Nullch;
1865 # define MAX_EXT_LEN 0
1869 * If dosearch is true and if scriptname does not contain path
1870 * delimiters, search the PATH for scriptname.
1872 * If SEARCH_EXTS is also defined, will look for each
1873 * scriptname{SEARCH_EXTS} whenever scriptname is not found
1874 * while searching the PATH.
1876 * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
1877 * proceeds as follows:
1879 * + look for ./scriptname{,.foo,.bar}
1880 * + search the PATH for scriptname{,.foo,.bar}
1883 * + look *only* in the PATH for scriptname{,.foo,.bar} (note
1884 * this will not look in '.' if it's not in the PATH)
1889 int hasdir, idx = 0, deftypes = 1;
1892 hasdir = (strpbrk(scriptname,":[</") != Nullch) ;
1893 /* The first time through, just add SEARCH_EXTS to whatever we
1894 * already have, so we can check for default file types. */
1896 (!hasdir && my_trnlnm("DCL$PATH",tokenbuf,idx++)) )
1902 if ((strlen(tokenbuf) + strlen(scriptname)
1903 + MAX_EXT_LEN) >= sizeof tokenbuf)
1904 continue; /* don't search dir with too-long name */
1905 strcat(tokenbuf, scriptname);
1909 if (strEQ(scriptname, "-"))
1911 if (dosearch) { /* Look in '.' first. */
1912 char *cur = scriptname;
1914 if ((curext = strrchr(scriptname,'.'))) /* possible current ext */
1916 if (strEQ(ext[i++],curext)) {
1917 extidx = -1; /* already has an ext */
1922 DEBUG_p(PerlIO_printf(Perl_debug_log,
1923 "Looking for %s\n",cur));
1924 if (Stat(cur,&statbuf) >= 0) {
1932 if (cur == scriptname) {
1933 len = strlen(scriptname);
1934 if (len+MAX_EXT_LEN+1 >= sizeof(tokenbuf))
1936 cur = strcpy(tokenbuf, scriptname);
1938 } while (extidx >= 0 && ext[extidx] /* try an extension? */
1939 && strcpy(tokenbuf+len, ext[extidx++]));
1944 if (dosearch && !strchr(scriptname, '/')
1946 && !strchr(scriptname, '\\')
1948 && (s = getenv("PATH"))) {
1951 bufend = s + strlen(s);
1952 while (s < bufend) {
1953 #if defined(atarist) || defined(DOSISH)
1958 && *s != ';'; len++, s++) {
1959 if (len < sizeof tokenbuf)
1962 if (len < sizeof tokenbuf)
1963 tokenbuf[len] = '\0';
1964 #else /* ! (atarist || DOSISH) */
1965 s = delimcpy(tokenbuf, tokenbuf + sizeof tokenbuf, s, bufend,
1968 #endif /* ! (atarist || DOSISH) */
1971 if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tokenbuf)
1972 continue; /* don't search dir with too-long name */
1974 #if defined(atarist) || defined(DOSISH)
1975 && tokenbuf[len - 1] != '/'
1976 && tokenbuf[len - 1] != '\\'
1979 tokenbuf[len++] = '/';
1980 if (len == 2 && tokenbuf[0] == '.')
1982 (void)strcpy(tokenbuf + len, scriptname);
1986 len = strlen(tokenbuf);
1987 if (extidx > 0) /* reset after previous loop */
1991 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tokenbuf));
1992 retval = Stat(tokenbuf,&statbuf);
1994 } while ( retval < 0 /* not there */
1995 && extidx>=0 && ext[extidx] /* try an extension? */
1996 && strcpy(tokenbuf+len, ext[extidx++])
2001 if (S_ISREG(statbuf.st_mode)
2002 && cando(S_IRUSR,TRUE,&statbuf)
2004 && cando(S_IXUSR,TRUE,&statbuf)
2008 xfound = tokenbuf; /* bingo! */
2012 xfailed = savepv(tokenbuf);
2015 if (!xfound && !seen_dot && !xfailed && (Stat(scriptname,&statbuf) < 0))
2017 seen_dot = 1; /* Disable message. */
2019 croak("Can't %s %s%s%s",
2020 (xfailed ? "execute" : "find"),
2021 (xfailed ? xfailed : scriptname),
2022 (xfailed ? "" : " on PATH"),
2023 (xfailed || seen_dot) ? "" : ", '.' not in PATH");
2026 scriptname = xfound;
2029 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
2030 char *s = scriptname + 8;
2039 origfilename = savepv(e_tmpname ? "-e" : scriptname);
2040 curcop->cop_filegv = gv_fetchfile(origfilename);
2041 if (strEQ(origfilename,"-"))
2043 if (fdscript >= 0) {
2044 rsfp = PerlIO_fdopen(fdscript,"r");
2045 #if defined(HAS_FCNTL) && defined(F_SETFD)
2047 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
2050 else if (preprocess) {
2051 char *cpp_cfg = CPPSTDIN;
2052 SV *cpp = NEWSV(0,0);
2053 SV *cmd = NEWSV(0,0);
2055 if (strEQ(cpp_cfg, "cppstdin"))
2056 sv_catpvf(cpp, "%s/", BIN_EXP);
2057 sv_catpv(cpp, cpp_cfg);
2060 sv_catpv(sv,PRIVLIB_EXP);
2064 sed %s -e \"/^[^#]/b\" \
2065 -e \"/^#[ ]*include[ ]/b\" \
2066 -e \"/^#[ ]*define[ ]/b\" \
2067 -e \"/^#[ ]*if[ ]/b\" \
2068 -e \"/^#[ ]*ifdef[ ]/b\" \
2069 -e \"/^#[ ]*ifndef[ ]/b\" \
2070 -e \"/^#[ ]*else/b\" \
2071 -e \"/^#[ ]*elif[ ]/b\" \
2072 -e \"/^#[ ]*undef[ ]/b\" \
2073 -e \"/^#[ ]*endif/b\" \
2076 (doextract ? "-e \"1,/^#/d\n\"" : ""),
2079 %s %s -e '/^[^#]/b' \
2080 -e '/^#[ ]*include[ ]/b' \
2081 -e '/^#[ ]*define[ ]/b' \
2082 -e '/^#[ ]*if[ ]/b' \
2083 -e '/^#[ ]*ifdef[ ]/b' \
2084 -e '/^#[ ]*ifndef[ ]/b' \
2085 -e '/^#[ ]*else/b' \
2086 -e '/^#[ ]*elif[ ]/b' \
2087 -e '/^#[ ]*undef[ ]/b' \
2088 -e '/^#[ ]*endif/b' \
2096 (doextract ? "-e '1,/^#/d\n'" : ""),
2098 scriptname, cpp, sv, CPPMINUS);
2100 #ifdef IAMSUID /* actually, this is caught earlier */
2101 if (euid != uid && !euid) { /* if running suidperl */
2103 (void)seteuid(uid); /* musn't stay setuid root */
2106 (void)setreuid((Uid_t)-1, uid);
2108 #ifdef HAS_SETRESUID
2109 (void)setresuid((Uid_t)-1, uid, (Uid_t)-1);
2115 if (geteuid() != uid)
2116 croak("Can't do seteuid!\n");
2118 #endif /* IAMSUID */
2119 rsfp = my_popen(SvPVX(cmd), "r");
2123 else if (!*scriptname) {
2124 forbid_setid("program input from stdin");
2125 rsfp = PerlIO_stdin();
2128 rsfp = PerlIO_open(scriptname,"r");
2129 #if defined(HAS_FCNTL) && defined(F_SETFD)
2131 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
2139 #ifndef IAMSUID /* in case script is not readable before setuid */
2140 if (euid && Stat(SvPVX(GvSV(curcop->cop_filegv)),&statbuf) >= 0 &&
2141 statbuf.st_mode & (S_ISUID|S_ISGID)) {
2143 execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
2144 croak("Can't do setuid\n");
2148 croak("Can't open perl script \"%s\": %s\n",
2149 SvPVX(GvSV(curcop->cop_filegv)), Strerror(errno));
2154 validate_suid(validarg, scriptname)
2160 /* do we need to emulate setuid on scripts? */
2162 /* This code is for those BSD systems that have setuid #! scripts disabled
2163 * in the kernel because of a security problem. Merely defining DOSUID
2164 * in perl will not fix that problem, but if you have disabled setuid
2165 * scripts in the kernel, this will attempt to emulate setuid and setgid
2166 * on scripts that have those now-otherwise-useless bits set. The setuid
2167 * root version must be called suidperl or sperlN.NNN. If regular perl
2168 * discovers that it has opened a setuid script, it calls suidperl with
2169 * the same argv that it had. If suidperl finds that the script it has
2170 * just opened is NOT setuid root, it sets the effective uid back to the
2171 * uid. We don't just make perl setuid root because that loses the
2172 * effective uid we had before invoking perl, if it was different from the
2175 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
2176 * be defined in suidperl only. suidperl must be setuid root. The
2177 * Configure script will set this up for you if you want it.
2183 if (Fstat(PerlIO_fileno(rsfp),&statbuf) < 0) /* normal stat is insecure */
2184 croak("Can't stat script \"%s\"",origfilename);
2185 if (fdscript < 0 && statbuf.st_mode & (S_ISUID|S_ISGID)) {
2189 #ifndef HAS_SETREUID
2190 /* On this access check to make sure the directories are readable,
2191 * there is actually a small window that the user could use to make
2192 * filename point to an accessible directory. So there is a faint
2193 * chance that someone could execute a setuid script down in a
2194 * non-accessible directory. I don't know what to do about that.
2195 * But I don't think it's too important. The manual lies when
2196 * it says access() is useful in setuid programs.
2198 if (access(SvPVX(GvSV(curcop->cop_filegv)),1)) /*double check*/
2199 croak("Permission denied");
2201 /* If we can swap euid and uid, then we can determine access rights
2202 * with a simple stat of the file, and then compare device and
2203 * inode to make sure we did stat() on the same file we opened.
2204 * Then we just have to make sure he or she can execute it.
2207 struct stat tmpstatbuf;
2211 setreuid(euid,uid) < 0
2214 setresuid(euid,uid,(Uid_t)-1) < 0
2217 || getuid() != euid || geteuid() != uid)
2218 croak("Can't swap uid and euid"); /* really paranoid */
2219 if (Stat(SvPVX(GvSV(curcop->cop_filegv)),&tmpstatbuf) < 0)
2220 croak("Permission denied"); /* testing full pathname here */
2221 if (tmpstatbuf.st_dev != statbuf.st_dev ||
2222 tmpstatbuf.st_ino != statbuf.st_ino) {
2223 (void)PerlIO_close(rsfp);
2224 if (rsfp = my_popen("/bin/mail root","w")) { /* heh, heh */
2226 "User %ld tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
2227 (Filename of set-id script was %s, uid %ld gid %ld.)\n\nSincerely,\nperl\n",
2228 (long)uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
2229 (long)statbuf.st_dev, (long)statbuf.st_ino,
2230 SvPVX(GvSV(curcop->cop_filegv)),
2231 (long)statbuf.st_uid, (long)statbuf.st_gid);
2232 (void)my_pclose(rsfp);
2234 croak("Permission denied\n");
2238 setreuid(uid,euid) < 0
2240 # if defined(HAS_SETRESUID)
2241 setresuid(uid,euid,(Uid_t)-1) < 0
2244 || getuid() != uid || geteuid() != euid)
2245 croak("Can't reswap uid and euid");
2246 if (!cando(S_IXUSR,FALSE,&statbuf)) /* can real uid exec? */
2247 croak("Permission denied\n");
2249 #endif /* HAS_SETREUID */
2250 #endif /* IAMSUID */
2252 if (!S_ISREG(statbuf.st_mode))
2253 croak("Permission denied");
2254 if (statbuf.st_mode & S_IWOTH)
2255 croak("Setuid/gid script is writable by world");
2256 doswitches = FALSE; /* -s is insecure in suid */
2258 if (sv_gets(linestr, rsfp, 0) == Nullch ||
2259 strnNE(SvPV(linestr,na),"#!",2) ) /* required even on Sys V */
2260 croak("No #! line");
2261 s = SvPV(linestr,na)+2;
2263 while (!isSPACE(*s)) s++;
2264 for (s2 = s; (s2 > SvPV(linestr,na)+2 &&
2265 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
2266 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
2267 croak("Not a perl script");
2268 while (*s == ' ' || *s == '\t') s++;
2270 * #! arg must be what we saw above. They can invoke it by
2271 * mentioning suidperl explicitly, but they may not add any strange
2272 * arguments beyond what #! says if they do invoke suidperl that way.
2274 len = strlen(validarg);
2275 if (strEQ(validarg," PHOOEY ") ||
2276 strnNE(s,validarg,len) || !isSPACE(s[len]))
2277 croak("Args must match #! line");
2280 if (euid != uid && (statbuf.st_mode & S_ISUID) &&
2281 euid == statbuf.st_uid)
2283 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2284 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2285 #endif /* IAMSUID */
2287 if (euid) { /* oops, we're not the setuid root perl */
2288 (void)PerlIO_close(rsfp);
2291 execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
2293 croak("Can't do setuid\n");
2296 if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid) {
2298 (void)setegid(statbuf.st_gid);
2301 (void)setregid((Gid_t)-1,statbuf.st_gid);
2303 #ifdef HAS_SETRESGID
2304 (void)setresgid((Gid_t)-1,statbuf.st_gid,(Gid_t)-1);
2306 setgid(statbuf.st_gid);
2310 if (getegid() != statbuf.st_gid)
2311 croak("Can't do setegid!\n");
2313 if (statbuf.st_mode & S_ISUID) {
2314 if (statbuf.st_uid != euid)
2316 (void)seteuid(statbuf.st_uid); /* all that for this */
2319 (void)setreuid((Uid_t)-1,statbuf.st_uid);
2321 #ifdef HAS_SETRESUID
2322 (void)setresuid((Uid_t)-1,statbuf.st_uid,(Uid_t)-1);
2324 setuid(statbuf.st_uid);
2328 if (geteuid() != statbuf.st_uid)
2329 croak("Can't do seteuid!\n");
2331 else if (uid) { /* oops, mustn't run as root */
2333 (void)seteuid((Uid_t)uid);
2336 (void)setreuid((Uid_t)-1,(Uid_t)uid);
2338 #ifdef HAS_SETRESUID
2339 (void)setresuid((Uid_t)-1,(Uid_t)uid,(Uid_t)-1);
2345 if (geteuid() != uid)
2346 croak("Can't do seteuid!\n");
2349 if (!cando(S_IXUSR,TRUE,&statbuf))
2350 croak("Permission denied\n"); /* they can't do this */
2353 else if (preprocess)
2354 croak("-P not allowed for setuid/setgid script\n");
2355 else if (fdscript >= 0)
2356 croak("fd script not allowed in suidperl\n");
2358 croak("Script is not setuid/setgid in suidperl\n");
2360 /* We absolutely must clear out any saved ids here, so we */
2361 /* exec the real perl, substituting fd script for scriptname. */
2362 /* (We pass script name as "subdir" of fd, which perl will grok.) */
2363 PerlIO_rewind(rsfp);
2364 lseek(PerlIO_fileno(rsfp),(Off_t)0,0); /* just in case rewind didn't */
2365 for (which = 1; origargv[which] && origargv[which] != scriptname; which++) ;
2366 if (!origargv[which])
2367 croak("Permission denied");
2368 origargv[which] = savepv(form("/dev/fd/%d/%s",
2369 PerlIO_fileno(rsfp), origargv[which]));
2370 #if defined(HAS_FCNTL) && defined(F_SETFD)
2371 fcntl(PerlIO_fileno(rsfp),F_SETFD,0); /* ensure no close-on-exec */
2373 execv(form("%s/perl%s", BIN_EXP, patchlevel), origargv); /* try again */
2374 croak("Can't do setuid\n");
2375 #endif /* IAMSUID */
2377 if (euid != uid || egid != gid) { /* (suidperl doesn't exist, in fact) */
2378 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
2380 Fstat(PerlIO_fileno(rsfp),&statbuf); /* may be either wrapped or real suid */
2381 if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
2383 (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
2386 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2387 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2388 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
2389 /* not set-id, must be wrapped */
2397 register char *s, *s2;
2399 /* skip forward in input to the real script? */
2403 if ((s = sv_gets(linestr, rsfp, 0)) == Nullch)
2404 croak("No Perl script found in input\n");
2405 if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
2406 PerlIO_ungetc(rsfp, '\n'); /* to keep line count right */
2408 while (*s && !(isSPACE (*s) || *s == '#')) s++;
2410 while (*s == ' ' || *s == '\t') s++;
2412 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
2413 if (strnEQ(s2-4,"perl",4))
2415 while (s = moreswitches(s)) ;
2417 if (cddir && chdir(cddir) < 0)
2418 croak("Can't chdir to %s",cddir);
2426 uid = (int)getuid();
2427 euid = (int)geteuid();
2428 gid = (int)getgid();
2429 egid = (int)getegid();
2434 tainting |= (uid && (euid != uid || egid != gid));
2442 croak("No %s allowed while running setuid", s);
2444 croak("No %s allowed while running setgid", s);
2451 curstash = debstash;
2452 dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
2454 DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
2455 DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
2456 DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
2457 DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
2458 sv_setiv(DBsingle, 0);
2459 DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
2460 sv_setiv(DBtrace, 0);
2461 DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
2462 sv_setiv(DBsignal, 0);
2463 curstash = defstash;
2471 mainstack = curstack; /* remember in case we switch stacks */
2472 AvREAL_off(curstack); /* not a real array */
2473 av_extend(curstack,127);
2475 stack_base = AvARRAY(curstack);
2476 stack_sp = stack_base;
2477 stack_max = stack_base + 127;
2479 cxstack_max = 8192 / sizeof(CONTEXT) - 2; /* Use most of 8K. */
2480 New(50,cxstack,cxstack_max + 1,CONTEXT);
2483 New(50,tmps_stack,128,SV*);
2489 * The following stacks almost certainly should be per-interpreter,
2490 * but for now they're not. XXX
2494 markstack_ptr = markstack;
2496 New(54,markstack,64,I32);
2497 markstack_ptr = markstack;
2498 markstack_max = markstack + 64;
2504 New(54,scopestack,32,I32);
2506 scopestack_max = 32;
2512 New(54,savestack,128,ANY);
2514 savestack_max = 128;
2520 New(54,retstack,16,OP*);
2531 Safefree(tmps_stack);
2538 static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
2547 subname = newSVpv("main",4);
2551 init_predump_symbols()
2557 sv_setpvn(GvSV(gv_fetchpv("\"", TRUE, SVt_PV)), " ", 1);
2559 stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
2560 GvMULTI_on(stdingv);
2561 IoIFP(GvIOp(stdingv)) = PerlIO_stdin();
2562 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
2564 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(stdingv));
2566 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
2568 IoOFP(GvIOp(tmpgv)) = IoIFP(GvIOp(tmpgv)) = PerlIO_stdout();
2570 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
2572 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(defoutgv));
2574 othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
2575 GvMULTI_on(othergv);
2576 IoOFP(GvIOp(othergv)) = IoIFP(GvIOp(othergv)) = PerlIO_stderr();
2577 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
2579 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(othergv));
2581 statname = NEWSV(66,0); /* last filename we did stat on */
2584 osname = savepv(OSNAME);
2588 init_postdump_symbols(argc,argv,env)
2590 register char **argv;
2591 register char **env;
2597 argc--,argv++; /* skip name of script */
2599 for (; argc > 0 && **argv == '-'; argc--,argv++) {
2602 if (argv[0][1] == '-') {
2606 if (s = strchr(argv[0], '=')) {
2608 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
2611 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
2614 toptarget = NEWSV(0,0);
2615 sv_upgrade(toptarget, SVt_PVFM);
2616 sv_setpvn(toptarget, "", 0);
2617 bodytarget = NEWSV(0,0);
2618 sv_upgrade(bodytarget, SVt_PVFM);
2619 sv_setpvn(bodytarget, "", 0);
2620 formtarget = bodytarget;
2623 if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
2624 sv_setpv(GvSV(tmpgv),origfilename);
2625 magicname("0", "0", 1);
2627 if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
2628 sv_setpv(GvSV(tmpgv),origargv[0]);
2629 if (argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
2631 (void)gv_AVadd(argvgv);
2632 av_clear(GvAVn(argvgv));
2633 for (; argc > 0; argc--,argv++) {
2634 av_push(GvAVn(argvgv),newSVpv(argv[0],0));
2637 if (envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
2641 hv_magic(hv, envgv, 'E');
2642 #ifndef VMS /* VMS doesn't have environ array */
2643 /* Note that if the supplied env parameter is actually a copy
2644 of the global environ then it may now point to free'd memory
2645 if the environment has been modified since. To avoid this
2646 problem we treat env==NULL as meaning 'use the default'
2651 environ[0] = Nullch;
2652 for (; *env; env++) {
2653 if (!(s = strchr(*env,'=')))
2659 sv = newSVpv(s--,0);
2660 (void)hv_store(hv, *env, s - *env, sv, 0);
2662 #if defined(__BORLANDC__) && defined(USE_WIN32_RTL_ENV)
2663 /* Sins of the RTL. See note in my_setenv(). */
2664 (void)putenv(savepv(*env));
2668 #ifdef DYNAMIC_ENV_FETCH
2669 HvNAME(hv) = savepv(ENV_HV_NAME);
2673 if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
2674 sv_setiv(GvSV(tmpgv), (IV)getpid());
2683 s = getenv("PERL5LIB");
2687 incpush(getenv("PERLLIB"), FALSE);
2689 /* Treat PERL5?LIB as a possible search list logical name -- the
2690 * "natural" VMS idiom for a Unix path string. We allow each
2691 * element to be a set of |-separated directories for compatibility.
2695 if (my_trnlnm("PERL5LIB",buf,0))
2696 do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
2698 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE);
2702 /* Use the ~-expanded versions of APPLLIB (undocumented),
2703 ARCHLIB PRIVLIB SITEARCH SITELIB and OLDARCHLIB
2706 incpush(APPLLIB_EXP, FALSE);
2710 incpush(ARCHLIB_EXP, FALSE);
2713 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
2715 incpush(PRIVLIB_EXP, FALSE);
2718 incpush(SITEARCH_EXP, FALSE);
2721 incpush(SITELIB_EXP, FALSE);
2723 #ifdef OLDARCHLIB_EXP /* 5.00[01] compatibility */
2724 incpush(OLDARCHLIB_EXP, FALSE);
2728 incpush(".", FALSE);
2732 # define PERLLIB_SEP ';'
2735 # define PERLLIB_SEP '|'
2737 # define PERLLIB_SEP ':'
2740 #ifndef PERLLIB_MANGLE
2741 # define PERLLIB_MANGLE(s,n) (s)
2745 incpush(p, addsubdirs)
2749 SV *subdir = Nullsv;
2750 static char *archpat_auto;
2757 if (!archpat_auto) {
2758 STRLEN len = (sizeof(ARCHNAME) + strlen(patchlevel)
2759 + sizeof("//auto"));
2760 New(55, archpat_auto, len, char);
2761 sprintf(archpat_auto, "/%s/%s/auto", ARCHNAME, patchlevel);
2763 for (len = sizeof(ARCHNAME) + 2;
2764 archpat_auto[len] != '\0' && archpat_auto[len] != '/'; len++)
2765 if (archpat_auto[len] == '.') archpat_auto[len] = '_';
2770 /* Break at all separators */
2772 SV *libdir = newSV(0);
2775 /* skip any consecutive separators */
2776 while ( *p == PERLLIB_SEP ) {
2777 /* Uncomment the next line for PATH semantics */
2778 /* av_push(GvAVn(incgv), newSVpv(".", 1)); */
2782 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
2783 sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
2788 sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
2789 p = Nullch; /* break out */
2793 * BEFORE pushing libdir onto @INC we may first push version- and
2794 * archname-specific sub-directories.
2797 struct stat tmpstatbuf;
2802 if ((unix = tounixspec_ts(SvPV(libdir,na),Nullch)) != Nullch) {
2804 while (unix[len-1] == '/') len--; /* Cosmetic */
2805 sv_usepvn(libdir,unix,len);
2808 PerlIO_printf(PerlIO_stderr(),
2809 "Failed to unixify @INC element \"%s\"\n",
2812 /* .../archname/version if -d .../archname/version/auto */
2813 sv_setsv(subdir, libdir);
2814 sv_catpv(subdir, archpat_auto);
2815 if (Stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2816 S_ISDIR(tmpstatbuf.st_mode))
2817 av_push(GvAVn(incgv),
2818 newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2820 /* .../archname if -d .../archname/auto */
2821 sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME),
2822 strlen(patchlevel) + 1, "", 0);
2823 if (Stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2824 S_ISDIR(tmpstatbuf.st_mode))
2825 av_push(GvAVn(incgv),
2826 newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2829 /* finally push this lib directory on the end of @INC */
2830 av_push(GvAVn(incgv), libdir);
2833 SvREFCNT_dec(subdir);
2837 call_list(oldscope, list)
2842 line_t oldline = curcop->cop_line;
2847 while (AvFILL(list) >= 0) {
2848 CV *cv = (CV*)av_shift(list);
2855 SV* atsv = GvSV(errgv);
2857 perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
2858 (void)SvPV(atsv, len);
2861 curcop = &compiling;
2862 curcop->cop_line = oldline;
2863 if (list == beginav)
2864 sv_catpv(atsv, "BEGIN failed--compilation aborted");
2866 sv_catpv(atsv, "END failed--cleanup aborted");
2867 while (scopestack_ix > oldscope)
2869 croak("%s", SvPVX(atsv));
2877 /* my_exit() was called */
2878 while (scopestack_ix > oldscope)
2881 curstash = defstash;
2883 call_list(oldscope, endav);
2885 curcop = &compiling;
2886 curcop->cop_line = oldline;
2888 if (list == beginav)
2889 croak("BEGIN failed--compilation aborted");
2891 croak("END failed--cleanup aborted");
2897 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
2902 curcop = &compiling;
2903 curcop->cop_line = oldline;
2917 DEBUG_L(PerlIO_printf(Perl_debug_log, "my_exit: thread 0x%lx, status %lu\n",
2918 (unsigned long) thr, (unsigned long) status));
2919 #endif /* USE_THREADS */
2928 STATUS_NATIVE_SET(status);
2938 if (vaxc$errno & 1) {
2939 if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
2940 STATUS_NATIVE_SET(44);
2943 if (!vaxc$errno && errno) /* unlikely */
2944 STATUS_NATIVE_SET(44);
2946 STATUS_NATIVE_SET(vaxc$errno);
2950 STATUS_POSIX_SET(errno);
2951 else if (STATUS_POSIX == 0)
2952 STATUS_POSIX_SET(255);
2961 register CONTEXT *cx;
2970 (void)UNLINK(e_tmpname);
2971 Safefree(e_tmpname);
2975 if (cxstack_ix >= 0) {