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);
124 /* Init the real globals? */
127 #ifdef NEED_PTHREAD_INIT
129 #endif /* NEED_PTHREAD_INIT */
130 New(53, thr, 1, struct thread);
131 MUTEX_INIT(&malloc_mutex);
132 MUTEX_INIT(&sv_mutex);
133 MUTEX_INIT(&eval_mutex);
134 COND_INIT(&eval_cond);
135 MUTEX_INIT(&nthreads_mutex);
136 COND_INIT(&nthreads_cond);
143 thr->next = thr->prev = thr->next_run = thr->prev_run = thr;
147 self = pthread_self();
148 if (pthread_key_create(&thr_key, thread_destruct))
149 croak("panic: pthread_key_create");
150 if (pthread_setspecific(thr_key, (void *) thr))
151 croak("panic: pthread_setspecific");
152 #endif /* FAKE_THREADS */
153 #endif /* USE_THREADS */
155 linestr = NEWSV(65,80);
156 sv_upgrade(linestr,SVt_PVIV);
158 if (!SvREADONLY(&sv_undef)) {
159 SvREADONLY_on(&sv_undef);
163 SvREADONLY_on(&sv_no);
165 sv_setpv(&sv_yes,Yes);
167 SvREADONLY_on(&sv_yes);
170 nrs = newSVpv("\n", 1);
171 rs = SvREFCNT_inc(nrs);
173 sighandlerp = sighandler;
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 COND_DESTROY(&eval_cond);
536 #endif /* USE_THREADS */
538 /* As the absolutely last thing, free the non-arena SV for mess() */
541 /* we know that type >= SVt_PV */
543 Safefree(SvPVX(mess_sv));
544 Safefree(SvANY(mess_sv));
552 PerlInterpreter *sv_interp;
554 if (!(curinterp = sv_interp))
560 perl_parse(sv_interp, xsinit, argc, argv, env)
561 PerlInterpreter *sv_interp;
562 void (*xsinit)_((void));
570 char *scriptname = NULL;
571 VOL bool dosearch = FALSE;
578 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
581 croak("suidperl is no longer needed since the kernel can now execute\n\
582 setuid perl scripts securely.\n");
586 if (!(curinterp = sv_interp))
589 #if defined(NeXT) && defined(__DYNAMIC__)
590 _dyld_lookup_and_bind
591 ("__environ", (unsigned long *) &environ_pointer, NULL);
596 #ifndef VMS /* VMS doesn't have environ array */
597 origenviron = environ;
603 /* Come here if running an undumped a.out. */
605 origfilename = savepv(argv[0]);
607 cxstack_ix = -1; /* start label stack again */
609 init_postdump_symbols(argc,argv,env);
614 curpad = AvARRAY(comppad);
619 SvREFCNT_dec(main_cv);
623 oldscope = scopestack_ix;
631 /* my_exit() was called */
632 while (scopestack_ix > oldscope)
636 call_list(oldscope, endav);
638 return STATUS_NATIVE_EXPORT;
641 PerlIO_printf(PerlIO_stderr(), "panic: top_env\n");
645 sv_setpvn(linestr,"",0);
646 sv = newSVpv("",0); /* first used for -I flags */
650 for (argc--,argv++; argc > 0; argc--,argv++) {
651 if (argv[0][0] != '-' || !argv[0][1])
655 validarg = " PHOOEY ";
680 if (s = moreswitches(s))
690 if (euid != uid || egid != gid)
691 croak("No -e allowed in setuid scripts");
693 e_tmpname = savepv(TMPPATH);
694 (void)mktemp(e_tmpname);
696 croak("Can't mktemp()");
697 e_fp = PerlIO_open(e_tmpname,"w");
699 croak("Cannot open temporary file");
704 PerlIO_puts(e_fp,argv[1]);
708 croak("No code specified for -e");
709 (void)PerlIO_putc(e_fp,'\n');
720 incpush(argv[1], TRUE);
721 sv_catpv(sv,argv[1]);
738 preambleav = newAV();
739 av_push(preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
741 Sv = newSVpv("print myconfig();",0);
743 sv_catpv(Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
745 sv_catpv(Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
747 #if defined(DEBUGGING) || defined(NO_EMBED) || defined(MULTIPLICITY)
748 sv_catpv(Sv,"\" Compile-time options:");
750 sv_catpv(Sv," DEBUGGING");
753 sv_catpv(Sv," NO_EMBED");
756 sv_catpv(Sv," MULTIPLICITY");
758 sv_catpv(Sv,"\\n\",");
760 #if defined(LOCAL_PATCH_COUNT)
761 if (LOCAL_PATCH_COUNT > 0) {
763 sv_catpv(Sv,"\" Locally applied patches:\\n\",");
764 for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
766 sv_catpvf(Sv,"\" \\t%s\\n\",",localpatches[i]);
770 sv_catpvf(Sv,"\" Built under %s\\n\"",OSNAME);
773 sv_catpvf(Sv,",\" Compiled at %s %s\\n\"",__DATE__,__TIME__);
775 sv_catpvf(Sv,",\" Compiled on %s\\n\"",__DATE__);
780 @env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; \
781 print \" \\%ENV:\\n @env\\n\" if @env; \
782 print \" \\@INC:\\n @INC\\n\";");
785 Sv = newSVpv("config_vars(qw(",0);
790 av_push(preambleav, Sv);
791 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
805 croak("Unrecognized switch: -%s",s);
810 if (!tainting && (s = getenv("PERL5OPT"))) {
821 if (!strchr("DIMUdmw", *s))
822 croak("Illegal switch in PERL5OPT: -%c", *s);
828 scriptname = argv[0];
830 if (PerlIO_flush(e_fp) || PerlIO_error(e_fp) || PerlIO_close(e_fp)) {
832 warn("Did you forget to compile with -DMULTIPLICITY?");
834 croak("Can't write to temp file for -e: %s", Strerror(errno));
838 scriptname = e_tmpname;
840 else if (scriptname == Nullch) {
842 if ( isatty(PerlIO_fileno(PerlIO_stdin())) )
850 open_script(scriptname,dosearch,sv);
852 validate_suid(validarg, scriptname);
857 main_cv = compcv = (CV*)NEWSV(1104,0);
858 sv_upgrade((SV *)compcv, SVt_PVCV);
862 av_push(comppad, Nullsv);
863 curpad = AvARRAY(comppad);
864 comppad_name = newAV();
865 comppad_name_fill = 0;
866 min_intro_pending = 0;
869 av_store(comppad_name, 0, newSVpv("@_", 2));
870 curpad[0] = (SV*)newAV();
871 SvPADMY_on(curpad[0]); /* XXX Needed? */
873 New(666, CvMUTEXP(compcv), 1, perl_mutex);
874 MUTEX_INIT(CvMUTEXP(compcv));
875 #endif /* USE_THREADS */
877 comppadlist = newAV();
878 AvREAL_off(comppadlist);
879 av_store(comppadlist, 0, (SV*)comppad_name);
880 av_store(comppadlist, 1, (SV*)comppad);
881 CvPADLIST(compcv) = comppadlist;
883 boot_core_UNIVERSAL();
885 (*xsinit)(); /* in case linked C routines want magical variables */
890 #if defined(DEBUGGING) && defined(USE_THREADS) && defined(__linux__)
891 DEBUG_L(signal(SIGSEGV, (void(*)(int))catch_sigsegv););
894 init_predump_symbols();
896 init_postdump_symbols(argc,argv,env);
900 /* now parse the script */
903 if (yyparse() || error_count) {
905 croak("%s had compilation errors.\n", origfilename);
907 croak("Execution of %s aborted due to compilation errors.\n",
911 curcop->cop_line = 0;
915 (void)UNLINK(e_tmpname);
920 /* now that script is parsed, we can modify record separator */
922 rs = SvREFCNT_inc(nrs);
923 sv_setsv(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), rs);
934 #ifdef DEBUGGING_MSTATS
935 if ((s=getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
936 dump_mstats("after compilation:");
947 PerlInterpreter *sv_interp;
954 if (!(curinterp = sv_interp))
957 oldscope = scopestack_ix;
962 cxstack_ix = -1; /* start context stack again */
965 /* my_exit() was called */
966 while (scopestack_ix > oldscope)
970 call_list(oldscope, endav);
972 #ifdef DEBUGGING_MSTATS
973 if (getenv("PERL_DEBUG_MSTATS"))
974 dump_mstats("after execution: ");
977 return STATUS_NATIVE_EXPORT;
980 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
985 if (curstack != mainstack) {
987 SWITCHSTACK(curstack, mainstack);
992 DEBUG_r(PerlIO_printf(PerlIO_stderr(), "%s $` $& $' support.\n",
993 sawampersand ? "Enabling" : "Omitting"));
997 DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
999 DEBUG_L(PerlIO_printf(Perl_debug_log, "main thread is 0x%lx\n",
1000 (unsigned long) thr));
1001 #endif /* USE_THREADS */
1004 PerlIO_printf(PerlIO_stderr(), "%s syntax OK\n", origfilename);
1007 if (perldb && DBsingle)
1008 sv_setiv(DBsingle, 1);
1010 call_list(oldscope, initav);
1020 else if (main_start) {
1021 CvDEPTH(main_cv) = 1;
1032 perl_get_sv(name, create)
1036 GV* gv = gv_fetchpv(name, create, SVt_PV);
1043 perl_get_av(name, create)
1047 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
1056 perl_get_hv(name, create)
1060 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
1069 perl_get_cv(name, create)
1073 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
1074 if (create && !GvCVu(gv))
1075 return newSUB(start_subparse(FALSE, 0),
1076 newSVOP(OP_CONST, 0, newSVpv(name,0)),
1084 /* Be sure to refetch the stack pointer after calling these routines. */
1087 perl_call_argv(subname, flags, argv)
1089 I32 flags; /* See G_* flags in cop.h */
1090 register char **argv; /* null terminated arg list */
1098 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
1103 return perl_call_pv(subname, flags);
1107 perl_call_pv(subname, flags)
1108 char *subname; /* name of the subroutine */
1109 I32 flags; /* See G_* flags in cop.h */
1111 return perl_call_sv((SV*)perl_get_cv(subname, TRUE), flags);
1115 perl_call_method(methname, flags)
1116 char *methname; /* name of the subroutine */
1117 I32 flags; /* See G_* flags in cop.h */
1124 XPUSHs(sv_2mortal(newSVpv(methname,0)));
1127 return perl_call_sv(*stack_sp--, flags);
1130 /* May be called with any of a CV, a GV, or an SV containing the name. */
1132 perl_call_sv(sv, flags)
1134 I32 flags; /* See G_* flags in cop.h */
1137 LOGOP myop; /* fake syntax tree node */
1143 bool oldcatch = CATCH_GET;
1147 if (flags & G_DISCARD) {
1152 Zero(&myop, 1, LOGOP);
1153 myop.op_next = Nullop;
1154 if (!(flags & G_NOARGS))
1155 myop.op_flags |= OPf_STACKED;
1156 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1157 (flags & G_ARRAY) ? OPf_WANT_LIST :
1162 EXTEND(stack_sp, 1);
1165 oldscope = scopestack_ix;
1167 if (perldb && curstash != debstash
1168 /* Handle first BEGIN of -d. */
1169 && (DBcv || (DBcv = GvCV(DBsub)))
1170 /* Try harder, since this may have been a sighandler, thus
1171 * curstash may be meaningless. */
1172 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != debstash))
1173 op->op_private |= OPpENTERSUB_DB;
1175 if (flags & G_EVAL) {
1176 cLOGOP->op_other = op;
1178 /* we're trying to emulate pp_entertry() here */
1180 register CONTEXT *cx;
1181 I32 gimme = GIMME_V;
1186 push_return(op->op_next);
1187 PUSHBLOCK(cx, CXt_EVAL, stack_sp);
1189 eval_root = op; /* Only needed so that goto works right. */
1192 if (flags & G_KEEPERR)
1195 sv_setpv(GvSV(errgv),"");
1207 /* my_exit() was called */
1208 curstash = defstash;
1212 croak("Callback called exit");
1221 stack_sp = stack_base + oldmark;
1222 if (flags & G_ARRAY)
1226 *++stack_sp = &sv_undef;
1234 if (op == (OP*)&myop)
1235 op = pp_entersub(ARGS);
1238 retval = stack_sp - (stack_base + oldmark);
1239 if ((flags & G_EVAL) && !(flags & G_KEEPERR))
1240 sv_setpv(GvSV(errgv),"");
1243 if (flags & G_EVAL) {
1244 if (scopestack_ix > oldscope) {
1248 register CONTEXT *cx;
1260 CATCH_SET(oldcatch);
1262 if (flags & G_DISCARD) {
1263 stack_sp = stack_base + oldmark;
1271 /* Eval a string. The G_EVAL flag is always assumed. */
1274 perl_eval_sv(sv, flags)
1276 I32 flags; /* See G_* flags in cop.h */
1279 UNOP myop; /* fake syntax tree node */
1281 I32 oldmark = sp - stack_base;
1287 if (flags & G_DISCARD) {
1295 EXTEND(stack_sp, 1);
1297 oldscope = scopestack_ix;
1299 if (!(flags & G_NOARGS))
1300 myop.op_flags = OPf_STACKED;
1301 myop.op_next = Nullop;
1302 myop.op_type = OP_ENTEREVAL;
1303 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1304 (flags & G_ARRAY) ? OPf_WANT_LIST :
1306 if (flags & G_KEEPERR)
1307 myop.op_flags |= OPf_SPECIAL;
1317 /* my_exit() was called */
1318 curstash = defstash;
1322 croak("Callback called exit");
1331 stack_sp = stack_base + oldmark;
1332 if (flags & G_ARRAY)
1336 *++stack_sp = &sv_undef;
1341 if (op == (OP*)&myop)
1342 op = pp_entereval(ARGS);
1345 retval = stack_sp - (stack_base + oldmark);
1346 if (!(flags & G_KEEPERR))
1347 sv_setpv(GvSV(errgv),"");
1351 if (flags & G_DISCARD) {
1352 stack_sp = stack_base + oldmark;
1361 perl_eval_pv(p, croak_on_error)
1367 SV* sv = newSVpv(p, 0);
1370 perl_eval_sv(sv, G_SCALAR);
1377 if (croak_on_error && SvTRUE(GvSV(errgv)))
1378 croak(SvPVx(GvSV(errgv), na));
1383 /* Require a module. */
1389 SV* sv = sv_newmortal();
1390 sv_setpv(sv, "require '");
1393 perl_eval_sv(sv, G_DISCARD);
1397 magicname(sym,name,namlen)
1404 if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
1405 sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
1409 usage(name) /* XXX move this out into a module ? */
1412 /* This message really ought to be max 23 lines.
1413 * Removed -h because the user already knows that opton. Others? */
1414 printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
1415 printf("\n -0[octal] specify record separator (\\0, if no argument)");
1416 printf("\n -a autosplit mode with -n or -p (splits $_ into @F)");
1417 printf("\n -c check syntax only (runs BEGIN and END blocks)");
1418 printf("\n -d[:debugger] run scripts under debugger");
1419 printf("\n -D[number/list] set debugging flags (argument is a bit mask or flags)");
1420 printf("\n -e 'command' one line of script. Several -e's allowed. Omit [programfile].");
1421 printf("\n -F/pattern/ split() pattern for autosplit (-a). The //'s are optional.");
1422 printf("\n -i[extension] edit <> files in place (make backup if extension supplied)");
1423 printf("\n -Idirectory specify @INC/#include directory (may be used more then once)");
1424 printf("\n -l[octal] enable line ending processing, specifies line teminator");
1425 printf("\n -[mM][-]module.. executes `use/no module...' before executing your script.");
1426 printf("\n -n assume 'while (<>) { ... }' loop arround your script");
1427 printf("\n -p assume loop like -n but print line also like sed");
1428 printf("\n -P run script through C preprocessor before compilation");
1429 printf("\n -s enable some switch parsing for switches after script name");
1430 printf("\n -S look for the script using PATH environment variable");
1431 printf("\n -T turn on tainting checks");
1432 printf("\n -u dump core after parsing script");
1433 printf("\n -U allow unsafe operations");
1434 printf("\n -v print version number and patchlevel of perl");
1435 printf("\n -V[:variable] print perl configuration information");
1436 printf("\n -w TURN WARNINGS ON FOR COMPILATION OF YOUR SCRIPT.");
1437 printf("\n -x[directory] strip off text before #!perl line and perhaps cd to directory\n");
1440 /* This routine handles any switches that can be given during run */
1451 rschar = scan_oct(s, 4, &numlen);
1453 if (rschar & ~((U8)~0))
1455 else if (!rschar && numlen >= 2)
1456 nrs = newSVpv("", 0);
1459 nrs = newSVpv(&ch, 1);
1464 splitstr = savepv(s + 1);
1478 if (*s == ':' || *s == '=') {
1479 my_setenv("PERL5DB", form("use Devel::%s;", ++s));
1490 if (isALPHA(s[1])) {
1491 static char debopts[] = "psltocPmfrxuLHXD";
1494 for (s++; *s && (d = strchr(debopts,*s)); s++)
1495 debug |= 1 << (d - debopts);
1499 for (s++; isDIGIT(*s); s++) ;
1501 debug |= 0x80000000;
1503 warn("Recompile perl with -DDEBUGGING to use -D switch\n");
1504 for (s++; isALNUM(*s); s++) ;
1514 inplace = savepv(s+1);
1516 for (s = inplace; *s && !isSPACE(*s); s++) ;
1523 for (e = s; *e && !isSPACE(*e); e++) ;
1524 p = savepvn(s, e-s);
1531 croak("No space allowed after -I");
1541 *ors = scan_oct(s, 3 + (*s == '0'), &numlen);
1550 ors = SvPV(nrs, orslen);
1551 ors = savepvn(ors, orslen);
1555 forbid_setid("-M"); /* XXX ? */
1558 forbid_setid("-m"); /* XXX ? */
1563 /* -M-foo == 'no foo' */
1564 if (*s == '-') { use = "no "; ++s; }
1565 sv = newSVpv(use,0);
1567 /* We allow -M'Module qw(Foo Bar)' */
1568 while(isALNUM(*s) || *s==':') ++s;
1570 sv_catpv(sv, start);
1571 if (*(start-1) == 'm') {
1573 croak("Can't use '%c' after -mname", *s);
1574 sv_catpv( sv, " ()");
1577 sv_catpvn(sv, start, s-start);
1578 sv_catpv(sv, " split(/,/,q{");
1583 if (preambleav == NULL)
1584 preambleav = newAV();
1585 av_push(preambleav, sv);
1588 croak("No space allowed after -%c", *(s-1));
1605 croak("Too late for \"-T\" option");
1617 #if defined(SUBVERSION) && SUBVERSION > 0
1618 printf("\nThis is perl, version 5.%03d_%02d", PATCHLEVEL, SUBVERSION);
1620 printf("\nThis is perl, version %s",patchlevel);
1623 printf("\n\nCopyright 1987-1997, Larry Wall\n");
1625 printf("\n\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
1628 printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n");
1631 printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
1632 "Version 5 port Copyright (c) 1994-1997, Andreas Kaiser, Ilya Zakharevich\n");
1635 printf("atariST series port, ++jrb bammi@cadence.com\n");
1638 Perl may be copied only under the terms of either the Artistic License or the\n\
1639 GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n");
1647 if (s[1] == '-') /* Additional switches on #! line. */
1655 #ifdef ALTERNATE_SHEBANG
1656 case 'S': /* OS/2 needs -S on "extproc" line. */
1664 croak("Can't emulate -%.1s on #! line",s);
1669 /* compliments of Tom Christiansen */
1671 /* unexec() can be found in the Gnu emacs distribution */
1682 prog = newSVpv(BIN_EXP);
1683 sv_catpv(prog, "/perl");
1684 file = newSVpv(origfilename);
1685 sv_catpv(file, ".perldump");
1687 status = unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
1689 PerlIO_printf(PerlIO_stderr(), "unexec of %s into %s failed!\n",
1690 SvPVX(prog), SvPVX(file));
1694 # include <lib$routines.h>
1695 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
1697 ABORT(); /* for use with undump */
1708 /* Note that strtab is a rather special HV. Assumptions are made
1709 about not iterating on it, and not adding tie magic to it.
1710 It is properly deallocated in perl_destruct() */
1712 HvSHAREKEYS_off(strtab); /* mandatory */
1713 Newz(506,((XPVHV*)SvANY(strtab))->xhv_array,
1714 sizeof(HE*) * (((XPVHV*)SvANY(strtab))->xhv_max + 1), char);
1716 curstash = defstash = newHV();
1717 curstname = newSVpv("main",4);
1718 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
1719 SvREFCNT_dec(GvHV(gv));
1720 GvHV(gv) = (HV*)SvREFCNT_inc(defstash);
1722 HvNAME(defstash) = savepv("main");
1723 incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
1725 defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
1726 errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
1728 sv_setpvn(GvSV(errgv), "", 0);
1729 curstash = defstash;
1730 compiling.cop_stash = defstash;
1731 debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
1732 /* We must init $/ before switches are processed. */
1733 sv_setpvn(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), "\n", 1);
1736 #ifdef CAN_PROTOTYPE
1738 open_script(char *scriptname, bool dosearch, SV *sv)
1741 open_script(scriptname,dosearch,sv)
1748 char *xfound = Nullch;
1749 char *xfailed = Nullch;
1753 #if defined(DOSISH) && !defined(OS2) && !defined(atarist)
1754 # define SEARCH_EXTS ".bat", ".cmd", NULL
1755 # define MAX_EXT_LEN 4
1758 # define SEARCH_EXTS ".pl", ".com", NULL
1759 # define MAX_EXT_LEN 4
1761 /* additional extensions to try in each dir if scriptname not found */
1763 char *ext[] = { SEARCH_EXTS };
1764 int extidx = (strchr(scriptname,'.')) ? -1 : 0; /* has ext already */
1766 # define MAX_EXT_LEN 0
1771 int hasdir, idx = 0, deftypes = 1;
1773 hasdir = (strpbrk(scriptname,":[</") != Nullch) ;
1774 /* The first time through, just add SEARCH_EXTS to whatever we
1775 * already have, so we can check for default file types. */
1777 (!hasdir && my_trnlnm("DCL$PATH",tokenbuf,idx++)) )
1783 if ((strlen(tokenbuf) + strlen(scriptname)
1784 + MAX_EXT_LEN) >= sizeof tokenbuf)
1785 continue; /* don't search dir with too-long name */
1786 strcat(tokenbuf, scriptname);
1788 if (dosearch && !strchr(scriptname, '/') && (s = getenv("PATH"))) {
1789 bufend = s + strlen(s);
1790 while (s < bufend) {
1792 s = delimcpy(tokenbuf, tokenbuf + sizeof tokenbuf, s, bufend,
1800 for (len = 0; *s && *s != ',' && *s != ';'; len++, s++) {
1801 if (len < sizeof tokenbuf)
1804 if (len < sizeof tokenbuf)
1805 tokenbuf[len] = '\0';
1806 #endif /* atarist */
1809 if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tokenbuf)
1810 continue; /* don't search dir with too-long name */
1812 #if defined(atarist) && !defined(DOSISH)
1813 && tokenbuf[len - 1] != '/'
1815 #if defined(atarist) || defined(DOSISH)
1816 && tokenbuf[len - 1] != '\\'
1819 tokenbuf[len++] = '/';
1820 (void)strcpy(tokenbuf + len, scriptname);
1824 len = strlen(tokenbuf);
1825 if (extidx > 0) /* reset after previous loop */
1829 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tokenbuf));
1830 retval = Stat(tokenbuf,&statbuf);
1832 } while ( retval < 0 /* not there */
1833 && extidx>=0 && ext[extidx] /* try an extension? */
1834 && strcpy(tokenbuf+len, ext[extidx++])
1839 if (S_ISREG(statbuf.st_mode)
1840 && cando(S_IRUSR,TRUE,&statbuf)
1842 && cando(S_IXUSR,TRUE,&statbuf)
1846 xfound = tokenbuf; /* bingo! */
1850 xfailed = savepv(tokenbuf);
1853 croak("Can't execute %s", xfailed ? xfailed : scriptname );
1856 scriptname = xfound;
1859 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
1860 char *s = scriptname + 8;
1869 origfilename = savepv(e_tmpname ? "-e" : scriptname);
1870 curcop->cop_filegv = gv_fetchfile(origfilename);
1871 if (strEQ(origfilename,"-"))
1873 if (fdscript >= 0) {
1874 rsfp = PerlIO_fdopen(fdscript,"r");
1875 #if defined(HAS_FCNTL) && defined(F_SETFD)
1877 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
1880 else if (preprocess) {
1881 char *cpp_cfg = CPPSTDIN;
1882 SV *cpp = NEWSV(0,0);
1883 SV *cmd = NEWSV(0,0);
1885 if (strEQ(cpp_cfg, "cppstdin"))
1886 sv_catpvf(cpp, "%s/", BIN_EXP);
1887 sv_catpv(cpp, cpp_cfg);
1890 sv_catpv(sv,PRIVLIB_EXP);
1894 sed %s -e \"/^[^#]/b\" \
1895 -e \"/^#[ ]*include[ ]/b\" \
1896 -e \"/^#[ ]*define[ ]/b\" \
1897 -e \"/^#[ ]*if[ ]/b\" \
1898 -e \"/^#[ ]*ifdef[ ]/b\" \
1899 -e \"/^#[ ]*ifndef[ ]/b\" \
1900 -e \"/^#[ ]*else/b\" \
1901 -e \"/^#[ ]*elif[ ]/b\" \
1902 -e \"/^#[ ]*undef[ ]/b\" \
1903 -e \"/^#[ ]*endif/b\" \
1906 (doextract ? "-e \"1,/^#/d\n\"" : ""),
1909 %s %s -e '/^[^#]/b' \
1910 -e '/^#[ ]*include[ ]/b' \
1911 -e '/^#[ ]*define[ ]/b' \
1912 -e '/^#[ ]*if[ ]/b' \
1913 -e '/^#[ ]*ifdef[ ]/b' \
1914 -e '/^#[ ]*ifndef[ ]/b' \
1915 -e '/^#[ ]*else/b' \
1916 -e '/^#[ ]*elif[ ]/b' \
1917 -e '/^#[ ]*undef[ ]/b' \
1918 -e '/^#[ ]*endif/b' \
1926 (doextract ? "-e '1,/^#/d\n'" : ""),
1928 scriptname, cpp, sv, CPPMINUS);
1930 #ifdef IAMSUID /* actually, this is caught earlier */
1931 if (euid != uid && !euid) { /* if running suidperl */
1933 (void)seteuid(uid); /* musn't stay setuid root */
1936 (void)setreuid((Uid_t)-1, uid);
1938 #ifdef HAS_SETRESUID
1939 (void)setresuid((Uid_t)-1, uid, (Uid_t)-1);
1945 if (geteuid() != uid)
1946 croak("Can't do seteuid!\n");
1948 #endif /* IAMSUID */
1949 rsfp = my_popen(SvPVX(cmd), "r");
1953 else if (!*scriptname) {
1954 forbid_setid("program input from stdin");
1955 rsfp = PerlIO_stdin();
1958 rsfp = PerlIO_open(scriptname,"r");
1959 #if defined(HAS_FCNTL) && defined(F_SETFD)
1961 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
1969 #ifndef IAMSUID /* in case script is not readable before setuid */
1970 if (euid && Stat(SvPVX(GvSV(curcop->cop_filegv)),&statbuf) >= 0 &&
1971 statbuf.st_mode & (S_ISUID|S_ISGID)) {
1973 execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
1974 croak("Can't do setuid\n");
1978 croak("Can't open perl script \"%s\": %s\n",
1979 SvPVX(GvSV(curcop->cop_filegv)), Strerror(errno));
1984 validate_suid(validarg, scriptname)
1990 /* do we need to emulate setuid on scripts? */
1992 /* This code is for those BSD systems that have setuid #! scripts disabled
1993 * in the kernel because of a security problem. Merely defining DOSUID
1994 * in perl will not fix that problem, but if you have disabled setuid
1995 * scripts in the kernel, this will attempt to emulate setuid and setgid
1996 * on scripts that have those now-otherwise-useless bits set. The setuid
1997 * root version must be called suidperl or sperlN.NNN. If regular perl
1998 * discovers that it has opened a setuid script, it calls suidperl with
1999 * the same argv that it had. If suidperl finds that the script it has
2000 * just opened is NOT setuid root, it sets the effective uid back to the
2001 * uid. We don't just make perl setuid root because that loses the
2002 * effective uid we had before invoking perl, if it was different from the
2005 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
2006 * be defined in suidperl only. suidperl must be setuid root. The
2007 * Configure script will set this up for you if you want it.
2013 if (Fstat(PerlIO_fileno(rsfp),&statbuf) < 0) /* normal stat is insecure */
2014 croak("Can't stat script \"%s\"",origfilename);
2015 if (fdscript < 0 && statbuf.st_mode & (S_ISUID|S_ISGID)) {
2019 #ifndef HAS_SETREUID
2020 /* On this access check to make sure the directories are readable,
2021 * there is actually a small window that the user could use to make
2022 * filename point to an accessible directory. So there is a faint
2023 * chance that someone could execute a setuid script down in a
2024 * non-accessible directory. I don't know what to do about that.
2025 * But I don't think it's too important. The manual lies when
2026 * it says access() is useful in setuid programs.
2028 if (access(SvPVX(GvSV(curcop->cop_filegv)),1)) /*double check*/
2029 croak("Permission denied");
2031 /* If we can swap euid and uid, then we can determine access rights
2032 * with a simple stat of the file, and then compare device and
2033 * inode to make sure we did stat() on the same file we opened.
2034 * Then we just have to make sure he or she can execute it.
2037 struct stat tmpstatbuf;
2041 setreuid(euid,uid) < 0
2044 setresuid(euid,uid,(Uid_t)-1) < 0
2047 || getuid() != euid || geteuid() != uid)
2048 croak("Can't swap uid and euid"); /* really paranoid */
2049 if (Stat(SvPVX(GvSV(curcop->cop_filegv)),&tmpstatbuf) < 0)
2050 croak("Permission denied"); /* testing full pathname here */
2051 if (tmpstatbuf.st_dev != statbuf.st_dev ||
2052 tmpstatbuf.st_ino != statbuf.st_ino) {
2053 (void)PerlIO_close(rsfp);
2054 if (rsfp = my_popen("/bin/mail root","w")) { /* heh, heh */
2056 "User %ld tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
2057 (Filename of set-id script was %s, uid %ld gid %ld.)\n\nSincerely,\nperl\n",
2058 (long)uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
2059 (long)statbuf.st_dev, (long)statbuf.st_ino,
2060 SvPVX(GvSV(curcop->cop_filegv)),
2061 (long)statbuf.st_uid, (long)statbuf.st_gid);
2062 (void)my_pclose(rsfp);
2064 croak("Permission denied\n");
2068 setreuid(uid,euid) < 0
2070 # if defined(HAS_SETRESUID)
2071 setresuid(uid,euid,(Uid_t)-1) < 0
2074 || getuid() != uid || geteuid() != euid)
2075 croak("Can't reswap uid and euid");
2076 if (!cando(S_IXUSR,FALSE,&statbuf)) /* can real uid exec? */
2077 croak("Permission denied\n");
2079 #endif /* HAS_SETREUID */
2080 #endif /* IAMSUID */
2082 if (!S_ISREG(statbuf.st_mode))
2083 croak("Permission denied");
2084 if (statbuf.st_mode & S_IWOTH)
2085 croak("Setuid/gid script is writable by world");
2086 doswitches = FALSE; /* -s is insecure in suid */
2088 if (sv_gets(linestr, rsfp, 0) == Nullch ||
2089 strnNE(SvPV(linestr,na),"#!",2) ) /* required even on Sys V */
2090 croak("No #! line");
2091 s = SvPV(linestr,na)+2;
2093 while (!isSPACE(*s)) s++;
2094 for (s2 = s; (s2 > SvPV(linestr,na)+2 &&
2095 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
2096 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
2097 croak("Not a perl script");
2098 while (*s == ' ' || *s == '\t') s++;
2100 * #! arg must be what we saw above. They can invoke it by
2101 * mentioning suidperl explicitly, but they may not add any strange
2102 * arguments beyond what #! says if they do invoke suidperl that way.
2104 len = strlen(validarg);
2105 if (strEQ(validarg," PHOOEY ") ||
2106 strnNE(s,validarg,len) || !isSPACE(s[len]))
2107 croak("Args must match #! line");
2110 if (euid != uid && (statbuf.st_mode & S_ISUID) &&
2111 euid == statbuf.st_uid)
2113 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2114 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2115 #endif /* IAMSUID */
2117 if (euid) { /* oops, we're not the setuid root perl */
2118 (void)PerlIO_close(rsfp);
2121 execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
2123 croak("Can't do setuid\n");
2126 if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid) {
2128 (void)setegid(statbuf.st_gid);
2131 (void)setregid((Gid_t)-1,statbuf.st_gid);
2133 #ifdef HAS_SETRESGID
2134 (void)setresgid((Gid_t)-1,statbuf.st_gid,(Gid_t)-1);
2136 setgid(statbuf.st_gid);
2140 if (getegid() != statbuf.st_gid)
2141 croak("Can't do setegid!\n");
2143 if (statbuf.st_mode & S_ISUID) {
2144 if (statbuf.st_uid != euid)
2146 (void)seteuid(statbuf.st_uid); /* all that for this */
2149 (void)setreuid((Uid_t)-1,statbuf.st_uid);
2151 #ifdef HAS_SETRESUID
2152 (void)setresuid((Uid_t)-1,statbuf.st_uid,(Uid_t)-1);
2154 setuid(statbuf.st_uid);
2158 if (geteuid() != statbuf.st_uid)
2159 croak("Can't do seteuid!\n");
2161 else if (uid) { /* oops, mustn't run as root */
2163 (void)seteuid((Uid_t)uid);
2166 (void)setreuid((Uid_t)-1,(Uid_t)uid);
2168 #ifdef HAS_SETRESUID
2169 (void)setresuid((Uid_t)-1,(Uid_t)uid,(Uid_t)-1);
2175 if (geteuid() != uid)
2176 croak("Can't do seteuid!\n");
2179 if (!cando(S_IXUSR,TRUE,&statbuf))
2180 croak("Permission denied\n"); /* they can't do this */
2183 else if (preprocess)
2184 croak("-P not allowed for setuid/setgid script\n");
2185 else if (fdscript >= 0)
2186 croak("fd script not allowed in suidperl\n");
2188 croak("Script is not setuid/setgid in suidperl\n");
2190 /* We absolutely must clear out any saved ids here, so we */
2191 /* exec the real perl, substituting fd script for scriptname. */
2192 /* (We pass script name as "subdir" of fd, which perl will grok.) */
2193 PerlIO_rewind(rsfp);
2194 lseek(PerlIO_fileno(rsfp),(Off_t)0,0); /* just in case rewind didn't */
2195 for (which = 1; origargv[which] && origargv[which] != scriptname; which++) ;
2196 if (!origargv[which])
2197 croak("Permission denied");
2198 origargv[which] = savepv(form("/dev/fd/%d/%s",
2199 PerlIO_fileno(rsfp), origargv[which]));
2200 #if defined(HAS_FCNTL) && defined(F_SETFD)
2201 fcntl(PerlIO_fileno(rsfp),F_SETFD,0); /* ensure no close-on-exec */
2203 execv(form("%s/perl%s", BIN_EXP, patchlevel), origargv); /* try again */
2204 croak("Can't do setuid\n");
2205 #endif /* IAMSUID */
2207 if (euid != uid || egid != gid) { /* (suidperl doesn't exist, in fact) */
2208 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
2210 Fstat(PerlIO_fileno(rsfp),&statbuf); /* may be either wrapped or real suid */
2211 if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
2213 (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
2216 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2217 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2218 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
2219 /* not set-id, must be wrapped */
2227 register char *s, *s2;
2229 /* skip forward in input to the real script? */
2233 if ((s = sv_gets(linestr, rsfp, 0)) == Nullch)
2234 croak("No Perl script found in input\n");
2235 if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
2236 PerlIO_ungetc(rsfp, '\n'); /* to keep line count right */
2238 while (*s && !(isSPACE (*s) || *s == '#')) s++;
2240 while (*s == ' ' || *s == '\t') s++;
2242 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
2243 if (strnEQ(s2-4,"perl",4))
2245 while (s = moreswitches(s)) ;
2247 if (cddir && chdir(cddir) < 0)
2248 croak("Can't chdir to %s",cddir);
2256 uid = (int)getuid();
2257 euid = (int)geteuid();
2258 gid = (int)getgid();
2259 egid = (int)getegid();
2264 tainting |= (uid && (euid != uid || egid != gid));
2272 croak("No %s allowed while running setuid", s);
2274 croak("No %s allowed while running setgid", s);
2281 curstash = debstash;
2282 dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
2284 DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
2285 DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
2286 DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
2287 DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
2288 sv_setiv(DBsingle, 0);
2289 DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
2290 sv_setiv(DBtrace, 0);
2291 DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
2292 sv_setiv(DBsignal, 0);
2293 curstash = defstash;
2301 mainstack = curstack; /* remember in case we switch stacks */
2302 AvREAL_off(curstack); /* not a real array */
2303 av_extend(curstack,127);
2305 stack_base = AvARRAY(curstack);
2306 stack_sp = stack_base;
2307 stack_max = stack_base + 127;
2309 cxstack_max = 8192 / sizeof(CONTEXT) - 2; /* Use most of 8K. */
2310 New(50,cxstack,cxstack_max + 1,CONTEXT);
2313 New(50,tmps_stack,128,SV*);
2319 * The following stacks almost certainly should be per-interpreter,
2320 * but for now they're not. XXX
2324 markstack_ptr = markstack;
2326 New(54,markstack,64,I32);
2327 markstack_ptr = markstack;
2328 markstack_max = markstack + 64;
2334 New(54,scopestack,32,I32);
2336 scopestack_max = 32;
2342 New(54,savestack,128,ANY);
2344 savestack_max = 128;
2350 New(54,retstack,16,OP*);
2361 Safefree(tmps_stack);
2368 static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
2376 subname = newSVpv("main",4);
2380 init_predump_symbols()
2386 sv_setpvn(GvSV(gv_fetchpv("\"", TRUE, SVt_PV)), " ", 1);
2388 stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
2389 GvMULTI_on(stdingv);
2390 IoIFP(GvIOp(stdingv)) = PerlIO_stdin();
2391 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
2393 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(stdingv));
2395 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
2397 IoOFP(GvIOp(tmpgv)) = IoIFP(GvIOp(tmpgv)) = PerlIO_stdout();
2399 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
2401 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(defoutgv));
2403 othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
2404 GvMULTI_on(othergv);
2405 IoOFP(GvIOp(othergv)) = IoIFP(GvIOp(othergv)) = PerlIO_stderr();
2406 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
2408 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(othergv));
2410 statname = NEWSV(66,0); /* last filename we did stat on */
2413 osname = savepv(OSNAME);
2417 init_postdump_symbols(argc,argv,env)
2419 register char **argv;
2420 register char **env;
2426 argc--,argv++; /* skip name of script */
2428 for (; argc > 0 && **argv == '-'; argc--,argv++) {
2431 if (argv[0][1] == '-') {
2435 if (s = strchr(argv[0], '=')) {
2437 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
2440 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
2443 toptarget = NEWSV(0,0);
2444 sv_upgrade(toptarget, SVt_PVFM);
2445 sv_setpvn(toptarget, "", 0);
2446 bodytarget = NEWSV(0,0);
2447 sv_upgrade(bodytarget, SVt_PVFM);
2448 sv_setpvn(bodytarget, "", 0);
2449 formtarget = bodytarget;
2452 if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
2453 sv_setpv(GvSV(tmpgv),origfilename);
2454 magicname("0", "0", 1);
2456 if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
2457 sv_setpv(GvSV(tmpgv),origargv[0]);
2458 if (argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
2460 (void)gv_AVadd(argvgv);
2461 av_clear(GvAVn(argvgv));
2462 for (; argc > 0; argc--,argv++) {
2463 av_push(GvAVn(argvgv),newSVpv(argv[0],0));
2466 if (envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
2470 hv_magic(hv, envgv, 'E');
2471 #ifndef VMS /* VMS doesn't have environ array */
2472 /* Note that if the supplied env parameter is actually a copy
2473 of the global environ then it may now point to free'd memory
2474 if the environment has been modified since. To avoid this
2475 problem we treat env==NULL as meaning 'use the default'
2480 environ[0] = Nullch;
2481 for (; *env; env++) {
2482 if (!(s = strchr(*env,'=')))
2488 sv = newSVpv(s--,0);
2489 (void)hv_store(hv, *env, s - *env, sv, 0);
2491 #if defined(__BORLANDC__) && defined(USE_WIN32_RTL_ENV)
2492 /* Sins of the RTL. See note in my_setenv(). */
2493 (void)putenv(savepv(*env));
2497 #ifdef DYNAMIC_ENV_FETCH
2498 HvNAME(hv) = savepv(ENV_HV_NAME);
2502 if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
2503 sv_setiv(GvSV(tmpgv), (IV)getpid());
2512 s = getenv("PERL5LIB");
2516 incpush(getenv("PERLLIB"), FALSE);
2518 /* Treat PERL5?LIB as a possible search list logical name -- the
2519 * "natural" VMS idiom for a Unix path string. We allow each
2520 * element to be a set of |-separated directories for compatibility.
2524 if (my_trnlnm("PERL5LIB",buf,0))
2525 do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
2527 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE);
2531 /* Use the ~-expanded versions of APPLLIB (undocumented),
2532 ARCHLIB PRIVLIB SITEARCH SITELIB and OLDARCHLIB
2535 incpush(APPLLIB_EXP, FALSE);
2539 incpush(ARCHLIB_EXP, FALSE);
2542 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
2544 incpush(PRIVLIB_EXP, FALSE);
2547 incpush(SITEARCH_EXP, FALSE);
2550 incpush(SITELIB_EXP, FALSE);
2552 #ifdef OLDARCHLIB_EXP /* 5.00[01] compatibility */
2553 incpush(OLDARCHLIB_EXP, FALSE);
2557 incpush(".", FALSE);
2561 # define PERLLIB_SEP ';'
2564 # define PERLLIB_SEP '|'
2566 # define PERLLIB_SEP ':'
2569 #ifndef PERLLIB_MANGLE
2570 # define PERLLIB_MANGLE(s,n) (s)
2574 incpush(p, addsubdirs)
2578 SV *subdir = Nullsv;
2579 static char *archpat_auto;
2586 if (!archpat_auto) {
2587 STRLEN len = (sizeof(ARCHNAME) + strlen(patchlevel)
2588 + sizeof("//auto"));
2589 New(55, archpat_auto, len, char);
2590 sprintf(archpat_auto, "/%s/%s/auto", ARCHNAME, patchlevel);
2592 for (len = sizeof(ARCHNAME) + 2;
2593 archpat_auto[len] != '\0' && archpat_auto[len] != '/'; len++)
2594 if (archpat_auto[len] == '.') archpat_auto[len] = '_';
2599 /* Break at all separators */
2601 SV *libdir = newSV(0);
2604 /* skip any consecutive separators */
2605 while ( *p == PERLLIB_SEP ) {
2606 /* Uncomment the next line for PATH semantics */
2607 /* av_push(GvAVn(incgv), newSVpv(".", 1)); */
2611 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
2612 sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
2617 sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
2618 p = Nullch; /* break out */
2622 * BEFORE pushing libdir onto @INC we may first push version- and
2623 * archname-specific sub-directories.
2626 struct stat tmpstatbuf;
2631 if ((unix = tounixspec_ts(SvPV(libdir,na),Nullch)) != Nullch) {
2633 while (unix[len-1] == '/') len--; /* Cosmetic */
2634 sv_usepvn(libdir,unix,len);
2637 PerlIO_printf(PerlIO_stderr(),
2638 "Failed to unixify @INC element \"%s\"\n",
2641 /* .../archname/version if -d .../archname/version/auto */
2642 sv_setsv(subdir, libdir);
2643 sv_catpv(subdir, archpat_auto);
2644 if (Stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2645 S_ISDIR(tmpstatbuf.st_mode))
2646 av_push(GvAVn(incgv),
2647 newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2649 /* .../archname if -d .../archname/auto */
2650 sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME),
2651 strlen(patchlevel) + 1, "", 0);
2652 if (Stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2653 S_ISDIR(tmpstatbuf.st_mode))
2654 av_push(GvAVn(incgv),
2655 newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2658 /* finally push this lib directory on the end of @INC */
2659 av_push(GvAVn(incgv), libdir);
2662 SvREFCNT_dec(subdir);
2666 call_list(oldscope, list)
2671 line_t oldline = curcop->cop_line;
2676 while (AvFILL(list) >= 0) {
2677 CV *cv = (CV*)av_shift(list);
2684 SV* atsv = GvSV(errgv);
2686 perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
2687 (void)SvPV(atsv, len);
2690 curcop = &compiling;
2691 curcop->cop_line = oldline;
2692 if (list == beginav)
2693 sv_catpv(atsv, "BEGIN failed--compilation aborted");
2695 sv_catpv(atsv, "END failed--cleanup aborted");
2696 while (scopestack_ix > oldscope)
2698 croak("%s", SvPVX(atsv));
2706 /* my_exit() was called */
2707 while (scopestack_ix > oldscope)
2709 curstash = defstash;
2711 call_list(oldscope, endav);
2714 curcop = &compiling;
2715 curcop->cop_line = oldline;
2717 if (list == beginav)
2718 croak("BEGIN failed--compilation aborted");
2720 croak("END failed--cleanup aborted");
2726 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
2731 curcop = &compiling;
2732 curcop->cop_line = oldline;
2746 DEBUG_L(PerlIO_printf(Perl_debug_log, "my_exit: thread 0x%lx, status %lu\n",
2747 (unsigned long) thr, (unsigned long) status));
2748 #endif /* USE_THREADS */
2757 STATUS_NATIVE_SET(status);
2767 if (vaxc$errno & 1) {
2768 if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
2769 STATUS_NATIVE_SET(44);
2772 if (!vaxc$errno && errno) /* unlikely */
2773 STATUS_NATIVE_SET(44);
2775 STATUS_NATIVE_SET(vaxc$errno);
2779 STATUS_POSIX_SET(errno);
2780 else if (STATUS_POSIX == 0)
2781 STATUS_POSIX_SET(255);
2790 register CONTEXT *cx;
2799 (void)UNLINK(e_tmpname);
2800 Safefree(e_tmpname);
2804 if (cxstack_ix >= 0) {