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;
110 #if defined(USE_THREADS) && !defined(FAKE_THREADS)
114 if (!(curinterp = sv_interp))
118 Zero(sv_interp, 1, PerlInterpreter);
121 /* Init the real globals (and main thread)? */
125 New(53, thr, 1, struct thread);
126 MUTEX_INIT(&malloc_mutex);
127 MUTEX_INIT(&sv_mutex);
128 MUTEX_INIT(&eval_mutex);
129 COND_INIT(&eval_cond);
130 MUTEX_INIT(&threads_mutex);
131 COND_INIT(&nthreads_cond);
135 thr->flags = THRf_R_JOINABLE;
136 MUTEX_INIT(&thr->mutex);
141 thr->next_run = thr->prev_run = thr;
146 self = pthread_self();
147 if (pthread_key_create(&thr_key, 0))
148 croak("panic: pthread_key_create");
149 if (pthread_setspecific(thr_key, (void *) thr))
150 croak("panic: pthread_setspecific");
151 #endif /* FAKE_THREADS */
152 #endif /* USE_THREADS */
154 linestr = NEWSV(65,80);
155 sv_upgrade(linestr,SVt_PVIV);
157 if (!SvREADONLY(&sv_undef)) {
158 SvREADONLY_on(&sv_undef);
162 SvREADONLY_on(&sv_no);
164 sv_setpv(&sv_yes,Yes);
166 SvREADONLY_on(&sv_yes);
169 nrs = newSVpv("\n", 1);
170 rs = SvREFCNT_inc(nrs);
172 sighandlerp = sighandler;
177 * There is no way we can refer to them from Perl so close them to save
178 * space. The other alternative would be to provide STDAUX and STDPRN
181 (void)fclose(stdaux);
182 (void)fclose(stdprn);
188 perl_destruct_level = 1;
190 if(perl_destruct_level > 0)
196 start_env.je_prev = NULL;
197 start_env.je_ret = -1;
198 start_env.je_mustcatch = TRUE;
199 top_env = &start_env;
202 SET_NUMERIC_STANDARD();
203 #if defined(SUBVERSION) && SUBVERSION > 0
204 sprintf(patchlevel, "%7.5f", (double) 5
205 + ((double) PATCHLEVEL / (double) 1000)
206 + ((double) SUBVERSION / (double) 100000));
208 sprintf(patchlevel, "%5.3f", (double) 5 +
209 ((double) PATCHLEVEL / (double) 1000));
212 #if defined(LOCAL_PATCH_COUNT)
213 localpatches = local_patches; /* For possible -v */
216 PerlIO_init(); /* Hook to IO system */
218 fdpid = newAV(); /* for remembering popen pids by fd */
222 New(51,debname,128,char);
223 New(52,debdelim,128,char);
230 perl_destruct(sv_interp)
231 register PerlInterpreter *sv_interp;
234 int destruct_level; /* 0=none, 1=full, 2=full with checks */
239 if (!(curinterp = sv_interp))
244 /* Join with any remaining non-detached threads */
245 MUTEX_LOCK(&threads_mutex);
246 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
247 "perl_destruct: waiting for %d threads\n",
249 for (t = thr->next; t != thr; t = t->next) {
250 MUTEX_LOCK(&t->mutex);
251 switch (ThrSTATE(t)) {
254 ThrSETSTATE(t, THRf_DEAD);
255 MUTEX_UNLOCK(&t->mutex);
257 MUTEX_UNLOCK(&threads_mutex);
258 if (pthread_join(t->Tself, (void**)&av))
259 croak("panic: pthread_join failed during global destruction");
260 SvREFCNT_dec((SV*)av);
265 /* Now wait for the thread count nthreads to drop to one */
268 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
269 "perl_destruct: waiting for %d threads\n",
271 COND_WAIT(&nthreads_cond, &threads_mutex);
273 /* At this point, we're the last thread */
274 MUTEX_UNLOCK(&threads_mutex);
275 DEBUG_L(PerlIO_printf(PerlIO_stderr(), "perl_destruct: armageddon has arrived\n"));
276 MUTEX_DESTROY(&threads_mutex);
277 COND_DESTROY(&nthreads_cond);
278 #endif /* !defined(FAKE_THREADS) */
279 #endif /* USE_THREADS */
281 destruct_level = perl_destruct_level;
285 if (s = getenv("PERL_DESTRUCT_LEVEL")) {
287 if (destruct_level < i)
296 /* We must account for everything. */
298 /* Destroy the main CV and syntax tree */
300 curpad = AvARRAY(comppad);
305 SvREFCNT_dec(main_cv);
310 * Try to destruct global references. We do this first so that the
311 * destructors and destructees still exist. Some sv's might remain.
312 * Non-referenced objects are on their own.
319 /* unhook hooks which will soon be, or use, destroyed data */
320 SvREFCNT_dec(warnhook);
322 SvREFCNT_dec(diehook);
324 SvREFCNT_dec(parsehook);
327 if (destruct_level == 0){
329 DEBUG_P(debprofdump());
331 /* The exit() function will do everything that needs doing. */
335 /* loosen bonds of global variables */
338 (void)PerlIO_close(rsfp);
342 /* Filters for program text */
343 SvREFCNT_dec(rsfp_filters);
344 rsfp_filters = Nullav;
356 sawampersand = FALSE; /* must save all match strings */
357 sawstudy = FALSE; /* do fbm_instr on all strings */
372 /* magical thingies */
374 Safefree(ofs); /* $, */
377 Safefree(ors); /* $\ */
380 SvREFCNT_dec(nrs); /* $\ helper */
383 multiline = 0; /* $* */
385 SvREFCNT_dec(statname);
389 /* defgv, aka *_ should be taken care of elsewhere */
391 #if 0 /* just about all regexp stuff, seems to be ok */
393 /* shortcuts to regexp stuff */
398 SAVEFREEOP(oldlastpm); /* for saving regexp context during debugger */
400 regprecomp = NULL; /* uncompiled string. */
401 regparse = NULL; /* Input-scan pointer. */
402 regxend = NULL; /* End of input for compile */
403 regnpar = 0; /* () count. */
404 regcode = NULL; /* Code-emit pointer; ®dummy = don't. */
405 regsize = 0; /* Code size. */
406 regnaughty = 0; /* How bad is this pattern? */
407 regsawback = 0; /* Did we see \1, ...? */
409 reginput = NULL; /* String-input pointer. */
410 regbol = NULL; /* Beginning of input, for ^ check. */
411 regeol = NULL; /* End of input, for $ check. */
412 regstartp = (char **)NULL; /* Pointer to startp array. */
413 regendp = (char **)NULL; /* Ditto for endp. */
414 reglastparen = 0; /* Similarly for lastparen. */
415 regtill = NULL; /* How far we are required to go. */
416 regflags = 0; /* are we folding, multilining? */
417 regprev = (char)NULL; /* char before regbol, \n if none */
421 /* clean up after study() */
422 SvREFCNT_dec(lastscream);
424 Safefree(screamfirst);
426 Safefree(screamnext);
429 /* startup and shutdown function lists */
430 SvREFCNT_dec(beginav);
432 SvREFCNT_dec(initav);
437 /* temp stack during pp_sort() */
438 SvREFCNT_dec(sortstack);
441 /* shortcuts just get cleared */
451 /* reset so print() ends up where we expect */
454 /* Prepare to destruct main symbol table. */
461 if (destruct_level >= 2) {
462 if (scopestack_ix != 0)
463 warn("Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
464 (long)scopestack_ix);
465 if (savestack_ix != 0)
466 warn("Unbalanced saves: %ld more saves than restores\n",
468 if (tmps_floor != -1)
469 warn("Unbalanced tmps: %ld more allocs than frees\n",
470 (long)tmps_floor + 1);
471 if (cxstack_ix != -1)
472 warn("Unbalanced context: %ld more PUSHes than POPs\n",
473 (long)cxstack_ix + 1);
476 /* Now absolutely destruct everything, somehow or other, loops or no. */
478 SvFLAGS(strtab) |= SVTYPEMASK; /* don't clean out strtab now */
479 while (sv_count != 0 && sv_count != last_sv_count) {
480 last_sv_count = sv_count;
483 SvFLAGS(strtab) &= ~SVTYPEMASK;
484 SvFLAGS(strtab) |= SVt_PVHV;
486 /* Destruct the global string table. */
488 /* Yell and reset the HeVAL() slots that are still holding refcounts,
489 * so that sv_free() won't fail on them.
498 array = HvARRAY(strtab);
502 warn("Unbalanced string table refcount: (%d) for \"%s\"",
503 HeVAL(hent) - Nullsv, HeKEY(hent));
504 HeVAL(hent) = Nullsv;
514 SvREFCNT_dec(strtab);
517 warn("Scalars leaked: %ld\n", (long)sv_count);
521 /* No SVs have survived, need to clean out */
525 Safefree(origfilename);
527 hints = 0; /* Reset hints. Should hints be per-interpreter ? */
529 DEBUG_P(debprofdump());
531 MUTEX_DESTROY(&sv_mutex);
532 MUTEX_DESTROY(&malloc_mutex);
533 MUTEX_DESTROY(&eval_mutex);
534 COND_DESTROY(&eval_cond);
535 #endif /* USE_THREADS */
537 /* As the absolutely last thing, free the non-arena SV for mess() */
540 /* we know that type >= SVt_PV */
542 Safefree(SvPVX(mess_sv));
543 Safefree(SvANY(mess_sv));
551 PerlInterpreter *sv_interp;
553 if (!(curinterp = sv_interp))
559 perl_parse(sv_interp, xsinit, argc, argv, env)
560 PerlInterpreter *sv_interp;
561 void (*xsinit)_((void));
569 char *scriptname = NULL;
570 VOL bool dosearch = FALSE;
577 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
580 croak("suidperl is no longer needed since the kernel can now execute\n\
581 setuid perl scripts securely.\n");
585 if (!(curinterp = sv_interp))
588 #if defined(NeXT) && defined(__DYNAMIC__)
589 _dyld_lookup_and_bind
590 ("__environ", (unsigned long *) &environ_pointer, NULL);
595 #ifndef VMS /* VMS doesn't have environ array */
596 origenviron = environ;
602 /* Come here if running an undumped a.out. */
604 origfilename = savepv(argv[0]);
606 cxstack_ix = -1; /* start label stack again */
608 init_postdump_symbols(argc,argv,env);
613 curpad = AvARRAY(comppad);
618 SvREFCNT_dec(main_cv);
622 oldscope = scopestack_ix;
630 /* my_exit() was called */
631 while (scopestack_ix > oldscope)
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 */
800 if (*++s) { /* catch use of gnu style long options */
801 if (strEQ(s, "version")) {
805 if (strEQ(s, "help")) {
809 croak("Unrecognized switch: --%s (-h will show valid options)",s);
816 croak("Unrecognized switch: -%s (-h will show valid options)",s);
821 if (!tainting && (s = getenv("PERL5OPT"))) {
832 if (!strchr("DIMUdmw", *s))
833 croak("Illegal switch in PERL5OPT: -%c", *s);
839 scriptname = argv[0];
841 if (PerlIO_flush(e_fp) || PerlIO_error(e_fp) || PerlIO_close(e_fp)) {
843 warn("Did you forget to compile with -DMULTIPLICITY?");
845 croak("Can't write to temp file for -e: %s", Strerror(errno));
849 scriptname = e_tmpname;
851 else if (scriptname == Nullch) {
853 if ( isatty(PerlIO_fileno(PerlIO_stdin())) )
861 open_script(scriptname,dosearch,sv);
863 validate_suid(validarg, scriptname);
868 main_cv = compcv = (CV*)NEWSV(1104,0);
869 sv_upgrade((SV *)compcv, SVt_PVCV);
873 av_push(comppad, Nullsv);
874 curpad = AvARRAY(comppad);
875 comppad_name = newAV();
876 comppad_name_fill = 0;
877 min_intro_pending = 0;
880 av_store(comppad_name, 0, newSVpv("@_", 2));
881 curpad[0] = (SV*)newAV();
882 SvPADMY_on(curpad[0]); /* XXX Needed? */
884 New(666, CvMUTEXP(compcv), 1, perl_mutex);
885 MUTEX_INIT(CvMUTEXP(compcv));
886 #endif /* USE_THREADS */
888 comppadlist = newAV();
889 AvREAL_off(comppadlist);
890 av_store(comppadlist, 0, (SV*)comppad_name);
891 av_store(comppadlist, 1, (SV*)comppad);
892 CvPADLIST(compcv) = comppadlist;
894 boot_core_UNIVERSAL();
896 (*xsinit)(); /* in case linked C routines want magical variables */
897 #if defined(VMS) || defined(WIN32)
901 #if defined(DEBUGGING) && defined(USE_THREADS) && defined(__linux__)
902 DEBUG_L(signal(SIGSEGV, (void(*)(int))catch_sigsegv););
905 init_predump_symbols();
907 init_postdump_symbols(argc,argv,env);
911 /* now parse the script */
914 if (yyparse() || error_count) {
916 croak("%s had compilation errors.\n", origfilename);
918 croak("Execution of %s aborted due to compilation errors.\n",
922 curcop->cop_line = 0;
926 (void)UNLINK(e_tmpname);
931 /* now that script is parsed, we can modify record separator */
933 rs = SvREFCNT_inc(nrs);
934 sv_setsv(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), rs);
946 if ((s=getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
947 dump_mstats("after compilation:");
958 PerlInterpreter *sv_interp;
965 if (!(curinterp = sv_interp))
968 oldscope = scopestack_ix;
973 cxstack_ix = -1; /* start context stack again */
976 /* my_exit() was called */
977 while (scopestack_ix > oldscope)
982 call_list(oldscope, endav);
984 if (getenv("PERL_DEBUG_MSTATS"))
985 dump_mstats("after execution: ");
988 return STATUS_NATIVE_EXPORT;
991 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
996 if (curstack != mainstack) {
998 SWITCHSTACK(curstack, mainstack);
1003 DEBUG_r(PerlIO_printf(PerlIO_stderr(), "%s $` $& $' support.\n",
1004 sawampersand ? "Enabling" : "Omitting"));
1007 DEBUG_x(dump_all());
1008 DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
1010 DEBUG_L(PerlIO_printf(Perl_debug_log, "main thread is 0x%lx\n",
1011 (unsigned long) thr));
1012 #endif /* USE_THREADS */
1015 PerlIO_printf(PerlIO_stderr(), "%s syntax OK\n", origfilename);
1018 if (PERLDB_SINGLE && DBsingle)
1019 sv_setiv(DBsingle, 1);
1021 call_list(oldscope, initav);
1031 else if (main_start) {
1032 CvDEPTH(main_cv) = 1;
1043 perl_get_sv(name, create)
1047 GV* gv = gv_fetchpv(name, create, SVt_PV);
1054 perl_get_av(name, create)
1058 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
1067 perl_get_hv(name, create)
1071 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
1080 perl_get_cv(name, create)
1084 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
1085 if (create && !GvCVu(gv))
1086 return newSUB(start_subparse(FALSE, 0),
1087 newSVOP(OP_CONST, 0, newSVpv(name,0)),
1095 /* Be sure to refetch the stack pointer after calling these routines. */
1098 perl_call_argv(subname, flags, argv)
1100 I32 flags; /* See G_* flags in cop.h */
1101 register char **argv; /* null terminated arg list */
1109 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
1114 return perl_call_pv(subname, flags);
1118 perl_call_pv(subname, flags)
1119 char *subname; /* name of the subroutine */
1120 I32 flags; /* See G_* flags in cop.h */
1122 return perl_call_sv((SV*)perl_get_cv(subname, TRUE), flags);
1126 perl_call_method(methname, flags)
1127 char *methname; /* name of the subroutine */
1128 I32 flags; /* See G_* flags in cop.h */
1135 XPUSHs(sv_2mortal(newSVpv(methname,0)));
1138 return perl_call_sv(*stack_sp--, flags);
1141 /* May be called with any of a CV, a GV, or an SV containing the name. */
1143 perl_call_sv(sv, flags)
1145 I32 flags; /* See G_* flags in cop.h */
1148 LOGOP myop; /* fake syntax tree node */
1154 bool oldcatch = CATCH_GET;
1159 if (flags & G_DISCARD) {
1164 Zero(&myop, 1, LOGOP);
1165 myop.op_next = Nullop;
1166 if (!(flags & G_NOARGS))
1167 myop.op_flags |= OPf_STACKED;
1168 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1169 (flags & G_ARRAY) ? OPf_WANT_LIST :
1174 EXTEND(stack_sp, 1);
1177 oldscope = scopestack_ix;
1179 if (PERLDB_SUB && curstash != debstash
1180 /* Handle first BEGIN of -d. */
1181 && (DBcv || (DBcv = GvCV(DBsub)))
1182 /* Try harder, since this may have been a sighandler, thus
1183 * curstash may be meaningless. */
1184 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != debstash))
1185 op->op_private |= OPpENTERSUB_DB;
1187 if (flags & G_EVAL) {
1188 cLOGOP->op_other = op;
1190 /* we're trying to emulate pp_entertry() here */
1192 register CONTEXT *cx;
1193 I32 gimme = GIMME_V;
1198 push_return(op->op_next);
1199 PUSHBLOCK(cx, CXt_EVAL, stack_sp);
1201 eval_root = op; /* Only needed so that goto works right. */
1204 if (flags & G_KEEPERR)
1207 sv_setpv(GvSV(errgv),"");
1219 /* my_exit() was called */
1220 curstash = defstash;
1224 croak("Callback called exit");
1233 stack_sp = stack_base + oldmark;
1234 if (flags & G_ARRAY)
1238 *++stack_sp = &sv_undef;
1246 if (op == (OP*)&myop)
1247 op = pp_entersub(ARGS);
1250 retval = stack_sp - (stack_base + oldmark);
1251 if ((flags & G_EVAL) && !(flags & G_KEEPERR))
1252 sv_setpv(GvSV(errgv),"");
1255 if (flags & G_EVAL) {
1256 if (scopestack_ix > oldscope) {
1260 register CONTEXT *cx;
1272 CATCH_SET(oldcatch);
1274 if (flags & G_DISCARD) {
1275 stack_sp = stack_base + oldmark;
1284 /* Eval a string. The G_EVAL flag is always assumed. */
1287 perl_eval_sv(sv, flags)
1289 I32 flags; /* See G_* flags in cop.h */
1292 UNOP myop; /* fake syntax tree node */
1294 I32 oldmark = sp - stack_base;
1301 if (flags & G_DISCARD) {
1309 EXTEND(stack_sp, 1);
1311 oldscope = scopestack_ix;
1313 if (!(flags & G_NOARGS))
1314 myop.op_flags = OPf_STACKED;
1315 myop.op_next = Nullop;
1316 myop.op_type = OP_ENTEREVAL;
1317 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1318 (flags & G_ARRAY) ? OPf_WANT_LIST :
1320 if (flags & G_KEEPERR)
1321 myop.op_flags |= OPf_SPECIAL;
1331 /* my_exit() was called */
1332 curstash = defstash;
1336 croak("Callback called exit");
1345 stack_sp = stack_base + oldmark;
1346 if (flags & G_ARRAY)
1350 *++stack_sp = &sv_undef;
1355 if (op == (OP*)&myop)
1356 op = pp_entereval(ARGS);
1359 retval = stack_sp - (stack_base + oldmark);
1360 if (!(flags & G_KEEPERR))
1361 sv_setpv(GvSV(errgv),"");
1365 if (flags & G_DISCARD) {
1366 stack_sp = stack_base + oldmark;
1376 perl_eval_pv(p, croak_on_error)
1382 SV* sv = newSVpv(p, 0);
1385 perl_eval_sv(sv, G_SCALAR);
1392 if (croak_on_error && SvTRUE(GvSV(errgv)))
1393 croak(SvPVx(GvSV(errgv), na));
1398 /* Require a module. */
1404 SV* sv = sv_newmortal();
1405 sv_setpv(sv, "require '");
1408 perl_eval_sv(sv, G_DISCARD);
1412 magicname(sym,name,namlen)
1419 if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
1420 sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
1424 usage(name) /* XXX move this out into a module ? */
1427 /* This message really ought to be max 23 lines.
1428 * Removed -h because the user already knows that opton. Others? */
1429 printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
1430 printf("\n -0[octal] specify record separator (\\0, if no argument)");
1431 printf("\n -a autosplit mode with -n or -p (splits $_ into @F)");
1432 printf("\n -c check syntax only (runs BEGIN and END blocks)");
1433 printf("\n -d[:debugger] run scripts under debugger");
1434 printf("\n -D[number/list] set debugging flags (argument is a bit mask or flags)");
1435 printf("\n -e 'command' one line of script. Several -e's allowed. Omit [programfile].");
1436 printf("\n -F/pattern/ split() pattern for autosplit (-a). The //'s are optional.");
1437 printf("\n -i[extension] edit <> files in place (make backup if extension supplied)");
1438 printf("\n -Idirectory specify @INC/#include directory (may be used more than once)");
1439 printf("\n -l[octal] enable line ending processing, specifies line terminator");
1440 printf("\n -[mM][-]module.. executes `use/no module...' before executing your script.");
1441 printf("\n -n assume 'while (<>) { ... }' loop around your script");
1442 printf("\n -p assume loop like -n but print line also like sed");
1443 printf("\n -P run script through C preprocessor before compilation");
1444 printf("\n -s enable some switch parsing for switches after script name");
1445 printf("\n -S look for the script using PATH environment variable");
1446 printf("\n -T turn on tainting checks");
1447 printf("\n -u dump core after parsing script");
1448 printf("\n -U allow unsafe operations");
1449 printf("\n -v print version number and patchlevel of perl");
1450 printf("\n -V[:variable] print perl configuration information");
1451 printf("\n -w TURN WARNINGS ON FOR COMPILATION OF YOUR SCRIPT. Recommended.");
1452 printf("\n -x[directory] strip off text before #!perl line and perhaps cd to directory\n");
1455 /* This routine handles any switches that can be given during run */
1466 rschar = scan_oct(s, 4, &numlen);
1468 if (rschar & ~((U8)~0))
1470 else if (!rschar && numlen >= 2)
1471 nrs = newSVpv("", 0);
1474 nrs = newSVpv(&ch, 1);
1479 splitstr = savepv(s + 1);
1493 if (*s == ':' || *s == '=') {
1494 my_setenv("PERL5DB", form("use Devel::%s;", ++s));
1498 perldb = PERLDB_ALL;
1505 if (isALPHA(s[1])) {
1506 static char debopts[] = "psltocPmfrxuLHXD";
1509 for (s++; *s && (d = strchr(debopts,*s)); s++)
1510 debug |= 1 << (d - debopts);
1514 for (s++; isDIGIT(*s); s++) ;
1516 debug |= 0x80000000;
1518 warn("Recompile perl with -DDEBUGGING to use -D switch\n");
1519 for (s++; isALNUM(*s); s++) ;
1529 inplace = savepv(s+1);
1531 for (s = inplace; *s && !isSPACE(*s); s++) ;
1538 for (e = s; *e && !isSPACE(*e); e++) ;
1539 p = savepvn(s, e-s);
1546 croak("No space allowed after -I");
1556 *ors = scan_oct(s, 3 + (*s == '0'), &numlen);
1565 ors = SvPV(nrs, orslen);
1566 ors = savepvn(ors, orslen);
1570 forbid_setid("-M"); /* XXX ? */
1573 forbid_setid("-m"); /* XXX ? */
1578 /* -M-foo == 'no foo' */
1579 if (*s == '-') { use = "no "; ++s; }
1580 sv = newSVpv(use,0);
1582 /* We allow -M'Module qw(Foo Bar)' */
1583 while(isALNUM(*s) || *s==':') ++s;
1585 sv_catpv(sv, start);
1586 if (*(start-1) == 'm') {
1588 croak("Can't use '%c' after -mname", *s);
1589 sv_catpv( sv, " ()");
1592 sv_catpvn(sv, start, s-start);
1593 sv_catpv(sv, " split(/,/,q{");
1598 if (preambleav == NULL)
1599 preambleav = newAV();
1600 av_push(preambleav, sv);
1603 croak("No space allowed after -%c", *(s-1));
1620 croak("Too late for \"-T\" option");
1632 #if defined(SUBVERSION) && SUBVERSION > 0
1633 printf("\nThis is perl, version 5.%03d_%02d", PATCHLEVEL, SUBVERSION);
1635 printf("\nThis is perl, version %s",patchlevel);
1638 printf("\n\nCopyright 1987-1997, Larry Wall\n");
1640 printf("\n\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
1643 printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n");
1646 printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
1647 "Version 5 port Copyright (c) 1994-1997, Andreas Kaiser, Ilya Zakharevich\n");
1650 printf("atariST series port, ++jrb bammi@cadence.com\n");
1653 Perl may be copied only under the terms of either the Artistic License or the\n\
1654 GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n");
1662 if (s[1] == '-') /* Additional switches on #! line. */
1670 #ifdef ALTERNATE_SHEBANG
1671 case 'S': /* OS/2 needs -S on "extproc" line. */
1679 croak("Can't emulate -%.1s on #! line",s);
1684 /* compliments of Tom Christiansen */
1686 /* unexec() can be found in the Gnu emacs distribution */
1697 prog = newSVpv(BIN_EXP);
1698 sv_catpv(prog, "/perl");
1699 file = newSVpv(origfilename);
1700 sv_catpv(file, ".perldump");
1702 status = unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
1704 PerlIO_printf(PerlIO_stderr(), "unexec of %s into %s failed!\n",
1705 SvPVX(prog), SvPVX(file));
1709 # include <lib$routines.h>
1710 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
1712 ABORT(); /* for use with undump */
1723 /* Note that strtab is a rather special HV. Assumptions are made
1724 about not iterating on it, and not adding tie magic to it.
1725 It is properly deallocated in perl_destruct() */
1727 HvSHAREKEYS_off(strtab); /* mandatory */
1728 Newz(506,((XPVHV*)SvANY(strtab))->xhv_array,
1729 sizeof(HE*) * (((XPVHV*)SvANY(strtab))->xhv_max + 1), char);
1731 curstash = defstash = newHV();
1732 curstname = newSVpv("main",4);
1733 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
1734 SvREFCNT_dec(GvHV(gv));
1735 GvHV(gv) = (HV*)SvREFCNT_inc(defstash);
1737 HvNAME(defstash) = savepv("main");
1738 incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
1740 defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
1741 errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
1743 (void)form("%240s",""); /* Preallocate temp - for immediate signals. */
1744 sv_grow(GvSV(errgv), 240); /* Preallocate - for immediate signals. */
1745 sv_setpvn(GvSV(errgv), "", 0);
1746 curstash = defstash;
1747 compiling.cop_stash = defstash;
1748 debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
1749 /* We must init $/ before switches are processed. */
1750 sv_setpvn(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), "\n", 1);
1753 #ifdef CAN_PROTOTYPE
1755 open_script(char *scriptname, bool dosearch, SV *sv)
1758 open_script(scriptname,dosearch,sv)
1765 char *xfound = Nullch;
1766 char *xfailed = Nullch;
1770 #if defined(DOSISH) && !defined(OS2) && !defined(atarist)
1771 # define SEARCH_EXTS ".bat", ".cmd", NULL
1772 # define MAX_EXT_LEN 4
1775 # define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL
1776 # define MAX_EXT_LEN 4
1779 # define SEARCH_EXTS ".pl", ".com", NULL
1780 # define MAX_EXT_LEN 4
1782 /* additional extensions to try in each dir if scriptname not found */
1784 char *ext[] = { SEARCH_EXTS };
1785 int extidx = 0, i = 0;
1786 char *curext = Nullch;
1788 # define MAX_EXT_LEN 0
1792 * If dosearch is true and if scriptname does not contain path
1793 * delimiters, search the PATH for scriptname.
1795 * If SEARCH_EXTS is also defined, will look for each
1796 * scriptname{SEARCH_EXTS} whenever scriptname is not found
1797 * while searching the PATH.
1799 * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
1800 * proceeds as follows:
1802 * + look for ./scriptname{,.foo,.bar}
1803 * + search the PATH for scriptname{,.foo,.bar}
1806 * + look *only* in the PATH for scriptname{,.foo,.bar} (note
1807 * this will not look in '.' if it's not in the PATH)
1812 int hasdir, idx = 0, deftypes = 1;
1815 hasdir = (strpbrk(scriptname,":[</") != Nullch) ;
1816 /* The first time through, just add SEARCH_EXTS to whatever we
1817 * already have, so we can check for default file types. */
1819 (!hasdir && my_trnlnm("DCL$PATH",tokenbuf,idx++)) )
1825 if ((strlen(tokenbuf) + strlen(scriptname)
1826 + MAX_EXT_LEN) >= sizeof tokenbuf)
1827 continue; /* don't search dir with too-long name */
1828 strcat(tokenbuf, scriptname);
1832 if (strEQ(scriptname, "-"))
1834 if (dosearch) { /* Look in '.' first. */
1835 char *cur = scriptname;
1837 if ((curext = strrchr(scriptname,'.'))) /* possible current ext */
1839 if (strEQ(ext[i++],curext)) {
1840 extidx = -1; /* already has an ext */
1845 DEBUG_p(PerlIO_printf(Perl_debug_log,
1846 "Looking for %s\n",cur));
1847 if (Stat(cur,&statbuf) >= 0) {
1855 if (cur == scriptname) {
1856 len = strlen(scriptname);
1857 if (len+MAX_EXT_LEN+1 >= sizeof(tokenbuf))
1859 cur = strcpy(tokenbuf, scriptname);
1861 } while (extidx >= 0 && ext[extidx] /* try an extension? */
1862 && strcpy(tokenbuf+len, ext[extidx++]));
1867 if (dosearch && !strchr(scriptname, '/')
1869 && !strchr(scriptname, '\\')
1871 && (s = getenv("PATH"))) {
1874 bufend = s + strlen(s);
1875 while (s < bufend) {
1876 #if defined(atarist) || defined(DOSISH)
1881 && *s != ';'; len++, s++) {
1882 if (len < sizeof tokenbuf)
1885 if (len < sizeof tokenbuf)
1886 tokenbuf[len] = '\0';
1887 #else /* ! (atarist || DOSISH) */
1888 s = delimcpy(tokenbuf, tokenbuf + sizeof tokenbuf, s, bufend,
1891 #endif /* ! (atarist || DOSISH) */
1894 if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tokenbuf)
1895 continue; /* don't search dir with too-long name */
1897 #if defined(atarist) || defined(DOSISH)
1898 && tokenbuf[len - 1] != '/'
1899 && tokenbuf[len - 1] != '\\'
1902 tokenbuf[len++] = '/';
1903 if (len == 2 && tokenbuf[0] == '.')
1905 (void)strcpy(tokenbuf + len, scriptname);
1909 len = strlen(tokenbuf);
1910 if (extidx > 0) /* reset after previous loop */
1914 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tokenbuf));
1915 retval = Stat(tokenbuf,&statbuf);
1917 } while ( retval < 0 /* not there */
1918 && extidx>=0 && ext[extidx] /* try an extension? */
1919 && strcpy(tokenbuf+len, ext[extidx++])
1924 if (S_ISREG(statbuf.st_mode)
1925 && cando(S_IRUSR,TRUE,&statbuf)
1927 && cando(S_IXUSR,TRUE,&statbuf)
1931 xfound = tokenbuf; /* bingo! */
1935 xfailed = savepv(tokenbuf);
1938 if (!xfound && !seen_dot && !xfailed && (Stat(scriptname,&statbuf) < 0))
1940 seen_dot = 1; /* Disable message. */
1942 croak("Can't %s %s%s%s",
1943 (xfailed ? "execute" : "find"),
1944 (xfailed ? xfailed : scriptname),
1945 (xfailed ? "" : " on PATH"),
1946 (xfailed || seen_dot) ? "" : ", '.' not in PATH");
1949 scriptname = xfound;
1952 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
1953 char *s = scriptname + 8;
1962 origfilename = savepv(e_tmpname ? "-e" : scriptname);
1963 curcop->cop_filegv = gv_fetchfile(origfilename);
1964 if (strEQ(origfilename,"-"))
1966 if (fdscript >= 0) {
1967 rsfp = PerlIO_fdopen(fdscript,"r");
1968 #if defined(HAS_FCNTL) && defined(F_SETFD)
1970 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
1973 else if (preprocess) {
1974 char *cpp_cfg = CPPSTDIN;
1975 SV *cpp = NEWSV(0,0);
1976 SV *cmd = NEWSV(0,0);
1978 if (strEQ(cpp_cfg, "cppstdin"))
1979 sv_catpvf(cpp, "%s/", BIN_EXP);
1980 sv_catpv(cpp, cpp_cfg);
1983 sv_catpv(sv,PRIVLIB_EXP);
1987 sed %s -e \"/^[^#]/b\" \
1988 -e \"/^#[ ]*include[ ]/b\" \
1989 -e \"/^#[ ]*define[ ]/b\" \
1990 -e \"/^#[ ]*if[ ]/b\" \
1991 -e \"/^#[ ]*ifdef[ ]/b\" \
1992 -e \"/^#[ ]*ifndef[ ]/b\" \
1993 -e \"/^#[ ]*else/b\" \
1994 -e \"/^#[ ]*elif[ ]/b\" \
1995 -e \"/^#[ ]*undef[ ]/b\" \
1996 -e \"/^#[ ]*endif/b\" \
1999 (doextract ? "-e \"1,/^#/d\n\"" : ""),
2002 %s %s -e '/^[^#]/b' \
2003 -e '/^#[ ]*include[ ]/b' \
2004 -e '/^#[ ]*define[ ]/b' \
2005 -e '/^#[ ]*if[ ]/b' \
2006 -e '/^#[ ]*ifdef[ ]/b' \
2007 -e '/^#[ ]*ifndef[ ]/b' \
2008 -e '/^#[ ]*else/b' \
2009 -e '/^#[ ]*elif[ ]/b' \
2010 -e '/^#[ ]*undef[ ]/b' \
2011 -e '/^#[ ]*endif/b' \
2019 (doextract ? "-e '1,/^#/d\n'" : ""),
2021 scriptname, cpp, sv, CPPMINUS);
2023 #ifdef IAMSUID /* actually, this is caught earlier */
2024 if (euid != uid && !euid) { /* if running suidperl */
2026 (void)seteuid(uid); /* musn't stay setuid root */
2029 (void)setreuid((Uid_t)-1, uid);
2031 #ifdef HAS_SETRESUID
2032 (void)setresuid((Uid_t)-1, uid, (Uid_t)-1);
2038 if (geteuid() != uid)
2039 croak("Can't do seteuid!\n");
2041 #endif /* IAMSUID */
2042 rsfp = my_popen(SvPVX(cmd), "r");
2046 else if (!*scriptname) {
2047 forbid_setid("program input from stdin");
2048 rsfp = PerlIO_stdin();
2051 rsfp = PerlIO_open(scriptname,"r");
2052 #if defined(HAS_FCNTL) && defined(F_SETFD)
2054 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
2062 #ifndef IAMSUID /* in case script is not readable before setuid */
2063 if (euid && Stat(SvPVX(GvSV(curcop->cop_filegv)),&statbuf) >= 0 &&
2064 statbuf.st_mode & (S_ISUID|S_ISGID)) {
2066 execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
2067 croak("Can't do setuid\n");
2071 croak("Can't open perl script \"%s\": %s\n",
2072 SvPVX(GvSV(curcop->cop_filegv)), Strerror(errno));
2077 validate_suid(validarg, scriptname)
2083 /* do we need to emulate setuid on scripts? */
2085 /* This code is for those BSD systems that have setuid #! scripts disabled
2086 * in the kernel because of a security problem. Merely defining DOSUID
2087 * in perl will not fix that problem, but if you have disabled setuid
2088 * scripts in the kernel, this will attempt to emulate setuid and setgid
2089 * on scripts that have those now-otherwise-useless bits set. The setuid
2090 * root version must be called suidperl or sperlN.NNN. If regular perl
2091 * discovers that it has opened a setuid script, it calls suidperl with
2092 * the same argv that it had. If suidperl finds that the script it has
2093 * just opened is NOT setuid root, it sets the effective uid back to the
2094 * uid. We don't just make perl setuid root because that loses the
2095 * effective uid we had before invoking perl, if it was different from the
2098 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
2099 * be defined in suidperl only. suidperl must be setuid root. The
2100 * Configure script will set this up for you if you want it.
2106 if (Fstat(PerlIO_fileno(rsfp),&statbuf) < 0) /* normal stat is insecure */
2107 croak("Can't stat script \"%s\"",origfilename);
2108 if (fdscript < 0 && statbuf.st_mode & (S_ISUID|S_ISGID)) {
2112 #ifndef HAS_SETREUID
2113 /* On this access check to make sure the directories are readable,
2114 * there is actually a small window that the user could use to make
2115 * filename point to an accessible directory. So there is a faint
2116 * chance that someone could execute a setuid script down in a
2117 * non-accessible directory. I don't know what to do about that.
2118 * But I don't think it's too important. The manual lies when
2119 * it says access() is useful in setuid programs.
2121 if (access(SvPVX(GvSV(curcop->cop_filegv)),1)) /*double check*/
2122 croak("Permission denied");
2124 /* If we can swap euid and uid, then we can determine access rights
2125 * with a simple stat of the file, and then compare device and
2126 * inode to make sure we did stat() on the same file we opened.
2127 * Then we just have to make sure he or she can execute it.
2130 struct stat tmpstatbuf;
2134 setreuid(euid,uid) < 0
2137 setresuid(euid,uid,(Uid_t)-1) < 0
2140 || getuid() != euid || geteuid() != uid)
2141 croak("Can't swap uid and euid"); /* really paranoid */
2142 if (Stat(SvPVX(GvSV(curcop->cop_filegv)),&tmpstatbuf) < 0)
2143 croak("Permission denied"); /* testing full pathname here */
2144 if (tmpstatbuf.st_dev != statbuf.st_dev ||
2145 tmpstatbuf.st_ino != statbuf.st_ino) {
2146 (void)PerlIO_close(rsfp);
2147 if (rsfp = my_popen("/bin/mail root","w")) { /* heh, heh */
2149 "User %ld tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
2150 (Filename of set-id script was %s, uid %ld gid %ld.)\n\nSincerely,\nperl\n",
2151 (long)uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
2152 (long)statbuf.st_dev, (long)statbuf.st_ino,
2153 SvPVX(GvSV(curcop->cop_filegv)),
2154 (long)statbuf.st_uid, (long)statbuf.st_gid);
2155 (void)my_pclose(rsfp);
2157 croak("Permission denied\n");
2161 setreuid(uid,euid) < 0
2163 # if defined(HAS_SETRESUID)
2164 setresuid(uid,euid,(Uid_t)-1) < 0
2167 || getuid() != uid || geteuid() != euid)
2168 croak("Can't reswap uid and euid");
2169 if (!cando(S_IXUSR,FALSE,&statbuf)) /* can real uid exec? */
2170 croak("Permission denied\n");
2172 #endif /* HAS_SETREUID */
2173 #endif /* IAMSUID */
2175 if (!S_ISREG(statbuf.st_mode))
2176 croak("Permission denied");
2177 if (statbuf.st_mode & S_IWOTH)
2178 croak("Setuid/gid script is writable by world");
2179 doswitches = FALSE; /* -s is insecure in suid */
2181 if (sv_gets(linestr, rsfp, 0) == Nullch ||
2182 strnNE(SvPV(linestr,na),"#!",2) ) /* required even on Sys V */
2183 croak("No #! line");
2184 s = SvPV(linestr,na)+2;
2186 while (!isSPACE(*s)) s++;
2187 for (s2 = s; (s2 > SvPV(linestr,na)+2 &&
2188 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
2189 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
2190 croak("Not a perl script");
2191 while (*s == ' ' || *s == '\t') s++;
2193 * #! arg must be what we saw above. They can invoke it by
2194 * mentioning suidperl explicitly, but they may not add any strange
2195 * arguments beyond what #! says if they do invoke suidperl that way.
2197 len = strlen(validarg);
2198 if (strEQ(validarg," PHOOEY ") ||
2199 strnNE(s,validarg,len) || !isSPACE(s[len]))
2200 croak("Args must match #! line");
2203 if (euid != uid && (statbuf.st_mode & S_ISUID) &&
2204 euid == statbuf.st_uid)
2206 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2207 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2208 #endif /* IAMSUID */
2210 if (euid) { /* oops, we're not the setuid root perl */
2211 (void)PerlIO_close(rsfp);
2214 execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
2216 croak("Can't do setuid\n");
2219 if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid) {
2221 (void)setegid(statbuf.st_gid);
2224 (void)setregid((Gid_t)-1,statbuf.st_gid);
2226 #ifdef HAS_SETRESGID
2227 (void)setresgid((Gid_t)-1,statbuf.st_gid,(Gid_t)-1);
2229 setgid(statbuf.st_gid);
2233 if (getegid() != statbuf.st_gid)
2234 croak("Can't do setegid!\n");
2236 if (statbuf.st_mode & S_ISUID) {
2237 if (statbuf.st_uid != euid)
2239 (void)seteuid(statbuf.st_uid); /* all that for this */
2242 (void)setreuid((Uid_t)-1,statbuf.st_uid);
2244 #ifdef HAS_SETRESUID
2245 (void)setresuid((Uid_t)-1,statbuf.st_uid,(Uid_t)-1);
2247 setuid(statbuf.st_uid);
2251 if (geteuid() != statbuf.st_uid)
2252 croak("Can't do seteuid!\n");
2254 else if (uid) { /* oops, mustn't run as root */
2256 (void)seteuid((Uid_t)uid);
2259 (void)setreuid((Uid_t)-1,(Uid_t)uid);
2261 #ifdef HAS_SETRESUID
2262 (void)setresuid((Uid_t)-1,(Uid_t)uid,(Uid_t)-1);
2268 if (geteuid() != uid)
2269 croak("Can't do seteuid!\n");
2272 if (!cando(S_IXUSR,TRUE,&statbuf))
2273 croak("Permission denied\n"); /* they can't do this */
2276 else if (preprocess)
2277 croak("-P not allowed for setuid/setgid script\n");
2278 else if (fdscript >= 0)
2279 croak("fd script not allowed in suidperl\n");
2281 croak("Script is not setuid/setgid in suidperl\n");
2283 /* We absolutely must clear out any saved ids here, so we */
2284 /* exec the real perl, substituting fd script for scriptname. */
2285 /* (We pass script name as "subdir" of fd, which perl will grok.) */
2286 PerlIO_rewind(rsfp);
2287 lseek(PerlIO_fileno(rsfp),(Off_t)0,0); /* just in case rewind didn't */
2288 for (which = 1; origargv[which] && origargv[which] != scriptname; which++) ;
2289 if (!origargv[which])
2290 croak("Permission denied");
2291 origargv[which] = savepv(form("/dev/fd/%d/%s",
2292 PerlIO_fileno(rsfp), origargv[which]));
2293 #if defined(HAS_FCNTL) && defined(F_SETFD)
2294 fcntl(PerlIO_fileno(rsfp),F_SETFD,0); /* ensure no close-on-exec */
2296 execv(form("%s/perl%s", BIN_EXP, patchlevel), origargv); /* try again */
2297 croak("Can't do setuid\n");
2298 #endif /* IAMSUID */
2300 if (euid != uid || egid != gid) { /* (suidperl doesn't exist, in fact) */
2301 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
2303 Fstat(PerlIO_fileno(rsfp),&statbuf); /* may be either wrapped or real suid */
2304 if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
2306 (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
2309 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2310 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2311 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
2312 /* not set-id, must be wrapped */
2320 register char *s, *s2;
2322 /* skip forward in input to the real script? */
2326 if ((s = sv_gets(linestr, rsfp, 0)) == Nullch)
2327 croak("No Perl script found in input\n");
2328 if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
2329 PerlIO_ungetc(rsfp, '\n'); /* to keep line count right */
2331 while (*s && !(isSPACE (*s) || *s == '#')) s++;
2333 while (*s == ' ' || *s == '\t') s++;
2335 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
2336 if (strnEQ(s2-4,"perl",4))
2338 while (s = moreswitches(s)) ;
2340 if (cddir && chdir(cddir) < 0)
2341 croak("Can't chdir to %s",cddir);
2349 uid = (int)getuid();
2350 euid = (int)geteuid();
2351 gid = (int)getgid();
2352 egid = (int)getegid();
2357 tainting |= (uid && (euid != uid || egid != gid));
2365 croak("No %s allowed while running setuid", s);
2367 croak("No %s allowed while running setgid", s);
2374 curstash = debstash;
2375 dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
2377 DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
2378 DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
2379 DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
2380 DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
2381 sv_setiv(DBsingle, 0);
2382 DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
2383 sv_setiv(DBtrace, 0);
2384 DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
2385 sv_setiv(DBsignal, 0);
2386 curstash = defstash;
2394 mainstack = curstack; /* remember in case we switch stacks */
2395 AvREAL_off(curstack); /* not a real array */
2396 av_extend(curstack,127);
2398 stack_base = AvARRAY(curstack);
2399 stack_sp = stack_base;
2400 stack_max = stack_base + 127;
2402 cxstack_max = 8192 / sizeof(CONTEXT) - 2; /* Use most of 8K. */
2403 New(50,cxstack,cxstack_max + 1,CONTEXT);
2406 New(50,tmps_stack,128,SV*);
2412 * The following stacks almost certainly should be per-interpreter,
2413 * but for now they're not. XXX
2417 markstack_ptr = markstack;
2419 New(54,markstack,64,I32);
2420 markstack_ptr = markstack;
2421 markstack_max = markstack + 64;
2427 New(54,scopestack,32,I32);
2429 scopestack_max = 32;
2435 New(54,savestack,128,ANY);
2437 savestack_max = 128;
2443 New(54,retstack,16,OP*);
2454 Safefree(tmps_stack);
2461 static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
2470 subname = newSVpv("main",4);
2474 init_predump_symbols()
2480 sv_setpvn(GvSV(gv_fetchpv("\"", TRUE, SVt_PV)), " ", 1);
2482 stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
2483 GvMULTI_on(stdingv);
2484 IoIFP(GvIOp(stdingv)) = PerlIO_stdin();
2485 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
2487 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(stdingv));
2489 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
2491 IoOFP(GvIOp(tmpgv)) = IoIFP(GvIOp(tmpgv)) = PerlIO_stdout();
2493 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
2495 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(defoutgv));
2497 othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
2498 GvMULTI_on(othergv);
2499 IoOFP(GvIOp(othergv)) = IoIFP(GvIOp(othergv)) = PerlIO_stderr();
2500 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
2502 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(othergv));
2504 statname = NEWSV(66,0); /* last filename we did stat on */
2507 osname = savepv(OSNAME);
2511 init_postdump_symbols(argc,argv,env)
2513 register char **argv;
2514 register char **env;
2520 argc--,argv++; /* skip name of script */
2522 for (; argc > 0 && **argv == '-'; argc--,argv++) {
2525 if (argv[0][1] == '-') {
2529 if (s = strchr(argv[0], '=')) {
2531 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
2534 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
2537 toptarget = NEWSV(0,0);
2538 sv_upgrade(toptarget, SVt_PVFM);
2539 sv_setpvn(toptarget, "", 0);
2540 bodytarget = NEWSV(0,0);
2541 sv_upgrade(bodytarget, SVt_PVFM);
2542 sv_setpvn(bodytarget, "", 0);
2543 formtarget = bodytarget;
2546 if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
2547 sv_setpv(GvSV(tmpgv),origfilename);
2548 magicname("0", "0", 1);
2550 if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
2551 sv_setpv(GvSV(tmpgv),origargv[0]);
2552 if (argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
2554 (void)gv_AVadd(argvgv);
2555 av_clear(GvAVn(argvgv));
2556 for (; argc > 0; argc--,argv++) {
2557 av_push(GvAVn(argvgv),newSVpv(argv[0],0));
2560 if (envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
2564 hv_magic(hv, envgv, 'E');
2565 #ifndef VMS /* VMS doesn't have environ array */
2566 /* Note that if the supplied env parameter is actually a copy
2567 of the global environ then it may now point to free'd memory
2568 if the environment has been modified since. To avoid this
2569 problem we treat env==NULL as meaning 'use the default'
2574 environ[0] = Nullch;
2575 for (; *env; env++) {
2576 if (!(s = strchr(*env,'=')))
2582 sv = newSVpv(s--,0);
2583 (void)hv_store(hv, *env, s - *env, sv, 0);
2585 #if defined(__BORLANDC__) && defined(USE_WIN32_RTL_ENV)
2586 /* Sins of the RTL. See note in my_setenv(). */
2587 (void)putenv(savepv(*env));
2591 #ifdef DYNAMIC_ENV_FETCH
2592 HvNAME(hv) = savepv(ENV_HV_NAME);
2596 if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
2597 sv_setiv(GvSV(tmpgv), (IV)getpid());
2606 s = getenv("PERL5LIB");
2610 incpush(getenv("PERLLIB"), FALSE);
2612 /* Treat PERL5?LIB as a possible search list logical name -- the
2613 * "natural" VMS idiom for a Unix path string. We allow each
2614 * element to be a set of |-separated directories for compatibility.
2618 if (my_trnlnm("PERL5LIB",buf,0))
2619 do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
2621 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE);
2625 /* Use the ~-expanded versions of APPLLIB (undocumented),
2626 ARCHLIB PRIVLIB SITEARCH SITELIB and OLDARCHLIB
2629 incpush(APPLLIB_EXP, FALSE);
2633 incpush(ARCHLIB_EXP, FALSE);
2636 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
2638 incpush(PRIVLIB_EXP, FALSE);
2641 incpush(SITEARCH_EXP, FALSE);
2644 incpush(SITELIB_EXP, FALSE);
2646 #ifdef OLDARCHLIB_EXP /* 5.00[01] compatibility */
2647 incpush(OLDARCHLIB_EXP, FALSE);
2651 incpush(".", FALSE);
2655 # define PERLLIB_SEP ';'
2658 # define PERLLIB_SEP '|'
2660 # define PERLLIB_SEP ':'
2663 #ifndef PERLLIB_MANGLE
2664 # define PERLLIB_MANGLE(s,n) (s)
2668 incpush(p, addsubdirs)
2672 SV *subdir = Nullsv;
2673 static char *archpat_auto;
2680 if (!archpat_auto) {
2681 STRLEN len = (sizeof(ARCHNAME) + strlen(patchlevel)
2682 + sizeof("//auto"));
2683 New(55, archpat_auto, len, char);
2684 sprintf(archpat_auto, "/%s/%s/auto", ARCHNAME, patchlevel);
2686 for (len = sizeof(ARCHNAME) + 2;
2687 archpat_auto[len] != '\0' && archpat_auto[len] != '/'; len++)
2688 if (archpat_auto[len] == '.') archpat_auto[len] = '_';
2693 /* Break at all separators */
2695 SV *libdir = newSV(0);
2698 /* skip any consecutive separators */
2699 while ( *p == PERLLIB_SEP ) {
2700 /* Uncomment the next line for PATH semantics */
2701 /* av_push(GvAVn(incgv), newSVpv(".", 1)); */
2705 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
2706 sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
2711 sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
2712 p = Nullch; /* break out */
2716 * BEFORE pushing libdir onto @INC we may first push version- and
2717 * archname-specific sub-directories.
2720 struct stat tmpstatbuf;
2725 if ((unix = tounixspec_ts(SvPV(libdir,na),Nullch)) != Nullch) {
2727 while (unix[len-1] == '/') len--; /* Cosmetic */
2728 sv_usepvn(libdir,unix,len);
2731 PerlIO_printf(PerlIO_stderr(),
2732 "Failed to unixify @INC element \"%s\"\n",
2735 /* .../archname/version if -d .../archname/version/auto */
2736 sv_setsv(subdir, libdir);
2737 sv_catpv(subdir, archpat_auto);
2738 if (Stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2739 S_ISDIR(tmpstatbuf.st_mode))
2740 av_push(GvAVn(incgv),
2741 newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2743 /* .../archname if -d .../archname/auto */
2744 sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME),
2745 strlen(patchlevel) + 1, "", 0);
2746 if (Stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2747 S_ISDIR(tmpstatbuf.st_mode))
2748 av_push(GvAVn(incgv),
2749 newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2752 /* finally push this lib directory on the end of @INC */
2753 av_push(GvAVn(incgv), libdir);
2756 SvREFCNT_dec(subdir);
2760 call_list(oldscope, list)
2765 line_t oldline = curcop->cop_line;
2770 while (AvFILL(list) >= 0) {
2771 CV *cv = (CV*)av_shift(list);
2778 SV* atsv = GvSV(errgv);
2780 perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
2781 (void)SvPV(atsv, len);
2784 curcop = &compiling;
2785 curcop->cop_line = oldline;
2786 if (list == beginav)
2787 sv_catpv(atsv, "BEGIN failed--compilation aborted");
2789 sv_catpv(atsv, "END failed--cleanup aborted");
2790 while (scopestack_ix > oldscope)
2792 croak("%s", SvPVX(atsv));
2800 /* my_exit() was called */
2801 while (scopestack_ix > oldscope)
2804 curstash = defstash;
2806 call_list(oldscope, endav);
2808 curcop = &compiling;
2809 curcop->cop_line = oldline;
2811 if (list == beginav)
2812 croak("BEGIN failed--compilation aborted");
2814 croak("END failed--cleanup aborted");
2820 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
2825 curcop = &compiling;
2826 curcop->cop_line = oldline;
2840 DEBUG_L(PerlIO_printf(Perl_debug_log, "my_exit: thread 0x%lx, status %lu\n",
2841 (unsigned long) thr, (unsigned long) status));
2842 #endif /* USE_THREADS */
2851 STATUS_NATIVE_SET(status);
2861 if (vaxc$errno & 1) {
2862 if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
2863 STATUS_NATIVE_SET(44);
2866 if (!vaxc$errno && errno) /* unlikely */
2867 STATUS_NATIVE_SET(44);
2869 STATUS_NATIVE_SET(vaxc$errno);
2873 STATUS_POSIX_SET(errno);
2874 else if (STATUS_POSIX == 0)
2875 STATUS_POSIX_SET(255);
2884 register CONTEXT *cx;
2893 (void)UNLINK(e_tmpname);
2894 Safefree(e_tmpname);
2898 if (cxstack_ix >= 0) {