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