This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Typo in thread.h: ADD_THREAD_INTERN should be HAVE_THREAD_INTERN
[perl5.git] / perl.c
CommitLineData
a0d0e21e
LW
1/* perl.c
2 *
9607fc9c 3 * Copyright (c) 1987-1997 Larry Wall
a687059c 4 *
352d5a3a
LW
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.
a687059c 7 *
8d063cd8
LW
8 */
9
a0d0e21e
LW
10/*
11 * "A ship then new they built for him/of mithril and of elven glass" --Bilbo
12 */
45d8adaa 13
378cc40b
LW
14#include "EXTERN.h"
15#include "perl.h"
a687059c 16#include "patchlevel.h"
378cc40b 17
df5cef82 18/* XXX If this causes problems, set i_unistd=undef in the hint file. */
a0d0e21e
LW
19#ifdef I_UNISTD
20#include <unistd.h>
21#endif
a0d0e21e 22
54310121
PP
23#if !defined(STANDARD_C) && !defined(HAS_GETENV_PROTOTYPE)
24char *getenv _((char *)); /* Usually in <stdlib.h> */
25#endif
26
71be2cbc 27dEXTCONST char rcsid[] = "perl.c\nPatch level: ###\n";
463ee0b2 28
a687059c
LW
29#ifdef IAMSUID
30#ifndef DOSUID
31#define DOSUID
32#endif
33#endif
378cc40b 34
a687059c
LW
35#ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
36#ifdef DOSUID
37#undef DOSUID
38#endif
39#endif
8d063cd8 40
8ebc5c01
PP
41#define I_REINIT \
42 STMT_START { \
43 chopset = " \n-"; \
44 copline = NOLINE; \
45 curcop = &compiling; \
46 curcopdb = NULL; \
47 cxstack_ix = -1; \
48 cxstack_max = 128; \
49 dbargs = 0; \
50 dlmax = 128; \
51 laststatval = -1; \
52 laststype = OP_STAT; \
53 maxscream = -1; \
54 maxsysfd = MAXSYSFD; \
55 statname = Nullsv; \
56 tmps_floor = -1; \
57 tmps_ix = -1; \
58 op_mask = NULL; \
59 dlmax = 128; \
60 laststatval = -1; \
61 laststype = OP_STAT; \
46fc3d4c 62 mess_sv = Nullsv; \
8ebc5c01
PP
63 } STMT_END
64
a0d0e21e 65static void find_beginning _((void));
bbce6d69 66static void forbid_setid _((char *));
774d564b 67static void incpush _((char *, int));
748a9306 68static void init_ids _((void));
a0d0e21e
LW
69static void init_debugger _((void));
70static void init_lexer _((void));
71static void init_main_stash _((void));
199100c8
MB
72#ifdef USE_THREADS
73static struct thread * init_main_thread _((void));
74#endif /* USE_THREADS */
a0d0e21e
LW
75static void init_perllib _((void));
76static void init_postdump_symbols _((int, char **, char **));
77static void init_predump_symbols _((void));
f86702cc 78static void my_exit_jump _((void)) __attribute__((noreturn));
6e72f9df 79static void nuke_stacks _((void));
a0d0e21e 80static void open_script _((char *, bool, SV *));
ab821d7f 81static void usage _((char *));
96436eeb
PP
82static void validate_suid _((char *, char*));
83
84static int fdscript = -1;
79072805 85
77a005ab
MB
86#if defined(DEBUGGING) && defined(USE_THREADS) && defined(__linux__)
87#include <asm/sigcontext.h>
88static void
89catch_sigsegv(int signo, struct sigcontext_struct sc)
90{
91 signal(SIGSEGV, SIG_DFL);
92 fprintf(stderr, "Segmentation fault dereferencing 0x%lx\n"
93 "return_address = 0x%lx, eip = 0x%lx\n",
94 sc.cr2, __builtin_return_address(0), sc.eip);
95 fprintf(stderr, "thread = 0x%lx\n", (unsigned long)THR);
96}
97#endif
98
93a17b20 99PerlInterpreter *
8ac85365 100perl_alloc(void)
79072805 101{
93a17b20 102 PerlInterpreter *sv_interp;
79072805 103
8990e307 104 curinterp = 0;
93a17b20 105 New(53, sv_interp, 1, PerlInterpreter);
79072805
LW
106 return sv_interp;
107}
108
109void
8ac85365 110perl_construct(register PerlInterpreter *sv_interp)
79072805 111{
a863c7d1
MB
112#ifdef USE_THREADS
113 int i;
114#ifndef FAKE_THREADS
11343788 115 struct thread *thr;
a863c7d1
MB
116#endif /* FAKE_THREADS */
117#endif /* USE_THREADS */
11343788 118
79072805
LW
119 if (!(curinterp = sv_interp))
120 return;
121
8990e307 122#ifdef MULTIPLICITY
93a17b20 123 Zero(sv_interp, 1, PerlInterpreter);
8990e307 124#endif
79072805 125
33f46ff6 126 /* Init the real globals (and main thread)? */
c116a00c 127 if (!linestr) {
11343788 128#ifdef USE_THREADS
8023c3ce 129
33f46ff6 130 INIT_THREADS;
0b9678a8
NIS
131#ifdef ALLOC_THREAD_KEY
132 ALLOC_THREAD_KEY;
133#else
a863c7d1
MB
134 if (pthread_key_create(&thr_key, 0))
135 croak("panic: pthread_key_create");
aeea060c 136#endif
c116a00c
MB
137 MUTEX_INIT(&malloc_mutex);
138 MUTEX_INIT(&sv_mutex);
a863c7d1
MB
139 /*
140 * Safe to use basic SV functions from now on (though
141 * not things like mortals or tainting yet).
142 */
c116a00c
MB
143 MUTEX_INIT(&eval_mutex);
144 COND_INIT(&eval_cond);
33f46ff6 145 MUTEX_INIT(&threads_mutex);
c116a00c 146 COND_INIT(&nthreads_cond);
a863c7d1 147
199100c8 148 thr = init_main_thread();
11343788
MB
149#endif /* USE_THREADS */
150
79072805 151 linestr = NEWSV(65,80);
ed6116ce 152 sv_upgrade(linestr,SVt_PVIV);
79072805 153
6e72f9df
PP
154 if (!SvREADONLY(&sv_undef)) {
155 SvREADONLY_on(&sv_undef);
79072805 156
6e72f9df
PP
157 sv_setpv(&sv_no,No);
158 SvNV(&sv_no);
159 SvREADONLY_on(&sv_no);
79072805 160
6e72f9df
PP
161 sv_setpv(&sv_yes,Yes);
162 SvNV(&sv_yes);
163 SvREADONLY_on(&sv_yes);
164 }
79072805 165
c07a80fd
PP
166 nrs = newSVpv("\n", 1);
167 rs = SvREFCNT_inc(nrs);
168
c23142e2 169 sighandlerp = sighandler;
44a8e56a
PP
170 pidstatus = newHV();
171
79072805
LW
172#ifdef MSDOS
173 /*
174 * There is no way we can refer to them from Perl so close them to save
175 * space. The other alternative would be to provide STDAUX and STDPRN
176 * filehandles.
177 */
178 (void)fclose(stdaux);
179 (void)fclose(stdprn);
180#endif
181 }
182
8990e307 183#ifdef MULTIPLICITY
8ebc5c01
PP
184 I_REINIT;
185 perl_destruct_level = 1;
186#else
187 if(perl_destruct_level > 0)
188 I_REINIT;
79072805
LW
189#endif
190
748a9306 191 init_ids();
fb73857a 192 lex_state = LEX_NOTPARSING;
a5f75d66 193
54310121
PP
194 start_env.je_prev = NULL;
195 start_env.je_ret = -1;
196 start_env.je_mustcatch = TRUE;
197 top_env = &start_env;
f86702cc
PP
198 STATUS_ALL_SUCCESS;
199
36477c24 200 SET_NUMERIC_STANDARD();
a5f75d66 201#if defined(SUBVERSION) && SUBVERSION > 0
e2666263
PP
202 sprintf(patchlevel, "%7.5f", (double) 5
203 + ((double) PATCHLEVEL / (double) 1000)
204 + ((double) SUBVERSION / (double) 100000));
a5f75d66 205#else
e2666263
PP
206 sprintf(patchlevel, "%5.3f", (double) 5 +
207 ((double) PATCHLEVEL / (double) 1000));
a5f75d66 208#endif
79072805 209
ab821d7f 210#if defined(LOCAL_PATCH_COUNT)
6e72f9df 211 localpatches = local_patches; /* For possible -v */
ab821d7f
PP
212#endif
213
760ac839
LW
214 PerlIO_init(); /* Hook to IO system */
215
79072805 216 fdpid = newAV(); /* for remembering popen pids by fd */
8990e307 217
11343788
MB
218 init_stacks(ARGS);
219 DEBUG( {
220 New(51,debname,128,char);
221 New(52,debdelim,128,char);
222 } )
223
8990e307 224 ENTER;
79072805
LW
225}
226
227void
8ac85365 228perl_destruct(register PerlInterpreter *sv_interp)
79072805 229{
11343788 230 dTHR;
748a9306 231 int destruct_level; /* 0=none, 1=full, 2=full with checks */
8990e307 232 I32 last_sv_count;
a0d0e21e 233 HV *hv;
1f2bfc8a 234#ifdef USE_THREADS
33f46ff6 235 Thread t;
1f2bfc8a 236#endif /* USE_THREADS */
8990e307 237
79072805
LW
238 if (!(curinterp = sv_interp))
239 return;
748a9306 240
11343788 241#ifdef USE_THREADS
0f15f207 242#ifndef FAKE_THREADS
8023c3ce
MB
243 /* Pass 1 on any remaining threads: detach joinables, join zombies */
244 retry_cleanup:
33f46ff6
MB
245 MUTEX_LOCK(&threads_mutex);
246 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
c7848ba1 247 "perl_destruct: waiting for %d threads...\n",
33f46ff6
MB
248 nthreads - 1));
249 for (t = thr->next; t != thr; t = t->next) {
605e5515
MB
250 MUTEX_LOCK(&t->mutex);
251 switch (ThrSTATE(t)) {
252 AV *av;
c7848ba1
MB
253 case THRf_ZOMBIE:
254 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
255 "perl_destruct: joining zombie %p\n", t));
605e5515
MB
256 ThrSETSTATE(t, THRf_DEAD);
257 MUTEX_UNLOCK(&t->mutex);
258 nthreads--;
8023c3ce
MB
259 /*
260 * The SvREFCNT_dec below may take a long time (e.g. av
261 * may contain an object scalar whose destructor gets
262 * called) so we have to unlock threads_mutex and start
263 * all over again.
264 */
605e5515 265 MUTEX_UNLOCK(&threads_mutex);
ea0efc06 266 JOIN(t, &av);
605e5515 267 SvREFCNT_dec((SV*)av);
c7848ba1
MB
268 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
269 "perl_destruct: joined zombie %p OK\n", t));
8023c3ce 270 goto retry_cleanup;
c7848ba1
MB
271 case THRf_R_JOINABLE:
272 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
273 "perl_destruct: detaching thread %p\n", t));
274 ThrSETSTATE(t, THRf_R_DETACHED);
275 /*
276 * We unlock threads_mutex and t->mutex in the opposite order
277 * from which we locked them just so that DETACH won't
278 * deadlock if it panics. It's only a breach of good style
279 * not a bug since they are unlocks not locks.
280 */
281 MUTEX_UNLOCK(&threads_mutex);
282 DETACH(t);
283 MUTEX_UNLOCK(&t->mutex);
8023c3ce 284 goto retry_cleanup;
c7848ba1
MB
285 default:
286 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
287 "perl_destruct: ignoring %p (state %u)\n",
288 t, ThrSTATE(t)));
289 MUTEX_UNLOCK(&t->mutex);
c7848ba1 290 /* fall through and out */
33f46ff6
MB
291 }
292 }
8023c3ce
MB
293 /* We leave the above "Pass 1" loop with threads_mutex still locked */
294
295 /* Pass 2 on remaining threads: wait for the thread count to drop to one */
11343788
MB
296 while (nthreads > 1)
297 {
33f46ff6 298 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
c7848ba1 299 "perl_destruct: final wait for %d threads\n",
33f46ff6
MB
300 nthreads - 1));
301 COND_WAIT(&nthreads_cond, &threads_mutex);
11343788
MB
302 }
303 /* At this point, we're the last thread */
33f46ff6 304 MUTEX_UNLOCK(&threads_mutex);
d9f997d7 305 DEBUG_L(PerlIO_printf(PerlIO_stderr(), "perl_destruct: armageddon has arrived\n"));
33f46ff6 306 MUTEX_DESTROY(&threads_mutex);
11343788 307 COND_DESTROY(&nthreads_cond);
0f15f207 308#endif /* !defined(FAKE_THREADS) */
11343788
MB
309#endif /* USE_THREADS */
310
748a9306 311 destruct_level = perl_destruct_level;
4633a7c4
LW
312#ifdef DEBUGGING
313 {
314 char *s;
5f05dabc
PP
315 if (s = getenv("PERL_DESTRUCT_LEVEL")) {
316 int i = atoi(s);
317 if (destruct_level < i)
318 destruct_level = i;
319 }
4633a7c4
LW
320 }
321#endif
322
8990e307 323 LEAVE;
a0d0e21e
LW
324 FREETMPS;
325
ff0cee69
PP
326 /* We must account for everything. */
327
328 /* Destroy the main CV and syntax tree */
6e72f9df
PP
329 if (main_root) {
330 curpad = AvARRAY(comppad);
331 op_free(main_root);
ff0cee69 332 main_root = Nullop;
a0d0e21e 333 }
ff0cee69
PP
334 main_start = Nullop;
335 SvREFCNT_dec(main_cv);
336 main_cv = Nullcv;
337
a0d0e21e
LW
338 if (sv_objcount) {
339 /*
340 * Try to destruct global references. We do this first so that the
341 * destructors and destructees still exist. Some sv's might remain.
342 * Non-referenced objects are on their own.
343 */
344
345 dirty = TRUE;
346 sv_clean_objs();
8990e307
LW
347 }
348
5cd24f17
PP
349 /* unhook hooks which will soon be, or use, destroyed data */
350 SvREFCNT_dec(warnhook);
351 warnhook = Nullsv;
352 SvREFCNT_dec(diehook);
353 diehook = Nullsv;
354 SvREFCNT_dec(parsehook);
355 parsehook = Nullsv;
356
a0d0e21e 357 if (destruct_level == 0){
8990e307 358
a0d0e21e
LW
359 DEBUG_P(debprofdump());
360
361 /* The exit() function will do everything that needs doing. */
362 return;
363 }
5dd60ef7 364
5f05dabc
PP
365 /* loosen bonds of global variables */
366
8ebc5c01
PP
367 if(rsfp) {
368 (void)PerlIO_close(rsfp);
369 rsfp = Nullfp;
370 }
371
372 /* Filters for program text */
373 SvREFCNT_dec(rsfp_filters);
374 rsfp_filters = Nullav;
375
376 /* switches */
377 preprocess = FALSE;
378 minus_n = FALSE;
379 minus_p = FALSE;
380 minus_l = FALSE;
381 minus_a = FALSE;
382 minus_F = FALSE;
383 doswitches = FALSE;
384 dowarn = FALSE;
385 doextract = FALSE;
386 sawampersand = FALSE; /* must save all match strings */
387 sawstudy = FALSE; /* do fbm_instr on all strings */
388 sawvec = FALSE;
389 unsafe = FALSE;
390
391 Safefree(inplace);
392 inplace = Nullch;
393
394 Safefree(e_tmpname);
395 e_tmpname = Nullch;
396
397 if (e_fp) {
398 PerlIO_close(e_fp);
399 e_fp = Nullfp;
400 }
401
402 /* magical thingies */
403
404 Safefree(ofs); /* $, */
405 ofs = Nullch;
5f05dabc 406
8ebc5c01
PP
407 Safefree(ors); /* $\ */
408 ors = Nullch;
409
410 SvREFCNT_dec(nrs); /* $\ helper */
5f05dabc
PP
411 nrs = Nullsv;
412
8ebc5c01 413 multiline = 0; /* $* */
5f05dabc 414
8ebc5c01 415 SvREFCNT_dec(statname);
5f05dabc
PP
416 statname = Nullsv;
417 statgv = Nullgv;
5f05dabc 418
8ebc5c01
PP
419 /* defgv, aka *_ should be taken care of elsewhere */
420
421#if 0 /* just about all regexp stuff, seems to be ok */
422
423 /* shortcuts to regexp stuff */
424 leftgv = Nullgv;
425 ampergv = Nullgv;
426
427 SAVEFREEOP(curpm);
428 SAVEFREEOP(oldlastpm); /* for saving regexp context during debugger */
429
430 regprecomp = NULL; /* uncompiled string. */
431 regparse = NULL; /* Input-scan pointer. */
432 regxend = NULL; /* End of input for compile */
433 regnpar = 0; /* () count. */
434 regcode = NULL; /* Code-emit pointer; &regdummy = don't. */
435 regsize = 0; /* Code size. */
436 regnaughty = 0; /* How bad is this pattern? */
437 regsawback = 0; /* Did we see \1, ...? */
438
439 reginput = NULL; /* String-input pointer. */
440 regbol = NULL; /* Beginning of input, for ^ check. */
441 regeol = NULL; /* End of input, for $ check. */
442 regstartp = (char **)NULL; /* Pointer to startp array. */
443 regendp = (char **)NULL; /* Ditto for endp. */
444 reglastparen = 0; /* Similarly for lastparen. */
445 regtill = NULL; /* How far we are required to go. */
446 regflags = 0; /* are we folding, multilining? */
447 regprev = (char)NULL; /* char before regbol, \n if none */
448
449#endif /* if 0 */
450
451 /* clean up after study() */
452 SvREFCNT_dec(lastscream);
453 lastscream = Nullsv;
454 Safefree(screamfirst);
455 screamfirst = 0;
456 Safefree(screamnext);
457 screamnext = 0;
458
459 /* startup and shutdown function lists */
460 SvREFCNT_dec(beginav);
461 SvREFCNT_dec(endav);
77a005ab 462 SvREFCNT_dec(initav);
5618dfe8 463 beginav = Nullav;
5618dfe8 464 endav = Nullav;
77a005ab 465 initav = Nullav;
5618dfe8 466
8ebc5c01
PP
467 /* temp stack during pp_sort() */
468 SvREFCNT_dec(sortstack);
469 sortstack = Nullav;
470
471 /* shortcuts just get cleared */
472 envgv = Nullgv;
473 siggv = Nullgv;
474 incgv = Nullgv;
12f917ad 475 errgv = Nullgv;
8ebc5c01
PP
476 argvgv = Nullgv;
477 argvoutgv = Nullgv;
478 stdingv = Nullgv;
479 last_in_gv = Nullgv;
480
481 /* reset so print() ends up where we expect */
482 setdefout(Nullgv);
483
a0d0e21e 484 /* Prepare to destruct main symbol table. */
5f05dabc 485
a0d0e21e 486 hv = defstash;
85e6fe83 487 defstash = 0;
a0d0e21e
LW
488 SvREFCNT_dec(hv);
489
490 FREETMPS;
491 if (destruct_level >= 2) {
492 if (scopestack_ix != 0)
ff0cee69
PP
493 warn("Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
494 (long)scopestack_ix);
a0d0e21e 495 if (savestack_ix != 0)
ff0cee69
PP
496 warn("Unbalanced saves: %ld more saves than restores\n",
497 (long)savestack_ix);
a0d0e21e 498 if (tmps_floor != -1)
ff0cee69
PP
499 warn("Unbalanced tmps: %ld more allocs than frees\n",
500 (long)tmps_floor + 1);
a0d0e21e 501 if (cxstack_ix != -1)
ff0cee69
PP
502 warn("Unbalanced context: %ld more PUSHes than POPs\n",
503 (long)cxstack_ix + 1);
a0d0e21e 504 }
8990e307
LW
505
506 /* Now absolutely destruct everything, somehow or other, loops or no. */
8990e307 507 last_sv_count = 0;
6e72f9df 508 SvFLAGS(strtab) |= SVTYPEMASK; /* don't clean out strtab now */
8990e307
LW
509 while (sv_count != 0 && sv_count != last_sv_count) {
510 last_sv_count = sv_count;
511 sv_clean_all();
512 }
6e72f9df
PP
513 SvFLAGS(strtab) &= ~SVTYPEMASK;
514 SvFLAGS(strtab) |= SVt_PVHV;
515
516 /* Destruct the global string table. */
517 {
518 /* Yell and reset the HeVAL() slots that are still holding refcounts,
519 * so that sv_free() won't fail on them.
520 */
521 I32 riter;
522 I32 max;
523 HE *hent;
524 HE **array;
525
526 riter = 0;
527 max = HvMAX(strtab);
528 array = HvARRAY(strtab);
529 hent = array[0];
530 for (;;) {
531 if (hent) {
532 warn("Unbalanced string table refcount: (%d) for \"%s\"",
533 HeVAL(hent) - Nullsv, HeKEY(hent));
534 HeVAL(hent) = Nullsv;
535 hent = HeNEXT(hent);
536 }
537 if (!hent) {
538 if (++riter > max)
539 break;
540 hent = array[riter];
541 }
542 }
543 }
544 SvREFCNT_dec(strtab);
545
8990e307 546 if (sv_count != 0)
ff0cee69 547 warn("Scalars leaked: %ld\n", (long)sv_count);
6e72f9df 548
4633a7c4 549 sv_free_arenas();
44a8e56a
PP
550
551 /* No SVs have survived, need to clean out */
552 linestr = NULL;
553 pidstatus = Nullhv;
6e72f9df
PP
554 if (origfilename)
555 Safefree(origfilename);
556 nuke_stacks();
fc36a67e 557 hints = 0; /* Reset hints. Should hints be per-interpreter ? */
a0d0e21e
LW
558
559 DEBUG_P(debprofdump());
11343788
MB
560#ifdef USE_THREADS
561 MUTEX_DESTROY(&sv_mutex);
562 MUTEX_DESTROY(&malloc_mutex);
563 MUTEX_DESTROY(&eval_mutex);
c116a00c 564 COND_DESTROY(&eval_cond);
fc36a67e 565
8023c3ce
MB
566 /* As the penultimate thing, free the non-arena SV for thrsv */
567 Safefree(SvPVX(thrsv));
568 Safefree(SvANY(thrsv));
569 Safefree(thrsv);
570 thrsv = Nullsv;
571#endif /* USE_THREADS */
572
fc36a67e
PP
573 /* As the absolutely last thing, free the non-arena SV for mess() */
574
575 if (mess_sv) {
576 /* we know that type >= SVt_PV */
577 SvOOK_off(mess_sv);
578 Safefree(SvPVX(mess_sv));
579 Safefree(SvANY(mess_sv));
580 Safefree(mess_sv);
581 mess_sv = Nullsv;
582 }
79072805
LW
583}
584
585void
8ac85365 586perl_free(PerlInterpreter *sv_interp)
79072805
LW
587{
588 if (!(curinterp = sv_interp))
589 return;
590 Safefree(sv_interp);
591}
592
593int
8ac85365 594perl_parse(PerlInterpreter *sv_interp, void (*xsinit) (void), int argc, char **argv, char **env)
8d063cd8 595{
11343788 596 dTHR;
79072805 597 register SV *sv;
8d063cd8 598 register char *s;
1a30305b 599 char *scriptname = NULL;
a0d0e21e 600 VOL bool dosearch = FALSE;
13281fa4 601 char *validarg = "";
2ae324a7 602 I32 oldscope;
748a9306 603 AV* comppadlist;
54310121 604 dJMPENV;
22921e25 605 int ret;
8d063cd8 606
a687059c
LW
607#ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
608#ifdef IAMSUID
609#undef IAMSUID
463ee0b2 610 croak("suidperl is no longer needed since the kernel can now execute\n\
a687059c
LW
611setuid perl scripts securely.\n");
612#endif
613#endif
614
79072805
LW
615 if (!(curinterp = sv_interp))
616 return 255;
617
6e72f9df
PP
618#if defined(NeXT) && defined(__DYNAMIC__)
619 _dyld_lookup_and_bind
620 ("__environ", (unsigned long *) &environ_pointer, NULL);
621#endif /* environ */
622
ac58e20f
LW
623 origargv = argv;
624 origargc = argc;
a0d0e21e 625#ifndef VMS /* VMS doesn't have environ array */
fe14fcc3 626 origenviron = environ;
a0d0e21e 627#endif
ab821d7f 628 e_tmpname = Nullch;
a0d0e21e
LW
629
630 if (do_undump) {
631
632 /* Come here if running an undumped a.out. */
633
634 origfilename = savepv(argv[0]);
635 do_undump = FALSE;
636 cxstack_ix = -1; /* start label stack again */
748a9306 637 init_ids();
a0d0e21e
LW
638 init_postdump_symbols(argc,argv,env);
639 return 0;
640 }
641
ff0cee69
PP
642 if (main_root) {
643 curpad = AvARRAY(comppad);
a0d0e21e 644 op_free(main_root);
ff0cee69
PP
645 main_root = Nullop;
646 }
647 main_start = Nullop;
648 SvREFCNT_dec(main_cv);
649 main_cv = Nullcv;
79072805 650
f86702cc 651 time(&basetime);
2ae324a7 652 oldscope = scopestack_ix;
f86702cc 653
22921e25
CS
654 JMPENV_PUSH(ret);
655 switch (ret) {
79072805 656 case 1:
f86702cc
PP
657 STATUS_ALL_FAILURE;
658 /* FALL THROUGH */
79072805 659 case 2:
f86702cc 660 /* my_exit() was called */
2ae324a7
PP
661 while (scopestack_ix > oldscope)
662 LEAVE;
84902520 663 FREETMPS;
8990e307
LW
664 curstash = defstash;
665 if (endav)
68dc0745 666 call_list(oldscope, endav);
54310121 667 JMPENV_POP;
f86702cc 668 return STATUS_NATIVE_EXPORT;
79072805 669 case 3:
54310121 670 JMPENV_POP;
760ac839 671 PerlIO_printf(PerlIO_stderr(), "panic: top_env\n");
8990e307 672 return 1;
79072805
LW
673 }
674
79072805
LW
675 sv_setpvn(linestr,"",0);
676 sv = newSVpv("",0); /* first used for -I flags */
8990e307 677 SAVEFREESV(sv);
79072805 678 init_main_stash();
54310121 679
33b78306 680 for (argc--,argv++; argc > 0; argc--,argv++) {
8d063cd8
LW
681 if (argv[0][0] != '-' || !argv[0][1])
682 break;
13281fa4
LW
683#ifdef DOSUID
684 if (*validarg)
685 validarg = " PHOOEY ";
686 else
687 validarg = argv[0];
688#endif
689 s = argv[0]+1;
8d063cd8 690 reswitch:
13281fa4 691 switch (*s) {
27e2fb84 692 case '0':
2304df62 693 case 'F':
378cc40b 694 case 'a':
33b78306 695 case 'c':
a687059c 696 case 'd':
8d063cd8 697 case 'D':
4633a7c4 698 case 'h':
33b78306 699 case 'i':
fe14fcc3 700 case 'l':
1a30305b
PP
701 case 'M':
702 case 'm':
33b78306
LW
703 case 'n':
704 case 'p':
79072805 705 case 's':
33b78306
LW
706 case 'u':
707 case 'U':
708 case 'v':
709 case 'w':
710 if (s = moreswitches(s))
711 goto reswitch;
8d063cd8 712 break;
33b78306 713
f86702cc
PP
714 case 'T':
715 tainting = TRUE;
716 s++;
717 goto reswitch;
718
8d063cd8 719 case 'e':
a687059c 720 if (euid != uid || egid != gid)
463ee0b2 721 croak("No -e allowed in setuid scripts");
8d063cd8 722 if (!e_fp) {
a0d0e21e 723 e_tmpname = savepv(TMPPATH);
a687059c 724 (void)mktemp(e_tmpname);
83025b21 725 if (!*e_tmpname)
463ee0b2 726 croak("Can't mktemp()");
760ac839 727 e_fp = PerlIO_open(e_tmpname,"w");
33b78306 728 if (!e_fp)
463ee0b2 729 croak("Cannot open temporary file");
8d063cd8 730 }
552a7a9b
PP
731 if (*++s)
732 PerlIO_puts(e_fp,s);
733 else if (argv[1]) {
760ac839 734 PerlIO_puts(e_fp,argv[1]);
33b78306
LW
735 argc--,argv++;
736 }
552a7a9b
PP
737 else
738 croak("No code specified for -e");
760ac839 739 (void)PerlIO_putc(e_fp,'\n');
8d063cd8 740 break;
fb73857a 741 case 'I': /* -I handled both here and in moreswitches() */
bbce6d69 742 forbid_setid("-I");
fb73857a 743 if (!*++s && (s=argv[1]) != Nullch) {
8d063cd8 744 argc--,argv++;
8d063cd8 745 }
fb73857a
PP
746 while (s && isSPACE(*s))
747 ++s;
748 if (s && *s) {
749 char *e, *p;
750 for (e = s; *e && !isSPACE(*e); e++) ;
751 p = savepvn(s, e-s);
752 incpush(p, TRUE);
753 sv_catpv(sv,"-I");
754 sv_catpv(sv,p);
755 sv_catpv(sv," ");
756 Safefree(p);
757 } /* XXX else croak? */
8d063cd8 758 break;
8d063cd8 759 case 'P':
bbce6d69 760 forbid_setid("-P");
8d063cd8 761 preprocess = TRUE;
13281fa4 762 s++;
8d063cd8 763 goto reswitch;
378cc40b 764 case 'S':
bbce6d69 765 forbid_setid("-S");
378cc40b 766 dosearch = TRUE;
13281fa4 767 s++;
378cc40b 768 goto reswitch;
1a30305b
PP
769 case 'V':
770 if (!preambleav)
771 preambleav = newAV();
772 av_push(preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
773 if (*++s != ':') {
6e72f9df
PP
774 Sv = newSVpv("print myconfig();",0);
775#ifdef VMS
776 sv_catpv(Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
777#else
778 sv_catpv(Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
779#endif
54310121 780#if defined(DEBUGGING) || defined(NO_EMBED) || defined(MULTIPLICITY)
46fc3d4c 781 sv_catpv(Sv,"\" Compile-time options:");
6e72f9df 782# ifdef DEBUGGING
46fc3d4c 783 sv_catpv(Sv," DEBUGGING");
6e72f9df 784# endif
54310121 785# ifdef NO_EMBED
46fc3d4c 786 sv_catpv(Sv," NO_EMBED");
6e72f9df
PP
787# endif
788# ifdef MULTIPLICITY
46fc3d4c 789 sv_catpv(Sv," MULTIPLICITY");
6e72f9df 790# endif
46fc3d4c 791 sv_catpv(Sv,"\\n\",");
6e72f9df
PP
792#endif
793#if defined(LOCAL_PATCH_COUNT)
54310121
PP
794 if (LOCAL_PATCH_COUNT > 0) {
795 int i;
5cd24f17 796 sv_catpv(Sv,"\" Locally applied patches:\\n\",");
6e72f9df 797 for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
46fc3d4c
PP
798 if (localpatches[i])
799 sv_catpvf(Sv,"\" \\t%s\\n\",",localpatches[i]);
6e72f9df
PP
800 }
801 }
802#endif
46fc3d4c 803 sv_catpvf(Sv,"\" Built under %s\\n\"",OSNAME);
6e72f9df
PP
804#ifdef __DATE__
805# ifdef __TIME__
46fc3d4c 806 sv_catpvf(Sv,",\" Compiled at %s %s\\n\"",__DATE__,__TIME__);
6e72f9df 807# else
46fc3d4c 808 sv_catpvf(Sv,",\" Compiled on %s\\n\"",__DATE__);
6e72f9df 809# endif
6e72f9df 810#endif
54310121
PP
811 sv_catpv(Sv, "; \
812$\"=\"\\n \"; \
813@env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; \
814print \" \\%ENV:\\n @env\\n\" if @env; \
815print \" \\@INC:\\n @INC\\n\";");
1a30305b
PP
816 }
817 else {
818 Sv = newSVpv("config_vars(qw(",0);
819 sv_catpv(Sv, ++s);
820 sv_catpv(Sv, "))");
821 s += strlen(s);
822 }
823 av_push(preambleav, Sv);
c07a80fd 824 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
1a30305b 825 goto reswitch;
33b78306
LW
826 case 'x':
827 doextract = TRUE;
13281fa4 828 s++;
33b78306 829 if (*s)
a0d0e21e 830 cddir = savepv(s);
33b78306 831 break;
8d063cd8
LW
832 case 0:
833 break;
fb73857a
PP
834 case '-':
835 if (!*++s || isSPACE(*s)) {
836 argc--,argv++;
837 goto switch_end;
838 }
839 /* catch use of gnu style long options */
840 if (strEQ(s, "version")) {
841 s = "v";
842 goto reswitch;
843 }
844 if (strEQ(s, "help")) {
845 s = "h";
846 goto reswitch;
847 }
848 s--;
849 /* FALL THROUGH */
8d063cd8 850 default:
90248788 851 croak("Unrecognized switch: -%s (-h will show valid options)",s);
8d063cd8
LW
852 }
853 }
854 switch_end:
54310121
PP
855
856 if (!tainting && (s = getenv("PERL5OPT"))) {
fb73857a 857 while (s && *s) {
54310121
PP
858 while (isSPACE(*s))
859 s++;
860 if (*s == '-') {
861 s++;
862 if (isSPACE(*s))
863 continue;
864 }
865 if (!*s)
866 break;
867 if (!strchr("DIMUdmw", *s))
868 croak("Illegal switch in PERL5OPT: -%c", *s);
869 s = moreswitches(s);
870 }
871 }
872
1a30305b
PP
873 if (!scriptname)
874 scriptname = argv[0];
8d063cd8 875 if (e_fp) {
68dc0745
PP
876 if (PerlIO_flush(e_fp) || PerlIO_error(e_fp) || PerlIO_close(e_fp)) {
877#ifndef MULTIPLICITY
878 warn("Did you forget to compile with -DMULTIPLICITY?");
879#endif
2304df62 880 croak("Can't write to temp file for -e: %s", Strerror(errno));
68dc0745 881 }
ab821d7f 882 e_fp = Nullfp;
8d063cd8 883 argc++,argv--;
45d8adaa 884 scriptname = e_tmpname;
8d063cd8 885 }
79072805
LW
886 else if (scriptname == Nullch) {
887#ifdef MSDOS
760ac839 888 if ( isatty(PerlIO_fileno(PerlIO_stdin())) )
55497cff 889 moreswitches("h");
fe14fcc3 890#endif
79072805
LW
891 scriptname = "-";
892 }
fe14fcc3 893
79072805 894 init_perllib();
8d063cd8 895
79072805 896 open_script(scriptname,dosearch,sv);
8d063cd8 897
96436eeb 898 validate_suid(validarg, scriptname);
378cc40b 899
79072805
LW
900 if (doextract)
901 find_beginning();
902
4fdae800 903 main_cv = compcv = (CV*)NEWSV(1104,0);
748a9306 904 sv_upgrade((SV *)compcv, SVt_PVCV);
07055b4c 905 CvUNIQUE_on(compcv);
748a9306 906
6e72f9df 907 comppad = newAV();
79072805
LW
908 av_push(comppad, Nullsv);
909 curpad = AvARRAY(comppad);
6e72f9df 910 comppad_name = newAV();
8990e307 911 comppad_name_fill = 0;
e858de61
MB
912 min_intro_pending = 0;
913 padix = 0;
11343788
MB
914#ifdef USE_THREADS
915 av_store(comppad_name, 0, newSVpv("@_", 2));
e858de61 916 curpad[0] = (SV*)newAV();
6d4ff0d2 917 SvPADMY_on(curpad[0]); /* XXX Needed? */
e858de61 918 CvOWNER(compcv) = 0;
12ca11f6 919 New(666, CvMUTEXP(compcv), 1, perl_mutex);
e858de61 920 MUTEX_INIT(CvMUTEXP(compcv));
11343788 921#endif /* USE_THREADS */
79072805 922
748a9306
LW
923 comppadlist = newAV();
924 AvREAL_off(comppadlist);
8e07c86e
AD
925 av_store(comppadlist, 0, (SV*)comppad_name);
926 av_store(comppadlist, 1, (SV*)comppad);
748a9306
LW
927 CvPADLIST(compcv) = comppadlist;
928
6e72f9df 929 boot_core_UNIVERSAL();
a0d0e21e
LW
930 if (xsinit)
931 (*xsinit)(); /* in case linked C routines want magical variables */
ad2e33dc 932#if defined(VMS) || defined(WIN32)
748a9306
LW
933 init_os_extras();
934#endif
93a17b20 935
77a005ab
MB
936#if defined(DEBUGGING) && defined(USE_THREADS) && defined(__linux__)
937 DEBUG_L(signal(SIGSEGV, (void(*)(int))catch_sigsegv););
938#endif
939
93a17b20 940 init_predump_symbols();
8990e307
LW
941 if (!do_undump)
942 init_postdump_symbols(argc,argv,env);
93a17b20 943
79072805
LW
944 init_lexer();
945
946 /* now parse the script */
947
948 error_count = 0;
949 if (yyparse() || error_count) {
950 if (minus_c)
463ee0b2 951 croak("%s had compilation errors.\n", origfilename);
79072805 952 else {
463ee0b2 953 croak("Execution of %s aborted due to compilation errors.\n",
79072805 954 origfilename);
378cc40b 955 }
79072805
LW
956 }
957 curcop->cop_line = 0;
958 curstash = defstash;
959 preprocess = FALSE;
ab821d7f 960 if (e_tmpname) {
79072805 961 (void)UNLINK(e_tmpname);
ab821d7f
PP
962 Safefree(e_tmpname);
963 e_tmpname = Nullch;
378cc40b 964 }
a687059c 965
93a17b20 966 /* now that script is parsed, we can modify record separator */
c07a80fd
PP
967 SvREFCNT_dec(rs);
968 rs = SvREFCNT_inc(nrs);
a863c7d1 969#ifdef USE_THREADS
554b3eca 970 sv_setsv(*av_fetch(thr->magicals, find_thread_magical("/"), FALSE), rs);
a863c7d1 971#else
c07a80fd 972 sv_setsv(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), rs);
a863c7d1 973#endif /* USE_THREADS */
79072805
LW
974 if (do_undump)
975 my_unexec();
976
8990e307
LW
977 if (dowarn)
978 gv_check(defstash);
979
a0d0e21e
LW
980 LEAVE;
981 FREETMPS;
c07a80fd 982
3562ef9b 983#ifdef MYMALLOC
c07a80fd
PP
984 if ((s=getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
985 dump_mstats("after compilation:");
986#endif
987
a0d0e21e
LW
988 ENTER;
989 restartop = 0;
54310121 990 JMPENV_POP;
79072805
LW
991 return 0;
992}
993
994int
8ac85365 995perl_run(PerlInterpreter *sv_interp)
79072805 996{
11343788 997 dTHR;
2ae324a7 998 I32 oldscope;
22921e25
CS
999 dJMPENV;
1000 int ret;
2ae324a7 1001
79072805
LW
1002 if (!(curinterp = sv_interp))
1003 return 255;
2ae324a7
PP
1004
1005 oldscope = scopestack_ix;
1006
22921e25
CS
1007 JMPENV_PUSH(ret);
1008 switch (ret) {
79072805
LW
1009 case 1:
1010 cxstack_ix = -1; /* start context stack again */
1011 break;
1012 case 2:
f86702cc 1013 /* my_exit() was called */
2ae324a7
PP
1014 while (scopestack_ix > oldscope)
1015 LEAVE;
84902520 1016 FREETMPS;
79072805 1017 curstash = defstash;
93a17b20 1018 if (endav)
68dc0745 1019 call_list(oldscope, endav);
3562ef9b 1020#ifdef MYMALLOC
c07a80fd
PP
1021 if (getenv("PERL_DEBUG_MSTATS"))
1022 dump_mstats("after execution: ");
1023#endif
54310121 1024 JMPENV_POP;
f86702cc 1025 return STATUS_NATIVE_EXPORT;
79072805
LW
1026 case 3:
1027 if (!restartop) {
760ac839 1028 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
a0d0e21e 1029 FREETMPS;
54310121 1030 JMPENV_POP;
8990e307 1031 return 1;
83025b21 1032 }
6e72f9df 1033 if (curstack != mainstack) {
79072805 1034 dSP;
6e72f9df 1035 SWITCHSTACK(curstack, mainstack);
79072805
LW
1036 }
1037 break;
8d063cd8 1038 }
79072805 1039
fb73857a 1040 DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
6e72f9df
PP
1041 sawampersand ? "Enabling" : "Omitting"));
1042
79072805
LW
1043 if (!restartop) {
1044 DEBUG_x(dump_all());
760ac839 1045 DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
11343788 1046#ifdef USE_THREADS
5dc0d613
MB
1047 DEBUG_L(PerlIO_printf(Perl_debug_log, "main thread is 0x%lx\n",
1048 (unsigned long) thr));
11343788 1049#endif /* USE_THREADS */
79072805
LW
1050
1051 if (minus_c) {
760ac839 1052 PerlIO_printf(PerlIO_stderr(), "%s syntax OK\n", origfilename);
79072805
LW
1053 my_exit(0);
1054 }
84902520 1055 if (PERLDB_SINGLE && DBsingle)
a0d0e21e 1056 sv_setiv(DBsingle, 1);
7d07dbc2
MB
1057 if (initav)
1058 call_list(oldscope, initav);
45d8adaa 1059 }
79072805
LW
1060
1061 /* do it */
1062
1063 if (restartop) {
1064 op = restartop;
1065 restartop = 0;
ab821d7f 1066 runops();
79072805
LW
1067 }
1068 else if (main_start) {
4fdae800 1069 CvDEPTH(main_cv) = 1;
79072805 1070 op = main_start;
ab821d7f 1071 runops();
79072805 1072 }
79072805
LW
1073
1074 my_exit(0);
54310121 1075 /* NOTREACHED */
a0d0e21e 1076 return 0;
79072805
LW
1077}
1078
a0d0e21e 1079SV*
8ac85365 1080perl_get_sv(char *name, I32 create)
a0d0e21e 1081{
2faa37cc 1082 GV *gv;
38a03e6e 1083#ifdef USE_THREADS
2faa37cc
MB
1084 if (name[1] == '\0' && !isALPHA(name[0])) {
1085 PADOFFSET tmp = find_thread_magical(name);
1086 if (tmp != NOT_IN_PAD) {
1087 dTHR;
1088 return *av_fetch(thr->magicals, tmp, FALSE);
1089 }
38a03e6e
MB
1090 }
1091#endif /* USE_THREADS */
2faa37cc 1092 gv = gv_fetchpv(name, create, SVt_PV);
a0d0e21e
LW
1093 if (gv)
1094 return GvSV(gv);
1095 return Nullsv;
1096}
1097
1098AV*
8ac85365 1099perl_get_av(char *name, I32 create)
a0d0e21e
LW
1100{
1101 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
1102 if (create)
1103 return GvAVn(gv);
1104 if (gv)
1105 return GvAV(gv);
1106 return Nullav;
1107}
1108
1109HV*
8ac85365 1110perl_get_hv(char *name, I32 create)
a0d0e21e
LW
1111{
1112 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
1113 if (create)
1114 return GvHVn(gv);
1115 if (gv)
1116 return GvHV(gv);
1117 return Nullhv;
1118}
1119
1120CV*
8ac85365 1121perl_get_cv(char *name, I32 create)
a0d0e21e
LW
1122{
1123 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
8ebc5c01 1124 if (create && !GvCVu(gv))
774d564b 1125 return newSUB(start_subparse(FALSE, 0),
a0d0e21e 1126 newSVOP(OP_CONST, 0, newSVpv(name,0)),
4633a7c4 1127 Nullop,
a0d0e21e
LW
1128 Nullop);
1129 if (gv)
8ebc5c01 1130 return GvCVu(gv);
a0d0e21e
LW
1131 return Nullcv;
1132}
1133
79072805
LW
1134/* Be sure to refetch the stack pointer after calling these routines. */
1135
a0d0e21e 1136I32
8ac85365
NIS
1137perl_call_argv(char *subname, I32 flags, register char **argv)
1138
1139 /* See G_* flags in cop.h */
1140 /* null terminated arg list */
8990e307 1141{
a0d0e21e 1142 dSP;
8990e307 1143
a0d0e21e
LW
1144 PUSHMARK(sp);
1145 if (argv) {
8990e307 1146 while (*argv) {
a0d0e21e 1147 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
8990e307
LW
1148 argv++;
1149 }
a0d0e21e 1150 PUTBACK;
8990e307 1151 }
a0d0e21e 1152 return perl_call_pv(subname, flags);
8990e307
LW
1153}
1154
a0d0e21e 1155I32
8ac85365
NIS
1156perl_call_pv(char *subname, I32 flags)
1157 /* name of the subroutine */
1158 /* See G_* flags in cop.h */
a0d0e21e
LW
1159{
1160 return perl_call_sv((SV*)perl_get_cv(subname, TRUE), flags);
1161}
1162
1163I32
8ac85365
NIS
1164perl_call_method(char *methname, I32 flags)
1165 /* name of the subroutine */
1166 /* See G_* flags in cop.h */
a0d0e21e
LW
1167{
1168 dSP;
1169 OP myop;
1170 if (!op)
1171 op = &myop;
1172 XPUSHs(sv_2mortal(newSVpv(methname,0)));
1173 PUTBACK;
11343788 1174 pp_method(ARGS);
a0d0e21e
LW
1175 return perl_call_sv(*stack_sp--, flags);
1176}
1177
1178/* May be called with any of a CV, a GV, or an SV containing the name. */
1179I32
8ac85365
NIS
1180perl_call_sv(SV *sv, I32 flags)
1181
1182 /* See G_* flags in cop.h */
a0d0e21e 1183{
11343788 1184 dTHR;
a0d0e21e
LW
1185 LOGOP myop; /* fake syntax tree node */
1186 SV** sp = stack_sp;
aa689395 1187 I32 oldmark;
a0d0e21e 1188 I32 retval;
a0d0e21e 1189 I32 oldscope;
6e72f9df 1190 static CV *DBcv;
54310121
PP
1191 bool oldcatch = CATCH_GET;
1192 dJMPENV;
22921e25 1193 int ret;
d6602a8c 1194 OP* oldop = op;
1e422769 1195
a0d0e21e
LW
1196 if (flags & G_DISCARD) {
1197 ENTER;
1198 SAVETMPS;
1199 }
1200
aa689395 1201 Zero(&myop, 1, LOGOP);
54310121 1202 myop.op_next = Nullop;
f51d4af5 1203 if (!(flags & G_NOARGS))
aa689395 1204 myop.op_flags |= OPf_STACKED;
54310121
PP
1205 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1206 (flags & G_ARRAY) ? OPf_WANT_LIST :
1207 OPf_WANT_SCALAR);
462e5cf6 1208 SAVEOP();
a0d0e21e 1209 op = (OP*)&myop;
aa689395 1210
a0d0e21e
LW
1211 EXTEND(stack_sp, 1);
1212 *++stack_sp = sv;
aa689395 1213 oldmark = TOPMARK;
a0d0e21e
LW
1214 oldscope = scopestack_ix;
1215
84902520 1216 if (PERLDB_SUB && curstash != debstash
36477c24
PP
1217 /* Handle first BEGIN of -d. */
1218 && (DBcv || (DBcv = GvCV(DBsub)))
1219 /* Try harder, since this may have been a sighandler, thus
1220 * curstash may be meaningless. */
1221 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != debstash))
6e72f9df 1222 op->op_private |= OPpENTERSUB_DB;
a0d0e21e
LW
1223
1224 if (flags & G_EVAL) {
a0d0e21e
LW
1225 cLOGOP->op_other = op;
1226 markstack_ptr--;
4633a7c4
LW
1227 /* we're trying to emulate pp_entertry() here */
1228 {
1229 register CONTEXT *cx;
54310121 1230 I32 gimme = GIMME_V;
4633a7c4
LW
1231
1232 ENTER;
1233 SAVETMPS;
1234
1235 push_return(op->op_next);
1236 PUSHBLOCK(cx, CXt_EVAL, stack_sp);
1237 PUSHEVAL(cx, 0, 0);
1238 eval_root = op; /* Only needed so that goto works right. */
1239
1240 in_eval = 1;
1241 if (flags & G_KEEPERR)
1242 in_eval |= 4;
1243 else
38a03e6e 1244 sv_setpv(ERRSV,"");
4633a7c4 1245 }
a0d0e21e
LW
1246 markstack_ptr++;
1247
22921e25
CS
1248 JMPENV_PUSH(ret);
1249 switch (ret) {
a0d0e21e
LW
1250 case 0:
1251 break;
1252 case 1:
f86702cc 1253 STATUS_ALL_FAILURE;
a0d0e21e
LW
1254 /* FALL THROUGH */
1255 case 2:
1256 /* my_exit() was called */
1257 curstash = defstash;
1258 FREETMPS;
54310121 1259 JMPENV_POP;
a0d0e21e
LW
1260 if (statusvalue)
1261 croak("Callback called exit");
f86702cc 1262 my_exit_jump();
a0d0e21e
LW
1263 /* NOTREACHED */
1264 case 3:
1265 if (restartop) {
1266 op = restartop;
1267 restartop = 0;
54310121 1268 break;
a0d0e21e
LW
1269 }
1270 stack_sp = stack_base + oldmark;
1271 if (flags & G_ARRAY)
1272 retval = 0;
1273 else {
1274 retval = 1;
1275 *++stack_sp = &sv_undef;
1276 }
1277 goto cleanup;
1278 }
1279 }
1e422769 1280 else
54310121 1281 CATCH_SET(TRUE);
a0d0e21e
LW
1282
1283 if (op == (OP*)&myop)
11343788 1284 op = pp_entersub(ARGS);
a0d0e21e 1285 if (op)
ab821d7f 1286 runops();
a0d0e21e 1287 retval = stack_sp - (stack_base + oldmark);
4633a7c4 1288 if ((flags & G_EVAL) && !(flags & G_KEEPERR))
38a03e6e 1289 sv_setpv(ERRSV,"");
a0d0e21e
LW
1290
1291 cleanup:
1292 if (flags & G_EVAL) {
1293 if (scopestack_ix > oldscope) {
a0a2876f
LW
1294 SV **newsp;
1295 PMOP *newpm;
1296 I32 gimme;
1297 register CONTEXT *cx;
1298 I32 optype;
1299
1300 POPBLOCK(cx,newpm);
1301 POPEVAL(cx);
1302 pop_return();
1303 curpm = newpm;
1304 LEAVE;
a0d0e21e 1305 }
54310121 1306 JMPENV_POP;
a0d0e21e 1307 }
1e422769 1308 else
54310121 1309 CATCH_SET(oldcatch);
1e422769 1310
a0d0e21e
LW
1311 if (flags & G_DISCARD) {
1312 stack_sp = stack_base + oldmark;
1313 retval = 0;
1314 FREETMPS;
1315 LEAVE;
1316 }
d6602a8c 1317 op = oldop;
a0d0e21e
LW
1318 return retval;
1319}
1320
6e72f9df 1321/* Eval a string. The G_EVAL flag is always assumed. */
8990e307 1322
a0d0e21e 1323I32
8ac85365
NIS
1324perl_eval_sv(SV *sv, I32 flags)
1325
1326 /* See G_* flags in cop.h */
a0d0e21e 1327{
11343788 1328 dTHR;
a0d0e21e 1329 UNOP myop; /* fake syntax tree node */
4633a7c4
LW
1330 SV** sp = stack_sp;
1331 I32 oldmark = sp - stack_base;
1332 I32 retval;
4633a7c4 1333 I32 oldscope;
54310121 1334 dJMPENV;
22921e25 1335 int ret;
84902520
TB
1336 OP* oldop = op;
1337
4633a7c4
LW
1338 if (flags & G_DISCARD) {
1339 ENTER;
1340 SAVETMPS;
1341 }
1342
462e5cf6 1343 SAVEOP();
79072805 1344 op = (OP*)&myop;
a0d0e21e 1345 Zero(op, 1, UNOP);
4633a7c4
LW
1346 EXTEND(stack_sp, 1);
1347 *++stack_sp = sv;
1348 oldscope = scopestack_ix;
79072805 1349
4633a7c4
LW
1350 if (!(flags & G_NOARGS))
1351 myop.op_flags = OPf_STACKED;
79072805 1352 myop.op_next = Nullop;
6e72f9df 1353 myop.op_type = OP_ENTEREVAL;
54310121
PP
1354 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1355 (flags & G_ARRAY) ? OPf_WANT_LIST :
1356 OPf_WANT_SCALAR);
6e72f9df
PP
1357 if (flags & G_KEEPERR)
1358 myop.op_flags |= OPf_SPECIAL;
4633a7c4 1359
22921e25
CS
1360 JMPENV_PUSH(ret);
1361 switch (ret) {
4633a7c4
LW
1362 case 0:
1363 break;
1364 case 1:
f86702cc 1365 STATUS_ALL_FAILURE;
4633a7c4
LW
1366 /* FALL THROUGH */
1367 case 2:
1368 /* my_exit() was called */
1369 curstash = defstash;
1370 FREETMPS;
54310121 1371 JMPENV_POP;
4633a7c4
LW
1372 if (statusvalue)
1373 croak("Callback called exit");
f86702cc 1374 my_exit_jump();
4633a7c4
LW
1375 /* NOTREACHED */
1376 case 3:
1377 if (restartop) {
1378 op = restartop;
1379 restartop = 0;
54310121 1380 break;
4633a7c4
LW
1381 }
1382 stack_sp = stack_base + oldmark;
1383 if (flags & G_ARRAY)
1384 retval = 0;
1385 else {
1386 retval = 1;
1387 *++stack_sp = &sv_undef;
1388 }
1389 goto cleanup;
1390 }
1391
1392 if (op == (OP*)&myop)
11343788 1393 op = pp_entereval(ARGS);
4633a7c4 1394 if (op)
ab821d7f 1395 runops();
4633a7c4 1396 retval = stack_sp - (stack_base + oldmark);
6e72f9df 1397 if (!(flags & G_KEEPERR))
38a03e6e 1398 sv_setpv(ERRSV,"");
4633a7c4
LW
1399
1400 cleanup:
54310121 1401 JMPENV_POP;
4633a7c4
LW
1402 if (flags & G_DISCARD) {
1403 stack_sp = stack_base + oldmark;
1404 retval = 0;
1405 FREETMPS;
1406 LEAVE;
1407 }
84902520 1408 op = oldop;
4633a7c4
LW
1409 return retval;
1410}
1411
137443ea 1412SV*
8ac85365 1413perl_eval_pv(char *p, I32 croak_on_error)
137443ea
PP
1414{
1415 dSP;
1416 SV* sv = newSVpv(p, 0);
1417
1418 PUSHMARK(sp);
1419 perl_eval_sv(sv, G_SCALAR);
1420 SvREFCNT_dec(sv);
1421
1422 SPAGAIN;
1423 sv = POPs;
1424 PUTBACK;
1425
38a03e6e
MB
1426 if (croak_on_error && SvTRUE(ERRSV))
1427 croak(SvPVx(ERRSV, na));
137443ea
PP
1428
1429 return sv;
1430}
1431
4633a7c4
LW
1432/* Require a module. */
1433
1434void
8ac85365 1435perl_require_pv(char *pv)
4633a7c4
LW
1436{
1437 SV* sv = sv_newmortal();
1438 sv_setpv(sv, "require '");
1439 sv_catpv(sv, pv);
1440 sv_catpv(sv, "'");
1441 perl_eval_sv(sv, G_DISCARD);
79072805
LW
1442}
1443
79072805 1444void
8ac85365 1445magicname(char *sym, char *name, I32 namlen)
79072805
LW
1446{
1447 register GV *gv;
1448
85e6fe83 1449 if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
79072805
LW
1450 sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
1451}
1452
ab821d7f 1453static void
8ac85365
NIS
1454usage(char *name) /* XXX move this out into a module ? */
1455
4633a7c4 1456{
ab821d7f
PP
1457 /* This message really ought to be max 23 lines.
1458 * Removed -h because the user already knows that opton. Others? */
fb73857a
PP
1459
1460 static char *usage[] = {
1461"-0[octal] specify record separator (\\0, if no argument)",
1462"-a autosplit mode with -n or -p (splits $_ into @F)",
1463"-c check syntax only (runs BEGIN and END blocks)",
1464"-d[:debugger] run scripts under debugger",
1465"-D[number/list] set debugging flags (argument is a bit mask or flags)",
1466"-e 'command' one line of script. Several -e's allowed. Omit [programfile].",
1467"-F/pattern/ split() pattern for autosplit (-a). The //'s are optional.",
1468"-i[extension] edit <> files in place (make backup if extension supplied)",
1469"-Idirectory specify @INC/#include directory (may be used more than once)",
1470"-l[octal] enable line ending processing, specifies line terminator",
1471"-[mM][-]module.. executes `use/no module...' before executing your script.",
1472"-n assume 'while (<>) { ... }' loop around your script",
1473"-p assume loop like -n but print line also like sed",
1474"-P run script through C preprocessor before compilation",
1475"-s enable some switch parsing for switches after script name",
1476"-S look for the script using PATH environment variable",
1477"-T turn on tainting checks",
1478"-u dump core after parsing script",
1479"-U allow unsafe operations",
1480"-v print version number and patchlevel of perl",
1481"-V[:variable] print perl configuration information",
1482"-w TURN WARNINGS ON FOR COMPILATION OF YOUR SCRIPT. Recommended.",
1483"-x[directory] strip off text before #!perl line and perhaps cd to directory",
1484"\n",
1485NULL
1486};
1487 char **p = usage;
1488
ab821d7f 1489 printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
fb73857a
PP
1490 while (*p)
1491 printf("\n %s", *p++);
4633a7c4
LW
1492}
1493
79072805
LW
1494/* This routine handles any switches that can be given during run */
1495
1496char *
8ac85365 1497moreswitches(char *s)
79072805
LW
1498{
1499 I32 numlen;
c07a80fd 1500 U32 rschar;
79072805
LW
1501
1502 switch (*s) {
1503 case '0':
a863c7d1
MB
1504 {
1505 dTHR;
c07a80fd
PP
1506 rschar = scan_oct(s, 4, &numlen);
1507 SvREFCNT_dec(nrs);
1508 if (rschar & ~((U8)~0))
1509 nrs = &sv_undef;
1510 else if (!rschar && numlen >= 2)
1511 nrs = newSVpv("", 0);
1512 else {
1513 char ch = rschar;
1514 nrs = newSVpv(&ch, 1);
79072805
LW
1515 }
1516 return s + numlen;
a863c7d1 1517 }
2304df62
AD
1518 case 'F':
1519 minus_F = TRUE;
a0d0e21e 1520 splitstr = savepv(s + 1);
2304df62
AD
1521 s += strlen(s);
1522 return s;
79072805
LW
1523 case 'a':
1524 minus_a = TRUE;
1525 s++;
1526 return s;
1527 case 'c':
1528 minus_c = TRUE;
1529 s++;
1530 return s;
1531 case 'd':
bbce6d69 1532 forbid_setid("-d");
4633a7c4 1533 s++;
c07a80fd 1534 if (*s == ':' || *s == '=') {
46fc3d4c 1535 my_setenv("PERL5DB", form("use Devel::%s;", ++s));
4633a7c4 1536 s += strlen(s);
4633a7c4 1537 }
a0d0e21e 1538 if (!perldb) {
84902520 1539 perldb = PERLDB_ALL;
a0d0e21e
LW
1540 init_debugger();
1541 }
79072805
LW
1542 return s;
1543 case 'D':
1544#ifdef DEBUGGING
bbce6d69 1545 forbid_setid("-D");
79072805 1546 if (isALPHA(s[1])) {
8990e307 1547 static char debopts[] = "psltocPmfrxuLHXD";
79072805
LW
1548 char *d;
1549
93a17b20 1550 for (s++; *s && (d = strchr(debopts,*s)); s++)
79072805
LW
1551 debug |= 1 << (d - debopts);
1552 }
1553 else {
1554 debug = atoi(s+1);
1555 for (s++; isDIGIT(*s); s++) ;
1556 }
8990e307 1557 debug |= 0x80000000;
79072805
LW
1558#else
1559 warn("Recompile perl with -DDEBUGGING to use -D switch\n");
a0d0e21e 1560 for (s++; isALNUM(*s); s++) ;
79072805
LW
1561#endif
1562 /*SUPPRESS 530*/
1563 return s;
4633a7c4
LW
1564 case 'h':
1565 usage(origargv[0]);
1566 exit(0);
79072805
LW
1567 case 'i':
1568 if (inplace)
1569 Safefree(inplace);
a0d0e21e 1570 inplace = savepv(s+1);
79072805
LW
1571 /*SUPPRESS 530*/
1572 for (s = inplace; *s && !isSPACE(*s); s++) ;
fb73857a
PP
1573 if (*s)
1574 *s++ = '\0';
1575 return s;
1576 case 'I': /* -I handled both here and in parse_perl() */
bbce6d69 1577 forbid_setid("-I");
fb73857a
PP
1578 ++s;
1579 while (*s && isSPACE(*s))
1580 ++s;
1581 if (*s) {
774d564b 1582 char *e, *p;
748a9306 1583 for (e = s; *e && !isSPACE(*e); e++) ;
774d564b
PP
1584 p = savepvn(s, e-s);
1585 incpush(p, TRUE);
1586 Safefree(p);
fb73857a 1587 s = e;
79072805
LW
1588 }
1589 else
463ee0b2 1590 croak("No space allowed after -I");
fb73857a 1591 return s;
79072805
LW
1592 case 'l':
1593 minus_l = TRUE;
1594 s++;
a0d0e21e
LW
1595 if (ors)
1596 Safefree(ors);
79072805 1597 if (isDIGIT(*s)) {
a0d0e21e 1598 ors = savepv("\n");
79072805
LW
1599 orslen = 1;
1600 *ors = scan_oct(s, 3 + (*s == '0'), &numlen);
1601 s += numlen;
1602 }
1603 else {
a863c7d1 1604 dTHR;
c07a80fd 1605 if (RsPARA(nrs)) {
6e72f9df 1606 ors = "\n\n";
c07a80fd
PP
1607 orslen = 2;
1608 }
1609 else
1610 ors = SvPV(nrs, orslen);
6e72f9df 1611 ors = savepvn(ors, orslen);
79072805
LW
1612 }
1613 return s;
1a30305b 1614 case 'M':
bbce6d69 1615 forbid_setid("-M"); /* XXX ? */
1a30305b
PP
1616 /* FALL THROUGH */
1617 case 'm':
bbce6d69 1618 forbid_setid("-m"); /* XXX ? */
1a30305b 1619 if (*++s) {
a5f75d66 1620 char *start;
11343788 1621 SV *sv;
a5f75d66
AD
1622 char *use = "use ";
1623 /* -M-foo == 'no foo' */
1624 if (*s == '-') { use = "no "; ++s; }
11343788 1625 sv = newSVpv(use,0);
a5f75d66 1626 start = s;
1a30305b 1627 /* We allow -M'Module qw(Foo Bar)' */
c07a80fd
PP
1628 while(isALNUM(*s) || *s==':') ++s;
1629 if (*s != '=') {
11343788 1630 sv_catpv(sv, start);
c07a80fd
PP
1631 if (*(start-1) == 'm') {
1632 if (*s != '\0')
1633 croak("Can't use '%c' after -mname", *s);
11343788 1634 sv_catpv( sv, " ()");
c07a80fd
PP
1635 }
1636 } else {
11343788
MB
1637 sv_catpvn(sv, start, s-start);
1638 sv_catpv(sv, " split(/,/,q{");
1639 sv_catpv(sv, ++s);
1640 sv_catpv(sv, "})");
c07a80fd 1641 }
1a30305b 1642 s += strlen(s);
c07a80fd
PP
1643 if (preambleav == NULL)
1644 preambleav = newAV();
11343788 1645 av_push(preambleav, sv);
1a30305b
PP
1646 }
1647 else
1648 croak("No space allowed after -%c", *(s-1));
1649 return s;
79072805
LW
1650 case 'n':
1651 minus_n = TRUE;
1652 s++;
1653 return s;
1654 case 'p':
1655 minus_p = TRUE;
1656 s++;
1657 return s;
1658 case 's':
bbce6d69 1659 forbid_setid("-s");
79072805
LW
1660 doswitches = TRUE;
1661 s++;
1662 return s;
463ee0b2 1663 case 'T':
f86702cc 1664 if (!tainting)
9607fc9c 1665 croak("Too late for \"-T\" option");
463ee0b2
LW
1666 s++;
1667 return s;
79072805
LW
1668 case 'u':
1669 do_undump = TRUE;
1670 s++;
1671 return s;
1672 case 'U':
1673 unsafe = TRUE;
1674 s++;
1675 return s;
1676 case 'v':
a5f75d66 1677#if defined(SUBVERSION) && SUBVERSION > 0
fb73857a
PP
1678 printf("\nThis is perl, version 5.%03d_%02d built for %s",
1679 PATCHLEVEL, SUBVERSION, ARCHNAME);
a5f75d66 1680#else
fb73857a
PP
1681 printf("\nThis is perl, version %s built for %s",
1682 patchlevel, ARCHNAME);
1683#endif
1684#if defined(LOCAL_PATCH_COUNT)
1685 if (LOCAL_PATCH_COUNT > 0)
1686 printf("\n(with %d registered patch%s, see perl -V for more detail)",
1687 LOCAL_PATCH_COUNT, (LOCAL_PATCH_COUNT!=1) ? "es" : "");
a5f75d66 1688#endif
1a30305b 1689
44a8e56a 1690 printf("\n\nCopyright 1987-1997, Larry Wall\n");
79072805 1691#ifdef MSDOS
fb73857a 1692 printf("\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
55497cff
PP
1693#endif
1694#ifdef DJGPP
1695 printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n");
4633a7c4 1696#endif
79072805 1697#ifdef OS2
5dd60ef7 1698 printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
9607fc9c 1699 "Version 5 port Copyright (c) 1994-1997, Andreas Kaiser, Ilya Zakharevich\n");
79072805 1700#endif
79072805 1701#ifdef atarist
760ac839 1702 printf("atariST series port, ++jrb bammi@cadence.com\n");
79072805 1703#endif
760ac839 1704 printf("\n\
79072805 1705Perl may be copied only under the terms of either the Artistic License or the\n\
760ac839 1706GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n");
79072805
LW
1707 exit(0);
1708 case 'w':
1709 dowarn = TRUE;
1710 s++;
1711 return s;
a0d0e21e 1712 case '*':
79072805
LW
1713 case ' ':
1714 if (s[1] == '-') /* Additional switches on #! line. */
1715 return s+2;
1716 break;
a0d0e21e 1717 case '-':
79072805
LW
1718 case 0:
1719 case '\n':
1720 case '\t':
1721 break;
aa689395
PP
1722#ifdef ALTERNATE_SHEBANG
1723 case 'S': /* OS/2 needs -S on "extproc" line. */
1724 break;
1725#endif
a0d0e21e
LW
1726 case 'P':
1727 if (preprocess)
1728 return s+1;
1729 /* FALL THROUGH */
79072805 1730 default:
a0d0e21e 1731 croak("Can't emulate -%.1s on #! line",s);
79072805
LW
1732 }
1733 return Nullch;
1734}
1735
1736/* compliments of Tom Christiansen */
1737
1738/* unexec() can be found in the Gnu emacs distribution */
1739
1740void
8ac85365 1741my_unexec(void)
79072805
LW
1742{
1743#ifdef UNEXEC
46fc3d4c
PP
1744 SV* prog;
1745 SV* file;
79072805
LW
1746 int status;
1747 extern int etext;
1748
46fc3d4c
PP
1749 prog = newSVpv(BIN_EXP);
1750 sv_catpv(prog, "/perl");
1751 file = newSVpv(origfilename);
1752 sv_catpv(file, ".perldump");
79072805 1753
46fc3d4c 1754 status = unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
79072805 1755 if (status)
46fc3d4c
PP
1756 PerlIO_printf(PerlIO_stderr(), "unexec of %s into %s failed!\n",
1757 SvPVX(prog), SvPVX(file));
a0d0e21e 1758 exit(status);
79072805 1759#else
a5f75d66
AD
1760# ifdef VMS
1761# include <lib$routines.h>
1762 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
aa689395 1763# else
79072805 1764 ABORT(); /* for use with undump */
aa689395 1765# endif
a5f75d66 1766#endif
79072805
LW
1767}
1768
1769static void
8ac85365 1770init_main_stash(void)
79072805 1771{
11343788 1772 dTHR;
463ee0b2 1773 GV *gv;
6e72f9df
PP
1774
1775 /* Note that strtab is a rather special HV. Assumptions are made
1776 about not iterating on it, and not adding tie magic to it.
1777 It is properly deallocated in perl_destruct() */
1778 strtab = newHV();
1779 HvSHAREKEYS_off(strtab); /* mandatory */
1780 Newz(506,((XPVHV*)SvANY(strtab))->xhv_array,
1781 sizeof(HE*) * (((XPVHV*)SvANY(strtab))->xhv_max + 1), char);
1782
463ee0b2 1783 curstash = defstash = newHV();
79072805 1784 curstname = newSVpv("main",4);
adbc6bb1
LW
1785 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
1786 SvREFCNT_dec(GvHV(gv));
1787 GvHV(gv) = (HV*)SvREFCNT_inc(defstash);
463ee0b2 1788 SvREADONLY_on(gv);
a0d0e21e 1789 HvNAME(defstash) = savepv("main");
85e6fe83 1790 incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
a5f75d66 1791 GvMULTI_on(incgv);
a0d0e21e 1792 defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
12f917ad
MB
1793 errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
1794 GvMULTI_on(errgv);
84902520 1795 (void)form("%240s",""); /* Preallocate temp - for immediate signals. */
38a03e6e
MB
1796 sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */
1797 sv_setpvn(ERRSV, "", 0);
8990e307
LW
1798 curstash = defstash;
1799 compiling.cop_stash = defstash;
adbc6bb1 1800 debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
4633a7c4
LW
1801 /* We must init $/ before switches are processed. */
1802 sv_setpvn(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), "\n", 1);
79072805
LW
1803}
1804
a0d0e21e
LW
1805#ifdef CAN_PROTOTYPE
1806static void
1807open_script(char *scriptname, bool dosearch, SV *sv)
1808#else
79072805
LW
1809static void
1810open_script(scriptname,dosearch,sv)
1811char *scriptname;
1812bool dosearch;
1813SV *sv;
a0d0e21e 1814#endif
79072805 1815{
0f15f207 1816 dTHR;
79072805
LW
1817 char *xfound = Nullch;
1818 char *xfailed = Nullch;
1819 register char *s;
1820 I32 len;
a38d6535
LW
1821 int retval;
1822#if defined(DOSISH) && !defined(OS2) && !defined(atarist)
fc36a67e
PP
1823# define SEARCH_EXTS ".bat", ".cmd", NULL
1824# define MAX_EXT_LEN 4
a38d6535 1825#endif
d8c2d278
IZ
1826#ifdef OS2
1827# define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL
1828# define MAX_EXT_LEN 4
1829#endif
ab821d7f
PP
1830#ifdef VMS
1831# define SEARCH_EXTS ".pl", ".com", NULL
fc36a67e 1832# define MAX_EXT_LEN 4
ab821d7f 1833#endif
a38d6535
LW
1834 /* additional extensions to try in each dir if scriptname not found */
1835#ifdef SEARCH_EXTS
1836 char *ext[] = { SEARCH_EXTS };
2a92aaa0
GS
1837 int extidx = 0, i = 0;
1838 char *curext = Nullch;
fc36a67e
PP
1839#else
1840# define MAX_EXT_LEN 0
a38d6535 1841#endif
79072805 1842
2a92aaa0
GS
1843 /*
1844 * If dosearch is true and if scriptname does not contain path
1845 * delimiters, search the PATH for scriptname.
1846 *
1847 * If SEARCH_EXTS is also defined, will look for each
1848 * scriptname{SEARCH_EXTS} whenever scriptname is not found
1849 * while searching the PATH.
1850 *
1851 * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
1852 * proceeds as follows:
1853 * If DOSISH:
1854 * + look for ./scriptname{,.foo,.bar}
1855 * + search the PATH for scriptname{,.foo,.bar}
1856 *
1857 * If !DOSISH:
1858 * + look *only* in the PATH for scriptname{,.foo,.bar} (note
1859 * this will not look in '.' if it's not in the PATH)
1860 */
1861
c07a80fd 1862#ifdef VMS
6e72f9df
PP
1863 if (dosearch) {
1864 int hasdir, idx = 0, deftypes = 1;
1a2dec3c 1865 bool seen_dot = 1;
6e72f9df
PP
1866
1867 hasdir = (strpbrk(scriptname,":[</") != Nullch) ;
1868 /* The first time through, just add SEARCH_EXTS to whatever we
1869 * already have, so we can check for default file types. */
fc36a67e
PP
1870 while (deftypes ||
1871 (!hasdir && my_trnlnm("DCL$PATH",tokenbuf,idx++)) )
1872 {
1873 if (deftypes) {
1874 deftypes = 0;
1875 *tokenbuf = '\0';
1876 }
1877 if ((strlen(tokenbuf) + strlen(scriptname)
1878 + MAX_EXT_LEN) >= sizeof tokenbuf)
1879 continue; /* don't search dir with too-long name */
1880 strcat(tokenbuf, scriptname);
c07a80fd 1881#else /* !VMS */
2a92aaa0 1882
fc36a67e 1883#ifdef DOSISH
2a92aaa0 1884 if (strEQ(scriptname, "-"))
84902520 1885 dosearch = 0;
2a92aaa0
GS
1886 if (dosearch) { /* Look in '.' first. */
1887 char *cur = scriptname;
1888#ifdef SEARCH_EXTS
1889 if ((curext = strrchr(scriptname,'.'))) /* possible current ext */
1890 while (ext[i])
1891 if (strEQ(ext[i++],curext)) {
1892 extidx = -1; /* already has an ext */
1893 break;
1894 }
1895 do {
79072805 1896#endif
2a92aaa0
GS
1897 DEBUG_p(PerlIO_printf(Perl_debug_log,
1898 "Looking for %s\n",cur));
1899 if (Stat(cur,&statbuf) >= 0) {
1900 dosearch = 0;
1901 scriptname = cur;
84902520 1902#ifdef SEARCH_EXTS
2a92aaa0 1903 break;
84902520 1904#endif
2a92aaa0
GS
1905 }
1906#ifdef SEARCH_EXTS
1907 if (cur == scriptname) {
1908 len = strlen(scriptname);
1909 if (len+MAX_EXT_LEN+1 >= sizeof(tokenbuf))
1910 break;
1911 cur = strcpy(tokenbuf, scriptname);
1912 }
1913 } while (extidx >= 0 && ext[extidx] /* try an extension? */
1914 && strcpy(tokenbuf+len, ext[extidx++]));
1915#endif
1916 }
1917#endif
84902520 1918
e92c4225
WJ
1919 if (dosearch && !strchr(scriptname, '/')
1920#ifdef DOSISH
1921 && !strchr(scriptname, '\\')
1922#endif
1923 && (s = getenv("PATH"))) {
2a92aaa0 1924 bool seen_dot = 0;
84902520 1925
79072805 1926 bufend = s + strlen(s);
fc36a67e 1927 while (s < bufend) {
2a92aaa0
GS
1928#if defined(atarist) || defined(DOSISH)
1929 for (len = 0; *s
1930# ifdef atarist
1931 && *s != ','
1932# endif
1933 && *s != ';'; len++, s++) {
fc36a67e
PP
1934 if (len < sizeof tokenbuf)
1935 tokenbuf[len] = *s;
1936 }
1937 if (len < sizeof tokenbuf)
1938 tokenbuf[len] = '\0';
84902520
TB
1939#else /* ! (atarist || DOSISH) */
1940 s = delimcpy(tokenbuf, tokenbuf + sizeof tokenbuf, s, bufend,
1941 ':',
1942 &len);
1943#endif /* ! (atarist || DOSISH) */
fc36a67e 1944 if (s < bufend)
79072805 1945 s++;
fc36a67e
PP
1946 if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tokenbuf)
1947 continue; /* don't search dir with too-long name */
1948 if (len
fc36a67e 1949#if defined(atarist) || defined(DOSISH)
2a92aaa0 1950 && tokenbuf[len - 1] != '/'
fc36a67e 1951 && tokenbuf[len - 1] != '\\'
79072805 1952#endif
fc36a67e
PP
1953 )
1954 tokenbuf[len++] = '/';
84902520 1955 if (len == 2 && tokenbuf[0] == '.')
2a92aaa0 1956 seen_dot = 1;
fc36a67e 1957 (void)strcpy(tokenbuf + len, scriptname);
c07a80fd 1958#endif /* !VMS */
a38d6535
LW
1959
1960#ifdef SEARCH_EXTS
1961 len = strlen(tokenbuf);
1962 if (extidx > 0) /* reset after previous loop */
1963 extidx = 0;
1964 do {
1965#endif
760ac839 1966 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tokenbuf));
a38d6535
LW
1967 retval = Stat(tokenbuf,&statbuf);
1968#ifdef SEARCH_EXTS
1969 } while ( retval < 0 /* not there */
1970 && extidx>=0 && ext[extidx] /* try an extension? */
1971 && strcpy(tokenbuf+len, ext[extidx++])
1972 );
1973#endif
1974 if (retval < 0)
79072805
LW
1975 continue;
1976 if (S_ISREG(statbuf.st_mode)
c90c0ff4
PP
1977 && cando(S_IRUSR,TRUE,&statbuf)
1978#ifndef DOSISH
1979 && cando(S_IXUSR,TRUE,&statbuf)
1980#endif
1981 )
1982 {
79072805
LW
1983 xfound = tokenbuf; /* bingo! */
1984 break;
1985 }
1986 if (!xfailed)
a0d0e21e 1987 xfailed = savepv(tokenbuf);
79072805 1988 }
2a92aaa0
GS
1989#ifndef DOSISH
1990 if (!xfound && !seen_dot && !xfailed && (Stat(scriptname,&statbuf) < 0))
84902520
TB
1991#endif
1992 seen_dot = 1; /* Disable message. */
79072805 1993 if (!xfound)
84902520 1994 croak("Can't %s %s%s%s",
2a92aaa0
GS
1995 (xfailed ? "execute" : "find"),
1996 (xfailed ? xfailed : scriptname),
1997 (xfailed ? "" : " on PATH"),
1998 (xfailed || seen_dot) ? "" : ", '.' not in PATH");
79072805
LW
1999 if (xfailed)
2000 Safefree(xfailed);
2001 scriptname = xfound;
2002 }
2003
96436eeb
PP
2004 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
2005 char *s = scriptname + 8;
2006 fdscript = atoi(s);
2007 while (isDIGIT(*s))
2008 s++;
2009 if (*s)
2010 scriptname = s + 1;
2011 }
2012 else
2013 fdscript = -1;
ab821d7f 2014 origfilename = savepv(e_tmpname ? "-e" : scriptname);
79072805
LW
2015 curcop->cop_filegv = gv_fetchfile(origfilename);
2016 if (strEQ(origfilename,"-"))
2017 scriptname = "";
96436eeb 2018 if (fdscript >= 0) {
760ac839 2019 rsfp = PerlIO_fdopen(fdscript,"r");
96436eeb 2020#if defined(HAS_FCNTL) && defined(F_SETFD)
7aa04957
CS
2021 if (rsfp)
2022 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
96436eeb
PP
2023#endif
2024 }
2025 else if (preprocess) {
46fc3d4c
PP
2026 char *cpp_cfg = CPPSTDIN;
2027 SV *cpp = NEWSV(0,0);
2028 SV *cmd = NEWSV(0,0);
2029
2030 if (strEQ(cpp_cfg, "cppstdin"))
2031 sv_catpvf(cpp, "%s/", BIN_EXP);
2032 sv_catpv(cpp, cpp_cfg);
79072805 2033
79072805 2034 sv_catpv(sv,"-I");
fed7345c 2035 sv_catpv(sv,PRIVLIB_EXP);
46fc3d4c 2036
79072805 2037#ifdef MSDOS
46fc3d4c 2038 sv_setpvf(cmd, "\
79072805
LW
2039sed %s -e \"/^[^#]/b\" \
2040 -e \"/^#[ ]*include[ ]/b\" \
2041 -e \"/^#[ ]*define[ ]/b\" \
2042 -e \"/^#[ ]*if[ ]/b\" \
2043 -e \"/^#[ ]*ifdef[ ]/b\" \
2044 -e \"/^#[ ]*ifndef[ ]/b\" \
2045 -e \"/^#[ ]*else/b\" \
2046 -e \"/^#[ ]*elif[ ]/b\" \
2047 -e \"/^#[ ]*undef[ ]/b\" \
2048 -e \"/^#[ ]*endif/b\" \
2049 -e \"s/^#.*//\" \
fc36a67e 2050 %s | %_ -C %_ %s",
79072805
LW
2051 (doextract ? "-e \"1,/^#/d\n\"" : ""),
2052#else
46fc3d4c 2053 sv_setpvf(cmd, "\
79072805
LW
2054%s %s -e '/^[^#]/b' \
2055 -e '/^#[ ]*include[ ]/b' \
2056 -e '/^#[ ]*define[ ]/b' \
2057 -e '/^#[ ]*if[ ]/b' \
2058 -e '/^#[ ]*ifdef[ ]/b' \
2059 -e '/^#[ ]*ifndef[ ]/b' \
2060 -e '/^#[ ]*else/b' \
2061 -e '/^#[ ]*elif[ ]/b' \
2062 -e '/^#[ ]*undef[ ]/b' \
2063 -e '/^#[ ]*endif/b' \
2064 -e 's/^[ ]*#.*//' \
fc36a67e 2065 %s | %_ -C %_ %s",
79072805
LW
2066#ifdef LOC_SED
2067 LOC_SED,
2068#else
2069 "sed",
2070#endif
2071 (doextract ? "-e '1,/^#/d\n'" : ""),
2072#endif
46fc3d4c 2073 scriptname, cpp, sv, CPPMINUS);
79072805
LW
2074 doextract = FALSE;
2075#ifdef IAMSUID /* actually, this is caught earlier */
2076 if (euid != uid && !euid) { /* if running suidperl */
2077#ifdef HAS_SETEUID
2078 (void)seteuid(uid); /* musn't stay setuid root */
2079#else
2080#ifdef HAS_SETREUID
85e6fe83
LW
2081 (void)setreuid((Uid_t)-1, uid);
2082#else
2083#ifdef HAS_SETRESUID
2084 (void)setresuid((Uid_t)-1, uid, (Uid_t)-1);
79072805
LW
2085#else
2086 setuid(uid);
2087#endif
2088#endif
85e6fe83 2089#endif
79072805 2090 if (geteuid() != uid)
463ee0b2 2091 croak("Can't do seteuid!\n");
79072805
LW
2092 }
2093#endif /* IAMSUID */
46fc3d4c
PP
2094 rsfp = my_popen(SvPVX(cmd), "r");
2095 SvREFCNT_dec(cmd);
2096 SvREFCNT_dec(cpp);
79072805
LW
2097 }
2098 else if (!*scriptname) {
bbce6d69 2099 forbid_setid("program input from stdin");
760ac839 2100 rsfp = PerlIO_stdin();
79072805 2101 }
96436eeb 2102 else {
760ac839 2103 rsfp = PerlIO_open(scriptname,"r");
96436eeb 2104#if defined(HAS_FCNTL) && defined(F_SETFD)
7aa04957
CS
2105 if (rsfp)
2106 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
96436eeb
PP
2107#endif
2108 }
5dd60ef7
PP
2109 if (e_tmpname) {
2110 e_fp = rsfp;
2111 }
7aa04957 2112 if (!rsfp) {
13281fa4 2113#ifdef DOSUID
a687059c 2114#ifndef IAMSUID /* in case script is not readable before setuid */
a0d0e21e 2115 if (euid && Stat(SvPVX(GvSV(curcop->cop_filegv)),&statbuf) >= 0 &&
13281fa4 2116 statbuf.st_mode & (S_ISUID|S_ISGID)) {
46fc3d4c
PP
2117 /* try again */
2118 execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
463ee0b2 2119 croak("Can't do setuid\n");
13281fa4
LW
2120 }
2121#endif
2122#endif
463ee0b2 2123 croak("Can't open perl script \"%s\": %s\n",
2304df62 2124 SvPVX(GvSV(curcop->cop_filegv)), Strerror(errno));
13281fa4 2125 }
79072805 2126}
8d063cd8 2127
79072805 2128static void
8ac85365 2129validate_suid(char *validarg, char *scriptname)
79072805 2130{
96436eeb
PP
2131 int which;
2132
13281fa4
LW
2133 /* do we need to emulate setuid on scripts? */
2134
2135 /* This code is for those BSD systems that have setuid #! scripts disabled
2136 * in the kernel because of a security problem. Merely defining DOSUID
2137 * in perl will not fix that problem, but if you have disabled setuid
2138 * scripts in the kernel, this will attempt to emulate setuid and setgid
2139 * on scripts that have those now-otherwise-useless bits set. The setuid
27e2fb84
LW
2140 * root version must be called suidperl or sperlN.NNN. If regular perl
2141 * discovers that it has opened a setuid script, it calls suidperl with
2142 * the same argv that it had. If suidperl finds that the script it has
2143 * just opened is NOT setuid root, it sets the effective uid back to the
2144 * uid. We don't just make perl setuid root because that loses the
2145 * effective uid we had before invoking perl, if it was different from the
2146 * uid.
13281fa4
LW
2147 *
2148 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
2149 * be defined in suidperl only. suidperl must be setuid root. The
2150 * Configure script will set this up for you if you want it.
2151 */
a687059c 2152
13281fa4 2153#ifdef DOSUID
ea0efc06 2154 dTHR;
6e72f9df 2155 char *s, *s2;
a0d0e21e 2156
760ac839 2157 if (Fstat(PerlIO_fileno(rsfp),&statbuf) < 0) /* normal stat is insecure */
463ee0b2 2158 croak("Can't stat script \"%s\"",origfilename);
96436eeb 2159 if (fdscript < 0 && statbuf.st_mode & (S_ISUID|S_ISGID)) {
79072805 2160 I32 len;
13281fa4 2161
a687059c 2162#ifdef IAMSUID
fe14fcc3 2163#ifndef HAS_SETREUID
a687059c
LW
2164 /* On this access check to make sure the directories are readable,
2165 * there is actually a small window that the user could use to make
2166 * filename point to an accessible directory. So there is a faint
2167 * chance that someone could execute a setuid script down in a
2168 * non-accessible directory. I don't know what to do about that.
2169 * But I don't think it's too important. The manual lies when
2170 * it says access() is useful in setuid programs.
2171 */
463ee0b2
LW
2172 if (access(SvPVX(GvSV(curcop->cop_filegv)),1)) /*double check*/
2173 croak("Permission denied");
a687059c
LW
2174#else
2175 /* If we can swap euid and uid, then we can determine access rights
2176 * with a simple stat of the file, and then compare device and
2177 * inode to make sure we did stat() on the same file we opened.
2178 * Then we just have to make sure he or she can execute it.
2179 */
2180 {
2181 struct stat tmpstatbuf;
2182
85e6fe83
LW
2183 if (
2184#ifdef HAS_SETREUID
2185 setreuid(euid,uid) < 0
a0d0e21e
LW
2186#else
2187# if HAS_SETRESUID
85e6fe83 2188 setresuid(euid,uid,(Uid_t)-1) < 0
a0d0e21e 2189# endif
85e6fe83
LW
2190#endif
2191 || getuid() != euid || geteuid() != uid)
463ee0b2 2192 croak("Can't swap uid and euid"); /* really paranoid */
a0d0e21e 2193 if (Stat(SvPVX(GvSV(curcop->cop_filegv)),&tmpstatbuf) < 0)
463ee0b2 2194 croak("Permission denied"); /* testing full pathname here */
a687059c
LW
2195 if (tmpstatbuf.st_dev != statbuf.st_dev ||
2196 tmpstatbuf.st_ino != statbuf.st_ino) {
760ac839 2197 (void)PerlIO_close(rsfp);
79072805 2198 if (rsfp = my_popen("/bin/mail root","w")) { /* heh, heh */
760ac839 2199 PerlIO_printf(rsfp,
ff0cee69
PP
2200"User %ld tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
2201(Filename of set-id script was %s, uid %ld gid %ld.)\n\nSincerely,\nperl\n",
2202 (long)uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
2203 (long)statbuf.st_dev, (long)statbuf.st_ino,
463ee0b2 2204 SvPVX(GvSV(curcop->cop_filegv)),
ff0cee69 2205 (long)statbuf.st_uid, (long)statbuf.st_gid);
79072805 2206 (void)my_pclose(rsfp);
a687059c 2207 }
463ee0b2 2208 croak("Permission denied\n");
a687059c 2209 }
85e6fe83
LW
2210 if (
2211#ifdef HAS_SETREUID
2212 setreuid(uid,euid) < 0
a0d0e21e
LW
2213#else
2214# if defined(HAS_SETRESUID)
85e6fe83 2215 setresuid(uid,euid,(Uid_t)-1) < 0
a0d0e21e 2216# endif
85e6fe83
LW
2217#endif
2218 || getuid() != uid || geteuid() != euid)
463ee0b2 2219 croak("Can't reswap uid and euid");
27e2fb84 2220 if (!cando(S_IXUSR,FALSE,&statbuf)) /* can real uid exec? */
463ee0b2 2221 croak("Permission denied\n");
a687059c 2222 }
fe14fcc3 2223#endif /* HAS_SETREUID */
a687059c
LW
2224#endif /* IAMSUID */
2225
27e2fb84 2226 if (!S_ISREG(statbuf.st_mode))
463ee0b2 2227 croak("Permission denied");
27e2fb84 2228 if (statbuf.st_mode & S_IWOTH)
463ee0b2 2229 croak("Setuid/gid script is writable by world");
13281fa4 2230 doswitches = FALSE; /* -s is insecure in suid */
79072805 2231 curcop->cop_line++;
760ac839
LW
2232 if (sv_gets(linestr, rsfp, 0) == Nullch ||
2233 strnNE(SvPV(linestr,na),"#!",2) ) /* required even on Sys V */
463ee0b2 2234 croak("No #! line");
760ac839 2235 s = SvPV(linestr,na)+2;
663a0e37 2236 if (*s == ' ') s++;
45d8adaa 2237 while (!isSPACE(*s)) s++;
760ac839 2238 for (s2 = s; (s2 > SvPV(linestr,na)+2 &&
6e72f9df
PP
2239 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
2240 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
463ee0b2 2241 croak("Not a perl script");
a687059c 2242 while (*s == ' ' || *s == '\t') s++;
13281fa4
LW
2243 /*
2244 * #! arg must be what we saw above. They can invoke it by
2245 * mentioning suidperl explicitly, but they may not add any strange
2246 * arguments beyond what #! says if they do invoke suidperl that way.
2247 */
2248 len = strlen(validarg);
2249 if (strEQ(validarg," PHOOEY ") ||
45d8adaa 2250 strnNE(s,validarg,len) || !isSPACE(s[len]))
463ee0b2 2251 croak("Args must match #! line");
a687059c
LW
2252
2253#ifndef IAMSUID
2254 if (euid != uid && (statbuf.st_mode & S_ISUID) &&
2255 euid == statbuf.st_uid)
2256 if (!do_undump)
463ee0b2 2257 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
a687059c
LW
2258FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2259#endif /* IAMSUID */
13281fa4
LW
2260
2261 if (euid) { /* oops, we're not the setuid root perl */
760ac839 2262 (void)PerlIO_close(rsfp);
13281fa4 2263#ifndef IAMSUID
46fc3d4c
PP
2264 /* try again */
2265 execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
13281fa4 2266#endif
463ee0b2 2267 croak("Can't do setuid\n");
13281fa4
LW
2268 }
2269
83025b21 2270 if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid) {
fe14fcc3 2271#ifdef HAS_SETEGID
a687059c
LW
2272 (void)setegid(statbuf.st_gid);
2273#else
fe14fcc3 2274#ifdef HAS_SETREGID
85e6fe83
LW
2275 (void)setregid((Gid_t)-1,statbuf.st_gid);
2276#else
2277#ifdef HAS_SETRESGID
2278 (void)setresgid((Gid_t)-1,statbuf.st_gid,(Gid_t)-1);
a687059c
LW
2279#else
2280 setgid(statbuf.st_gid);
2281#endif
2282#endif
85e6fe83 2283#endif
83025b21 2284 if (getegid() != statbuf.st_gid)
463ee0b2 2285 croak("Can't do setegid!\n");
83025b21 2286 }
a687059c
LW
2287 if (statbuf.st_mode & S_ISUID) {
2288 if (statbuf.st_uid != euid)
fe14fcc3 2289#ifdef HAS_SETEUID
a687059c
LW
2290 (void)seteuid(statbuf.st_uid); /* all that for this */
2291#else
fe14fcc3 2292#ifdef HAS_SETREUID
85e6fe83
LW
2293 (void)setreuid((Uid_t)-1,statbuf.st_uid);
2294#else
2295#ifdef HAS_SETRESUID
2296 (void)setresuid((Uid_t)-1,statbuf.st_uid,(Uid_t)-1);
a687059c
LW
2297#else
2298 setuid(statbuf.st_uid);
2299#endif
2300#endif
85e6fe83 2301#endif
83025b21 2302 if (geteuid() != statbuf.st_uid)
463ee0b2 2303 croak("Can't do seteuid!\n");
a687059c 2304 }
83025b21 2305 else if (uid) { /* oops, mustn't run as root */
fe14fcc3 2306#ifdef HAS_SETEUID
85e6fe83 2307 (void)seteuid((Uid_t)uid);
a687059c 2308#else
fe14fcc3 2309#ifdef HAS_SETREUID
85e6fe83 2310 (void)setreuid((Uid_t)-1,(Uid_t)uid);
a687059c 2311#else
85e6fe83
LW
2312#ifdef HAS_SETRESUID
2313 (void)setresuid((Uid_t)-1,(Uid_t)uid,(Uid_t)-1);
2314#else
2315 setuid((Uid_t)uid);
2316#endif
a687059c
LW
2317#endif
2318#endif
83025b21 2319 if (geteuid() != uid)
463ee0b2 2320 croak("Can't do seteuid!\n");
83025b21 2321 }
748a9306 2322 init_ids();
27e2fb84 2323 if (!cando(S_IXUSR,TRUE,&statbuf))
463ee0b2 2324 croak("Permission denied\n"); /* they can't do this */
13281fa4
LW
2325 }
2326#ifdef IAMSUID
2327 else if (preprocess)
463ee0b2 2328 croak("-P not allowed for setuid/setgid script\n");
96436eeb
PP
2329 else if (fdscript >= 0)
2330 croak("fd script not allowed in suidperl\n");
13281fa4 2331 else
463ee0b2 2332 croak("Script is not setuid/setgid in suidperl\n");
96436eeb
PP
2333
2334 /* We absolutely must clear out any saved ids here, so we */
2335 /* exec the real perl, substituting fd script for scriptname. */
2336 /* (We pass script name as "subdir" of fd, which perl will grok.) */
760ac839
LW
2337 PerlIO_rewind(rsfp);
2338 lseek(PerlIO_fileno(rsfp),(Off_t)0,0); /* just in case rewind didn't */
96436eeb
PP
2339 for (which = 1; origargv[which] && origargv[which] != scriptname; which++) ;
2340 if (!origargv[which])
2341 croak("Permission denied");
46fc3d4c
PP
2342 origargv[which] = savepv(form("/dev/fd/%d/%s",
2343 PerlIO_fileno(rsfp), origargv[which]));
96436eeb 2344#if defined(HAS_FCNTL) && defined(F_SETFD)
760ac839 2345 fcntl(PerlIO_fileno(rsfp),F_SETFD,0); /* ensure no close-on-exec */
96436eeb 2346#endif
46fc3d4c 2347 execv(form("%s/perl%s", BIN_EXP, patchlevel), origargv); /* try again */
96436eeb 2348 croak("Can't do setuid\n");
13281fa4 2349#endif /* IAMSUID */
a687059c 2350#else /* !DOSUID */
a687059c
LW
2351 if (euid != uid || egid != gid) { /* (suidperl doesn't exist, in fact) */
2352#ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
96827780 2353 dTHR;
760ac839 2354 Fstat(PerlIO_fileno(rsfp),&statbuf); /* may be either wrapped or real suid */
a687059c
LW
2355 if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
2356 ||
2357 (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
2358 )
2359 if (!do_undump)
463ee0b2 2360 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
a687059c
LW
2361FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2362#endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
2363 /* not set-id, must be wrapped */
a687059c 2364 }
13281fa4 2365#endif /* DOSUID */
79072805 2366}
13281fa4 2367
79072805 2368static void
8ac85365 2369find_beginning(void)
79072805 2370{
6e72f9df 2371 register char *s, *s2;
33b78306
LW
2372
2373 /* skip forward in input to the real script? */
2374
bbce6d69 2375 forbid_setid("-x");
33b78306 2376 while (doextract) {
79072805 2377 if ((s = sv_gets(linestr, rsfp, 0)) == Nullch)
463ee0b2 2378 croak("No Perl script found in input\n");
6e72f9df 2379 if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
760ac839 2380 PerlIO_ungetc(rsfp, '\n'); /* to keep line count right */
33b78306 2381 doextract = FALSE;
6e72f9df
PP
2382 while (*s && !(isSPACE (*s) || *s == '#')) s++;
2383 s2 = s;
2384 while (*s == ' ' || *s == '\t') s++;
2385 if (*s++ == '-') {
2386 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
2387 if (strnEQ(s2-4,"perl",4))
2388 /*SUPPRESS 530*/
2389 while (s = moreswitches(s)) ;
33b78306 2390 }
79072805 2391 if (cddir && chdir(cddir) < 0)
463ee0b2 2392 croak("Can't chdir to %s",cddir);
83025b21
LW
2393 }
2394 }
2395}
2396
79072805 2397static void
8ac85365 2398init_ids(void)
352d5a3a 2399{
748a9306
LW
2400 uid = (int)getuid();
2401 euid = (int)geteuid();
2402 gid = (int)getgid();
2403 egid = (int)getegid();
2404#ifdef VMS
2405 uid |= gid << 16;
2406 euid |= egid << 16;
2407#endif
4633a7c4 2408 tainting |= (uid && (euid != uid || egid != gid));
748a9306 2409}
79072805 2410
748a9306 2411static void
8ac85365 2412forbid_setid(char *s)
bbce6d69
PP
2413{
2414 if (euid != uid)
2415 croak("No %s allowed while running setuid", s);
2416 if (egid != gid)
2417 croak("No %s allowed while running setgid", s);
2418}
2419
2420static void
8ac85365 2421init_debugger(void)
748a9306 2422{
11343788 2423 dTHR;
79072805 2424 curstash = debstash;
748a9306 2425 dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
79072805 2426 AvREAL_off(dbargs);
a0d0e21e
LW
2427 DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
2428 DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
748a9306
LW
2429 DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
2430 DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
c07a80fd 2431 sv_setiv(DBsingle, 0);
748a9306 2432 DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
c07a80fd 2433 sv_setiv(DBtrace, 0);
748a9306 2434 DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
c07a80fd 2435 sv_setiv(DBsignal, 0);
79072805 2436 curstash = defstash;
352d5a3a
LW
2437}
2438
11343788 2439void
8ac85365 2440init_stacks(ARGSproto)
79072805 2441{
6e72f9df 2442 curstack = newAV();
5f05dabc
PP
2443 mainstack = curstack; /* remember in case we switch stacks */
2444 AvREAL_off(curstack); /* not a real array */
6e72f9df 2445 av_extend(curstack,127);
79072805 2446
6e72f9df 2447 stack_base = AvARRAY(curstack);
79072805 2448 stack_sp = stack_base;
8990e307 2449 stack_max = stack_base + 127;
79072805 2450
a5f75d66
AD
2451 cxstack_max = 8192 / sizeof(CONTEXT) - 2; /* Use most of 8K. */
2452 New(50,cxstack,cxstack_max + 1,CONTEXT);
8990e307 2453 cxstack_ix = -1;
8990e307
LW
2454
2455 New(50,tmps_stack,128,SV*);
6d4ff0d2 2456 tmps_floor = -1;
8990e307
LW
2457 tmps_ix = -1;
2458 tmps_max = 128;
2459
5f05dabc
PP
2460 /*
2461 * The following stacks almost certainly should be per-interpreter,
2462 * but for now they're not. XXX
2463 */
2464
6e72f9df
PP
2465 if (markstack) {
2466 markstack_ptr = markstack;
2467 } else {
2468 New(54,markstack,64,I32);
2469 markstack_ptr = markstack;
2470 markstack_max = markstack + 64;
2471 }
79072805 2472
6e72f9df
PP
2473 if (scopestack) {
2474 scopestack_ix = 0;
2475 } else {
2476 New(54,scopestack,32,I32);
2477 scopestack_ix = 0;
2478 scopestack_max = 32;
2479 }
79072805 2480
6e72f9df
PP
2481 if (savestack) {
2482 savestack_ix = 0;
2483 } else {
2484 New(54,savestack,128,ANY);
2485 savestack_ix = 0;
2486 savestack_max = 128;
2487 }
79072805 2488
6e72f9df
PP
2489 if (retstack) {
2490 retstack_ix = 0;
2491 } else {
2492 New(54,retstack,16,OP*);
2493 retstack_ix = 0;
2494 retstack_max = 16;
5f05dabc 2495 }
378cc40b 2496}
33b78306 2497
6e72f9df 2498static void
8ac85365 2499nuke_stacks(void)
6e72f9df 2500{
e858de61 2501 dTHR;
6e72f9df
PP
2502 Safefree(cxstack);
2503 Safefree(tmps_stack);
5f05dabc
PP
2504 DEBUG( {
2505 Safefree(debname);
2506 Safefree(debdelim);
2507 } )
378cc40b 2508}
33b78306 2509
760ac839 2510static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
7aa04957 2511
79072805 2512static void
8ac85365 2513init_lexer(void)
8990e307 2514{
a0d0e21e 2515 tmpfp = rsfp;
90248788 2516 rsfp = Nullfp;
8990e307
LW
2517 lex_start(linestr);
2518 rsfp = tmpfp;
2519 subname = newSVpv("main",4);
2520}
2521
2522static void
8ac85365 2523init_predump_symbols(void)
45d8adaa 2524{
11343788 2525 dTHR;
93a17b20 2526 GV *tmpgv;
a0d0e21e 2527 GV *othergv;
79072805 2528
a863c7d1 2529#ifdef USE_THREADS
554b3eca 2530 sv_setpvn(*av_fetch(thr->magicals,find_thread_magical("\""),FALSE)," ", 1);
a863c7d1 2531#else
85e6fe83 2532 sv_setpvn(GvSV(gv_fetchpv("\"", TRUE, SVt_PV)), " ", 1);
a863c7d1 2533#endif /* USE_THREADS */
79072805 2534
85e6fe83 2535 stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
a5f75d66 2536 GvMULTI_on(stdingv);
760ac839 2537 IoIFP(GvIOp(stdingv)) = PerlIO_stdin();
adbc6bb1 2538 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
a5f75d66 2539 GvMULTI_on(tmpgv);
a0d0e21e 2540 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(stdingv));
79072805 2541
85e6fe83 2542 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
a5f75d66 2543 GvMULTI_on(tmpgv);
760ac839 2544 IoOFP(GvIOp(tmpgv)) = IoIFP(GvIOp(tmpgv)) = PerlIO_stdout();
4633a7c4 2545 setdefout(tmpgv);
adbc6bb1 2546 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
a5f75d66 2547 GvMULTI_on(tmpgv);
a0d0e21e 2548 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(defoutgv));
79072805 2549
a0d0e21e 2550 othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
a5f75d66 2551 GvMULTI_on(othergv);
760ac839 2552 IoOFP(GvIOp(othergv)) = IoIFP(GvIOp(othergv)) = PerlIO_stderr();
adbc6bb1 2553 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
a5f75d66 2554 GvMULTI_on(tmpgv);
a0d0e21e 2555 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(othergv));
79072805
LW
2556
2557 statname = NEWSV(66,0); /* last filename we did stat on */
ab821d7f 2558
6e72f9df
PP
2559 if (!osname)
2560 osname = savepv(OSNAME);
79072805 2561}
33b78306 2562
79072805 2563static void
8ac85365 2564init_postdump_symbols(register int argc, register char **argv, register char **env)
33b78306 2565{
a863c7d1 2566 dTHR;
79072805
LW
2567 char *s;
2568 SV *sv;
2569 GV* tmpgv;
fe14fcc3 2570
79072805
LW
2571 argc--,argv++; /* skip name of script */
2572 if (doswitches) {
2573 for (; argc > 0 && **argv == '-'; argc--,argv++) {
2574 if (!argv[0][1])
2575 break;
2576 if (argv[0][1] == '-') {
2577 argc--,argv++;
2578 break;
2579 }
93a17b20 2580 if (s = strchr(argv[0], '=')) {
79072805 2581 *s++ = '\0';
85e6fe83 2582 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
79072805
LW
2583 }
2584 else
85e6fe83 2585 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
fe14fcc3 2586 }
79072805
LW
2587 }
2588 toptarget = NEWSV(0,0);
2589 sv_upgrade(toptarget, SVt_PVFM);
2590 sv_setpvn(toptarget, "", 0);
748a9306 2591 bodytarget = NEWSV(0,0);
79072805
LW
2592 sv_upgrade(bodytarget, SVt_PVFM);
2593 sv_setpvn(bodytarget, "", 0);
2594 formtarget = bodytarget;
2595
bbce6d69 2596 TAINT;
85e6fe83 2597 if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
79072805
LW
2598 sv_setpv(GvSV(tmpgv),origfilename);
2599 magicname("0", "0", 1);
2600 }
85e6fe83 2601 if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
79072805 2602 sv_setpv(GvSV(tmpgv),origargv[0]);
85e6fe83 2603 if (argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
a5f75d66 2604 GvMULTI_on(argvgv);
79072805
LW
2605 (void)gv_AVadd(argvgv);
2606 av_clear(GvAVn(argvgv));
2607 for (; argc > 0; argc--,argv++) {
a0d0e21e 2608 av_push(GvAVn(argvgv),newSVpv(argv[0],0));
79072805
LW
2609 }
2610 }
85e6fe83 2611 if (envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
79072805 2612 HV *hv;
a5f75d66 2613 GvMULTI_on(envgv);
79072805 2614 hv = GvHVn(envgv);
5aabfad6 2615 hv_magic(hv, envgv, 'E');
a0d0e21e 2616#ifndef VMS /* VMS doesn't have environ array */
4633a7c4
LW
2617 /* Note that if the supplied env parameter is actually a copy
2618 of the global environ then it may now point to free'd memory
2619 if the environment has been modified since. To avoid this
2620 problem we treat env==NULL as meaning 'use the default'
2621 */
2622 if (!env)
2623 env = environ;
5aabfad6 2624 if (env != environ)
79072805
LW
2625 environ[0] = Nullch;
2626 for (; *env; env++) {
93a17b20 2627 if (!(s = strchr(*env,'=')))
79072805
LW
2628 continue;
2629 *s++ = '\0';
137443ea
PP
2630#ifdef WIN32
2631 (void)strupr(*env);
2632#endif
79072805
LW
2633 sv = newSVpv(s--,0);
2634 (void)hv_store(hv, *env, s - *env, sv, 0);
2635 *s = '=';
3e3baf6d
TB
2636#if defined(__BORLANDC__) && defined(USE_WIN32_RTL_ENV)
2637 /* Sins of the RTL. See note in my_setenv(). */
2638 (void)putenv(savepv(*env));
2639#endif
fe14fcc3 2640 }
4550b24a
PP
2641#endif
2642#ifdef DYNAMIC_ENV_FETCH
2643 HvNAME(hv) = savepv(ENV_HV_NAME);
2644#endif
79072805 2645 }
bbce6d69 2646 TAINT_NOT;
85e6fe83 2647 if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
1e422769 2648 sv_setiv(GvSV(tmpgv), (IV)getpid());
33b78306 2649}
34de22dd 2650
79072805 2651static void
8ac85365 2652init_perllib(void)
34de22dd 2653{
85e6fe83
LW
2654 char *s;
2655 if (!tainting) {
552a7a9b 2656#ifndef VMS
85e6fe83
LW
2657 s = getenv("PERL5LIB");
2658 if (s)
774d564b 2659 incpush(s, TRUE);
85e6fe83 2660 else
774d564b 2661 incpush(getenv("PERLLIB"), FALSE);
552a7a9b
PP
2662#else /* VMS */
2663 /* Treat PERL5?LIB as a possible search list logical name -- the
2664 * "natural" VMS idiom for a Unix path string. We allow each
2665 * element to be a set of |-separated directories for compatibility.
2666 */
2667 char buf[256];
2668 int idx = 0;
2669 if (my_trnlnm("PERL5LIB",buf,0))
774d564b 2670 do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
552a7a9b 2671 else
774d564b 2672 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE);
552a7a9b 2673#endif /* VMS */
85e6fe83 2674 }
34de22dd 2675
c90c0ff4 2676/* Use the ~-expanded versions of APPLLIB (undocumented),
df5cef82
PP
2677 ARCHLIB PRIVLIB SITEARCH SITELIB and OLDARCHLIB
2678*/
4633a7c4 2679#ifdef APPLLIB_EXP
774d564b 2680 incpush(APPLLIB_EXP, FALSE);
16d20bd9 2681#endif
4633a7c4 2682
fed7345c 2683#ifdef ARCHLIB_EXP
774d564b 2684 incpush(ARCHLIB_EXP, FALSE);
a0d0e21e 2685#endif
fed7345c
AD
2686#ifndef PRIVLIB_EXP
2687#define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
34de22dd 2688#endif
774d564b 2689 incpush(PRIVLIB_EXP, FALSE);
4633a7c4
LW
2690
2691#ifdef SITEARCH_EXP
774d564b 2692 incpush(SITEARCH_EXP, FALSE);
4633a7c4
LW
2693#endif
2694#ifdef SITELIB_EXP
774d564b 2695 incpush(SITELIB_EXP, FALSE);
4633a7c4
LW
2696#endif
2697#ifdef OLDARCHLIB_EXP /* 5.00[01] compatibility */
774d564b 2698 incpush(OLDARCHLIB_EXP, FALSE);
4633a7c4 2699#endif
a0d0e21e 2700
4633a7c4 2701 if (!tainting)
774d564b
PP
2702 incpush(".", FALSE);
2703}
2704
2705#if defined(DOSISH)
2706# define PERLLIB_SEP ';'
2707#else
2708# if defined(VMS)
2709# define PERLLIB_SEP '|'
2710# else
2711# define PERLLIB_SEP ':'
2712# endif
2713#endif
2714#ifndef PERLLIB_MANGLE
2715# define PERLLIB_MANGLE(s,n) (s)
2716#endif
2717
2718static void
8ac85365 2719incpush(char *p, int addsubdirs)
774d564b
PP
2720{
2721 SV *subdir = Nullsv;
2722 static char *archpat_auto;
2723
2724 if (!p)
2725 return;
2726
2727 if (addsubdirs) {
2728 subdir = newSV(0);
2729 if (!archpat_auto) {
2730 STRLEN len = (sizeof(ARCHNAME) + strlen(patchlevel)
2731 + sizeof("//auto"));
2732 New(55, archpat_auto, len, char);
2733 sprintf(archpat_auto, "/%s/%s/auto", ARCHNAME, patchlevel);
aa689395
PP
2734#ifdef VMS
2735 for (len = sizeof(ARCHNAME) + 2;
2736 archpat_auto[len] != '\0' && archpat_auto[len] != '/'; len++)
2737 if (archpat_auto[len] == '.') archpat_auto[len] = '_';
2738#endif
774d564b
PP
2739 }
2740 }
2741
2742 /* Break at all separators */
2743 while (p && *p) {
2744 SV *libdir = newSV(0);
2745 char *s;
2746
2747 /* skip any consecutive separators */
2748 while ( *p == PERLLIB_SEP ) {
2749 /* Uncomment the next line for PATH semantics */
2750 /* av_push(GvAVn(incgv), newSVpv(".", 1)); */
2751 p++;
2752 }
2753
2754 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
2755 sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
2756 (STRLEN)(s - p));
2757 p = s + 1;
2758 }
2759 else {
2760 sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
2761 p = Nullch; /* break out */
2762 }
2763
2764 /*
2765 * BEFORE pushing libdir onto @INC we may first push version- and
2766 * archname-specific sub-directories.
2767 */
2768 if (addsubdirs) {
2769 struct stat tmpstatbuf;
aa689395
PP
2770#ifdef VMS
2771 char *unix;
2772 STRLEN len;
774d564b 2773
aa689395
PP
2774 if ((unix = tounixspec_ts(SvPV(libdir,na),Nullch)) != Nullch) {
2775 len = strlen(unix);
2776 while (unix[len-1] == '/') len--; /* Cosmetic */
2777 sv_usepvn(libdir,unix,len);
2778 }
2779 else
2780 PerlIO_printf(PerlIO_stderr(),
2781 "Failed to unixify @INC element \"%s\"\n",
2782 SvPV(libdir,na));
2783#endif
4fdae800 2784 /* .../archname/version if -d .../archname/version/auto */
774d564b
PP
2785 sv_setsv(subdir, libdir);
2786 sv_catpv(subdir, archpat_auto);
2787 if (Stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2788 S_ISDIR(tmpstatbuf.st_mode))
2789 av_push(GvAVn(incgv),
2790 newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2791
4fdae800 2792 /* .../archname if -d .../archname/auto */
774d564b
PP
2793 sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME),
2794 strlen(patchlevel) + 1, "", 0);
2795 if (Stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2796 S_ISDIR(tmpstatbuf.st_mode))
2797 av_push(GvAVn(incgv),
2798 newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2799 }
2800
2801 /* finally push this lib directory on the end of @INC */
2802 av_push(GvAVn(incgv), libdir);
2803 }
2804
2805 SvREFCNT_dec(subdir);
34de22dd 2806}
93a17b20 2807
199100c8
MB
2808#ifdef USE_THREADS
2809static struct thread *
2810init_main_thread()
2811{
2812 struct thread *thr;
2813 XPV *xpv;
2814
2815 Newz(53, thr, 1, struct thread);
2816 curcop = &compiling;
2817 thr->cvcache = newHV();
2818 thr->magicals = newAV();
2819 thr->specific = newAV();
38a03e6e 2820 thr->errhv = newHV();
199100c8
MB
2821 thr->flags = THRf_R_JOINABLE;
2822 MUTEX_INIT(&thr->mutex);
2823 /* Handcraft thrsv similarly to mess_sv */
2824 New(53, thrsv, 1, SV);
2825 Newz(53, xpv, 1, XPV);
2826 SvFLAGS(thrsv) = SVt_PV;
2827 SvANY(thrsv) = (void*)xpv;
2828 SvREFCNT(thrsv) = 1 << 30; /* practically infinite */
2829 SvPVX(thrsv) = (char*)thr;
2830 SvCUR_set(thrsv, sizeof(thr));
2831 SvLEN_set(thrsv, sizeof(thr));
2832 *SvEND(thrsv) = '\0'; /* in the trailing_nul field */
2833 thr->oursv = thrsv;
2834 curcop = &compiling;
2835 chopset = " \n-";
2836
2837 MUTEX_LOCK(&threads_mutex);
2838 nthreads++;
2839 thr->tid = 0;
2840 thr->next = thr;
2841 thr->prev = thr;
2842 MUTEX_UNLOCK(&threads_mutex);
2843
2844#ifdef HAVE_THREAD_INTERN
2845 init_thread_intern(thr);
2846#else
2847 thr->self = pthread_self();
2848#endif /* HAVE_THREAD_INTERN */
2849 SET_THR(thr);
2850
2851 /*
2852 * These must come after the SET_THR because sv_setpvn does
2853 * SvTAINT and the taint fields require dTHR.
2854 */
2855 toptarget = NEWSV(0,0);
2856 sv_upgrade(toptarget, SVt_PVFM);
2857 sv_setpvn(toptarget, "", 0);
2858 bodytarget = NEWSV(0,0);
2859 sv_upgrade(bodytarget, SVt_PVFM);
2860 sv_setpvn(bodytarget, "", 0);
2861 formtarget = bodytarget;
2faa37cc 2862 thr->errsv = newSVpv("", 0);
199100c8
MB
2863 return thr;
2864}
2865#endif /* USE_THREADS */
2866
93a17b20 2867void
8ac85365 2868call_list(I32 oldscope, AV *list)
93a17b20 2869{
11343788 2870 dTHR;
a0d0e21e 2871 line_t oldline = curcop->cop_line;
22921e25
CS
2872 STRLEN len;
2873 dJMPENV;
2874 int ret;
93a17b20 2875
8990e307
LW
2876 while (AvFILL(list) >= 0) {
2877 CV *cv = (CV*)av_shift(list);
93a17b20 2878
8990e307 2879 SAVEFREESV(cv);
a0d0e21e 2880
22921e25
CS
2881 JMPENV_PUSH(ret);
2882 switch (ret) {
748a9306 2883 case 0: {
38a03e6e 2884 SV* atsv = ERRSV;
748a9306
LW
2885 PUSHMARK(stack_sp);
2886 perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
12f917ad 2887 (void)SvPV(atsv, len);
748a9306 2888 if (len) {
54310121 2889 JMPENV_POP;
748a9306
LW
2890 curcop = &compiling;
2891 curcop->cop_line = oldline;
2892 if (list == beginav)
12f917ad 2893 sv_catpv(atsv, "BEGIN failed--compilation aborted");
748a9306 2894 else
12f917ad 2895 sv_catpv(atsv, "END failed--cleanup aborted");
2ae324a7
PP
2896 while (scopestack_ix > oldscope)
2897 LEAVE;
12f917ad 2898 croak("%s", SvPVX(atsv));
748a9306 2899 }
a0d0e21e 2900 }
85e6fe83
LW
2901 break;
2902 case 1:
f86702cc 2903 STATUS_ALL_FAILURE;
85e6fe83
LW
2904 /* FALL THROUGH */
2905 case 2:
2906 /* my_exit() was called */
2ae324a7
PP
2907 while (scopestack_ix > oldscope)
2908 LEAVE;
84902520 2909 FREETMPS;
85e6fe83
LW
2910 curstash = defstash;
2911 if (endav)
68dc0745 2912 call_list(oldscope, endav);
54310121 2913 JMPENV_POP;
a0d0e21e
LW
2914 curcop = &compiling;
2915 curcop->cop_line = oldline;
85e6fe83
LW
2916 if (statusvalue) {
2917 if (list == beginav)
a0d0e21e 2918 croak("BEGIN failed--compilation aborted");
85e6fe83 2919 else
a0d0e21e 2920 croak("END failed--cleanup aborted");
85e6fe83 2921 }
f86702cc 2922 my_exit_jump();
85e6fe83 2923 /* NOTREACHED */
85e6fe83
LW
2924 case 3:
2925 if (!restartop) {
760ac839 2926 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
a0d0e21e 2927 FREETMPS;
85e6fe83
LW
2928 break;
2929 }
54310121 2930 JMPENV_POP;
a0d0e21e
LW
2931 curcop = &compiling;
2932 curcop->cop_line = oldline;
54310121 2933 JMPENV_JUMP(3);
8990e307 2934 }
54310121 2935 JMPENV_POP;
93a17b20 2936 }
93a17b20 2937}
93a17b20 2938
f86702cc 2939void
8ac85365 2940my_exit(U32 status)
f86702cc 2941{
5dc0d613
MB
2942 dTHR;
2943
2944#ifdef USE_THREADS
a863c7d1
MB
2945 DEBUG_L(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
2946 thr, (unsigned long) status));
5dc0d613 2947#endif /* USE_THREADS */
f86702cc
PP
2948 switch (status) {
2949 case 0:
2950 STATUS_ALL_SUCCESS;
2951 break;
2952 case 1:
2953 STATUS_ALL_FAILURE;
2954 break;
2955 default:
2956 STATUS_NATIVE_SET(status);
2957 break;
2958 }
2959 my_exit_jump();
2960}
2961
2962void
8ac85365 2963my_failure_exit(void)
f86702cc
PP
2964{
2965#ifdef VMS
2966 if (vaxc$errno & 1) {
4fdae800
PP
2967 if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
2968 STATUS_NATIVE_SET(44);
f86702cc
PP
2969 }
2970 else {
ff0cee69 2971 if (!vaxc$errno && errno) /* unlikely */
4fdae800 2972 STATUS_NATIVE_SET(44);
f86702cc 2973 else
4fdae800 2974 STATUS_NATIVE_SET(vaxc$errno);
f86702cc
PP
2975 }
2976#else
2977 if (errno & 255)
2978 STATUS_POSIX_SET(errno);
2979 else if (STATUS_POSIX == 0)
2980 STATUS_POSIX_SET(255);
2981#endif
2982 my_exit_jump();
93a17b20
LW
2983}
2984
f86702cc 2985static void
8ac85365 2986my_exit_jump(void)
f86702cc 2987{
e858de61 2988 dTHR;
f86702cc
PP
2989 register CONTEXT *cx;
2990 I32 gimme;
2991 SV **newsp;
2992
2993 if (e_tmpname) {
2994 if (e_fp) {
2995 PerlIO_close(e_fp);
2996 e_fp = Nullfp;
2997 }
2998 (void)UNLINK(e_tmpname);
2999 Safefree(e_tmpname);
3000 e_tmpname = Nullch;
3001 }
3002
3003 if (cxstack_ix >= 0) {
3004 if (cxstack_ix > 0)
3005 dounwind(0);
3006 POPBLOCK(cx,curpm);
3007 LEAVE;
3008 }
ff0cee69 3009
54310121 3010 JMPENV_JUMP(2);
f86702cc 3011}
4e35701f 3012
aeea060c 3013