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> */
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));
73 static struct perl_thread * init_main_thread _((void));
74 #endif /* USE_THREADS */
75 static void init_perllib _((void));
76 static void init_postdump_symbols _((int, char **, char **));
77 static void init_predump_symbols _((void));
78 static void my_exit_jump _((void)) __attribute__((noreturn));
79 static void nuke_stacks _((void));
80 static void open_script _((char *, bool, SV *));
81 static void usage _((char *));
82 static void validate_suid _((char *, char*));
84 static int fdscript = -1;
89 PerlInterpreter *sv_interp;
92 New(53, sv_interp, 1, PerlInterpreter);
97 perl_construct(register PerlInterpreter *sv_interp)
102 struct perl_thread *thr;
103 #endif /* FAKE_THREADS */
104 #endif /* USE_THREADS */
106 if (!(curinterp = sv_interp))
110 Zero(sv_interp, 1, PerlInterpreter);
113 /* Init the real globals (and main thread)? */
118 #ifdef ALLOC_THREAD_KEY
121 if (pthread_key_create(&thr_key, 0))
122 croak("panic: pthread_key_create");
124 MUTEX_INIT(&sv_mutex);
126 * Safe to use basic SV functions from now on (though
127 * not things like mortals or tainting yet).
129 MUTEX_INIT(&eval_mutex);
130 COND_INIT(&eval_cond);
131 MUTEX_INIT(&threads_mutex);
132 COND_INIT(&nthreads_cond);
133 #ifdef EMULATE_ATOMIC_REFCOUNTS
134 MUTEX_INIT(&svref_mutex);
135 #endif /* EMULATE_ATOMIC_REFCOUNTS */
137 thr = init_main_thread();
138 #endif /* USE_THREADS */
140 linestr = NEWSV(65,80);
141 sv_upgrade(linestr,SVt_PVIV);
143 if (!SvREADONLY(&sv_undef)) {
144 SvREADONLY_on(&sv_undef);
148 SvREADONLY_on(&sv_no);
150 sv_setpv(&sv_yes,Yes);
152 SvREADONLY_on(&sv_yes);
155 nrs = newSVpv("\n", 1);
156 rs = SvREFCNT_inc(nrs);
158 sighandlerp = sighandler;
163 * There is no way we can refer to them from Perl so close them to save
164 * space. The other alternative would be to provide STDAUX and STDPRN
167 (void)fclose(stdaux);
168 (void)fclose(stdprn);
174 perl_destruct_level = 1;
176 if(perl_destruct_level > 0)
181 lex_state = LEX_NOTPARSING;
183 start_env.je_prev = NULL;
184 start_env.je_ret = -1;
185 start_env.je_mustcatch = TRUE;
186 top_env = &start_env;
189 SET_NUMERIC_STANDARD();
190 #if defined(SUBVERSION) && SUBVERSION > 0
191 sprintf(patchlevel, "%7.5f", (double) 5
192 + ((double) PATCHLEVEL / (double) 1000)
193 + ((double) SUBVERSION / (double) 100000));
195 sprintf(patchlevel, "%5.3f", (double) 5 +
196 ((double) PATCHLEVEL / (double) 1000));
199 #if defined(LOCAL_PATCH_COUNT)
200 localpatches = local_patches; /* For possible -v */
203 PerlIO_init(); /* Hook to IO system */
205 fdpid = newAV(); /* for remembering popen pids by fd */
209 New(51,debname,128,char);
210 New(52,debdelim,128,char);
217 perl_destruct(register PerlInterpreter *sv_interp)
220 int destruct_level; /* 0=none, 1=full, 2=full with checks */
225 #endif /* USE_THREADS */
227 if (!(curinterp = sv_interp))
232 /* Pass 1 on any remaining threads: detach joinables, join zombies */
234 MUTEX_LOCK(&threads_mutex);
235 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
236 "perl_destruct: waiting for %d threads...\n",
238 for (t = thr->next; t != thr; t = t->next) {
239 MUTEX_LOCK(&t->mutex);
240 switch (ThrSTATE(t)) {
243 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
244 "perl_destruct: joining zombie %p\n", t));
245 ThrSETSTATE(t, THRf_DEAD);
246 MUTEX_UNLOCK(&t->mutex);
249 * The SvREFCNT_dec below may take a long time (e.g. av
250 * may contain an object scalar whose destructor gets
251 * called) so we have to unlock threads_mutex and start
254 MUTEX_UNLOCK(&threads_mutex);
256 SvREFCNT_dec((SV*)av);
257 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
258 "perl_destruct: joined zombie %p OK\n", t));
260 case THRf_R_JOINABLE:
261 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
262 "perl_destruct: detaching thread %p\n", t));
263 ThrSETSTATE(t, THRf_R_DETACHED);
265 * We unlock threads_mutex and t->mutex in the opposite order
266 * from which we locked them just so that DETACH won't
267 * deadlock if it panics. It's only a breach of good style
268 * not a bug since they are unlocks not locks.
270 MUTEX_UNLOCK(&threads_mutex);
272 MUTEX_UNLOCK(&t->mutex);
275 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
276 "perl_destruct: ignoring %p (state %u)\n",
278 MUTEX_UNLOCK(&t->mutex);
279 /* fall through and out */
282 /* We leave the above "Pass 1" loop with threads_mutex still locked */
284 /* Pass 2 on remaining threads: wait for the thread count to drop to one */
287 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
288 "perl_destruct: final wait for %d threads\n",
290 COND_WAIT(&nthreads_cond, &threads_mutex);
292 /* At this point, we're the last thread */
293 MUTEX_UNLOCK(&threads_mutex);
294 DEBUG_L(PerlIO_printf(PerlIO_stderr(), "perl_destruct: armageddon has arrived\n"));
295 MUTEX_DESTROY(&threads_mutex);
296 COND_DESTROY(&nthreads_cond);
297 #endif /* !defined(FAKE_THREADS) */
298 #endif /* USE_THREADS */
300 destruct_level = perl_destruct_level;
304 if (s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL")) {
306 if (destruct_level < i)
315 /* We must account for everything. */
317 /* Destroy the main CV and syntax tree */
319 curpad = AvARRAY(comppad);
324 SvREFCNT_dec(main_cv);
329 * Try to destruct global references. We do this first so that the
330 * destructors and destructees still exist. Some sv's might remain.
331 * Non-referenced objects are on their own.
338 /* unhook hooks which will soon be, or use, destroyed data */
339 SvREFCNT_dec(warnhook);
341 SvREFCNT_dec(diehook);
343 SvREFCNT_dec(parsehook);
346 if (destruct_level == 0){
348 DEBUG_P(debprofdump());
350 /* The exit() function will do everything that needs doing. */
354 /* loosen bonds of global variables */
357 (void)PerlIO_close(rsfp);
361 /* Filters for program text */
362 SvREFCNT_dec(rsfp_filters);
363 rsfp_filters = Nullav;
375 sawampersand = FALSE; /* must save all match strings */
376 sawstudy = FALSE; /* do fbm_instr on all strings */
391 /* magical thingies */
393 Safefree(ofs); /* $, */
396 Safefree(ors); /* $\ */
399 SvREFCNT_dec(nrs); /* $\ helper */
402 multiline = 0; /* $* */
404 SvREFCNT_dec(statname);
408 /* defgv, aka *_ should be taken care of elsewhere */
410 /* clean up after study() */
411 SvREFCNT_dec(lastscream);
413 Safefree(screamfirst);
415 Safefree(screamnext);
418 /* startup and shutdown function lists */
419 SvREFCNT_dec(beginav);
421 SvREFCNT_dec(initav);
426 /* temp stack during pp_sort() */
427 SvREFCNT_dec(sortstack);
430 /* shortcuts just get cleared */
440 /* reset so print() ends up where we expect */
443 /* Prepare to destruct main symbol table. */
450 if (destruct_level >= 2) {
451 if (scopestack_ix != 0)
452 warn("Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
453 (long)scopestack_ix);
454 if (savestack_ix != 0)
455 warn("Unbalanced saves: %ld more saves than restores\n",
457 if (tmps_floor != -1)
458 warn("Unbalanced tmps: %ld more allocs than frees\n",
459 (long)tmps_floor + 1);
460 if (cxstack_ix != -1)
461 warn("Unbalanced context: %ld more PUSHes than POPs\n",
462 (long)cxstack_ix + 1);
465 /* Now absolutely destruct everything, somehow or other, loops or no. */
467 SvFLAGS(strtab) |= SVTYPEMASK; /* don't clean out strtab now */
468 while (sv_count != 0 && sv_count != last_sv_count) {
469 last_sv_count = sv_count;
472 SvFLAGS(strtab) &= ~SVTYPEMASK;
473 SvFLAGS(strtab) |= SVt_PVHV;
475 /* Destruct the global string table. */
477 /* Yell and reset the HeVAL() slots that are still holding refcounts,
478 * so that sv_free() won't fail on them.
487 array = HvARRAY(strtab);
491 warn("Unbalanced string table refcount: (%d) for \"%s\"",
492 HeVAL(hent) - Nullsv, HeKEY(hent));
493 HeVAL(hent) = Nullsv;
503 SvREFCNT_dec(strtab);
506 warn("Scalars leaked: %ld\n", (long)sv_count);
510 /* No SVs have survived, need to clean out */
514 Safefree(origfilename);
516 hints = 0; /* Reset hints. Should hints be per-interpreter ? */
518 DEBUG_P(debprofdump());
520 MUTEX_DESTROY(&sv_mutex);
521 MUTEX_DESTROY(&eval_mutex);
522 COND_DESTROY(&eval_cond);
524 /* As the penultimate thing, free the non-arena SV for thrsv */
525 Safefree(SvPVX(thrsv));
526 Safefree(SvANY(thrsv));
529 #endif /* USE_THREADS */
531 /* As the absolutely last thing, free the non-arena SV for mess() */
534 /* we know that type >= SVt_PV */
536 Safefree(SvPVX(mess_sv));
537 Safefree(SvANY(mess_sv));
544 perl_free(PerlInterpreter *sv_interp)
546 if (!(curinterp = sv_interp))
552 perl_parse(PerlInterpreter *sv_interp, void (*xsinit) (void), int argc, char **argv, char **env)
557 char *scriptname = NULL;
558 VOL bool dosearch = FALSE;
566 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
569 croak("suidperl is no longer needed since the kernel can now execute\n\
570 setuid perl scripts securely.\n");
574 if (!(curinterp = sv_interp))
577 #if defined(NeXT) && defined(__DYNAMIC__)
578 _dyld_lookup_and_bind
579 ("__environ", (unsigned long *) &environ_pointer, NULL);
584 #ifndef VMS /* VMS doesn't have environ array */
585 origenviron = environ;
591 /* Come here if running an undumped a.out. */
593 origfilename = savepv(argv[0]);
595 cxstack_ix = -1; /* start label stack again */
597 init_postdump_symbols(argc,argv,env);
602 curpad = AvARRAY(comppad);
607 SvREFCNT_dec(main_cv);
611 oldscope = scopestack_ix;
619 /* my_exit() was called */
620 while (scopestack_ix > oldscope)
625 call_list(oldscope, endav);
627 return STATUS_NATIVE_EXPORT;
630 PerlIO_printf(PerlIO_stderr(), "panic: top_env\n");
634 sv_setpvn(linestr,"",0);
635 sv = newSVpv("",0); /* first used for -I flags */
639 for (argc--,argv++; argc > 0; argc--,argv++) {
640 if (argv[0][0] != '-' || !argv[0][1])
644 validarg = " PHOOEY ";
669 if (s = moreswitches(s))
679 if (euid != uid || egid != gid)
680 croak("No -e allowed in setuid scripts");
682 e_tmpname = savepv(TMPPATH);
684 e_tmpfd = PerlLIO_mkstemp(e_tmpname);
687 croak("Can't mkstemp() temporary file \"%s\"", e_tmpname);
688 e_fp = PerlIO_fdopen(e_tmpfd,"w");
689 #else /* use mktemp() */
690 (void)PerlLIO_mktemp(e_tmpname);
692 croak("Can't mktemp() temporary file \"%s\"", e_tmpname);
693 e_fp = PerlIO_open(e_tmpname,"w");
694 #endif /* HAS_MKSTEMP */
696 croak("Cannot open temporary file \"%s\"", e_tmpname);
701 PerlIO_puts(e_fp,argv[1]);
705 croak("No code specified for -e");
706 (void)PerlIO_putc(e_fp,'\n');
708 case 'I': /* -I handled both here and in moreswitches() */
710 if (!*++s && (s=argv[1]) != Nullch) {
713 while (s && isSPACE(*s))
717 for (e = s; *e && !isSPACE(*e); e++) ;
724 } /* XXX else croak? */
738 preambleav = newAV();
739 av_push(preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
741 Sv = newSVpv("print myconfig();",0);
743 sv_catpv(Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
745 sv_catpv(Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
747 #if defined(DEBUGGING) || defined(NO_EMBED) || defined(MULTIPLICITY)
748 sv_catpv(Sv,"\" Compile-time options:");
750 sv_catpv(Sv," DEBUGGING");
753 sv_catpv(Sv," NO_EMBED");
756 sv_catpv(Sv," MULTIPLICITY");
758 sv_catpv(Sv,"\\n\",");
760 #if defined(LOCAL_PATCH_COUNT)
761 if (LOCAL_PATCH_COUNT > 0) {
763 sv_catpv(Sv,"\" Locally applied patches:\\n\",");
764 for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
766 sv_catpvf(Sv,"\" \\t%s\\n\",",localpatches[i]);
770 sv_catpvf(Sv,"\" Built under %s\\n\"",OSNAME);
773 sv_catpvf(Sv,",\" Compiled at %s %s\\n\"",__DATE__,__TIME__);
775 sv_catpvf(Sv,",\" Compiled on %s\\n\"",__DATE__);
780 @env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; \
781 print \" \\%ENV:\\n @env\\n\" if @env; \
782 print \" \\@INC:\\n @INC\\n\";");
785 Sv = newSVpv("config_vars(qw(",0);
790 av_push(preambleav, Sv);
791 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
802 if (!*++s || isSPACE(*s)) {
806 /* catch use of gnu style long options */
807 if (strEQ(s, "version")) {
811 if (strEQ(s, "help")) {
818 croak("Unrecognized switch: -%s (-h will show valid options)",s);
823 if (!tainting && (s = PerlEnv_getenv("PERL5OPT"))) {
834 if (!strchr("DIMUdmw", *s))
835 croak("Illegal switch in PERL5OPT: -%c", *s);
841 scriptname = argv[0];
843 if (PerlIO_flush(e_fp) || PerlIO_error(e_fp) || PerlIO_close(e_fp)) {
845 warn("Did you forget to compile with -DMULTIPLICITY?");
847 croak("Can't write to temp file for -e: %s", Strerror(errno));
851 scriptname = e_tmpname;
853 else if (scriptname == Nullch) {
855 if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) )
863 open_script(scriptname,dosearch,sv);
865 validate_suid(validarg, scriptname);
870 main_cv = compcv = (CV*)NEWSV(1104,0);
871 sv_upgrade((SV *)compcv, SVt_PVCV);
875 av_push(comppad, Nullsv);
876 curpad = AvARRAY(comppad);
877 comppad_name = newAV();
878 comppad_name_fill = 0;
879 min_intro_pending = 0;
882 av_store(comppad_name, 0, newSVpv("@_", 2));
883 curpad[0] = (SV*)newAV();
884 SvPADMY_on(curpad[0]); /* XXX Needed? */
886 New(666, CvMUTEXP(compcv), 1, perl_mutex);
887 MUTEX_INIT(CvMUTEXP(compcv));
888 #endif /* USE_THREADS */
890 comppadlist = newAV();
891 AvREAL_off(comppadlist);
892 av_store(comppadlist, 0, (SV*)comppad_name);
893 av_store(comppadlist, 1, (SV*)comppad);
894 CvPADLIST(compcv) = comppadlist;
896 boot_core_UNIVERSAL();
898 (*xsinit)(); /* in case linked C routines want magical variables */
899 #if defined(VMS) || defined(WIN32) || defined(DJGPP)
903 init_predump_symbols();
905 init_postdump_symbols(argc,argv,env);
909 /* now parse the script */
911 SETERRNO(0,SS$_NORMAL);
913 if (yyparse() || error_count) {
915 croak("%s had compilation errors.\n", origfilename);
917 croak("Execution of %s aborted due to compilation errors.\n",
921 curcop->cop_line = 0;
925 (void)UNLINK(e_tmpname);
931 /* now that script is parsed, we can modify record separator */
933 rs = SvREFCNT_inc(nrs);
934 sv_setsv(perl_get_sv("/", TRUE), rs);
945 if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
946 dump_mstats("after compilation:");
956 perl_run(PerlInterpreter *sv_interp)
963 if (!(curinterp = sv_interp))
966 oldscope = scopestack_ix;
971 cxstack_ix = -1; /* start context stack again */
974 /* my_exit() was called */
975 while (scopestack_ix > oldscope)
980 call_list(oldscope, endav);
982 if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
983 dump_mstats("after execution: ");
986 return STATUS_NATIVE_EXPORT;
989 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
994 if (curstack != mainstack) {
996 SWITCHSTACK(curstack, mainstack);
1001 DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
1002 sawampersand ? "Enabling" : "Omitting"));
1005 DEBUG_x(dump_all());
1006 DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
1008 DEBUG_L(PerlIO_printf(Perl_debug_log, "main thread is 0x%lx\n",
1009 (unsigned long) thr));
1010 #endif /* USE_THREADS */
1013 PerlIO_printf(PerlIO_stderr(), "%s syntax OK\n", origfilename);
1016 if (PERLDB_SINGLE && DBsingle)
1017 sv_setiv(DBsingle, 1);
1019 call_list(oldscope, initav);
1029 else if (main_start) {
1030 CvDEPTH(main_cv) = 1;
1041 perl_get_sv(char *name, I32 create)
1045 if (name[1] == '\0' && !isALPHA(name[0])) {
1046 PADOFFSET tmp = find_threadsv(name);
1047 if (tmp != NOT_IN_PAD) {
1049 return THREADSV(tmp);
1052 #endif /* USE_THREADS */
1053 gv = gv_fetchpv(name, create, SVt_PV);
1060 perl_get_av(char *name, I32 create)
1062 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
1071 perl_get_hv(char *name, I32 create)
1073 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
1082 perl_get_cv(char *name, I32 create)
1084 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
1085 if (create && !GvCVu(gv))
1086 return newSUB(start_subparse(FALSE, 0),
1087 newSVOP(OP_CONST, 0, newSVpv(name,0)),
1095 /* Be sure to refetch the stack pointer after calling these routines. */
1098 perl_call_argv(char *sub_name, I32 flags, register char **argv)
1100 /* See G_* flags in cop.h */
1101 /* null terminated arg list */
1108 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
1113 return perl_call_pv(sub_name, flags);
1117 perl_call_pv(char *sub_name, I32 flags)
1118 /* name of the subroutine */
1119 /* See G_* flags in cop.h */
1121 return perl_call_sv((SV*)perl_get_cv(sub_name, TRUE), flags);
1125 perl_call_method(char *methname, I32 flags)
1126 /* name of the subroutine */
1127 /* See G_* flags in cop.h */
1133 XPUSHs(sv_2mortal(newSVpv(methname,0)));
1136 return perl_call_sv(*stack_sp--, flags);
1139 /* May be called with any of a CV, a GV, or an SV containing the name. */
1141 perl_call_sv(SV *sv, I32 flags)
1143 /* See G_* flags in cop.h */
1146 LOGOP myop; /* fake syntax tree node */
1151 bool oldcatch = CATCH_GET;
1156 if (flags & G_DISCARD) {
1161 Zero(&myop, 1, LOGOP);
1162 myop.op_next = Nullop;
1163 if (!(flags & G_NOARGS))
1164 myop.op_flags |= OPf_STACKED;
1165 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1166 (flags & G_ARRAY) ? OPf_WANT_LIST :
1171 EXTEND(stack_sp, 1);
1174 oldscope = scopestack_ix;
1176 if (PERLDB_SUB && curstash != debstash
1177 /* Handle first BEGIN of -d. */
1178 && (DBcv || (DBcv = GvCV(DBsub)))
1179 /* Try harder, since this may have been a sighandler, thus
1180 * curstash may be meaningless. */
1181 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != debstash))
1182 op->op_private |= OPpENTERSUB_DB;
1184 if (flags & G_EVAL) {
1185 cLOGOP->op_other = op;
1187 /* we're trying to emulate pp_entertry() here */
1189 register PERL_CONTEXT *cx;
1190 I32 gimme = GIMME_V;
1195 push_return(op->op_next);
1196 PUSHBLOCK(cx, CXt_EVAL, stack_sp);
1198 eval_root = op; /* Only needed so that goto works right. */
1201 if (flags & G_KEEPERR)
1216 /* my_exit() was called */
1217 curstash = defstash;
1221 croak("Callback called exit");
1230 stack_sp = stack_base + oldmark;
1231 if (flags & G_ARRAY)
1235 *++stack_sp = &sv_undef;
1243 if (op == (OP*)&myop)
1244 op = pp_entersub(ARGS);
1247 retval = stack_sp - (stack_base + oldmark);
1248 if ((flags & G_EVAL) && !(flags & G_KEEPERR))
1252 if (flags & G_EVAL) {
1253 if (scopestack_ix > oldscope) {
1257 register PERL_CONTEXT *cx;
1269 CATCH_SET(oldcatch);
1271 if (flags & G_DISCARD) {
1272 stack_sp = stack_base + oldmark;
1281 /* Eval a string. The G_EVAL flag is always assumed. */
1284 perl_eval_sv(SV *sv, I32 flags)
1286 /* See G_* flags in cop.h */
1289 UNOP myop; /* fake syntax tree node */
1290 I32 oldmark = SP - stack_base;
1297 if (flags & G_DISCARD) {
1305 EXTEND(stack_sp, 1);
1307 oldscope = scopestack_ix;
1309 if (!(flags & G_NOARGS))
1310 myop.op_flags = OPf_STACKED;
1311 myop.op_next = Nullop;
1312 myop.op_type = OP_ENTEREVAL;
1313 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1314 (flags & G_ARRAY) ? OPf_WANT_LIST :
1316 if (flags & G_KEEPERR)
1317 myop.op_flags |= OPf_SPECIAL;
1327 /* my_exit() was called */
1328 curstash = defstash;
1332 croak("Callback called exit");
1341 stack_sp = stack_base + oldmark;
1342 if (flags & G_ARRAY)
1346 *++stack_sp = &sv_undef;
1351 if (op == (OP*)&myop)
1352 op = pp_entereval(ARGS);
1355 retval = stack_sp - (stack_base + oldmark);
1356 if (!(flags & G_KEEPERR))
1361 if (flags & G_DISCARD) {
1362 stack_sp = stack_base + oldmark;
1372 perl_eval_pv(char *p, I32 croak_on_error)
1375 SV* sv = newSVpv(p, 0);
1378 perl_eval_sv(sv, G_SCALAR);
1385 if (croak_on_error && SvTRUE(ERRSV))
1386 croak(SvPVx(ERRSV, na));
1391 /* Require a module. */
1394 perl_require_pv(char *pv)
1396 SV* sv = sv_newmortal();
1397 sv_setpv(sv, "require '");
1400 perl_eval_sv(sv, G_DISCARD);
1404 magicname(char *sym, char *name, I32 namlen)
1408 if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
1409 sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
1413 usage(char *name) /* XXX move this out into a module ? */
1416 /* This message really ought to be max 23 lines.
1417 * Removed -h because the user already knows that opton. Others? */
1419 static char *usage[] = {
1420 "-0[octal] specify record separator (\\0, if no argument)",
1421 "-a autosplit mode with -n or -p (splits $_ into @F)",
1422 "-c check syntax only (runs BEGIN and END blocks)",
1423 "-d[:debugger] run scripts under debugger",
1424 "-D[number/list] set debugging flags (argument is a bit mask or flags)",
1425 "-e 'command' one line of script. Several -e's allowed. Omit [programfile].",
1426 "-F/pattern/ split() pattern for autosplit (-a). The //'s are optional.",
1427 "-i[extension] edit <> files in place (make backup if extension supplied)",
1428 "-Idirectory specify @INC/#include directory (may be used more than once)",
1429 "-l[octal] enable line ending processing, specifies line terminator",
1430 "-[mM][-]module.. executes `use/no module...' before executing your script.",
1431 "-n assume 'while (<>) { ... }' loop around your script",
1432 "-p assume loop like -n but print line also like sed",
1433 "-P run script through C preprocessor before compilation",
1434 "-s enable some switch parsing for switches after script name",
1435 "-S look for the script using PATH environment variable",
1436 "-T turn on tainting checks",
1437 "-u dump core after parsing script",
1438 "-U allow unsafe operations",
1439 "-v print version number and patchlevel of perl",
1440 "-V[:variable] print perl configuration information",
1441 "-w TURN WARNINGS ON FOR COMPILATION OF YOUR SCRIPT. Recommended.",
1442 "-x[directory] strip off text before #!perl line and perhaps cd to directory",
1448 printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
1450 printf("\n %s", *p++);
1453 /* This routine handles any switches that can be given during run */
1456 moreswitches(char *s)
1465 rschar = scan_oct(s, 4, &numlen);
1467 if (rschar & ~((U8)~0))
1469 else if (!rschar && numlen >= 2)
1470 nrs = newSVpv("", 0);
1473 nrs = newSVpv(&ch, 1);
1479 splitstr = savepv(s + 1);
1493 if (*s == ':' || *s == '=') {
1494 my_setenv("PERL5DB", form("use Devel::%s;", ++s));
1498 perldb = PERLDB_ALL;
1505 if (isALPHA(s[1])) {
1506 static char debopts[] = "psltocPmfrxuLHXD";
1509 for (s++; *s && (d = strchr(debopts,*s)); s++)
1510 debug |= 1 << (d - debopts);
1514 for (s++; isDIGIT(*s); s++) ;
1516 debug |= 0x80000000;
1518 warn("Recompile perl with -DDEBUGGING to use -D switch\n");
1519 for (s++; isALNUM(*s); s++) ;
1529 inplace = savepv(s+1);
1531 for (s = inplace; *s && !isSPACE(*s); s++) ;
1535 case 'I': /* -I handled both here and in parse_perl() */
1538 while (*s && isSPACE(*s))
1542 for (e = s; *e && !isSPACE(*e); e++) ;
1543 p = savepvn(s, e-s);
1549 croak("No space allowed after -I");
1559 *ors = scan_oct(s, 3 + (*s == '0'), &numlen);
1569 ors = SvPV(nrs, orslen);
1570 ors = savepvn(ors, orslen);
1574 forbid_setid("-M"); /* XXX ? */
1577 forbid_setid("-m"); /* XXX ? */
1582 /* -M-foo == 'no foo' */
1583 if (*s == '-') { use = "no "; ++s; }
1584 sv = newSVpv(use,0);
1586 /* We allow -M'Module qw(Foo Bar)' */
1587 while(isALNUM(*s) || *s==':') ++s;
1589 sv_catpv(sv, start);
1590 if (*(start-1) == 'm') {
1592 croak("Can't use '%c' after -mname", *s);
1593 sv_catpv( sv, " ()");
1596 sv_catpvn(sv, start, s-start);
1597 sv_catpv(sv, " split(/,/,q{");
1602 if (preambleav == NULL)
1603 preambleav = newAV();
1604 av_push(preambleav, sv);
1607 croak("No space allowed after -%c", *(s-1));
1624 croak("Too late for \"-T\" option");
1636 #if defined(SUBVERSION) && SUBVERSION > 0
1637 printf("\nThis is perl, version 5.%03d_%02d built for %s",
1638 PATCHLEVEL, SUBVERSION, ARCHNAME);
1640 printf("\nThis is perl, version %s built for %s",
1641 patchlevel, ARCHNAME);
1643 #if defined(LOCAL_PATCH_COUNT)
1644 if (LOCAL_PATCH_COUNT > 0)
1645 printf("\n(with %d registered patch%s, see perl -V for more detail)",
1646 LOCAL_PATCH_COUNT, (LOCAL_PATCH_COUNT!=1) ? "es" : "");
1649 printf("\n\nCopyright 1987-1998, Larry Wall\n");
1651 printf("\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
1654 printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n");
1655 printf("djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1998\n");
1658 printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
1659 "Version 5 port Copyright (c) 1994-1998, Andreas Kaiser, Ilya Zakharevich\n");
1662 printf("atariST series port, ++jrb bammi@cadence.com\n");
1665 Perl may be copied only under the terms of either the Artistic License or the\n\
1666 GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n");
1674 if (s[1] == '-') /* Additional switches on #! line. */
1685 #ifdef ALTERNATE_SHEBANG
1686 case 'S': /* OS/2 needs -S on "extproc" line. */
1694 croak("Can't emulate -%.1s on #! line",s);
1699 /* compliments of Tom Christiansen */
1701 /* unexec() can be found in the Gnu emacs distribution */
1712 prog = newSVpv(BIN_EXP);
1713 sv_catpv(prog, "/perl");
1714 file = newSVpv(origfilename);
1715 sv_catpv(file, ".perldump");
1717 status = unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
1719 PerlIO_printf(PerlIO_stderr(), "unexec of %s into %s failed!\n",
1720 SvPVX(prog), SvPVX(file));
1721 PerlProc_exit(status);
1724 # include <lib$routines.h>
1725 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
1727 ABORT(); /* for use with undump */
1733 init_main_stash(void)
1738 /* Note that strtab is a rather special HV. Assumptions are made
1739 about not iterating on it, and not adding tie magic to it.
1740 It is properly deallocated in perl_destruct() */
1742 HvSHAREKEYS_off(strtab); /* mandatory */
1743 Newz(506,((XPVHV*)SvANY(strtab))->xhv_array,
1744 sizeof(HE*) * (((XPVHV*)SvANY(strtab))->xhv_max + 1), char);
1746 curstash = defstash = newHV();
1747 curstname = newSVpv("main",4);
1748 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
1749 SvREFCNT_dec(GvHV(gv));
1750 GvHV(gv) = (HV*)SvREFCNT_inc(defstash);
1752 HvNAME(defstash) = savepv("main");
1753 incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
1755 defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
1756 errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
1758 (void)form("%240s",""); /* Preallocate temp - for immediate signals. */
1759 sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */
1760 sv_setpvn(ERRSV, "", 0);
1761 curstash = defstash;
1762 compiling.cop_stash = defstash;
1763 debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
1764 globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
1765 /* We must init $/ before switches are processed. */
1766 sv_setpvn(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), "\n", 1);
1770 open_script(char *scriptname, bool dosearch, SV *sv)
1773 char *xfound = Nullch;
1774 char *xfailed = Nullch;
1778 #if defined(DOSISH) && !defined(OS2) && !defined(atarist)
1779 # define SEARCH_EXTS ".bat", ".cmd", NULL
1780 # define MAX_EXT_LEN 4
1783 # define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL
1784 # define MAX_EXT_LEN 4
1787 # define SEARCH_EXTS ".pl", ".com", NULL
1788 # define MAX_EXT_LEN 4
1790 /* additional extensions to try in each dir if scriptname not found */
1792 char *ext[] = { SEARCH_EXTS };
1793 int extidx = 0, i = 0;
1794 char *curext = Nullch;
1796 # define MAX_EXT_LEN 0
1800 * If dosearch is true and if scriptname does not contain path
1801 * delimiters, search the PATH for scriptname.
1803 * If SEARCH_EXTS is also defined, will look for each
1804 * scriptname{SEARCH_EXTS} whenever scriptname is not found
1805 * while searching the PATH.
1807 * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
1808 * proceeds as follows:
1809 * If DOSISH or VMSISH:
1810 * + look for ./scriptname{,.foo,.bar}
1811 * + search the PATH for scriptname{,.foo,.bar}
1814 * + look *only* in the PATH for scriptname{,.foo,.bar} (note
1815 * this will not look in '.' if it's not in the PATH)
1819 # ifdef ALWAYS_DEFTYPES
1820 len = strlen(scriptname);
1821 if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') {
1822 int hasdir, idx = 0, deftypes = 1;
1825 hasdir = !dosearch || (strpbrk(scriptname,":[</") != Nullch) ;
1828 int hasdir, idx = 0, deftypes = 1;
1831 hasdir = (strpbrk(scriptname,":[</") != Nullch) ;
1833 /* The first time through, just add SEARCH_EXTS to whatever we
1834 * already have, so we can check for default file types. */
1836 (!hasdir && my_trnlnm("DCL$PATH",tokenbuf,idx++)) )
1842 if ((strlen(tokenbuf) + strlen(scriptname)
1843 + MAX_EXT_LEN) >= sizeof tokenbuf)
1844 continue; /* don't search dir with too-long name */
1845 strcat(tokenbuf, scriptname);
1849 if (strEQ(scriptname, "-"))
1851 if (dosearch) { /* Look in '.' first. */
1852 char *cur = scriptname;
1854 if ((curext = strrchr(scriptname,'.'))) /* possible current ext */
1856 if (strEQ(ext[i++],curext)) {
1857 extidx = -1; /* already has an ext */
1862 DEBUG_p(PerlIO_printf(Perl_debug_log,
1863 "Looking for %s\n",cur));
1864 if (PerlLIO_stat(cur,&statbuf) >= 0) {
1872 if (cur == scriptname) {
1873 len = strlen(scriptname);
1874 if (len+MAX_EXT_LEN+1 >= sizeof(tokenbuf))
1876 cur = strcpy(tokenbuf, scriptname);
1878 } while (extidx >= 0 && ext[extidx] /* try an extension? */
1879 && strcpy(tokenbuf+len, ext[extidx++]));
1884 if (dosearch && !strchr(scriptname, '/')
1886 && !strchr(scriptname, '\\')
1888 && (s = PerlEnv_getenv("PATH"))) {
1891 bufend = s + strlen(s);
1892 while (s < bufend) {
1893 #if defined(atarist) || defined(DOSISH)
1898 && *s != ';'; len++, s++) {
1899 if (len < sizeof tokenbuf)
1902 if (len < sizeof tokenbuf)
1903 tokenbuf[len] = '\0';
1904 #else /* ! (atarist || DOSISH) */
1905 s = delimcpy(tokenbuf, tokenbuf + sizeof tokenbuf, s, bufend,
1908 #endif /* ! (atarist || DOSISH) */
1911 if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tokenbuf)
1912 continue; /* don't search dir with too-long name */
1914 #if defined(atarist) || defined(DOSISH)
1915 && tokenbuf[len - 1] != '/'
1916 && tokenbuf[len - 1] != '\\'
1919 tokenbuf[len++] = '/';
1920 if (len == 2 && tokenbuf[0] == '.')
1922 (void)strcpy(tokenbuf + len, scriptname);
1926 len = strlen(tokenbuf);
1927 if (extidx > 0) /* reset after previous loop */
1931 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tokenbuf));
1932 retval = PerlLIO_stat(tokenbuf,&statbuf);
1934 } while ( retval < 0 /* not there */
1935 && extidx>=0 && ext[extidx] /* try an extension? */
1936 && strcpy(tokenbuf+len, ext[extidx++])
1941 if (S_ISREG(statbuf.st_mode)
1942 && cando(S_IRUSR,TRUE,&statbuf)
1944 && cando(S_IXUSR,TRUE,&statbuf)
1948 xfound = tokenbuf; /* bingo! */
1952 xfailed = savepv(tokenbuf);
1955 if (!xfound && !seen_dot && !xfailed && (PerlLIO_stat(scriptname,&statbuf) < 0))
1957 seen_dot = 1; /* Disable message. */
1959 croak("Can't %s %s%s%s",
1960 (xfailed ? "execute" : "find"),
1961 (xfailed ? xfailed : scriptname),
1962 (xfailed ? "" : " on PATH"),
1963 (xfailed || seen_dot) ? "" : ", '.' not in PATH");
1966 scriptname = xfound;
1969 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
1970 char *s = scriptname + 8;
1979 origfilename = savepv(e_tmpname ? "-e" : scriptname);
1980 curcop->cop_filegv = gv_fetchfile(origfilename);
1981 if (strEQ(origfilename,"-"))
1983 if (fdscript >= 0) {
1984 rsfp = PerlIO_fdopen(fdscript,PERL_SCRIPT_MODE);
1985 #if defined(HAS_FCNTL) && defined(F_SETFD)
1987 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
1990 else if (preprocess) {
1991 char *cpp_cfg = CPPSTDIN;
1992 SV *cpp = NEWSV(0,0);
1993 SV *cmd = NEWSV(0,0);
1995 if (strEQ(cpp_cfg, "cppstdin"))
1996 sv_catpvf(cpp, "%s/", BIN_EXP);
1997 sv_catpv(cpp, cpp_cfg);
2000 sv_catpv(sv,PRIVLIB_EXP);
2004 sed %s -e \"/^[^#]/b\" \
2005 -e \"/^#[ ]*include[ ]/b\" \
2006 -e \"/^#[ ]*define[ ]/b\" \
2007 -e \"/^#[ ]*if[ ]/b\" \
2008 -e \"/^#[ ]*ifdef[ ]/b\" \
2009 -e \"/^#[ ]*ifndef[ ]/b\" \
2010 -e \"/^#[ ]*else/b\" \
2011 -e \"/^#[ ]*elif[ ]/b\" \
2012 -e \"/^#[ ]*undef[ ]/b\" \
2013 -e \"/^#[ ]*endif/b\" \
2016 (doextract ? "-e \"1,/^#/d\n\"" : ""),
2019 %s %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' \
2036 (doextract ? "-e '1,/^#/d\n'" : ""),
2038 scriptname, cpp, sv, CPPMINUS);
2040 #ifdef IAMSUID /* actually, this is caught earlier */
2041 if (euid != uid && !euid) { /* if running suidperl */
2043 (void)seteuid(uid); /* musn't stay setuid root */
2046 (void)setreuid((Uid_t)-1, uid);
2048 #ifdef HAS_SETRESUID
2049 (void)setresuid((Uid_t)-1, uid, (Uid_t)-1);
2055 if (geteuid() != uid)
2056 croak("Can't do seteuid!\n");
2058 #endif /* IAMSUID */
2059 rsfp = PerlProc_popen(SvPVX(cmd), "r");
2063 else if (!*scriptname) {
2064 forbid_setid("program input from stdin");
2065 rsfp = PerlIO_stdin();
2068 rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
2069 #if defined(HAS_FCNTL) && defined(F_SETFD)
2071 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
2079 #ifndef IAMSUID /* in case script is not readable before setuid */
2080 if (euid && PerlLIO_stat(SvPVX(GvSV(curcop->cop_filegv)),&statbuf) >= 0 &&
2081 statbuf.st_mode & (S_ISUID|S_ISGID)) {
2083 PerlProc_execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
2084 croak("Can't do setuid\n");
2088 croak("Can't open perl script \"%s\": %s\n",
2089 SvPVX(GvSV(curcop->cop_filegv)), Strerror(errno));
2094 validate_suid(char *validarg, char *scriptname)
2098 /* do we need to emulate setuid on scripts? */
2100 /* This code is for those BSD systems that have setuid #! scripts disabled
2101 * in the kernel because of a security problem. Merely defining DOSUID
2102 * in perl will not fix that problem, but if you have disabled setuid
2103 * scripts in the kernel, this will attempt to emulate setuid and setgid
2104 * on scripts that have those now-otherwise-useless bits set. The setuid
2105 * root version must be called suidperl or sperlN.NNN. If regular perl
2106 * discovers that it has opened a setuid script, it calls suidperl with
2107 * the same argv that it had. If suidperl finds that the script it has
2108 * just opened is NOT setuid root, it sets the effective uid back to the
2109 * uid. We don't just make perl setuid root because that loses the
2110 * effective uid we had before invoking perl, if it was different from the
2113 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
2114 * be defined in suidperl only. suidperl must be setuid root. The
2115 * Configure script will set this up for you if you want it.
2122 if (PerlLIO_fstat(PerlIO_fileno(rsfp),&statbuf) < 0) /* normal stat is insecure */
2123 croak("Can't stat script \"%s\"",origfilename);
2124 if (fdscript < 0 && statbuf.st_mode & (S_ISUID|S_ISGID)) {
2128 #ifndef HAS_SETREUID
2129 /* On this access check to make sure the directories are readable,
2130 * there is actually a small window that the user could use to make
2131 * filename point to an accessible directory. So there is a faint
2132 * chance that someone could execute a setuid script down in a
2133 * non-accessible directory. I don't know what to do about that.
2134 * But I don't think it's too important. The manual lies when
2135 * it says access() is useful in setuid programs.
2137 if (PerlLIO_access(SvPVX(GvSV(curcop->cop_filegv)),1)) /*double check*/
2138 croak("Permission denied");
2140 /* If we can swap euid and uid, then we can determine access rights
2141 * with a simple stat of the file, and then compare device and
2142 * inode to make sure we did stat() on the same file we opened.
2143 * Then we just have to make sure he or she can execute it.
2146 struct stat tmpstatbuf;
2150 setreuid(euid,uid) < 0
2153 setresuid(euid,uid,(Uid_t)-1) < 0
2156 || getuid() != euid || geteuid() != uid)
2157 croak("Can't swap uid and euid"); /* really paranoid */
2158 if (PerlLIO_stat(SvPVX(GvSV(curcop->cop_filegv)),&tmpstatbuf) < 0)
2159 croak("Permission denied"); /* testing full pathname here */
2160 if (tmpstatbuf.st_dev != statbuf.st_dev ||
2161 tmpstatbuf.st_ino != statbuf.st_ino) {
2162 (void)PerlIO_close(rsfp);
2163 if (rsfp = PerlProc_popen("/bin/mail root","w")) { /* heh, heh */
2165 "User %ld tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
2166 (Filename of set-id script was %s, uid %ld gid %ld.)\n\nSincerely,\nperl\n",
2167 (long)uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
2168 (long)statbuf.st_dev, (long)statbuf.st_ino,
2169 SvPVX(GvSV(curcop->cop_filegv)),
2170 (long)statbuf.st_uid, (long)statbuf.st_gid);
2171 (void)PerlProc_pclose(rsfp);
2173 croak("Permission denied\n");
2177 setreuid(uid,euid) < 0
2179 # if defined(HAS_SETRESUID)
2180 setresuid(uid,euid,(Uid_t)-1) < 0
2183 || getuid() != uid || geteuid() != euid)
2184 croak("Can't reswap uid and euid");
2185 if (!cando(S_IXUSR,FALSE,&statbuf)) /* can real uid exec? */
2186 croak("Permission denied\n");
2188 #endif /* HAS_SETREUID */
2189 #endif /* IAMSUID */
2191 if (!S_ISREG(statbuf.st_mode))
2192 croak("Permission denied");
2193 if (statbuf.st_mode & S_IWOTH)
2194 croak("Setuid/gid script is writable by world");
2195 doswitches = FALSE; /* -s is insecure in suid */
2197 if (sv_gets(linestr, rsfp, 0) == Nullch ||
2198 strnNE(SvPV(linestr,na),"#!",2) ) /* required even on Sys V */
2199 croak("No #! line");
2200 s = SvPV(linestr,na)+2;
2202 while (!isSPACE(*s)) s++;
2203 for (s2 = s; (s2 > SvPV(linestr,na)+2 &&
2204 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
2205 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
2206 croak("Not a perl script");
2207 while (*s == ' ' || *s == '\t') s++;
2209 * #! arg must be what we saw above. They can invoke it by
2210 * mentioning suidperl explicitly, but they may not add any strange
2211 * arguments beyond what #! says if they do invoke suidperl that way.
2213 len = strlen(validarg);
2214 if (strEQ(validarg," PHOOEY ") ||
2215 strnNE(s,validarg,len) || !isSPACE(s[len]))
2216 croak("Args must match #! line");
2219 if (euid != uid && (statbuf.st_mode & S_ISUID) &&
2220 euid == statbuf.st_uid)
2222 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2223 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2224 #endif /* IAMSUID */
2226 if (euid) { /* oops, we're not the setuid root perl */
2227 (void)PerlIO_close(rsfp);
2230 PerlProc_execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
2232 croak("Can't do setuid\n");
2235 if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid) {
2237 (void)setegid(statbuf.st_gid);
2240 (void)setregid((Gid_t)-1,statbuf.st_gid);
2242 #ifdef HAS_SETRESGID
2243 (void)setresgid((Gid_t)-1,statbuf.st_gid,(Gid_t)-1);
2245 setgid(statbuf.st_gid);
2249 if (getegid() != statbuf.st_gid)
2250 croak("Can't do setegid!\n");
2252 if (statbuf.st_mode & S_ISUID) {
2253 if (statbuf.st_uid != euid)
2255 (void)seteuid(statbuf.st_uid); /* all that for this */
2258 (void)setreuid((Uid_t)-1,statbuf.st_uid);
2260 #ifdef HAS_SETRESUID
2261 (void)setresuid((Uid_t)-1,statbuf.st_uid,(Uid_t)-1);
2263 setuid(statbuf.st_uid);
2267 if (geteuid() != statbuf.st_uid)
2268 croak("Can't do seteuid!\n");
2270 else if (uid) { /* oops, mustn't run as root */
2272 (void)seteuid((Uid_t)uid);
2275 (void)setreuid((Uid_t)-1,(Uid_t)uid);
2277 #ifdef HAS_SETRESUID
2278 (void)setresuid((Uid_t)-1,(Uid_t)uid,(Uid_t)-1);
2284 if (geteuid() != uid)
2285 croak("Can't do seteuid!\n");
2288 if (!cando(S_IXUSR,TRUE,&statbuf))
2289 croak("Permission denied\n"); /* they can't do this */
2292 else if (preprocess)
2293 croak("-P not allowed for setuid/setgid script\n");
2294 else if (fdscript >= 0)
2295 croak("fd script not allowed in suidperl\n");
2297 croak("Script is not setuid/setgid in suidperl\n");
2299 /* We absolutely must clear out any saved ids here, so we */
2300 /* exec the real perl, substituting fd script for scriptname. */
2301 /* (We pass script name as "subdir" of fd, which perl will grok.) */
2302 PerlIO_rewind(rsfp);
2303 PerlLIO_lseek(PerlIO_fileno(rsfp),(Off_t)0,0); /* just in case rewind didn't */
2304 for (which = 1; origargv[which] && origargv[which] != scriptname; which++) ;
2305 if (!origargv[which])
2306 croak("Permission denied");
2307 origargv[which] = savepv(form("/dev/fd/%d/%s",
2308 PerlIO_fileno(rsfp), origargv[which]));
2309 #if defined(HAS_FCNTL) && defined(F_SETFD)
2310 fcntl(PerlIO_fileno(rsfp),F_SETFD,0); /* ensure no close-on-exec */
2312 PerlProc_execv(form("%s/perl%s", BIN_EXP, patchlevel), origargv); /* try again */
2313 croak("Can't do setuid\n");
2314 #endif /* IAMSUID */
2316 if (euid != uid || egid != gid) { /* (suidperl doesn't exist, in fact) */
2317 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
2319 PerlLIO_fstat(PerlIO_fileno(rsfp),&statbuf); /* may be either wrapped or real suid */
2320 if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
2322 (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
2325 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2326 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2327 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
2328 /* not set-id, must be wrapped */
2334 find_beginning(void)
2336 register char *s, *s2;
2338 /* skip forward in input to the real script? */
2342 if ((s = sv_gets(linestr, rsfp, 0)) == Nullch)
2343 croak("No Perl script found in input\n");
2344 if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
2345 PerlIO_ungetc(rsfp, '\n'); /* to keep line count right */
2347 while (*s && !(isSPACE (*s) || *s == '#')) s++;
2349 while (*s == ' ' || *s == '\t') s++;
2351 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
2352 if (strnEQ(s2-4,"perl",4))
2354 while (s = moreswitches(s)) ;
2356 if (cddir && PerlDir_chdir(cddir) < 0)
2357 croak("Can't chdir to %s",cddir);
2365 uid = (int)getuid();
2366 euid = (int)geteuid();
2367 gid = (int)getgid();
2368 egid = (int)getegid();
2373 tainting |= (uid && (euid != uid || egid != gid));
2377 forbid_setid(char *s)
2380 croak("No %s allowed while running setuid", s);
2382 croak("No %s allowed while running setgid", s);
2389 curstash = debstash;
2390 dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
2392 DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
2393 DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
2394 DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
2395 DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
2396 sv_setiv(DBsingle, 0);
2397 DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
2398 sv_setiv(DBtrace, 0);
2399 DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
2400 sv_setiv(DBsignal, 0);
2401 curstash = defstash;
2404 #ifndef STRESS_REALLOC
2405 #define REASONABLE(size) (size)
2407 #define REASONABLE(size) (1) /* unreasonable */
2411 init_stacks(ARGSproto)
2414 mainstack = curstack; /* remember in case we switch stacks */
2415 AvREAL_off(curstack); /* not a real array */
2416 av_extend(curstack,REASONABLE(127));
2418 stack_base = AvARRAY(curstack);
2419 stack_sp = stack_base;
2420 stack_max = stack_base + REASONABLE(127);
2422 /* Use most of 8K. */
2423 cxstack_max = REASONABLE(8192 / sizeof(PERL_CONTEXT) - 2);
2424 New(50,cxstack,cxstack_max + 1,PERL_CONTEXT);
2427 New(50,tmps_stack,REASONABLE(128),SV*);
2430 tmps_max = REASONABLE(128);
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,REASONABLE(32),I32);
2441 markstack_ptr = markstack;
2442 markstack_max = markstack + REASONABLE(32);
2448 New(54,scopestack,REASONABLE(32),I32);
2450 scopestack_max = REASONABLE(32);
2456 New(54,savestack,REASONABLE(128),ANY);
2458 savestack_max = REASONABLE(128);
2464 New(54,retstack,REASONABLE(16),OP*);
2466 retstack_max = REASONABLE(16);
2477 Safefree(tmps_stack);
2484 static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
2493 subname = newSVpv("main",4);
2497 init_predump_symbols(void)
2503 sv_setpvn(perl_get_sv("\"", TRUE), " ", 1);
2504 stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
2505 GvMULTI_on(stdingv);
2506 IoIFP(GvIOp(stdingv)) = PerlIO_stdin();
2507 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
2509 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(stdingv));
2511 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
2513 IoOFP(GvIOp(tmpgv)) = IoIFP(GvIOp(tmpgv)) = PerlIO_stdout();
2515 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
2517 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(defoutgv));
2519 othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
2520 GvMULTI_on(othergv);
2521 IoOFP(GvIOp(othergv)) = IoIFP(GvIOp(othergv)) = PerlIO_stderr();
2522 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
2524 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(othergv));
2526 statname = NEWSV(66,0); /* last filename we did stat on */
2529 osname = savepv(OSNAME);
2533 init_postdump_symbols(register int argc, register char **argv, register char **env)
2540 argc--,argv++; /* skip name of script */
2542 for (; argc > 0 && **argv == '-'; argc--,argv++) {
2545 if (argv[0][1] == '-') {
2549 if (s = strchr(argv[0], '=')) {
2551 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
2554 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
2557 toptarget = NEWSV(0,0);
2558 sv_upgrade(toptarget, SVt_PVFM);
2559 sv_setpvn(toptarget, "", 0);
2560 bodytarget = NEWSV(0,0);
2561 sv_upgrade(bodytarget, SVt_PVFM);
2562 sv_setpvn(bodytarget, "", 0);
2563 formtarget = bodytarget;
2566 if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
2567 sv_setpv(GvSV(tmpgv),origfilename);
2568 magicname("0", "0", 1);
2570 if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
2571 sv_setpv(GvSV(tmpgv),origargv[0]);
2572 if (argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
2574 (void)gv_AVadd(argvgv);
2575 av_clear(GvAVn(argvgv));
2576 for (; argc > 0; argc--,argv++) {
2577 av_push(GvAVn(argvgv),newSVpv(argv[0],0));
2580 if (envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
2584 hv_magic(hv, envgv, 'E');
2585 #ifndef VMS /* VMS doesn't have environ array */
2586 /* Note that if the supplied env parameter is actually a copy
2587 of the global environ then it may now point to free'd memory
2588 if the environment has been modified since. To avoid this
2589 problem we treat env==NULL as meaning 'use the default'
2594 environ[0] = Nullch;
2595 for (; *env; env++) {
2596 if (!(s = strchr(*env,'=')))
2599 #if defined(WIN32) || defined(MSDOS)
2602 sv = newSVpv(s--,0);
2603 (void)hv_store(hv, *env, s - *env, sv, 0);
2605 #if defined(__BORLANDC__) && defined(USE_WIN32_RTL_ENV)
2606 /* Sins of the RTL. See note in my_setenv(). */
2607 (void)PerlEnv_putenv(savepv(*env));
2611 #ifdef DYNAMIC_ENV_FETCH
2612 HvNAME(hv) = savepv(ENV_HV_NAME);
2616 if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
2617 sv_setiv(GvSV(tmpgv), (IV)getpid());
2626 s = PerlEnv_getenv("PERL5LIB");
2630 incpush(PerlEnv_getenv("PERLLIB"), FALSE);
2632 /* Treat PERL5?LIB as a possible search list logical name -- the
2633 * "natural" VMS idiom for a Unix path string. We allow each
2634 * element to be a set of |-separated directories for compatibility.
2638 if (my_trnlnm("PERL5LIB",buf,0))
2639 do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
2641 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE);
2645 /* Use the ~-expanded versions of APPLLIB (undocumented),
2646 ARCHLIB PRIVLIB SITEARCH and SITELIB
2649 incpush(APPLLIB_EXP, FALSE);
2653 incpush(ARCHLIB_EXP, FALSE);
2656 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
2658 incpush(PRIVLIB_EXP, FALSE);
2661 incpush(SITEARCH_EXP, FALSE);
2664 incpush(SITELIB_EXP, FALSE);
2667 incpush(".", FALSE);
2671 # define PERLLIB_SEP ';'
2674 # define PERLLIB_SEP '|'
2676 # define PERLLIB_SEP ':'
2679 #ifndef PERLLIB_MANGLE
2680 # define PERLLIB_MANGLE(s,n) (s)
2684 incpush(char *p, int addsubdirs)
2686 SV *subdir = Nullsv;
2687 static char *archpat_auto;
2693 subdir = NEWSV(55,0);
2694 if (!archpat_auto) {
2695 STRLEN len = (sizeof(ARCHNAME) + strlen(patchlevel)
2696 + sizeof("//auto"));
2697 New(55, archpat_auto, len, char);
2698 sprintf(archpat_auto, "/%s/%s/auto", ARCHNAME, patchlevel);
2700 for (len = sizeof(ARCHNAME) + 2;
2701 archpat_auto[len] != '\0' && archpat_auto[len] != '/'; len++)
2702 if (archpat_auto[len] == '.') archpat_auto[len] = '_';
2707 /* Break at all separators */
2709 SV *libdir = NEWSV(55,0);
2712 /* skip any consecutive separators */
2713 while ( *p == PERLLIB_SEP ) {
2714 /* Uncomment the next line for PATH semantics */
2715 /* av_push(GvAVn(incgv), newSVpv(".", 1)); */
2719 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
2720 sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
2725 sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
2726 p = Nullch; /* break out */
2730 * BEFORE pushing libdir onto @INC we may first push version- and
2731 * archname-specific sub-directories.
2734 struct stat tmpstatbuf;
2739 if ((unix = tounixspec_ts(SvPV(libdir,na),Nullch)) != Nullch) {
2741 while (unix[len-1] == '/') len--; /* Cosmetic */
2742 sv_usepvn(libdir,unix,len);
2745 PerlIO_printf(PerlIO_stderr(),
2746 "Failed to unixify @INC element \"%s\"\n",
2749 /* .../archname/version if -d .../archname/version/auto */
2750 sv_setsv(subdir, libdir);
2751 sv_catpv(subdir, archpat_auto);
2752 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2753 S_ISDIR(tmpstatbuf.st_mode))
2754 av_push(GvAVn(incgv),
2755 newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2757 /* .../archname if -d .../archname/auto */
2758 sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME),
2759 strlen(patchlevel) + 1, "", 0);
2760 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2761 S_ISDIR(tmpstatbuf.st_mode))
2762 av_push(GvAVn(incgv),
2763 newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2766 /* finally push this lib directory on the end of @INC */
2767 av_push(GvAVn(incgv), libdir);
2770 SvREFCNT_dec(subdir);
2774 static struct perl_thread *
2777 struct perl_thread *thr;
2780 Newz(53, thr, 1, struct perl_thread);
2781 curcop = &compiling;
2782 thr->cvcache = newHV();
2783 thr->threadsv = newAV();
2784 /* thr->threadsvp is set when find_threadsv is called */
2785 thr->specific = newAV();
2786 thr->errhv = newHV();
2787 thr->flags = THRf_R_JOINABLE;
2788 MUTEX_INIT(&thr->mutex);
2789 /* Handcraft thrsv similarly to mess_sv */
2790 New(53, thrsv, 1, SV);
2791 Newz(53, xpv, 1, XPV);
2792 SvFLAGS(thrsv) = SVt_PV;
2793 SvANY(thrsv) = (void*)xpv;
2794 SvREFCNT(thrsv) = 1 << 30; /* practically infinite */
2795 SvPVX(thrsv) = (char*)thr;
2796 SvCUR_set(thrsv, sizeof(thr));
2797 SvLEN_set(thrsv, sizeof(thr));
2798 *SvEND(thrsv) = '\0'; /* in the trailing_nul field */
2800 curcop = &compiling;
2803 MUTEX_LOCK(&threads_mutex);
2808 MUTEX_UNLOCK(&threads_mutex);
2810 #ifdef HAVE_THREAD_INTERN
2811 init_thread_intern(thr);
2814 #ifdef SET_THREAD_SELF
2815 SET_THREAD_SELF(thr);
2817 thr->self = pthread_self();
2818 #endif /* SET_THREAD_SELF */
2822 * These must come after the SET_THR because sv_setpvn does
2823 * SvTAINT and the taint fields require dTHR.
2825 toptarget = NEWSV(0,0);
2826 sv_upgrade(toptarget, SVt_PVFM);
2827 sv_setpvn(toptarget, "", 0);
2828 bodytarget = NEWSV(0,0);
2829 sv_upgrade(bodytarget, SVt_PVFM);
2830 sv_setpvn(bodytarget, "", 0);
2831 formtarget = bodytarget;
2832 thr->errsv = newSVpv("", 0);
2833 (void) find_threadsv("@"); /* Ensure $@ is initialised early */
2836 #endif /* USE_THREADS */
2839 call_list(I32 oldscope, AV *list)
2842 line_t oldline = curcop->cop_line;
2847 while (AvFILL(list) >= 0) {
2848 CV *cv = (CV*)av_shift(list);
2857 perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
2858 (void)SvPV(atsv, len);
2861 curcop = &compiling;
2862 curcop->cop_line = oldline;
2863 if (list == beginav)
2864 sv_catpv(atsv, "BEGIN failed--compilation aborted");
2866 sv_catpv(atsv, "END failed--cleanup aborted");
2867 while (scopestack_ix > oldscope)
2869 croak("%s", SvPVX(atsv));
2877 /* my_exit() was called */
2878 while (scopestack_ix > oldscope)
2881 curstash = defstash;
2883 call_list(oldscope, endav);
2885 curcop = &compiling;
2886 curcop->cop_line = oldline;
2888 if (list == beginav)
2889 croak("BEGIN failed--compilation aborted");
2891 croak("END failed--cleanup aborted");
2897 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
2902 curcop = &compiling;
2903 curcop->cop_line = oldline;
2916 DEBUG_L(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
2917 thr, (unsigned long) status));
2918 #endif /* USE_THREADS */
2927 STATUS_NATIVE_SET(status);
2934 my_failure_exit(void)
2937 if (vaxc$errno & 1) {
2938 if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
2939 STATUS_NATIVE_SET(44);
2942 if (!vaxc$errno && errno) /* unlikely */
2943 STATUS_NATIVE_SET(44);
2945 STATUS_NATIVE_SET(vaxc$errno);
2949 STATUS_POSIX_SET(errno);
2950 else if (STATUS_POSIX == 0)
2951 STATUS_POSIX_SET(255);
2960 register PERL_CONTEXT *cx;
2969 (void)UNLINK(e_tmpname);
2970 Safefree(e_tmpname);
2974 if (cxstack_ix >= 0) {