3 * Copyright (c) 1987-1997 Larry Wall
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
11 * "A ship then new they built for him/of mithril and of elven glass" --Bilbo
16 #include "patchlevel.h"
18 /* XXX If this causes problems, set i_unistd=undef in the hint file. */
23 #if !defined(STANDARD_C) && !defined(HAS_GETENV_PROTOTYPE)
24 char *getenv _((char *)); /* Usually in <stdlib.h> */
27 dEXTCONST char rcsid[] = "perl.c\nPatch level: ###\n";
35 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
45 curcop = &compiling; \
52 laststype = OP_STAT; \
54 maxsysfd = MAXSYSFD; \
61 laststype = OP_STAT; \
65 static void find_beginning _((void));
66 static void forbid_setid _((char *));
67 static void incpush _((char *, int));
68 static void init_ids _((void));
69 static void init_debugger _((void));
70 static void init_lexer _((void));
71 static void init_main_stash _((void));
72 static void init_perllib _((void));
73 static void init_postdump_symbols _((int, char **, char **));
74 static void init_predump_symbols _((void));
75 static void my_exit_jump _((void)) __attribute__((noreturn));
76 static void nuke_stacks _((void));
77 static void open_script _((char *, bool, SV *));
78 static void usage _((char *));
79 static void validate_suid _((char *, char*));
81 static int fdscript = -1;
83 #if defined(DEBUGGING) && defined(USE_THREADS) && defined(__linux__)
84 #include <asm/sigcontext.h>
86 catch_sigsegv(int signo, struct sigcontext_struct sc)
88 signal(SIGSEGV, SIG_DFL);
89 fprintf(stderr, "Segmentation fault dereferencing 0x%lx\n"
90 "return_address = 0x%lx, eip = 0x%lx\n",
91 sc.cr2, __builtin_return_address(0), sc.eip);
92 fprintf(stderr, "thread = 0x%lx\n", (unsigned long)THR);
99 PerlInterpreter *sv_interp;
102 New(53, sv_interp, 1, PerlInterpreter);
107 perl_construct( sv_interp )
108 register PerlInterpreter *sv_interp;
110 #if defined(USE_THREADS) && !defined(FAKE_THREADS)
114 if (!(curinterp = sv_interp))
118 Zero(sv_interp, 1, PerlInterpreter);
121 /* Init the real globals (and main thread)? */
125 New(53, thr, 1, struct thread);
126 MUTEX_INIT(&malloc_mutex);
127 MUTEX_INIT(&sv_mutex);
128 MUTEX_INIT(&eval_mutex);
129 COND_INIT(&eval_cond);
130 MUTEX_INIT(&threads_mutex);
131 COND_INIT(&nthreads_cond);
135 thr->flags = THRf_R_JOINABLE;
136 MUTEX_INIT(&thr->mutex);
140 #ifdef HAVE_THREAD_INTERN
141 init_thread_intern(thr);
143 self = pthread_self();
144 if (pthread_key_create(&thr_key, 0))
145 croak("panic: pthread_key_create");
146 if (pthread_setspecific(thr_key, (void *) thr))
147 croak("panic: pthread_setspecific");
148 #endif /* FAKE_THREADS */
149 #endif /* USE_THREADS */
151 linestr = NEWSV(65,80);
152 sv_upgrade(linestr,SVt_PVIV);
154 if (!SvREADONLY(&sv_undef)) {
155 SvREADONLY_on(&sv_undef);
159 SvREADONLY_on(&sv_no);
161 sv_setpv(&sv_yes,Yes);
163 SvREADONLY_on(&sv_yes);
166 nrs = newSVpv("\n", 1);
167 rs = SvREFCNT_inc(nrs);
169 sighandlerp = sighandler;
174 * There is no way we can refer to them from Perl so close them to save
175 * space. The other alternative would be to provide STDAUX and STDPRN
178 (void)fclose(stdaux);
179 (void)fclose(stdprn);
185 perl_destruct_level = 1;
187 if(perl_destruct_level > 0)
193 start_env.je_prev = NULL;
194 start_env.je_ret = -1;
195 start_env.je_mustcatch = TRUE;
196 top_env = &start_env;
199 SET_NUMERIC_STANDARD();
200 #if defined(SUBVERSION) && SUBVERSION > 0
201 sprintf(patchlevel, "%7.5f", (double) 5
202 + ((double) PATCHLEVEL / (double) 1000)
203 + ((double) SUBVERSION / (double) 100000));
205 sprintf(patchlevel, "%5.3f", (double) 5 +
206 ((double) PATCHLEVEL / (double) 1000));
209 #if defined(LOCAL_PATCH_COUNT)
210 localpatches = local_patches; /* For possible -v */
213 PerlIO_init(); /* Hook to IO system */
215 fdpid = newAV(); /* for remembering popen pids by fd */
219 New(51,debname,128,char);
220 New(52,debdelim,128,char);
227 perl_destruct(sv_interp)
228 register PerlInterpreter *sv_interp;
231 int destruct_level; /* 0=none, 1=full, 2=full with checks */
236 if (!(curinterp = sv_interp))
241 /* Join with any remaining non-detached threads */
242 MUTEX_LOCK(&threads_mutex);
243 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
244 "perl_destruct: waiting for %d threads...\n",
246 for (t = thr->next; t != thr; t = t->next) {
247 MUTEX_LOCK(&t->mutex);
248 switch (ThrSTATE(t)) {
251 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
252 "perl_destruct: joining zombie %p\n", t));
253 ThrSETSTATE(t, THRf_DEAD);
254 MUTEX_UNLOCK(&t->mutex);
256 MUTEX_UNLOCK(&threads_mutex);
257 if (pthread_join(t->Tself, (void**)&av))
258 croak("panic: pthread_join failed during global destruction");
259 SvREFCNT_dec((SV*)av);
260 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
261 "perl_destruct: joined zombie %p OK\n", t));
263 case THRf_R_JOINABLE:
264 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
265 "perl_destruct: detaching thread %p\n", t));
266 ThrSETSTATE(t, THRf_R_DETACHED);
268 * We unlock threads_mutex and t->mutex in the opposite order
269 * from which we locked them just so that DETACH won't
270 * deadlock if it panics. It's only a breach of good style
271 * not a bug since they are unlocks not locks.
273 MUTEX_UNLOCK(&threads_mutex);
275 MUTEX_UNLOCK(&t->mutex);
278 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
279 "perl_destruct: ignoring %p (state %u)\n",
281 MUTEX_UNLOCK(&t->mutex);
282 MUTEX_UNLOCK(&threads_mutex);
283 /* fall through and out */
286 /* Now wait for the thread count nthreads to drop to one */
289 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
290 "perl_destruct: final wait for %d threads\n",
292 COND_WAIT(&nthreads_cond, &threads_mutex);
294 /* At this point, we're the last thread */
295 MUTEX_UNLOCK(&threads_mutex);
296 DEBUG_L(PerlIO_printf(PerlIO_stderr(), "perl_destruct: armageddon has arrived\n"));
297 MUTEX_DESTROY(&threads_mutex);
298 COND_DESTROY(&nthreads_cond);
299 #endif /* !defined(FAKE_THREADS) */
300 #endif /* USE_THREADS */
302 destruct_level = perl_destruct_level;
306 if (s = getenv("PERL_DESTRUCT_LEVEL")) {
308 if (destruct_level < i)
317 /* We must account for everything. */
319 /* Destroy the main CV and syntax tree */
321 curpad = AvARRAY(comppad);
326 SvREFCNT_dec(main_cv);
331 * Try to destruct global references. We do this first so that the
332 * destructors and destructees still exist. Some sv's might remain.
333 * Non-referenced objects are on their own.
340 /* unhook hooks which will soon be, or use, destroyed data */
341 SvREFCNT_dec(warnhook);
343 SvREFCNT_dec(diehook);
345 SvREFCNT_dec(parsehook);
348 if (destruct_level == 0){
350 DEBUG_P(debprofdump());
352 /* The exit() function will do everything that needs doing. */
356 /* loosen bonds of global variables */
359 (void)PerlIO_close(rsfp);
363 /* Filters for program text */
364 SvREFCNT_dec(rsfp_filters);
365 rsfp_filters = Nullav;
377 sawampersand = FALSE; /* must save all match strings */
378 sawstudy = FALSE; /* do fbm_instr on all strings */
393 /* magical thingies */
395 Safefree(ofs); /* $, */
398 Safefree(ors); /* $\ */
401 SvREFCNT_dec(nrs); /* $\ helper */
404 multiline = 0; /* $* */
406 SvREFCNT_dec(statname);
410 /* defgv, aka *_ should be taken care of elsewhere */
412 #if 0 /* just about all regexp stuff, seems to be ok */
414 /* shortcuts to regexp stuff */
419 SAVEFREEOP(oldlastpm); /* for saving regexp context during debugger */
421 regprecomp = NULL; /* uncompiled string. */
422 regparse = NULL; /* Input-scan pointer. */
423 regxend = NULL; /* End of input for compile */
424 regnpar = 0; /* () count. */
425 regcode = NULL; /* Code-emit pointer; ®dummy = don't. */
426 regsize = 0; /* Code size. */
427 regnaughty = 0; /* How bad is this pattern? */
428 regsawback = 0; /* Did we see \1, ...? */
430 reginput = NULL; /* String-input pointer. */
431 regbol = NULL; /* Beginning of input, for ^ check. */
432 regeol = NULL; /* End of input, for $ check. */
433 regstartp = (char **)NULL; /* Pointer to startp array. */
434 regendp = (char **)NULL; /* Ditto for endp. */
435 reglastparen = 0; /* Similarly for lastparen. */
436 regtill = NULL; /* How far we are required to go. */
437 regflags = 0; /* are we folding, multilining? */
438 regprev = (char)NULL; /* char before regbol, \n if none */
442 /* clean up after study() */
443 SvREFCNT_dec(lastscream);
445 Safefree(screamfirst);
447 Safefree(screamnext);
450 /* startup and shutdown function lists */
451 SvREFCNT_dec(beginav);
453 SvREFCNT_dec(initav);
458 /* temp stack during pp_sort() */
459 SvREFCNT_dec(sortstack);
462 /* shortcuts just get cleared */
472 /* reset so print() ends up where we expect */
475 /* Prepare to destruct main symbol table. */
482 if (destruct_level >= 2) {
483 if (scopestack_ix != 0)
484 warn("Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
485 (long)scopestack_ix);
486 if (savestack_ix != 0)
487 warn("Unbalanced saves: %ld more saves than restores\n",
489 if (tmps_floor != -1)
490 warn("Unbalanced tmps: %ld more allocs than frees\n",
491 (long)tmps_floor + 1);
492 if (cxstack_ix != -1)
493 warn("Unbalanced context: %ld more PUSHes than POPs\n",
494 (long)cxstack_ix + 1);
497 /* Now absolutely destruct everything, somehow or other, loops or no. */
499 SvFLAGS(strtab) |= SVTYPEMASK; /* don't clean out strtab now */
500 while (sv_count != 0 && sv_count != last_sv_count) {
501 last_sv_count = sv_count;
504 SvFLAGS(strtab) &= ~SVTYPEMASK;
505 SvFLAGS(strtab) |= SVt_PVHV;
507 /* Destruct the global string table. */
509 /* Yell and reset the HeVAL() slots that are still holding refcounts,
510 * so that sv_free() won't fail on them.
519 array = HvARRAY(strtab);
523 warn("Unbalanced string table refcount: (%d) for \"%s\"",
524 HeVAL(hent) - Nullsv, HeKEY(hent));
525 HeVAL(hent) = Nullsv;
535 SvREFCNT_dec(strtab);
538 warn("Scalars leaked: %ld\n", (long)sv_count);
542 /* No SVs have survived, need to clean out */
546 Safefree(origfilename);
548 hints = 0; /* Reset hints. Should hints be per-interpreter ? */
550 DEBUG_P(debprofdump());
552 MUTEX_DESTROY(&sv_mutex);
553 MUTEX_DESTROY(&malloc_mutex);
554 MUTEX_DESTROY(&eval_mutex);
555 COND_DESTROY(&eval_cond);
556 #endif /* USE_THREADS */
558 /* As the absolutely last thing, free the non-arena SV for mess() */
561 /* we know that type >= SVt_PV */
563 Safefree(SvPVX(mess_sv));
564 Safefree(SvANY(mess_sv));
572 PerlInterpreter *sv_interp;
574 if (!(curinterp = sv_interp))
580 perl_parse(sv_interp, xsinit, argc, argv, env)
581 PerlInterpreter *sv_interp;
582 void (*xsinit)_((void));
590 char *scriptname = NULL;
591 VOL bool dosearch = FALSE;
598 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
601 croak("suidperl is no longer needed since the kernel can now execute\n\
602 setuid perl scripts securely.\n");
606 if (!(curinterp = sv_interp))
609 #if defined(NeXT) && defined(__DYNAMIC__)
610 _dyld_lookup_and_bind
611 ("__environ", (unsigned long *) &environ_pointer, NULL);
616 #ifndef VMS /* VMS doesn't have environ array */
617 origenviron = environ;
623 /* Come here if running an undumped a.out. */
625 origfilename = savepv(argv[0]);
627 cxstack_ix = -1; /* start label stack again */
629 init_postdump_symbols(argc,argv,env);
634 curpad = AvARRAY(comppad);
639 SvREFCNT_dec(main_cv);
643 oldscope = scopestack_ix;
651 /* my_exit() was called */
652 while (scopestack_ix > oldscope)
657 call_list(oldscope, endav);
659 return STATUS_NATIVE_EXPORT;
662 PerlIO_printf(PerlIO_stderr(), "panic: top_env\n");
666 sv_setpvn(linestr,"",0);
667 sv = newSVpv("",0); /* first used for -I flags */
671 for (argc--,argv++; argc > 0; argc--,argv++) {
672 if (argv[0][0] != '-' || !argv[0][1])
676 validarg = " PHOOEY ";
701 if (s = moreswitches(s))
711 if (euid != uid || egid != gid)
712 croak("No -e allowed in setuid scripts");
714 e_tmpname = savepv(TMPPATH);
715 (void)mktemp(e_tmpname);
717 croak("Can't mktemp()");
718 e_fp = PerlIO_open(e_tmpname,"w");
720 croak("Cannot open temporary file");
725 PerlIO_puts(e_fp,argv[1]);
729 croak("No code specified for -e");
730 (void)PerlIO_putc(e_fp,'\n');
741 incpush(argv[1], TRUE);
742 sv_catpv(sv,argv[1]);
759 preambleav = newAV();
760 av_push(preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
762 Sv = newSVpv("print myconfig();",0);
764 sv_catpv(Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
766 sv_catpv(Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
768 #if defined(DEBUGGING) || defined(NO_EMBED) || defined(MULTIPLICITY)
769 sv_catpv(Sv,"\" Compile-time options:");
771 sv_catpv(Sv," DEBUGGING");
774 sv_catpv(Sv," NO_EMBED");
777 sv_catpv(Sv," MULTIPLICITY");
779 sv_catpv(Sv,"\\n\",");
781 #if defined(LOCAL_PATCH_COUNT)
782 if (LOCAL_PATCH_COUNT > 0) {
784 sv_catpv(Sv,"\" Locally applied patches:\\n\",");
785 for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
787 sv_catpvf(Sv,"\" \\t%s\\n\",",localpatches[i]);
791 sv_catpvf(Sv,"\" Built under %s\\n\"",OSNAME);
794 sv_catpvf(Sv,",\" Compiled at %s %s\\n\"",__DATE__,__TIME__);
796 sv_catpvf(Sv,",\" Compiled on %s\\n\"",__DATE__);
801 @env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; \
802 print \" \\%ENV:\\n @env\\n\" if @env; \
803 print \" \\@INC:\\n @INC\\n\";");
806 Sv = newSVpv("config_vars(qw(",0);
811 av_push(preambleav, Sv);
812 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
821 if (*++s) { /* catch use of gnu style long options */
822 if (strEQ(s, "version")) {
826 if (strEQ(s, "help")) {
830 croak("Unrecognized switch: --%s (-h will show valid options)",s);
837 croak("Unrecognized switch: -%s (-h will show valid options)",s);
842 if (!tainting && (s = getenv("PERL5OPT"))) {
853 if (!strchr("DIMUdmw", *s))
854 croak("Illegal switch in PERL5OPT: -%c", *s);
860 scriptname = argv[0];
862 if (PerlIO_flush(e_fp) || PerlIO_error(e_fp) || PerlIO_close(e_fp)) {
864 warn("Did you forget to compile with -DMULTIPLICITY?");
866 croak("Can't write to temp file for -e: %s", Strerror(errno));
870 scriptname = e_tmpname;
872 else if (scriptname == Nullch) {
874 if ( isatty(PerlIO_fileno(PerlIO_stdin())) )
882 open_script(scriptname,dosearch,sv);
884 validate_suid(validarg, scriptname);
889 main_cv = compcv = (CV*)NEWSV(1104,0);
890 sv_upgrade((SV *)compcv, SVt_PVCV);
894 av_push(comppad, Nullsv);
895 curpad = AvARRAY(comppad);
896 comppad_name = newAV();
897 comppad_name_fill = 0;
898 min_intro_pending = 0;
901 av_store(comppad_name, 0, newSVpv("@_", 2));
902 curpad[0] = (SV*)newAV();
903 SvPADMY_on(curpad[0]); /* XXX Needed? */
905 New(666, CvMUTEXP(compcv), 1, perl_mutex);
906 MUTEX_INIT(CvMUTEXP(compcv));
907 #endif /* USE_THREADS */
909 comppadlist = newAV();
910 AvREAL_off(comppadlist);
911 av_store(comppadlist, 0, (SV*)comppad_name);
912 av_store(comppadlist, 1, (SV*)comppad);
913 CvPADLIST(compcv) = comppadlist;
915 boot_core_UNIVERSAL();
917 (*xsinit)(); /* in case linked C routines want magical variables */
918 #if defined(VMS) || defined(WIN32)
922 #if defined(DEBUGGING) && defined(USE_THREADS) && defined(__linux__)
923 DEBUG_L(signal(SIGSEGV, (void(*)(int))catch_sigsegv););
926 init_predump_symbols();
928 init_postdump_symbols(argc,argv,env);
932 /* now parse the script */
935 if (yyparse() || error_count) {
937 croak("%s had compilation errors.\n", origfilename);
939 croak("Execution of %s aborted due to compilation errors.\n",
943 curcop->cop_line = 0;
947 (void)UNLINK(e_tmpname);
952 /* now that script is parsed, we can modify record separator */
954 rs = SvREFCNT_inc(nrs);
955 sv_setsv(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), rs);
967 if ((s=getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
968 dump_mstats("after compilation:");
979 PerlInterpreter *sv_interp;
986 if (!(curinterp = sv_interp))
989 oldscope = scopestack_ix;
994 cxstack_ix = -1; /* start context stack again */
997 /* my_exit() was called */
998 while (scopestack_ix > oldscope)
1001 curstash = defstash;
1003 call_list(oldscope, endav);
1005 if (getenv("PERL_DEBUG_MSTATS"))
1006 dump_mstats("after execution: ");
1009 return STATUS_NATIVE_EXPORT;
1012 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
1017 if (curstack != mainstack) {
1019 SWITCHSTACK(curstack, mainstack);
1024 DEBUG_r(PerlIO_printf(PerlIO_stderr(), "%s $` $& $' support.\n",
1025 sawampersand ? "Enabling" : "Omitting"));
1028 DEBUG_x(dump_all());
1029 DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
1031 DEBUG_L(PerlIO_printf(Perl_debug_log, "main thread is 0x%lx\n",
1032 (unsigned long) thr));
1033 #endif /* USE_THREADS */
1036 PerlIO_printf(PerlIO_stderr(), "%s syntax OK\n", origfilename);
1039 if (PERLDB_SINGLE && DBsingle)
1040 sv_setiv(DBsingle, 1);
1042 call_list(oldscope, initav);
1052 else if (main_start) {
1053 CvDEPTH(main_cv) = 1;
1064 perl_get_sv(name, create)
1068 GV* gv = gv_fetchpv(name, create, SVt_PV);
1075 perl_get_av(name, create)
1079 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
1088 perl_get_hv(name, create)
1092 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
1101 perl_get_cv(name, create)
1105 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
1106 if (create && !GvCVu(gv))
1107 return newSUB(start_subparse(FALSE, 0),
1108 newSVOP(OP_CONST, 0, newSVpv(name,0)),
1116 /* Be sure to refetch the stack pointer after calling these routines. */
1119 perl_call_argv(subname, flags, argv)
1121 I32 flags; /* See G_* flags in cop.h */
1122 register char **argv; /* null terminated arg list */
1130 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
1135 return perl_call_pv(subname, flags);
1139 perl_call_pv(subname, flags)
1140 char *subname; /* name of the subroutine */
1141 I32 flags; /* See G_* flags in cop.h */
1143 return perl_call_sv((SV*)perl_get_cv(subname, TRUE), flags);
1147 perl_call_method(methname, flags)
1148 char *methname; /* name of the subroutine */
1149 I32 flags; /* See G_* flags in cop.h */
1156 XPUSHs(sv_2mortal(newSVpv(methname,0)));
1159 return perl_call_sv(*stack_sp--, flags);
1162 /* May be called with any of a CV, a GV, or an SV containing the name. */
1164 perl_call_sv(sv, flags)
1166 I32 flags; /* See G_* flags in cop.h */
1169 LOGOP myop; /* fake syntax tree node */
1175 bool oldcatch = CATCH_GET;
1180 if (flags & G_DISCARD) {
1185 Zero(&myop, 1, LOGOP);
1186 myop.op_next = Nullop;
1187 if (!(flags & G_NOARGS))
1188 myop.op_flags |= OPf_STACKED;
1189 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1190 (flags & G_ARRAY) ? OPf_WANT_LIST :
1195 EXTEND(stack_sp, 1);
1198 oldscope = scopestack_ix;
1200 if (PERLDB_SUB && curstash != debstash
1201 /* Handle first BEGIN of -d. */
1202 && (DBcv || (DBcv = GvCV(DBsub)))
1203 /* Try harder, since this may have been a sighandler, thus
1204 * curstash may be meaningless. */
1205 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != debstash))
1206 op->op_private |= OPpENTERSUB_DB;
1208 if (flags & G_EVAL) {
1209 cLOGOP->op_other = op;
1211 /* we're trying to emulate pp_entertry() here */
1213 register CONTEXT *cx;
1214 I32 gimme = GIMME_V;
1219 push_return(op->op_next);
1220 PUSHBLOCK(cx, CXt_EVAL, stack_sp);
1222 eval_root = op; /* Only needed so that goto works right. */
1225 if (flags & G_KEEPERR)
1228 sv_setpv(GvSV(errgv),"");
1240 /* my_exit() was called */
1241 curstash = defstash;
1245 croak("Callback called exit");
1254 stack_sp = stack_base + oldmark;
1255 if (flags & G_ARRAY)
1259 *++stack_sp = &sv_undef;
1267 if (op == (OP*)&myop)
1268 op = pp_entersub(ARGS);
1271 retval = stack_sp - (stack_base + oldmark);
1272 if ((flags & G_EVAL) && !(flags & G_KEEPERR))
1273 sv_setpv(GvSV(errgv),"");
1276 if (flags & G_EVAL) {
1277 if (scopestack_ix > oldscope) {
1281 register CONTEXT *cx;
1293 CATCH_SET(oldcatch);
1295 if (flags & G_DISCARD) {
1296 stack_sp = stack_base + oldmark;
1305 /* Eval a string. The G_EVAL flag is always assumed. */
1308 perl_eval_sv(sv, flags)
1310 I32 flags; /* See G_* flags in cop.h */
1313 UNOP myop; /* fake syntax tree node */
1315 I32 oldmark = sp - stack_base;
1322 if (flags & G_DISCARD) {
1330 EXTEND(stack_sp, 1);
1332 oldscope = scopestack_ix;
1334 if (!(flags & G_NOARGS))
1335 myop.op_flags = OPf_STACKED;
1336 myop.op_next = Nullop;
1337 myop.op_type = OP_ENTEREVAL;
1338 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1339 (flags & G_ARRAY) ? OPf_WANT_LIST :
1341 if (flags & G_KEEPERR)
1342 myop.op_flags |= OPf_SPECIAL;
1352 /* my_exit() was called */
1353 curstash = defstash;
1357 croak("Callback called exit");
1366 stack_sp = stack_base + oldmark;
1367 if (flags & G_ARRAY)
1371 *++stack_sp = &sv_undef;
1376 if (op == (OP*)&myop)
1377 op = pp_entereval(ARGS);
1380 retval = stack_sp - (stack_base + oldmark);
1381 if (!(flags & G_KEEPERR))
1382 sv_setpv(GvSV(errgv),"");
1386 if (flags & G_DISCARD) {
1387 stack_sp = stack_base + oldmark;
1397 perl_eval_pv(p, croak_on_error)
1403 SV* sv = newSVpv(p, 0);
1406 perl_eval_sv(sv, G_SCALAR);
1413 if (croak_on_error && SvTRUE(GvSV(errgv)))
1414 croak(SvPVx(GvSV(errgv), na));
1419 /* Require a module. */
1425 SV* sv = sv_newmortal();
1426 sv_setpv(sv, "require '");
1429 perl_eval_sv(sv, G_DISCARD);
1433 magicname(sym,name,namlen)
1440 if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
1441 sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
1445 usage(name) /* XXX move this out into a module ? */
1448 /* This message really ought to be max 23 lines.
1449 * Removed -h because the user already knows that opton. Others? */
1450 printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
1451 printf("\n -0[octal] specify record separator (\\0, if no argument)");
1452 printf("\n -a autosplit mode with -n or -p (splits $_ into @F)");
1453 printf("\n -c check syntax only (runs BEGIN and END blocks)");
1454 printf("\n -d[:debugger] run scripts under debugger");
1455 printf("\n -D[number/list] set debugging flags (argument is a bit mask or flags)");
1456 printf("\n -e 'command' one line of script. Several -e's allowed. Omit [programfile].");
1457 printf("\n -F/pattern/ split() pattern for autosplit (-a). The //'s are optional.");
1458 printf("\n -i[extension] edit <> files in place (make backup if extension supplied)");
1459 printf("\n -Idirectory specify @INC/#include directory (may be used more than once)");
1460 printf("\n -l[octal] enable line ending processing, specifies line terminator");
1461 printf("\n -[mM][-]module.. executes `use/no module...' before executing your script.");
1462 printf("\n -n assume 'while (<>) { ... }' loop around your script");
1463 printf("\n -p assume loop like -n but print line also like sed");
1464 printf("\n -P run script through C preprocessor before compilation");
1465 printf("\n -s enable some switch parsing for switches after script name");
1466 printf("\n -S look for the script using PATH environment variable");
1467 printf("\n -T turn on tainting checks");
1468 printf("\n -u dump core after parsing script");
1469 printf("\n -U allow unsafe operations");
1470 printf("\n -v print version number and patchlevel of perl");
1471 printf("\n -V[:variable] print perl configuration information");
1472 printf("\n -w TURN WARNINGS ON FOR COMPILATION OF YOUR SCRIPT. Recommended.");
1473 printf("\n -x[directory] strip off text before #!perl line and perhaps cd to directory\n");
1476 /* This routine handles any switches that can be given during run */
1487 rschar = scan_oct(s, 4, &numlen);
1489 if (rschar & ~((U8)~0))
1491 else if (!rschar && numlen >= 2)
1492 nrs = newSVpv("", 0);
1495 nrs = newSVpv(&ch, 1);
1500 splitstr = savepv(s + 1);
1514 if (*s == ':' || *s == '=') {
1515 my_setenv("PERL5DB", form("use Devel::%s;", ++s));
1519 perldb = PERLDB_ALL;
1526 if (isALPHA(s[1])) {
1527 static char debopts[] = "psltocPmfrxuLHXD";
1530 for (s++; *s && (d = strchr(debopts,*s)); s++)
1531 debug |= 1 << (d - debopts);
1535 for (s++; isDIGIT(*s); s++) ;
1537 debug |= 0x80000000;
1539 warn("Recompile perl with -DDEBUGGING to use -D switch\n");
1540 for (s++; isALNUM(*s); s++) ;
1550 inplace = savepv(s+1);
1552 for (s = inplace; *s && !isSPACE(*s); s++) ;
1559 for (e = s; *e && !isSPACE(*e); e++) ;
1560 p = savepvn(s, e-s);
1567 croak("No space allowed after -I");
1577 *ors = scan_oct(s, 3 + (*s == '0'), &numlen);
1586 ors = SvPV(nrs, orslen);
1587 ors = savepvn(ors, orslen);
1591 forbid_setid("-M"); /* XXX ? */
1594 forbid_setid("-m"); /* XXX ? */
1599 /* -M-foo == 'no foo' */
1600 if (*s == '-') { use = "no "; ++s; }
1601 sv = newSVpv(use,0);
1603 /* We allow -M'Module qw(Foo Bar)' */
1604 while(isALNUM(*s) || *s==':') ++s;
1606 sv_catpv(sv, start);
1607 if (*(start-1) == 'm') {
1609 croak("Can't use '%c' after -mname", *s);
1610 sv_catpv( sv, " ()");
1613 sv_catpvn(sv, start, s-start);
1614 sv_catpv(sv, " split(/,/,q{");
1619 if (preambleav == NULL)
1620 preambleav = newAV();
1621 av_push(preambleav, sv);
1624 croak("No space allowed after -%c", *(s-1));
1641 croak("Too late for \"-T\" option");
1653 #if defined(SUBVERSION) && SUBVERSION > 0
1654 printf("\nThis is perl, version 5.%03d_%02d", PATCHLEVEL, SUBVERSION);
1656 printf("\nThis is perl, version %s",patchlevel);
1659 printf("\n\nCopyright 1987-1997, Larry Wall\n");
1661 printf("\n\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
1664 printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n");
1667 printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
1668 "Version 5 port Copyright (c) 1994-1997, Andreas Kaiser, Ilya Zakharevich\n");
1671 printf("atariST series port, ++jrb bammi@cadence.com\n");
1674 Perl may be copied only under the terms of either the Artistic License or the\n\
1675 GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n");
1683 if (s[1] == '-') /* Additional switches on #! line. */
1691 #ifdef ALTERNATE_SHEBANG
1692 case 'S': /* OS/2 needs -S on "extproc" line. */
1700 croak("Can't emulate -%.1s on #! line",s);
1705 /* compliments of Tom Christiansen */
1707 /* unexec() can be found in the Gnu emacs distribution */
1718 prog = newSVpv(BIN_EXP);
1719 sv_catpv(prog, "/perl");
1720 file = newSVpv(origfilename);
1721 sv_catpv(file, ".perldump");
1723 status = unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
1725 PerlIO_printf(PerlIO_stderr(), "unexec of %s into %s failed!\n",
1726 SvPVX(prog), SvPVX(file));
1730 # include <lib$routines.h>
1731 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
1733 ABORT(); /* for use with undump */
1744 /* Note that strtab is a rather special HV. Assumptions are made
1745 about not iterating on it, and not adding tie magic to it.
1746 It is properly deallocated in perl_destruct() */
1748 HvSHAREKEYS_off(strtab); /* mandatory */
1749 Newz(506,((XPVHV*)SvANY(strtab))->xhv_array,
1750 sizeof(HE*) * (((XPVHV*)SvANY(strtab))->xhv_max + 1), char);
1752 curstash = defstash = newHV();
1753 curstname = newSVpv("main",4);
1754 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
1755 SvREFCNT_dec(GvHV(gv));
1756 GvHV(gv) = (HV*)SvREFCNT_inc(defstash);
1758 HvNAME(defstash) = savepv("main");
1759 incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
1761 defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
1762 errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
1764 (void)form("%240s",""); /* Preallocate temp - for immediate signals. */
1765 sv_grow(GvSV(errgv), 240); /* Preallocate - for immediate signals. */
1766 sv_setpvn(GvSV(errgv), "", 0);
1767 curstash = defstash;
1768 compiling.cop_stash = defstash;
1769 debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
1770 /* We must init $/ before switches are processed. */
1771 sv_setpvn(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), "\n", 1);
1774 #ifdef CAN_PROTOTYPE
1776 open_script(char *scriptname, bool dosearch, SV *sv)
1779 open_script(scriptname,dosearch,sv)
1786 char *xfound = Nullch;
1787 char *xfailed = Nullch;
1791 #if defined(DOSISH) && !defined(OS2) && !defined(atarist)
1792 # define SEARCH_EXTS ".bat", ".cmd", NULL
1793 # define MAX_EXT_LEN 4
1796 # define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL
1797 # define MAX_EXT_LEN 4
1800 # define SEARCH_EXTS ".pl", ".com", NULL
1801 # define MAX_EXT_LEN 4
1803 /* additional extensions to try in each dir if scriptname not found */
1805 char *ext[] = { SEARCH_EXTS };
1806 int extidx = 0, i = 0;
1807 char *curext = Nullch;
1809 # define MAX_EXT_LEN 0
1813 * If dosearch is true and if scriptname does not contain path
1814 * delimiters, search the PATH for scriptname.
1816 * If SEARCH_EXTS is also defined, will look for each
1817 * scriptname{SEARCH_EXTS} whenever scriptname is not found
1818 * while searching the PATH.
1820 * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
1821 * proceeds as follows:
1823 * + look for ./scriptname{,.foo,.bar}
1824 * + search the PATH for scriptname{,.foo,.bar}
1827 * + look *only* in the PATH for scriptname{,.foo,.bar} (note
1828 * this will not look in '.' if it's not in the PATH)
1833 int hasdir, idx = 0, deftypes = 1;
1836 hasdir = (strpbrk(scriptname,":[</") != Nullch) ;
1837 /* The first time through, just add SEARCH_EXTS to whatever we
1838 * already have, so we can check for default file types. */
1840 (!hasdir && my_trnlnm("DCL$PATH",tokenbuf,idx++)) )
1846 if ((strlen(tokenbuf) + strlen(scriptname)
1847 + MAX_EXT_LEN) >= sizeof tokenbuf)
1848 continue; /* don't search dir with too-long name */
1849 strcat(tokenbuf, scriptname);
1853 if (strEQ(scriptname, "-"))
1855 if (dosearch) { /* Look in '.' first. */
1856 char *cur = scriptname;
1858 if ((curext = strrchr(scriptname,'.'))) /* possible current ext */
1860 if (strEQ(ext[i++],curext)) {
1861 extidx = -1; /* already has an ext */
1866 DEBUG_p(PerlIO_printf(Perl_debug_log,
1867 "Looking for %s\n",cur));
1868 if (Stat(cur,&statbuf) >= 0) {
1876 if (cur == scriptname) {
1877 len = strlen(scriptname);
1878 if (len+MAX_EXT_LEN+1 >= sizeof(tokenbuf))
1880 cur = strcpy(tokenbuf, scriptname);
1882 } while (extidx >= 0 && ext[extidx] /* try an extension? */
1883 && strcpy(tokenbuf+len, ext[extidx++]));
1888 if (dosearch && !strchr(scriptname, '/')
1890 && !strchr(scriptname, '\\')
1892 && (s = getenv("PATH"))) {
1895 bufend = s + strlen(s);
1896 while (s < bufend) {
1897 #if defined(atarist) || defined(DOSISH)
1902 && *s != ';'; len++, s++) {
1903 if (len < sizeof tokenbuf)
1906 if (len < sizeof tokenbuf)
1907 tokenbuf[len] = '\0';
1908 #else /* ! (atarist || DOSISH) */
1909 s = delimcpy(tokenbuf, tokenbuf + sizeof tokenbuf, s, bufend,
1912 #endif /* ! (atarist || DOSISH) */
1915 if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tokenbuf)
1916 continue; /* don't search dir with too-long name */
1918 #if defined(atarist) || defined(DOSISH)
1919 && tokenbuf[len - 1] != '/'
1920 && tokenbuf[len - 1] != '\\'
1923 tokenbuf[len++] = '/';
1924 if (len == 2 && tokenbuf[0] == '.')
1926 (void)strcpy(tokenbuf + len, scriptname);
1930 len = strlen(tokenbuf);
1931 if (extidx > 0) /* reset after previous loop */
1935 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tokenbuf));
1936 retval = Stat(tokenbuf,&statbuf);
1938 } while ( retval < 0 /* not there */
1939 && extidx>=0 && ext[extidx] /* try an extension? */
1940 && strcpy(tokenbuf+len, ext[extidx++])
1945 if (S_ISREG(statbuf.st_mode)
1946 && cando(S_IRUSR,TRUE,&statbuf)
1948 && cando(S_IXUSR,TRUE,&statbuf)
1952 xfound = tokenbuf; /* bingo! */
1956 xfailed = savepv(tokenbuf);
1959 if (!xfound && !seen_dot && !xfailed && (Stat(scriptname,&statbuf) < 0))
1961 seen_dot = 1; /* Disable message. */
1963 croak("Can't %s %s%s%s",
1964 (xfailed ? "execute" : "find"),
1965 (xfailed ? xfailed : scriptname),
1966 (xfailed ? "" : " on PATH"),
1967 (xfailed || seen_dot) ? "" : ", '.' not in PATH");
1970 scriptname = xfound;
1973 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
1974 char *s = scriptname + 8;
1983 origfilename = savepv(e_tmpname ? "-e" : scriptname);
1984 curcop->cop_filegv = gv_fetchfile(origfilename);
1985 if (strEQ(origfilename,"-"))
1987 if (fdscript >= 0) {
1988 rsfp = PerlIO_fdopen(fdscript,"r");
1989 #if defined(HAS_FCNTL) && defined(F_SETFD)
1991 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
1994 else if (preprocess) {
1995 char *cpp_cfg = CPPSTDIN;
1996 SV *cpp = NEWSV(0,0);
1997 SV *cmd = NEWSV(0,0);
1999 if (strEQ(cpp_cfg, "cppstdin"))
2000 sv_catpvf(cpp, "%s/", BIN_EXP);
2001 sv_catpv(cpp, cpp_cfg);
2004 sv_catpv(sv,PRIVLIB_EXP);
2008 sed %s -e \"/^[^#]/b\" \
2009 -e \"/^#[ ]*include[ ]/b\" \
2010 -e \"/^#[ ]*define[ ]/b\" \
2011 -e \"/^#[ ]*if[ ]/b\" \
2012 -e \"/^#[ ]*ifdef[ ]/b\" \
2013 -e \"/^#[ ]*ifndef[ ]/b\" \
2014 -e \"/^#[ ]*else/b\" \
2015 -e \"/^#[ ]*elif[ ]/b\" \
2016 -e \"/^#[ ]*undef[ ]/b\" \
2017 -e \"/^#[ ]*endif/b\" \
2020 (doextract ? "-e \"1,/^#/d\n\"" : ""),
2023 %s %s -e '/^[^#]/b' \
2024 -e '/^#[ ]*include[ ]/b' \
2025 -e '/^#[ ]*define[ ]/b' \
2026 -e '/^#[ ]*if[ ]/b' \
2027 -e '/^#[ ]*ifdef[ ]/b' \
2028 -e '/^#[ ]*ifndef[ ]/b' \
2029 -e '/^#[ ]*else/b' \
2030 -e '/^#[ ]*elif[ ]/b' \
2031 -e '/^#[ ]*undef[ ]/b' \
2032 -e '/^#[ ]*endif/b' \
2040 (doextract ? "-e '1,/^#/d\n'" : ""),
2042 scriptname, cpp, sv, CPPMINUS);
2044 #ifdef IAMSUID /* actually, this is caught earlier */
2045 if (euid != uid && !euid) { /* if running suidperl */
2047 (void)seteuid(uid); /* musn't stay setuid root */
2050 (void)setreuid((Uid_t)-1, uid);
2052 #ifdef HAS_SETRESUID
2053 (void)setresuid((Uid_t)-1, uid, (Uid_t)-1);
2059 if (geteuid() != uid)
2060 croak("Can't do seteuid!\n");
2062 #endif /* IAMSUID */
2063 rsfp = my_popen(SvPVX(cmd), "r");
2067 else if (!*scriptname) {
2068 forbid_setid("program input from stdin");
2069 rsfp = PerlIO_stdin();
2072 rsfp = PerlIO_open(scriptname,"r");
2073 #if defined(HAS_FCNTL) && defined(F_SETFD)
2075 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
2083 #ifndef IAMSUID /* in case script is not readable before setuid */
2084 if (euid && Stat(SvPVX(GvSV(curcop->cop_filegv)),&statbuf) >= 0 &&
2085 statbuf.st_mode & (S_ISUID|S_ISGID)) {
2087 execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
2088 croak("Can't do setuid\n");
2092 croak("Can't open perl script \"%s\": %s\n",
2093 SvPVX(GvSV(curcop->cop_filegv)), Strerror(errno));
2098 validate_suid(validarg, scriptname)
2104 /* do we need to emulate setuid on scripts? */
2106 /* This code is for those BSD systems that have setuid #! scripts disabled
2107 * in the kernel because of a security problem. Merely defining DOSUID
2108 * in perl will not fix that problem, but if you have disabled setuid
2109 * scripts in the kernel, this will attempt to emulate setuid and setgid
2110 * on scripts that have those now-otherwise-useless bits set. The setuid
2111 * root version must be called suidperl or sperlN.NNN. If regular perl
2112 * discovers that it has opened a setuid script, it calls suidperl with
2113 * the same argv that it had. If suidperl finds that the script it has
2114 * just opened is NOT setuid root, it sets the effective uid back to the
2115 * uid. We don't just make perl setuid root because that loses the
2116 * effective uid we had before invoking perl, if it was different from the
2119 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
2120 * be defined in suidperl only. suidperl must be setuid root. The
2121 * Configure script will set this up for you if you want it.
2127 if (Fstat(PerlIO_fileno(rsfp),&statbuf) < 0) /* normal stat is insecure */
2128 croak("Can't stat script \"%s\"",origfilename);
2129 if (fdscript < 0 && statbuf.st_mode & (S_ISUID|S_ISGID)) {
2133 #ifndef HAS_SETREUID
2134 /* On this access check to make sure the directories are readable,
2135 * there is actually a small window that the user could use to make
2136 * filename point to an accessible directory. So there is a faint
2137 * chance that someone could execute a setuid script down in a
2138 * non-accessible directory. I don't know what to do about that.
2139 * But I don't think it's too important. The manual lies when
2140 * it says access() is useful in setuid programs.
2142 if (access(SvPVX(GvSV(curcop->cop_filegv)),1)) /*double check*/
2143 croak("Permission denied");
2145 /* If we can swap euid and uid, then we can determine access rights
2146 * with a simple stat of the file, and then compare device and
2147 * inode to make sure we did stat() on the same file we opened.
2148 * Then we just have to make sure he or she can execute it.
2151 struct stat tmpstatbuf;
2155 setreuid(euid,uid) < 0
2158 setresuid(euid,uid,(Uid_t)-1) < 0
2161 || getuid() != euid || geteuid() != uid)
2162 croak("Can't swap uid and euid"); /* really paranoid */
2163 if (Stat(SvPVX(GvSV(curcop->cop_filegv)),&tmpstatbuf) < 0)
2164 croak("Permission denied"); /* testing full pathname here */
2165 if (tmpstatbuf.st_dev != statbuf.st_dev ||
2166 tmpstatbuf.st_ino != statbuf.st_ino) {
2167 (void)PerlIO_close(rsfp);
2168 if (rsfp = my_popen("/bin/mail root","w")) { /* heh, heh */
2170 "User %ld tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
2171 (Filename of set-id script was %s, uid %ld gid %ld.)\n\nSincerely,\nperl\n",
2172 (long)uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
2173 (long)statbuf.st_dev, (long)statbuf.st_ino,
2174 SvPVX(GvSV(curcop->cop_filegv)),
2175 (long)statbuf.st_uid, (long)statbuf.st_gid);
2176 (void)my_pclose(rsfp);
2178 croak("Permission denied\n");
2182 setreuid(uid,euid) < 0
2184 # if defined(HAS_SETRESUID)
2185 setresuid(uid,euid,(Uid_t)-1) < 0
2188 || getuid() != uid || geteuid() != euid)
2189 croak("Can't reswap uid and euid");
2190 if (!cando(S_IXUSR,FALSE,&statbuf)) /* can real uid exec? */
2191 croak("Permission denied\n");
2193 #endif /* HAS_SETREUID */
2194 #endif /* IAMSUID */
2196 if (!S_ISREG(statbuf.st_mode))
2197 croak("Permission denied");
2198 if (statbuf.st_mode & S_IWOTH)
2199 croak("Setuid/gid script is writable by world");
2200 doswitches = FALSE; /* -s is insecure in suid */
2202 if (sv_gets(linestr, rsfp, 0) == Nullch ||
2203 strnNE(SvPV(linestr,na),"#!",2) ) /* required even on Sys V */
2204 croak("No #! line");
2205 s = SvPV(linestr,na)+2;
2207 while (!isSPACE(*s)) s++;
2208 for (s2 = s; (s2 > SvPV(linestr,na)+2 &&
2209 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
2210 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
2211 croak("Not a perl script");
2212 while (*s == ' ' || *s == '\t') s++;
2214 * #! arg must be what we saw above. They can invoke it by
2215 * mentioning suidperl explicitly, but they may not add any strange
2216 * arguments beyond what #! says if they do invoke suidperl that way.
2218 len = strlen(validarg);
2219 if (strEQ(validarg," PHOOEY ") ||
2220 strnNE(s,validarg,len) || !isSPACE(s[len]))
2221 croak("Args must match #! line");
2224 if (euid != uid && (statbuf.st_mode & S_ISUID) &&
2225 euid == statbuf.st_uid)
2227 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2228 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2229 #endif /* IAMSUID */
2231 if (euid) { /* oops, we're not the setuid root perl */
2232 (void)PerlIO_close(rsfp);
2235 execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
2237 croak("Can't do setuid\n");
2240 if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid) {
2242 (void)setegid(statbuf.st_gid);
2245 (void)setregid((Gid_t)-1,statbuf.st_gid);
2247 #ifdef HAS_SETRESGID
2248 (void)setresgid((Gid_t)-1,statbuf.st_gid,(Gid_t)-1);
2250 setgid(statbuf.st_gid);
2254 if (getegid() != statbuf.st_gid)
2255 croak("Can't do setegid!\n");
2257 if (statbuf.st_mode & S_ISUID) {
2258 if (statbuf.st_uid != euid)
2260 (void)seteuid(statbuf.st_uid); /* all that for this */
2263 (void)setreuid((Uid_t)-1,statbuf.st_uid);
2265 #ifdef HAS_SETRESUID
2266 (void)setresuid((Uid_t)-1,statbuf.st_uid,(Uid_t)-1);
2268 setuid(statbuf.st_uid);
2272 if (geteuid() != statbuf.st_uid)
2273 croak("Can't do seteuid!\n");
2275 else if (uid) { /* oops, mustn't run as root */
2277 (void)seteuid((Uid_t)uid);
2280 (void)setreuid((Uid_t)-1,(Uid_t)uid);
2282 #ifdef HAS_SETRESUID
2283 (void)setresuid((Uid_t)-1,(Uid_t)uid,(Uid_t)-1);
2289 if (geteuid() != uid)
2290 croak("Can't do seteuid!\n");
2293 if (!cando(S_IXUSR,TRUE,&statbuf))
2294 croak("Permission denied\n"); /* they can't do this */
2297 else if (preprocess)
2298 croak("-P not allowed for setuid/setgid script\n");
2299 else if (fdscript >= 0)
2300 croak("fd script not allowed in suidperl\n");
2302 croak("Script is not setuid/setgid in suidperl\n");
2304 /* We absolutely must clear out any saved ids here, so we */
2305 /* exec the real perl, substituting fd script for scriptname. */
2306 /* (We pass script name as "subdir" of fd, which perl will grok.) */
2307 PerlIO_rewind(rsfp);
2308 lseek(PerlIO_fileno(rsfp),(Off_t)0,0); /* just in case rewind didn't */
2309 for (which = 1; origargv[which] && origargv[which] != scriptname; which++) ;
2310 if (!origargv[which])
2311 croak("Permission denied");
2312 origargv[which] = savepv(form("/dev/fd/%d/%s",
2313 PerlIO_fileno(rsfp), origargv[which]));
2314 #if defined(HAS_FCNTL) && defined(F_SETFD)
2315 fcntl(PerlIO_fileno(rsfp),F_SETFD,0); /* ensure no close-on-exec */
2317 execv(form("%s/perl%s", BIN_EXP, patchlevel), origargv); /* try again */
2318 croak("Can't do setuid\n");
2319 #endif /* IAMSUID */
2321 if (euid != uid || egid != gid) { /* (suidperl doesn't exist, in fact) */
2322 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
2324 Fstat(PerlIO_fileno(rsfp),&statbuf); /* may be either wrapped or real suid */
2325 if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
2327 (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
2330 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2331 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2332 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
2333 /* not set-id, must be wrapped */
2341 register char *s, *s2;
2343 /* skip forward in input to the real script? */
2347 if ((s = sv_gets(linestr, rsfp, 0)) == Nullch)
2348 croak("No Perl script found in input\n");
2349 if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
2350 PerlIO_ungetc(rsfp, '\n'); /* to keep line count right */
2352 while (*s && !(isSPACE (*s) || *s == '#')) s++;
2354 while (*s == ' ' || *s == '\t') s++;
2356 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
2357 if (strnEQ(s2-4,"perl",4))
2359 while (s = moreswitches(s)) ;
2361 if (cddir && chdir(cddir) < 0)
2362 croak("Can't chdir to %s",cddir);
2370 uid = (int)getuid();
2371 euid = (int)geteuid();
2372 gid = (int)getgid();
2373 egid = (int)getegid();
2378 tainting |= (uid && (euid != uid || egid != gid));
2386 croak("No %s allowed while running setuid", s);
2388 croak("No %s allowed while running setgid", s);
2395 curstash = debstash;
2396 dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
2398 DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
2399 DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
2400 DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
2401 DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
2402 sv_setiv(DBsingle, 0);
2403 DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
2404 sv_setiv(DBtrace, 0);
2405 DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
2406 sv_setiv(DBsignal, 0);
2407 curstash = defstash;
2415 mainstack = curstack; /* remember in case we switch stacks */
2416 AvREAL_off(curstack); /* not a real array */
2417 av_extend(curstack,127);
2419 stack_base = AvARRAY(curstack);
2420 stack_sp = stack_base;
2421 stack_max = stack_base + 127;
2423 cxstack_max = 8192 / sizeof(CONTEXT) - 2; /* Use most of 8K. */
2424 New(50,cxstack,cxstack_max + 1,CONTEXT);
2427 New(50,tmps_stack,128,SV*);
2433 * The following stacks almost certainly should be per-interpreter,
2434 * but for now they're not. XXX
2438 markstack_ptr = markstack;
2440 New(54,markstack,64,I32);
2441 markstack_ptr = markstack;
2442 markstack_max = markstack + 64;
2448 New(54,scopestack,32,I32);
2450 scopestack_max = 32;
2456 New(54,savestack,128,ANY);
2458 savestack_max = 128;
2464 New(54,retstack,16,OP*);
2475 Safefree(tmps_stack);
2482 static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
2491 subname = newSVpv("main",4);
2495 init_predump_symbols()
2501 sv_setpvn(GvSV(gv_fetchpv("\"", TRUE, SVt_PV)), " ", 1);
2503 stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
2504 GvMULTI_on(stdingv);
2505 IoIFP(GvIOp(stdingv)) = PerlIO_stdin();
2506 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
2508 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(stdingv));
2510 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
2512 IoOFP(GvIOp(tmpgv)) = IoIFP(GvIOp(tmpgv)) = PerlIO_stdout();
2514 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
2516 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(defoutgv));
2518 othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
2519 GvMULTI_on(othergv);
2520 IoOFP(GvIOp(othergv)) = IoIFP(GvIOp(othergv)) = PerlIO_stderr();
2521 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
2523 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(othergv));
2525 statname = NEWSV(66,0); /* last filename we did stat on */
2528 osname = savepv(OSNAME);
2532 init_postdump_symbols(argc,argv,env)
2534 register char **argv;
2535 register char **env;
2541 argc--,argv++; /* skip name of script */
2543 for (; argc > 0 && **argv == '-'; argc--,argv++) {
2546 if (argv[0][1] == '-') {
2550 if (s = strchr(argv[0], '=')) {
2552 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
2555 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
2558 toptarget = NEWSV(0,0);
2559 sv_upgrade(toptarget, SVt_PVFM);
2560 sv_setpvn(toptarget, "", 0);
2561 bodytarget = NEWSV(0,0);
2562 sv_upgrade(bodytarget, SVt_PVFM);
2563 sv_setpvn(bodytarget, "", 0);
2564 formtarget = bodytarget;
2567 if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
2568 sv_setpv(GvSV(tmpgv),origfilename);
2569 magicname("0", "0", 1);
2571 if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
2572 sv_setpv(GvSV(tmpgv),origargv[0]);
2573 if (argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
2575 (void)gv_AVadd(argvgv);
2576 av_clear(GvAVn(argvgv));
2577 for (; argc > 0; argc--,argv++) {
2578 av_push(GvAVn(argvgv),newSVpv(argv[0],0));
2581 if (envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
2585 hv_magic(hv, envgv, 'E');
2586 #ifndef VMS /* VMS doesn't have environ array */
2587 /* Note that if the supplied env parameter is actually a copy
2588 of the global environ then it may now point to free'd memory
2589 if the environment has been modified since. To avoid this
2590 problem we treat env==NULL as meaning 'use the default'
2595 environ[0] = Nullch;
2596 for (; *env; env++) {
2597 if (!(s = strchr(*env,'=')))
2603 sv = newSVpv(s--,0);
2604 (void)hv_store(hv, *env, s - *env, sv, 0);
2606 #if defined(__BORLANDC__) && defined(USE_WIN32_RTL_ENV)
2607 /* Sins of the RTL. See note in my_setenv(). */
2608 (void)putenv(savepv(*env));
2612 #ifdef DYNAMIC_ENV_FETCH
2613 HvNAME(hv) = savepv(ENV_HV_NAME);
2617 if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
2618 sv_setiv(GvSV(tmpgv), (IV)getpid());
2627 s = getenv("PERL5LIB");
2631 incpush(getenv("PERLLIB"), FALSE);
2633 /* Treat PERL5?LIB as a possible search list logical name -- the
2634 * "natural" VMS idiom for a Unix path string. We allow each
2635 * element to be a set of |-separated directories for compatibility.
2639 if (my_trnlnm("PERL5LIB",buf,0))
2640 do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
2642 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE);
2646 /* Use the ~-expanded versions of APPLLIB (undocumented),
2647 ARCHLIB PRIVLIB SITEARCH SITELIB and OLDARCHLIB
2650 incpush(APPLLIB_EXP, FALSE);
2654 incpush(ARCHLIB_EXP, FALSE);
2657 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
2659 incpush(PRIVLIB_EXP, FALSE);
2662 incpush(SITEARCH_EXP, FALSE);
2665 incpush(SITELIB_EXP, FALSE);
2667 #ifdef OLDARCHLIB_EXP /* 5.00[01] compatibility */
2668 incpush(OLDARCHLIB_EXP, FALSE);
2672 incpush(".", FALSE);
2676 # define PERLLIB_SEP ';'
2679 # define PERLLIB_SEP '|'
2681 # define PERLLIB_SEP ':'
2684 #ifndef PERLLIB_MANGLE
2685 # define PERLLIB_MANGLE(s,n) (s)
2689 incpush(p, addsubdirs)
2693 SV *subdir = Nullsv;
2694 static char *archpat_auto;
2701 if (!archpat_auto) {
2702 STRLEN len = (sizeof(ARCHNAME) + strlen(patchlevel)
2703 + sizeof("//auto"));
2704 New(55, archpat_auto, len, char);
2705 sprintf(archpat_auto, "/%s/%s/auto", ARCHNAME, patchlevel);
2707 for (len = sizeof(ARCHNAME) + 2;
2708 archpat_auto[len] != '\0' && archpat_auto[len] != '/'; len++)
2709 if (archpat_auto[len] == '.') archpat_auto[len] = '_';
2714 /* Break at all separators */
2716 SV *libdir = newSV(0);
2719 /* skip any consecutive separators */
2720 while ( *p == PERLLIB_SEP ) {
2721 /* Uncomment the next line for PATH semantics */
2722 /* av_push(GvAVn(incgv), newSVpv(".", 1)); */
2726 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
2727 sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
2732 sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
2733 p = Nullch; /* break out */
2737 * BEFORE pushing libdir onto @INC we may first push version- and
2738 * archname-specific sub-directories.
2741 struct stat tmpstatbuf;
2746 if ((unix = tounixspec_ts(SvPV(libdir,na),Nullch)) != Nullch) {
2748 while (unix[len-1] == '/') len--; /* Cosmetic */
2749 sv_usepvn(libdir,unix,len);
2752 PerlIO_printf(PerlIO_stderr(),
2753 "Failed to unixify @INC element \"%s\"\n",
2756 /* .../archname/version if -d .../archname/version/auto */
2757 sv_setsv(subdir, libdir);
2758 sv_catpv(subdir, archpat_auto);
2759 if (Stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2760 S_ISDIR(tmpstatbuf.st_mode))
2761 av_push(GvAVn(incgv),
2762 newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2764 /* .../archname if -d .../archname/auto */
2765 sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME),
2766 strlen(patchlevel) + 1, "", 0);
2767 if (Stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2768 S_ISDIR(tmpstatbuf.st_mode))
2769 av_push(GvAVn(incgv),
2770 newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2773 /* finally push this lib directory on the end of @INC */
2774 av_push(GvAVn(incgv), libdir);
2777 SvREFCNT_dec(subdir);
2781 call_list(oldscope, list)
2786 line_t oldline = curcop->cop_line;
2791 while (AvFILL(list) >= 0) {
2792 CV *cv = (CV*)av_shift(list);
2799 SV* atsv = GvSV(errgv);
2801 perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
2802 (void)SvPV(atsv, len);
2805 curcop = &compiling;
2806 curcop->cop_line = oldline;
2807 if (list == beginav)
2808 sv_catpv(atsv, "BEGIN failed--compilation aborted");
2810 sv_catpv(atsv, "END failed--cleanup aborted");
2811 while (scopestack_ix > oldscope)
2813 croak("%s", SvPVX(atsv));
2821 /* my_exit() was called */
2822 while (scopestack_ix > oldscope)
2825 curstash = defstash;
2827 call_list(oldscope, endav);
2829 curcop = &compiling;
2830 curcop->cop_line = oldline;
2832 if (list == beginav)
2833 croak("BEGIN failed--compilation aborted");
2835 croak("END failed--cleanup aborted");
2841 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
2846 curcop = &compiling;
2847 curcop->cop_line = oldline;
2861 DEBUG_L(PerlIO_printf(Perl_debug_log, "my_exit: thread 0x%lx, status %lu\n",
2862 (unsigned long) thr, (unsigned long) status));
2863 #endif /* USE_THREADS */
2872 STATUS_NATIVE_SET(status);
2882 if (vaxc$errno & 1) {
2883 if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
2884 STATUS_NATIVE_SET(44);
2887 if (!vaxc$errno && errno) /* unlikely */
2888 STATUS_NATIVE_SET(44);
2890 STATUS_NATIVE_SET(vaxc$errno);
2894 STATUS_POSIX_SET(errno);
2895 else if (STATUS_POSIX == 0)
2896 STATUS_POSIX_SET(255);
2905 register CONTEXT *cx;
2914 (void)UNLINK(e_tmpname);
2915 Safefree(e_tmpname);
2919 if (cxstack_ix >= 0) {