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 sighandlerp = sighandler;
168 MUTEX_INIT(&malloc_mutex);
169 MUTEX_INIT(&sv_mutex);
170 MUTEX_INIT(&eval_mutex);
171 MUTEX_INIT(&nthreads_mutex);
172 COND_INIT(&nthreads_cond);
178 * There is no way we can refer to them from Perl so close them to save
179 * space. The other alternative would be to provide STDAUX and STDPRN
182 (void)fclose(stdaux);
183 (void)fclose(stdprn);
189 perl_destruct_level = 1;
191 if(perl_destruct_level > 0)
197 start_env.je_prev = NULL;
198 start_env.je_ret = -1;
199 start_env.je_mustcatch = TRUE;
200 top_env = &start_env;
203 SET_NUMERIC_STANDARD();
204 #if defined(SUBVERSION) && SUBVERSION > 0
205 sprintf(patchlevel, "%7.5f", (double) 5
206 + ((double) PATCHLEVEL / (double) 1000)
207 + ((double) SUBVERSION / (double) 100000));
209 sprintf(patchlevel, "%5.3f", (double) 5 +
210 ((double) PATCHLEVEL / (double) 1000));
213 #if defined(LOCAL_PATCH_COUNT)
214 localpatches = local_patches; /* For possible -v */
217 PerlIO_init(); /* Hook to IO system */
219 fdpid = newAV(); /* for remembering popen pids by fd */
223 New(51,debname,128,char);
224 New(52,debdelim,128,char);
235 struct thread *thr = (struct thread *) arg;
237 * Decrement the global thread count and signal anyone listening.
238 * The only official thread listening is the original thread while
239 * in perl_destruct. It waits until it's the only thread and then
240 * performs END blocks and other process clean-ups.
242 DEBUG_L(PerlIO_printf(PerlIO_stderr(), "thread_destruct: 0x%lx\n", (unsigned long) thr));
245 MUTEX_LOCK(&nthreads_mutex);
247 COND_BROADCAST(&nthreads_cond);
248 MUTEX_UNLOCK(&nthreads_mutex);
250 #endif /* USE_THREADS */
253 perl_destruct(sv_interp)
254 register PerlInterpreter *sv_interp;
257 int destruct_level; /* 0=none, 1=full, 2=full with checks */
261 if (!(curinterp = sv_interp))
266 /* Wait until all user-created threads go away */
267 MUTEX_LOCK(&nthreads_mutex);
270 DEBUG_L(PerlIO_printf(PerlIO_stderr(), "perl_destruct: waiting for %d threads\n",
272 COND_WAIT(&nthreads_cond, &nthreads_mutex);
274 /* At this point, we're the last thread */
275 MUTEX_UNLOCK(&nthreads_mutex);
276 DEBUG_L(PerlIO_printf(PerlIO_stderr(), "perl_destruct: armageddon has arrived\n"));
277 MUTEX_DESTROY(&nthreads_mutex);
278 COND_DESTROY(&nthreads_cond);
279 #endif /* !defined(FAKE_THREADS) */
280 #endif /* USE_THREADS */
282 destruct_level = perl_destruct_level;
286 if (s = getenv("PERL_DESTRUCT_LEVEL")) {
288 if (destruct_level < i)
297 /* We must account for everything. */
299 /* Destroy the main CV and syntax tree */
301 curpad = AvARRAY(comppad);
306 SvREFCNT_dec(main_cv);
311 * Try to destruct global references. We do this first so that the
312 * destructors and destructees still exist. Some sv's might remain.
313 * Non-referenced objects are on their own.
320 /* unhook hooks which will soon be, or use, destroyed data */
321 SvREFCNT_dec(warnhook);
323 SvREFCNT_dec(diehook);
325 SvREFCNT_dec(parsehook);
328 if (destruct_level == 0){
330 DEBUG_P(debprofdump());
332 /* The exit() function will do everything that needs doing. */
336 /* loosen bonds of global variables */
339 (void)PerlIO_close(rsfp);
343 /* Filters for program text */
344 SvREFCNT_dec(rsfp_filters);
345 rsfp_filters = Nullav;
357 sawampersand = FALSE; /* must save all match strings */
358 sawstudy = FALSE; /* do fbm_instr on all strings */
373 /* magical thingies */
375 Safefree(ofs); /* $, */
378 Safefree(ors); /* $\ */
381 SvREFCNT_dec(nrs); /* $\ helper */
384 multiline = 0; /* $* */
386 SvREFCNT_dec(statname);
390 /* defgv, aka *_ should be taken care of elsewhere */
392 #if 0 /* just about all regexp stuff, seems to be ok */
394 /* shortcuts to regexp stuff */
399 SAVEFREEOP(oldlastpm); /* for saving regexp context during debugger */
401 regprecomp = NULL; /* uncompiled string. */
402 regparse = NULL; /* Input-scan pointer. */
403 regxend = NULL; /* End of input for compile */
404 regnpar = 0; /* () count. */
405 regcode = NULL; /* Code-emit pointer; ®dummy = don't. */
406 regsize = 0; /* Code size. */
407 regnaughty = 0; /* How bad is this pattern? */
408 regsawback = 0; /* Did we see \1, ...? */
410 reginput = NULL; /* String-input pointer. */
411 regbol = NULL; /* Beginning of input, for ^ check. */
412 regeol = NULL; /* End of input, for $ check. */
413 regstartp = (char **)NULL; /* Pointer to startp array. */
414 regendp = (char **)NULL; /* Ditto for endp. */
415 reglastparen = 0; /* Similarly for lastparen. */
416 regtill = NULL; /* How far we are required to go. */
417 regflags = 0; /* are we folding, multilining? */
418 regprev = (char)NULL; /* char before regbol, \n if none */
422 /* clean up after study() */
423 SvREFCNT_dec(lastscream);
425 Safefree(screamfirst);
427 Safefree(screamnext);
430 /* startup and shutdown function lists */
431 SvREFCNT_dec(beginav);
433 SvREFCNT_dec(initav);
438 /* temp stack during pp_sort() */
439 SvREFCNT_dec(sortstack);
442 /* shortcuts just get cleared */
452 /* reset so print() ends up where we expect */
455 /* Prepare to destruct main symbol table. */
462 if (destruct_level >= 2) {
463 if (scopestack_ix != 0)
464 warn("Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
465 (long)scopestack_ix);
466 if (savestack_ix != 0)
467 warn("Unbalanced saves: %ld more saves than restores\n",
469 if (tmps_floor != -1)
470 warn("Unbalanced tmps: %ld more allocs than frees\n",
471 (long)tmps_floor + 1);
472 if (cxstack_ix != -1)
473 warn("Unbalanced context: %ld more PUSHes than POPs\n",
474 (long)cxstack_ix + 1);
477 /* Now absolutely destruct everything, somehow or other, loops or no. */
479 SvFLAGS(strtab) |= SVTYPEMASK; /* don't clean out strtab now */
480 while (sv_count != 0 && sv_count != last_sv_count) {
481 last_sv_count = sv_count;
484 SvFLAGS(strtab) &= ~SVTYPEMASK;
485 SvFLAGS(strtab) |= SVt_PVHV;
487 /* Destruct the global string table. */
489 /* Yell and reset the HeVAL() slots that are still holding refcounts,
490 * so that sv_free() won't fail on them.
499 array = HvARRAY(strtab);
503 warn("Unbalanced string table refcount: (%d) for \"%s\"",
504 HeVAL(hent) - Nullsv, HeKEY(hent));
505 HeVAL(hent) = Nullsv;
515 SvREFCNT_dec(strtab);
518 warn("Scalars leaked: %ld\n", (long)sv_count);
522 /* No SVs have survived, need to clean out */
526 Safefree(origfilename);
528 hints = 0; /* Reset hints. Should hints be per-interpreter ? */
530 DEBUG_P(debprofdump());
532 MUTEX_DESTROY(&sv_mutex);
533 MUTEX_DESTROY(&malloc_mutex);
534 MUTEX_DESTROY(&eval_mutex);
535 #endif /* USE_THREADS */
537 /* As the absolutely last thing, free the non-arena SV for mess() */
540 /* we know that type >= SVt_PV */
542 Safefree(SvPVX(mess_sv));
543 Safefree(SvANY(mess_sv));
551 PerlInterpreter *sv_interp;
553 if (!(curinterp = sv_interp))
559 perl_parse(sv_interp, xsinit, argc, argv, env)
560 PerlInterpreter *sv_interp;
561 void (*xsinit)_((void));
569 char *scriptname = NULL;
570 VOL bool dosearch = FALSE;
577 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
580 croak("suidperl is no longer needed since the kernel can now execute\n\
581 setuid perl scripts securely.\n");
585 if (!(curinterp = sv_interp))
588 #if defined(NeXT) && defined(__DYNAMIC__)
589 _dyld_lookup_and_bind
590 ("__environ", (unsigned long *) &environ_pointer, NULL);
595 #ifndef VMS /* VMS doesn't have environ array */
596 origenviron = environ;
602 /* Come here if running an undumped a.out. */
604 origfilename = savepv(argv[0]);
606 cxstack_ix = -1; /* start label stack again */
608 init_postdump_symbols(argc,argv,env);
613 curpad = AvARRAY(comppad);
618 SvREFCNT_dec(main_cv);
622 oldscope = scopestack_ix;
630 /* my_exit() was called */
631 while (scopestack_ix > oldscope)
635 call_list(oldscope, endav);
637 return STATUS_NATIVE_EXPORT;
640 PerlIO_printf(PerlIO_stderr(), "panic: top_env\n");
644 sv_setpvn(linestr,"",0);
645 sv = newSVpv("",0); /* first used for -I flags */
649 for (argc--,argv++; argc > 0; argc--,argv++) {
650 if (argv[0][0] != '-' || !argv[0][1])
654 validarg = " PHOOEY ";
679 if (s = moreswitches(s))
689 if (euid != uid || egid != gid)
690 croak("No -e allowed in setuid scripts");
692 e_tmpname = savepv(TMPPATH);
693 (void)mktemp(e_tmpname);
695 croak("Can't mktemp()");
696 e_fp = PerlIO_open(e_tmpname,"w");
698 croak("Cannot open temporary file");
703 PerlIO_puts(e_fp,argv[1]);
707 croak("No code specified for -e");
708 (void)PerlIO_putc(e_fp,'\n');
719 incpush(argv[1], TRUE);
720 sv_catpv(sv,argv[1]);
737 preambleav = newAV();
738 av_push(preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
740 Sv = newSVpv("print myconfig();",0);
742 sv_catpv(Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
744 sv_catpv(Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
746 #if defined(DEBUGGING) || defined(NO_EMBED) || defined(MULTIPLICITY)
747 sv_catpv(Sv,"\" Compile-time options:");
749 sv_catpv(Sv," DEBUGGING");
752 sv_catpv(Sv," NO_EMBED");
755 sv_catpv(Sv," MULTIPLICITY");
757 sv_catpv(Sv,"\\n\",");
759 #if defined(LOCAL_PATCH_COUNT)
760 if (LOCAL_PATCH_COUNT > 0) {
762 sv_catpv(Sv,"\" Locally applied patches:\\n\",");
763 for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
765 sv_catpvf(Sv,"\" \\t%s\\n\",",localpatches[i]);
769 sv_catpvf(Sv,"\" Built under %s\\n\"",OSNAME);
772 sv_catpvf(Sv,",\" Compiled at %s %s\\n\"",__DATE__,__TIME__);
774 sv_catpvf(Sv,",\" Compiled on %s\\n\"",__DATE__);
779 @env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; \
780 print \" \\%ENV:\\n @env\\n\" if @env; \
781 print \" \\@INC:\\n @INC\\n\";");
784 Sv = newSVpv("config_vars(qw(",0);
789 av_push(preambleav, Sv);
790 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
804 croak("Unrecognized switch: -%s",s);
809 if (!tainting && (s = getenv("PERL5OPT"))) {
820 if (!strchr("DIMUdmw", *s))
821 croak("Illegal switch in PERL5OPT: -%c", *s);
827 scriptname = argv[0];
829 if (PerlIO_flush(e_fp) || PerlIO_error(e_fp) || PerlIO_close(e_fp)) {
831 warn("Did you forget to compile with -DMULTIPLICITY?");
833 croak("Can't write to temp file for -e: %s", Strerror(errno));
837 scriptname = e_tmpname;
839 else if (scriptname == Nullch) {
841 if ( isatty(PerlIO_fileno(PerlIO_stdin())) )
849 open_script(scriptname,dosearch,sv);
851 validate_suid(validarg, scriptname);
856 main_cv = compcv = (CV*)NEWSV(1104,0);
857 sv_upgrade((SV *)compcv, SVt_PVCV);
861 av_push(comppad, Nullsv);
862 curpad = AvARRAY(comppad);
863 comppad_name = newAV();
864 comppad_name_fill = 0;
865 min_intro_pending = 0;
868 av_store(comppad_name, 0, newSVpv("@_", 2));
869 curpad[0] = (SV*)newAV();
870 SvPADMY_on(curpad[0]); /* XXX Needed? */
872 New(666, CvMUTEXP(compcv), 1, perl_mutex);
873 MUTEX_INIT(CvMUTEXP(compcv));
874 #endif /* USE_THREADS */
876 comppadlist = newAV();
877 AvREAL_off(comppadlist);
878 av_store(comppadlist, 0, (SV*)comppad_name);
879 av_store(comppadlist, 1, (SV*)comppad);
880 CvPADLIST(compcv) = comppadlist;
882 boot_core_UNIVERSAL();
884 (*xsinit)(); /* in case linked C routines want magical variables */
889 #if defined(DEBUGGING) && defined(USE_THREADS) && defined(__linux__)
890 DEBUG_L(signal(SIGSEGV, (void(*)(int))catch_sigsegv););
893 init_predump_symbols();
895 init_postdump_symbols(argc,argv,env);
899 /* now parse the script */
902 if (yyparse() || error_count) {
904 croak("%s had compilation errors.\n", origfilename);
906 croak("Execution of %s aborted due to compilation errors.\n",
910 curcop->cop_line = 0;
914 (void)UNLINK(e_tmpname);
919 /* now that script is parsed, we can modify record separator */
921 rs = SvREFCNT_inc(nrs);
922 sv_setsv(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), rs);
933 #ifdef DEBUGGING_MSTATS
934 if ((s=getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
935 dump_mstats("after compilation:");
946 PerlInterpreter *sv_interp;
953 if (!(curinterp = sv_interp))
956 oldscope = scopestack_ix;
961 cxstack_ix = -1; /* start context stack again */
964 /* my_exit() was called */
965 while (scopestack_ix > oldscope)
969 call_list(oldscope, endav);
971 #ifdef DEBUGGING_MSTATS
972 if (getenv("PERL_DEBUG_MSTATS"))
973 dump_mstats("after execution: ");
976 return STATUS_NATIVE_EXPORT;
979 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
984 if (curstack != mainstack) {
986 SWITCHSTACK(curstack, mainstack);
991 DEBUG_r(PerlIO_printf(PerlIO_stderr(), "%s $` $& $' support.\n",
992 sawampersand ? "Enabling" : "Omitting"));
996 DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
998 DEBUG_L(PerlIO_printf(Perl_debug_log, "main thread is 0x%lx\n",
999 (unsigned long) thr));
1000 #endif /* USE_THREADS */
1003 PerlIO_printf(PerlIO_stderr(), "%s syntax OK\n", origfilename);
1006 if (perldb && DBsingle)
1007 sv_setiv(DBsingle, 1);
1009 call_list(oldscope, initav);
1019 else if (main_start) {
1020 CvDEPTH(main_cv) = 1;
1031 perl_get_sv(name, create)
1035 GV* gv = gv_fetchpv(name, create, SVt_PV);
1042 perl_get_av(name, create)
1046 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
1055 perl_get_hv(name, create)
1059 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
1068 perl_get_cv(name, create)
1072 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
1073 if (create && !GvCVu(gv))
1074 return newSUB(start_subparse(FALSE, 0),
1075 newSVOP(OP_CONST, 0, newSVpv(name,0)),
1083 /* Be sure to refetch the stack pointer after calling these routines. */
1086 perl_call_argv(subname, flags, argv)
1088 I32 flags; /* See G_* flags in cop.h */
1089 register char **argv; /* null terminated arg list */
1097 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
1102 return perl_call_pv(subname, flags);
1106 perl_call_pv(subname, flags)
1107 char *subname; /* name of the subroutine */
1108 I32 flags; /* See G_* flags in cop.h */
1110 return perl_call_sv((SV*)perl_get_cv(subname, TRUE), flags);
1114 perl_call_method(methname, flags)
1115 char *methname; /* name of the subroutine */
1116 I32 flags; /* See G_* flags in cop.h */
1123 XPUSHs(sv_2mortal(newSVpv(methname,0)));
1126 return perl_call_sv(*stack_sp--, flags);
1129 /* May be called with any of a CV, a GV, or an SV containing the name. */
1131 perl_call_sv(sv, flags)
1133 I32 flags; /* See G_* flags in cop.h */
1136 LOGOP myop; /* fake syntax tree node */
1142 bool oldcatch = CATCH_GET;
1146 if (flags & G_DISCARD) {
1151 Zero(&myop, 1, LOGOP);
1152 myop.op_next = Nullop;
1153 if (!(flags & G_NOARGS))
1154 myop.op_flags |= OPf_STACKED;
1155 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1156 (flags & G_ARRAY) ? OPf_WANT_LIST :
1161 EXTEND(stack_sp, 1);
1164 oldscope = scopestack_ix;
1166 if (perldb && curstash != debstash
1167 /* Handle first BEGIN of -d. */
1168 && (DBcv || (DBcv = GvCV(DBsub)))
1169 /* Try harder, since this may have been a sighandler, thus
1170 * curstash may be meaningless. */
1171 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != debstash))
1172 op->op_private |= OPpENTERSUB_DB;
1174 if (flags & G_EVAL) {
1175 cLOGOP->op_other = op;
1177 /* we're trying to emulate pp_entertry() here */
1179 register CONTEXT *cx;
1180 I32 gimme = GIMME_V;
1185 push_return(op->op_next);
1186 PUSHBLOCK(cx, CXt_EVAL, stack_sp);
1188 eval_root = op; /* Only needed so that goto works right. */
1191 if (flags & G_KEEPERR)
1194 sv_setpv(GvSV(errgv),"");
1206 /* my_exit() was called */
1207 curstash = defstash;
1211 croak("Callback called exit");
1220 stack_sp = stack_base + oldmark;
1221 if (flags & G_ARRAY)
1225 *++stack_sp = &sv_undef;
1233 if (op == (OP*)&myop)
1234 op = pp_entersub(ARGS);
1237 retval = stack_sp - (stack_base + oldmark);
1238 if ((flags & G_EVAL) && !(flags & G_KEEPERR))
1239 sv_setpv(GvSV(errgv),"");
1242 if (flags & G_EVAL) {
1243 if (scopestack_ix > oldscope) {
1247 register CONTEXT *cx;
1259 CATCH_SET(oldcatch);
1261 if (flags & G_DISCARD) {
1262 stack_sp = stack_base + oldmark;
1270 /* Eval a string. The G_EVAL flag is always assumed. */
1273 perl_eval_sv(sv, flags)
1275 I32 flags; /* See G_* flags in cop.h */
1278 UNOP myop; /* fake syntax tree node */
1280 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))
1346 sv_setpv(GvSV(errgv),"");
1350 if (flags & G_DISCARD) {
1351 stack_sp = stack_base + oldmark;
1360 perl_eval_pv(p, croak_on_error)
1366 SV* sv = newSVpv(p, 0);
1369 perl_eval_sv(sv, G_SCALAR);
1376 if (croak_on_error && SvTRUE(GvSV(errgv)))
1377 croak(SvPVx(GvSV(errgv), na));
1382 /* Require a module. */
1388 SV* sv = sv_newmortal();
1389 sv_setpv(sv, "require '");
1392 perl_eval_sv(sv, G_DISCARD);
1396 magicname(sym,name,namlen)
1403 if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
1404 sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
1408 usage(name) /* XXX move this out into a module ? */
1411 /* This message really ought to be max 23 lines.
1412 * Removed -h because the user already knows that opton. Others? */
1413 printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
1414 printf("\n -0[octal] specify record separator (\\0, if no argument)");
1415 printf("\n -a autosplit mode with -n or -p (splits $_ into @F)");
1416 printf("\n -c check syntax only (runs BEGIN and END blocks)");
1417 printf("\n -d[:debugger] run scripts under debugger");
1418 printf("\n -D[number/list] set debugging flags (argument is a bit mask or flags)");
1419 printf("\n -e 'command' one line of script. Several -e's allowed. Omit [programfile].");
1420 printf("\n -F/pattern/ split() pattern for autosplit (-a). The //'s are optional.");
1421 printf("\n -i[extension] edit <> files in place (make backup if extension supplied)");
1422 printf("\n -Idirectory specify @INC/#include directory (may be used more then once)");
1423 printf("\n -l[octal] enable line ending processing, specifies line teminator");
1424 printf("\n -[mM][-]module.. executes `use/no module...' before executing your script.");
1425 printf("\n -n assume 'while (<>) { ... }' loop arround your script");
1426 printf("\n -p assume loop like -n but print line also like sed");
1427 printf("\n -P run script through C preprocessor before compilation");
1428 printf("\n -s enable some switch parsing for switches after script name");
1429 printf("\n -S look for the script using PATH environment variable");
1430 printf("\n -T turn on tainting checks");
1431 printf("\n -u dump core after parsing script");
1432 printf("\n -U allow unsafe operations");
1433 printf("\n -v print version number and patchlevel of perl");
1434 printf("\n -V[:variable] print perl configuration information");
1435 printf("\n -w TURN WARNINGS ON FOR COMPILATION OF YOUR SCRIPT.");
1436 printf("\n -x[directory] strip off text before #!perl line and perhaps cd to directory\n");
1439 /* This routine handles any switches that can be given during run */
1450 rschar = scan_oct(s, 4, &numlen);
1452 if (rschar & ~((U8)~0))
1454 else if (!rschar && numlen >= 2)
1455 nrs = newSVpv("", 0);
1458 nrs = newSVpv(&ch, 1);
1463 splitstr = savepv(s + 1);
1477 if (*s == ':' || *s == '=') {
1478 my_setenv("PERL5DB", form("use Devel::%s;", ++s));
1489 if (isALPHA(s[1])) {
1490 static char debopts[] = "psltocPmfrxuLHXD";
1493 for (s++; *s && (d = strchr(debopts,*s)); s++)
1494 debug |= 1 << (d - debopts);
1498 for (s++; isDIGIT(*s); s++) ;
1500 debug |= 0x80000000;
1502 warn("Recompile perl with -DDEBUGGING to use -D switch\n");
1503 for (s++; isALNUM(*s); s++) ;
1513 inplace = savepv(s+1);
1515 for (s = inplace; *s && !isSPACE(*s); s++) ;
1522 for (e = s; *e && !isSPACE(*e); e++) ;
1523 p = savepvn(s, e-s);
1530 croak("No space allowed after -I");
1540 *ors = scan_oct(s, 3 + (*s == '0'), &numlen);
1549 ors = SvPV(nrs, orslen);
1550 ors = savepvn(ors, orslen);
1554 forbid_setid("-M"); /* XXX ? */
1557 forbid_setid("-m"); /* XXX ? */
1562 /* -M-foo == 'no foo' */
1563 if (*s == '-') { use = "no "; ++s; }
1564 sv = newSVpv(use,0);
1566 /* We allow -M'Module qw(Foo Bar)' */
1567 while(isALNUM(*s) || *s==':') ++s;
1569 sv_catpv(sv, start);
1570 if (*(start-1) == 'm') {
1572 croak("Can't use '%c' after -mname", *s);
1573 sv_catpv( sv, " ()");
1576 sv_catpvn(sv, start, s-start);
1577 sv_catpv(sv, " split(/,/,q{");
1582 if (preambleav == NULL)
1583 preambleav = newAV();
1584 av_push(preambleav, sv);
1587 croak("No space allowed after -%c", *(s-1));
1604 croak("Too late for \"-T\" option");
1616 #if defined(SUBVERSION) && SUBVERSION > 0
1617 printf("\nThis is perl, version 5.%03d_%02d", PATCHLEVEL, SUBVERSION);
1619 printf("\nThis is perl, version %s",patchlevel);
1622 printf("\n\nCopyright 1987-1997, Larry Wall\n");
1624 printf("\n\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
1627 printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n");
1630 printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
1631 "Version 5 port Copyright (c) 1994-1997, Andreas Kaiser, Ilya Zakharevich\n");
1634 printf("atariST series port, ++jrb bammi@cadence.com\n");
1637 Perl may be copied only under the terms of either the Artistic License or the\n\
1638 GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n");
1646 if (s[1] == '-') /* Additional switches on #! line. */
1654 #ifdef ALTERNATE_SHEBANG
1655 case 'S': /* OS/2 needs -S on "extproc" line. */
1663 croak("Can't emulate -%.1s on #! line",s);
1668 /* compliments of Tom Christiansen */
1670 /* unexec() can be found in the Gnu emacs distribution */
1681 prog = newSVpv(BIN_EXP);
1682 sv_catpv(prog, "/perl");
1683 file = newSVpv(origfilename);
1684 sv_catpv(file, ".perldump");
1686 status = unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
1688 PerlIO_printf(PerlIO_stderr(), "unexec of %s into %s failed!\n",
1689 SvPVX(prog), SvPVX(file));
1693 # include <lib$routines.h>
1694 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
1696 ABORT(); /* for use with undump */
1707 /* Note that strtab is a rather special HV. Assumptions are made
1708 about not iterating on it, and not adding tie magic to it.
1709 It is properly deallocated in perl_destruct() */
1711 HvSHAREKEYS_off(strtab); /* mandatory */
1712 Newz(506,((XPVHV*)SvANY(strtab))->xhv_array,
1713 sizeof(HE*) * (((XPVHV*)SvANY(strtab))->xhv_max + 1), char);
1715 curstash = defstash = newHV();
1716 curstname = newSVpv("main",4);
1717 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
1718 SvREFCNT_dec(GvHV(gv));
1719 GvHV(gv) = (HV*)SvREFCNT_inc(defstash);
1721 HvNAME(defstash) = savepv("main");
1722 incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
1724 defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
1725 errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
1727 sv_setpvn(GvSV(errgv), "", 0);
1728 curstash = defstash;
1729 compiling.cop_stash = defstash;
1730 debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
1731 /* We must init $/ before switches are processed. */
1732 sv_setpvn(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), "\n", 1);
1735 #ifdef CAN_PROTOTYPE
1737 open_script(char *scriptname, bool dosearch, SV *sv)
1740 open_script(scriptname,dosearch,sv)
1747 char *xfound = Nullch;
1748 char *xfailed = Nullch;
1752 #if defined(DOSISH) && !defined(OS2) && !defined(atarist)
1753 # define SEARCH_EXTS ".bat", ".cmd", NULL
1754 # define MAX_EXT_LEN 4
1757 # define SEARCH_EXTS ".pl", ".com", NULL
1758 # define MAX_EXT_LEN 4
1760 /* additional extensions to try in each dir if scriptname not found */
1762 char *ext[] = { SEARCH_EXTS };
1763 int extidx = (strchr(scriptname,'.')) ? -1 : 0; /* has ext already */
1765 # define MAX_EXT_LEN 0
1770 int hasdir, idx = 0, deftypes = 1;
1772 hasdir = (strpbrk(scriptname,":[</") != Nullch) ;
1773 /* The first time through, just add SEARCH_EXTS to whatever we
1774 * already have, so we can check for default file types. */
1776 (!hasdir && my_trnlnm("DCL$PATH",tokenbuf,idx++)) )
1782 if ((strlen(tokenbuf) + strlen(scriptname)
1783 + MAX_EXT_LEN) >= sizeof tokenbuf)
1784 continue; /* don't search dir with too-long name */
1785 strcat(tokenbuf, scriptname);
1787 if (dosearch && !strchr(scriptname, '/') && (s = getenv("PATH"))) {
1788 bufend = s + strlen(s);
1789 while (s < bufend) {
1791 s = delimcpy(tokenbuf, tokenbuf + sizeof tokenbuf, s, bufend,
1799 for (len = 0; *s && *s != ',' && *s != ';'; len++, s++) {
1800 if (len < sizeof tokenbuf)
1803 if (len < sizeof tokenbuf)
1804 tokenbuf[len] = '\0';
1805 #endif /* atarist */
1808 if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tokenbuf)
1809 continue; /* don't search dir with too-long name */
1811 #if defined(atarist) && !defined(DOSISH)
1812 && tokenbuf[len - 1] != '/'
1814 #if defined(atarist) || defined(DOSISH)
1815 && tokenbuf[len - 1] != '\\'
1818 tokenbuf[len++] = '/';
1819 (void)strcpy(tokenbuf + len, scriptname);
1823 len = strlen(tokenbuf);
1824 if (extidx > 0) /* reset after previous loop */
1828 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tokenbuf));
1829 retval = Stat(tokenbuf,&statbuf);
1831 } while ( retval < 0 /* not there */
1832 && extidx>=0 && ext[extidx] /* try an extension? */
1833 && strcpy(tokenbuf+len, ext[extidx++])
1838 if (S_ISREG(statbuf.st_mode)
1839 && cando(S_IRUSR,TRUE,&statbuf)
1841 && cando(S_IXUSR,TRUE,&statbuf)
1845 xfound = tokenbuf; /* bingo! */
1849 xfailed = savepv(tokenbuf);
1852 croak("Can't execute %s", xfailed ? xfailed : scriptname );
1855 scriptname = xfound;
1858 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
1859 char *s = scriptname + 8;
1868 origfilename = savepv(e_tmpname ? "-e" : scriptname);
1869 curcop->cop_filegv = gv_fetchfile(origfilename);
1870 if (strEQ(origfilename,"-"))
1872 if (fdscript >= 0) {
1873 rsfp = PerlIO_fdopen(fdscript,"r");
1874 #if defined(HAS_FCNTL) && defined(F_SETFD)
1876 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
1879 else if (preprocess) {
1880 char *cpp_cfg = CPPSTDIN;
1881 SV *cpp = NEWSV(0,0);
1882 SV *cmd = NEWSV(0,0);
1884 if (strEQ(cpp_cfg, "cppstdin"))
1885 sv_catpvf(cpp, "%s/", BIN_EXP);
1886 sv_catpv(cpp, cpp_cfg);
1889 sv_catpv(sv,PRIVLIB_EXP);
1893 sed %s -e \"/^[^#]/b\" \
1894 -e \"/^#[ ]*include[ ]/b\" \
1895 -e \"/^#[ ]*define[ ]/b\" \
1896 -e \"/^#[ ]*if[ ]/b\" \
1897 -e \"/^#[ ]*ifdef[ ]/b\" \
1898 -e \"/^#[ ]*ifndef[ ]/b\" \
1899 -e \"/^#[ ]*else/b\" \
1900 -e \"/^#[ ]*elif[ ]/b\" \
1901 -e \"/^#[ ]*undef[ ]/b\" \
1902 -e \"/^#[ ]*endif/b\" \
1905 (doextract ? "-e \"1,/^#/d\n\"" : ""),
1908 %s %s -e '/^[^#]/b' \
1909 -e '/^#[ ]*include[ ]/b' \
1910 -e '/^#[ ]*define[ ]/b' \
1911 -e '/^#[ ]*if[ ]/b' \
1912 -e '/^#[ ]*ifdef[ ]/b' \
1913 -e '/^#[ ]*ifndef[ ]/b' \
1914 -e '/^#[ ]*else/b' \
1915 -e '/^#[ ]*elif[ ]/b' \
1916 -e '/^#[ ]*undef[ ]/b' \
1917 -e '/^#[ ]*endif/b' \
1925 (doextract ? "-e '1,/^#/d\n'" : ""),
1927 scriptname, cpp, sv, CPPMINUS);
1929 #ifdef IAMSUID /* actually, this is caught earlier */
1930 if (euid != uid && !euid) { /* if running suidperl */
1932 (void)seteuid(uid); /* musn't stay setuid root */
1935 (void)setreuid((Uid_t)-1, uid);
1937 #ifdef HAS_SETRESUID
1938 (void)setresuid((Uid_t)-1, uid, (Uid_t)-1);
1944 if (geteuid() != uid)
1945 croak("Can't do seteuid!\n");
1947 #endif /* IAMSUID */
1948 rsfp = my_popen(SvPVX(cmd), "r");
1952 else if (!*scriptname) {
1953 forbid_setid("program input from stdin");
1954 rsfp = PerlIO_stdin();
1957 rsfp = PerlIO_open(scriptname,"r");
1958 #if defined(HAS_FCNTL) && defined(F_SETFD)
1960 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
1968 #ifndef IAMSUID /* in case script is not readable before setuid */
1969 if (euid && Stat(SvPVX(GvSV(curcop->cop_filegv)),&statbuf) >= 0 &&
1970 statbuf.st_mode & (S_ISUID|S_ISGID)) {
1972 execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
1973 croak("Can't do setuid\n");
1977 croak("Can't open perl script \"%s\": %s\n",
1978 SvPVX(GvSV(curcop->cop_filegv)), Strerror(errno));
1983 validate_suid(validarg, scriptname)
1989 /* do we need to emulate setuid on scripts? */
1991 /* This code is for those BSD systems that have setuid #! scripts disabled
1992 * in the kernel because of a security problem. Merely defining DOSUID
1993 * in perl will not fix that problem, but if you have disabled setuid
1994 * scripts in the kernel, this will attempt to emulate setuid and setgid
1995 * on scripts that have those now-otherwise-useless bits set. The setuid
1996 * root version must be called suidperl or sperlN.NNN. If regular perl
1997 * discovers that it has opened a setuid script, it calls suidperl with
1998 * the same argv that it had. If suidperl finds that the script it has
1999 * just opened is NOT setuid root, it sets the effective uid back to the
2000 * uid. We don't just make perl setuid root because that loses the
2001 * effective uid we had before invoking perl, if it was different from the
2004 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
2005 * be defined in suidperl only. suidperl must be setuid root. The
2006 * Configure script will set this up for you if you want it.
2012 if (Fstat(PerlIO_fileno(rsfp),&statbuf) < 0) /* normal stat is insecure */
2013 croak("Can't stat script \"%s\"",origfilename);
2014 if (fdscript < 0 && statbuf.st_mode & (S_ISUID|S_ISGID)) {
2018 #ifndef HAS_SETREUID
2019 /* On this access check to make sure the directories are readable,
2020 * there is actually a small window that the user could use to make
2021 * filename point to an accessible directory. So there is a faint
2022 * chance that someone could execute a setuid script down in a
2023 * non-accessible directory. I don't know what to do about that.
2024 * But I don't think it's too important. The manual lies when
2025 * it says access() is useful in setuid programs.
2027 if (access(SvPVX(GvSV(curcop->cop_filegv)),1)) /*double check*/
2028 croak("Permission denied");
2030 /* If we can swap euid and uid, then we can determine access rights
2031 * with a simple stat of the file, and then compare device and
2032 * inode to make sure we did stat() on the same file we opened.
2033 * Then we just have to make sure he or she can execute it.
2036 struct stat tmpstatbuf;
2040 setreuid(euid,uid) < 0
2043 setresuid(euid,uid,(Uid_t)-1) < 0
2046 || getuid() != euid || geteuid() != uid)
2047 croak("Can't swap uid and euid"); /* really paranoid */
2048 if (Stat(SvPVX(GvSV(curcop->cop_filegv)),&tmpstatbuf) < 0)
2049 croak("Permission denied"); /* testing full pathname here */
2050 if (tmpstatbuf.st_dev != statbuf.st_dev ||
2051 tmpstatbuf.st_ino != statbuf.st_ino) {
2052 (void)PerlIO_close(rsfp);
2053 if (rsfp = my_popen("/bin/mail root","w")) { /* heh, heh */
2055 "User %ld tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
2056 (Filename of set-id script was %s, uid %ld gid %ld.)\n\nSincerely,\nperl\n",
2057 (long)uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
2058 (long)statbuf.st_dev, (long)statbuf.st_ino,
2059 SvPVX(GvSV(curcop->cop_filegv)),
2060 (long)statbuf.st_uid, (long)statbuf.st_gid);
2061 (void)my_pclose(rsfp);
2063 croak("Permission denied\n");
2067 setreuid(uid,euid) < 0
2069 # if defined(HAS_SETRESUID)
2070 setresuid(uid,euid,(Uid_t)-1) < 0
2073 || getuid() != uid || geteuid() != euid)
2074 croak("Can't reswap uid and euid");
2075 if (!cando(S_IXUSR,FALSE,&statbuf)) /* can real uid exec? */
2076 croak("Permission denied\n");
2078 #endif /* HAS_SETREUID */
2079 #endif /* IAMSUID */
2081 if (!S_ISREG(statbuf.st_mode))
2082 croak("Permission denied");
2083 if (statbuf.st_mode & S_IWOTH)
2084 croak("Setuid/gid script is writable by world");
2085 doswitches = FALSE; /* -s is insecure in suid */
2087 if (sv_gets(linestr, rsfp, 0) == Nullch ||
2088 strnNE(SvPV(linestr,na),"#!",2) ) /* required even on Sys V */
2089 croak("No #! line");
2090 s = SvPV(linestr,na)+2;
2092 while (!isSPACE(*s)) s++;
2093 for (s2 = s; (s2 > SvPV(linestr,na)+2 &&
2094 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
2095 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
2096 croak("Not a perl script");
2097 while (*s == ' ' || *s == '\t') s++;
2099 * #! arg must be what we saw above. They can invoke it by
2100 * mentioning suidperl explicitly, but they may not add any strange
2101 * arguments beyond what #! says if they do invoke suidperl that way.
2103 len = strlen(validarg);
2104 if (strEQ(validarg," PHOOEY ") ||
2105 strnNE(s,validarg,len) || !isSPACE(s[len]))
2106 croak("Args must match #! line");
2109 if (euid != uid && (statbuf.st_mode & S_ISUID) &&
2110 euid == statbuf.st_uid)
2112 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2113 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2114 #endif /* IAMSUID */
2116 if (euid) { /* oops, we're not the setuid root perl */
2117 (void)PerlIO_close(rsfp);
2120 execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
2122 croak("Can't do setuid\n");
2125 if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid) {
2127 (void)setegid(statbuf.st_gid);
2130 (void)setregid((Gid_t)-1,statbuf.st_gid);
2132 #ifdef HAS_SETRESGID
2133 (void)setresgid((Gid_t)-1,statbuf.st_gid,(Gid_t)-1);
2135 setgid(statbuf.st_gid);
2139 if (getegid() != statbuf.st_gid)
2140 croak("Can't do setegid!\n");
2142 if (statbuf.st_mode & S_ISUID) {
2143 if (statbuf.st_uid != euid)
2145 (void)seteuid(statbuf.st_uid); /* all that for this */
2148 (void)setreuid((Uid_t)-1,statbuf.st_uid);
2150 #ifdef HAS_SETRESUID
2151 (void)setresuid((Uid_t)-1,statbuf.st_uid,(Uid_t)-1);
2153 setuid(statbuf.st_uid);
2157 if (geteuid() != statbuf.st_uid)
2158 croak("Can't do seteuid!\n");
2160 else if (uid) { /* oops, mustn't run as root */
2162 (void)seteuid((Uid_t)uid);
2165 (void)setreuid((Uid_t)-1,(Uid_t)uid);
2167 #ifdef HAS_SETRESUID
2168 (void)setresuid((Uid_t)-1,(Uid_t)uid,(Uid_t)-1);
2174 if (geteuid() != uid)
2175 croak("Can't do seteuid!\n");
2178 if (!cando(S_IXUSR,TRUE,&statbuf))
2179 croak("Permission denied\n"); /* they can't do this */
2182 else if (preprocess)
2183 croak("-P not allowed for setuid/setgid script\n");
2184 else if (fdscript >= 0)
2185 croak("fd script not allowed in suidperl\n");
2187 croak("Script is not setuid/setgid in suidperl\n");
2189 /* We absolutely must clear out any saved ids here, so we */
2190 /* exec the real perl, substituting fd script for scriptname. */
2191 /* (We pass script name as "subdir" of fd, which perl will grok.) */
2192 PerlIO_rewind(rsfp);
2193 lseek(PerlIO_fileno(rsfp),(Off_t)0,0); /* just in case rewind didn't */
2194 for (which = 1; origargv[which] && origargv[which] != scriptname; which++) ;
2195 if (!origargv[which])
2196 croak("Permission denied");
2197 origargv[which] = savepv(form("/dev/fd/%d/%s",
2198 PerlIO_fileno(rsfp), origargv[which]));
2199 #if defined(HAS_FCNTL) && defined(F_SETFD)
2200 fcntl(PerlIO_fileno(rsfp),F_SETFD,0); /* ensure no close-on-exec */
2202 execv(form("%s/perl%s", BIN_EXP, patchlevel), origargv); /* try again */
2203 croak("Can't do setuid\n");
2204 #endif /* IAMSUID */
2206 if (euid != uid || egid != gid) { /* (suidperl doesn't exist, in fact) */
2207 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
2209 Fstat(PerlIO_fileno(rsfp),&statbuf); /* may be either wrapped or real suid */
2210 if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
2212 (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
2215 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2216 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2217 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
2218 /* not set-id, must be wrapped */
2226 register char *s, *s2;
2228 /* skip forward in input to the real script? */
2232 if ((s = sv_gets(linestr, rsfp, 0)) == Nullch)
2233 croak("No Perl script found in input\n");
2234 if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
2235 PerlIO_ungetc(rsfp, '\n'); /* to keep line count right */
2237 while (*s && !(isSPACE (*s) || *s == '#')) s++;
2239 while (*s == ' ' || *s == '\t') s++;
2241 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
2242 if (strnEQ(s2-4,"perl",4))
2244 while (s = moreswitches(s)) ;
2246 if (cddir && chdir(cddir) < 0)
2247 croak("Can't chdir to %s",cddir);
2255 uid = (int)getuid();
2256 euid = (int)geteuid();
2257 gid = (int)getgid();
2258 egid = (int)getegid();
2263 tainting |= (uid && (euid != uid || egid != gid));
2271 croak("No %s allowed while running setuid", s);
2273 croak("No %s allowed while running setgid", s);
2280 curstash = debstash;
2281 dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
2283 DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
2284 DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
2285 DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
2286 DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
2287 sv_setiv(DBsingle, 0);
2288 DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
2289 sv_setiv(DBtrace, 0);
2290 DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
2291 sv_setiv(DBsignal, 0);
2292 curstash = defstash;
2300 mainstack = curstack; /* remember in case we switch stacks */
2301 AvREAL_off(curstack); /* not a real array */
2302 av_extend(curstack,127);
2304 stack_base = AvARRAY(curstack);
2305 stack_sp = stack_base;
2306 stack_max = stack_base + 127;
2308 cxstack_max = 8192 / sizeof(CONTEXT) - 2; /* Use most of 8K. */
2309 New(50,cxstack,cxstack_max + 1,CONTEXT);
2312 New(50,tmps_stack,128,SV*);
2318 * The following stacks almost certainly should be per-interpreter,
2319 * but for now they're not. XXX
2323 markstack_ptr = markstack;
2325 New(54,markstack,64,I32);
2326 markstack_ptr = markstack;
2327 markstack_max = markstack + 64;
2333 New(54,scopestack,32,I32);
2335 scopestack_max = 32;
2341 New(54,savestack,128,ANY);
2343 savestack_max = 128;
2349 New(54,retstack,16,OP*);
2360 Safefree(tmps_stack);
2367 static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
2375 subname = newSVpv("main",4);
2379 init_predump_symbols()
2385 sv_setpvn(GvSV(gv_fetchpv("\"", TRUE, SVt_PV)), " ", 1);
2387 stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
2388 GvMULTI_on(stdingv);
2389 IoIFP(GvIOp(stdingv)) = PerlIO_stdin();
2390 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
2392 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(stdingv));
2394 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
2396 IoOFP(GvIOp(tmpgv)) = IoIFP(GvIOp(tmpgv)) = PerlIO_stdout();
2398 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
2400 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(defoutgv));
2402 othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
2403 GvMULTI_on(othergv);
2404 IoOFP(GvIOp(othergv)) = IoIFP(GvIOp(othergv)) = PerlIO_stderr();
2405 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
2407 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(othergv));
2409 statname = NEWSV(66,0); /* last filename we did stat on */
2412 osname = savepv(OSNAME);
2416 init_postdump_symbols(argc,argv,env)
2418 register char **argv;
2419 register char **env;
2425 argc--,argv++; /* skip name of script */
2427 for (; argc > 0 && **argv == '-'; argc--,argv++) {
2430 if (argv[0][1] == '-') {
2434 if (s = strchr(argv[0], '=')) {
2436 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
2439 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
2442 toptarget = NEWSV(0,0);
2443 sv_upgrade(toptarget, SVt_PVFM);
2444 sv_setpvn(toptarget, "", 0);
2445 bodytarget = NEWSV(0,0);
2446 sv_upgrade(bodytarget, SVt_PVFM);
2447 sv_setpvn(bodytarget, "", 0);
2448 formtarget = bodytarget;
2451 if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
2452 sv_setpv(GvSV(tmpgv),origfilename);
2453 magicname("0", "0", 1);
2455 if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
2456 sv_setpv(GvSV(tmpgv),origargv[0]);
2457 if (argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
2459 (void)gv_AVadd(argvgv);
2460 av_clear(GvAVn(argvgv));
2461 for (; argc > 0; argc--,argv++) {
2462 av_push(GvAVn(argvgv),newSVpv(argv[0],0));
2465 if (envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
2469 hv_magic(hv, envgv, 'E');
2470 #ifndef VMS /* VMS doesn't have environ array */
2471 /* Note that if the supplied env parameter is actually a copy
2472 of the global environ then it may now point to free'd memory
2473 if the environment has been modified since. To avoid this
2474 problem we treat env==NULL as meaning 'use the default'
2479 environ[0] = Nullch;
2480 for (; *env; env++) {
2481 if (!(s = strchr(*env,'=')))
2487 sv = newSVpv(s--,0);
2488 (void)hv_store(hv, *env, s - *env, sv, 0);
2490 #if defined(__BORLANDC__) && defined(USE_WIN32_RTL_ENV)
2491 /* Sins of the RTL. See note in my_setenv(). */
2492 (void)putenv(savepv(*env));
2496 #ifdef DYNAMIC_ENV_FETCH
2497 HvNAME(hv) = savepv(ENV_HV_NAME);
2501 if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
2502 sv_setiv(GvSV(tmpgv), (IV)getpid());
2511 s = getenv("PERL5LIB");
2515 incpush(getenv("PERLLIB"), FALSE);
2517 /* Treat PERL5?LIB as a possible search list logical name -- the
2518 * "natural" VMS idiom for a Unix path string. We allow each
2519 * element to be a set of |-separated directories for compatibility.
2523 if (my_trnlnm("PERL5LIB",buf,0))
2524 do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
2526 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE);
2530 /* Use the ~-expanded versions of APPLLIB (undocumented),
2531 ARCHLIB PRIVLIB SITEARCH SITELIB and OLDARCHLIB
2534 incpush(APPLLIB_EXP, FALSE);
2538 incpush(ARCHLIB_EXP, FALSE);
2541 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
2543 incpush(PRIVLIB_EXP, FALSE);
2546 incpush(SITEARCH_EXP, FALSE);
2549 incpush(SITELIB_EXP, FALSE);
2551 #ifdef OLDARCHLIB_EXP /* 5.00[01] compatibility */
2552 incpush(OLDARCHLIB_EXP, FALSE);
2556 incpush(".", FALSE);
2560 # define PERLLIB_SEP ';'
2563 # define PERLLIB_SEP '|'
2565 # define PERLLIB_SEP ':'
2568 #ifndef PERLLIB_MANGLE
2569 # define PERLLIB_MANGLE(s,n) (s)
2573 incpush(p, addsubdirs)
2577 SV *subdir = Nullsv;
2578 static char *archpat_auto;
2585 if (!archpat_auto) {
2586 STRLEN len = (sizeof(ARCHNAME) + strlen(patchlevel)
2587 + sizeof("//auto"));
2588 New(55, archpat_auto, len, char);
2589 sprintf(archpat_auto, "/%s/%s/auto", ARCHNAME, patchlevel);
2591 for (len = sizeof(ARCHNAME) + 2;
2592 archpat_auto[len] != '\0' && archpat_auto[len] != '/'; len++)
2593 if (archpat_auto[len] == '.') archpat_auto[len] = '_';
2598 /* Break at all separators */
2600 SV *libdir = newSV(0);
2603 /* skip any consecutive separators */
2604 while ( *p == PERLLIB_SEP ) {
2605 /* Uncomment the next line for PATH semantics */
2606 /* av_push(GvAVn(incgv), newSVpv(".", 1)); */
2610 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
2611 sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
2616 sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
2617 p = Nullch; /* break out */
2621 * BEFORE pushing libdir onto @INC we may first push version- and
2622 * archname-specific sub-directories.
2625 struct stat tmpstatbuf;
2630 if ((unix = tounixspec_ts(SvPV(libdir,na),Nullch)) != Nullch) {
2632 while (unix[len-1] == '/') len--; /* Cosmetic */
2633 sv_usepvn(libdir,unix,len);
2636 PerlIO_printf(PerlIO_stderr(),
2637 "Failed to unixify @INC element \"%s\"\n",
2640 /* .../archname/version if -d .../archname/version/auto */
2641 sv_setsv(subdir, libdir);
2642 sv_catpv(subdir, archpat_auto);
2643 if (Stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2644 S_ISDIR(tmpstatbuf.st_mode))
2645 av_push(GvAVn(incgv),
2646 newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2648 /* .../archname if -d .../archname/auto */
2649 sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME),
2650 strlen(patchlevel) + 1, "", 0);
2651 if (Stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2652 S_ISDIR(tmpstatbuf.st_mode))
2653 av_push(GvAVn(incgv),
2654 newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2657 /* finally push this lib directory on the end of @INC */
2658 av_push(GvAVn(incgv), libdir);
2661 SvREFCNT_dec(subdir);
2665 call_list(oldscope, list)
2670 line_t oldline = curcop->cop_line;
2675 while (AvFILL(list) >= 0) {
2676 CV *cv = (CV*)av_shift(list);
2683 SV* atsv = GvSV(errgv);
2685 perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
2686 (void)SvPV(atsv, len);
2689 curcop = &compiling;
2690 curcop->cop_line = oldline;
2691 if (list == beginav)
2692 sv_catpv(atsv, "BEGIN failed--compilation aborted");
2694 sv_catpv(atsv, "END failed--cleanup aborted");
2695 while (scopestack_ix > oldscope)
2697 croak("%s", SvPVX(atsv));
2705 /* my_exit() was called */
2706 while (scopestack_ix > oldscope)
2708 curstash = defstash;
2710 call_list(oldscope, endav);
2713 curcop = &compiling;
2714 curcop->cop_line = oldline;
2716 if (list == beginav)
2717 croak("BEGIN failed--compilation aborted");
2719 croak("END failed--cleanup aborted");
2725 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
2730 curcop = &compiling;
2731 curcop->cop_line = oldline;
2745 DEBUG_L(PerlIO_printf(Perl_debug_log, "my_exit: thread 0x%lx, status %lu\n",
2746 (unsigned long) thr, (unsigned long) status));
2747 #endif /* USE_THREADS */
2756 STATUS_NATIVE_SET(status);
2766 if (vaxc$errno & 1) {
2767 if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
2768 STATUS_NATIVE_SET(44);
2771 if (!vaxc$errno && errno) /* unlikely */
2772 STATUS_NATIVE_SET(44);
2774 STATUS_NATIVE_SET(vaxc$errno);
2778 STATUS_POSIX_SET(errno);
2779 else if (STATUS_POSIX == 0)
2780 STATUS_POSIX_SET(255);
2789 register CONTEXT *cx;
2798 (void)UNLINK(e_tmpname);
2799 Safefree(e_tmpname);
2803 if (cxstack_ix >= 0) {