3 * Copyright (c) 1987-1998 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> */
34 dEXTCONST char rcsid[] = "perl.c\nPatch level: ###\n";
42 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
52 curcop = &compiling; \
59 laststype = OP_STAT; \
61 maxsysfd = MAXSYSFD; \
68 laststype = OP_STAT; \
72 static void find_beginning _((void));
73 static void forbid_setid _((char *));
74 static void incpush _((char *, int));
75 static void init_ids _((void));
76 static void init_debugger _((void));
77 static void init_lexer _((void));
78 static void init_main_stash _((void));
80 static struct perl_thread * init_main_thread _((void));
81 #endif /* USE_THREADS */
82 static void init_perllib _((void));
83 static void init_postdump_symbols _((int, char **, char **));
84 static void init_predump_symbols _((void));
85 static void my_exit_jump _((void)) __attribute__((noreturn));
86 static void nuke_stacks _((void));
87 static void open_script _((char *, bool, SV *));
88 static void usage _((char *));
89 static void validate_suid _((char *, char*));
90 static I32 read_e_script _((int idx, SV *buf_sv, int maxlen));
92 static int fdscript = -1;
97 PerlInterpreter *sv_interp;
100 New(53, sv_interp, 1, PerlInterpreter);
105 perl_construct(register PerlInterpreter *sv_interp)
110 struct perl_thread *thr;
111 #endif /* FAKE_THREADS */
112 #endif /* USE_THREADS */
114 if (!(curinterp = sv_interp))
118 Zero(sv_interp, 1, PerlInterpreter);
121 /* Init the real globals (and main thread)? */
126 #ifdef ALLOC_THREAD_KEY
129 if (pthread_key_create(&thr_key, 0))
130 croak("panic: pthread_key_create");
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);
141 #ifdef EMULATE_ATOMIC_REFCOUNTS
142 MUTEX_INIT(&svref_mutex);
143 #endif /* EMULATE_ATOMIC_REFCOUNTS */
145 thr = init_main_thread();
146 #endif /* USE_THREADS */
148 linestr = NEWSV(65,80);
149 sv_upgrade(linestr,SVt_PVIV);
151 if (!SvREADONLY(&sv_undef)) {
152 SvREADONLY_on(&sv_undef);
156 SvREADONLY_on(&sv_no);
158 sv_setpv(&sv_yes,Yes);
160 SvREADONLY_on(&sv_yes);
163 nrs = newSVpv("\n", 1);
164 rs = SvREFCNT_inc(nrs);
166 sighandlerp = sighandler;
171 * There is no way we can refer to them from Perl so close them to save
172 * space. The other alternative would be to provide STDAUX and STDPRN
175 (void)fclose(stdaux);
176 (void)fclose(stdprn);
183 perl_destruct_level = 1;
185 if(perl_destruct_level > 0)
190 lex_state = LEX_NOTPARSING;
192 start_env.je_prev = NULL;
193 start_env.je_ret = -1;
194 start_env.je_mustcatch = TRUE;
195 top_env = &start_env;
198 SET_NUMERIC_STANDARD();
199 #if defined(SUBVERSION) && SUBVERSION > 0
200 sprintf(patchlevel, "%7.5f", (double) 5
201 + ((double) PATCHLEVEL / (double) 1000)
202 + ((double) SUBVERSION / (double) 100000));
204 sprintf(patchlevel, "%5.3f", (double) 5 +
205 ((double) PATCHLEVEL / (double) 1000));
208 #if defined(LOCAL_PATCH_COUNT)
209 localpatches = local_patches; /* For possible -v */
212 PerlIO_init(); /* Hook to IO system */
214 fdpid = newAV(); /* for remembering popen pids by fd */
215 modglobal = newHV(); /* pointers to per-interpreter module globals */
218 New(51,debname,128,char);
219 New(52,debdelim,128,char);
226 perl_destruct(register PerlInterpreter *sv_interp)
229 int destruct_level; /* 0=none, 1=full, 2=full with checks */
234 #endif /* USE_THREADS */
236 if (!(curinterp = sv_interp))
241 /* Pass 1 on any remaining threads: detach joinables, join zombies */
243 MUTEX_LOCK(&threads_mutex);
244 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
245 "perl_destruct: waiting for %d threads...\n",
247 for (t = thr->next; t != thr; t = t->next) {
248 MUTEX_LOCK(&t->mutex);
249 switch (ThrSTATE(t)) {
252 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
253 "perl_destruct: joining zombie %p\n", t));
254 ThrSETSTATE(t, THRf_DEAD);
255 MUTEX_UNLOCK(&t->mutex);
258 * The SvREFCNT_dec below may take a long time (e.g. av
259 * may contain an object scalar whose destructor gets
260 * called) so we have to unlock threads_mutex and start
263 MUTEX_UNLOCK(&threads_mutex);
265 SvREFCNT_dec((SV*)av);
266 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
267 "perl_destruct: joined zombie %p OK\n", t));
269 case THRf_R_JOINABLE:
270 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
271 "perl_destruct: detaching thread %p\n", t));
272 ThrSETSTATE(t, THRf_R_DETACHED);
274 * We unlock threads_mutex and t->mutex in the opposite order
275 * from which we locked them just so that DETACH won't
276 * deadlock if it panics. It's only a breach of good style
277 * not a bug since they are unlocks not locks.
279 MUTEX_UNLOCK(&threads_mutex);
281 MUTEX_UNLOCK(&t->mutex);
284 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
285 "perl_destruct: ignoring %p (state %u)\n",
287 MUTEX_UNLOCK(&t->mutex);
288 /* fall through and out */
291 /* We leave the above "Pass 1" loop with threads_mutex still locked */
293 /* Pass 2 on remaining threads: wait for the thread count to drop to one */
296 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
297 "perl_destruct: final wait for %d threads\n",
299 COND_WAIT(&nthreads_cond, &threads_mutex);
301 /* At this point, we're the last thread */
302 MUTEX_UNLOCK(&threads_mutex);
303 DEBUG_L(PerlIO_printf(PerlIO_stderr(), "perl_destruct: armageddon has arrived\n"));
304 MUTEX_DESTROY(&threads_mutex);
305 COND_DESTROY(&nthreads_cond);
306 #endif /* !defined(FAKE_THREADS) */
307 #endif /* USE_THREADS */
309 destruct_level = perl_destruct_level;
313 if (s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL")) {
315 if (destruct_level < i)
324 /* We must account for everything. */
326 /* Destroy the main CV and syntax tree */
328 curpad = AvARRAY(comppad);
334 SvREFCNT_dec(main_cv);
339 * Try to destruct global references. We do this first so that the
340 * destructors and destructees still exist. Some sv's might remain.
341 * Non-referenced objects are on their own.
348 /* unhook hooks which will soon be, or use, destroyed data */
349 SvREFCNT_dec(warnhook);
351 SvREFCNT_dec(diehook);
353 SvREFCNT_dec(parsehook);
356 /* call exit list functions */
357 while (exitlistlen-- > 0)
358 exitlist[exitlistlen].fn(exitlist[exitlistlen].ptr);
362 if (destruct_level == 0){
364 DEBUG_P(debprofdump());
366 /* The exit() function will do everything that needs doing. */
370 /* loosen bonds of global variables */
373 (void)PerlIO_close(rsfp);
377 /* Filters for program text */
378 SvREFCNT_dec(rsfp_filters);
379 rsfp_filters = Nullav;
391 sawampersand = FALSE; /* must save all match strings */
392 sawstudy = FALSE; /* do fbm_instr on all strings */
400 SvREFCNT_dec(e_script);
404 /* magical thingies */
406 Safefree(ofs); /* $, */
409 Safefree(ors); /* $\ */
412 SvREFCNT_dec(nrs); /* $\ helper */
415 multiline = 0; /* $* */
417 SvREFCNT_dec(statname);
421 /* defgv, aka *_ should be taken care of elsewhere */
423 /* clean up after study() */
424 SvREFCNT_dec(lastscream);
426 Safefree(screamfirst);
428 Safefree(screamnext);
431 /* startup and shutdown function lists */
432 SvREFCNT_dec(beginav);
434 SvREFCNT_dec(initav);
439 /* shortcuts just get cleared */
449 /* reset so print() ends up where we expect */
452 /* Prepare to destruct main symbol table. */
459 if (destruct_level >= 2) {
460 if (scopestack_ix != 0)
461 warn("Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
462 (long)scopestack_ix);
463 if (savestack_ix != 0)
464 warn("Unbalanced saves: %ld more saves than restores\n",
466 if (tmps_floor != -1)
467 warn("Unbalanced tmps: %ld more allocs than frees\n",
468 (long)tmps_floor + 1);
469 if (cxstack_ix != -1)
470 warn("Unbalanced context: %ld more PUSHes than POPs\n",
471 (long)cxstack_ix + 1);
474 /* Now absolutely destruct everything, somehow or other, loops or no. */
476 SvFLAGS(strtab) |= SVTYPEMASK; /* don't clean out strtab now */
477 while (sv_count != 0 && sv_count != last_sv_count) {
478 last_sv_count = sv_count;
481 SvFLAGS(strtab) &= ~SVTYPEMASK;
482 SvFLAGS(strtab) |= SVt_PVHV;
484 /* Destruct the global string table. */
486 /* Yell and reset the HeVAL() slots that are still holding refcounts,
487 * so that sv_free() won't fail on them.
496 array = HvARRAY(strtab);
500 warn("Unbalanced string table refcount: (%d) for \"%s\"",
501 HeVAL(hent) - Nullsv, HeKEY(hent));
502 HeVAL(hent) = Nullsv;
512 SvREFCNT_dec(strtab);
515 warn("Scalars leaked: %ld\n", (long)sv_count);
519 /* No SVs have survived, need to clean out */
523 Safefree(origfilename);
525 hints = 0; /* Reset hints. Should hints be per-interpreter ? */
527 DEBUG_P(debprofdump());
529 MUTEX_DESTROY(&sv_mutex);
530 MUTEX_DESTROY(&eval_mutex);
531 COND_DESTROY(&eval_cond);
533 /* As the penultimate thing, free the non-arena SV for thrsv */
534 Safefree(SvPVX(thrsv));
535 Safefree(SvANY(thrsv));
538 #endif /* USE_THREADS */
540 /* As the absolutely last thing, free the non-arena SV for mess() */
543 /* we know that type >= SVt_PV */
545 Safefree(SvPVX(mess_sv));
546 Safefree(SvANY(mess_sv));
553 perl_free(PerlInterpreter *sv_interp)
555 if (!(curinterp = sv_interp))
561 perl_atexit(void (*fn) (void *), void *ptr)
563 Renew(exitlist, exitlistlen+1, PerlExitListEntry);
564 exitlist[exitlistlen].fn = fn;
565 exitlist[exitlistlen].ptr = ptr;
570 perl_parse(PerlInterpreter *sv_interp, void (*xsinit) (void), int argc, char **argv, char **env)
575 char *scriptname = NULL;
576 VOL bool dosearch = FALSE;
583 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
586 croak("suidperl is no longer needed since the kernel can now execute\n\
587 setuid perl scripts securely.\n");
591 if (!(curinterp = sv_interp))
594 #if defined(NeXT) && defined(__DYNAMIC__)
595 _dyld_lookup_and_bind
596 ("__environ", (unsigned long *) &environ_pointer, NULL);
601 #ifndef VMS /* VMS doesn't have environ array */
602 origenviron = environ;
607 /* Come here if running an undumped a.out. */
609 origfilename = savepv(argv[0]);
611 cxstack_ix = -1; /* start label stack again */
613 init_postdump_symbols(argc,argv,env);
618 curpad = AvARRAY(comppad);
623 SvREFCNT_dec(main_cv);
627 oldscope = scopestack_ix;
635 /* my_exit() was called */
636 while (scopestack_ix > oldscope)
641 call_list(oldscope, endav);
643 return STATUS_NATIVE_EXPORT;
646 PerlIO_printf(PerlIO_stderr(), "panic: top_env\n");
650 sv_setpvn(linestr,"",0);
651 sv = newSVpv("",0); /* first used for -I flags */
655 for (argc--,argv++; argc > 0; argc--,argv++) {
656 if (argv[0][0] != '-' || !argv[0][1])
660 validarg = " PHOOEY ";
686 if (s = moreswitches(s))
696 if (euid != uid || egid != gid)
697 croak("No -e allowed in setuid scripts");
699 e_script = newSVpv("",0);
700 filter_add(read_e_script, NULL);
703 sv_catpv(e_script, s);
705 sv_catpv(e_script, argv[1]);
709 croak("No code specified for -e");
710 sv_catpv(e_script, "\n");
713 case 'I': /* -I handled both here and in moreswitches() */
715 if (!*++s && (s=argv[1]) != Nullch) {
718 while (s && isSPACE(*s))
722 for (e = s; *e && !isSPACE(*e); e++) ;
729 } /* XXX else croak? */
743 preambleav = newAV();
744 av_push(preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
746 Sv = newSVpv("print myconfig();",0);
748 sv_catpv(Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
750 sv_catpv(Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
752 #if defined(DEBUGGING) || defined(NO_EMBED) || defined(MULTIPLICITY)
753 sv_catpv(Sv,"\" Compile-time options:");
755 sv_catpv(Sv," DEBUGGING");
758 sv_catpv(Sv," NO_EMBED");
761 sv_catpv(Sv," MULTIPLICITY");
763 sv_catpv(Sv,"\\n\",");
765 #if defined(LOCAL_PATCH_COUNT)
766 if (LOCAL_PATCH_COUNT > 0) {
768 sv_catpv(Sv,"\" Locally applied patches:\\n\",");
769 for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
771 sv_catpvf(Sv,"\" \\t%s\\n\",",localpatches[i]);
775 sv_catpvf(Sv,"\" Built under %s\\n\"",OSNAME);
778 sv_catpvf(Sv,",\" Compiled at %s %s\\n\"",__DATE__,__TIME__);
780 sv_catpvf(Sv,",\" Compiled on %s\\n\"",__DATE__);
785 @env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; \
786 print \" \\%ENV:\\n @env\\n\" if @env; \
787 print \" \\@INC:\\n @INC\\n\";");
790 Sv = newSVpv("config_vars(qw(",0);
795 av_push(preambleav, Sv);
796 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
807 if (!*++s || isSPACE(*s)) {
811 /* catch use of gnu style long options */
812 if (strEQ(s, "version")) {
816 if (strEQ(s, "help")) {
823 croak("Unrecognized switch: -%s (-h will show valid options)",s);
828 if (!tainting && (s = PerlEnv_getenv("PERL5OPT"))) {
839 if (!strchr("DIMUdmw", *s))
840 croak("Illegal switch in PERL5OPT: -%c", *s);
846 scriptname = argv[0];
849 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
851 else if (scriptname == Nullch) {
853 if ( PerlLIO_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) || defined(DJGPP)
901 init_predump_symbols();
902 /* init_postdump_symbols not currently designed to be called */
903 /* more than once (ENV isn't cleared first, for example) */
904 /* But running with -u leaves %ENV & @ARGV undefined! XXX */
906 init_postdump_symbols(argc,argv,env);
910 /* now parse the script */
912 SETERRNO(0,SS$_NORMAL);
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 SvREFCNT_dec(e_script);
930 /* now that script is parsed, we can modify record separator */
932 rs = SvREFCNT_inc(nrs);
933 sv_setsv(perl_get_sv("/", TRUE), rs);
944 if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
945 dump_mstats("after compilation:");
955 perl_run(PerlInterpreter *sv_interp)
962 if (!(curinterp = sv_interp))
965 oldscope = scopestack_ix;
970 cxstack_ix = -1; /* start context stack again */
973 /* my_exit() was called */
974 while (scopestack_ix > oldscope)
979 call_list(oldscope, endav);
981 if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
982 dump_mstats("after execution: ");
985 return STATUS_NATIVE_EXPORT;
988 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
993 POPSTACK_TO(mainstack);
997 DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
998 sawampersand ? "Enabling" : "Omitting"));
1001 DEBUG_x(dump_all());
1002 DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
1004 DEBUG_L(PerlIO_printf(Perl_debug_log, "main thread is 0x%lx\n",
1005 (unsigned long) thr));
1006 #endif /* USE_THREADS */
1009 PerlIO_printf(PerlIO_stderr(), "%s syntax OK\n", origfilename);
1012 if (PERLDB_SINGLE && DBsingle)
1013 sv_setiv(DBsingle, 1);
1015 call_list(oldscope, initav);
1025 else if (main_start) {
1026 CvDEPTH(main_cv) = 1;
1037 perl_get_sv(char *name, I32 create)
1041 if (name[1] == '\0' && !isALPHA(name[0])) {
1042 PADOFFSET tmp = find_threadsv(name);
1043 if (tmp != NOT_IN_PAD) {
1045 return THREADSV(tmp);
1048 #endif /* USE_THREADS */
1049 gv = gv_fetchpv(name, create, SVt_PV);
1056 perl_get_av(char *name, I32 create)
1058 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
1067 perl_get_hv(char *name, I32 create)
1069 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
1078 perl_get_cv(char *name, I32 create)
1080 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
1081 if (create && !GvCVu(gv))
1082 return newSUB(start_subparse(FALSE, 0),
1083 newSVOP(OP_CONST, 0, newSVpv(name,0)),
1091 /* Be sure to refetch the stack pointer after calling these routines. */
1094 perl_call_argv(char *sub_name, I32 flags, register char **argv)
1096 /* See G_* flags in cop.h */
1097 /* null terminated arg list */
1104 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
1109 return perl_call_pv(sub_name, flags);
1113 perl_call_pv(char *sub_name, I32 flags)
1114 /* name of the subroutine */
1115 /* See G_* flags in cop.h */
1117 return perl_call_sv((SV*)perl_get_cv(sub_name, TRUE), flags);
1121 perl_call_method(char *methname, I32 flags)
1122 /* name of the subroutine */
1123 /* See G_* flags in cop.h */
1129 XPUSHs(sv_2mortal(newSVpv(methname,0)));
1134 return perl_call_sv(*stack_sp--, flags);
1137 /* May be called with any of a CV, a GV, or an SV containing the name. */
1139 perl_call_sv(SV *sv, I32 flags)
1141 /* See G_* flags in cop.h */
1144 LOGOP myop; /* fake syntax tree node */
1149 bool oldcatch = CATCH_GET;
1154 if (flags & G_DISCARD) {
1159 Zero(&myop, 1, LOGOP);
1160 myop.op_next = Nullop;
1161 if (!(flags & G_NOARGS))
1162 myop.op_flags |= OPf_STACKED;
1163 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1164 (flags & G_ARRAY) ? OPf_WANT_LIST :
1169 EXTEND(stack_sp, 1);
1172 oldscope = scopestack_ix;
1174 if (PERLDB_SUB && curstash != debstash
1175 /* Handle first BEGIN of -d. */
1176 && (DBcv || (DBcv = GvCV(DBsub)))
1177 /* Try harder, since this may have been a sighandler, thus
1178 * curstash may be meaningless. */
1179 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != debstash)
1180 && !(flags & G_NODEBUG))
1181 op->op_private |= OPpENTERSUB_DB;
1183 if (flags & G_EVAL) {
1184 cLOGOP->op_other = op;
1186 /* we're trying to emulate pp_entertry() here */
1188 register PERL_CONTEXT *cx;
1189 I32 gimme = GIMME_V;
1194 push_return(op->op_next);
1195 PUSHBLOCK(cx, CXt_EVAL, stack_sp);
1197 eval_root = op; /* Only needed so that goto works right. */
1200 if (flags & G_KEEPERR)
1215 /* my_exit() was called */
1216 curstash = defstash;
1220 croak("Callback called exit");
1229 stack_sp = stack_base + oldmark;
1230 if (flags & G_ARRAY)
1234 *++stack_sp = &sv_undef;
1242 if (op == (OP*)&myop)
1243 op = pp_entersub(ARGS);
1246 retval = stack_sp - (stack_base + oldmark);
1247 if ((flags & G_EVAL) && !(flags & G_KEEPERR))
1251 if (flags & G_EVAL) {
1252 if (scopestack_ix > oldscope) {
1256 register PERL_CONTEXT *cx;
1268 CATCH_SET(oldcatch);
1270 if (flags & G_DISCARD) {
1271 stack_sp = stack_base + oldmark;
1280 /* Eval a string. The G_EVAL flag is always assumed. */
1283 perl_eval_sv(SV *sv, I32 flags)
1285 /* See G_* flags in cop.h */
1288 UNOP myop; /* fake syntax tree node */
1289 I32 oldmark = SP - stack_base;
1296 if (flags & G_DISCARD) {
1304 EXTEND(stack_sp, 1);
1306 oldscope = scopestack_ix;
1308 if (!(flags & G_NOARGS))
1309 myop.op_flags = OPf_STACKED;
1310 myop.op_next = Nullop;
1311 myop.op_type = OP_ENTEREVAL;
1312 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1313 (flags & G_ARRAY) ? OPf_WANT_LIST :
1315 if (flags & G_KEEPERR)
1316 myop.op_flags |= OPf_SPECIAL;
1326 /* my_exit() was called */
1327 curstash = defstash;
1331 croak("Callback called exit");
1340 stack_sp = stack_base + oldmark;
1341 if (flags & G_ARRAY)
1345 *++stack_sp = &sv_undef;
1350 if (op == (OP*)&myop)
1351 op = pp_entereval(ARGS);
1354 retval = stack_sp - (stack_base + oldmark);
1355 if (!(flags & G_KEEPERR))
1360 if (flags & G_DISCARD) {
1361 stack_sp = stack_base + oldmark;
1371 perl_eval_pv(char *p, I32 croak_on_error)
1374 SV* sv = newSVpv(p, 0);
1377 perl_eval_sv(sv, G_SCALAR);
1384 if (croak_on_error && SvTRUE(ERRSV))
1385 croak(SvPVx(ERRSV, na));
1390 /* Require a module. */
1393 perl_require_pv(char *pv)
1395 SV* sv = sv_newmortal();
1396 sv_setpv(sv, "require '");
1399 perl_eval_sv(sv, G_DISCARD);
1403 magicname(char *sym, char *name, I32 namlen)
1407 if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
1408 sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
1412 usage(char *name) /* XXX move this out into a module ? */
1415 /* This message really ought to be max 23 lines.
1416 * Removed -h because the user already knows that opton. Others? */
1418 static char *usage[] = {
1419 "-0[octal] specify record separator (\\0, if no argument)",
1420 "-a autosplit mode with -n or -p (splits $_ into @F)",
1421 "-c check syntax only (runs BEGIN and END blocks)",
1422 "-d[:debugger] run scripts under debugger",
1423 "-D[number/list] set debugging flags (argument is a bit mask or flags)",
1424 "-e 'command' one line of script. Several -e's allowed. Omit [programfile].",
1425 "-F/pattern/ split() pattern for autosplit (-a). The //'s are optional.",
1426 "-i[extension] edit <> files in place (make backup if extension supplied)",
1427 "-Idirectory specify @INC/#include directory (may be used more than once)",
1428 "-l[octal] enable line ending processing, specifies line terminator",
1429 "-[mM][-]module.. executes `use/no module...' before executing your script.",
1430 "-n assume 'while (<>) { ... }' loop around your script",
1431 "-p assume loop like -n but print line also like sed",
1432 "-P run script through C preprocessor before compilation",
1433 "-s enable some switch parsing for switches after script name",
1434 "-S look for the script using PATH environment variable",
1435 "-T turn on tainting checks",
1436 "-u dump core after parsing script",
1437 "-U allow unsafe operations",
1438 "-v print version number, patchlevel plus VERY IMPORTANT perl info",
1439 "-V[:variable] print perl configuration information",
1440 "-w TURN WARNINGS ON FOR COMPILATION OF YOUR SCRIPT. Recommended.",
1441 "-x[directory] strip off text before #!perl line and perhaps cd to directory",
1447 printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
1449 printf("\n %s", *p++);
1452 /* This routine handles any switches that can be given during run */
1455 moreswitches(char *s)
1464 rschar = scan_oct(s, 4, &numlen);
1466 if (rschar & ~((U8)~0))
1468 else if (!rschar && numlen >= 2)
1469 nrs = newSVpv("", 0);
1472 nrs = newSVpv(&ch, 1);
1478 splitstr = savepv(s + 1);
1492 if (*s == ':' || *s == '=') {
1493 my_setenv("PERL5DB", form("use Devel::%s;", ++s));
1497 perldb = PERLDB_ALL;
1504 if (isALPHA(s[1])) {
1505 static char debopts[] = "psltocPmfrxuLHXD";
1508 for (s++; *s && (d = strchr(debopts,*s)); s++)
1509 debug |= 1 << (d - debopts);
1513 for (s++; isDIGIT(*s); s++) ;
1515 debug |= 0x80000000;
1517 warn("Recompile perl with -DDEBUGGING to use -D switch\n");
1518 for (s++; isALNUM(*s); s++) ;
1528 inplace = savepv(s+1);
1530 for (s = inplace; *s && !isSPACE(*s); s++) ;
1533 if (*s == '-') /* Additional switches on #! line. */
1537 case 'I': /* -I handled both here and in parse_perl() */
1540 while (*s && isSPACE(*s))
1544 for (e = s; *e && !isSPACE(*e); e++) ;
1545 p = savepvn(s, e-s);
1551 croak("No space allowed after -I");
1561 *ors = scan_oct(s, 3 + (*s == '0'), &numlen);
1571 ors = SvPV(nrs, orslen);
1572 ors = savepvn(ors, orslen);
1576 forbid_setid("-M"); /* XXX ? */
1579 forbid_setid("-m"); /* XXX ? */
1584 /* -M-foo == 'no foo' */
1585 if (*s == '-') { use = "no "; ++s; }
1586 sv = newSVpv(use,0);
1588 /* We allow -M'Module qw(Foo Bar)' */
1589 while(isALNUM(*s) || *s==':') ++s;
1591 sv_catpv(sv, start);
1592 if (*(start-1) == 'm') {
1594 croak("Can't use '%c' after -mname", *s);
1595 sv_catpv( sv, " ()");
1598 sv_catpvn(sv, start, s-start);
1599 sv_catpv(sv, " split(/,/,q{");
1604 if (preambleav == NULL)
1605 preambleav = newAV();
1606 av_push(preambleav, sv);
1609 croak("No space allowed after -%c", *(s-1));
1626 croak("Too late for \"-T\" option");
1638 #if defined(SUBVERSION) && SUBVERSION > 0
1639 printf("\nThis is perl, version 5.%03d_%02d built for %s",
1640 PATCHLEVEL, SUBVERSION, ARCHNAME);
1642 printf("\nThis is perl, version %s built for %s",
1643 patchlevel, ARCHNAME);
1645 #if defined(LOCAL_PATCH_COUNT)
1646 if (LOCAL_PATCH_COUNT > 0)
1647 printf("\n(with %d registered patch%s, see perl -V for more detail)",
1648 LOCAL_PATCH_COUNT, (LOCAL_PATCH_COUNT!=1) ? "es" : "");
1651 printf("\n\nCopyright 1987-1998, Larry Wall\n");
1653 printf("\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
1656 printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n");
1657 printf("djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1998\n");
1660 printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
1661 "Version 5 port Copyright (c) 1994-1998, Andreas Kaiser, Ilya Zakharevich\n");
1664 printf("atariST series port, ++jrb bammi@cadence.com\n");
1667 Perl may be copied only under the terms of either the Artistic License or the\n\
1668 GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n\
1669 Complete documentation for Perl, including FAQ lists, should be found on\n\
1670 this system using `man perl' or `perldoc perl'. If you have access to the\n\
1671 Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n");
1679 if (s[1] == '-') /* Additional switches on #! line. */
1690 #ifdef ALTERNATE_SHEBANG
1691 case 'S': /* OS/2 needs -S on "extproc" line. */
1699 croak("Can't emulate -%.1s on #! line",s);
1704 /* compliments of Tom Christiansen */
1706 /* unexec() can be found in the Gnu emacs distribution */
1707 /* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
1718 prog = newSVpv(BIN_EXP, 0);
1719 sv_catpv(prog, "/perl");
1720 file = newSVpv(origfilename, 0);
1721 sv_catpv(file, ".perldump");
1723 unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
1724 /* unexec prints msg to stderr in case of failure */
1725 PerlProc_exit(status);
1728 # include <lib$routines.h>
1729 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
1731 ABORT(); /* for use with undump */
1737 init_main_stash(void)
1742 /* Note that strtab is a rather special HV. Assumptions are made
1743 about not iterating on it, and not adding tie magic to it.
1744 It is properly deallocated in perl_destruct() */
1746 HvSHAREKEYS_off(strtab); /* mandatory */
1747 Newz(506,((XPVHV*)SvANY(strtab))->xhv_array,
1748 sizeof(HE*) * (((XPVHV*)SvANY(strtab))->xhv_max + 1), char);
1750 curstash = defstash = newHV();
1751 curstname = newSVpv("main",4);
1752 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
1753 SvREFCNT_dec(GvHV(gv));
1754 GvHV(gv) = (HV*)SvREFCNT_inc(defstash);
1756 HvNAME(defstash) = savepv("main");
1757 incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
1759 defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
1760 errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
1762 (void)form("%240s",""); /* Preallocate temp - for immediate signals. */
1763 sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */
1764 sv_setpvn(ERRSV, "", 0);
1765 curstash = defstash;
1766 compiling.cop_stash = defstash;
1767 debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
1768 globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
1769 /* We must init $/ before switches are processed. */
1770 sv_setpvn(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), "\n", 1);
1774 open_script(char *scriptname, bool dosearch, SV *sv)
1779 scriptname = find_script(scriptname, dosearch, NULL, 0);
1781 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
1782 char *s = scriptname + 8;
1791 origfilename = savepv(e_script ? "-e" : scriptname);
1792 curcop->cop_filegv = gv_fetchfile(origfilename);
1793 if (strEQ(origfilename,"-"))
1795 if (fdscript >= 0) {
1796 rsfp = PerlIO_fdopen(fdscript,PERL_SCRIPT_MODE);
1797 #if defined(HAS_FCNTL) && defined(F_SETFD)
1799 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
1802 else if (preprocess) {
1803 char *cpp_cfg = CPPSTDIN;
1804 SV *cpp = NEWSV(0,0);
1805 SV *cmd = NEWSV(0,0);
1807 if (strEQ(cpp_cfg, "cppstdin"))
1808 sv_catpvf(cpp, "%s/", BIN_EXP);
1809 sv_catpv(cpp, cpp_cfg);
1812 sv_catpv(sv,PRIVLIB_EXP);
1816 sed %s -e \"/^[^#]/b\" \
1817 -e \"/^#[ ]*include[ ]/b\" \
1818 -e \"/^#[ ]*define[ ]/b\" \
1819 -e \"/^#[ ]*if[ ]/b\" \
1820 -e \"/^#[ ]*ifdef[ ]/b\" \
1821 -e \"/^#[ ]*ifndef[ ]/b\" \
1822 -e \"/^#[ ]*else/b\" \
1823 -e \"/^#[ ]*elif[ ]/b\" \
1824 -e \"/^#[ ]*undef[ ]/b\" \
1825 -e \"/^#[ ]*endif/b\" \
1828 (doextract ? "-e \"1,/^#/d\n\"" : ""),
1831 %s %s -e '/^[^#]/b' \
1832 -e '/^#[ ]*include[ ]/b' \
1833 -e '/^#[ ]*define[ ]/b' \
1834 -e '/^#[ ]*if[ ]/b' \
1835 -e '/^#[ ]*ifdef[ ]/b' \
1836 -e '/^#[ ]*ifndef[ ]/b' \
1837 -e '/^#[ ]*else/b' \
1838 -e '/^#[ ]*elif[ ]/b' \
1839 -e '/^#[ ]*undef[ ]/b' \
1840 -e '/^#[ ]*endif/b' \
1848 (doextract ? "-e '1,/^#/d\n'" : ""),
1850 scriptname, cpp, sv, CPPMINUS);
1852 #ifdef IAMSUID /* actually, this is caught earlier */
1853 if (euid != uid && !euid) { /* if running suidperl */
1855 (void)seteuid(uid); /* musn't stay setuid root */
1858 (void)setreuid((Uid_t)-1, uid);
1860 #ifdef HAS_SETRESUID
1861 (void)setresuid((Uid_t)-1, uid, (Uid_t)-1);
1867 if (geteuid() != uid)
1868 croak("Can't do seteuid!\n");
1870 #endif /* IAMSUID */
1871 rsfp = PerlProc_popen(SvPVX(cmd), "r");
1875 else if (!*scriptname) {
1876 forbid_setid("program input from stdin");
1877 rsfp = PerlIO_stdin();
1880 rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
1881 #if defined(HAS_FCNTL) && defined(F_SETFD)
1883 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
1888 #ifndef IAMSUID /* in case script is not readable before setuid */
1889 if (euid && PerlLIO_stat(SvPVX(GvSV(curcop->cop_filegv)),&statbuf) >= 0 &&
1890 statbuf.st_mode & (S_ISUID|S_ISGID)) {
1892 PerlProc_execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
1893 croak("Can't do setuid\n");
1897 croak("Can't open perl script \"%s\": %s\n",
1898 SvPVX(GvSV(curcop->cop_filegv)), Strerror(errno));
1903 validate_suid(char *validarg, char *scriptname)
1907 /* do we need to emulate setuid on scripts? */
1909 /* This code is for those BSD systems that have setuid #! scripts disabled
1910 * in the kernel because of a security problem. Merely defining DOSUID
1911 * in perl will not fix that problem, but if you have disabled setuid
1912 * scripts in the kernel, this will attempt to emulate setuid and setgid
1913 * on scripts that have those now-otherwise-useless bits set. The setuid
1914 * root version must be called suidperl or sperlN.NNN. If regular perl
1915 * discovers that it has opened a setuid script, it calls suidperl with
1916 * the same argv that it had. If suidperl finds that the script it has
1917 * just opened is NOT setuid root, it sets the effective uid back to the
1918 * uid. We don't just make perl setuid root because that loses the
1919 * effective uid we had before invoking perl, if it was different from the
1922 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
1923 * be defined in suidperl only. suidperl must be setuid root. The
1924 * Configure script will set this up for you if you want it.
1931 if (PerlLIO_fstat(PerlIO_fileno(rsfp),&statbuf) < 0) /* normal stat is insecure */
1932 croak("Can't stat script \"%s\"",origfilename);
1933 if (fdscript < 0 && statbuf.st_mode & (S_ISUID|S_ISGID)) {
1937 #ifndef HAS_SETREUID
1938 /* On this access check to make sure the directories are readable,
1939 * there is actually a small window that the user could use to make
1940 * filename point to an accessible directory. So there is a faint
1941 * chance that someone could execute a setuid script down in a
1942 * non-accessible directory. I don't know what to do about that.
1943 * But I don't think it's too important. The manual lies when
1944 * it says access() is useful in setuid programs.
1946 if (PerlLIO_access(SvPVX(GvSV(curcop->cop_filegv)),1)) /*double check*/
1947 croak("Permission denied");
1949 /* If we can swap euid and uid, then we can determine access rights
1950 * with a simple stat of the file, and then compare device and
1951 * inode to make sure we did stat() on the same file we opened.
1952 * Then we just have to make sure he or she can execute it.
1955 struct stat tmpstatbuf;
1959 setreuid(euid,uid) < 0
1962 setresuid(euid,uid,(Uid_t)-1) < 0
1965 || getuid() != euid || geteuid() != uid)
1966 croak("Can't swap uid and euid"); /* really paranoid */
1967 if (PerlLIO_stat(SvPVX(GvSV(curcop->cop_filegv)),&tmpstatbuf) < 0)
1968 croak("Permission denied"); /* testing full pathname here */
1969 if (tmpstatbuf.st_dev != statbuf.st_dev ||
1970 tmpstatbuf.st_ino != statbuf.st_ino) {
1971 (void)PerlIO_close(rsfp);
1972 if (rsfp = PerlProc_popen("/bin/mail root","w")) { /* heh, heh */
1974 "User %ld tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
1975 (Filename of set-id script was %s, uid %ld gid %ld.)\n\nSincerely,\nperl\n",
1976 (long)uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
1977 (long)statbuf.st_dev, (long)statbuf.st_ino,
1978 SvPVX(GvSV(curcop->cop_filegv)),
1979 (long)statbuf.st_uid, (long)statbuf.st_gid);
1980 (void)PerlProc_pclose(rsfp);
1982 croak("Permission denied\n");
1986 setreuid(uid,euid) < 0
1988 # if defined(HAS_SETRESUID)
1989 setresuid(uid,euid,(Uid_t)-1) < 0
1992 || getuid() != uid || geteuid() != euid)
1993 croak("Can't reswap uid and euid");
1994 if (!cando(S_IXUSR,FALSE,&statbuf)) /* can real uid exec? */
1995 croak("Permission denied\n");
1997 #endif /* HAS_SETREUID */
1998 #endif /* IAMSUID */
2000 if (!S_ISREG(statbuf.st_mode))
2001 croak("Permission denied");
2002 if (statbuf.st_mode & S_IWOTH)
2003 croak("Setuid/gid script is writable by world");
2004 doswitches = FALSE; /* -s is insecure in suid */
2006 if (sv_gets(linestr, rsfp, 0) == Nullch ||
2007 strnNE(SvPV(linestr,na),"#!",2) ) /* required even on Sys V */
2008 croak("No #! line");
2009 s = SvPV(linestr,na)+2;
2011 while (!isSPACE(*s)) s++;
2012 for (s2 = s; (s2 > SvPV(linestr,na)+2 &&
2013 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
2014 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
2015 croak("Not a perl script");
2016 while (*s == ' ' || *s == '\t') s++;
2018 * #! arg must be what we saw above. They can invoke it by
2019 * mentioning suidperl explicitly, but they may not add any strange
2020 * arguments beyond what #! says if they do invoke suidperl that way.
2022 len = strlen(validarg);
2023 if (strEQ(validarg," PHOOEY ") ||
2024 strnNE(s,validarg,len) || !isSPACE(s[len]))
2025 croak("Args must match #! line");
2028 if (euid != uid && (statbuf.st_mode & S_ISUID) &&
2029 euid == statbuf.st_uid)
2031 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2032 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2033 #endif /* IAMSUID */
2035 if (euid) { /* oops, we're not the setuid root perl */
2036 (void)PerlIO_close(rsfp);
2039 PerlProc_execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
2041 croak("Can't do setuid\n");
2044 if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid) {
2046 (void)setegid(statbuf.st_gid);
2049 (void)setregid((Gid_t)-1,statbuf.st_gid);
2051 #ifdef HAS_SETRESGID
2052 (void)setresgid((Gid_t)-1,statbuf.st_gid,(Gid_t)-1);
2054 setgid(statbuf.st_gid);
2058 if (getegid() != statbuf.st_gid)
2059 croak("Can't do setegid!\n");
2061 if (statbuf.st_mode & S_ISUID) {
2062 if (statbuf.st_uid != euid)
2064 (void)seteuid(statbuf.st_uid); /* all that for this */
2067 (void)setreuid((Uid_t)-1,statbuf.st_uid);
2069 #ifdef HAS_SETRESUID
2070 (void)setresuid((Uid_t)-1,statbuf.st_uid,(Uid_t)-1);
2072 setuid(statbuf.st_uid);
2076 if (geteuid() != statbuf.st_uid)
2077 croak("Can't do seteuid!\n");
2079 else if (uid) { /* oops, mustn't run as root */
2081 (void)seteuid((Uid_t)uid);
2084 (void)setreuid((Uid_t)-1,(Uid_t)uid);
2086 #ifdef HAS_SETRESUID
2087 (void)setresuid((Uid_t)-1,(Uid_t)uid,(Uid_t)-1);
2093 if (geteuid() != uid)
2094 croak("Can't do seteuid!\n");
2097 if (!cando(S_IXUSR,TRUE,&statbuf))
2098 croak("Permission denied\n"); /* they can't do this */
2101 else if (preprocess)
2102 croak("-P not allowed for setuid/setgid script\n");
2103 else if (fdscript >= 0)
2104 croak("fd script not allowed in suidperl\n");
2106 croak("Script is not setuid/setgid in suidperl\n");
2108 /* We absolutely must clear out any saved ids here, so we */
2109 /* exec the real perl, substituting fd script for scriptname. */
2110 /* (We pass script name as "subdir" of fd, which perl will grok.) */
2111 PerlIO_rewind(rsfp);
2112 PerlLIO_lseek(PerlIO_fileno(rsfp),(Off_t)0,0); /* just in case rewind didn't */
2113 for (which = 1; origargv[which] && origargv[which] != scriptname; which++) ;
2114 if (!origargv[which])
2115 croak("Permission denied");
2116 origargv[which] = savepv(form("/dev/fd/%d/%s",
2117 PerlIO_fileno(rsfp), origargv[which]));
2118 #if defined(HAS_FCNTL) && defined(F_SETFD)
2119 fcntl(PerlIO_fileno(rsfp),F_SETFD,0); /* ensure no close-on-exec */
2121 PerlProc_execv(form("%s/perl%s", BIN_EXP, patchlevel), origargv); /* try again */
2122 croak("Can't do setuid\n");
2123 #endif /* IAMSUID */
2125 if (euid != uid || egid != gid) { /* (suidperl doesn't exist, in fact) */
2126 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
2128 PerlLIO_fstat(PerlIO_fileno(rsfp),&statbuf); /* may be either wrapped or real suid */
2129 if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
2131 (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
2134 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2135 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2136 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
2137 /* not set-id, must be wrapped */
2143 find_beginning(void)
2145 register char *s, *s2;
2147 /* skip forward in input to the real script? */
2151 if ((s = sv_gets(linestr, rsfp, 0)) == Nullch)
2152 croak("No Perl script found in input\n");
2153 if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
2154 PerlIO_ungetc(rsfp, '\n'); /* to keep line count right */
2156 while (*s && !(isSPACE (*s) || *s == '#')) s++;
2158 while (*s == ' ' || *s == '\t') s++;
2160 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
2161 if (strnEQ(s2-4,"perl",4))
2163 while (s = moreswitches(s)) ;
2165 if (cddir && PerlDir_chdir(cddir) < 0)
2166 croak("Can't chdir to %s",cddir);
2173 read_e_script(int idx, SV *buf_sv, int maxlen)
2176 FILTER_READ(idx+1, buf_sv, maxlen);
2177 p = SvPVX(e_script);
2178 nl = strchr(p, '\n');
2179 nl = (nl) ? nl+1 : SvEND(e_script);
2182 sv_catpvn(buf_sv, p, nl-p);
2183 sv_chop(e_script, nl);
2191 uid = (int)getuid();
2192 euid = (int)geteuid();
2193 gid = (int)getgid();
2194 egid = (int)getegid();
2199 tainting |= (uid && (euid != uid || egid != gid));
2203 forbid_setid(char *s)
2206 croak("No %s allowed while running setuid", s);
2208 croak("No %s allowed while running setgid", s);
2215 curstash = debstash;
2216 dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
2218 DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
2219 DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
2220 DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
2221 DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
2222 sv_setiv(DBsingle, 0);
2223 DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
2224 sv_setiv(DBtrace, 0);
2225 DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
2226 sv_setiv(DBsignal, 0);
2227 curstash = defstash;
2230 #ifndef STRESS_REALLOC
2231 #define REASONABLE(size) (size)
2233 #define REASONABLE(size) (1) /* unreasonable */
2237 init_stacks(ARGSproto)
2239 /* start with 128-item stack and 8K cxstack */
2240 curstackinfo = new_stackinfo(REASONABLE(128),
2241 REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
2242 curstackinfo->si_type = SI_MAIN;
2243 curstack = curstackinfo->si_stack;
2244 mainstack = curstack; /* remember in case we switch stacks */
2246 stack_base = AvARRAY(curstack);
2247 stack_sp = stack_base;
2248 stack_max = stack_base + AvMAX(curstack);
2250 New(50,tmps_stack,REASONABLE(128),SV*);
2253 tmps_max = REASONABLE(128);
2256 * The following stacks almost certainly should be per-interpreter,
2257 * but for now they're not. XXX
2261 markstack_ptr = markstack;
2263 New(54,markstack,REASONABLE(32),I32);
2264 markstack_ptr = markstack;
2265 markstack_max = markstack + REASONABLE(32);
2273 New(54,scopestack,REASONABLE(32),I32);
2275 scopestack_max = REASONABLE(32);
2281 New(54,savestack,REASONABLE(128),ANY);
2283 savestack_max = REASONABLE(128);
2289 New(54,retstack,REASONABLE(16),OP*);
2291 retstack_max = REASONABLE(16);
2301 while (curstackinfo->si_next)
2302 curstackinfo = curstackinfo->si_next;
2303 while (curstackinfo) {
2304 PERL_SI *p = curstackinfo->si_prev;
2305 /* curstackinfo->si_stack got nuked by sv_free_arenas() */
2306 Safefree(curstackinfo->si_cxstack);
2307 Safefree(curstackinfo);
2310 Safefree(tmps_stack);
2317 static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
2326 subname = newSVpv("main",4);
2330 init_predump_symbols(void)
2336 sv_setpvn(perl_get_sv("\"", TRUE), " ", 1);
2337 stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
2338 GvMULTI_on(stdingv);
2339 IoIFP(GvIOp(stdingv)) = PerlIO_stdin();
2340 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
2342 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(stdingv));
2344 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
2346 IoOFP(GvIOp(tmpgv)) = IoIFP(GvIOp(tmpgv)) = PerlIO_stdout();
2348 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
2350 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(defoutgv));
2352 othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
2353 GvMULTI_on(othergv);
2354 IoOFP(GvIOp(othergv)) = IoIFP(GvIOp(othergv)) = PerlIO_stderr();
2355 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
2357 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(othergv));
2359 statname = NEWSV(66,0); /* last filename we did stat on */
2362 osname = savepv(OSNAME);
2366 init_postdump_symbols(register int argc, register char **argv, register char **env)
2373 argc--,argv++; /* skip name of script */
2375 for (; argc > 0 && **argv == '-'; argc--,argv++) {
2378 if (argv[0][1] == '-') {
2382 if (s = strchr(argv[0], '=')) {
2384 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
2387 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
2390 toptarget = NEWSV(0,0);
2391 sv_upgrade(toptarget, SVt_PVFM);
2392 sv_setpvn(toptarget, "", 0);
2393 bodytarget = NEWSV(0,0);
2394 sv_upgrade(bodytarget, SVt_PVFM);
2395 sv_setpvn(bodytarget, "", 0);
2396 formtarget = bodytarget;
2399 if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
2400 sv_setpv(GvSV(tmpgv),origfilename);
2401 magicname("0", "0", 1);
2403 if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
2404 sv_setpv(GvSV(tmpgv),origargv[0]);
2405 if (argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
2407 (void)gv_AVadd(argvgv);
2408 av_clear(GvAVn(argvgv));
2409 for (; argc > 0; argc--,argv++) {
2410 av_push(GvAVn(argvgv),newSVpv(argv[0],0));
2413 if (envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
2417 hv_magic(hv, envgv, 'E');
2418 #ifndef VMS /* VMS doesn't have environ array */
2419 /* Note that if the supplied env parameter is actually a copy
2420 of the global environ then it may now point to free'd memory
2421 if the environment has been modified since. To avoid this
2422 problem we treat env==NULL as meaning 'use the default'
2427 environ[0] = Nullch;
2428 for (; *env; env++) {
2429 if (!(s = strchr(*env,'=')))
2432 #if defined(WIN32) || defined(MSDOS)
2435 sv = newSVpv(s--,0);
2436 (void)hv_store(hv, *env, s - *env, sv, 0);
2438 #if defined(__BORLANDC__) && defined(USE_WIN32_RTL_ENV)
2439 /* Sins of the RTL. See note in my_setenv(). */
2440 (void)PerlEnv_putenv(savepv(*env));
2444 #ifdef DYNAMIC_ENV_FETCH
2445 HvNAME(hv) = savepv(ENV_HV_NAME);
2449 if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
2450 sv_setiv(GvSV(tmpgv), (IV)getpid());
2459 s = PerlEnv_getenv("PERL5LIB");
2463 incpush(PerlEnv_getenv("PERLLIB"), FALSE);
2465 /* Treat PERL5?LIB as a possible search list logical name -- the
2466 * "natural" VMS idiom for a Unix path string. We allow each
2467 * element to be a set of |-separated directories for compatibility.
2471 if (my_trnlnm("PERL5LIB",buf,0))
2472 do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
2474 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE);
2478 /* Use the ~-expanded versions of APPLLIB (undocumented),
2479 ARCHLIB PRIVLIB SITEARCH and SITELIB
2482 incpush(APPLLIB_EXP, TRUE);
2486 incpush(ARCHLIB_EXP, FALSE);
2489 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
2491 incpush(PRIVLIB_EXP, FALSE);
2494 incpush(SITEARCH_EXP, FALSE);
2497 incpush(SITELIB_EXP, FALSE);
2500 incpush(".", FALSE);
2504 # define PERLLIB_SEP ';'
2507 # define PERLLIB_SEP '|'
2509 # define PERLLIB_SEP ':'
2512 #ifndef PERLLIB_MANGLE
2513 # define PERLLIB_MANGLE(s,n) (s)
2517 incpush(char *p, int addsubdirs)
2519 SV *subdir = Nullsv;
2520 static char *archpat_auto;
2526 subdir = NEWSV(55,0);
2527 if (!archpat_auto) {
2528 STRLEN len = (sizeof(ARCHNAME) + strlen(patchlevel)
2529 + sizeof("//auto"));
2530 New(55, archpat_auto, len, char);
2531 sprintf(archpat_auto, "/%s/%s/auto", ARCHNAME, patchlevel);
2533 for (len = sizeof(ARCHNAME) + 2;
2534 archpat_auto[len] != '\0' && archpat_auto[len] != '/'; len++)
2535 if (archpat_auto[len] == '.') archpat_auto[len] = '_';
2540 /* Break at all separators */
2542 SV *libdir = NEWSV(55,0);
2545 /* skip any consecutive separators */
2546 while ( *p == PERLLIB_SEP ) {
2547 /* Uncomment the next line for PATH semantics */
2548 /* av_push(GvAVn(incgv), newSVpv(".", 1)); */
2552 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
2553 sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
2558 sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
2559 p = Nullch; /* break out */
2563 * BEFORE pushing libdir onto @INC we may first push version- and
2564 * archname-specific sub-directories.
2567 struct stat tmpstatbuf;
2572 if ((unix = tounixspec_ts(SvPV(libdir,na),Nullch)) != Nullch) {
2574 while (unix[len-1] == '/') len--; /* Cosmetic */
2575 sv_usepvn(libdir,unix,len);
2578 PerlIO_printf(PerlIO_stderr(),
2579 "Failed to unixify @INC element \"%s\"\n",
2582 /* .../archname/version if -d .../archname/version/auto */
2583 sv_setsv(subdir, libdir);
2584 sv_catpv(subdir, archpat_auto);
2585 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2586 S_ISDIR(tmpstatbuf.st_mode))
2587 av_push(GvAVn(incgv),
2588 newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2590 /* .../archname if -d .../archname/auto */
2591 sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME),
2592 strlen(patchlevel) + 1, "", 0);
2593 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2594 S_ISDIR(tmpstatbuf.st_mode))
2595 av_push(GvAVn(incgv),
2596 newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2599 /* finally push this lib directory on the end of @INC */
2600 av_push(GvAVn(incgv), libdir);
2603 SvREFCNT_dec(subdir);
2607 static struct perl_thread *
2610 struct perl_thread *thr;
2613 Newz(53, thr, 1, struct perl_thread);
2614 curcop = &compiling;
2615 thr->cvcache = newHV();
2616 thr->threadsv = newAV();
2617 /* thr->threadsvp is set when find_threadsv is called */
2618 thr->specific = newAV();
2619 thr->errhv = newHV();
2620 thr->flags = THRf_R_JOINABLE;
2621 MUTEX_INIT(&thr->mutex);
2622 /* Handcraft thrsv similarly to mess_sv */
2623 New(53, thrsv, 1, SV);
2624 Newz(53, xpv, 1, XPV);
2625 SvFLAGS(thrsv) = SVt_PV;
2626 SvANY(thrsv) = (void*)xpv;
2627 SvREFCNT(thrsv) = 1 << 30; /* practically infinite */
2628 SvPVX(thrsv) = (char*)thr;
2629 SvCUR_set(thrsv, sizeof(thr));
2630 SvLEN_set(thrsv, sizeof(thr));
2631 *SvEND(thrsv) = '\0'; /* in the trailing_nul field */
2635 MUTEX_LOCK(&threads_mutex);
2640 MUTEX_UNLOCK(&threads_mutex);
2642 #ifdef HAVE_THREAD_INTERN
2643 init_thread_intern(thr);
2646 #ifdef SET_THREAD_SELF
2647 SET_THREAD_SELF(thr);
2649 thr->self = pthread_self();
2650 #endif /* SET_THREAD_SELF */
2654 * These must come after the SET_THR because sv_setpvn does
2655 * SvTAINT and the taint fields require dTHR.
2657 toptarget = NEWSV(0,0);
2658 sv_upgrade(toptarget, SVt_PVFM);
2659 sv_setpvn(toptarget, "", 0);
2660 bodytarget = NEWSV(0,0);
2661 sv_upgrade(bodytarget, SVt_PVFM);
2662 sv_setpvn(bodytarget, "", 0);
2663 formtarget = bodytarget;
2664 thr->errsv = newSVpv("", 0);
2665 (void) find_threadsv("@"); /* Ensure $@ is initialised early */
2668 #endif /* USE_THREADS */
2671 call_list(I32 oldscope, AV *list)
2674 line_t oldline = curcop->cop_line;
2679 while (AvFILL(list) >= 0) {
2680 CV *cv = (CV*)av_shift(list);
2689 perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
2690 (void)SvPV(atsv, len);
2693 curcop = &compiling;
2694 curcop->cop_line = oldline;
2695 if (list == beginav)
2696 sv_catpv(atsv, "BEGIN failed--compilation aborted");
2698 sv_catpv(atsv, "END failed--cleanup aborted");
2699 while (scopestack_ix > oldscope)
2701 croak("%s", SvPVX(atsv));
2709 /* my_exit() was called */
2710 while (scopestack_ix > oldscope)
2713 curstash = defstash;
2715 call_list(oldscope, endav);
2717 curcop = &compiling;
2718 curcop->cop_line = oldline;
2720 if (list == beginav)
2721 croak("BEGIN failed--compilation aborted");
2723 croak("END failed--cleanup aborted");
2729 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
2734 curcop = &compiling;
2735 curcop->cop_line = oldline;
2748 DEBUG_L(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
2749 thr, (unsigned long) status));
2750 #endif /* USE_THREADS */
2759 STATUS_NATIVE_SET(status);
2766 my_failure_exit(void)
2769 if (vaxc$errno & 1) {
2770 if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
2771 STATUS_NATIVE_SET(44);
2774 if (!vaxc$errno && errno) /* unlikely */
2775 STATUS_NATIVE_SET(44);
2777 STATUS_NATIVE_SET(vaxc$errno);
2782 STATUS_POSIX_SET(errno);
2784 exitstatus = STATUS_POSIX >> 8;
2785 if (exitstatus & 255)
2786 STATUS_POSIX_SET(exitstatus);
2788 STATUS_POSIX_SET(255);
2798 register PERL_CONTEXT *cx;
2803 SvREFCNT_dec(e_script);
2807 POPSTACK_TO(mainstack);
2808 if (cxstack_ix >= 0) {