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 *));
78 static void usage _((char *));
79 static void validate_suid _((char *, char*));
81 static int fdscript = -1;
83 #if defined(DEBUGGING) && defined(USE_THREADS) && defined(__linux__)
84 #include <asm/sigcontext.h>
86 catch_sigsegv(int signo, struct sigcontext_struct sc)
88 signal(SIGSEGV, SIG_DFL);
89 fprintf(stderr, "Segmentation fault dereferencing 0x%lx\n"
90 "return_address = 0x%lx, eip = 0x%lx\n",
91 sc.cr2, __builtin_return_address(0), sc.eip);
92 fprintf(stderr, "thread = 0x%lx\n", (unsigned long)THR);
99 PerlInterpreter *sv_interp;
102 New(53, sv_interp, 1, PerlInterpreter);
107 perl_construct( sv_interp )
108 register PerlInterpreter *sv_interp;
114 #endif /* FAKE_THREADS */
115 #endif /* USE_THREADS */
117 if (!(curinterp = sv_interp))
121 Zero(sv_interp, 1, PerlInterpreter);
124 /* Init the real globals (and main thread)? */
129 if (pthread_key_create(&thr_key, 0))
130 croak("panic: pthread_key_create");
131 MUTEX_INIT(&malloc_mutex);
132 MUTEX_INIT(&sv_mutex);
134 * Safe to use basic SV functions from now on (though
135 * not things like mortals or tainting yet).
137 MUTEX_INIT(&eval_mutex);
138 COND_INIT(&eval_cond);
139 MUTEX_INIT(&threads_mutex);
140 COND_INIT(&nthreads_cond);
142 thr = new_struct_thread(0);
143 #endif /* USE_THREADS */
145 linestr = NEWSV(65,80);
146 sv_upgrade(linestr,SVt_PVIV);
148 if (!SvREADONLY(&sv_undef)) {
149 SvREADONLY_on(&sv_undef);
153 SvREADONLY_on(&sv_no);
155 sv_setpv(&sv_yes,Yes);
157 SvREADONLY_on(&sv_yes);
160 nrs = newSVpv("\n", 1);
161 rs = SvREFCNT_inc(nrs);
163 sighandlerp = sighandler;
168 * There is no way we can refer to them from Perl so close them to save
169 * space. The other alternative would be to provide STDAUX and STDPRN
172 (void)fclose(stdaux);
173 (void)fclose(stdprn);
179 perl_destruct_level = 1;
181 if(perl_destruct_level > 0)
186 lex_state = LEX_NOTPARSING;
188 start_env.je_prev = NULL;
189 start_env.je_ret = -1;
190 start_env.je_mustcatch = TRUE;
191 top_env = &start_env;
194 SET_NUMERIC_STANDARD();
195 #if defined(SUBVERSION) && SUBVERSION > 0
196 sprintf(patchlevel, "%7.5f", (double) 5
197 + ((double) PATCHLEVEL / (double) 1000)
198 + ((double) SUBVERSION / (double) 100000));
200 sprintf(patchlevel, "%5.3f", (double) 5 +
201 ((double) PATCHLEVEL / (double) 1000));
204 #if defined(LOCAL_PATCH_COUNT)
205 localpatches = local_patches; /* For possible -v */
208 PerlIO_init(); /* Hook to IO system */
210 fdpid = newAV(); /* for remembering popen pids by fd */
214 New(51,debname,128,char);
215 New(52,debdelim,128,char);
222 perl_destruct(sv_interp)
223 register PerlInterpreter *sv_interp;
226 int destruct_level; /* 0=none, 1=full, 2=full with checks */
231 #endif /* USE_THREADS */
233 if (!(curinterp = sv_interp))
238 /* Pass 1 on any remaining threads: detach joinables, join zombies */
240 MUTEX_LOCK(&threads_mutex);
241 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
242 "perl_destruct: waiting for %d threads...\n",
244 for (t = thr->next; t != thr; t = t->next) {
245 MUTEX_LOCK(&t->mutex);
246 switch (ThrSTATE(t)) {
249 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
250 "perl_destruct: joining zombie %p\n", t));
251 ThrSETSTATE(t, THRf_DEAD);
252 MUTEX_UNLOCK(&t->mutex);
255 * The SvREFCNT_dec below may take a long time (e.g. av
256 * may contain an object scalar whose destructor gets
257 * called) so we have to unlock threads_mutex and start
260 MUTEX_UNLOCK(&threads_mutex);
262 SvREFCNT_dec((SV*)av);
263 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
264 "perl_destruct: joined zombie %p OK\n", t));
266 case THRf_R_JOINABLE:
267 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
268 "perl_destruct: detaching thread %p\n", t));
269 ThrSETSTATE(t, THRf_R_DETACHED);
271 * We unlock threads_mutex and t->mutex in the opposite order
272 * from which we locked them just so that DETACH won't
273 * deadlock if it panics. It's only a breach of good style
274 * not a bug since they are unlocks not locks.
276 MUTEX_UNLOCK(&threads_mutex);
278 MUTEX_UNLOCK(&t->mutex);
281 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
282 "perl_destruct: ignoring %p (state %u)\n",
284 MUTEX_UNLOCK(&t->mutex);
285 /* fall through and out */
288 /* We leave the above "Pass 1" loop with threads_mutex still locked */
290 /* Pass 2 on remaining threads: wait for the thread count to drop to one */
293 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
294 "perl_destruct: final wait for %d threads\n",
296 COND_WAIT(&nthreads_cond, &threads_mutex);
298 /* At this point, we're the last thread */
299 MUTEX_UNLOCK(&threads_mutex);
300 DEBUG_L(PerlIO_printf(PerlIO_stderr(), "perl_destruct: armageddon has arrived\n"));
301 MUTEX_DESTROY(&threads_mutex);
302 COND_DESTROY(&nthreads_cond);
303 #endif /* !defined(FAKE_THREADS) */
304 #endif /* USE_THREADS */
306 destruct_level = perl_destruct_level;
310 if (s = getenv("PERL_DESTRUCT_LEVEL")) {
312 if (destruct_level < i)
321 /* We must account for everything. */
323 /* Destroy the main CV and syntax tree */
325 curpad = AvARRAY(comppad);
330 SvREFCNT_dec(main_cv);
335 * Try to destruct global references. We do this first so that the
336 * destructors and destructees still exist. Some sv's might remain.
337 * Non-referenced objects are on their own.
344 /* unhook hooks which will soon be, or use, destroyed data */
345 SvREFCNT_dec(warnhook);
347 SvREFCNT_dec(diehook);
349 SvREFCNT_dec(parsehook);
352 if (destruct_level == 0){
354 DEBUG_P(debprofdump());
356 /* The exit() function will do everything that needs doing. */
360 /* loosen bonds of global variables */
363 (void)PerlIO_close(rsfp);
367 /* Filters for program text */
368 SvREFCNT_dec(rsfp_filters);
369 rsfp_filters = Nullav;
381 sawampersand = FALSE; /* must save all match strings */
382 sawstudy = FALSE; /* do fbm_instr on all strings */
397 /* magical thingies */
399 Safefree(ofs); /* $, */
402 Safefree(ors); /* $\ */
405 SvREFCNT_dec(nrs); /* $\ helper */
408 multiline = 0; /* $* */
410 SvREFCNT_dec(statname);
414 /* defgv, aka *_ should be taken care of elsewhere */
416 #if 0 /* just about all regexp stuff, seems to be ok */
418 /* shortcuts to regexp stuff */
423 SAVEFREEOP(oldlastpm); /* for saving regexp context during debugger */
425 regprecomp = NULL; /* uncompiled string. */
426 regparse = NULL; /* Input-scan pointer. */
427 regxend = NULL; /* End of input for compile */
428 regnpar = 0; /* () count. */
429 regcode = NULL; /* Code-emit pointer; ®dummy = don't. */
430 regsize = 0; /* Code size. */
431 regnaughty = 0; /* How bad is this pattern? */
432 regsawback = 0; /* Did we see \1, ...? */
434 reginput = NULL; /* String-input pointer. */
435 regbol = NULL; /* Beginning of input, for ^ check. */
436 regeol = NULL; /* End of input, for $ check. */
437 regstartp = (char **)NULL; /* Pointer to startp array. */
438 regendp = (char **)NULL; /* Ditto for endp. */
439 reglastparen = 0; /* Similarly for lastparen. */
440 regtill = NULL; /* How far we are required to go. */
441 regflags = 0; /* are we folding, multilining? */
442 regprev = (char)NULL; /* char before regbol, \n if none */
446 /* clean up after study() */
447 SvREFCNT_dec(lastscream);
449 Safefree(screamfirst);
451 Safefree(screamnext);
454 /* startup and shutdown function lists */
455 SvREFCNT_dec(beginav);
457 SvREFCNT_dec(initav);
462 /* temp stack during pp_sort() */
463 SvREFCNT_dec(sortstack);
466 /* shortcuts just get cleared */
477 /* reset so print() ends up where we expect */
480 /* Prepare to destruct main symbol table. */
487 if (destruct_level >= 2) {
488 if (scopestack_ix != 0)
489 warn("Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
490 (long)scopestack_ix);
491 if (savestack_ix != 0)
492 warn("Unbalanced saves: %ld more saves than restores\n",
494 if (tmps_floor != -1)
495 warn("Unbalanced tmps: %ld more allocs than frees\n",
496 (long)tmps_floor + 1);
497 if (cxstack_ix != -1)
498 warn("Unbalanced context: %ld more PUSHes than POPs\n",
499 (long)cxstack_ix + 1);
502 /* Now absolutely destruct everything, somehow or other, loops or no. */
504 SvFLAGS(strtab) |= SVTYPEMASK; /* don't clean out strtab now */
505 while (sv_count != 0 && sv_count != last_sv_count) {
506 last_sv_count = sv_count;
509 SvFLAGS(strtab) &= ~SVTYPEMASK;
510 SvFLAGS(strtab) |= SVt_PVHV;
512 /* Destruct the global string table. */
514 /* Yell and reset the HeVAL() slots that are still holding refcounts,
515 * so that sv_free() won't fail on them.
524 array = HvARRAY(strtab);
528 warn("Unbalanced string table refcount: (%d) for \"%s\"",
529 HeVAL(hent) - Nullsv, HeKEY(hent));
530 HeVAL(hent) = Nullsv;
540 SvREFCNT_dec(strtab);
543 warn("Scalars leaked: %ld\n", (long)sv_count);
547 /* No SVs have survived, need to clean out */
551 Safefree(origfilename);
553 hints = 0; /* Reset hints. Should hints be per-interpreter ? */
555 DEBUG_P(debprofdump());
557 MUTEX_DESTROY(&sv_mutex);
558 MUTEX_DESTROY(&malloc_mutex);
559 MUTEX_DESTROY(&eval_mutex);
560 COND_DESTROY(&eval_cond);
562 /* As the penultimate thing, free the non-arena SV for thrsv */
563 Safefree(SvPVX(thrsv));
564 Safefree(SvANY(thrsv));
567 #endif /* USE_THREADS */
569 /* As the absolutely last thing, free the non-arena SV for mess() */
572 /* we know that type >= SVt_PV */
574 Safefree(SvPVX(mess_sv));
575 Safefree(SvANY(mess_sv));
583 PerlInterpreter *sv_interp;
585 if (!(curinterp = sv_interp))
591 perl_parse(sv_interp, xsinit, argc, argv, env)
592 PerlInterpreter *sv_interp;
593 void (*xsinit)_((void));
601 char *scriptname = NULL;
602 VOL bool dosearch = FALSE;
609 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
612 croak("suidperl is no longer needed since the kernel can now execute\n\
613 setuid perl scripts securely.\n");
617 if (!(curinterp = sv_interp))
620 #if defined(NeXT) && defined(__DYNAMIC__)
621 _dyld_lookup_and_bind
622 ("__environ", (unsigned long *) &environ_pointer, NULL);
627 #ifndef VMS /* VMS doesn't have environ array */
628 origenviron = environ;
634 /* Come here if running an undumped a.out. */
636 origfilename = savepv(argv[0]);
638 cxstack_ix = -1; /* start label stack again */
640 init_postdump_symbols(argc,argv,env);
645 curpad = AvARRAY(comppad);
650 SvREFCNT_dec(main_cv);
654 oldscope = scopestack_ix;
662 /* my_exit() was called */
663 while (scopestack_ix > oldscope)
668 call_list(oldscope, endav);
670 return STATUS_NATIVE_EXPORT;
673 PerlIO_printf(PerlIO_stderr(), "panic: top_env\n");
677 sv_setpvn(linestr,"",0);
678 sv = newSVpv("",0); /* first used for -I flags */
682 for (argc--,argv++; argc > 0; argc--,argv++) {
683 if (argv[0][0] != '-' || !argv[0][1])
687 validarg = " PHOOEY ";
712 if (s = moreswitches(s))
722 if (euid != uid || egid != gid)
723 croak("No -e allowed in setuid scripts");
725 e_tmpname = savepv(TMPPATH);
726 (void)mktemp(e_tmpname);
728 croak("Can't mktemp()");
729 e_fp = PerlIO_open(e_tmpname,"w");
731 croak("Cannot open temporary file");
736 PerlIO_puts(e_fp,argv[1]);
740 croak("No code specified for -e");
741 (void)PerlIO_putc(e_fp,'\n');
743 case 'I': /* -I handled both here and in moreswitches() */
745 if (!*++s && (s=argv[1]) != Nullch) {
748 while (s && isSPACE(*s))
752 for (e = s; *e && !isSPACE(*e); e++) ;
759 } /* XXX else croak? */
773 preambleav = newAV();
774 av_push(preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
776 Sv = newSVpv("print myconfig();",0);
778 sv_catpv(Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
780 sv_catpv(Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
782 #if defined(DEBUGGING) || defined(NO_EMBED) || defined(MULTIPLICITY)
783 sv_catpv(Sv,"\" Compile-time options:");
785 sv_catpv(Sv," DEBUGGING");
788 sv_catpv(Sv," NO_EMBED");
791 sv_catpv(Sv," MULTIPLICITY");
793 sv_catpv(Sv,"\\n\",");
795 #if defined(LOCAL_PATCH_COUNT)
796 if (LOCAL_PATCH_COUNT > 0) {
798 sv_catpv(Sv,"\" Locally applied patches:\\n\",");
799 for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
801 sv_catpvf(Sv,"\" \\t%s\\n\",",localpatches[i]);
805 sv_catpvf(Sv,"\" Built under %s\\n\"",OSNAME);
808 sv_catpvf(Sv,",\" Compiled at %s %s\\n\"",__DATE__,__TIME__);
810 sv_catpvf(Sv,",\" Compiled on %s\\n\"",__DATE__);
815 @env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; \
816 print \" \\%ENV:\\n @env\\n\" if @env; \
817 print \" \\@INC:\\n @INC\\n\";");
820 Sv = newSVpv("config_vars(qw(",0);
825 av_push(preambleav, Sv);
826 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
837 if (!*++s || isSPACE(*s)) {
841 /* catch use of gnu style long options */
842 if (strEQ(s, "version")) {
846 if (strEQ(s, "help")) {
853 croak("Unrecognized switch: -%s (-h will show valid options)",s);
858 if (!tainting && (s = getenv("PERL5OPT"))) {
869 if (!strchr("DIMUdmw", *s))
870 croak("Illegal switch in PERL5OPT: -%c", *s);
876 scriptname = argv[0];
878 if (PerlIO_flush(e_fp) || PerlIO_error(e_fp) || PerlIO_close(e_fp)) {
880 warn("Did you forget to compile with -DMULTIPLICITY?");
882 croak("Can't write to temp file for -e: %s", Strerror(errno));
886 scriptname = e_tmpname;
888 else if (scriptname == Nullch) {
890 if ( isatty(PerlIO_fileno(PerlIO_stdin())) )
898 open_script(scriptname,dosearch,sv);
900 validate_suid(validarg, scriptname);
905 main_cv = compcv = (CV*)NEWSV(1104,0);
906 sv_upgrade((SV *)compcv, SVt_PVCV);
910 av_push(comppad, Nullsv);
911 curpad = AvARRAY(comppad);
912 comppad_name = newAV();
913 comppad_name_fill = 0;
914 min_intro_pending = 0;
917 av_store(comppad_name, 0, newSVpv("@_", 2));
918 curpad[0] = (SV*)newAV();
919 SvPADMY_on(curpad[0]); /* XXX Needed? */
921 New(666, CvMUTEXP(compcv), 1, perl_mutex);
922 MUTEX_INIT(CvMUTEXP(compcv));
923 #endif /* USE_THREADS */
925 comppadlist = newAV();
926 AvREAL_off(comppadlist);
927 av_store(comppadlist, 0, (SV*)comppad_name);
928 av_store(comppadlist, 1, (SV*)comppad);
929 CvPADLIST(compcv) = comppadlist;
931 boot_core_UNIVERSAL();
933 (*xsinit)(); /* in case linked C routines want magical variables */
934 #if defined(VMS) || defined(WIN32)
938 #if defined(DEBUGGING) && defined(USE_THREADS) && defined(__linux__)
939 DEBUG_L(signal(SIGSEGV, (void(*)(int))catch_sigsegv););
942 init_predump_symbols();
944 init_postdump_symbols(argc,argv,env);
948 /* now parse the script */
951 if (yyparse() || error_count) {
953 croak("%s had compilation errors.\n", origfilename);
955 croak("Execution of %s aborted due to compilation errors.\n",
959 curcop->cop_line = 0;
963 (void)UNLINK(e_tmpname);
968 /* now that script is parsed, we can modify record separator */
970 rs = SvREFCNT_inc(nrs);
972 sv_setsv(*av_fetch(thr->magicals, find_thread_magical("/"), FALSE), rs);
974 sv_setsv(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), rs);
975 #endif /* USE_THREADS */
986 if ((s=getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
987 dump_mstats("after compilation:");
998 PerlInterpreter *sv_interp;
1005 if (!(curinterp = sv_interp))
1008 oldscope = scopestack_ix;
1013 cxstack_ix = -1; /* start context stack again */
1016 /* my_exit() was called */
1017 while (scopestack_ix > oldscope)
1020 curstash = defstash;
1022 call_list(oldscope, endav);
1024 if (getenv("PERL_DEBUG_MSTATS"))
1025 dump_mstats("after execution: ");
1028 return STATUS_NATIVE_EXPORT;
1031 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
1036 if (curstack != mainstack) {
1038 SWITCHSTACK(curstack, mainstack);
1043 DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
1044 sawampersand ? "Enabling" : "Omitting"));
1047 DEBUG_x(dump_all());
1048 DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
1050 DEBUG_L(PerlIO_printf(Perl_debug_log, "main thread is 0x%lx\n",
1051 (unsigned long) thr));
1052 #endif /* USE_THREADS */
1055 PerlIO_printf(PerlIO_stderr(), "%s syntax OK\n", origfilename);
1058 if (PERLDB_SINGLE && DBsingle)
1059 sv_setiv(DBsingle, 1);
1061 call_list(oldscope, initav);
1071 else if (main_start) {
1072 CvDEPTH(main_cv) = 1;
1083 perl_get_sv(name, create)
1087 GV* gv = gv_fetchpv(name, create, SVt_PV);
1094 perl_get_av(name, create)
1098 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
1107 perl_get_hv(name, create)
1111 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
1120 perl_get_cv(name, create)
1124 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
1125 if (create && !GvCVu(gv))
1126 return newSUB(start_subparse(FALSE, 0),
1127 newSVOP(OP_CONST, 0, newSVpv(name,0)),
1135 /* Be sure to refetch the stack pointer after calling these routines. */
1138 perl_call_argv(subname, flags, argv)
1140 I32 flags; /* See G_* flags in cop.h */
1141 register char **argv; /* null terminated arg list */
1149 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
1154 return perl_call_pv(subname, flags);
1158 perl_call_pv(subname, flags)
1159 char *subname; /* name of the subroutine */
1160 I32 flags; /* See G_* flags in cop.h */
1162 return perl_call_sv((SV*)perl_get_cv(subname, TRUE), flags);
1166 perl_call_method(methname, flags)
1167 char *methname; /* name of the subroutine */
1168 I32 flags; /* See G_* flags in cop.h */
1175 XPUSHs(sv_2mortal(newSVpv(methname,0)));
1178 return perl_call_sv(*stack_sp--, flags);
1181 /* May be called with any of a CV, a GV, or an SV containing the name. */
1183 perl_call_sv(sv, flags)
1185 I32 flags; /* See G_* flags in cop.h */
1188 LOGOP myop; /* fake syntax tree node */
1194 bool oldcatch = CATCH_GET;
1199 if (flags & G_DISCARD) {
1204 Zero(&myop, 1, LOGOP);
1205 myop.op_next = Nullop;
1206 if (!(flags & G_NOARGS))
1207 myop.op_flags |= OPf_STACKED;
1208 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1209 (flags & G_ARRAY) ? OPf_WANT_LIST :
1214 EXTEND(stack_sp, 1);
1217 oldscope = scopestack_ix;
1219 if (PERLDB_SUB && curstash != debstash
1220 /* Handle first BEGIN of -d. */
1221 && (DBcv || (DBcv = GvCV(DBsub)))
1222 /* Try harder, since this may have been a sighandler, thus
1223 * curstash may be meaningless. */
1224 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != debstash))
1225 op->op_private |= OPpENTERSUB_DB;
1227 if (flags & G_EVAL) {
1228 cLOGOP->op_other = op;
1230 /* we're trying to emulate pp_entertry() here */
1232 register CONTEXT *cx;
1233 I32 gimme = GIMME_V;
1238 push_return(op->op_next);
1239 PUSHBLOCK(cx, CXt_EVAL, stack_sp);
1241 eval_root = op; /* Only needed so that goto works right. */
1244 if (flags & G_KEEPERR)
1259 /* my_exit() was called */
1260 curstash = defstash;
1264 croak("Callback called exit");
1273 stack_sp = stack_base + oldmark;
1274 if (flags & G_ARRAY)
1278 *++stack_sp = &sv_undef;
1286 if (op == (OP*)&myop)
1287 op = pp_entersub(ARGS);
1290 retval = stack_sp - (stack_base + oldmark);
1291 if ((flags & G_EVAL) && !(flags & G_KEEPERR))
1295 if (flags & G_EVAL) {
1296 if (scopestack_ix > oldscope) {
1300 register CONTEXT *cx;
1312 CATCH_SET(oldcatch);
1314 if (flags & G_DISCARD) {
1315 stack_sp = stack_base + oldmark;
1324 /* Eval a string. The G_EVAL flag is always assumed. */
1327 perl_eval_sv(sv, flags)
1329 I32 flags; /* See G_* flags in cop.h */
1332 UNOP myop; /* fake syntax tree node */
1334 I32 oldmark = sp - stack_base;
1341 if (flags & G_DISCARD) {
1349 EXTEND(stack_sp, 1);
1351 oldscope = scopestack_ix;
1353 if (!(flags & G_NOARGS))
1354 myop.op_flags = OPf_STACKED;
1355 myop.op_next = Nullop;
1356 myop.op_type = OP_ENTEREVAL;
1357 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1358 (flags & G_ARRAY) ? OPf_WANT_LIST :
1360 if (flags & G_KEEPERR)
1361 myop.op_flags |= OPf_SPECIAL;
1371 /* my_exit() was called */
1372 curstash = defstash;
1376 croak("Callback called exit");
1385 stack_sp = stack_base + oldmark;
1386 if (flags & G_ARRAY)
1390 *++stack_sp = &sv_undef;
1395 if (op == (OP*)&myop)
1396 op = pp_entereval(ARGS);
1399 retval = stack_sp - (stack_base + oldmark);
1400 if (!(flags & G_KEEPERR))
1405 if (flags & G_DISCARD) {
1406 stack_sp = stack_base + oldmark;
1416 perl_eval_pv(p, croak_on_error)
1422 SV* sv = newSVpv(p, 0);
1425 perl_eval_sv(sv, G_SCALAR);
1432 if (croak_on_error && SvTRUE(errsv))
1433 croak(SvPV(errsv, na));
1438 /* Require a module. */
1444 SV* sv = sv_newmortal();
1445 sv_setpv(sv, "require '");
1448 perl_eval_sv(sv, G_DISCARD);
1452 magicname(sym,name,namlen)
1459 if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
1460 sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
1464 usage(name) /* XXX move this out into a module ? */
1467 /* This message really ought to be max 23 lines.
1468 * Removed -h because the user already knows that opton. Others? */
1470 static char *usage[] = {
1471 "-0[octal] specify record separator (\\0, if no argument)",
1472 "-a autosplit mode with -n or -p (splits $_ into @F)",
1473 "-c check syntax only (runs BEGIN and END blocks)",
1474 "-d[:debugger] run scripts under debugger",
1475 "-D[number/list] set debugging flags (argument is a bit mask or flags)",
1476 "-e 'command' one line of script. Several -e's allowed. Omit [programfile].",
1477 "-F/pattern/ split() pattern for autosplit (-a). The //'s are optional.",
1478 "-i[extension] edit <> files in place (make backup if extension supplied)",
1479 "-Idirectory specify @INC/#include directory (may be used more than once)",
1480 "-l[octal] enable line ending processing, specifies line terminator",
1481 "-[mM][-]module.. executes `use/no module...' before executing your script.",
1482 "-n assume 'while (<>) { ... }' loop around your script",
1483 "-p assume loop like -n but print line also like sed",
1484 "-P run script through C preprocessor before compilation",
1485 "-s enable some switch parsing for switches after script name",
1486 "-S look for the script using PATH environment variable",
1487 "-T turn on tainting checks",
1488 "-u dump core after parsing script",
1489 "-U allow unsafe operations",
1490 "-v print version number and patchlevel of perl",
1491 "-V[:variable] print perl configuration information",
1492 "-w TURN WARNINGS ON FOR COMPILATION OF YOUR SCRIPT. Recommended.",
1493 "-x[directory] strip off text before #!perl line and perhaps cd to directory",
1499 printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
1501 printf("\n %s", *p++);
1504 /* This routine handles any switches that can be given during run */
1517 rschar = scan_oct(s, 4, &numlen);
1519 if (rschar & ~((U8)~0))
1521 else if (!rschar && numlen >= 2)
1522 nrs = newSVpv("", 0);
1525 nrs = newSVpv(&ch, 1);
1531 splitstr = savepv(s + 1);
1545 if (*s == ':' || *s == '=') {
1546 my_setenv("PERL5DB", form("use Devel::%s;", ++s));
1550 perldb = PERLDB_ALL;
1557 if (isALPHA(s[1])) {
1558 static char debopts[] = "psltocPmfrxuLHXD";
1561 for (s++; *s && (d = strchr(debopts,*s)); s++)
1562 debug |= 1 << (d - debopts);
1566 for (s++; isDIGIT(*s); s++) ;
1568 debug |= 0x80000000;
1570 warn("Recompile perl with -DDEBUGGING to use -D switch\n");
1571 for (s++; isALNUM(*s); s++) ;
1581 inplace = savepv(s+1);
1583 for (s = inplace; *s && !isSPACE(*s); s++) ;
1587 case 'I': /* -I handled both here and in parse_perl() */
1590 while (*s && isSPACE(*s))
1594 for (e = s; *e && !isSPACE(*e); e++) ;
1595 p = savepvn(s, e-s);
1601 croak("No space allowed after -I");
1611 *ors = scan_oct(s, 3 + (*s == '0'), &numlen);
1621 ors = SvPV(nrs, orslen);
1622 ors = savepvn(ors, orslen);
1626 forbid_setid("-M"); /* XXX ? */
1629 forbid_setid("-m"); /* XXX ? */
1634 /* -M-foo == 'no foo' */
1635 if (*s == '-') { use = "no "; ++s; }
1636 sv = newSVpv(use,0);
1638 /* We allow -M'Module qw(Foo Bar)' */
1639 while(isALNUM(*s) || *s==':') ++s;
1641 sv_catpv(sv, start);
1642 if (*(start-1) == 'm') {
1644 croak("Can't use '%c' after -mname", *s);
1645 sv_catpv( sv, " ()");
1648 sv_catpvn(sv, start, s-start);
1649 sv_catpv(sv, " split(/,/,q{");
1654 if (preambleav == NULL)
1655 preambleav = newAV();
1656 av_push(preambleav, sv);
1659 croak("No space allowed after -%c", *(s-1));
1676 croak("Too late for \"-T\" option");
1688 #if defined(SUBVERSION) && SUBVERSION > 0
1689 printf("\nThis is perl, version 5.%03d_%02d built for %s",
1690 PATCHLEVEL, SUBVERSION, ARCHNAME);
1692 printf("\nThis is perl, version %s built for %s",
1693 patchlevel, ARCHNAME);
1695 #if defined(LOCAL_PATCH_COUNT)
1696 if (LOCAL_PATCH_COUNT > 0)
1697 printf("\n(with %d registered patch%s, see perl -V for more detail)",
1698 LOCAL_PATCH_COUNT, (LOCAL_PATCH_COUNT!=1) ? "es" : "");
1701 printf("\n\nCopyright 1987-1997, Larry Wall\n");
1703 printf("\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
1706 printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n");
1709 printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
1710 "Version 5 port Copyright (c) 1994-1997, Andreas Kaiser, Ilya Zakharevich\n");
1713 printf("atariST series port, ++jrb bammi@cadence.com\n");
1716 Perl may be copied only under the terms of either the Artistic License or the\n\
1717 GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n");
1725 if (s[1] == '-') /* Additional switches on #! line. */
1733 #ifdef ALTERNATE_SHEBANG
1734 case 'S': /* OS/2 needs -S on "extproc" line. */
1742 croak("Can't emulate -%.1s on #! line",s);
1747 /* compliments of Tom Christiansen */
1749 /* unexec() can be found in the Gnu emacs distribution */
1760 prog = newSVpv(BIN_EXP);
1761 sv_catpv(prog, "/perl");
1762 file = newSVpv(origfilename);
1763 sv_catpv(file, ".perldump");
1765 status = unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
1767 PerlIO_printf(PerlIO_stderr(), "unexec of %s into %s failed!\n",
1768 SvPVX(prog), SvPVX(file));
1772 # include <lib$routines.h>
1773 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
1775 ABORT(); /* for use with undump */
1786 /* Note that strtab is a rather special HV. Assumptions are made
1787 about not iterating on it, and not adding tie magic to it.
1788 It is properly deallocated in perl_destruct() */
1790 HvSHAREKEYS_off(strtab); /* mandatory */
1791 Newz(506,((XPVHV*)SvANY(strtab))->xhv_array,
1792 sizeof(HE*) * (((XPVHV*)SvANY(strtab))->xhv_max + 1), char);
1794 curstash = defstash = newHV();
1795 curstname = newSVpv("main",4);
1796 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
1797 SvREFCNT_dec(GvHV(gv));
1798 GvHV(gv) = (HV*)SvREFCNT_inc(defstash);
1800 HvNAME(defstash) = savepv("main");
1801 incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
1803 defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
1804 errsv = newSVpv("", 0);
1806 (void)form("%240s",""); /* Preallocate temp - for immediate signals. */
1807 sv_grow(errsv, 240); /* Preallocate - for immediate signals. */
1808 sv_setpvn(errsv, "", 0);
1809 curstash = defstash;
1810 compiling.cop_stash = defstash;
1811 debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
1812 /* We must init $/ before switches are processed. */
1813 sv_setpvn(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), "\n", 1);
1816 #ifdef CAN_PROTOTYPE
1818 open_script(char *scriptname, bool dosearch, SV *sv)
1821 open_script(scriptname,dosearch,sv)
1828 char *xfound = Nullch;
1829 char *xfailed = Nullch;
1833 #if defined(DOSISH) && !defined(OS2) && !defined(atarist)
1834 # define SEARCH_EXTS ".bat", ".cmd", NULL
1835 # define MAX_EXT_LEN 4
1838 # define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL
1839 # define MAX_EXT_LEN 4
1842 # define SEARCH_EXTS ".pl", ".com", NULL
1843 # define MAX_EXT_LEN 4
1845 /* additional extensions to try in each dir if scriptname not found */
1847 char *ext[] = { SEARCH_EXTS };
1848 int extidx = 0, i = 0;
1849 char *curext = Nullch;
1851 # define MAX_EXT_LEN 0
1855 * If dosearch is true and if scriptname does not contain path
1856 * delimiters, search the PATH for scriptname.
1858 * If SEARCH_EXTS is also defined, will look for each
1859 * scriptname{SEARCH_EXTS} whenever scriptname is not found
1860 * while searching the PATH.
1862 * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
1863 * proceeds as follows:
1865 * + look for ./scriptname{,.foo,.bar}
1866 * + search the PATH for scriptname{,.foo,.bar}
1869 * + look *only* in the PATH for scriptname{,.foo,.bar} (note
1870 * this will not look in '.' if it's not in the PATH)
1875 int hasdir, idx = 0, deftypes = 1;
1878 hasdir = (strpbrk(scriptname,":[</") != Nullch) ;
1879 /* The first time through, just add SEARCH_EXTS to whatever we
1880 * already have, so we can check for default file types. */
1882 (!hasdir && my_trnlnm("DCL$PATH",tokenbuf,idx++)) )
1888 if ((strlen(tokenbuf) + strlen(scriptname)
1889 + MAX_EXT_LEN) >= sizeof tokenbuf)
1890 continue; /* don't search dir with too-long name */
1891 strcat(tokenbuf, scriptname);
1895 if (strEQ(scriptname, "-"))
1897 if (dosearch) { /* Look in '.' first. */
1898 char *cur = scriptname;
1900 if ((curext = strrchr(scriptname,'.'))) /* possible current ext */
1902 if (strEQ(ext[i++],curext)) {
1903 extidx = -1; /* already has an ext */
1908 DEBUG_p(PerlIO_printf(Perl_debug_log,
1909 "Looking for %s\n",cur));
1910 if (Stat(cur,&statbuf) >= 0) {
1918 if (cur == scriptname) {
1919 len = strlen(scriptname);
1920 if (len+MAX_EXT_LEN+1 >= sizeof(tokenbuf))
1922 cur = strcpy(tokenbuf, scriptname);
1924 } while (extidx >= 0 && ext[extidx] /* try an extension? */
1925 && strcpy(tokenbuf+len, ext[extidx++]));
1930 if (dosearch && !strchr(scriptname, '/')
1932 && !strchr(scriptname, '\\')
1934 && (s = getenv("PATH"))) {
1937 bufend = s + strlen(s);
1938 while (s < bufend) {
1939 #if defined(atarist) || defined(DOSISH)
1944 && *s != ';'; len++, s++) {
1945 if (len < sizeof tokenbuf)
1948 if (len < sizeof tokenbuf)
1949 tokenbuf[len] = '\0';
1950 #else /* ! (atarist || DOSISH) */
1951 s = delimcpy(tokenbuf, tokenbuf + sizeof tokenbuf, s, bufend,
1954 #endif /* ! (atarist || DOSISH) */
1957 if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tokenbuf)
1958 continue; /* don't search dir with too-long name */
1960 #if defined(atarist) || defined(DOSISH)
1961 && tokenbuf[len - 1] != '/'
1962 && tokenbuf[len - 1] != '\\'
1965 tokenbuf[len++] = '/';
1966 if (len == 2 && tokenbuf[0] == '.')
1968 (void)strcpy(tokenbuf + len, scriptname);
1972 len = strlen(tokenbuf);
1973 if (extidx > 0) /* reset after previous loop */
1977 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tokenbuf));
1978 retval = Stat(tokenbuf,&statbuf);
1980 } while ( retval < 0 /* not there */
1981 && extidx>=0 && ext[extidx] /* try an extension? */
1982 && strcpy(tokenbuf+len, ext[extidx++])
1987 if (S_ISREG(statbuf.st_mode)
1988 && cando(S_IRUSR,TRUE,&statbuf)
1990 && cando(S_IXUSR,TRUE,&statbuf)
1994 xfound = tokenbuf; /* bingo! */
1998 xfailed = savepv(tokenbuf);
2001 if (!xfound && !seen_dot && !xfailed && (Stat(scriptname,&statbuf) < 0))
2003 seen_dot = 1; /* Disable message. */
2005 croak("Can't %s %s%s%s",
2006 (xfailed ? "execute" : "find"),
2007 (xfailed ? xfailed : scriptname),
2008 (xfailed ? "" : " on PATH"),
2009 (xfailed || seen_dot) ? "" : ", '.' not in PATH");
2012 scriptname = xfound;
2015 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
2016 char *s = scriptname + 8;
2025 origfilename = savepv(e_tmpname ? "-e" : scriptname);
2026 curcop->cop_filegv = gv_fetchfile(origfilename);
2027 if (strEQ(origfilename,"-"))
2029 if (fdscript >= 0) {
2030 rsfp = PerlIO_fdopen(fdscript,"r");
2031 #if defined(HAS_FCNTL) && defined(F_SETFD)
2033 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
2036 else if (preprocess) {
2037 char *cpp_cfg = CPPSTDIN;
2038 SV *cpp = NEWSV(0,0);
2039 SV *cmd = NEWSV(0,0);
2041 if (strEQ(cpp_cfg, "cppstdin"))
2042 sv_catpvf(cpp, "%s/", BIN_EXP);
2043 sv_catpv(cpp, cpp_cfg);
2046 sv_catpv(sv,PRIVLIB_EXP);
2050 sed %s -e \"/^[^#]/b\" \
2051 -e \"/^#[ ]*include[ ]/b\" \
2052 -e \"/^#[ ]*define[ ]/b\" \
2053 -e \"/^#[ ]*if[ ]/b\" \
2054 -e \"/^#[ ]*ifdef[ ]/b\" \
2055 -e \"/^#[ ]*ifndef[ ]/b\" \
2056 -e \"/^#[ ]*else/b\" \
2057 -e \"/^#[ ]*elif[ ]/b\" \
2058 -e \"/^#[ ]*undef[ ]/b\" \
2059 -e \"/^#[ ]*endif/b\" \
2062 (doextract ? "-e \"1,/^#/d\n\"" : ""),
2065 %s %s -e '/^[^#]/b' \
2066 -e '/^#[ ]*include[ ]/b' \
2067 -e '/^#[ ]*define[ ]/b' \
2068 -e '/^#[ ]*if[ ]/b' \
2069 -e '/^#[ ]*ifdef[ ]/b' \
2070 -e '/^#[ ]*ifndef[ ]/b' \
2071 -e '/^#[ ]*else/b' \
2072 -e '/^#[ ]*elif[ ]/b' \
2073 -e '/^#[ ]*undef[ ]/b' \
2074 -e '/^#[ ]*endif/b' \
2082 (doextract ? "-e '1,/^#/d\n'" : ""),
2084 scriptname, cpp, sv, CPPMINUS);
2086 #ifdef IAMSUID /* actually, this is caught earlier */
2087 if (euid != uid && !euid) { /* if running suidperl */
2089 (void)seteuid(uid); /* musn't stay setuid root */
2092 (void)setreuid((Uid_t)-1, uid);
2094 #ifdef HAS_SETRESUID
2095 (void)setresuid((Uid_t)-1, uid, (Uid_t)-1);
2101 if (geteuid() != uid)
2102 croak("Can't do seteuid!\n");
2104 #endif /* IAMSUID */
2105 rsfp = my_popen(SvPVX(cmd), "r");
2109 else if (!*scriptname) {
2110 forbid_setid("program input from stdin");
2111 rsfp = PerlIO_stdin();
2114 rsfp = PerlIO_open(scriptname,"r");
2115 #if defined(HAS_FCNTL) && defined(F_SETFD)
2117 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
2125 #ifndef IAMSUID /* in case script is not readable before setuid */
2126 if (euid && Stat(SvPVX(GvSV(curcop->cop_filegv)),&statbuf) >= 0 &&
2127 statbuf.st_mode & (S_ISUID|S_ISGID)) {
2129 execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
2130 croak("Can't do setuid\n");
2134 croak("Can't open perl script \"%s\": %s\n",
2135 SvPVX(GvSV(curcop->cop_filegv)), Strerror(errno));
2140 validate_suid(validarg, scriptname)
2146 /* do we need to emulate setuid on scripts? */
2148 /* This code is for those BSD systems that have setuid #! scripts disabled
2149 * in the kernel because of a security problem. Merely defining DOSUID
2150 * in perl will not fix that problem, but if you have disabled setuid
2151 * scripts in the kernel, this will attempt to emulate setuid and setgid
2152 * on scripts that have those now-otherwise-useless bits set. The setuid
2153 * root version must be called suidperl or sperlN.NNN. If regular perl
2154 * discovers that it has opened a setuid script, it calls suidperl with
2155 * the same argv that it had. If suidperl finds that the script it has
2156 * just opened is NOT setuid root, it sets the effective uid back to the
2157 * uid. We don't just make perl setuid root because that loses the
2158 * effective uid we had before invoking perl, if it was different from the
2161 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
2162 * be defined in suidperl only. suidperl must be setuid root. The
2163 * Configure script will set this up for you if you want it.
2170 if (Fstat(PerlIO_fileno(rsfp),&statbuf) < 0) /* normal stat is insecure */
2171 croak("Can't stat script \"%s\"",origfilename);
2172 if (fdscript < 0 && statbuf.st_mode & (S_ISUID|S_ISGID)) {
2176 #ifndef HAS_SETREUID
2177 /* On this access check to make sure the directories are readable,
2178 * there is actually a small window that the user could use to make
2179 * filename point to an accessible directory. So there is a faint
2180 * chance that someone could execute a setuid script down in a
2181 * non-accessible directory. I don't know what to do about that.
2182 * But I don't think it's too important. The manual lies when
2183 * it says access() is useful in setuid programs.
2185 if (access(SvPVX(GvSV(curcop->cop_filegv)),1)) /*double check*/
2186 croak("Permission denied");
2188 /* If we can swap euid and uid, then we can determine access rights
2189 * with a simple stat of the file, and then compare device and
2190 * inode to make sure we did stat() on the same file we opened.
2191 * Then we just have to make sure he or she can execute it.
2194 struct stat tmpstatbuf;
2198 setreuid(euid,uid) < 0
2201 setresuid(euid,uid,(Uid_t)-1) < 0
2204 || getuid() != euid || geteuid() != uid)
2205 croak("Can't swap uid and euid"); /* really paranoid */
2206 if (Stat(SvPVX(GvSV(curcop->cop_filegv)),&tmpstatbuf) < 0)
2207 croak("Permission denied"); /* testing full pathname here */
2208 if (tmpstatbuf.st_dev != statbuf.st_dev ||
2209 tmpstatbuf.st_ino != statbuf.st_ino) {
2210 (void)PerlIO_close(rsfp);
2211 if (rsfp = my_popen("/bin/mail root","w")) { /* heh, heh */
2213 "User %ld tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
2214 (Filename of set-id script was %s, uid %ld gid %ld.)\n\nSincerely,\nperl\n",
2215 (long)uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
2216 (long)statbuf.st_dev, (long)statbuf.st_ino,
2217 SvPVX(GvSV(curcop->cop_filegv)),
2218 (long)statbuf.st_uid, (long)statbuf.st_gid);
2219 (void)my_pclose(rsfp);
2221 croak("Permission denied\n");
2225 setreuid(uid,euid) < 0
2227 # if defined(HAS_SETRESUID)
2228 setresuid(uid,euid,(Uid_t)-1) < 0
2231 || getuid() != uid || geteuid() != euid)
2232 croak("Can't reswap uid and euid");
2233 if (!cando(S_IXUSR,FALSE,&statbuf)) /* can real uid exec? */
2234 croak("Permission denied\n");
2236 #endif /* HAS_SETREUID */
2237 #endif /* IAMSUID */
2239 if (!S_ISREG(statbuf.st_mode))
2240 croak("Permission denied");
2241 if (statbuf.st_mode & S_IWOTH)
2242 croak("Setuid/gid script is writable by world");
2243 doswitches = FALSE; /* -s is insecure in suid */
2245 if (sv_gets(linestr, rsfp, 0) == Nullch ||
2246 strnNE(SvPV(linestr,na),"#!",2) ) /* required even on Sys V */
2247 croak("No #! line");
2248 s = SvPV(linestr,na)+2;
2250 while (!isSPACE(*s)) s++;
2251 for (s2 = s; (s2 > SvPV(linestr,na)+2 &&
2252 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
2253 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
2254 croak("Not a perl script");
2255 while (*s == ' ' || *s == '\t') s++;
2257 * #! arg must be what we saw above. They can invoke it by
2258 * mentioning suidperl explicitly, but they may not add any strange
2259 * arguments beyond what #! says if they do invoke suidperl that way.
2261 len = strlen(validarg);
2262 if (strEQ(validarg," PHOOEY ") ||
2263 strnNE(s,validarg,len) || !isSPACE(s[len]))
2264 croak("Args must match #! line");
2267 if (euid != uid && (statbuf.st_mode & S_ISUID) &&
2268 euid == statbuf.st_uid)
2270 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2271 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2272 #endif /* IAMSUID */
2274 if (euid) { /* oops, we're not the setuid root perl */
2275 (void)PerlIO_close(rsfp);
2278 execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
2280 croak("Can't do setuid\n");
2283 if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid) {
2285 (void)setegid(statbuf.st_gid);
2288 (void)setregid((Gid_t)-1,statbuf.st_gid);
2290 #ifdef HAS_SETRESGID
2291 (void)setresgid((Gid_t)-1,statbuf.st_gid,(Gid_t)-1);
2293 setgid(statbuf.st_gid);
2297 if (getegid() != statbuf.st_gid)
2298 croak("Can't do setegid!\n");
2300 if (statbuf.st_mode & S_ISUID) {
2301 if (statbuf.st_uid != euid)
2303 (void)seteuid(statbuf.st_uid); /* all that for this */
2306 (void)setreuid((Uid_t)-1,statbuf.st_uid);
2308 #ifdef HAS_SETRESUID
2309 (void)setresuid((Uid_t)-1,statbuf.st_uid,(Uid_t)-1);
2311 setuid(statbuf.st_uid);
2315 if (geteuid() != statbuf.st_uid)
2316 croak("Can't do seteuid!\n");
2318 else if (uid) { /* oops, mustn't run as root */
2320 (void)seteuid((Uid_t)uid);
2323 (void)setreuid((Uid_t)-1,(Uid_t)uid);
2325 #ifdef HAS_SETRESUID
2326 (void)setresuid((Uid_t)-1,(Uid_t)uid,(Uid_t)-1);
2332 if (geteuid() != uid)
2333 croak("Can't do seteuid!\n");
2336 if (!cando(S_IXUSR,TRUE,&statbuf))
2337 croak("Permission denied\n"); /* they can't do this */
2340 else if (preprocess)
2341 croak("-P not allowed for setuid/setgid script\n");
2342 else if (fdscript >= 0)
2343 croak("fd script not allowed in suidperl\n");
2345 croak("Script is not setuid/setgid in suidperl\n");
2347 /* We absolutely must clear out any saved ids here, so we */
2348 /* exec the real perl, substituting fd script for scriptname. */
2349 /* (We pass script name as "subdir" of fd, which perl will grok.) */
2350 PerlIO_rewind(rsfp);
2351 lseek(PerlIO_fileno(rsfp),(Off_t)0,0); /* just in case rewind didn't */
2352 for (which = 1; origargv[which] && origargv[which] != scriptname; which++) ;
2353 if (!origargv[which])
2354 croak("Permission denied");
2355 origargv[which] = savepv(form("/dev/fd/%d/%s",
2356 PerlIO_fileno(rsfp), origargv[which]));
2357 #if defined(HAS_FCNTL) && defined(F_SETFD)
2358 fcntl(PerlIO_fileno(rsfp),F_SETFD,0); /* ensure no close-on-exec */
2360 execv(form("%s/perl%s", BIN_EXP, patchlevel), origargv); /* try again */
2361 croak("Can't do setuid\n");
2362 #endif /* IAMSUID */
2364 if (euid != uid || egid != gid) { /* (suidperl doesn't exist, in fact) */
2365 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
2367 Fstat(PerlIO_fileno(rsfp),&statbuf); /* may be either wrapped or real suid */
2368 if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
2370 (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
2373 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2374 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2375 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
2376 /* not set-id, must be wrapped */
2384 register char *s, *s2;
2386 /* skip forward in input to the real script? */
2390 if ((s = sv_gets(linestr, rsfp, 0)) == Nullch)
2391 croak("No Perl script found in input\n");
2392 if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
2393 PerlIO_ungetc(rsfp, '\n'); /* to keep line count right */
2395 while (*s && !(isSPACE (*s) || *s == '#')) s++;
2397 while (*s == ' ' || *s == '\t') s++;
2399 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
2400 if (strnEQ(s2-4,"perl",4))
2402 while (s = moreswitches(s)) ;
2404 if (cddir && chdir(cddir) < 0)
2405 croak("Can't chdir to %s",cddir);
2413 uid = (int)getuid();
2414 euid = (int)geteuid();
2415 gid = (int)getgid();
2416 egid = (int)getegid();
2421 tainting |= (uid && (euid != uid || egid != gid));
2429 croak("No %s allowed while running setuid", s);
2431 croak("No %s allowed while running setgid", s);
2438 curstash = debstash;
2439 dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
2441 DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
2442 DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
2443 DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
2444 DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
2445 sv_setiv(DBsingle, 0);
2446 DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
2447 sv_setiv(DBtrace, 0);
2448 DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
2449 sv_setiv(DBsignal, 0);
2450 curstash = defstash;
2458 mainstack = curstack; /* remember in case we switch stacks */
2459 AvREAL_off(curstack); /* not a real array */
2460 av_extend(curstack,127);
2462 stack_base = AvARRAY(curstack);
2463 stack_sp = stack_base;
2464 stack_max = stack_base + 127;
2466 cxstack_max = 8192 / sizeof(CONTEXT) - 2; /* Use most of 8K. */
2467 New(50,cxstack,cxstack_max + 1,CONTEXT);
2470 New(50,tmps_stack,128,SV*);
2476 * The following stacks almost certainly should be per-interpreter,
2477 * but for now they're not. XXX
2481 markstack_ptr = markstack;
2483 New(54,markstack,64,I32);
2484 markstack_ptr = markstack;
2485 markstack_max = markstack + 64;
2491 New(54,scopestack,32,I32);
2493 scopestack_max = 32;
2499 New(54,savestack,128,ANY);
2501 savestack_max = 128;
2507 New(54,retstack,16,OP*);
2518 Safefree(tmps_stack);
2525 static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
2534 subname = newSVpv("main",4);
2538 init_predump_symbols()
2545 sv_setpvn(*av_fetch(thr->magicals,find_thread_magical("\""),FALSE)," ", 1);
2547 sv_setpvn(GvSV(gv_fetchpv("\"", TRUE, SVt_PV)), " ", 1);
2548 #endif /* USE_THREADS */
2550 stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
2551 GvMULTI_on(stdingv);
2552 IoIFP(GvIOp(stdingv)) = PerlIO_stdin();
2553 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
2555 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(stdingv));
2557 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
2559 IoOFP(GvIOp(tmpgv)) = IoIFP(GvIOp(tmpgv)) = PerlIO_stdout();
2561 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
2563 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(defoutgv));
2565 othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
2566 GvMULTI_on(othergv);
2567 IoOFP(GvIOp(othergv)) = IoIFP(GvIOp(othergv)) = PerlIO_stderr();
2568 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
2570 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(othergv));
2572 statname = NEWSV(66,0); /* last filename we did stat on */
2575 osname = savepv(OSNAME);
2579 init_postdump_symbols(argc,argv,env)
2581 register char **argv;
2582 register char **env;
2589 argc--,argv++; /* skip name of script */
2591 for (; argc > 0 && **argv == '-'; argc--,argv++) {
2594 if (argv[0][1] == '-') {
2598 if (s = strchr(argv[0], '=')) {
2600 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
2603 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
2606 toptarget = NEWSV(0,0);
2607 sv_upgrade(toptarget, SVt_PVFM);
2608 sv_setpvn(toptarget, "", 0);
2609 bodytarget = NEWSV(0,0);
2610 sv_upgrade(bodytarget, SVt_PVFM);
2611 sv_setpvn(bodytarget, "", 0);
2612 formtarget = bodytarget;
2615 if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
2616 sv_setpv(GvSV(tmpgv),origfilename);
2617 magicname("0", "0", 1);
2619 if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
2620 sv_setpv(GvSV(tmpgv),origargv[0]);
2621 if (argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
2623 (void)gv_AVadd(argvgv);
2624 av_clear(GvAVn(argvgv));
2625 for (; argc > 0; argc--,argv++) {
2626 av_push(GvAVn(argvgv),newSVpv(argv[0],0));
2629 if (envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
2633 hv_magic(hv, envgv, 'E');
2634 #ifndef VMS /* VMS doesn't have environ array */
2635 /* Note that if the supplied env parameter is actually a copy
2636 of the global environ then it may now point to free'd memory
2637 if the environment has been modified since. To avoid this
2638 problem we treat env==NULL as meaning 'use the default'
2643 environ[0] = Nullch;
2644 for (; *env; env++) {
2645 if (!(s = strchr(*env,'=')))
2651 sv = newSVpv(s--,0);
2652 (void)hv_store(hv, *env, s - *env, sv, 0);
2654 #if defined(__BORLANDC__) && defined(USE_WIN32_RTL_ENV)
2655 /* Sins of the RTL. See note in my_setenv(). */
2656 (void)putenv(savepv(*env));
2660 #ifdef DYNAMIC_ENV_FETCH
2661 HvNAME(hv) = savepv(ENV_HV_NAME);
2665 if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
2666 sv_setiv(GvSV(tmpgv), (IV)getpid());
2675 s = getenv("PERL5LIB");
2679 incpush(getenv("PERLLIB"), FALSE);
2681 /* Treat PERL5?LIB as a possible search list logical name -- the
2682 * "natural" VMS idiom for a Unix path string. We allow each
2683 * element to be a set of |-separated directories for compatibility.
2687 if (my_trnlnm("PERL5LIB",buf,0))
2688 do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
2690 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE);
2694 /* Use the ~-expanded versions of APPLLIB (undocumented),
2695 ARCHLIB PRIVLIB SITEARCH SITELIB and OLDARCHLIB
2698 incpush(APPLLIB_EXP, FALSE);
2702 incpush(ARCHLIB_EXP, FALSE);
2705 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
2707 incpush(PRIVLIB_EXP, FALSE);
2710 incpush(SITEARCH_EXP, FALSE);
2713 incpush(SITELIB_EXP, FALSE);
2715 #ifdef OLDARCHLIB_EXP /* 5.00[01] compatibility */
2716 incpush(OLDARCHLIB_EXP, FALSE);
2720 incpush(".", FALSE);
2724 # define PERLLIB_SEP ';'
2727 # define PERLLIB_SEP '|'
2729 # define PERLLIB_SEP ':'
2732 #ifndef PERLLIB_MANGLE
2733 # define PERLLIB_MANGLE(s,n) (s)
2737 incpush(p, addsubdirs)
2741 SV *subdir = Nullsv;
2742 static char *archpat_auto;
2749 if (!archpat_auto) {
2750 STRLEN len = (sizeof(ARCHNAME) + strlen(patchlevel)
2751 + sizeof("//auto"));
2752 New(55, archpat_auto, len, char);
2753 sprintf(archpat_auto, "/%s/%s/auto", ARCHNAME, patchlevel);
2755 for (len = sizeof(ARCHNAME) + 2;
2756 archpat_auto[len] != '\0' && archpat_auto[len] != '/'; len++)
2757 if (archpat_auto[len] == '.') archpat_auto[len] = '_';
2762 /* Break at all separators */
2764 SV *libdir = newSV(0);
2767 /* skip any consecutive separators */
2768 while ( *p == PERLLIB_SEP ) {
2769 /* Uncomment the next line for PATH semantics */
2770 /* av_push(GvAVn(incgv), newSVpv(".", 1)); */
2774 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
2775 sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
2780 sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
2781 p = Nullch; /* break out */
2785 * BEFORE pushing libdir onto @INC we may first push version- and
2786 * archname-specific sub-directories.
2789 struct stat tmpstatbuf;
2794 if ((unix = tounixspec_ts(SvPV(libdir,na),Nullch)) != Nullch) {
2796 while (unix[len-1] == '/') len--; /* Cosmetic */
2797 sv_usepvn(libdir,unix,len);
2800 PerlIO_printf(PerlIO_stderr(),
2801 "Failed to unixify @INC element \"%s\"\n",
2804 /* .../archname/version if -d .../archname/version/auto */
2805 sv_setsv(subdir, libdir);
2806 sv_catpv(subdir, archpat_auto);
2807 if (Stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2808 S_ISDIR(tmpstatbuf.st_mode))
2809 av_push(GvAVn(incgv),
2810 newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2812 /* .../archname if -d .../archname/auto */
2813 sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME),
2814 strlen(patchlevel) + 1, "", 0);
2815 if (Stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2816 S_ISDIR(tmpstatbuf.st_mode))
2817 av_push(GvAVn(incgv),
2818 newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2821 /* finally push this lib directory on the end of @INC */
2822 av_push(GvAVn(incgv), libdir);
2825 SvREFCNT_dec(subdir);
2829 call_list(oldscope, list)
2834 line_t oldline = curcop->cop_line;
2839 while (AvFILL(list) >= 0) {
2840 CV *cv = (CV*)av_shift(list);
2848 perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
2849 (void)SvPV(errsv, len);
2852 curcop = &compiling;
2853 curcop->cop_line = oldline;
2854 if (list == beginav)
2855 sv_catpv(errsv, "BEGIN failed--compilation aborted");
2857 sv_catpv(errsv, "END failed--cleanup aborted");
2858 while (scopestack_ix > oldscope)
2860 croak("%s", SvPVX(errsv));
2868 /* my_exit() was called */
2869 while (scopestack_ix > oldscope)
2872 curstash = defstash;
2874 call_list(oldscope, endav);
2876 curcop = &compiling;
2877 curcop->cop_line = oldline;
2879 if (list == beginav)
2880 croak("BEGIN failed--compilation aborted");
2882 croak("END failed--cleanup aborted");
2888 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
2893 curcop = &compiling;
2894 curcop->cop_line = oldline;
2908 DEBUG_L(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
2909 thr, (unsigned long) status));
2910 #endif /* USE_THREADS */
2919 STATUS_NATIVE_SET(status);
2929 if (vaxc$errno & 1) {
2930 if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
2931 STATUS_NATIVE_SET(44);
2934 if (!vaxc$errno && errno) /* unlikely */
2935 STATUS_NATIVE_SET(44);
2937 STATUS_NATIVE_SET(vaxc$errno);
2941 STATUS_POSIX_SET(errno);
2942 else if (STATUS_POSIX == 0)
2943 STATUS_POSIX_SET(255);
2952 register CONTEXT *cx;
2961 (void)UNLINK(e_tmpname);
2962 Safefree(e_tmpname);
2966 if (cxstack_ix >= 0) {