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