3 * Copyright (c) 1987-1997 Larry Wall
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
11 * "A ship then new they built for him/of mithril and of elven glass" --Bilbo
16 #include "patchlevel.h"
18 /* XXX If this causes problems, set i_unistd=undef in the hint file. */
23 #if !defined(STANDARD_C) && !defined(HAS_GETENV_PROTOTYPE)
24 char *getenv _((char *)); /* Usually in <stdlib.h> */
27 dEXTCONST char rcsid[] = "perl.c\nPatch level: ###\n";
35 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
45 curcop = &compiling; \
52 laststype = OP_STAT; \
54 maxsysfd = MAXSYSFD; \
61 laststype = OP_STAT; \
65 static void find_beginning _((void));
66 static void forbid_setid _((char *));
67 static void incpush _((char *, int));
68 static void init_ids _((void));
69 static void init_debugger _((void));
70 static void init_lexer _((void));
71 static void init_main_stash _((void));
72 static void init_perllib _((void));
73 static void init_postdump_symbols _((int, char **, char **));
74 static void init_predump_symbols _((void));
75 static void my_exit_jump _((void)) __attribute__((noreturn));
76 static void nuke_stacks _((void));
77 static void open_script _((char *, bool, SV *));
79 static void thread_destruct _((void *));
80 #endif /* USE_THREADS */
81 static void usage _((char *));
82 static void validate_suid _((char *, char*));
84 static int fdscript = -1;
86 #if defined(DEBUGGING) && defined(USE_THREADS) && defined(__linux__)
87 #include <asm/sigcontext.h>
89 catch_sigsegv(int signo, struct sigcontext_struct sc)
91 signal(SIGSEGV, SIG_DFL);
92 fprintf(stderr, "Segmentation fault dereferencing 0x%lx\n"
93 "return_address = 0x%lx, eip = 0x%lx\n",
94 sc.cr2, __builtin_return_address(0), sc.eip);
95 fprintf(stderr, "thread = 0x%lx\n", (unsigned long)THR);
102 PerlInterpreter *sv_interp;
105 New(53, sv_interp, 1, PerlInterpreter);
110 perl_construct( sv_interp )
111 register PerlInterpreter *sv_interp;
113 #if defined(USE_THREADS) && !defined(FAKE_THREADS)
117 if (!(curinterp = sv_interp))
121 Zero(sv_interp, 1, PerlInterpreter);
125 #ifdef NEED_PTHREAD_INIT
127 #endif /* NEED_PTHREAD_INIT */
128 New(53, thr, 1, struct thread);
131 thr->next = thr->prev = thr->next_run = thr->prev_run = thr;
135 self = pthread_self();
136 if (pthread_key_create(&thr_key, thread_destruct))
137 croak("panic: pthread_key_create");
138 if (pthread_setspecific(thr_key, (void *) thr))
139 croak("panic: pthread_setspecific");
140 #endif /* !FAKE_THREADS */
145 #endif /* USE_THREADS */
147 /* Init the real globals? */
149 linestr = NEWSV(65,80);
150 sv_upgrade(linestr,SVt_PVIV);
152 if (!SvREADONLY(&sv_undef)) {
153 SvREADONLY_on(&sv_undef);
157 SvREADONLY_on(&sv_no);
159 sv_setpv(&sv_yes,Yes);
161 SvREADONLY_on(&sv_yes);
164 nrs = newSVpv("\n", 1);
165 rs = SvREFCNT_inc(nrs);
167 MUTEX_INIT(&malloc_mutex);
168 MUTEX_INIT(&sv_mutex);
169 MUTEX_INIT(&eval_mutex);
170 MUTEX_INIT(&nthreads_mutex);
171 COND_INIT(&nthreads_cond);
177 * There is no way we can refer to them from Perl so close them to save
178 * space. The other alternative would be to provide STDAUX and STDPRN
181 (void)fclose(stdaux);
182 (void)fclose(stdprn);
188 perl_destruct_level = 1;
190 if(perl_destruct_level > 0)
196 start_env.je_prev = NULL;
197 start_env.je_ret = -1;
198 start_env.je_mustcatch = TRUE;
199 top_env = &start_env;
202 SET_NUMERIC_STANDARD();
203 #if defined(SUBVERSION) && SUBVERSION > 0
204 sprintf(patchlevel, "%7.5f", (double) 5
205 + ((double) PATCHLEVEL / (double) 1000)
206 + ((double) SUBVERSION / (double) 100000));
208 sprintf(patchlevel, "%5.3f", (double) 5 +
209 ((double) PATCHLEVEL / (double) 1000));
212 #if defined(LOCAL_PATCH_COUNT)
213 localpatches = local_patches; /* For possible -v */
216 PerlIO_init(); /* Hook to IO system */
218 fdpid = newAV(); /* for remembering popen pids by fd */
222 New(51,debname,128,char);
223 New(52,debdelim,128,char);
234 struct thread *thr = (struct thread *) arg;
236 * Decrement the global thread count and signal anyone listening.
237 * The only official thread listening is the original thread while
238 * in perl_destruct. It waits until it's the only thread and then
239 * performs END blocks and other process clean-ups.
241 DEBUG_L(fprintf(stderr, "thread_destruct: 0x%lx\n", (unsigned long) thr));
244 MUTEX_LOCK(&nthreads_mutex);
246 COND_BROADCAST(&nthreads_cond);
247 MUTEX_UNLOCK(&nthreads_mutex);
249 #endif /* USE_THREADS */
252 perl_destruct(sv_interp)
253 register PerlInterpreter *sv_interp;
256 int destruct_level; /* 0=none, 1=full, 2=full with checks */
260 if (!(curinterp = sv_interp))
265 /* Wait until all user-created threads go away */
266 MUTEX_LOCK(&nthreads_mutex);
269 DEBUG_L(fprintf(stderr, "perl_destruct: waiting for %d threads\n",
271 COND_WAIT(&nthreads_cond, &nthreads_mutex);
273 /* At this point, we're the last thread */
274 MUTEX_UNLOCK(&nthreads_mutex);
275 DEBUG_L(fprintf(stderr, "perl_destruct: armageddon has arrived\n"));
276 MUTEX_DESTROY(&nthreads_mutex);
277 COND_DESTROY(&nthreads_cond);
278 #endif /* !defined(FAKE_THREADS) */
279 #endif /* USE_THREADS */
281 destruct_level = perl_destruct_level;
285 if (s = getenv("PERL_DESTRUCT_LEVEL")) {
287 if (destruct_level < i)
296 /* We must account for everything. */
298 /* Destroy the main CV and syntax tree */
300 curpad = AvARRAY(comppad);
305 SvREFCNT_dec(main_cv);
310 * Try to destruct global references. We do this first so that the
311 * destructors and destructees still exist. Some sv's might remain.
312 * Non-referenced objects are on their own.
319 /* unhook hooks which will soon be, or use, destroyed data */
320 SvREFCNT_dec(warnhook);
322 SvREFCNT_dec(diehook);
324 SvREFCNT_dec(parsehook);
327 if (destruct_level == 0){
329 DEBUG_P(debprofdump());
331 /* The exit() function will do everything that needs doing. */
335 /* loosen bonds of global variables */
338 (void)PerlIO_close(rsfp);
342 /* Filters for program text */
343 SvREFCNT_dec(rsfp_filters);
344 rsfp_filters = Nullav;
356 sawampersand = FALSE; /* must save all match strings */
357 sawstudy = FALSE; /* do fbm_instr on all strings */
372 /* magical thingies */
374 Safefree(ofs); /* $, */
377 Safefree(ors); /* $\ */
380 SvREFCNT_dec(nrs); /* $\ helper */
383 multiline = 0; /* $* */
385 SvREFCNT_dec(statname);
389 /* defgv, aka *_ should be taken care of elsewhere */
391 #if 0 /* just about all regexp stuff, seems to be ok */
393 /* shortcuts to regexp stuff */
398 SAVEFREEOP(oldlastpm); /* for saving regexp context during debugger */
400 regprecomp = NULL; /* uncompiled string. */
401 regparse = NULL; /* Input-scan pointer. */
402 regxend = NULL; /* End of input for compile */
403 regnpar = 0; /* () count. */
404 regcode = NULL; /* Code-emit pointer; ®dummy = don't. */
405 regsize = 0; /* Code size. */
406 regnaughty = 0; /* How bad is this pattern? */
407 regsawback = 0; /* Did we see \1, ...? */
409 reginput = NULL; /* String-input pointer. */
410 regbol = NULL; /* Beginning of input, for ^ check. */
411 regeol = NULL; /* End of input, for $ check. */
412 regstartp = (char **)NULL; /* Pointer to startp array. */
413 regendp = (char **)NULL; /* Ditto for endp. */
414 reglastparen = 0; /* Similarly for lastparen. */
415 regtill = NULL; /* How far we are required to go. */
416 regflags = 0; /* are we folding, multilining? */
417 regprev = (char)NULL; /* char before regbol, \n if none */
421 /* clean up after study() */
422 SvREFCNT_dec(lastscream);
424 Safefree(screamfirst);
426 Safefree(screamnext);
429 /* startup and shutdown function lists */
430 SvREFCNT_dec(beginav);
432 SvREFCNT_dec(initav);
437 /* temp stack during pp_sort() */
438 SvREFCNT_dec(sortstack);
441 /* shortcuts just get cleared */
451 /* reset so print() ends up where we expect */
454 /* Prepare to destruct main symbol table. */
461 if (destruct_level >= 2) {
462 if (scopestack_ix != 0)
463 warn("Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
464 (long)scopestack_ix);
465 if (savestack_ix != 0)
466 warn("Unbalanced saves: %ld more saves than restores\n",
468 if (tmps_floor != -1)
469 warn("Unbalanced tmps: %ld more allocs than frees\n",
470 (long)tmps_floor + 1);
471 if (cxstack_ix != -1)
472 warn("Unbalanced context: %ld more PUSHes than POPs\n",
473 (long)cxstack_ix + 1);
476 /* Now absolutely destruct everything, somehow or other, loops or no. */
478 SvFLAGS(strtab) |= SVTYPEMASK; /* don't clean out strtab now */
479 while (sv_count != 0 && sv_count != last_sv_count) {
480 last_sv_count = sv_count;
483 SvFLAGS(strtab) &= ~SVTYPEMASK;
484 SvFLAGS(strtab) |= SVt_PVHV;
486 /* Destruct the global string table. */
488 /* Yell and reset the HeVAL() slots that are still holding refcounts,
489 * so that sv_free() won't fail on them.
498 array = HvARRAY(strtab);
502 warn("Unbalanced string table refcount: (%d) for \"%s\"",
503 HeVAL(hent) - Nullsv, HeKEY(hent));
504 HeVAL(hent) = Nullsv;
514 SvREFCNT_dec(strtab);
517 warn("Scalars leaked: %ld\n", (long)sv_count);
521 /* No SVs have survived, need to clean out */
525 Safefree(origfilename);
527 hints = 0; /* Reset hints. Should hints be per-interpreter ? */
529 DEBUG_P(debprofdump());
531 MUTEX_DESTROY(&sv_mutex);
532 MUTEX_DESTROY(&malloc_mutex);
533 MUTEX_DESTROY(&eval_mutex);
534 #endif /* USE_THREADS */
536 /* As the absolutely last thing, free the non-arena SV for mess() */
539 /* we know that type >= SVt_PV */
541 Safefree(SvPVX(mess_sv));
542 Safefree(SvANY(mess_sv));
550 PerlInterpreter *sv_interp;
552 if (!(curinterp = sv_interp))
558 perl_parse(sv_interp, xsinit, argc, argv, env)
559 PerlInterpreter *sv_interp;
560 void (*xsinit)_((void));
568 char *scriptname = NULL;
569 VOL bool dosearch = FALSE;
576 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
579 croak("suidperl is no longer needed since the kernel can now execute\n\
580 setuid perl scripts securely.\n");
584 if (!(curinterp = sv_interp))
587 #if defined(NeXT) && defined(__DYNAMIC__)
588 _dyld_lookup_and_bind
589 ("__environ", (unsigned long *) &environ_pointer, NULL);
594 #ifndef VMS /* VMS doesn't have environ array */
595 origenviron = environ;
601 /* Come here if running an undumped a.out. */
603 origfilename = savepv(argv[0]);
605 cxstack_ix = -1; /* start label stack again */
607 init_postdump_symbols(argc,argv,env);
612 curpad = AvARRAY(comppad);
617 SvREFCNT_dec(main_cv);
621 oldscope = scopestack_ix;
629 /* my_exit() was called */
630 while (scopestack_ix > oldscope)
634 call_list(oldscope, endav);
636 return STATUS_NATIVE_EXPORT;
639 PerlIO_printf(PerlIO_stderr(), "panic: top_env\n");
643 sv_setpvn(linestr,"",0);
644 sv = newSVpv("",0); /* first used for -I flags */
648 for (argc--,argv++; argc > 0; argc--,argv++) {
649 if (argv[0][0] != '-' || !argv[0][1])
653 validarg = " PHOOEY ";
678 if (s = moreswitches(s))
688 if (euid != uid || egid != gid)
689 croak("No -e allowed in setuid scripts");
691 e_tmpname = savepv(TMPPATH);
692 (void)mktemp(e_tmpname);
694 croak("Can't mktemp()");
695 e_fp = PerlIO_open(e_tmpname,"w");
697 croak("Cannot open temporary file");
702 PerlIO_puts(e_fp,argv[1]);
706 croak("No code specified for -e");
707 (void)PerlIO_putc(e_fp,'\n');
718 incpush(argv[1], TRUE);
719 sv_catpv(sv,argv[1]);
736 preambleav = newAV();
737 av_push(preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
739 Sv = newSVpv("print myconfig();",0);
741 sv_catpv(Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
743 sv_catpv(Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
745 #if defined(DEBUGGING) || defined(NO_EMBED) || defined(MULTIPLICITY)
746 sv_catpv(Sv,"\" Compile-time options:");
748 sv_catpv(Sv," DEBUGGING");
751 sv_catpv(Sv," NO_EMBED");
754 sv_catpv(Sv," MULTIPLICITY");
756 sv_catpv(Sv,"\\n\",");
758 #if defined(LOCAL_PATCH_COUNT)
759 if (LOCAL_PATCH_COUNT > 0) {
761 sv_catpv(Sv,"\" Locally applied patches:\\n\",");
762 for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
764 sv_catpvf(Sv,"\" \\t%s\\n\",",localpatches[i]);
768 sv_catpvf(Sv,"\" Built under %s\\n\"",OSNAME);
771 sv_catpvf(Sv,",\" Compiled at %s %s\\n\"",__DATE__,__TIME__);
773 sv_catpvf(Sv,",\" Compiled on %s\\n\"",__DATE__);
778 @env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; \
779 print \" \\%ENV:\\n @env\\n\" if @env; \
780 print \" \\@INC:\\n @INC\\n\";");
783 Sv = newSVpv("config_vars(qw(",0);
788 av_push(preambleav, Sv);
789 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
803 croak("Unrecognized switch: -%s",s);
808 if (!tainting && (s = getenv("PERL5OPT"))) {
819 if (!strchr("DIMUdmw", *s))
820 croak("Illegal switch in PERL5OPT: -%c", *s);
826 scriptname = argv[0];
828 if (PerlIO_flush(e_fp) || PerlIO_error(e_fp) || PerlIO_close(e_fp)) {
830 warn("Did you forget to compile with -DMULTIPLICITY?");
832 croak("Can't write to temp file for -e: %s", Strerror(errno));
836 scriptname = e_tmpname;
838 else if (scriptname == Nullch) {
840 if ( isatty(PerlIO_fileno(PerlIO_stdin())) )
848 open_script(scriptname,dosearch,sv);
850 validate_suid(validarg, scriptname);
855 main_cv = compcv = (CV*)NEWSV(1104,0);
856 sv_upgrade((SV *)compcv, SVt_PVCV);
860 av_push(comppad, Nullsv);
861 curpad = AvARRAY(comppad);
862 comppad_name = newAV();
863 comppad_name_fill = 0;
864 min_intro_pending = 0;
867 av_store(comppad_name, 0, newSVpv("@_", 2));
868 curpad[0] = (SV*)newAV();
869 SvPADMY_on(curpad[0]); /* XXX Needed? */
871 New(666, CvMUTEXP(compcv), 1, perl_mutex);
872 MUTEX_INIT(CvMUTEXP(compcv));
873 #endif /* USE_THREADS */
875 comppadlist = newAV();
876 AvREAL_off(comppadlist);
877 av_store(comppadlist, 0, (SV*)comppad_name);
878 av_store(comppadlist, 1, (SV*)comppad);
879 CvPADLIST(compcv) = comppadlist;
881 boot_core_UNIVERSAL();
883 (*xsinit)(); /* in case linked C routines want magical variables */
888 #if defined(DEBUGGING) && defined(USE_THREADS) && defined(__linux__)
889 DEBUG_L(signal(SIGSEGV, (void(*)(int))catch_sigsegv););
892 init_predump_symbols();
894 init_postdump_symbols(argc,argv,env);
898 /* now parse the script */
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(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), rs);
932 #ifdef DEBUGGING_MSTATS
933 if ((s=getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
934 dump_mstats("after compilation:");
945 PerlInterpreter *sv_interp;
952 if (!(curinterp = sv_interp))
955 oldscope = scopestack_ix;
960 cxstack_ix = -1; /* start context stack again */
963 /* my_exit() was called */
964 while (scopestack_ix > oldscope)
968 call_list(oldscope, endav);
970 #ifdef DEBUGGING_MSTATS
971 if (getenv("PERL_DEBUG_MSTATS"))
972 dump_mstats("after execution: ");
975 return STATUS_NATIVE_EXPORT;
978 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
983 if (curstack != mainstack) {
985 SWITCHSTACK(curstack, mainstack);
990 DEBUG_r(PerlIO_printf(PerlIO_stderr(), "%s $` $& $' support.\n",
991 sawampersand ? "Enabling" : "Omitting"));
995 DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
997 DEBUG_L(PerlIO_printf(Perl_debug_log, "main thread is 0x%lx\n",
998 (unsigned long) thr));
999 #endif /* USE_THREADS */
1002 PerlIO_printf(PerlIO_stderr(), "%s syntax OK\n", origfilename);
1005 if (perldb && DBsingle)
1006 sv_setiv(DBsingle, 1);
1008 call_list(oldscope, initav);
1018 else if (main_start) {
1019 CvDEPTH(main_cv) = 1;
1030 perl_get_sv(name, create)
1034 GV* gv = gv_fetchpv(name, create, SVt_PV);
1041 perl_get_av(name, create)
1045 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
1054 perl_get_hv(name, create)
1058 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
1067 perl_get_cv(name, 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(subname, flags, argv)
1087 I32 flags; /* See G_* flags in cop.h */
1088 register char **argv; /* null terminated arg list */
1096 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
1101 return perl_call_pv(subname, flags);
1105 perl_call_pv(subname, flags)
1106 char *subname; /* name of the subroutine */
1107 I32 flags; /* See G_* flags in cop.h */
1109 return perl_call_sv((SV*)perl_get_cv(subname, TRUE), flags);
1113 perl_call_method(methname, flags)
1114 char *methname; /* name of the subroutine */
1115 I32 flags; /* See G_* flags in cop.h */
1122 XPUSHs(sv_2mortal(newSVpv(methname,0)));
1125 return perl_call_sv(*stack_sp--, flags);
1128 /* May be called with any of a CV, a GV, or an SV containing the name. */
1130 perl_call_sv(sv, flags)
1132 I32 flags; /* See G_* flags in cop.h */
1135 LOGOP myop; /* fake syntax tree node */
1141 bool oldcatch = CATCH_GET;
1145 if (flags & G_DISCARD) {
1150 Zero(&myop, 1, LOGOP);
1151 myop.op_next = Nullop;
1152 if (!(flags & G_NOARGS))
1153 myop.op_flags |= OPf_STACKED;
1154 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1155 (flags & G_ARRAY) ? OPf_WANT_LIST :
1160 EXTEND(stack_sp, 1);
1163 oldscope = scopestack_ix;
1165 if (perldb && curstash != debstash
1166 /* Handle first BEGIN of -d. */
1167 && (DBcv || (DBcv = GvCV(DBsub)))
1168 /* Try harder, since this may have been a sighandler, thus
1169 * curstash may be meaningless. */
1170 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != debstash))
1171 op->op_private |= OPpENTERSUB_DB;
1173 if (flags & G_EVAL) {
1174 cLOGOP->op_other = op;
1176 /* we're trying to emulate pp_entertry() here */
1178 register CONTEXT *cx;
1179 I32 gimme = GIMME_V;
1184 push_return(op->op_next);
1185 PUSHBLOCK(cx, CXt_EVAL, stack_sp);
1187 eval_root = op; /* Only needed so that goto works right. */
1190 if (flags & G_KEEPERR)
1193 sv_setpv(GvSV(errgv),"");
1205 /* my_exit() was called */
1206 curstash = defstash;
1210 croak("Callback called exit");
1219 stack_sp = stack_base + oldmark;
1220 if (flags & G_ARRAY)
1224 *++stack_sp = &sv_undef;
1232 if (op == (OP*)&myop)
1233 op = pp_entersub(ARGS);
1236 retval = stack_sp - (stack_base + oldmark);
1237 if ((flags & G_EVAL) && !(flags & G_KEEPERR))
1238 sv_setpv(GvSV(errgv),"");
1241 if (flags & G_EVAL) {
1242 if (scopestack_ix > oldscope) {
1246 register CONTEXT *cx;
1258 CATCH_SET(oldcatch);
1260 if (flags & G_DISCARD) {
1261 stack_sp = stack_base + oldmark;
1269 /* Eval a string. The G_EVAL flag is always assumed. */
1272 perl_eval_sv(sv, flags)
1274 I32 flags; /* See G_* flags in cop.h */
1277 UNOP myop; /* fake syntax tree node */
1279 I32 oldmark = sp - stack_base;
1285 if (flags & G_DISCARD) {
1293 EXTEND(stack_sp, 1);
1295 oldscope = scopestack_ix;
1297 if (!(flags & G_NOARGS))
1298 myop.op_flags = OPf_STACKED;
1299 myop.op_next = Nullop;
1300 myop.op_type = OP_ENTEREVAL;
1301 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1302 (flags & G_ARRAY) ? OPf_WANT_LIST :
1304 if (flags & G_KEEPERR)
1305 myop.op_flags |= OPf_SPECIAL;
1315 /* my_exit() was called */
1316 curstash = defstash;
1320 croak("Callback called exit");
1329 stack_sp = stack_base + oldmark;
1330 if (flags & G_ARRAY)
1334 *++stack_sp = &sv_undef;
1339 if (op == (OP*)&myop)
1340 op = pp_entereval(ARGS);
1343 retval = stack_sp - (stack_base + oldmark);
1344 if (!(flags & G_KEEPERR))
1345 sv_setpv(GvSV(errgv),"");
1349 if (flags & G_DISCARD) {
1350 stack_sp = stack_base + oldmark;
1359 perl_eval_pv(p, croak_on_error)
1365 SV* sv = newSVpv(p, 0);
1368 perl_eval_sv(sv, G_SCALAR);
1375 if (croak_on_error && SvTRUE(GvSV(errgv)))
1376 croak(SvPVx(GvSV(errgv), na));
1381 /* Require a module. */
1387 SV* sv = sv_newmortal();
1388 sv_setpv(sv, "require '");
1391 perl_eval_sv(sv, G_DISCARD);
1395 magicname(sym,name,namlen)
1402 if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
1403 sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
1407 usage(name) /* XXX move this out into a module ? */
1410 /* This message really ought to be max 23 lines.
1411 * Removed -h because the user already knows that opton. Others? */
1412 printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
1413 printf("\n -0[octal] specify record separator (\\0, if no argument)");
1414 printf("\n -a autosplit mode with -n or -p (splits $_ into @F)");
1415 printf("\n -c check syntax only (runs BEGIN and END blocks)");
1416 printf("\n -d[:debugger] run scripts under debugger");
1417 printf("\n -D[number/list] set debugging flags (argument is a bit mask or flags)");
1418 printf("\n -e 'command' one line of script. Several -e's allowed. Omit [programfile].");
1419 printf("\n -F/pattern/ split() pattern for autosplit (-a). The //'s are optional.");
1420 printf("\n -i[extension] edit <> files in place (make backup if extension supplied)");
1421 printf("\n -Idirectory specify @INC/#include directory (may be used more then once)");
1422 printf("\n -l[octal] enable line ending processing, specifies line teminator");
1423 printf("\n -[mM][-]module.. executes `use/no module...' before executing your script.");
1424 printf("\n -n assume 'while (<>) { ... }' loop arround your script");
1425 printf("\n -p assume loop like -n but print line also like sed");
1426 printf("\n -P run script through C preprocessor before compilation");
1427 printf("\n -s enable some switch parsing for switches after script name");
1428 printf("\n -S look for the script using PATH environment variable");
1429 printf("\n -T turn on tainting checks");
1430 printf("\n -u dump core after parsing script");
1431 printf("\n -U allow unsafe operations");
1432 printf("\n -v print version number and patchlevel of perl");
1433 printf("\n -V[:variable] print perl configuration information");
1434 printf("\n -w TURN WARNINGS ON FOR COMPILATION OF YOUR SCRIPT.");
1435 printf("\n -x[directory] strip off text before #!perl line and perhaps cd to directory\n");
1438 /* This routine handles any switches that can be given during run */
1449 rschar = scan_oct(s, 4, &numlen);
1451 if (rschar & ~((U8)~0))
1453 else if (!rschar && numlen >= 2)
1454 nrs = newSVpv("", 0);
1457 nrs = newSVpv(&ch, 1);
1462 splitstr = savepv(s + 1);
1476 if (*s == ':' || *s == '=') {
1477 my_setenv("PERL5DB", form("use Devel::%s;", ++s));
1488 if (isALPHA(s[1])) {
1489 static char debopts[] = "psltocPmfrxuLHXD";
1492 for (s++; *s && (d = strchr(debopts,*s)); s++)
1493 debug |= 1 << (d - debopts);
1497 for (s++; isDIGIT(*s); s++) ;
1499 debug |= 0x80000000;
1501 warn("Recompile perl with -DDEBUGGING to use -D switch\n");
1502 for (s++; isALNUM(*s); s++) ;
1512 inplace = savepv(s+1);
1514 for (s = inplace; *s && !isSPACE(*s); s++) ;
1521 for (e = s; *e && !isSPACE(*e); e++) ;
1522 p = savepvn(s, e-s);
1529 croak("No space allowed after -I");
1539 *ors = scan_oct(s, 3 + (*s == '0'), &numlen);
1548 ors = SvPV(nrs, orslen);
1549 ors = savepvn(ors, orslen);
1553 forbid_setid("-M"); /* XXX ? */
1556 forbid_setid("-m"); /* XXX ? */
1561 /* -M-foo == 'no foo' */
1562 if (*s == '-') { use = "no "; ++s; }
1563 sv = newSVpv(use,0);
1565 /* We allow -M'Module qw(Foo Bar)' */
1566 while(isALNUM(*s) || *s==':') ++s;
1568 sv_catpv(sv, start);
1569 if (*(start-1) == 'm') {
1571 croak("Can't use '%c' after -mname", *s);
1572 sv_catpv( sv, " ()");
1575 sv_catpvn(sv, start, s-start);
1576 sv_catpv(sv, " split(/,/,q{");
1581 if (preambleav == NULL)
1582 preambleav = newAV();
1583 av_push(preambleav, sv);
1586 croak("No space allowed after -%c", *(s-1));
1603 croak("Too late for \"-T\" option");
1615 #if defined(SUBVERSION) && SUBVERSION > 0
1616 printf("\nThis is perl, version 5.%03d_%02d", PATCHLEVEL, SUBVERSION);
1618 printf("\nThis is perl, version %s",patchlevel);
1621 printf("\n\nCopyright 1987-1997, Larry Wall\n");
1623 printf("\n\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
1626 printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n");
1629 printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
1630 "Version 5 port Copyright (c) 1994-1997, Andreas Kaiser, Ilya Zakharevich\n");
1633 printf("atariST series port, ++jrb bammi@cadence.com\n");
1636 Perl may be copied only under the terms of either the Artistic License or the\n\
1637 GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n");
1645 if (s[1] == '-') /* Additional switches on #! line. */
1653 #ifdef ALTERNATE_SHEBANG
1654 case 'S': /* OS/2 needs -S on "extproc" line. */
1662 croak("Can't emulate -%.1s on #! line",s);
1667 /* compliments of Tom Christiansen */
1669 /* unexec() can be found in the Gnu emacs distribution */
1680 prog = newSVpv(BIN_EXP);
1681 sv_catpv(prog, "/perl");
1682 file = newSVpv(origfilename);
1683 sv_catpv(file, ".perldump");
1685 status = unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
1687 PerlIO_printf(PerlIO_stderr(), "unexec of %s into %s failed!\n",
1688 SvPVX(prog), SvPVX(file));
1692 # include <lib$routines.h>
1693 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
1695 ABORT(); /* for use with undump */
1706 /* Note that strtab is a rather special HV. Assumptions are made
1707 about not iterating on it, and not adding tie magic to it.
1708 It is properly deallocated in perl_destruct() */
1710 HvSHAREKEYS_off(strtab); /* mandatory */
1711 Newz(506,((XPVHV*)SvANY(strtab))->xhv_array,
1712 sizeof(HE*) * (((XPVHV*)SvANY(strtab))->xhv_max + 1), char);
1714 curstash = defstash = newHV();
1715 curstname = newSVpv("main",4);
1716 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
1717 SvREFCNT_dec(GvHV(gv));
1718 GvHV(gv) = (HV*)SvREFCNT_inc(defstash);
1720 HvNAME(defstash) = savepv("main");
1721 incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
1723 defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
1724 errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
1726 sv_setpvn(GvSV(errgv), "", 0);
1727 curstash = defstash;
1728 compiling.cop_stash = defstash;
1729 debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
1730 /* We must init $/ before switches are processed. */
1731 sv_setpvn(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), "\n", 1);
1734 #ifdef CAN_PROTOTYPE
1736 open_script(char *scriptname, bool dosearch, SV *sv)
1739 open_script(scriptname,dosearch,sv)
1746 char *xfound = Nullch;
1747 char *xfailed = Nullch;
1751 #if defined(DOSISH) && !defined(OS2) && !defined(atarist)
1752 # define SEARCH_EXTS ".bat", ".cmd", NULL
1753 # define MAX_EXT_LEN 4
1756 # define SEARCH_EXTS ".pl", ".com", NULL
1757 # define MAX_EXT_LEN 4
1759 /* additional extensions to try in each dir if scriptname not found */
1761 char *ext[] = { SEARCH_EXTS };
1762 int extidx = (strchr(scriptname,'.')) ? -1 : 0; /* has ext already */
1764 # define MAX_EXT_LEN 0
1769 int hasdir, idx = 0, deftypes = 1;
1771 hasdir = (strpbrk(scriptname,":[</") != Nullch) ;
1772 /* The first time through, just add SEARCH_EXTS to whatever we
1773 * already have, so we can check for default file types. */
1775 (!hasdir && my_trnlnm("DCL$PATH",tokenbuf,idx++)) )
1781 if ((strlen(tokenbuf) + strlen(scriptname)
1782 + MAX_EXT_LEN) >= sizeof tokenbuf)
1783 continue; /* don't search dir with too-long name */
1784 strcat(tokenbuf, scriptname);
1786 if (dosearch && !strchr(scriptname, '/') && (s = getenv("PATH"))) {
1787 bufend = s + strlen(s);
1788 while (s < bufend) {
1790 s = delimcpy(tokenbuf, tokenbuf + sizeof tokenbuf, s, bufend,
1798 for (len = 0; *s && *s != ',' && *s != ';'; len++, s++) {
1799 if (len < sizeof tokenbuf)
1802 if (len < sizeof tokenbuf)
1803 tokenbuf[len] = '\0';
1804 #endif /* atarist */
1807 if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tokenbuf)
1808 continue; /* don't search dir with too-long name */
1810 #if defined(atarist) && !defined(DOSISH)
1811 && tokenbuf[len - 1] != '/'
1813 #if defined(atarist) || defined(DOSISH)
1814 && tokenbuf[len - 1] != '\\'
1817 tokenbuf[len++] = '/';
1818 (void)strcpy(tokenbuf + len, scriptname);
1822 len = strlen(tokenbuf);
1823 if (extidx > 0) /* reset after previous loop */
1827 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tokenbuf));
1828 retval = Stat(tokenbuf,&statbuf);
1830 } while ( retval < 0 /* not there */
1831 && extidx>=0 && ext[extidx] /* try an extension? */
1832 && strcpy(tokenbuf+len, ext[extidx++])
1837 if (S_ISREG(statbuf.st_mode)
1838 && cando(S_IRUSR,TRUE,&statbuf)
1840 && cando(S_IXUSR,TRUE,&statbuf)
1844 xfound = tokenbuf; /* bingo! */
1848 xfailed = savepv(tokenbuf);
1851 croak("Can't execute %s", xfailed ? xfailed : scriptname );
1854 scriptname = xfound;
1857 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
1858 char *s = scriptname + 8;
1867 origfilename = savepv(e_tmpname ? "-e" : scriptname);
1868 curcop->cop_filegv = gv_fetchfile(origfilename);
1869 if (strEQ(origfilename,"-"))
1871 if (fdscript >= 0) {
1872 rsfp = PerlIO_fdopen(fdscript,"r");
1873 #if defined(HAS_FCNTL) && defined(F_SETFD)
1875 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
1878 else if (preprocess) {
1879 char *cpp_cfg = CPPSTDIN;
1880 SV *cpp = NEWSV(0,0);
1881 SV *cmd = NEWSV(0,0);
1883 if (strEQ(cpp_cfg, "cppstdin"))
1884 sv_catpvf(cpp, "%s/", BIN_EXP);
1885 sv_catpv(cpp, cpp_cfg);
1888 sv_catpv(sv,PRIVLIB_EXP);
1892 sed %s -e \"/^[^#]/b\" \
1893 -e \"/^#[ ]*include[ ]/b\" \
1894 -e \"/^#[ ]*define[ ]/b\" \
1895 -e \"/^#[ ]*if[ ]/b\" \
1896 -e \"/^#[ ]*ifdef[ ]/b\" \
1897 -e \"/^#[ ]*ifndef[ ]/b\" \
1898 -e \"/^#[ ]*else/b\" \
1899 -e \"/^#[ ]*elif[ ]/b\" \
1900 -e \"/^#[ ]*undef[ ]/b\" \
1901 -e \"/^#[ ]*endif/b\" \
1904 (doextract ? "-e \"1,/^#/d\n\"" : ""),
1907 %s %s -e '/^[^#]/b' \
1908 -e '/^#[ ]*include[ ]/b' \
1909 -e '/^#[ ]*define[ ]/b' \
1910 -e '/^#[ ]*if[ ]/b' \
1911 -e '/^#[ ]*ifdef[ ]/b' \
1912 -e '/^#[ ]*ifndef[ ]/b' \
1913 -e '/^#[ ]*else/b' \
1914 -e '/^#[ ]*elif[ ]/b' \
1915 -e '/^#[ ]*undef[ ]/b' \
1916 -e '/^#[ ]*endif/b' \
1924 (doextract ? "-e '1,/^#/d\n'" : ""),
1926 scriptname, cpp, sv, CPPMINUS);
1928 #ifdef IAMSUID /* actually, this is caught earlier */
1929 if (euid != uid && !euid) { /* if running suidperl */
1931 (void)seteuid(uid); /* musn't stay setuid root */
1934 (void)setreuid((Uid_t)-1, uid);
1936 #ifdef HAS_SETRESUID
1937 (void)setresuid((Uid_t)-1, uid, (Uid_t)-1);
1943 if (geteuid() != uid)
1944 croak("Can't do seteuid!\n");
1946 #endif /* IAMSUID */
1947 rsfp = my_popen(SvPVX(cmd), "r");
1951 else if (!*scriptname) {
1952 forbid_setid("program input from stdin");
1953 rsfp = PerlIO_stdin();
1956 rsfp = PerlIO_open(scriptname,"r");
1957 #if defined(HAS_FCNTL) && defined(F_SETFD)
1959 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
1967 #ifndef IAMSUID /* in case script is not readable before setuid */
1968 if (euid && Stat(SvPVX(GvSV(curcop->cop_filegv)),&statbuf) >= 0 &&
1969 statbuf.st_mode & (S_ISUID|S_ISGID)) {
1971 execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
1972 croak("Can't do setuid\n");
1976 croak("Can't open perl script \"%s\": %s\n",
1977 SvPVX(GvSV(curcop->cop_filegv)), Strerror(errno));
1982 validate_suid(validarg, scriptname)
1988 /* do we need to emulate setuid on scripts? */
1990 /* This code is for those BSD systems that have setuid #! scripts disabled
1991 * in the kernel because of a security problem. Merely defining DOSUID
1992 * in perl will not fix that problem, but if you have disabled setuid
1993 * scripts in the kernel, this will attempt to emulate setuid and setgid
1994 * on scripts that have those now-otherwise-useless bits set. The setuid
1995 * root version must be called suidperl or sperlN.NNN. If regular perl
1996 * discovers that it has opened a setuid script, it calls suidperl with
1997 * the same argv that it had. If suidperl finds that the script it has
1998 * just opened is NOT setuid root, it sets the effective uid back to the
1999 * uid. We don't just make perl setuid root because that loses the
2000 * effective uid we had before invoking perl, if it was different from the
2003 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
2004 * be defined in suidperl only. suidperl must be setuid root. The
2005 * Configure script will set this up for you if you want it.
2011 if (Fstat(PerlIO_fileno(rsfp),&statbuf) < 0) /* normal stat is insecure */
2012 croak("Can't stat script \"%s\"",origfilename);
2013 if (fdscript < 0 && statbuf.st_mode & (S_ISUID|S_ISGID)) {
2017 #ifndef HAS_SETREUID
2018 /* On this access check to make sure the directories are readable,
2019 * there is actually a small window that the user could use to make
2020 * filename point to an accessible directory. So there is a faint
2021 * chance that someone could execute a setuid script down in a
2022 * non-accessible directory. I don't know what to do about that.
2023 * But I don't think it's too important. The manual lies when
2024 * it says access() is useful in setuid programs.
2026 if (access(SvPVX(GvSV(curcop->cop_filegv)),1)) /*double check*/
2027 croak("Permission denied");
2029 /* If we can swap euid and uid, then we can determine access rights
2030 * with a simple stat of the file, and then compare device and
2031 * inode to make sure we did stat() on the same file we opened.
2032 * Then we just have to make sure he or she can execute it.
2035 struct stat tmpstatbuf;
2039 setreuid(euid,uid) < 0
2042 setresuid(euid,uid,(Uid_t)-1) < 0
2045 || getuid() != euid || geteuid() != uid)
2046 croak("Can't swap uid and euid"); /* really paranoid */
2047 if (Stat(SvPVX(GvSV(curcop->cop_filegv)),&tmpstatbuf) < 0)
2048 croak("Permission denied"); /* testing full pathname here */
2049 if (tmpstatbuf.st_dev != statbuf.st_dev ||
2050 tmpstatbuf.st_ino != statbuf.st_ino) {
2051 (void)PerlIO_close(rsfp);
2052 if (rsfp = my_popen("/bin/mail root","w")) { /* heh, heh */
2054 "User %ld tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
2055 (Filename of set-id script was %s, uid %ld gid %ld.)\n\nSincerely,\nperl\n",
2056 (long)uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
2057 (long)statbuf.st_dev, (long)statbuf.st_ino,
2058 SvPVX(GvSV(curcop->cop_filegv)),
2059 (long)statbuf.st_uid, (long)statbuf.st_gid);
2060 (void)my_pclose(rsfp);
2062 croak("Permission denied\n");
2066 setreuid(uid,euid) < 0
2068 # if defined(HAS_SETRESUID)
2069 setresuid(uid,euid,(Uid_t)-1) < 0
2072 || getuid() != uid || geteuid() != euid)
2073 croak("Can't reswap uid and euid");
2074 if (!cando(S_IXUSR,FALSE,&statbuf)) /* can real uid exec? */
2075 croak("Permission denied\n");
2077 #endif /* HAS_SETREUID */
2078 #endif /* IAMSUID */
2080 if (!S_ISREG(statbuf.st_mode))
2081 croak("Permission denied");
2082 if (statbuf.st_mode & S_IWOTH)
2083 croak("Setuid/gid script is writable by world");
2084 doswitches = FALSE; /* -s is insecure in suid */
2086 if (sv_gets(linestr, rsfp, 0) == Nullch ||
2087 strnNE(SvPV(linestr,na),"#!",2) ) /* required even on Sys V */
2088 croak("No #! line");
2089 s = SvPV(linestr,na)+2;
2091 while (!isSPACE(*s)) s++;
2092 for (s2 = s; (s2 > SvPV(linestr,na)+2 &&
2093 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
2094 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
2095 croak("Not a perl script");
2096 while (*s == ' ' || *s == '\t') s++;
2098 * #! arg must be what we saw above. They can invoke it by
2099 * mentioning suidperl explicitly, but they may not add any strange
2100 * arguments beyond what #! says if they do invoke suidperl that way.
2102 len = strlen(validarg);
2103 if (strEQ(validarg," PHOOEY ") ||
2104 strnNE(s,validarg,len) || !isSPACE(s[len]))
2105 croak("Args must match #! line");
2108 if (euid != uid && (statbuf.st_mode & S_ISUID) &&
2109 euid == statbuf.st_uid)
2111 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2112 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2113 #endif /* IAMSUID */
2115 if (euid) { /* oops, we're not the setuid root perl */
2116 (void)PerlIO_close(rsfp);
2119 execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
2121 croak("Can't do setuid\n");
2124 if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid) {
2126 (void)setegid(statbuf.st_gid);
2129 (void)setregid((Gid_t)-1,statbuf.st_gid);
2131 #ifdef HAS_SETRESGID
2132 (void)setresgid((Gid_t)-1,statbuf.st_gid,(Gid_t)-1);
2134 setgid(statbuf.st_gid);
2138 if (getegid() != statbuf.st_gid)
2139 croak("Can't do setegid!\n");
2141 if (statbuf.st_mode & S_ISUID) {
2142 if (statbuf.st_uid != euid)
2144 (void)seteuid(statbuf.st_uid); /* all that for this */
2147 (void)setreuid((Uid_t)-1,statbuf.st_uid);
2149 #ifdef HAS_SETRESUID
2150 (void)setresuid((Uid_t)-1,statbuf.st_uid,(Uid_t)-1);
2152 setuid(statbuf.st_uid);
2156 if (geteuid() != statbuf.st_uid)
2157 croak("Can't do seteuid!\n");
2159 else if (uid) { /* oops, mustn't run as root */
2161 (void)seteuid((Uid_t)uid);
2164 (void)setreuid((Uid_t)-1,(Uid_t)uid);
2166 #ifdef HAS_SETRESUID
2167 (void)setresuid((Uid_t)-1,(Uid_t)uid,(Uid_t)-1);
2173 if (geteuid() != uid)
2174 croak("Can't do seteuid!\n");
2177 if (!cando(S_IXUSR,TRUE,&statbuf))
2178 croak("Permission denied\n"); /* they can't do this */
2181 else if (preprocess)
2182 croak("-P not allowed for setuid/setgid script\n");
2183 else if (fdscript >= 0)
2184 croak("fd script not allowed in suidperl\n");
2186 croak("Script is not setuid/setgid in suidperl\n");
2188 /* We absolutely must clear out any saved ids here, so we */
2189 /* exec the real perl, substituting fd script for scriptname. */
2190 /* (We pass script name as "subdir" of fd, which perl will grok.) */
2191 PerlIO_rewind(rsfp);
2192 lseek(PerlIO_fileno(rsfp),(Off_t)0,0); /* just in case rewind didn't */
2193 for (which = 1; origargv[which] && origargv[which] != scriptname; which++) ;
2194 if (!origargv[which])
2195 croak("Permission denied");
2196 origargv[which] = savepv(form("/dev/fd/%d/%s",
2197 PerlIO_fileno(rsfp), origargv[which]));
2198 #if defined(HAS_FCNTL) && defined(F_SETFD)
2199 fcntl(PerlIO_fileno(rsfp),F_SETFD,0); /* ensure no close-on-exec */
2201 execv(form("%s/perl%s", BIN_EXP, patchlevel), origargv); /* try again */
2202 croak("Can't do setuid\n");
2203 #endif /* IAMSUID */
2205 if (euid != uid || egid != gid) { /* (suidperl doesn't exist, in fact) */
2206 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
2207 Fstat(PerlIO_fileno(rsfp),&statbuf); /* may be either wrapped or real suid */
2208 if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
2210 (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
2213 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2214 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2215 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
2216 /* not set-id, must be wrapped */
2224 register char *s, *s2;
2226 /* skip forward in input to the real script? */
2230 if ((s = sv_gets(linestr, rsfp, 0)) == Nullch)
2231 croak("No Perl script found in input\n");
2232 if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
2233 PerlIO_ungetc(rsfp, '\n'); /* to keep line count right */
2235 while (*s && !(isSPACE (*s) || *s == '#')) s++;
2237 while (*s == ' ' || *s == '\t') s++;
2239 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
2240 if (strnEQ(s2-4,"perl",4))
2242 while (s = moreswitches(s)) ;
2244 if (cddir && chdir(cddir) < 0)
2245 croak("Can't chdir to %s",cddir);
2253 uid = (int)getuid();
2254 euid = (int)geteuid();
2255 gid = (int)getgid();
2256 egid = (int)getegid();
2261 tainting |= (uid && (euid != uid || egid != gid));
2269 croak("No %s allowed while running setuid", s);
2271 croak("No %s allowed while running setgid", s);
2278 curstash = debstash;
2279 dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
2281 DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
2282 DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
2283 DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
2284 DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
2285 sv_setiv(DBsingle, 0);
2286 DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
2287 sv_setiv(DBtrace, 0);
2288 DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
2289 sv_setiv(DBsignal, 0);
2290 curstash = defstash;
2298 mainstack = curstack; /* remember in case we switch stacks */
2299 AvREAL_off(curstack); /* not a real array */
2300 av_extend(curstack,127);
2302 stack_base = AvARRAY(curstack);
2303 stack_sp = stack_base;
2304 stack_max = stack_base + 127;
2306 cxstack_max = 8192 / sizeof(CONTEXT) - 2; /* Use most of 8K. */
2307 New(50,cxstack,cxstack_max + 1,CONTEXT);
2310 New(50,tmps_stack,128,SV*);
2316 * The following stacks almost certainly should be per-interpreter,
2317 * but for now they're not. XXX
2321 markstack_ptr = markstack;
2323 New(54,markstack,64,I32);
2324 markstack_ptr = markstack;
2325 markstack_max = markstack + 64;
2331 New(54,scopestack,32,I32);
2333 scopestack_max = 32;
2339 New(54,savestack,128,ANY);
2341 savestack_max = 128;
2347 New(54,retstack,16,OP*);
2358 Safefree(tmps_stack);
2365 static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
2373 subname = newSVpv("main",4);
2377 init_predump_symbols()
2383 sv_setpvn(GvSV(gv_fetchpv("\"", TRUE, SVt_PV)), " ", 1);
2385 stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
2386 GvMULTI_on(stdingv);
2387 IoIFP(GvIOp(stdingv)) = PerlIO_stdin();
2388 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
2390 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(stdingv));
2392 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
2394 IoOFP(GvIOp(tmpgv)) = IoIFP(GvIOp(tmpgv)) = PerlIO_stdout();
2396 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
2398 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(defoutgv));
2400 othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
2401 GvMULTI_on(othergv);
2402 IoOFP(GvIOp(othergv)) = IoIFP(GvIOp(othergv)) = PerlIO_stderr();
2403 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
2405 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(othergv));
2407 statname = NEWSV(66,0); /* last filename we did stat on */
2410 osname = savepv(OSNAME);
2414 init_postdump_symbols(argc,argv,env)
2416 register char **argv;
2417 register char **env;
2423 argc--,argv++; /* skip name of script */
2425 for (; argc > 0 && **argv == '-'; argc--,argv++) {
2428 if (argv[0][1] == '-') {
2432 if (s = strchr(argv[0], '=')) {
2434 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
2437 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
2440 toptarget = NEWSV(0,0);
2441 sv_upgrade(toptarget, SVt_PVFM);
2442 sv_setpvn(toptarget, "", 0);
2443 bodytarget = NEWSV(0,0);
2444 sv_upgrade(bodytarget, SVt_PVFM);
2445 sv_setpvn(bodytarget, "", 0);
2446 formtarget = bodytarget;
2449 if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
2450 sv_setpv(GvSV(tmpgv),origfilename);
2451 magicname("0", "0", 1);
2453 if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
2454 sv_setpv(GvSV(tmpgv),origargv[0]);
2455 if (argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
2457 (void)gv_AVadd(argvgv);
2458 av_clear(GvAVn(argvgv));
2459 for (; argc > 0; argc--,argv++) {
2460 av_push(GvAVn(argvgv),newSVpv(argv[0],0));
2463 if (envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
2467 hv_magic(hv, envgv, 'E');
2468 #ifndef VMS /* VMS doesn't have environ array */
2469 /* Note that if the supplied env parameter is actually a copy
2470 of the global environ then it may now point to free'd memory
2471 if the environment has been modified since. To avoid this
2472 problem we treat env==NULL as meaning 'use the default'
2477 environ[0] = Nullch;
2478 for (; *env; env++) {
2479 if (!(s = strchr(*env,'=')))
2485 sv = newSVpv(s--,0);
2486 (void)hv_store(hv, *env, s - *env, sv, 0);
2490 #ifdef DYNAMIC_ENV_FETCH
2491 HvNAME(hv) = savepv(ENV_HV_NAME);
2495 if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
2496 sv_setiv(GvSV(tmpgv), (IV)getpid());
2505 s = getenv("PERL5LIB");
2509 incpush(getenv("PERLLIB"), FALSE);
2511 /* Treat PERL5?LIB as a possible search list logical name -- the
2512 * "natural" VMS idiom for a Unix path string. We allow each
2513 * element to be a set of |-separated directories for compatibility.
2517 if (my_trnlnm("PERL5LIB",buf,0))
2518 do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
2520 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE);
2524 /* Use the ~-expanded versions of APPLLIB (undocumented),
2525 ARCHLIB PRIVLIB SITEARCH SITELIB and OLDARCHLIB
2528 incpush(APPLLIB_EXP, FALSE);
2532 incpush(ARCHLIB_EXP, FALSE);
2535 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
2537 incpush(PRIVLIB_EXP, FALSE);
2540 incpush(SITEARCH_EXP, FALSE);
2543 incpush(SITELIB_EXP, FALSE);
2545 #ifdef OLDARCHLIB_EXP /* 5.00[01] compatibility */
2546 incpush(OLDARCHLIB_EXP, FALSE);
2550 incpush(".", FALSE);
2554 # define PERLLIB_SEP ';'
2557 # define PERLLIB_SEP '|'
2559 # define PERLLIB_SEP ':'
2562 #ifndef PERLLIB_MANGLE
2563 # define PERLLIB_MANGLE(s,n) (s)
2567 incpush(p, addsubdirs)
2571 SV *subdir = Nullsv;
2572 static char *archpat_auto;
2579 if (!archpat_auto) {
2580 STRLEN len = (sizeof(ARCHNAME) + strlen(patchlevel)
2581 + sizeof("//auto"));
2582 New(55, archpat_auto, len, char);
2583 sprintf(archpat_auto, "/%s/%s/auto", ARCHNAME, patchlevel);
2585 for (len = sizeof(ARCHNAME) + 2;
2586 archpat_auto[len] != '\0' && archpat_auto[len] != '/'; len++)
2587 if (archpat_auto[len] == '.') archpat_auto[len] = '_';
2592 /* Break at all separators */
2594 SV *libdir = newSV(0);
2597 /* skip any consecutive separators */
2598 while ( *p == PERLLIB_SEP ) {
2599 /* Uncomment the next line for PATH semantics */
2600 /* av_push(GvAVn(incgv), newSVpv(".", 1)); */
2604 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
2605 sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
2610 sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
2611 p = Nullch; /* break out */
2615 * BEFORE pushing libdir onto @INC we may first push version- and
2616 * archname-specific sub-directories.
2619 struct stat tmpstatbuf;
2624 if ((unix = tounixspec_ts(SvPV(libdir,na),Nullch)) != Nullch) {
2626 while (unix[len-1] == '/') len--; /* Cosmetic */
2627 sv_usepvn(libdir,unix,len);
2630 PerlIO_printf(PerlIO_stderr(),
2631 "Failed to unixify @INC element \"%s\"\n",
2634 /* .../archname/version if -d .../archname/version/auto */
2635 sv_setsv(subdir, libdir);
2636 sv_catpv(subdir, archpat_auto);
2637 if (Stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2638 S_ISDIR(tmpstatbuf.st_mode))
2639 av_push(GvAVn(incgv),
2640 newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2642 /* .../archname if -d .../archname/auto */
2643 sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME),
2644 strlen(patchlevel) + 1, "", 0);
2645 if (Stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2646 S_ISDIR(tmpstatbuf.st_mode))
2647 av_push(GvAVn(incgv),
2648 newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2651 /* finally push this lib directory on the end of @INC */
2652 av_push(GvAVn(incgv), libdir);
2655 SvREFCNT_dec(subdir);
2659 call_list(oldscope, list)
2664 line_t oldline = curcop->cop_line;
2669 while (AvFILL(list) >= 0) {
2670 CV *cv = (CV*)av_shift(list);
2677 SV* atsv = GvSV(errgv);
2679 perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
2680 (void)SvPV(atsv, len);
2683 curcop = &compiling;
2684 curcop->cop_line = oldline;
2685 if (list == beginav)
2686 sv_catpv(atsv, "BEGIN failed--compilation aborted");
2688 sv_catpv(atsv, "END failed--cleanup aborted");
2689 while (scopestack_ix > oldscope)
2691 croak("%s", SvPVX(atsv));
2699 /* my_exit() was called */
2700 while (scopestack_ix > oldscope)
2702 curstash = defstash;
2704 call_list(oldscope, endav);
2707 curcop = &compiling;
2708 curcop->cop_line = oldline;
2710 if (list == beginav)
2711 croak("BEGIN failed--compilation aborted");
2713 croak("END failed--cleanup aborted");
2719 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
2724 curcop = &compiling;
2725 curcop->cop_line = oldline;
2739 DEBUG_L(PerlIO_printf(Perl_debug_log, "my_exit: thread 0x%lx, status %lu\n",
2740 (unsigned long) thr, (unsigned long) status));
2741 #endif /* USE_THREADS */
2750 STATUS_NATIVE_SET(status);
2760 if (vaxc$errno & 1) {
2761 if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
2762 STATUS_NATIVE_SET(44);
2765 if (!vaxc$errno && errno) /* unlikely */
2766 STATUS_NATIVE_SET(44);
2768 STATUS_NATIVE_SET(vaxc$errno);
2772 STATUS_POSIX_SET(errno);
2773 else if (STATUS_POSIX == 0)
2774 STATUS_POSIX_SET(255);
2783 register CONTEXT *cx;
2792 (void)UNLINK(e_tmpname);
2793 Safefree(e_tmpname);
2797 if (cxstack_ix >= 0) {