3 * Copyright (c) 1987-1998 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> */
34 dEXTCONST char rcsid[] = "perl.c\nPatch level: ###\n";
42 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
52 curcop = &compiling; \
59 laststype = OP_STAT; \
61 maxsysfd = MAXSYSFD; \
68 laststype = OP_STAT; \
72 static void find_beginning _((void));
73 static void forbid_setid _((char *));
74 static void incpush _((char *, int));
75 static void init_ids _((void));
76 static void init_debugger _((void));
77 static void init_lexer _((void));
78 static void init_main_stash _((void));
80 static struct perl_thread * init_main_thread _((void));
81 #endif /* USE_THREADS */
82 static void init_perllib _((void));
83 static void init_postdump_symbols _((int, char **, char **));
84 static void init_predump_symbols _((void));
85 static void my_exit_jump _((void)) __attribute__((noreturn));
86 static void nuke_stacks _((void));
87 static void open_script _((char *, bool, SV *));
88 static void usage _((char *));
89 static void validate_suid _((char *, char*));
91 static int fdscript = -1;
96 PerlInterpreter *sv_interp;
99 New(53, sv_interp, 1, PerlInterpreter);
104 perl_construct(register PerlInterpreter *sv_interp)
109 struct perl_thread *thr;
110 #endif /* FAKE_THREADS */
111 #endif /* USE_THREADS */
113 if (!(curinterp = sv_interp))
117 Zero(sv_interp, 1, PerlInterpreter);
120 /* Init the real globals (and main thread)? */
125 #ifdef ALLOC_THREAD_KEY
128 if (pthread_key_create(&thr_key, 0))
129 croak("panic: pthread_key_create");
131 MUTEX_INIT(&sv_mutex);
133 * Safe to use basic SV functions from now on (though
134 * not things like mortals or tainting yet).
136 MUTEX_INIT(&eval_mutex);
137 COND_INIT(&eval_cond);
138 MUTEX_INIT(&threads_mutex);
139 COND_INIT(&nthreads_cond);
140 #ifdef EMULATE_ATOMIC_REFCOUNTS
141 MUTEX_INIT(&svref_mutex);
142 #endif /* EMULATE_ATOMIC_REFCOUNTS */
144 thr = init_main_thread();
145 #endif /* USE_THREADS */
147 linestr = NEWSV(65,80);
148 sv_upgrade(linestr,SVt_PVIV);
150 if (!SvREADONLY(&sv_undef)) {
151 SvREADONLY_on(&sv_undef);
155 SvREADONLY_on(&sv_no);
157 sv_setpv(&sv_yes,Yes);
159 SvREADONLY_on(&sv_yes);
162 nrs = newSVpv("\n", 1);
163 rs = SvREFCNT_inc(nrs);
165 sighandlerp = sighandler;
170 * There is no way we can refer to them from Perl so close them to save
171 * space. The other alternative would be to provide STDAUX and STDPRN
174 (void)fclose(stdaux);
175 (void)fclose(stdprn);
182 perl_destruct_level = 1;
184 if(perl_destruct_level > 0)
189 lex_state = LEX_NOTPARSING;
191 start_env.je_prev = NULL;
192 start_env.je_ret = -1;
193 start_env.je_mustcatch = TRUE;
194 top_env = &start_env;
197 SET_NUMERIC_STANDARD();
198 #if defined(SUBVERSION) && SUBVERSION > 0
199 sprintf(patchlevel, "%7.5f", (double) 5
200 + ((double) PATCHLEVEL / (double) 1000)
201 + ((double) SUBVERSION / (double) 100000));
203 sprintf(patchlevel, "%5.3f", (double) 5 +
204 ((double) PATCHLEVEL / (double) 1000));
207 #if defined(LOCAL_PATCH_COUNT)
208 localpatches = local_patches; /* For possible -v */
211 PerlIO_init(); /* Hook to IO system */
213 fdpid = newAV(); /* for remembering popen pids by fd */
216 New(51,debname,128,char);
217 New(52,debdelim,128,char);
224 perl_destruct(register PerlInterpreter *sv_interp)
227 int destruct_level; /* 0=none, 1=full, 2=full with checks */
232 #endif /* USE_THREADS */
234 if (!(curinterp = sv_interp))
239 /* Pass 1 on any remaining threads: detach joinables, join zombies */
241 MUTEX_LOCK(&threads_mutex);
242 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
243 "perl_destruct: waiting for %d threads...\n",
245 for (t = thr->next; t != thr; t = t->next) {
246 MUTEX_LOCK(&t->mutex);
247 switch (ThrSTATE(t)) {
250 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
251 "perl_destruct: joining zombie %p\n", t));
252 ThrSETSTATE(t, THRf_DEAD);
253 MUTEX_UNLOCK(&t->mutex);
256 * The SvREFCNT_dec below may take a long time (e.g. av
257 * may contain an object scalar whose destructor gets
258 * called) so we have to unlock threads_mutex and start
261 MUTEX_UNLOCK(&threads_mutex);
263 SvREFCNT_dec((SV*)av);
264 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
265 "perl_destruct: joined zombie %p OK\n", t));
267 case THRf_R_JOINABLE:
268 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
269 "perl_destruct: detaching thread %p\n", t));
270 ThrSETSTATE(t, THRf_R_DETACHED);
272 * We unlock threads_mutex and t->mutex in the opposite order
273 * from which we locked them just so that DETACH won't
274 * deadlock if it panics. It's only a breach of good style
275 * not a bug since they are unlocks not locks.
277 MUTEX_UNLOCK(&threads_mutex);
279 MUTEX_UNLOCK(&t->mutex);
282 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
283 "perl_destruct: ignoring %p (state %u)\n",
285 MUTEX_UNLOCK(&t->mutex);
286 /* fall through and out */
289 /* We leave the above "Pass 1" loop with threads_mutex still locked */
291 /* Pass 2 on remaining threads: wait for the thread count to drop to one */
294 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
295 "perl_destruct: final wait for %d threads\n",
297 COND_WAIT(&nthreads_cond, &threads_mutex);
299 /* At this point, we're the last thread */
300 MUTEX_UNLOCK(&threads_mutex);
301 DEBUG_L(PerlIO_printf(PerlIO_stderr(), "perl_destruct: armageddon has arrived\n"));
302 MUTEX_DESTROY(&threads_mutex);
303 COND_DESTROY(&nthreads_cond);
304 #endif /* !defined(FAKE_THREADS) */
305 #endif /* USE_THREADS */
307 destruct_level = perl_destruct_level;
311 if (s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL")) {
313 if (destruct_level < i)
322 /* We must account for everything. */
324 /* Destroy the main CV and syntax tree */
326 curpad = AvARRAY(comppad);
331 SvREFCNT_dec(main_cv);
336 * Try to destruct global references. We do this first so that the
337 * destructors and destructees still exist. Some sv's might remain.
338 * Non-referenced objects are on their own.
345 /* unhook hooks which will soon be, or use, destroyed data */
346 SvREFCNT_dec(warnhook);
348 SvREFCNT_dec(diehook);
350 SvREFCNT_dec(parsehook);
353 if (destruct_level == 0){
355 DEBUG_P(debprofdump());
357 /* The exit() function will do everything that needs doing. */
361 /* loosen bonds of global variables */
364 (void)PerlIO_close(rsfp);
368 /* Filters for program text */
369 SvREFCNT_dec(rsfp_filters);
370 rsfp_filters = Nullav;
382 sawampersand = FALSE; /* must save all match strings */
383 sawstudy = FALSE; /* do fbm_instr on all strings */
398 /* magical thingies */
400 Safefree(ofs); /* $, */
403 Safefree(ors); /* $\ */
406 SvREFCNT_dec(nrs); /* $\ helper */
409 multiline = 0; /* $* */
411 SvREFCNT_dec(statname);
415 /* defgv, aka *_ should be taken care of elsewhere */
417 /* clean up after study() */
418 SvREFCNT_dec(lastscream);
420 Safefree(screamfirst);
422 Safefree(screamnext);
425 /* startup and shutdown function lists */
426 SvREFCNT_dec(beginav);
428 SvREFCNT_dec(initav);
433 /* shortcuts just get cleared */
443 /* reset so print() ends up where we expect */
446 /* Prepare to destruct main symbol table. */
453 if (destruct_level >= 2) {
454 if (scopestack_ix != 0)
455 warn("Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
456 (long)scopestack_ix);
457 if (savestack_ix != 0)
458 warn("Unbalanced saves: %ld more saves than restores\n",
460 if (tmps_floor != -1)
461 warn("Unbalanced tmps: %ld more allocs than frees\n",
462 (long)tmps_floor + 1);
463 if (cxstack_ix != -1)
464 warn("Unbalanced context: %ld more PUSHes than POPs\n",
465 (long)cxstack_ix + 1);
468 /* Now absolutely destruct everything, somehow or other, loops or no. */
470 SvFLAGS(strtab) |= SVTYPEMASK; /* don't clean out strtab now */
471 while (sv_count != 0 && sv_count != last_sv_count) {
472 last_sv_count = sv_count;
475 SvFLAGS(strtab) &= ~SVTYPEMASK;
476 SvFLAGS(strtab) |= SVt_PVHV;
478 /* Destruct the global string table. */
480 /* Yell and reset the HeVAL() slots that are still holding refcounts,
481 * so that sv_free() won't fail on them.
490 array = HvARRAY(strtab);
494 warn("Unbalanced string table refcount: (%d) for \"%s\"",
495 HeVAL(hent) - Nullsv, HeKEY(hent));
496 HeVAL(hent) = &sv_undef;
506 SvREFCNT_dec(strtab);
509 warn("Scalars leaked: %ld\n", (long)sv_count);
513 /* No SVs have survived, need to clean out */
517 Safefree(origfilename);
519 hints = 0; /* Reset hints. Should hints be per-interpreter ? */
521 DEBUG_P(debprofdump());
523 MUTEX_DESTROY(&sv_mutex);
524 MUTEX_DESTROY(&eval_mutex);
525 COND_DESTROY(&eval_cond);
527 /* As the penultimate thing, free the non-arena SV for thrsv */
528 Safefree(SvPVX(thrsv));
529 Safefree(SvANY(thrsv));
532 #endif /* USE_THREADS */
534 /* As the absolutely last thing, free the non-arena SV for mess() */
537 /* we know that type >= SVt_PV */
539 Safefree(SvPVX(mess_sv));
540 Safefree(SvANY(mess_sv));
547 perl_free(PerlInterpreter *sv_interp)
549 if (!(curinterp = sv_interp))
555 perl_parse(PerlInterpreter *sv_interp, void (*xsinit) (void), int argc, char **argv, char **env)
560 char *scriptname = NULL;
561 VOL bool dosearch = FALSE;
569 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
572 croak("suidperl is no longer needed since the kernel can now execute\n\
573 setuid perl scripts securely.\n");
577 if (!(curinterp = sv_interp))
580 #if defined(NeXT) && defined(__DYNAMIC__)
581 _dyld_lookup_and_bind
582 ("__environ", (unsigned long *) &environ_pointer, NULL);
587 #ifndef VMS /* VMS doesn't have environ array */
588 origenviron = environ;
594 /* Come here if running an undumped a.out. */
596 origfilename = savepv(argv[0]);
598 cxstack_ix = -1; /* start label stack again */
600 init_postdump_symbols(argc,argv,env);
605 curpad = AvARRAY(comppad);
610 SvREFCNT_dec(main_cv);
614 oldscope = scopestack_ix;
622 /* my_exit() was called */
623 while (scopestack_ix > oldscope)
628 call_list(oldscope, endav);
630 return STATUS_NATIVE_EXPORT;
633 PerlIO_printf(PerlIO_stderr(), "panic: top_env\n");
637 sv_setpvn(linestr,"",0);
638 sv = newSVpv("",0); /* first used for -I flags */
642 for (argc--,argv++; argc > 0; argc--,argv++) {
643 if (argv[0][0] != '-' || !argv[0][1])
647 validarg = " PHOOEY ";
672 if (s = moreswitches(s))
682 if (euid != uid || egid != gid)
683 croak("No -e allowed in setuid scripts");
686 int oldumask = PerlLIO_umask(0177);
688 e_tmpname = savepv(TMPPATH);
690 e_tmpfd = PerlLIO_mkstemp(e_tmpname);
691 #else /* use mktemp() */
692 (void)PerlLIO_mktemp(e_tmpname);
694 croak("Cannot generate temporary filename");
695 # if defined(HAS_OPEN3) && defined(O_EXCL)
696 e_tmpfd = open(e_tmpname,
697 O_WRONLY | O_CREAT | O_EXCL,
700 (void)UNLINK(e_tmpname);
701 /* Yes, potential race. But at least we can say we tried. */
702 e_fp = PerlIO_open(e_tmpname,"w");
704 #endif /* ifdef HAS_MKSTEMP */
705 #if defined(HAS_MKSTEMP) || (defined(HAS_OPEN3) && defined(O_EXCL))
707 croak("Cannot create temporary file \"%s\"", e_tmpname);
708 e_fp = PerlIO_fdopen(e_tmpfd,"w");
711 croak("Cannot create temporary file \"%s\"", e_tmpname);
713 (void)PerlLIO_umask(oldumask);
719 PerlIO_puts(e_fp,argv[1]);
723 croak("No code specified for -e");
724 (void)PerlIO_putc(e_fp,'\n');
726 case 'I': /* -I handled both here and in moreswitches() */
728 if (!*++s && (s=argv[1]) != Nullch) {
731 while (s && isSPACE(*s))
735 for (e = s; *e && !isSPACE(*e); e++) ;
742 } /* XXX else croak? */
756 preambleav = newAV();
757 av_push(preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
759 Sv = newSVpv("print myconfig();",0);
761 sv_catpv(Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
763 sv_catpv(Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
765 #if defined(DEBUGGING) || defined(NO_EMBED) || defined(MULTIPLICITY)
766 sv_catpv(Sv,"\" Compile-time options:");
768 sv_catpv(Sv," DEBUGGING");
771 sv_catpv(Sv," NO_EMBED");
774 sv_catpv(Sv," MULTIPLICITY");
776 sv_catpv(Sv,"\\n\",");
778 #if defined(LOCAL_PATCH_COUNT)
779 if (LOCAL_PATCH_COUNT > 0) {
781 sv_catpv(Sv,"\" Locally applied patches:\\n\",");
782 for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
784 sv_catpvf(Sv,"\" \\t%s\\n\",",localpatches[i]);
788 sv_catpvf(Sv,"\" Built under %s\\n\"",OSNAME);
791 sv_catpvf(Sv,",\" Compiled at %s %s\\n\"",__DATE__,__TIME__);
793 sv_catpvf(Sv,",\" Compiled on %s\\n\"",__DATE__);
798 @env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; \
799 print \" \\%ENV:\\n @env\\n\" if @env; \
800 print \" \\@INC:\\n @INC\\n\";");
803 Sv = newSVpv("config_vars(qw(",0);
808 av_push(preambleav, Sv);
809 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
820 if (!*++s || isSPACE(*s)) {
824 /* catch use of gnu style long options */
825 if (strEQ(s, "version")) {
829 if (strEQ(s, "help")) {
836 croak("Unrecognized switch: -%s (-h will show valid options)",s);
841 if (!tainting && (s = PerlEnv_getenv("PERL5OPT"))) {
852 if (!strchr("DIMUdmw", *s))
853 croak("Illegal switch in PERL5OPT: -%c", *s);
859 scriptname = argv[0];
861 if (PerlIO_flush(e_fp) || PerlIO_error(e_fp) || PerlIO_close(e_fp)) {
863 warn("Did you forget to compile with -DMULTIPLICITY?");
865 croak("Can't write to temp file for -e: %s", Strerror(errno));
869 scriptname = e_tmpname;
871 else if (scriptname == Nullch) {
873 if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) )
881 open_script(scriptname,dosearch,sv);
883 validate_suid(validarg, scriptname);
888 main_cv = compcv = (CV*)NEWSV(1104,0);
889 sv_upgrade((SV *)compcv, SVt_PVCV);
893 av_push(comppad, Nullsv);
894 curpad = AvARRAY(comppad);
895 comppad_name = newAV();
896 comppad_name_fill = 0;
897 min_intro_pending = 0;
900 av_store(comppad_name, 0, newSVpv("@_", 2));
901 curpad[0] = (SV*)newAV();
902 SvPADMY_on(curpad[0]); /* XXX Needed? */
904 New(666, CvMUTEXP(compcv), 1, perl_mutex);
905 MUTEX_INIT(CvMUTEXP(compcv));
906 #endif /* USE_THREADS */
908 comppadlist = newAV();
909 AvREAL_off(comppadlist);
910 av_store(comppadlist, 0, (SV*)comppad_name);
911 av_store(comppadlist, 1, (SV*)comppad);
912 CvPADLIST(compcv) = comppadlist;
914 boot_core_UNIVERSAL();
916 (*xsinit)(); /* in case linked C routines want magical variables */
917 #if defined(VMS) || defined(WIN32) || defined(DJGPP)
921 init_predump_symbols();
923 init_postdump_symbols(argc,argv,env);
927 /* now parse the script */
929 SETERRNO(0,SS$_NORMAL);
931 if (yyparse() || error_count) {
933 croak("%s had compilation errors.\n", origfilename);
935 croak("Execution of %s aborted due to compilation errors.\n",
939 curcop->cop_line = 0;
943 (void)UNLINK(e_tmpname);
949 /* now that script is parsed, we can modify record separator */
951 rs = SvREFCNT_inc(nrs);
952 sv_setsv(perl_get_sv("/", TRUE), rs);
963 if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
964 dump_mstats("after compilation:");
974 perl_run(PerlInterpreter *sv_interp)
981 if (!(curinterp = sv_interp))
984 oldscope = scopestack_ix;
989 cxstack_ix = -1; /* start context stack again */
992 /* my_exit() was called */
993 while (scopestack_ix > oldscope)
998 call_list(oldscope, endav);
1000 if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
1001 dump_mstats("after execution: ");
1004 return STATUS_NATIVE_EXPORT;
1007 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
1012 POPSTACK_TO(mainstack);
1016 DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
1017 sawampersand ? "Enabling" : "Omitting"));
1020 DEBUG_x(dump_all());
1021 DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
1023 DEBUG_L(PerlIO_printf(Perl_debug_log, "main thread is 0x%lx\n",
1024 (unsigned long) thr));
1025 #endif /* USE_THREADS */
1028 PerlIO_printf(PerlIO_stderr(), "%s syntax OK\n", origfilename);
1031 if (PERLDB_SINGLE && DBsingle)
1032 sv_setiv(DBsingle, 1);
1034 call_list(oldscope, initav);
1044 else if (main_start) {
1045 CvDEPTH(main_cv) = 1;
1056 perl_get_sv(char *name, I32 create)
1060 if (name[1] == '\0' && !isALPHA(name[0])) {
1061 PADOFFSET tmp = find_threadsv(name);
1062 if (tmp != NOT_IN_PAD) {
1064 return THREADSV(tmp);
1067 #endif /* USE_THREADS */
1068 gv = gv_fetchpv(name, create, SVt_PV);
1075 perl_get_av(char *name, I32 create)
1077 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
1086 perl_get_hv(char *name, I32 create)
1088 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
1097 perl_get_cv(char *name, I32 create)
1099 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
1100 if (create && !GvCVu(gv))
1101 return newSUB(start_subparse(FALSE, 0),
1102 newSVOP(OP_CONST, 0, newSVpv(name,0)),
1110 /* Be sure to refetch the stack pointer after calling these routines. */
1113 perl_call_argv(char *sub_name, I32 flags, register char **argv)
1115 /* See G_* flags in cop.h */
1116 /* null terminated arg list */
1123 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
1128 return perl_call_pv(sub_name, flags);
1132 perl_call_pv(char *sub_name, I32 flags)
1133 /* name of the subroutine */
1134 /* See G_* flags in cop.h */
1136 return perl_call_sv((SV*)perl_get_cv(sub_name, TRUE), flags);
1140 perl_call_method(char *methname, I32 flags)
1141 /* name of the subroutine */
1142 /* See G_* flags in cop.h */
1148 XPUSHs(sv_2mortal(newSVpv(methname,0)));
1151 return perl_call_sv(*stack_sp--, flags);
1154 /* May be called with any of a CV, a GV, or an SV containing the name. */
1156 perl_call_sv(SV *sv, I32 flags)
1158 /* See G_* flags in cop.h */
1161 LOGOP myop; /* fake syntax tree node */
1166 bool oldcatch = CATCH_GET;
1171 if (flags & G_DISCARD) {
1176 Zero(&myop, 1, LOGOP);
1177 myop.op_next = Nullop;
1178 if (!(flags & G_NOARGS))
1179 myop.op_flags |= OPf_STACKED;
1180 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1181 (flags & G_ARRAY) ? OPf_WANT_LIST :
1186 EXTEND(stack_sp, 1);
1189 oldscope = scopestack_ix;
1191 if (PERLDB_SUB && curstash != debstash
1192 /* Handle first BEGIN of -d. */
1193 && (DBcv || (DBcv = GvCV(DBsub)))
1194 /* Try harder, since this may have been a sighandler, thus
1195 * curstash may be meaningless. */
1196 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != debstash))
1197 op->op_private |= OPpENTERSUB_DB;
1199 if (flags & G_EVAL) {
1200 cLOGOP->op_other = op;
1202 /* we're trying to emulate pp_entertry() here */
1204 register PERL_CONTEXT *cx;
1205 I32 gimme = GIMME_V;
1210 push_return(op->op_next);
1211 PUSHBLOCK(cx, CXt_EVAL, stack_sp);
1213 eval_root = op; /* Only needed so that goto works right. */
1216 if (flags & G_KEEPERR)
1231 /* my_exit() was called */
1232 curstash = defstash;
1236 croak("Callback called exit");
1245 stack_sp = stack_base + oldmark;
1246 if (flags & G_ARRAY)
1250 *++stack_sp = &sv_undef;
1258 if (op == (OP*)&myop)
1259 op = pp_entersub(ARGS);
1262 retval = stack_sp - (stack_base + oldmark);
1263 if ((flags & G_EVAL) && !(flags & G_KEEPERR))
1267 if (flags & G_EVAL) {
1268 if (scopestack_ix > oldscope) {
1272 register PERL_CONTEXT *cx;
1284 CATCH_SET(oldcatch);
1286 if (flags & G_DISCARD) {
1287 stack_sp = stack_base + oldmark;
1296 /* Eval a string. The G_EVAL flag is always assumed. */
1299 perl_eval_sv(SV *sv, I32 flags)
1301 /* See G_* flags in cop.h */
1304 UNOP myop; /* fake syntax tree node */
1305 I32 oldmark = SP - stack_base;
1312 if (flags & G_DISCARD) {
1320 EXTEND(stack_sp, 1);
1322 oldscope = scopestack_ix;
1324 if (!(flags & G_NOARGS))
1325 myop.op_flags = OPf_STACKED;
1326 myop.op_next = Nullop;
1327 myop.op_type = OP_ENTEREVAL;
1328 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1329 (flags & G_ARRAY) ? OPf_WANT_LIST :
1331 if (flags & G_KEEPERR)
1332 myop.op_flags |= OPf_SPECIAL;
1342 /* my_exit() was called */
1343 curstash = defstash;
1347 croak("Callback called exit");
1356 stack_sp = stack_base + oldmark;
1357 if (flags & G_ARRAY)
1361 *++stack_sp = &sv_undef;
1366 if (op == (OP*)&myop)
1367 op = pp_entereval(ARGS);
1370 retval = stack_sp - (stack_base + oldmark);
1371 if (!(flags & G_KEEPERR))
1376 if (flags & G_DISCARD) {
1377 stack_sp = stack_base + oldmark;
1387 perl_eval_pv(char *p, I32 croak_on_error)
1390 SV* sv = newSVpv(p, 0);
1393 perl_eval_sv(sv, G_SCALAR);
1400 if (croak_on_error && SvTRUE(ERRSV))
1401 croak(SvPVx(ERRSV, na));
1406 /* Require a module. */
1409 perl_require_pv(char *pv)
1411 SV* sv = sv_newmortal();
1412 sv_setpv(sv, "require '");
1415 perl_eval_sv(sv, G_DISCARD);
1419 magicname(char *sym, char *name, I32 namlen)
1423 if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
1424 sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
1428 usage(char *name) /* XXX move this out into a module ? */
1431 /* This message really ought to be max 23 lines.
1432 * Removed -h because the user already knows that opton. Others? */
1434 static char *usage[] = {
1435 "-0[octal] specify record separator (\\0, if no argument)",
1436 "-a autosplit mode with -n or -p (splits $_ into @F)",
1437 "-c check syntax only (runs BEGIN and END blocks)",
1438 "-d[:debugger] run scripts under debugger",
1439 "-D[number/list] set debugging flags (argument is a bit mask or flags)",
1440 "-e 'command' one line of script. Several -e's allowed. Omit [programfile].",
1441 "-F/pattern/ split() pattern for autosplit (-a). The //'s are optional.",
1442 "-i[extension] edit <> files in place (make backup if extension supplied)",
1443 "-Idirectory specify @INC/#include directory (may be used more than once)",
1444 "-l[octal] enable line ending processing, specifies line terminator",
1445 "-[mM][-]module.. executes `use/no module...' before executing your script.",
1446 "-n assume 'while (<>) { ... }' loop around your script",
1447 "-p assume loop like -n but print line also like sed",
1448 "-P run script through C preprocessor before compilation",
1449 "-s enable some switch parsing for switches after script name",
1450 "-S look for the script using PATH environment variable",
1451 "-T turn on tainting checks",
1452 "-u dump core after parsing script",
1453 "-U allow unsafe operations",
1454 "-v print version number and patchlevel of perl",
1455 "-V[:variable] print perl configuration information",
1456 "-w TURN WARNINGS ON FOR COMPILATION OF YOUR SCRIPT. Recommended.",
1457 "-x[directory] strip off text before #!perl line and perhaps cd to directory",
1463 printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
1465 printf("\n %s", *p++);
1468 /* This routine handles any switches that can be given during run */
1471 moreswitches(char *s)
1480 rschar = scan_oct(s, 4, &numlen);
1482 if (rschar & ~((U8)~0))
1484 else if (!rschar && numlen >= 2)
1485 nrs = newSVpv("", 0);
1488 nrs = newSVpv(&ch, 1);
1494 splitstr = savepv(s + 1);
1508 if (*s == ':' || *s == '=') {
1509 my_setenv("PERL5DB", form("use Devel::%s;", ++s));
1513 perldb = PERLDB_ALL;
1520 if (isALPHA(s[1])) {
1521 static char debopts[] = "psltocPmfrxuLHXD";
1524 for (s++; *s && (d = strchr(debopts,*s)); s++)
1525 debug |= 1 << (d - debopts);
1529 for (s++; isDIGIT(*s); s++) ;
1531 debug |= 0x80000000;
1533 warn("Recompile perl with -DDEBUGGING to use -D switch\n");
1534 for (s++; isALNUM(*s); s++) ;
1544 inplace = savepv(s+1);
1546 for (s = inplace; *s && !isSPACE(*s); s++) ;
1550 case 'I': /* -I handled both here and in parse_perl() */
1553 while (*s && isSPACE(*s))
1557 for (e = s; *e && !isSPACE(*e); e++) ;
1558 p = savepvn(s, e-s);
1564 croak("No space allowed after -I");
1574 *ors = scan_oct(s, 3 + (*s == '0'), &numlen);
1584 ors = SvPV(nrs, orslen);
1585 ors = savepvn(ors, orslen);
1589 forbid_setid("-M"); /* XXX ? */
1592 forbid_setid("-m"); /* XXX ? */
1597 /* -M-foo == 'no foo' */
1598 if (*s == '-') { use = "no "; ++s; }
1599 sv = newSVpv(use,0);
1601 /* We allow -M'Module qw(Foo Bar)' */
1602 while(isALNUM(*s) || *s==':') ++s;
1604 sv_catpv(sv, start);
1605 if (*(start-1) == 'm') {
1607 croak("Can't use '%c' after -mname", *s);
1608 sv_catpv( sv, " ()");
1611 sv_catpvn(sv, start, s-start);
1612 sv_catpv(sv, " split(/,/,q{");
1617 if (preambleav == NULL)
1618 preambleav = newAV();
1619 av_push(preambleav, sv);
1622 croak("No space allowed after -%c", *(s-1));
1639 croak("Too late for \"-T\" option");
1651 #if defined(SUBVERSION) && SUBVERSION > 0
1652 printf("\nThis is perl, version 5.%03d_%02d built for %s",
1653 PATCHLEVEL, SUBVERSION, ARCHNAME);
1655 printf("\nThis is perl, version %s built for %s",
1656 patchlevel, ARCHNAME);
1658 #if defined(LOCAL_PATCH_COUNT)
1659 if (LOCAL_PATCH_COUNT > 0)
1660 printf("\n(with %d registered patch%s, see perl -V for more detail)",
1661 LOCAL_PATCH_COUNT, (LOCAL_PATCH_COUNT!=1) ? "es" : "");
1664 printf("\n\nCopyright 1987-1998, Larry Wall\n");
1666 printf("\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
1669 printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n");
1670 printf("djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1998\n");
1673 printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
1674 "Version 5 port Copyright (c) 1994-1998, Andreas Kaiser, Ilya Zakharevich\n");
1677 printf("atariST series port, ++jrb bammi@cadence.com\n");
1680 Perl may be copied only under the terms of either the Artistic License or the\n\
1681 GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n");
1689 if (s[1] == '-') /* Additional switches on #! line. */
1700 #ifdef ALTERNATE_SHEBANG
1701 case 'S': /* OS/2 needs -S on "extproc" line. */
1709 croak("Can't emulate -%.1s on #! line",s);
1714 /* compliments of Tom Christiansen */
1716 /* unexec() can be found in the Gnu emacs distribution */
1727 prog = newSVpv(BIN_EXP);
1728 sv_catpv(prog, "/perl");
1729 file = newSVpv(origfilename);
1730 sv_catpv(file, ".perldump");
1732 status = unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
1734 PerlIO_printf(PerlIO_stderr(), "unexec of %s into %s failed!\n",
1735 SvPVX(prog), SvPVX(file));
1736 PerlProc_exit(status);
1739 # include <lib$routines.h>
1740 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
1742 ABORT(); /* for use with undump */
1748 init_main_stash(void)
1753 /* Note that strtab is a rather special HV. Assumptions are made
1754 about not iterating on it, and not adding tie magic to it.
1755 It is properly deallocated in perl_destruct() */
1757 HvSHAREKEYS_off(strtab); /* mandatory */
1758 Newz(506,((XPVHV*)SvANY(strtab))->xhv_array,
1759 sizeof(HE*) * (((XPVHV*)SvANY(strtab))->xhv_max + 1), char);
1761 curstash = defstash = newHV();
1762 curstname = newSVpv("main",4);
1763 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
1764 SvREFCNT_dec(GvHV(gv));
1765 GvHV(gv) = (HV*)SvREFCNT_inc(defstash);
1767 HvNAME(defstash) = savepv("main");
1768 incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
1770 defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
1771 errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
1773 (void)form("%240s",""); /* Preallocate temp - for immediate signals. */
1774 sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */
1775 sv_setpvn(ERRSV, "", 0);
1776 curstash = defstash;
1777 compiling.cop_stash = defstash;
1778 debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
1779 globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
1780 /* We must init $/ before switches are processed. */
1781 sv_setpvn(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), "\n", 1);
1785 open_script(char *scriptname, bool dosearch, SV *sv)
1788 char *xfound = Nullch;
1789 char *xfailed = Nullch;
1793 #if defined(DOSISH) && !defined(OS2) && !defined(atarist)
1794 # define SEARCH_EXTS ".bat", ".cmd", NULL
1795 # define MAX_EXT_LEN 4
1798 # define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL
1799 # define MAX_EXT_LEN 4
1802 # define SEARCH_EXTS ".pl", ".com", NULL
1803 # define MAX_EXT_LEN 4
1805 /* additional extensions to try in each dir if scriptname not found */
1807 char *ext[] = { SEARCH_EXTS };
1808 int extidx = 0, i = 0;
1809 char *curext = Nullch;
1811 # define MAX_EXT_LEN 0
1815 * If dosearch is true and if scriptname does not contain path
1816 * delimiters, search the PATH for scriptname.
1818 * If SEARCH_EXTS is also defined, will look for each
1819 * scriptname{SEARCH_EXTS} whenever scriptname is not found
1820 * while searching the PATH.
1822 * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
1823 * proceeds as follows:
1824 * If DOSISH or VMSISH:
1825 * + look for ./scriptname{,.foo,.bar}
1826 * + search the PATH for scriptname{,.foo,.bar}
1829 * + look *only* in the PATH for scriptname{,.foo,.bar} (note
1830 * this will not look in '.' if it's not in the PATH)
1834 # ifdef ALWAYS_DEFTYPES
1835 len = strlen(scriptname);
1836 if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') {
1837 int hasdir, idx = 0, deftypes = 1;
1840 hasdir = !dosearch || (strpbrk(scriptname,":[</") != Nullch) ;
1843 int hasdir, idx = 0, deftypes = 1;
1846 hasdir = (strpbrk(scriptname,":[</") != Nullch) ;
1848 /* The first time through, just add SEARCH_EXTS to whatever we
1849 * already have, so we can check for default file types. */
1851 (!hasdir && my_trnlnm("DCL$PATH",tokenbuf,idx++)) )
1857 if ((strlen(tokenbuf) + strlen(scriptname)
1858 + MAX_EXT_LEN) >= sizeof tokenbuf)
1859 continue; /* don't search dir with too-long name */
1860 strcat(tokenbuf, scriptname);
1864 if (strEQ(scriptname, "-"))
1866 if (dosearch) { /* Look in '.' first. */
1867 char *cur = scriptname;
1869 if ((curext = strrchr(scriptname,'.'))) /* possible current ext */
1871 if (strEQ(ext[i++],curext)) {
1872 extidx = -1; /* already has an ext */
1877 DEBUG_p(PerlIO_printf(Perl_debug_log,
1878 "Looking for %s\n",cur));
1879 if (PerlLIO_stat(cur,&statbuf) >= 0) {
1887 if (cur == scriptname) {
1888 len = strlen(scriptname);
1889 if (len+MAX_EXT_LEN+1 >= sizeof(tokenbuf))
1891 cur = strcpy(tokenbuf, scriptname);
1893 } while (extidx >= 0 && ext[extidx] /* try an extension? */
1894 && strcpy(tokenbuf+len, ext[extidx++]));
1899 if (dosearch && !strchr(scriptname, '/')
1901 && !strchr(scriptname, '\\')
1903 && (s = PerlEnv_getenv("PATH"))) {
1906 bufend = s + strlen(s);
1907 while (s < bufend) {
1908 #if defined(atarist) || defined(DOSISH)
1913 && *s != ';'; len++, s++) {
1914 if (len < sizeof tokenbuf)
1917 if (len < sizeof tokenbuf)
1918 tokenbuf[len] = '\0';
1919 #else /* ! (atarist || DOSISH) */
1920 s = delimcpy(tokenbuf, tokenbuf + sizeof tokenbuf, s, bufend,
1923 #endif /* ! (atarist || DOSISH) */
1926 if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tokenbuf)
1927 continue; /* don't search dir with too-long name */
1929 #if defined(atarist) || defined(DOSISH)
1930 && tokenbuf[len - 1] != '/'
1931 && tokenbuf[len - 1] != '\\'
1934 tokenbuf[len++] = '/';
1935 if (len == 2 && tokenbuf[0] == '.')
1937 (void)strcpy(tokenbuf + len, scriptname);
1941 len = strlen(tokenbuf);
1942 if (extidx > 0) /* reset after previous loop */
1946 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tokenbuf));
1947 retval = PerlLIO_stat(tokenbuf,&statbuf);
1949 } while ( retval < 0 /* not there */
1950 && extidx>=0 && ext[extidx] /* try an extension? */
1951 && strcpy(tokenbuf+len, ext[extidx++])
1956 if (S_ISREG(statbuf.st_mode)
1957 && cando(S_IRUSR,TRUE,&statbuf)
1959 && cando(S_IXUSR,TRUE,&statbuf)
1963 xfound = tokenbuf; /* bingo! */
1967 xfailed = savepv(tokenbuf);
1970 if (!xfound && !seen_dot && !xfailed && (PerlLIO_stat(scriptname,&statbuf) < 0))
1972 seen_dot = 1; /* Disable message. */
1974 croak("Can't %s %s%s%s",
1975 (xfailed ? "execute" : "find"),
1976 (xfailed ? xfailed : scriptname),
1977 (xfailed ? "" : " on PATH"),
1978 (xfailed || seen_dot) ? "" : ", '.' not in PATH");
1981 scriptname = xfound;
1984 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
1985 char *s = scriptname + 8;
1994 origfilename = savepv(e_tmpname ? "-e" : scriptname);
1995 curcop->cop_filegv = gv_fetchfile(origfilename);
1996 if (strEQ(origfilename,"-"))
1998 if (fdscript >= 0) {
1999 rsfp = PerlIO_fdopen(fdscript,PERL_SCRIPT_MODE);
2000 #if defined(HAS_FCNTL) && defined(F_SETFD)
2002 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
2005 else if (preprocess) {
2006 char *cpp_cfg = CPPSTDIN;
2007 SV *cpp = NEWSV(0,0);
2008 SV *cmd = NEWSV(0,0);
2010 if (strEQ(cpp_cfg, "cppstdin"))
2011 sv_catpvf(cpp, "%s/", BIN_EXP);
2012 sv_catpv(cpp, cpp_cfg);
2015 sv_catpv(sv,PRIVLIB_EXP);
2019 sed %s -e \"/^[^#]/b\" \
2020 -e \"/^#[ ]*include[ ]/b\" \
2021 -e \"/^#[ ]*define[ ]/b\" \
2022 -e \"/^#[ ]*if[ ]/b\" \
2023 -e \"/^#[ ]*ifdef[ ]/b\" \
2024 -e \"/^#[ ]*ifndef[ ]/b\" \
2025 -e \"/^#[ ]*else/b\" \
2026 -e \"/^#[ ]*elif[ ]/b\" \
2027 -e \"/^#[ ]*undef[ ]/b\" \
2028 -e \"/^#[ ]*endif/b\" \
2031 (doextract ? "-e \"1,/^#/d\n\"" : ""),
2034 %s %s -e '/^[^#]/b' \
2035 -e '/^#[ ]*include[ ]/b' \
2036 -e '/^#[ ]*define[ ]/b' \
2037 -e '/^#[ ]*if[ ]/b' \
2038 -e '/^#[ ]*ifdef[ ]/b' \
2039 -e '/^#[ ]*ifndef[ ]/b' \
2040 -e '/^#[ ]*else/b' \
2041 -e '/^#[ ]*elif[ ]/b' \
2042 -e '/^#[ ]*undef[ ]/b' \
2043 -e '/^#[ ]*endif/b' \
2051 (doextract ? "-e '1,/^#/d\n'" : ""),
2053 scriptname, cpp, sv, CPPMINUS);
2055 #ifdef IAMSUID /* actually, this is caught earlier */
2056 if (euid != uid && !euid) { /* if running suidperl */
2058 (void)seteuid(uid); /* musn't stay setuid root */
2061 (void)setreuid((Uid_t)-1, uid);
2063 #ifdef HAS_SETRESUID
2064 (void)setresuid((Uid_t)-1, uid, (Uid_t)-1);
2070 if (geteuid() != uid)
2071 croak("Can't do seteuid!\n");
2073 #endif /* IAMSUID */
2074 rsfp = PerlProc_popen(SvPVX(cmd), "r");
2078 else if (!*scriptname) {
2079 forbid_setid("program input from stdin");
2080 rsfp = PerlIO_stdin();
2083 rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
2084 #if defined(HAS_FCNTL) && defined(F_SETFD)
2086 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
2094 #ifndef IAMSUID /* in case script is not readable before setuid */
2095 if (euid && PerlLIO_stat(SvPVX(GvSV(curcop->cop_filegv)),&statbuf) >= 0 &&
2096 statbuf.st_mode & (S_ISUID|S_ISGID)) {
2098 PerlProc_execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
2099 croak("Can't do setuid\n");
2103 croak("Can't open perl script \"%s\": %s\n",
2104 SvPVX(GvSV(curcop->cop_filegv)), Strerror(errno));
2109 validate_suid(char *validarg, char *scriptname)
2113 /* do we need to emulate setuid on scripts? */
2115 /* This code is for those BSD systems that have setuid #! scripts disabled
2116 * in the kernel because of a security problem. Merely defining DOSUID
2117 * in perl will not fix that problem, but if you have disabled setuid
2118 * scripts in the kernel, this will attempt to emulate setuid and setgid
2119 * on scripts that have those now-otherwise-useless bits set. The setuid
2120 * root version must be called suidperl or sperlN.NNN. If regular perl
2121 * discovers that it has opened a setuid script, it calls suidperl with
2122 * the same argv that it had. If suidperl finds that the script it has
2123 * just opened is NOT setuid root, it sets the effective uid back to the
2124 * uid. We don't just make perl setuid root because that loses the
2125 * effective uid we had before invoking perl, if it was different from the
2128 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
2129 * be defined in suidperl only. suidperl must be setuid root. The
2130 * Configure script will set this up for you if you want it.
2137 if (PerlLIO_fstat(PerlIO_fileno(rsfp),&statbuf) < 0) /* normal stat is insecure */
2138 croak("Can't stat script \"%s\"",origfilename);
2139 if (fdscript < 0 && statbuf.st_mode & (S_ISUID|S_ISGID)) {
2143 #ifndef HAS_SETREUID
2144 /* On this access check to make sure the directories are readable,
2145 * there is actually a small window that the user could use to make
2146 * filename point to an accessible directory. So there is a faint
2147 * chance that someone could execute a setuid script down in a
2148 * non-accessible directory. I don't know what to do about that.
2149 * But I don't think it's too important. The manual lies when
2150 * it says access() is useful in setuid programs.
2152 if (PerlLIO_access(SvPVX(GvSV(curcop->cop_filegv)),1)) /*double check*/
2153 croak("Permission denied");
2155 /* If we can swap euid and uid, then we can determine access rights
2156 * with a simple stat of the file, and then compare device and
2157 * inode to make sure we did stat() on the same file we opened.
2158 * Then we just have to make sure he or she can execute it.
2161 struct stat tmpstatbuf;
2165 setreuid(euid,uid) < 0
2168 setresuid(euid,uid,(Uid_t)-1) < 0
2171 || getuid() != euid || geteuid() != uid)
2172 croak("Can't swap uid and euid"); /* really paranoid */
2173 if (PerlLIO_stat(SvPVX(GvSV(curcop->cop_filegv)),&tmpstatbuf) < 0)
2174 croak("Permission denied"); /* testing full pathname here */
2175 if (tmpstatbuf.st_dev != statbuf.st_dev ||
2176 tmpstatbuf.st_ino != statbuf.st_ino) {
2177 (void)PerlIO_close(rsfp);
2178 if (rsfp = PerlProc_popen("/bin/mail root","w")) { /* heh, heh */
2180 "User %ld tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
2181 (Filename of set-id script was %s, uid %ld gid %ld.)\n\nSincerely,\nperl\n",
2182 (long)uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
2183 (long)statbuf.st_dev, (long)statbuf.st_ino,
2184 SvPVX(GvSV(curcop->cop_filegv)),
2185 (long)statbuf.st_uid, (long)statbuf.st_gid);
2186 (void)PerlProc_pclose(rsfp);
2188 croak("Permission denied\n");
2192 setreuid(uid,euid) < 0
2194 # if defined(HAS_SETRESUID)
2195 setresuid(uid,euid,(Uid_t)-1) < 0
2198 || getuid() != uid || geteuid() != euid)
2199 croak("Can't reswap uid and euid");
2200 if (!cando(S_IXUSR,FALSE,&statbuf)) /* can real uid exec? */
2201 croak("Permission denied\n");
2203 #endif /* HAS_SETREUID */
2204 #endif /* IAMSUID */
2206 if (!S_ISREG(statbuf.st_mode))
2207 croak("Permission denied");
2208 if (statbuf.st_mode & S_IWOTH)
2209 croak("Setuid/gid script is writable by world");
2210 doswitches = FALSE; /* -s is insecure in suid */
2212 if (sv_gets(linestr, rsfp, 0) == Nullch ||
2213 strnNE(SvPV(linestr,na),"#!",2) ) /* required even on Sys V */
2214 croak("No #! line");
2215 s = SvPV(linestr,na)+2;
2217 while (!isSPACE(*s)) s++;
2218 for (s2 = s; (s2 > SvPV(linestr,na)+2 &&
2219 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
2220 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
2221 croak("Not a perl script");
2222 while (*s == ' ' || *s == '\t') s++;
2224 * #! arg must be what we saw above. They can invoke it by
2225 * mentioning suidperl explicitly, but they may not add any strange
2226 * arguments beyond what #! says if they do invoke suidperl that way.
2228 len = strlen(validarg);
2229 if (strEQ(validarg," PHOOEY ") ||
2230 strnNE(s,validarg,len) || !isSPACE(s[len]))
2231 croak("Args must match #! line");
2234 if (euid != uid && (statbuf.st_mode & S_ISUID) &&
2235 euid == statbuf.st_uid)
2237 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2238 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2239 #endif /* IAMSUID */
2241 if (euid) { /* oops, we're not the setuid root perl */
2242 (void)PerlIO_close(rsfp);
2245 PerlProc_execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
2247 croak("Can't do setuid\n");
2250 if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid) {
2252 (void)setegid(statbuf.st_gid);
2255 (void)setregid((Gid_t)-1,statbuf.st_gid);
2257 #ifdef HAS_SETRESGID
2258 (void)setresgid((Gid_t)-1,statbuf.st_gid,(Gid_t)-1);
2260 setgid(statbuf.st_gid);
2264 if (getegid() != statbuf.st_gid)
2265 croak("Can't do setegid!\n");
2267 if (statbuf.st_mode & S_ISUID) {
2268 if (statbuf.st_uid != euid)
2270 (void)seteuid(statbuf.st_uid); /* all that for this */
2273 (void)setreuid((Uid_t)-1,statbuf.st_uid);
2275 #ifdef HAS_SETRESUID
2276 (void)setresuid((Uid_t)-1,statbuf.st_uid,(Uid_t)-1);
2278 setuid(statbuf.st_uid);
2282 if (geteuid() != statbuf.st_uid)
2283 croak("Can't do seteuid!\n");
2285 else if (uid) { /* oops, mustn't run as root */
2287 (void)seteuid((Uid_t)uid);
2290 (void)setreuid((Uid_t)-1,(Uid_t)uid);
2292 #ifdef HAS_SETRESUID
2293 (void)setresuid((Uid_t)-1,(Uid_t)uid,(Uid_t)-1);
2299 if (geteuid() != uid)
2300 croak("Can't do seteuid!\n");
2303 if (!cando(S_IXUSR,TRUE,&statbuf))
2304 croak("Permission denied\n"); /* they can't do this */
2307 else if (preprocess)
2308 croak("-P not allowed for setuid/setgid script\n");
2309 else if (fdscript >= 0)
2310 croak("fd script not allowed in suidperl\n");
2312 croak("Script is not setuid/setgid in suidperl\n");
2314 /* We absolutely must clear out any saved ids here, so we */
2315 /* exec the real perl, substituting fd script for scriptname. */
2316 /* (We pass script name as "subdir" of fd, which perl will grok.) */
2317 PerlIO_rewind(rsfp);
2318 PerlLIO_lseek(PerlIO_fileno(rsfp),(Off_t)0,0); /* just in case rewind didn't */
2319 for (which = 1; origargv[which] && origargv[which] != scriptname; which++) ;
2320 if (!origargv[which])
2321 croak("Permission denied");
2322 origargv[which] = savepv(form("/dev/fd/%d/%s",
2323 PerlIO_fileno(rsfp), origargv[which]));
2324 #if defined(HAS_FCNTL) && defined(F_SETFD)
2325 fcntl(PerlIO_fileno(rsfp),F_SETFD,0); /* ensure no close-on-exec */
2327 PerlProc_execv(form("%s/perl%s", BIN_EXP, patchlevel), origargv); /* try again */
2328 croak("Can't do setuid\n");
2329 #endif /* IAMSUID */
2331 if (euid != uid || egid != gid) { /* (suidperl doesn't exist, in fact) */
2332 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
2334 PerlLIO_fstat(PerlIO_fileno(rsfp),&statbuf); /* may be either wrapped or real suid */
2335 if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
2337 (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
2340 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2341 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2342 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
2343 /* not set-id, must be wrapped */
2349 find_beginning(void)
2351 register char *s, *s2;
2353 /* skip forward in input to the real script? */
2357 if ((s = sv_gets(linestr, rsfp, 0)) == Nullch)
2358 croak("No Perl script found in input\n");
2359 if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
2360 PerlIO_ungetc(rsfp, '\n'); /* to keep line count right */
2362 while (*s && !(isSPACE (*s) || *s == '#')) s++;
2364 while (*s == ' ' || *s == '\t') s++;
2366 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
2367 if (strnEQ(s2-4,"perl",4))
2369 while (s = moreswitches(s)) ;
2371 if (cddir && PerlDir_chdir(cddir) < 0)
2372 croak("Can't chdir to %s",cddir);
2380 uid = (int)getuid();
2381 euid = (int)geteuid();
2382 gid = (int)getgid();
2383 egid = (int)getegid();
2388 tainting |= (uid && (euid != uid || egid != gid));
2392 forbid_setid(char *s)
2395 croak("No %s allowed while running setuid", s);
2397 croak("No %s allowed while running setgid", s);
2404 curstash = debstash;
2405 dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
2407 DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
2408 DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
2409 DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
2410 DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
2411 sv_setiv(DBsingle, 0);
2412 DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
2413 sv_setiv(DBtrace, 0);
2414 DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
2415 sv_setiv(DBsignal, 0);
2416 curstash = defstash;
2419 #ifndef STRESS_REALLOC
2420 #define REASONABLE(size) (size)
2422 #define REASONABLE(size) (1) /* unreasonable */
2426 init_stacks(ARGSproto)
2428 /* start with 128-item stack and 8K cxstack */
2429 curstackinfo = new_stackinfo(REASONABLE(128),
2430 REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
2431 curstackinfo->si_type = SI_MAIN;
2432 curstack = curstackinfo->si_stack;
2433 mainstack = curstack; /* remember in case we switch stacks */
2435 stack_base = AvARRAY(curstack);
2436 stack_sp = stack_base;
2437 stack_max = stack_base + AvMAX(curstack);
2439 New(50,tmps_stack,REASONABLE(128),SV*);
2442 tmps_max = REASONABLE(128);
2445 * The following stacks almost certainly should be per-interpreter,
2446 * but for now they're not. XXX
2450 markstack_ptr = markstack;
2452 New(54,markstack,REASONABLE(32),I32);
2453 markstack_ptr = markstack;
2454 markstack_max = markstack + REASONABLE(32);
2462 New(54,scopestack,REASONABLE(32),I32);
2464 scopestack_max = REASONABLE(32);
2470 New(54,savestack,REASONABLE(128),ANY);
2472 savestack_max = REASONABLE(128);
2478 New(54,retstack,REASONABLE(16),OP*);
2480 retstack_max = REASONABLE(16);
2490 while (curstackinfo->si_next)
2491 curstackinfo = curstackinfo->si_next;
2492 while (curstackinfo) {
2493 PERL_SI *p = curstackinfo->si_prev;
2494 SvREFCNT_dec(curstackinfo->si_stack);
2495 Safefree(curstackinfo->si_cxstack);
2496 Safefree(curstackinfo);
2499 Safefree(tmps_stack);
2506 static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
2515 subname = newSVpv("main",4);
2519 init_predump_symbols(void)
2525 sv_setpvn(perl_get_sv("\"", TRUE), " ", 1);
2526 stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
2527 GvMULTI_on(stdingv);
2528 IoIFP(GvIOp(stdingv)) = PerlIO_stdin();
2529 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
2531 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(stdingv));
2533 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
2535 IoOFP(GvIOp(tmpgv)) = IoIFP(GvIOp(tmpgv)) = PerlIO_stdout();
2537 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
2539 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(defoutgv));
2541 othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
2542 GvMULTI_on(othergv);
2543 IoOFP(GvIOp(othergv)) = IoIFP(GvIOp(othergv)) = PerlIO_stderr();
2544 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
2546 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(othergv));
2548 statname = NEWSV(66,0); /* last filename we did stat on */
2551 osname = savepv(OSNAME);
2555 init_postdump_symbols(register int argc, register char **argv, register char **env)
2562 argc--,argv++; /* skip name of script */
2564 for (; argc > 0 && **argv == '-'; argc--,argv++) {
2567 if (argv[0][1] == '-') {
2571 if (s = strchr(argv[0], '=')) {
2573 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
2576 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
2579 toptarget = NEWSV(0,0);
2580 sv_upgrade(toptarget, SVt_PVFM);
2581 sv_setpvn(toptarget, "", 0);
2582 bodytarget = NEWSV(0,0);
2583 sv_upgrade(bodytarget, SVt_PVFM);
2584 sv_setpvn(bodytarget, "", 0);
2585 formtarget = bodytarget;
2588 if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
2589 sv_setpv(GvSV(tmpgv),origfilename);
2590 magicname("0", "0", 1);
2592 if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
2593 sv_setpv(GvSV(tmpgv),origargv[0]);
2594 if (argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
2596 (void)gv_AVadd(argvgv);
2597 av_clear(GvAVn(argvgv));
2598 for (; argc > 0; argc--,argv++) {
2599 av_push(GvAVn(argvgv),newSVpv(argv[0],0));
2602 if (envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
2606 hv_magic(hv, envgv, 'E');
2607 #ifndef VMS /* VMS doesn't have environ array */
2608 /* Note that if the supplied env parameter is actually a copy
2609 of the global environ then it may now point to free'd memory
2610 if the environment has been modified since. To avoid this
2611 problem we treat env==NULL as meaning 'use the default'
2616 environ[0] = Nullch;
2617 for (; *env; env++) {
2618 if (!(s = strchr(*env,'=')))
2621 #if defined(WIN32) || defined(MSDOS)
2624 sv = newSVpv(s--,0);
2625 (void)hv_store(hv, *env, s - *env, sv, 0);
2627 #if defined(__BORLANDC__) && defined(USE_WIN32_RTL_ENV)
2628 /* Sins of the RTL. See note in my_setenv(). */
2629 (void)PerlEnv_putenv(savepv(*env));
2633 #ifdef DYNAMIC_ENV_FETCH
2634 HvNAME(hv) = savepv(ENV_HV_NAME);
2638 if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
2639 sv_setiv(GvSV(tmpgv), (IV)getpid());
2648 s = PerlEnv_getenv("PERL5LIB");
2652 incpush(PerlEnv_getenv("PERLLIB"), FALSE);
2654 /* Treat PERL5?LIB as a possible search list logical name -- the
2655 * "natural" VMS idiom for a Unix path string. We allow each
2656 * element to be a set of |-separated directories for compatibility.
2660 if (my_trnlnm("PERL5LIB",buf,0))
2661 do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
2663 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE);
2667 /* Use the ~-expanded versions of APPLLIB (undocumented),
2668 ARCHLIB PRIVLIB SITEARCH and SITELIB
2671 incpush(APPLLIB_EXP, FALSE);
2675 incpush(ARCHLIB_EXP, FALSE);
2678 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
2680 incpush(PRIVLIB_EXP, FALSE);
2683 incpush(SITEARCH_EXP, FALSE);
2686 incpush(SITELIB_EXP, FALSE);
2689 incpush(".", FALSE);
2693 # define PERLLIB_SEP ';'
2696 # define PERLLIB_SEP '|'
2698 # define PERLLIB_SEP ':'
2701 #ifndef PERLLIB_MANGLE
2702 # define PERLLIB_MANGLE(s,n) (s)
2706 incpush(char *p, int addsubdirs)
2708 SV *subdir = Nullsv;
2709 static char *archpat_auto;
2715 subdir = NEWSV(55,0);
2716 if (!archpat_auto) {
2717 STRLEN len = (sizeof(ARCHNAME) + strlen(patchlevel)
2718 + sizeof("//auto"));
2719 New(55, archpat_auto, len, char);
2720 sprintf(archpat_auto, "/%s/%s/auto", ARCHNAME, patchlevel);
2722 for (len = sizeof(ARCHNAME) + 2;
2723 archpat_auto[len] != '\0' && archpat_auto[len] != '/'; len++)
2724 if (archpat_auto[len] == '.') archpat_auto[len] = '_';
2729 /* Break at all separators */
2731 SV *libdir = NEWSV(55,0);
2734 /* skip any consecutive separators */
2735 while ( *p == PERLLIB_SEP ) {
2736 /* Uncomment the next line for PATH semantics */
2737 /* av_push(GvAVn(incgv), newSVpv(".", 1)); */
2741 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
2742 sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
2747 sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
2748 p = Nullch; /* break out */
2752 * BEFORE pushing libdir onto @INC we may first push version- and
2753 * archname-specific sub-directories.
2756 struct stat tmpstatbuf;
2761 if ((unix = tounixspec_ts(SvPV(libdir,na),Nullch)) != Nullch) {
2763 while (unix[len-1] == '/') len--; /* Cosmetic */
2764 sv_usepvn(libdir,unix,len);
2767 PerlIO_printf(PerlIO_stderr(),
2768 "Failed to unixify @INC element \"%s\"\n",
2771 /* .../archname/version if -d .../archname/version/auto */
2772 sv_setsv(subdir, libdir);
2773 sv_catpv(subdir, archpat_auto);
2774 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2775 S_ISDIR(tmpstatbuf.st_mode))
2776 av_push(GvAVn(incgv),
2777 newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2779 /* .../archname if -d .../archname/auto */
2780 sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME),
2781 strlen(patchlevel) + 1, "", 0);
2782 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2783 S_ISDIR(tmpstatbuf.st_mode))
2784 av_push(GvAVn(incgv),
2785 newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2788 /* finally push this lib directory on the end of @INC */
2789 av_push(GvAVn(incgv), libdir);
2792 SvREFCNT_dec(subdir);
2796 static struct perl_thread *
2799 struct perl_thread *thr;
2802 Newz(53, thr, 1, struct perl_thread);
2803 curcop = &compiling;
2804 thr->cvcache = newHV();
2805 thr->threadsv = newAV();
2806 /* thr->threadsvp is set when find_threadsv is called */
2807 thr->specific = newAV();
2808 thr->errhv = newHV();
2809 thr->flags = THRf_R_JOINABLE;
2810 MUTEX_INIT(&thr->mutex);
2811 /* Handcraft thrsv similarly to mess_sv */
2812 New(53, thrsv, 1, SV);
2813 Newz(53, xpv, 1, XPV);
2814 SvFLAGS(thrsv) = SVt_PV;
2815 SvANY(thrsv) = (void*)xpv;
2816 SvREFCNT(thrsv) = 1 << 30; /* practically infinite */
2817 SvPVX(thrsv) = (char*)thr;
2818 SvCUR_set(thrsv, sizeof(thr));
2819 SvLEN_set(thrsv, sizeof(thr));
2820 *SvEND(thrsv) = '\0'; /* in the trailing_nul field */
2822 curcop = &compiling;
2825 MUTEX_LOCK(&threads_mutex);
2830 MUTEX_UNLOCK(&threads_mutex);
2832 #ifdef HAVE_THREAD_INTERN
2833 init_thread_intern(thr);
2836 #ifdef SET_THREAD_SELF
2837 SET_THREAD_SELF(thr);
2839 thr->self = pthread_self();
2840 #endif /* SET_THREAD_SELF */
2844 * These must come after the SET_THR because sv_setpvn does
2845 * SvTAINT and the taint fields require dTHR.
2847 toptarget = NEWSV(0,0);
2848 sv_upgrade(toptarget, SVt_PVFM);
2849 sv_setpvn(toptarget, "", 0);
2850 bodytarget = NEWSV(0,0);
2851 sv_upgrade(bodytarget, SVt_PVFM);
2852 sv_setpvn(bodytarget, "", 0);
2853 formtarget = bodytarget;
2854 thr->errsv = newSVpv("", 0);
2855 (void) find_threadsv("@"); /* Ensure $@ is initialised early */
2858 #endif /* USE_THREADS */
2861 call_list(I32 oldscope, AV *list)
2864 line_t oldline = curcop->cop_line;
2869 while (AvFILL(list) >= 0) {
2870 CV *cv = (CV*)av_shift(list);
2879 perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
2880 (void)SvPV(atsv, len);
2883 curcop = &compiling;
2884 curcop->cop_line = oldline;
2885 if (list == beginav)
2886 sv_catpv(atsv, "BEGIN failed--compilation aborted");
2888 sv_catpv(atsv, "END failed--cleanup aborted");
2889 while (scopestack_ix > oldscope)
2891 croak("%s", SvPVX(atsv));
2899 /* my_exit() was called */
2900 while (scopestack_ix > oldscope)
2903 curstash = defstash;
2905 call_list(oldscope, endav);
2907 curcop = &compiling;
2908 curcop->cop_line = oldline;
2910 if (list == beginav)
2911 croak("BEGIN failed--compilation aborted");
2913 croak("END failed--cleanup aborted");
2919 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
2924 curcop = &compiling;
2925 curcop->cop_line = oldline;
2938 DEBUG_L(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
2939 thr, (unsigned long) status));
2940 #endif /* USE_THREADS */
2949 STATUS_NATIVE_SET(status);
2956 my_failure_exit(void)
2959 if (vaxc$errno & 1) {
2960 if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
2961 STATUS_NATIVE_SET(44);
2964 if (!vaxc$errno && errno) /* unlikely */
2965 STATUS_NATIVE_SET(44);
2967 STATUS_NATIVE_SET(vaxc$errno);
2971 STATUS_POSIX_SET(errno);
2972 else if (STATUS_POSIX == 0)
2973 STATUS_POSIX_SET(255);
2982 register PERL_CONTEXT *cx;
2991 (void)UNLINK(e_tmpname);
2992 Safefree(e_tmpname);
2996 if (cxstack_ix >= 0) {