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);
134 thr = init_main_thread();
135 #endif /* USE_THREADS */
137 linestr = NEWSV(65,80);
138 sv_upgrade(linestr,SVt_PVIV);
140 if (!SvREADONLY(&sv_undef)) {
141 SvREADONLY_on(&sv_undef);
145 SvREADONLY_on(&sv_no);
147 sv_setpv(&sv_yes,Yes);
149 SvREADONLY_on(&sv_yes);
152 nrs = newSVpv("\n", 1);
153 rs = SvREFCNT_inc(nrs);
155 sighandlerp = sighandler;
160 * There is no way we can refer to them from Perl so close them to save
161 * space. The other alternative would be to provide STDAUX and STDPRN
164 (void)fclose(stdaux);
165 (void)fclose(stdprn);
171 perl_destruct_level = 1;
173 if(perl_destruct_level > 0)
178 lex_state = LEX_NOTPARSING;
180 start_env.je_prev = NULL;
181 start_env.je_ret = -1;
182 start_env.je_mustcatch = TRUE;
183 top_env = &start_env;
186 SET_NUMERIC_STANDARD();
187 #if defined(SUBVERSION) && SUBVERSION > 0
188 sprintf(patchlevel, "%7.5f", (double) 5
189 + ((double) PATCHLEVEL / (double) 1000)
190 + ((double) SUBVERSION / (double) 100000));
192 sprintf(patchlevel, "%5.3f", (double) 5 +
193 ((double) PATCHLEVEL / (double) 1000));
196 #if defined(LOCAL_PATCH_COUNT)
197 localpatches = local_patches; /* For possible -v */
200 PerlIO_init(); /* Hook to IO system */
202 fdpid = newAV(); /* for remembering popen pids by fd */
206 New(51,debname,128,char);
207 New(52,debdelim,128,char);
214 perl_destruct(register PerlInterpreter *sv_interp)
217 int destruct_level; /* 0=none, 1=full, 2=full with checks */
222 #endif /* USE_THREADS */
224 if (!(curinterp = sv_interp))
229 /* Pass 1 on any remaining threads: detach joinables, join zombies */
231 MUTEX_LOCK(&threads_mutex);
232 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
233 "perl_destruct: waiting for %d threads...\n",
235 for (t = thr->next; t != thr; t = t->next) {
236 MUTEX_LOCK(&t->mutex);
237 switch (ThrSTATE(t)) {
240 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
241 "perl_destruct: joining zombie %p\n", t));
242 ThrSETSTATE(t, THRf_DEAD);
243 MUTEX_UNLOCK(&t->mutex);
246 * The SvREFCNT_dec below may take a long time (e.g. av
247 * may contain an object scalar whose destructor gets
248 * called) so we have to unlock threads_mutex and start
251 MUTEX_UNLOCK(&threads_mutex);
253 SvREFCNT_dec((SV*)av);
254 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
255 "perl_destruct: joined zombie %p OK\n", t));
257 case THRf_R_JOINABLE:
258 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
259 "perl_destruct: detaching thread %p\n", t));
260 ThrSETSTATE(t, THRf_R_DETACHED);
262 * We unlock threads_mutex and t->mutex in the opposite order
263 * from which we locked them just so that DETACH won't
264 * deadlock if it panics. It's only a breach of good style
265 * not a bug since they are unlocks not locks.
267 MUTEX_UNLOCK(&threads_mutex);
269 MUTEX_UNLOCK(&t->mutex);
272 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
273 "perl_destruct: ignoring %p (state %u)\n",
275 MUTEX_UNLOCK(&t->mutex);
276 /* fall through and out */
279 /* We leave the above "Pass 1" loop with threads_mutex still locked */
281 /* Pass 2 on remaining threads: wait for the thread count to drop to one */
284 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
285 "perl_destruct: final wait for %d threads\n",
287 COND_WAIT(&nthreads_cond, &threads_mutex);
289 /* At this point, we're the last thread */
290 MUTEX_UNLOCK(&threads_mutex);
291 DEBUG_L(PerlIO_printf(PerlIO_stderr(), "perl_destruct: armageddon has arrived\n"));
292 MUTEX_DESTROY(&threads_mutex);
293 COND_DESTROY(&nthreads_cond);
294 #endif /* !defined(FAKE_THREADS) */
295 #endif /* USE_THREADS */
297 destruct_level = perl_destruct_level;
301 if (s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL")) {
303 if (destruct_level < i)
312 /* We must account for everything. */
314 /* Destroy the main CV and syntax tree */
316 curpad = AvARRAY(comppad);
321 SvREFCNT_dec(main_cv);
326 * Try to destruct global references. We do this first so that the
327 * destructors and destructees still exist. Some sv's might remain.
328 * Non-referenced objects are on their own.
335 /* unhook hooks which will soon be, or use, destroyed data */
336 SvREFCNT_dec(warnhook);
338 SvREFCNT_dec(diehook);
340 SvREFCNT_dec(parsehook);
343 if (destruct_level == 0){
345 DEBUG_P(debprofdump());
347 /* The exit() function will do everything that needs doing. */
351 /* loosen bonds of global variables */
354 (void)PerlIO_close(rsfp);
358 /* Filters for program text */
359 SvREFCNT_dec(rsfp_filters);
360 rsfp_filters = Nullav;
372 sawampersand = FALSE; /* must save all match strings */
373 sawstudy = FALSE; /* do fbm_instr on all strings */
388 /* magical thingies */
390 Safefree(ofs); /* $, */
393 Safefree(ors); /* $\ */
396 SvREFCNT_dec(nrs); /* $\ helper */
399 multiline = 0; /* $* */
401 SvREFCNT_dec(statname);
405 /* defgv, aka *_ should be taken care of elsewhere */
407 /* clean up after study() */
408 SvREFCNT_dec(lastscream);
410 Safefree(screamfirst);
412 Safefree(screamnext);
415 /* startup and shutdown function lists */
416 SvREFCNT_dec(beginav);
418 SvREFCNT_dec(initav);
423 /* temp stack during pp_sort() */
424 SvREFCNT_dec(sortstack);
427 /* shortcuts just get cleared */
437 /* reset so print() ends up where we expect */
440 /* Prepare to destruct main symbol table. */
447 if (destruct_level >= 2) {
448 if (scopestack_ix != 0)
449 warn("Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
450 (long)scopestack_ix);
451 if (savestack_ix != 0)
452 warn("Unbalanced saves: %ld more saves than restores\n",
454 if (tmps_floor != -1)
455 warn("Unbalanced tmps: %ld more allocs than frees\n",
456 (long)tmps_floor + 1);
457 if (cxstack_ix != -1)
458 warn("Unbalanced context: %ld more PUSHes than POPs\n",
459 (long)cxstack_ix + 1);
462 /* Now absolutely destruct everything, somehow or other, loops or no. */
464 SvFLAGS(strtab) |= SVTYPEMASK; /* don't clean out strtab now */
465 while (sv_count != 0 && sv_count != last_sv_count) {
466 last_sv_count = sv_count;
469 SvFLAGS(strtab) &= ~SVTYPEMASK;
470 SvFLAGS(strtab) |= SVt_PVHV;
472 /* Destruct the global string table. */
474 /* Yell and reset the HeVAL() slots that are still holding refcounts,
475 * so that sv_free() won't fail on them.
484 array = HvARRAY(strtab);
488 warn("Unbalanced string table refcount: (%d) for \"%s\"",
489 HeVAL(hent) - Nullsv, HeKEY(hent));
490 HeVAL(hent) = Nullsv;
500 SvREFCNT_dec(strtab);
503 warn("Scalars leaked: %ld\n", (long)sv_count);
507 /* No SVs have survived, need to clean out */
511 Safefree(origfilename);
513 hints = 0; /* Reset hints. Should hints be per-interpreter ? */
515 DEBUG_P(debprofdump());
517 MUTEX_DESTROY(&sv_mutex);
518 MUTEX_DESTROY(&eval_mutex);
519 COND_DESTROY(&eval_cond);
521 /* As the penultimate thing, free the non-arena SV for thrsv */
522 Safefree(SvPVX(thrsv));
523 Safefree(SvANY(thrsv));
526 #endif /* USE_THREADS */
528 /* As the absolutely last thing, free the non-arena SV for mess() */
531 /* we know that type >= SVt_PV */
533 Safefree(SvPVX(mess_sv));
534 Safefree(SvANY(mess_sv));
541 perl_free(PerlInterpreter *sv_interp)
543 if (!(curinterp = sv_interp))
549 perl_parse(PerlInterpreter *sv_interp, void (*xsinit) (void), int argc, char **argv, char **env)
554 char *scriptname = NULL;
555 VOL bool dosearch = FALSE;
562 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
565 croak("suidperl is no longer needed since the kernel can now execute\n\
566 setuid perl scripts securely.\n");
570 if (!(curinterp = sv_interp))
573 #if defined(NeXT) && defined(__DYNAMIC__)
574 _dyld_lookup_and_bind
575 ("__environ", (unsigned long *) &environ_pointer, NULL);
580 #ifndef VMS /* VMS doesn't have environ array */
581 origenviron = environ;
587 /* Come here if running an undumped a.out. */
589 origfilename = savepv(argv[0]);
591 cxstack_ix = -1; /* start label stack again */
593 init_postdump_symbols(argc,argv,env);
598 curpad = AvARRAY(comppad);
603 SvREFCNT_dec(main_cv);
607 oldscope = scopestack_ix;
615 /* my_exit() was called */
616 while (scopestack_ix > oldscope)
621 call_list(oldscope, endav);
623 return STATUS_NATIVE_EXPORT;
626 PerlIO_printf(PerlIO_stderr(), "panic: top_env\n");
630 sv_setpvn(linestr,"",0);
631 sv = newSVpv("",0); /* first used for -I flags */
635 for (argc--,argv++; argc > 0; argc--,argv++) {
636 if (argv[0][0] != '-' || !argv[0][1])
640 validarg = " PHOOEY ";
665 if (s = moreswitches(s))
675 if (euid != uid || egid != gid)
676 croak("No -e allowed in setuid scripts");
678 e_tmpname = savepv(TMPPATH);
679 (void)PerlLIO_mktemp(e_tmpname);
681 croak("Can't mktemp()");
682 e_fp = PerlIO_open(e_tmpname,"w");
684 croak("Cannot open temporary file");
689 PerlIO_puts(e_fp,argv[1]);
693 croak("No code specified for -e");
694 (void)PerlIO_putc(e_fp,'\n');
696 case 'I': /* -I handled both here and in moreswitches() */
698 if (!*++s && (s=argv[1]) != Nullch) {
701 while (s && isSPACE(*s))
705 for (e = s; *e && !isSPACE(*e); e++) ;
712 } /* XXX else croak? */
726 preambleav = newAV();
727 av_push(preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
729 Sv = newSVpv("print myconfig();",0);
731 sv_catpv(Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
733 sv_catpv(Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
735 #if defined(DEBUGGING) || defined(NO_EMBED) || defined(MULTIPLICITY)
736 sv_catpv(Sv,"\" Compile-time options:");
738 sv_catpv(Sv," DEBUGGING");
741 sv_catpv(Sv," NO_EMBED");
744 sv_catpv(Sv," MULTIPLICITY");
746 sv_catpv(Sv,"\\n\",");
748 #if defined(LOCAL_PATCH_COUNT)
749 if (LOCAL_PATCH_COUNT > 0) {
751 sv_catpv(Sv,"\" Locally applied patches:\\n\",");
752 for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
754 sv_catpvf(Sv,"\" \\t%s\\n\",",localpatches[i]);
758 sv_catpvf(Sv,"\" Built under %s\\n\"",OSNAME);
761 sv_catpvf(Sv,",\" Compiled at %s %s\\n\"",__DATE__,__TIME__);
763 sv_catpvf(Sv,",\" Compiled on %s\\n\"",__DATE__);
768 @env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; \
769 print \" \\%ENV:\\n @env\\n\" if @env; \
770 print \" \\@INC:\\n @INC\\n\";");
773 Sv = newSVpv("config_vars(qw(",0);
778 av_push(preambleav, Sv);
779 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
790 if (!*++s || isSPACE(*s)) {
794 /* catch use of gnu style long options */
795 if (strEQ(s, "version")) {
799 if (strEQ(s, "help")) {
806 croak("Unrecognized switch: -%s (-h will show valid options)",s);
811 if (!tainting && (s = PerlEnv_getenv("PERL5OPT"))) {
822 if (!strchr("DIMUdmw", *s))
823 croak("Illegal switch in PERL5OPT: -%c", *s);
829 scriptname = argv[0];
831 if (PerlIO_flush(e_fp) || PerlIO_error(e_fp) || PerlIO_close(e_fp)) {
833 warn("Did you forget to compile with -DMULTIPLICITY?");
835 croak("Can't write to temp file for -e: %s", Strerror(errno));
839 scriptname = e_tmpname;
841 else if (scriptname == Nullch) {
843 if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) )
851 open_script(scriptname,dosearch,sv);
853 validate_suid(validarg, scriptname);
858 main_cv = compcv = (CV*)NEWSV(1104,0);
859 sv_upgrade((SV *)compcv, SVt_PVCV);
863 av_push(comppad, Nullsv);
864 curpad = AvARRAY(comppad);
865 comppad_name = newAV();
866 comppad_name_fill = 0;
867 min_intro_pending = 0;
870 av_store(comppad_name, 0, newSVpv("@_", 2));
871 curpad[0] = (SV*)newAV();
872 SvPADMY_on(curpad[0]); /* XXX Needed? */
874 New(666, CvMUTEXP(compcv), 1, perl_mutex);
875 MUTEX_INIT(CvMUTEXP(compcv));
876 #endif /* USE_THREADS */
878 comppadlist = newAV();
879 AvREAL_off(comppadlist);
880 av_store(comppadlist, 0, (SV*)comppad_name);
881 av_store(comppadlist, 1, (SV*)comppad);
882 CvPADLIST(compcv) = comppadlist;
884 boot_core_UNIVERSAL();
886 (*xsinit)(); /* in case linked C routines want magical variables */
887 #if defined(VMS) || defined(WIN32) || defined(DJGPP)
891 init_predump_symbols();
893 init_postdump_symbols(argc,argv,env);
897 /* now parse the script */
899 SETERRNO(0,SS$_NORMAL);
901 if (yyparse() || error_count) {
903 croak("%s had compilation errors.\n", origfilename);
905 croak("Execution of %s aborted due to compilation errors.\n",
909 curcop->cop_line = 0;
913 (void)UNLINK(e_tmpname);
918 /* now that script is parsed, we can modify record separator */
920 rs = SvREFCNT_inc(nrs);
921 sv_setsv(perl_get_sv("/", TRUE), rs);
932 if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
933 dump_mstats("after compilation:");
943 perl_run(PerlInterpreter *sv_interp)
950 if (!(curinterp = sv_interp))
953 oldscope = scopestack_ix;
958 cxstack_ix = -1; /* start context stack again */
961 /* my_exit() was called */
962 while (scopestack_ix > oldscope)
967 call_list(oldscope, endav);
969 if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
970 dump_mstats("after execution: ");
973 return STATUS_NATIVE_EXPORT;
976 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
981 if (curstack != mainstack) {
983 SWITCHSTACK(curstack, mainstack);
988 DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
989 sawampersand ? "Enabling" : "Omitting"));
993 DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
995 DEBUG_L(PerlIO_printf(Perl_debug_log, "main thread is 0x%lx\n",
996 (unsigned long) thr));
997 #endif /* USE_THREADS */
1000 PerlIO_printf(PerlIO_stderr(), "%s syntax OK\n", origfilename);
1003 if (PERLDB_SINGLE && DBsingle)
1004 sv_setiv(DBsingle, 1);
1006 call_list(oldscope, initav);
1016 else if (main_start) {
1017 CvDEPTH(main_cv) = 1;
1028 perl_get_sv(char *name, I32 create)
1032 if (name[1] == '\0' && !isALPHA(name[0])) {
1033 PADOFFSET tmp = find_threadsv(name);
1034 if (tmp != NOT_IN_PAD) {
1036 return THREADSV(tmp);
1039 #endif /* USE_THREADS */
1040 gv = gv_fetchpv(name, create, SVt_PV);
1047 perl_get_av(char *name, I32 create)
1049 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
1058 perl_get_hv(char *name, I32 create)
1060 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
1069 perl_get_cv(char *name, I32 create)
1071 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
1072 if (create && !GvCVu(gv))
1073 return newSUB(start_subparse(FALSE, 0),
1074 newSVOP(OP_CONST, 0, newSVpv(name,0)),
1082 /* Be sure to refetch the stack pointer after calling these routines. */
1085 perl_call_argv(char *sub_name, I32 flags, register char **argv)
1087 /* See G_* flags in cop.h */
1088 /* null terminated arg list */
1095 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
1100 return perl_call_pv(sub_name, flags);
1104 perl_call_pv(char *sub_name, I32 flags)
1105 /* name of the subroutine */
1106 /* See G_* flags in cop.h */
1108 return perl_call_sv((SV*)perl_get_cv(sub_name, TRUE), flags);
1112 perl_call_method(char *methname, I32 flags)
1113 /* name of the subroutine */
1114 /* See G_* flags in cop.h */
1120 XPUSHs(sv_2mortal(newSVpv(methname,0)));
1123 return perl_call_sv(*stack_sp--, flags);
1126 /* May be called with any of a CV, a GV, or an SV containing the name. */
1128 perl_call_sv(SV *sv, I32 flags)
1130 /* See G_* flags in cop.h */
1133 LOGOP myop; /* fake syntax tree node */
1139 bool oldcatch = CATCH_GET;
1144 if (flags & G_DISCARD) {
1149 Zero(&myop, 1, LOGOP);
1150 myop.op_next = Nullop;
1151 if (!(flags & G_NOARGS))
1152 myop.op_flags |= OPf_STACKED;
1153 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1154 (flags & G_ARRAY) ? OPf_WANT_LIST :
1159 EXTEND(stack_sp, 1);
1162 oldscope = scopestack_ix;
1164 if (PERLDB_SUB && curstash != debstash
1165 /* Handle first BEGIN of -d. */
1166 && (DBcv || (DBcv = GvCV(DBsub)))
1167 /* Try harder, since this may have been a sighandler, thus
1168 * curstash may be meaningless. */
1169 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != debstash))
1170 op->op_private |= OPpENTERSUB_DB;
1172 if (flags & G_EVAL) {
1173 cLOGOP->op_other = op;
1175 /* we're trying to emulate pp_entertry() here */
1177 register PERL_CONTEXT *cx;
1178 I32 gimme = GIMME_V;
1183 push_return(op->op_next);
1184 PUSHBLOCK(cx, CXt_EVAL, stack_sp);
1186 eval_root = op; /* Only needed so that goto works right. */
1189 if (flags & G_KEEPERR)
1204 /* my_exit() was called */
1205 curstash = defstash;
1209 croak("Callback called exit");
1218 stack_sp = stack_base + oldmark;
1219 if (flags & G_ARRAY)
1223 *++stack_sp = &sv_undef;
1231 if (op == (OP*)&myop)
1232 op = pp_entersub(ARGS);
1235 retval = stack_sp - (stack_base + oldmark);
1236 if ((flags & G_EVAL) && !(flags & G_KEEPERR))
1240 if (flags & G_EVAL) {
1241 if (scopestack_ix > oldscope) {
1245 register PERL_CONTEXT *cx;
1257 CATCH_SET(oldcatch);
1259 if (flags & G_DISCARD) {
1260 stack_sp = stack_base + oldmark;
1269 /* Eval a string. The G_EVAL flag is always assumed. */
1272 perl_eval_sv(SV *sv, I32 flags)
1274 /* See G_* flags in cop.h */
1277 UNOP myop; /* fake syntax tree node */
1279 I32 oldmark = sp - stack_base;
1286 if (flags & G_DISCARD) {
1294 EXTEND(stack_sp, 1);
1296 oldscope = scopestack_ix;
1298 if (!(flags & G_NOARGS))
1299 myop.op_flags = OPf_STACKED;
1300 myop.op_next = Nullop;
1301 myop.op_type = OP_ENTEREVAL;
1302 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1303 (flags & G_ARRAY) ? OPf_WANT_LIST :
1305 if (flags & G_KEEPERR)
1306 myop.op_flags |= OPf_SPECIAL;
1316 /* my_exit() was called */
1317 curstash = defstash;
1321 croak("Callback called exit");
1330 stack_sp = stack_base + oldmark;
1331 if (flags & G_ARRAY)
1335 *++stack_sp = &sv_undef;
1340 if (op == (OP*)&myop)
1341 op = pp_entereval(ARGS);
1344 retval = stack_sp - (stack_base + oldmark);
1345 if (!(flags & G_KEEPERR))
1350 if (flags & G_DISCARD) {
1351 stack_sp = stack_base + oldmark;
1361 perl_eval_pv(char *p, I32 croak_on_error)
1364 SV* sv = newSVpv(p, 0);
1367 perl_eval_sv(sv, G_SCALAR);
1374 if (croak_on_error && SvTRUE(ERRSV))
1375 croak(SvPVx(ERRSV, na));
1380 /* Require a module. */
1383 perl_require_pv(char *pv)
1385 SV* sv = sv_newmortal();
1386 sv_setpv(sv, "require '");
1389 perl_eval_sv(sv, G_DISCARD);
1393 magicname(char *sym, char *name, I32 namlen)
1397 if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
1398 sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
1402 usage(char *name) /* XXX move this out into a module ? */
1405 /* This message really ought to be max 23 lines.
1406 * Removed -h because the user already knows that opton. Others? */
1408 static char *usage[] = {
1409 "-0[octal] specify record separator (\\0, if no argument)",
1410 "-a autosplit mode with -n or -p (splits $_ into @F)",
1411 "-c check syntax only (runs BEGIN and END blocks)",
1412 "-d[:debugger] run scripts under debugger",
1413 "-D[number/list] set debugging flags (argument is a bit mask or flags)",
1414 "-e 'command' one line of script. Several -e's allowed. Omit [programfile].",
1415 "-F/pattern/ split() pattern for autosplit (-a). The //'s are optional.",
1416 "-i[extension] edit <> files in place (make backup if extension supplied)",
1417 "-Idirectory specify @INC/#include directory (may be used more than once)",
1418 "-l[octal] enable line ending processing, specifies line terminator",
1419 "-[mM][-]module.. executes `use/no module...' before executing your script.",
1420 "-n assume 'while (<>) { ... }' loop around your script",
1421 "-p assume loop like -n but print line also like sed",
1422 "-P run script through C preprocessor before compilation",
1423 "-s enable some switch parsing for switches after script name",
1424 "-S look for the script using PATH environment variable",
1425 "-T turn on tainting checks",
1426 "-u dump core after parsing script",
1427 "-U allow unsafe operations",
1428 "-v print version number and patchlevel of perl",
1429 "-V[:variable] print perl configuration information",
1430 "-w TURN WARNINGS ON FOR COMPILATION OF YOUR SCRIPT. Recommended.",
1431 "-x[directory] strip off text before #!perl line and perhaps cd to directory",
1437 printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
1439 printf("\n %s", *p++);
1442 /* This routine handles any switches that can be given during run */
1445 moreswitches(char *s)
1454 rschar = scan_oct(s, 4, &numlen);
1456 if (rschar & ~((U8)~0))
1458 else if (!rschar && numlen >= 2)
1459 nrs = newSVpv("", 0);
1462 nrs = newSVpv(&ch, 1);
1468 splitstr = savepv(s + 1);
1482 if (*s == ':' || *s == '=') {
1483 my_setenv("PERL5DB", form("use Devel::%s;", ++s));
1487 perldb = PERLDB_ALL;
1494 if (isALPHA(s[1])) {
1495 static char debopts[] = "psltocPmfrxuLHXD";
1498 for (s++; *s && (d = strchr(debopts,*s)); s++)
1499 debug |= 1 << (d - debopts);
1503 for (s++; isDIGIT(*s); s++) ;
1505 debug |= 0x80000000;
1507 warn("Recompile perl with -DDEBUGGING to use -D switch\n");
1508 for (s++; isALNUM(*s); s++) ;
1518 inplace = savepv(s+1);
1520 for (s = inplace; *s && !isSPACE(*s); s++) ;
1524 case 'I': /* -I handled both here and in parse_perl() */
1527 while (*s && isSPACE(*s))
1531 for (e = s; *e && !isSPACE(*e); e++) ;
1532 p = savepvn(s, e-s);
1538 croak("No space allowed after -I");
1548 *ors = scan_oct(s, 3 + (*s == '0'), &numlen);
1558 ors = SvPV(nrs, orslen);
1559 ors = savepvn(ors, orslen);
1563 forbid_setid("-M"); /* XXX ? */
1566 forbid_setid("-m"); /* XXX ? */
1571 /* -M-foo == 'no foo' */
1572 if (*s == '-') { use = "no "; ++s; }
1573 sv = newSVpv(use,0);
1575 /* We allow -M'Module qw(Foo Bar)' */
1576 while(isALNUM(*s) || *s==':') ++s;
1578 sv_catpv(sv, start);
1579 if (*(start-1) == 'm') {
1581 croak("Can't use '%c' after -mname", *s);
1582 sv_catpv( sv, " ()");
1585 sv_catpvn(sv, start, s-start);
1586 sv_catpv(sv, " split(/,/,q{");
1591 if (preambleav == NULL)
1592 preambleav = newAV();
1593 av_push(preambleav, sv);
1596 croak("No space allowed after -%c", *(s-1));
1613 croak("Too late for \"-T\" option");
1625 #if defined(SUBVERSION) && SUBVERSION > 0
1626 printf("\nThis is perl, version 5.%03d_%02d built for %s",
1627 PATCHLEVEL, SUBVERSION, ARCHNAME);
1629 printf("\nThis is perl, version %s built for %s",
1630 patchlevel, ARCHNAME);
1632 #if defined(LOCAL_PATCH_COUNT)
1633 if (LOCAL_PATCH_COUNT > 0)
1634 printf("\n(with %d registered patch%s, see perl -V for more detail)",
1635 LOCAL_PATCH_COUNT, (LOCAL_PATCH_COUNT!=1) ? "es" : "");
1638 printf("\n\nCopyright 1987-1998, Larry Wall\n");
1640 printf("\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
1643 printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n");
1644 printf("djgpp v2 port (perl5004) by Laszlo Molnar, 1997\n");
1647 printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
1648 "Version 5 port Copyright (c) 1994-1998, Andreas Kaiser, Ilya Zakharevich\n");
1651 printf("atariST series port, ++jrb bammi@cadence.com\n");
1654 Perl may be copied only under the terms of either the Artistic License or the\n\
1655 GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n");
1663 if (s[1] == '-') /* Additional switches on #! line. */
1674 #ifdef ALTERNATE_SHEBANG
1675 case 'S': /* OS/2 needs -S on "extproc" line. */
1683 croak("Can't emulate -%.1s on #! line",s);
1688 /* compliments of Tom Christiansen */
1690 /* unexec() can be found in the Gnu emacs distribution */
1701 prog = newSVpv(BIN_EXP);
1702 sv_catpv(prog, "/perl");
1703 file = newSVpv(origfilename);
1704 sv_catpv(file, ".perldump");
1706 status = unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
1708 PerlIO_printf(PerlIO_stderr(), "unexec of %s into %s failed!\n",
1709 SvPVX(prog), SvPVX(file));
1710 PerlProc_exit(status);
1713 # include <lib$routines.h>
1714 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
1716 ABORT(); /* for use with undump */
1722 init_main_stash(void)
1727 /* Note that strtab is a rather special HV. Assumptions are made
1728 about not iterating on it, and not adding tie magic to it.
1729 It is properly deallocated in perl_destruct() */
1731 HvSHAREKEYS_off(strtab); /* mandatory */
1732 Newz(506,((XPVHV*)SvANY(strtab))->xhv_array,
1733 sizeof(HE*) * (((XPVHV*)SvANY(strtab))->xhv_max + 1), char);
1735 curstash = defstash = newHV();
1736 curstname = newSVpv("main",4);
1737 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
1738 SvREFCNT_dec(GvHV(gv));
1739 GvHV(gv) = (HV*)SvREFCNT_inc(defstash);
1741 HvNAME(defstash) = savepv("main");
1742 incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
1744 defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
1745 errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
1747 (void)form("%240s",""); /* Preallocate temp - for immediate signals. */
1748 sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */
1749 sv_setpvn(ERRSV, "", 0);
1750 curstash = defstash;
1751 compiling.cop_stash = defstash;
1752 debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
1753 globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
1754 /* We must init $/ before switches are processed. */
1755 sv_setpvn(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), "\n", 1);
1758 #ifdef CAN_PROTOTYPE
1760 open_script(char *scriptname, bool dosearch, SV *sv)
1763 open_script(scriptname,dosearch,sv)
1770 char *xfound = Nullch;
1771 char *xfailed = Nullch;
1775 #if defined(DOSISH) && !defined(OS2) && !defined(atarist)
1776 # define SEARCH_EXTS ".bat", ".cmd", NULL
1777 # define MAX_EXT_LEN 4
1780 # define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL
1781 # define MAX_EXT_LEN 4
1784 # define SEARCH_EXTS ".pl", ".com", NULL
1785 # define MAX_EXT_LEN 4
1787 /* additional extensions to try in each dir if scriptname not found */
1789 char *ext[] = { SEARCH_EXTS };
1790 int extidx = 0, i = 0;
1791 char *curext = Nullch;
1793 # define MAX_EXT_LEN 0
1797 * If dosearch is true and if scriptname does not contain path
1798 * delimiters, search the PATH for scriptname.
1800 * If SEARCH_EXTS is also defined, will look for each
1801 * scriptname{SEARCH_EXTS} whenever scriptname is not found
1802 * while searching the PATH.
1804 * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
1805 * proceeds as follows:
1806 * If DOSISH or VMSISH:
1807 * + look for ./scriptname{,.foo,.bar}
1808 * + search the PATH for scriptname{,.foo,.bar}
1811 * + look *only* in the PATH for scriptname{,.foo,.bar} (note
1812 * this will not look in '.' if it's not in the PATH)
1816 # ifdef ALWAYS_DEFTYPES
1817 len = strlen(scriptname);
1818 if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') {
1819 int hasdir, idx = 0, deftypes = 1;
1822 hasdir = !dosearch || (strpbrk(scriptname,":[</") != Nullch) ;
1825 int hasdir, idx = 0, deftypes = 1;
1828 hasdir = (strpbrk(scriptname,":[</") != Nullch) ;
1830 /* The first time through, just add SEARCH_EXTS to whatever we
1831 * already have, so we can check for default file types. */
1833 (!hasdir && my_trnlnm("DCL$PATH",tokenbuf,idx++)) )
1839 if ((strlen(tokenbuf) + strlen(scriptname)
1840 + MAX_EXT_LEN) >= sizeof tokenbuf)
1841 continue; /* don't search dir with too-long name */
1842 strcat(tokenbuf, scriptname);
1846 if (strEQ(scriptname, "-"))
1848 if (dosearch) { /* Look in '.' first. */
1849 char *cur = scriptname;
1851 if ((curext = strrchr(scriptname,'.'))) /* possible current ext */
1853 if (strEQ(ext[i++],curext)) {
1854 extidx = -1; /* already has an ext */
1859 DEBUG_p(PerlIO_printf(Perl_debug_log,
1860 "Looking for %s\n",cur));
1861 if (Stat(cur,&statbuf) >= 0) {
1869 if (cur == scriptname) {
1870 len = strlen(scriptname);
1871 if (len+MAX_EXT_LEN+1 >= sizeof(tokenbuf))
1873 cur = strcpy(tokenbuf, scriptname);
1875 } while (extidx >= 0 && ext[extidx] /* try an extension? */
1876 && strcpy(tokenbuf+len, ext[extidx++]));
1881 if (dosearch && !strchr(scriptname, '/')
1883 && !strchr(scriptname, '\\')
1885 && (s = PerlEnv_getenv("PATH"))) {
1888 bufend = s + strlen(s);
1889 while (s < bufend) {
1890 #if defined(atarist) || defined(DOSISH)
1895 && *s != ';'; len++, s++) {
1896 if (len < sizeof tokenbuf)
1899 if (len < sizeof tokenbuf)
1900 tokenbuf[len] = '\0';
1901 #else /* ! (atarist || DOSISH) */
1902 s = delimcpy(tokenbuf, tokenbuf + sizeof tokenbuf, s, bufend,
1905 #endif /* ! (atarist || DOSISH) */
1908 if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tokenbuf)
1909 continue; /* don't search dir with too-long name */
1911 #if defined(atarist) || defined(DOSISH)
1912 && tokenbuf[len - 1] != '/'
1913 && tokenbuf[len - 1] != '\\'
1916 tokenbuf[len++] = '/';
1917 if (len == 2 && tokenbuf[0] == '.')
1919 (void)strcpy(tokenbuf + len, scriptname);
1923 len = strlen(tokenbuf);
1924 if (extidx > 0) /* reset after previous loop */
1928 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tokenbuf));
1929 retval = Stat(tokenbuf,&statbuf);
1931 } while ( retval < 0 /* not there */
1932 && extidx>=0 && ext[extidx] /* try an extension? */
1933 && strcpy(tokenbuf+len, ext[extidx++])
1938 if (S_ISREG(statbuf.st_mode)
1939 && cando(S_IRUSR,TRUE,&statbuf)
1941 && cando(S_IXUSR,TRUE,&statbuf)
1945 xfound = tokenbuf; /* bingo! */
1949 xfailed = savepv(tokenbuf);
1952 if (!xfound && !seen_dot && !xfailed && (Stat(scriptname,&statbuf) < 0))
1954 seen_dot = 1; /* Disable message. */
1956 croak("Can't %s %s%s%s",
1957 (xfailed ? "execute" : "find"),
1958 (xfailed ? xfailed : scriptname),
1959 (xfailed ? "" : " on PATH"),
1960 (xfailed || seen_dot) ? "" : ", '.' not in PATH");
1963 scriptname = xfound;
1966 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
1967 char *s = scriptname + 8;
1976 origfilename = savepv(e_tmpname ? "-e" : scriptname);
1977 curcop->cop_filegv = gv_fetchfile(origfilename);
1978 if (strEQ(origfilename,"-"))
1980 if (fdscript >= 0) {
1981 rsfp = PerlIO_fdopen(fdscript,PERL_SCRIPT_MODE);
1982 #if defined(HAS_FCNTL) && defined(F_SETFD)
1984 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
1987 else if (preprocess) {
1988 char *cpp_cfg = CPPSTDIN;
1989 SV *cpp = NEWSV(0,0);
1990 SV *cmd = NEWSV(0,0);
1992 if (strEQ(cpp_cfg, "cppstdin"))
1993 sv_catpvf(cpp, "%s/", BIN_EXP);
1994 sv_catpv(cpp, cpp_cfg);
1997 sv_catpv(sv,PRIVLIB_EXP);
2001 sed %s -e \"/^[^#]/b\" \
2002 -e \"/^#[ ]*include[ ]/b\" \
2003 -e \"/^#[ ]*define[ ]/b\" \
2004 -e \"/^#[ ]*if[ ]/b\" \
2005 -e \"/^#[ ]*ifdef[ ]/b\" \
2006 -e \"/^#[ ]*ifndef[ ]/b\" \
2007 -e \"/^#[ ]*else/b\" \
2008 -e \"/^#[ ]*elif[ ]/b\" \
2009 -e \"/^#[ ]*undef[ ]/b\" \
2010 -e \"/^#[ ]*endif/b\" \
2013 (doextract ? "-e \"1,/^#/d\n\"" : ""),
2016 %s %s -e '/^[^#]/b' \
2017 -e '/^#[ ]*include[ ]/b' \
2018 -e '/^#[ ]*define[ ]/b' \
2019 -e '/^#[ ]*if[ ]/b' \
2020 -e '/^#[ ]*ifdef[ ]/b' \
2021 -e '/^#[ ]*ifndef[ ]/b' \
2022 -e '/^#[ ]*else/b' \
2023 -e '/^#[ ]*elif[ ]/b' \
2024 -e '/^#[ ]*undef[ ]/b' \
2025 -e '/^#[ ]*endif/b' \
2033 (doextract ? "-e '1,/^#/d\n'" : ""),
2035 scriptname, cpp, sv, CPPMINUS);
2037 #ifdef IAMSUID /* actually, this is caught earlier */
2038 if (euid != uid && !euid) { /* if running suidperl */
2040 (void)seteuid(uid); /* musn't stay setuid root */
2043 (void)setreuid((Uid_t)-1, uid);
2045 #ifdef HAS_SETRESUID
2046 (void)setresuid((Uid_t)-1, uid, (Uid_t)-1);
2052 if (geteuid() != uid)
2053 croak("Can't do seteuid!\n");
2055 #endif /* IAMSUID */
2056 rsfp = PerlProc_popen(SvPVX(cmd), "r");
2060 else if (!*scriptname) {
2061 forbid_setid("program input from stdin");
2062 rsfp = PerlIO_stdin();
2065 rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
2066 #if defined(HAS_FCNTL) && defined(F_SETFD)
2068 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
2076 #ifndef IAMSUID /* in case script is not readable before setuid */
2077 if (euid && Stat(SvPVX(GvSV(curcop->cop_filegv)),&statbuf) >= 0 &&
2078 statbuf.st_mode & (S_ISUID|S_ISGID)) {
2080 PerlProc_execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
2081 croak("Can't do setuid\n");
2085 croak("Can't open perl script \"%s\": %s\n",
2086 SvPVX(GvSV(curcop->cop_filegv)), Strerror(errno));
2091 validate_suid(char *validarg, char *scriptname)
2095 /* do we need to emulate setuid on scripts? */
2097 /* This code is for those BSD systems that have setuid #! scripts disabled
2098 * in the kernel because of a security problem. Merely defining DOSUID
2099 * in perl will not fix that problem, but if you have disabled setuid
2100 * scripts in the kernel, this will attempt to emulate setuid and setgid
2101 * on scripts that have those now-otherwise-useless bits set. The setuid
2102 * root version must be called suidperl or sperlN.NNN. If regular perl
2103 * discovers that it has opened a setuid script, it calls suidperl with
2104 * the same argv that it had. If suidperl finds that the script it has
2105 * just opened is NOT setuid root, it sets the effective uid back to the
2106 * uid. We don't just make perl setuid root because that loses the
2107 * effective uid we had before invoking perl, if it was different from the
2110 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
2111 * be defined in suidperl only. suidperl must be setuid root. The
2112 * Configure script will set this up for you if you want it.
2119 if (PerlLIO_fstat(PerlIO_fileno(rsfp),&statbuf) < 0) /* normal stat is insecure */
2120 croak("Can't stat script \"%s\"",origfilename);
2121 if (fdscript < 0 && statbuf.st_mode & (S_ISUID|S_ISGID)) {
2125 #ifndef HAS_SETREUID
2126 /* On this access check to make sure the directories are readable,
2127 * there is actually a small window that the user could use to make
2128 * filename point to an accessible directory. So there is a faint
2129 * chance that someone could execute a setuid script down in a
2130 * non-accessible directory. I don't know what to do about that.
2131 * But I don't think it's too important. The manual lies when
2132 * it says access() is useful in setuid programs.
2134 if (PerlLIO_access(SvPVX(GvSV(curcop->cop_filegv)),1)) /*double check*/
2135 croak("Permission denied");
2137 /* If we can swap euid and uid, then we can determine access rights
2138 * with a simple stat of the file, and then compare device and
2139 * inode to make sure we did stat() on the same file we opened.
2140 * Then we just have to make sure he or she can execute it.
2143 struct stat tmpstatbuf;
2147 setreuid(euid,uid) < 0
2150 setresuid(euid,uid,(Uid_t)-1) < 0
2153 || getuid() != euid || geteuid() != uid)
2154 croak("Can't swap uid and euid"); /* really paranoid */
2155 if (Stat(SvPVX(GvSV(curcop->cop_filegv)),&tmpstatbuf) < 0)
2156 croak("Permission denied"); /* testing full pathname here */
2157 if (tmpstatbuf.st_dev != statbuf.st_dev ||
2158 tmpstatbuf.st_ino != statbuf.st_ino) {
2159 (void)PerlIO_close(rsfp);
2160 if (rsfp = PerlProc_popen("/bin/mail root","w")) { /* heh, heh */
2162 "User %ld tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
2163 (Filename of set-id script was %s, uid %ld gid %ld.)\n\nSincerely,\nperl\n",
2164 (long)uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
2165 (long)statbuf.st_dev, (long)statbuf.st_ino,
2166 SvPVX(GvSV(curcop->cop_filegv)),
2167 (long)statbuf.st_uid, (long)statbuf.st_gid);
2168 (void)PerlProc_pclose(rsfp);
2170 croak("Permission denied\n");
2174 setreuid(uid,euid) < 0
2176 # if defined(HAS_SETRESUID)
2177 setresuid(uid,euid,(Uid_t)-1) < 0
2180 || getuid() != uid || geteuid() != euid)
2181 croak("Can't reswap uid and euid");
2182 if (!cando(S_IXUSR,FALSE,&statbuf)) /* can real uid exec? */
2183 croak("Permission denied\n");
2185 #endif /* HAS_SETREUID */
2186 #endif /* IAMSUID */
2188 if (!S_ISREG(statbuf.st_mode))
2189 croak("Permission denied");
2190 if (statbuf.st_mode & S_IWOTH)
2191 croak("Setuid/gid script is writable by world");
2192 doswitches = FALSE; /* -s is insecure in suid */
2194 if (sv_gets(linestr, rsfp, 0) == Nullch ||
2195 strnNE(SvPV(linestr,na),"#!",2) ) /* required even on Sys V */
2196 croak("No #! line");
2197 s = SvPV(linestr,na)+2;
2199 while (!isSPACE(*s)) s++;
2200 for (s2 = s; (s2 > SvPV(linestr,na)+2 &&
2201 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
2202 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
2203 croak("Not a perl script");
2204 while (*s == ' ' || *s == '\t') s++;
2206 * #! arg must be what we saw above. They can invoke it by
2207 * mentioning suidperl explicitly, but they may not add any strange
2208 * arguments beyond what #! says if they do invoke suidperl that way.
2210 len = strlen(validarg);
2211 if (strEQ(validarg," PHOOEY ") ||
2212 strnNE(s,validarg,len) || !isSPACE(s[len]))
2213 croak("Args must match #! line");
2216 if (euid != uid && (statbuf.st_mode & S_ISUID) &&
2217 euid == statbuf.st_uid)
2219 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2220 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2221 #endif /* IAMSUID */
2223 if (euid) { /* oops, we're not the setuid root perl */
2224 (void)PerlIO_close(rsfp);
2227 PerlProc_execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
2229 croak("Can't do setuid\n");
2232 if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid) {
2234 (void)setegid(statbuf.st_gid);
2237 (void)setregid((Gid_t)-1,statbuf.st_gid);
2239 #ifdef HAS_SETRESGID
2240 (void)setresgid((Gid_t)-1,statbuf.st_gid,(Gid_t)-1);
2242 setgid(statbuf.st_gid);
2246 if (getegid() != statbuf.st_gid)
2247 croak("Can't do setegid!\n");
2249 if (statbuf.st_mode & S_ISUID) {
2250 if (statbuf.st_uid != euid)
2252 (void)seteuid(statbuf.st_uid); /* all that for this */
2255 (void)setreuid((Uid_t)-1,statbuf.st_uid);
2257 #ifdef HAS_SETRESUID
2258 (void)setresuid((Uid_t)-1,statbuf.st_uid,(Uid_t)-1);
2260 setuid(statbuf.st_uid);
2264 if (geteuid() != statbuf.st_uid)
2265 croak("Can't do seteuid!\n");
2267 else if (uid) { /* oops, mustn't run as root */
2269 (void)seteuid((Uid_t)uid);
2272 (void)setreuid((Uid_t)-1,(Uid_t)uid);
2274 #ifdef HAS_SETRESUID
2275 (void)setresuid((Uid_t)-1,(Uid_t)uid,(Uid_t)-1);
2281 if (geteuid() != uid)
2282 croak("Can't do seteuid!\n");
2285 if (!cando(S_IXUSR,TRUE,&statbuf))
2286 croak("Permission denied\n"); /* they can't do this */
2289 else if (preprocess)
2290 croak("-P not allowed for setuid/setgid script\n");
2291 else if (fdscript >= 0)
2292 croak("fd script not allowed in suidperl\n");
2294 croak("Script is not setuid/setgid in suidperl\n");
2296 /* We absolutely must clear out any saved ids here, so we */
2297 /* exec the real perl, substituting fd script for scriptname. */
2298 /* (We pass script name as "subdir" of fd, which perl will grok.) */
2299 PerlIO_rewind(rsfp);
2300 PerlLIO_lseek(PerlIO_fileno(rsfp),(Off_t)0,0); /* just in case rewind didn't */
2301 for (which = 1; origargv[which] && origargv[which] != scriptname; which++) ;
2302 if (!origargv[which])
2303 croak("Permission denied");
2304 origargv[which] = savepv(form("/dev/fd/%d/%s",
2305 PerlIO_fileno(rsfp), origargv[which]));
2306 #if defined(HAS_FCNTL) && defined(F_SETFD)
2307 fcntl(PerlIO_fileno(rsfp),F_SETFD,0); /* ensure no close-on-exec */
2309 PerlProc_execv(form("%s/perl%s", BIN_EXP, patchlevel), origargv); /* try again */
2310 croak("Can't do setuid\n");
2311 #endif /* IAMSUID */
2313 if (euid != uid || egid != gid) { /* (suidperl doesn't exist, in fact) */
2314 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
2316 PerlLIO_fstat(PerlIO_fileno(rsfp),&statbuf); /* may be either wrapped or real suid */
2317 if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
2319 (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
2322 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2323 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2324 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
2325 /* not set-id, must be wrapped */
2331 find_beginning(void)
2333 register char *s, *s2;
2335 /* skip forward in input to the real script? */
2339 if ((s = sv_gets(linestr, rsfp, 0)) == Nullch)
2340 croak("No Perl script found in input\n");
2341 if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
2342 PerlIO_ungetc(rsfp, '\n'); /* to keep line count right */
2344 while (*s && !(isSPACE (*s) || *s == '#')) s++;
2346 while (*s == ' ' || *s == '\t') s++;
2348 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
2349 if (strnEQ(s2-4,"perl",4))
2351 while (s = moreswitches(s)) ;
2353 if (cddir && PerlDir_chdir(cddir) < 0)
2354 croak("Can't chdir to %s",cddir);
2362 uid = (int)getuid();
2363 euid = (int)geteuid();
2364 gid = (int)getgid();
2365 egid = (int)getegid();
2370 tainting |= (uid && (euid != uid || egid != gid));
2374 forbid_setid(char *s)
2377 croak("No %s allowed while running setuid", s);
2379 croak("No %s allowed while running setgid", s);
2386 curstash = debstash;
2387 dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
2389 DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
2390 DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
2391 DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
2392 DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
2393 sv_setiv(DBsingle, 0);
2394 DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
2395 sv_setiv(DBtrace, 0);
2396 DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
2397 sv_setiv(DBsignal, 0);
2398 curstash = defstash;
2402 init_stacks(ARGSproto)
2405 mainstack = curstack; /* remember in case we switch stacks */
2406 AvREAL_off(curstack); /* not a real array */
2407 av_extend(curstack,127);
2409 stack_base = AvARRAY(curstack);
2410 stack_sp = stack_base;
2411 stack_max = stack_base + 127;
2413 cxstack_max = 8192 / sizeof(PERL_CONTEXT) - 2; /* Use most of 8K. */
2414 New(50,cxstack,cxstack_max + 1,PERL_CONTEXT);
2417 New(50,tmps_stack,128,SV*);
2423 * The following stacks almost certainly should be per-interpreter,
2424 * but for now they're not. XXX
2428 markstack_ptr = markstack;
2430 New(54,markstack,64,I32);
2431 markstack_ptr = markstack;
2432 markstack_max = markstack + 64;
2438 New(54,scopestack,32,I32);
2440 scopestack_max = 32;
2446 New(54,savestack,128,ANY);
2448 savestack_max = 128;
2454 New(54,retstack,16,OP*);
2465 Safefree(tmps_stack);
2472 static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
2481 subname = newSVpv("main",4);
2485 init_predump_symbols(void)
2491 sv_setpvn(perl_get_sv("\"", TRUE), " ", 1);
2492 stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
2493 GvMULTI_on(stdingv);
2494 IoIFP(GvIOp(stdingv)) = PerlIO_stdin();
2495 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
2497 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(stdingv));
2499 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
2501 IoOFP(GvIOp(tmpgv)) = IoIFP(GvIOp(tmpgv)) = PerlIO_stdout();
2503 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
2505 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(defoutgv));
2507 othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
2508 GvMULTI_on(othergv);
2509 IoOFP(GvIOp(othergv)) = IoIFP(GvIOp(othergv)) = PerlIO_stderr();
2510 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
2512 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(othergv));
2514 statname = NEWSV(66,0); /* last filename we did stat on */
2517 osname = savepv(OSNAME);
2521 init_postdump_symbols(register int argc, register char **argv, register char **env)
2528 argc--,argv++; /* skip name of script */
2530 for (; argc > 0 && **argv == '-'; argc--,argv++) {
2533 if (argv[0][1] == '-') {
2537 if (s = strchr(argv[0], '=')) {
2539 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
2542 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
2545 toptarget = NEWSV(0,0);
2546 sv_upgrade(toptarget, SVt_PVFM);
2547 sv_setpvn(toptarget, "", 0);
2548 bodytarget = NEWSV(0,0);
2549 sv_upgrade(bodytarget, SVt_PVFM);
2550 sv_setpvn(bodytarget, "", 0);
2551 formtarget = bodytarget;
2554 if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
2555 sv_setpv(GvSV(tmpgv),origfilename);
2556 magicname("0", "0", 1);
2558 if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
2559 sv_setpv(GvSV(tmpgv),origargv[0]);
2560 if (argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
2562 (void)gv_AVadd(argvgv);
2563 av_clear(GvAVn(argvgv));
2564 for (; argc > 0; argc--,argv++) {
2565 av_push(GvAVn(argvgv),newSVpv(argv[0],0));
2568 if (envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
2572 hv_magic(hv, envgv, 'E');
2573 #ifndef VMS /* VMS doesn't have environ array */
2574 /* Note that if the supplied env parameter is actually a copy
2575 of the global environ then it may now point to free'd memory
2576 if the environment has been modified since. To avoid this
2577 problem we treat env==NULL as meaning 'use the default'
2582 environ[0] = Nullch;
2583 for (; *env; env++) {
2584 if (!(s = strchr(*env,'=')))
2587 #if defined(WIN32) || defined(MSDOS)
2590 sv = newSVpv(s--,0);
2591 (void)hv_store(hv, *env, s - *env, sv, 0);
2593 #if defined(__BORLANDC__) && defined(USE_WIN32_RTL_ENV)
2594 /* Sins of the RTL. See note in my_setenv(). */
2595 (void)PerlEnv_putenv(savepv(*env));
2599 #ifdef DYNAMIC_ENV_FETCH
2600 HvNAME(hv) = savepv(ENV_HV_NAME);
2604 if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
2605 sv_setiv(GvSV(tmpgv), (IV)getpid());
2614 s = PerlEnv_getenv("PERL5LIB");
2618 incpush(PerlEnv_getenv("PERLLIB"), FALSE);
2620 /* Treat PERL5?LIB as a possible search list logical name -- the
2621 * "natural" VMS idiom for a Unix path string. We allow each
2622 * element to be a set of |-separated directories for compatibility.
2626 if (my_trnlnm("PERL5LIB",buf,0))
2627 do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
2629 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE);
2633 /* Use the ~-expanded versions of APPLLIB (undocumented),
2634 ARCHLIB PRIVLIB SITEARCH and SITELIB
2637 incpush(APPLLIB_EXP, FALSE);
2641 incpush(ARCHLIB_EXP, FALSE);
2644 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
2646 incpush(PRIVLIB_EXP, FALSE);
2649 incpush(SITEARCH_EXP, FALSE);
2652 incpush(SITELIB_EXP, FALSE);
2655 incpush(".", FALSE);
2659 # define PERLLIB_SEP ';'
2662 # define PERLLIB_SEP '|'
2664 # define PERLLIB_SEP ':'
2667 #ifndef PERLLIB_MANGLE
2668 # define PERLLIB_MANGLE(s,n) (s)
2672 incpush(char *p, int addsubdirs)
2674 SV *subdir = Nullsv;
2675 static char *archpat_auto;
2681 subdir = NEWSV(55,0);
2682 if (!archpat_auto) {
2683 STRLEN len = (sizeof(ARCHNAME) + strlen(patchlevel)
2684 + sizeof("//auto"));
2685 New(55, archpat_auto, len, char);
2686 sprintf(archpat_auto, "/%s/%s/auto", ARCHNAME, patchlevel);
2688 for (len = sizeof(ARCHNAME) + 2;
2689 archpat_auto[len] != '\0' && archpat_auto[len] != '/'; len++)
2690 if (archpat_auto[len] == '.') archpat_auto[len] = '_';
2695 /* Break at all separators */
2697 SV *libdir = NEWSV(55,0);
2700 /* skip any consecutive separators */
2701 while ( *p == PERLLIB_SEP ) {
2702 /* Uncomment the next line for PATH semantics */
2703 /* av_push(GvAVn(incgv), newSVpv(".", 1)); */
2707 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
2708 sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
2713 sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
2714 p = Nullch; /* break out */
2718 * BEFORE pushing libdir onto @INC we may first push version- and
2719 * archname-specific sub-directories.
2722 struct stat tmpstatbuf;
2727 if ((unix = tounixspec_ts(SvPV(libdir,na),Nullch)) != Nullch) {
2729 while (unix[len-1] == '/') len--; /* Cosmetic */
2730 sv_usepvn(libdir,unix,len);
2733 PerlIO_printf(PerlIO_stderr(),
2734 "Failed to unixify @INC element \"%s\"\n",
2737 /* .../archname/version if -d .../archname/version/auto */
2738 sv_setsv(subdir, libdir);
2739 sv_catpv(subdir, archpat_auto);
2740 if (Stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2741 S_ISDIR(tmpstatbuf.st_mode))
2742 av_push(GvAVn(incgv),
2743 newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2745 /* .../archname if -d .../archname/auto */
2746 sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME),
2747 strlen(patchlevel) + 1, "", 0);
2748 if (Stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2749 S_ISDIR(tmpstatbuf.st_mode))
2750 av_push(GvAVn(incgv),
2751 newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2754 /* finally push this lib directory on the end of @INC */
2755 av_push(GvAVn(incgv), libdir);
2758 SvREFCNT_dec(subdir);
2762 static struct perl_thread *
2765 struct perl_thread *thr;
2768 Newz(53, thr, 1, struct perl_thread);
2769 curcop = &compiling;
2770 thr->cvcache = newHV();
2771 thr->threadsv = newAV();
2772 /* thr->threadsvp is set when find_threadsv is called */
2773 thr->specific = newAV();
2774 thr->errhv = newHV();
2775 thr->flags = THRf_R_JOINABLE;
2776 MUTEX_INIT(&thr->mutex);
2777 /* Handcraft thrsv similarly to mess_sv */
2778 New(53, thrsv, 1, SV);
2779 Newz(53, xpv, 1, XPV);
2780 SvFLAGS(thrsv) = SVt_PV;
2781 SvANY(thrsv) = (void*)xpv;
2782 SvREFCNT(thrsv) = 1 << 30; /* practically infinite */
2783 SvPVX(thrsv) = (char*)thr;
2784 SvCUR_set(thrsv, sizeof(thr));
2785 SvLEN_set(thrsv, sizeof(thr));
2786 *SvEND(thrsv) = '\0'; /* in the trailing_nul field */
2788 curcop = &compiling;
2791 MUTEX_LOCK(&threads_mutex);
2796 MUTEX_UNLOCK(&threads_mutex);
2798 #ifdef HAVE_THREAD_INTERN
2799 init_thread_intern(thr);
2802 #ifdef SET_THREAD_SELF
2803 SET_THREAD_SELF(thr);
2805 thr->self = pthread_self();
2806 #endif /* SET_THREAD_SELF */
2810 * These must come after the SET_THR because sv_setpvn does
2811 * SvTAINT and the taint fields require dTHR.
2813 toptarget = NEWSV(0,0);
2814 sv_upgrade(toptarget, SVt_PVFM);
2815 sv_setpvn(toptarget, "", 0);
2816 bodytarget = NEWSV(0,0);
2817 sv_upgrade(bodytarget, SVt_PVFM);
2818 sv_setpvn(bodytarget, "", 0);
2819 formtarget = bodytarget;
2820 thr->errsv = newSVpv("", 0);
2821 (void) find_threadsv("@"); /* Ensure $@ is initialised early */
2824 #endif /* USE_THREADS */
2827 call_list(I32 oldscope, AV *list)
2830 line_t oldline = curcop->cop_line;
2835 while (AvFILL(list) >= 0) {
2836 CV *cv = (CV*)av_shift(list);
2845 perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
2846 (void)SvPV(atsv, len);
2849 curcop = &compiling;
2850 curcop->cop_line = oldline;
2851 if (list == beginav)
2852 sv_catpv(atsv, "BEGIN failed--compilation aborted");
2854 sv_catpv(atsv, "END failed--cleanup aborted");
2855 while (scopestack_ix > oldscope)
2857 croak("%s", SvPVX(atsv));
2865 /* my_exit() was called */
2866 while (scopestack_ix > oldscope)
2869 curstash = defstash;
2871 call_list(oldscope, endav);
2873 curcop = &compiling;
2874 curcop->cop_line = oldline;
2876 if (list == beginav)
2877 croak("BEGIN failed--compilation aborted");
2879 croak("END failed--cleanup aborted");
2885 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
2890 curcop = &compiling;
2891 curcop->cop_line = oldline;
2904 DEBUG_L(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
2905 thr, (unsigned long) status));
2906 #endif /* USE_THREADS */
2915 STATUS_NATIVE_SET(status);
2922 my_failure_exit(void)
2925 if (vaxc$errno & 1) {
2926 if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
2927 STATUS_NATIVE_SET(44);
2930 if (!vaxc$errno && errno) /* unlikely */
2931 STATUS_NATIVE_SET(44);
2933 STATUS_NATIVE_SET(vaxc$errno);
2937 STATUS_POSIX_SET(errno);
2938 else if (STATUS_POSIX == 0)
2939 STATUS_POSIX_SET(255);
2948 register PERL_CONTEXT *cx;
2957 (void)UNLINK(e_tmpname);
2958 Safefree(e_tmpname);
2962 if (cxstack_ix >= 0) {