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