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
2208 Fstat(PerlIO_fileno(rsfp),&statbuf); /* may be either wrapped or real suid */
2209 if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
2211 (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
2214 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2215 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2216 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
2217 /* not set-id, must be wrapped */
2225 register char *s, *s2;
2227 /* skip forward in input to the real script? */
2231 if ((s = sv_gets(linestr, rsfp, 0)) == Nullch)
2232 croak("No Perl script found in input\n");
2233 if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
2234 PerlIO_ungetc(rsfp, '\n'); /* to keep line count right */
2236 while (*s && !(isSPACE (*s) || *s == '#')) s++;
2238 while (*s == ' ' || *s == '\t') s++;
2240 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
2241 if (strnEQ(s2-4,"perl",4))
2243 while (s = moreswitches(s)) ;
2245 if (cddir && chdir(cddir) < 0)
2246 croak("Can't chdir to %s",cddir);
2254 uid = (int)getuid();
2255 euid = (int)geteuid();
2256 gid = (int)getgid();
2257 egid = (int)getegid();
2262 tainting |= (uid && (euid != uid || egid != gid));
2270 croak("No %s allowed while running setuid", s);
2272 croak("No %s allowed while running setgid", s);
2279 curstash = debstash;
2280 dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
2282 DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
2283 DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
2284 DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
2285 DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
2286 sv_setiv(DBsingle, 0);
2287 DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
2288 sv_setiv(DBtrace, 0);
2289 DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
2290 sv_setiv(DBsignal, 0);
2291 curstash = defstash;
2299 mainstack = curstack; /* remember in case we switch stacks */
2300 AvREAL_off(curstack); /* not a real array */
2301 av_extend(curstack,127);
2303 stack_base = AvARRAY(curstack);
2304 stack_sp = stack_base;
2305 stack_max = stack_base + 127;
2307 cxstack_max = 8192 / sizeof(CONTEXT) - 2; /* Use most of 8K. */
2308 New(50,cxstack,cxstack_max + 1,CONTEXT);
2311 New(50,tmps_stack,128,SV*);
2317 * The following stacks almost certainly should be per-interpreter,
2318 * but for now they're not. XXX
2322 markstack_ptr = markstack;
2324 New(54,markstack,64,I32);
2325 markstack_ptr = markstack;
2326 markstack_max = markstack + 64;
2332 New(54,scopestack,32,I32);
2334 scopestack_max = 32;
2340 New(54,savestack,128,ANY);
2342 savestack_max = 128;
2348 New(54,retstack,16,OP*);
2359 Safefree(tmps_stack);
2366 static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
2374 subname = newSVpv("main",4);
2378 init_predump_symbols()
2384 sv_setpvn(GvSV(gv_fetchpv("\"", TRUE, SVt_PV)), " ", 1);
2386 stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
2387 GvMULTI_on(stdingv);
2388 IoIFP(GvIOp(stdingv)) = PerlIO_stdin();
2389 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
2391 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(stdingv));
2393 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
2395 IoOFP(GvIOp(tmpgv)) = IoIFP(GvIOp(tmpgv)) = PerlIO_stdout();
2397 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
2399 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(defoutgv));
2401 othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
2402 GvMULTI_on(othergv);
2403 IoOFP(GvIOp(othergv)) = IoIFP(GvIOp(othergv)) = PerlIO_stderr();
2404 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
2406 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(othergv));
2408 statname = NEWSV(66,0); /* last filename we did stat on */
2411 osname = savepv(OSNAME);
2415 init_postdump_symbols(argc,argv,env)
2417 register char **argv;
2418 register char **env;
2424 argc--,argv++; /* skip name of script */
2426 for (; argc > 0 && **argv == '-'; argc--,argv++) {
2429 if (argv[0][1] == '-') {
2433 if (s = strchr(argv[0], '=')) {
2435 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
2438 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
2441 toptarget = NEWSV(0,0);
2442 sv_upgrade(toptarget, SVt_PVFM);
2443 sv_setpvn(toptarget, "", 0);
2444 bodytarget = NEWSV(0,0);
2445 sv_upgrade(bodytarget, SVt_PVFM);
2446 sv_setpvn(bodytarget, "", 0);
2447 formtarget = bodytarget;
2450 if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
2451 sv_setpv(GvSV(tmpgv),origfilename);
2452 magicname("0", "0", 1);
2454 if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
2455 sv_setpv(GvSV(tmpgv),origargv[0]);
2456 if (argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
2458 (void)gv_AVadd(argvgv);
2459 av_clear(GvAVn(argvgv));
2460 for (; argc > 0; argc--,argv++) {
2461 av_push(GvAVn(argvgv),newSVpv(argv[0],0));
2464 if (envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
2468 hv_magic(hv, envgv, 'E');
2469 #ifndef VMS /* VMS doesn't have environ array */
2470 /* Note that if the supplied env parameter is actually a copy
2471 of the global environ then it may now point to free'd memory
2472 if the environment has been modified since. To avoid this
2473 problem we treat env==NULL as meaning 'use the default'
2478 environ[0] = Nullch;
2479 for (; *env; env++) {
2480 if (!(s = strchr(*env,'=')))
2486 sv = newSVpv(s--,0);
2487 (void)hv_store(hv, *env, s - *env, sv, 0);
2489 #if defined(__BORLANDC__) && defined(USE_WIN32_RTL_ENV)
2490 /* Sins of the RTL. See note in my_setenv(). */
2491 (void)putenv(savepv(*env));
2495 #ifdef DYNAMIC_ENV_FETCH
2496 HvNAME(hv) = savepv(ENV_HV_NAME);
2500 if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
2501 sv_setiv(GvSV(tmpgv), (IV)getpid());
2510 s = getenv("PERL5LIB");
2514 incpush(getenv("PERLLIB"), FALSE);
2516 /* Treat PERL5?LIB as a possible search list logical name -- the
2517 * "natural" VMS idiom for a Unix path string. We allow each
2518 * element to be a set of |-separated directories for compatibility.
2522 if (my_trnlnm("PERL5LIB",buf,0))
2523 do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
2525 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE);
2529 /* Use the ~-expanded versions of APPLLIB (undocumented),
2530 ARCHLIB PRIVLIB SITEARCH SITELIB and OLDARCHLIB
2533 incpush(APPLLIB_EXP, FALSE);
2537 incpush(ARCHLIB_EXP, FALSE);
2540 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
2542 incpush(PRIVLIB_EXP, FALSE);
2545 incpush(SITEARCH_EXP, FALSE);
2548 incpush(SITELIB_EXP, FALSE);
2550 #ifdef OLDARCHLIB_EXP /* 5.00[01] compatibility */
2551 incpush(OLDARCHLIB_EXP, FALSE);
2555 incpush(".", FALSE);
2559 # define PERLLIB_SEP ';'
2562 # define PERLLIB_SEP '|'
2564 # define PERLLIB_SEP ':'
2567 #ifndef PERLLIB_MANGLE
2568 # define PERLLIB_MANGLE(s,n) (s)
2572 incpush(p, addsubdirs)
2576 SV *subdir = Nullsv;
2577 static char *archpat_auto;
2584 if (!archpat_auto) {
2585 STRLEN len = (sizeof(ARCHNAME) + strlen(patchlevel)
2586 + sizeof("//auto"));
2587 New(55, archpat_auto, len, char);
2588 sprintf(archpat_auto, "/%s/%s/auto", ARCHNAME, patchlevel);
2590 for (len = sizeof(ARCHNAME) + 2;
2591 archpat_auto[len] != '\0' && archpat_auto[len] != '/'; len++)
2592 if (archpat_auto[len] == '.') archpat_auto[len] = '_';
2597 /* Break at all separators */
2599 SV *libdir = newSV(0);
2602 /* skip any consecutive separators */
2603 while ( *p == PERLLIB_SEP ) {
2604 /* Uncomment the next line for PATH semantics */
2605 /* av_push(GvAVn(incgv), newSVpv(".", 1)); */
2609 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
2610 sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
2615 sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
2616 p = Nullch; /* break out */
2620 * BEFORE pushing libdir onto @INC we may first push version- and
2621 * archname-specific sub-directories.
2624 struct stat tmpstatbuf;
2629 if ((unix = tounixspec_ts(SvPV(libdir,na),Nullch)) != Nullch) {
2631 while (unix[len-1] == '/') len--; /* Cosmetic */
2632 sv_usepvn(libdir,unix,len);
2635 PerlIO_printf(PerlIO_stderr(),
2636 "Failed to unixify @INC element \"%s\"\n",
2639 /* .../archname/version if -d .../archname/version/auto */
2640 sv_setsv(subdir, libdir);
2641 sv_catpv(subdir, archpat_auto);
2642 if (Stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2643 S_ISDIR(tmpstatbuf.st_mode))
2644 av_push(GvAVn(incgv),
2645 newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2647 /* .../archname if -d .../archname/auto */
2648 sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME),
2649 strlen(patchlevel) + 1, "", 0);
2650 if (Stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2651 S_ISDIR(tmpstatbuf.st_mode))
2652 av_push(GvAVn(incgv),
2653 newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2656 /* finally push this lib directory on the end of @INC */
2657 av_push(GvAVn(incgv), libdir);
2660 SvREFCNT_dec(subdir);
2664 call_list(oldscope, list)
2669 line_t oldline = curcop->cop_line;
2674 while (AvFILL(list) >= 0) {
2675 CV *cv = (CV*)av_shift(list);
2682 SV* atsv = GvSV(errgv);
2684 perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
2685 (void)SvPV(atsv, len);
2688 curcop = &compiling;
2689 curcop->cop_line = oldline;
2690 if (list == beginav)
2691 sv_catpv(atsv, "BEGIN failed--compilation aborted");
2693 sv_catpv(atsv, "END failed--cleanup aborted");
2694 while (scopestack_ix > oldscope)
2696 croak("%s", SvPVX(atsv));
2704 /* my_exit() was called */
2705 while (scopestack_ix > oldscope)
2707 curstash = defstash;
2709 call_list(oldscope, endav);
2712 curcop = &compiling;
2713 curcop->cop_line = oldline;
2715 if (list == beginav)
2716 croak("BEGIN failed--compilation aborted");
2718 croak("END failed--cleanup aborted");
2724 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
2729 curcop = &compiling;
2730 curcop->cop_line = oldline;
2744 DEBUG_L(PerlIO_printf(Perl_debug_log, "my_exit: thread 0x%lx, status %lu\n",
2745 (unsigned long) thr, (unsigned long) status));
2746 #endif /* USE_THREADS */
2755 STATUS_NATIVE_SET(status);
2765 if (vaxc$errno & 1) {
2766 if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
2767 STATUS_NATIVE_SET(44);
2770 if (!vaxc$errno && errno) /* unlikely */
2771 STATUS_NATIVE_SET(44);
2773 STATUS_NATIVE_SET(vaxc$errno);
2777 STATUS_POSIX_SET(errno);
2778 else if (STATUS_POSIX == 0)
2779 STATUS_POSIX_SET(255);
2788 register CONTEXT *cx;
2797 (void)UNLINK(e_tmpname);
2798 Safefree(e_tmpname);
2802 if (cxstack_ix >= 0) {