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