This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
added suggested patch (via PM), tweaked to implicitly specify -DDEBUGGING
[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
a3f9223b
GS
1721#ifdef __BEOS__
1722 printf("BeOS port Copyright Tom Spindler, 1997-1998\n");
1723#endif
baed7233
DL
1724#ifdef BINARY_BUILD_NOTICE
1725 BINARY_BUILD_NOTICE;
1726#endif
760ac839 1727 printf("\n\
79072805 1728Perl may be copied only under the terms of either the Artistic License or the\n\
95103687
GS
1729GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n\
1730Complete documentation for Perl, including FAQ lists, should be found on\n\
1731this system using `man perl' or `perldoc perl'. If you have access to the\n\
1732Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n");
6ad3d225 1733 PerlProc_exit(0);
79072805
LW
1734 case 'w':
1735 dowarn = TRUE;
1736 s++;
1737 return s;
a0d0e21e 1738 case '*':
79072805
LW
1739 case ' ':
1740 if (s[1] == '-') /* Additional switches on #! line. */
1741 return s+2;
1742 break;
a0d0e21e 1743 case '-':
79072805 1744 case 0:
a868473f
NIS
1745#ifdef WIN32
1746 case '\r':
1747#endif
79072805
LW
1748 case '\n':
1749 case '\t':
1750 break;
aa689395
PP
1751#ifdef ALTERNATE_SHEBANG
1752 case 'S': /* OS/2 needs -S on "extproc" line. */
1753 break;
1754#endif
a0d0e21e
LW
1755 case 'P':
1756 if (preprocess)
1757 return s+1;
1758 /* FALL THROUGH */
79072805 1759 default:
a0d0e21e 1760 croak("Can't emulate -%.1s on #! line",s);
79072805
LW
1761 }
1762 return Nullch;
1763}
1764
1765/* compliments of Tom Christiansen */
1766
1767/* unexec() can be found in the Gnu emacs distribution */
ee580363 1768/* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
79072805
LW
1769
1770void
8ac85365 1771my_unexec(void)
79072805
LW
1772{
1773#ifdef UNEXEC
46fc3d4c
PP
1774 SV* prog;
1775 SV* file;
ee580363 1776 int status = 1;
79072805
LW
1777 extern int etext;
1778
ee580363 1779 prog = newSVpv(BIN_EXP, 0);
46fc3d4c 1780 sv_catpv(prog, "/perl");
ee580363 1781 file = newSVpv(origfilename, 0);
46fc3d4c 1782 sv_catpv(file, ".perldump");
79072805 1783
ee580363
GS
1784 unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
1785 /* unexec prints msg to stderr in case of failure */
6ad3d225 1786 PerlProc_exit(status);
79072805 1787#else
a5f75d66
AD
1788# ifdef VMS
1789# include <lib$routines.h>
1790 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
aa689395 1791# else
79072805 1792 ABORT(); /* for use with undump */
aa689395 1793# endif
a5f75d66 1794#endif
79072805
LW
1795}
1796
cb68f92d
GS
1797/* initialize curinterp */
1798STATIC void
1799init_interp(void)
1800{
1801
066ef5b5 1802#ifdef PERL_OBJECT /* XXX kludge */
cb68f92d
GS
1803#define I_REINIT \
1804 STMT_START { \
1805 chopset = " \n-"; \
1806 copline = NOLINE; \
1807 curcop = &compiling; \
1808 curcopdb = NULL; \
1809 dbargs = 0; \
1810 dlmax = 128; \
1811 laststatval = -1; \
1812 laststype = OP_STAT; \
1813 maxscream = -1; \
1814 maxsysfd = MAXSYSFD; \
1815 statname = Nullsv; \
1816 tmps_floor = -1; \
1817 tmps_ix = -1; \
1818 op_mask = NULL; \
1819 dlmax = 128; \
1820 laststatval = -1; \
1821 laststype = OP_STAT; \
1822 mess_sv = Nullsv; \
1823 splitstr = " "; \
1824 generation = 100; \
1825 exitlist = NULL; \
1826 exitlistlen = 0; \
1827 regindent = 0; \
1828 in_clean_objs = FALSE; \
1829 in_clean_all= FALSE; \
1830 profiledata = NULL; \
1831 rsfp = Nullfp; \
1832 rsfp_filters= Nullav; \
1833 } STMT_END
9666903d 1834 I_REINIT;
066ef5b5
GS
1835#else
1836# ifdef MULTIPLICITY
1837# define PERLVAR(var,type)
1838# define PERLVARI(var,type,init) curinterp->var = init;
1839# define PERLVARIC(var,type,init) curinterp->var = init;
1840# include "intrpvar.h"
1841# ifndef USE_THREADS
1842# include "thrdvar.h"
1843# endif
1844# undef PERLVAR
1845# undef PERLVARI
1846# undef PERLVARIC
1847# else
1848# define PERLVAR(var,type)
1849# define PERLVARI(var,type,init) var = init;
1850# define PERLVARIC(var,type,init) var = init;
1851# include "intrpvar.h"
1852# ifndef USE_THREADS
1853# include "thrdvar.h"
1854# endif
1855# undef PERLVAR
1856# undef PERLVARI
1857# undef PERLVARIC
1858# endif
cb68f92d
GS
1859#endif
1860
cb68f92d
GS
1861}
1862
76e3520e 1863STATIC void
8ac85365 1864init_main_stash(void)
79072805 1865{
11343788 1866 dTHR;
463ee0b2 1867 GV *gv;
6e72f9df
PP
1868
1869 /* Note that strtab is a rather special HV. Assumptions are made
1870 about not iterating on it, and not adding tie magic to it.
1871 It is properly deallocated in perl_destruct() */
1872 strtab = newHV();
1873 HvSHAREKEYS_off(strtab); /* mandatory */
8fb9a439 1874 hv_ksplit(strtab, 512);
6e72f9df 1875
463ee0b2 1876 curstash = defstash = newHV();
79072805 1877 curstname = newSVpv("main",4);
adbc6bb1
LW
1878 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
1879 SvREFCNT_dec(GvHV(gv));
1880 GvHV(gv) = (HV*)SvREFCNT_inc(defstash);
463ee0b2 1881 SvREADONLY_on(gv);
a0d0e21e 1882 HvNAME(defstash) = savepv("main");
85e6fe83 1883 incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
a5f75d66 1884 GvMULTI_on(incgv);
b3ac6de7
IZ
1885 hintgv = gv_fetchpv("\010",TRUE, SVt_PV); /* ^H */
1886 GvMULTI_on(hintgv);
a0d0e21e 1887 defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
12f917ad
MB
1888 errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
1889 GvMULTI_on(errgv);
95a449b8 1890 replgv = gv_fetchpv("\022", TRUE, SVt_PV); /* ^R */
ce862d02 1891 GvMULTI_on(replgv);
84902520 1892 (void)form("%240s",""); /* Preallocate temp - for immediate signals. */
38a03e6e
MB
1893 sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */
1894 sv_setpvn(ERRSV, "", 0);
8990e307
LW
1895 curstash = defstash;
1896 compiling.cop_stash = defstash;
adbc6bb1 1897 debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
49dc05e3 1898 globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
4633a7c4
LW
1899 /* We must init $/ before switches are processed. */
1900 sv_setpvn(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), "\n", 1);
79072805
LW
1901}
1902
76e3520e 1903STATIC void
01f988be 1904open_script(char *scriptname, bool dosearch, SV *sv, int *fdscript)
79072805 1905{
0f15f207 1906 dTHR;
79072805 1907 register char *s;
2a92aaa0 1908
6c4ab083 1909 *fdscript = -1;
79072805 1910
6c4ab083
GS
1911 if (e_script) {
1912 origfilename = savepv("-e");
96436eeb 1913 }
6c4ab083
GS
1914 else {
1915 /* if find_script() returns, it returns a malloc()-ed value */
1916 origfilename = scriptname = find_script(scriptname, dosearch, NULL, 1);
1917
1918 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
1919 char *s = scriptname + 8;
1920 *fdscript = atoi(s);
1921 while (isDIGIT(*s))
1922 s++;
1923 if (*s) {
1924 scriptname = savepv(s + 1);
1925 Safefree(origfilename);
1926 origfilename = scriptname;
1927 }
1928 }
1929 }
1930
79072805
LW
1931 curcop->cop_filegv = gv_fetchfile(origfilename);
1932 if (strEQ(origfilename,"-"))
1933 scriptname = "";
01f988be
GS
1934 if (*fdscript >= 0) {
1935 rsfp = PerlIO_fdopen(*fdscript,PERL_SCRIPT_MODE);
96436eeb 1936#if defined(HAS_FCNTL) && defined(F_SETFD)
7aa04957
CS
1937 if (rsfp)
1938 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
96436eeb
PP
1939#endif
1940 }
1941 else if (preprocess) {
46fc3d4c 1942 char *cpp_cfg = CPPSTDIN;
63bfd3db 1943 SV *cpp = newSVpv("",0);
46fc3d4c
PP
1944 SV *cmd = NEWSV(0,0);
1945
1946 if (strEQ(cpp_cfg, "cppstdin"))
1947 sv_catpvf(cpp, "%s/", BIN_EXP);
1948 sv_catpv(cpp, cpp_cfg);
79072805 1949
79072805 1950 sv_catpv(sv,"-I");
fed7345c 1951 sv_catpv(sv,PRIVLIB_EXP);
46fc3d4c 1952
79072805 1953#ifdef MSDOS
46fc3d4c 1954 sv_setpvf(cmd, "\
79072805
LW
1955sed %s -e \"/^[^#]/b\" \
1956 -e \"/^#[ ]*include[ ]/b\" \
1957 -e \"/^#[ ]*define[ ]/b\" \
1958 -e \"/^#[ ]*if[ ]/b\" \
1959 -e \"/^#[ ]*ifdef[ ]/b\" \
1960 -e \"/^#[ ]*ifndef[ ]/b\" \
1961 -e \"/^#[ ]*else/b\" \
1962 -e \"/^#[ ]*elif[ ]/b\" \
1963 -e \"/^#[ ]*undef[ ]/b\" \
1964 -e \"/^#[ ]*endif/b\" \
1965 -e \"s/^#.*//\" \
fc36a67e 1966 %s | %_ -C %_ %s",
79072805
LW
1967 (doextract ? "-e \"1,/^#/d\n\"" : ""),
1968#else
46fc3d4c 1969 sv_setpvf(cmd, "\
79072805
LW
1970%s %s -e '/^[^#]/b' \
1971 -e '/^#[ ]*include[ ]/b' \
1972 -e '/^#[ ]*define[ ]/b' \
1973 -e '/^#[ ]*if[ ]/b' \
1974 -e '/^#[ ]*ifdef[ ]/b' \
1975 -e '/^#[ ]*ifndef[ ]/b' \
1976 -e '/^#[ ]*else/b' \
1977 -e '/^#[ ]*elif[ ]/b' \
1978 -e '/^#[ ]*undef[ ]/b' \
1979 -e '/^#[ ]*endif/b' \
1980 -e 's/^[ ]*#.*//' \
fc36a67e 1981 %s | %_ -C %_ %s",
79072805
LW
1982#ifdef LOC_SED
1983 LOC_SED,
1984#else
1985 "sed",
1986#endif
1987 (doextract ? "-e '1,/^#/d\n'" : ""),
1988#endif
46fc3d4c 1989 scriptname, cpp, sv, CPPMINUS);
79072805
LW
1990 doextract = FALSE;
1991#ifdef IAMSUID /* actually, this is caught earlier */
1992 if (euid != uid && !euid) { /* if running suidperl */
1993#ifdef HAS_SETEUID
1994 (void)seteuid(uid); /* musn't stay setuid root */
1995#else
1996#ifdef HAS_SETREUID
85e6fe83
LW
1997 (void)setreuid((Uid_t)-1, uid);
1998#else
1999#ifdef HAS_SETRESUID
2000 (void)setresuid((Uid_t)-1, uid, (Uid_t)-1);
79072805 2001#else
76e3520e 2002 PerlProc_setuid(uid);
79072805
LW
2003#endif
2004#endif
85e6fe83 2005#endif
76e3520e 2006 if (PerlProc_geteuid() != uid)
463ee0b2 2007 croak("Can't do seteuid!\n");
79072805
LW
2008 }
2009#endif /* IAMSUID */
6ad3d225 2010 rsfp = PerlProc_popen(SvPVX(cmd), "r");
46fc3d4c
PP
2011 SvREFCNT_dec(cmd);
2012 SvREFCNT_dec(cpp);
79072805
LW
2013 }
2014 else if (!*scriptname) {
bbce6d69 2015 forbid_setid("program input from stdin");
760ac839 2016 rsfp = PerlIO_stdin();
79072805 2017 }
96436eeb 2018 else {
a868473f 2019 rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
96436eeb 2020#if defined(HAS_FCNTL) && defined(F_SETFD)
7aa04957
CS
2021 if (rsfp)
2022 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
96436eeb
PP
2023#endif
2024 }
7aa04957 2025 if (!rsfp) {
13281fa4 2026#ifdef DOSUID
a687059c 2027#ifndef IAMSUID /* in case script is not readable before setuid */
76e3520e 2028 if (euid && PerlLIO_stat(SvPVX(GvSV(curcop->cop_filegv)),&statbuf) >= 0 &&
13281fa4 2029 statbuf.st_mode & (S_ISUID|S_ISGID)) {
46fc3d4c 2030 /* try again */
6ad3d225 2031 PerlProc_execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
463ee0b2 2032 croak("Can't do setuid\n");
13281fa4
LW
2033 }
2034#endif
2035#endif
463ee0b2 2036 croak("Can't open perl script \"%s\": %s\n",
2304df62 2037 SvPVX(GvSV(curcop->cop_filegv)), Strerror(errno));
13281fa4 2038 }
79072805 2039}
8d063cd8 2040
76e3520e 2041STATIC void
01f988be 2042validate_suid(char *validarg, char *scriptname, int fdscript)
79072805 2043{
96436eeb
PP
2044 int which;
2045
13281fa4
LW
2046 /* do we need to emulate setuid on scripts? */
2047
2048 /* This code is for those BSD systems that have setuid #! scripts disabled
2049 * in the kernel because of a security problem. Merely defining DOSUID
2050 * in perl will not fix that problem, but if you have disabled setuid
2051 * scripts in the kernel, this will attempt to emulate setuid and setgid
2052 * on scripts that have those now-otherwise-useless bits set. The setuid
27e2fb84
LW
2053 * root version must be called suidperl or sperlN.NNN. If regular perl
2054 * discovers that it has opened a setuid script, it calls suidperl with
2055 * the same argv that it had. If suidperl finds that the script it has
2056 * just opened is NOT setuid root, it sets the effective uid back to the
2057 * uid. We don't just make perl setuid root because that loses the
2058 * effective uid we had before invoking perl, if it was different from the
2059 * uid.
13281fa4
LW
2060 *
2061 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
2062 * be defined in suidperl only. suidperl must be setuid root. The
2063 * Configure script will set this up for you if you want it.
2064 */
a687059c 2065
13281fa4 2066#ifdef DOSUID
ea0efc06 2067 dTHR;
6e72f9df 2068 char *s, *s2;
a0d0e21e 2069
6ad3d225 2070 if (PerlLIO_fstat(PerlIO_fileno(rsfp),&statbuf) < 0) /* normal stat is insecure */
463ee0b2 2071 croak("Can't stat script \"%s\"",origfilename);
96436eeb 2072 if (fdscript < 0 && statbuf.st_mode & (S_ISUID|S_ISGID)) {
79072805 2073 I32 len;
13281fa4 2074
a687059c 2075#ifdef IAMSUID
fe14fcc3 2076#ifndef HAS_SETREUID
a687059c
LW
2077 /* On this access check to make sure the directories are readable,
2078 * there is actually a small window that the user could use to make
2079 * filename point to an accessible directory. So there is a faint
2080 * chance that someone could execute a setuid script down in a
2081 * non-accessible directory. I don't know what to do about that.
2082 * But I don't think it's too important. The manual lies when
2083 * it says access() is useful in setuid programs.
2084 */
6ad3d225 2085 if (PerlLIO_access(SvPVX(GvSV(curcop->cop_filegv)),1)) /*double check*/
463ee0b2 2086 croak("Permission denied");
a687059c
LW
2087#else
2088 /* If we can swap euid and uid, then we can determine access rights
2089 * with a simple stat of the file, and then compare device and
2090 * inode to make sure we did stat() on the same file we opened.
2091 * Then we just have to make sure he or she can execute it.
2092 */
2093 {
2094 struct stat tmpstatbuf;
2095
85e6fe83
LW
2096 if (
2097#ifdef HAS_SETREUID
2098 setreuid(euid,uid) < 0
a0d0e21e
LW
2099#else
2100# if HAS_SETRESUID
85e6fe83 2101 setresuid(euid,uid,(Uid_t)-1) < 0
a0d0e21e 2102# endif
85e6fe83 2103#endif
76e3520e 2104 || PerlProc_getuid() != euid || PerlProc_geteuid() != uid)
463ee0b2 2105 croak("Can't swap uid and euid"); /* really paranoid */
76e3520e 2106 if (PerlLIO_stat(SvPVX(GvSV(curcop->cop_filegv)),&tmpstatbuf) < 0)
463ee0b2 2107 croak("Permission denied"); /* testing full pathname here */
a687059c
LW
2108 if (tmpstatbuf.st_dev != statbuf.st_dev ||
2109 tmpstatbuf.st_ino != statbuf.st_ino) {
760ac839 2110 (void)PerlIO_close(rsfp);
6ad3d225 2111 if (rsfp = PerlProc_popen("/bin/mail root","w")) { /* heh, heh */
760ac839 2112 PerlIO_printf(rsfp,
ff0cee69
PP
2113"User %ld tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
2114(Filename of set-id script was %s, uid %ld gid %ld.)\n\nSincerely,\nperl\n",
2115 (long)uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
2116 (long)statbuf.st_dev, (long)statbuf.st_ino,
463ee0b2 2117 SvPVX(GvSV(curcop->cop_filegv)),
ff0cee69 2118 (long)statbuf.st_uid, (long)statbuf.st_gid);
6ad3d225 2119 (void)PerlProc_pclose(rsfp);
a687059c 2120 }
463ee0b2 2121 croak("Permission denied\n");
a687059c 2122 }
85e6fe83
LW
2123 if (
2124#ifdef HAS_SETREUID
2125 setreuid(uid,euid) < 0
a0d0e21e
LW
2126#else
2127# if defined(HAS_SETRESUID)
85e6fe83 2128 setresuid(uid,euid,(Uid_t)-1) < 0
a0d0e21e 2129# endif
85e6fe83 2130#endif
76e3520e 2131 || PerlProc_getuid() != uid || PerlProc_geteuid() != euid)
463ee0b2 2132 croak("Can't reswap uid and euid");
27e2fb84 2133 if (!cando(S_IXUSR,FALSE,&statbuf)) /* can real uid exec? */
463ee0b2 2134 croak("Permission denied\n");
a687059c 2135 }
fe14fcc3 2136#endif /* HAS_SETREUID */
a687059c
LW
2137#endif /* IAMSUID */
2138
27e2fb84 2139 if (!S_ISREG(statbuf.st_mode))
463ee0b2 2140 croak("Permission denied");
27e2fb84 2141 if (statbuf.st_mode & S_IWOTH)
463ee0b2 2142 croak("Setuid/gid script is writable by world");
13281fa4 2143 doswitches = FALSE; /* -s is insecure in suid */
79072805 2144 curcop->cop_line++;
760ac839
LW
2145 if (sv_gets(linestr, rsfp, 0) == Nullch ||
2146 strnNE(SvPV(linestr,na),"#!",2) ) /* required even on Sys V */
463ee0b2 2147 croak("No #! line");
760ac839 2148 s = SvPV(linestr,na)+2;
663a0e37 2149 if (*s == ' ') s++;
45d8adaa 2150 while (!isSPACE(*s)) s++;
760ac839 2151 for (s2 = s; (s2 > SvPV(linestr,na)+2 &&
6e72f9df
PP
2152 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
2153 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
463ee0b2 2154 croak("Not a perl script");
a687059c 2155 while (*s == ' ' || *s == '\t') s++;
13281fa4
LW
2156 /*
2157 * #! arg must be what we saw above. They can invoke it by
2158 * mentioning suidperl explicitly, but they may not add any strange
2159 * arguments beyond what #! says if they do invoke suidperl that way.
2160 */
2161 len = strlen(validarg);
2162 if (strEQ(validarg," PHOOEY ") ||
45d8adaa 2163 strnNE(s,validarg,len) || !isSPACE(s[len]))
463ee0b2 2164 croak("Args must match #! line");
a687059c
LW
2165
2166#ifndef IAMSUID
2167 if (euid != uid && (statbuf.st_mode & S_ISUID) &&
2168 euid == statbuf.st_uid)
2169 if (!do_undump)
463ee0b2 2170 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
a687059c
LW
2171FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2172#endif /* IAMSUID */
13281fa4
LW
2173
2174 if (euid) { /* oops, we're not the setuid root perl */
760ac839 2175 (void)PerlIO_close(rsfp);
13281fa4 2176#ifndef IAMSUID
46fc3d4c 2177 /* try again */
6ad3d225 2178 PerlProc_execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
13281fa4 2179#endif
463ee0b2 2180 croak("Can't do setuid\n");
13281fa4
LW
2181 }
2182
83025b21 2183 if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid) {
fe14fcc3 2184#ifdef HAS_SETEGID
a687059c
LW
2185 (void)setegid(statbuf.st_gid);
2186#else
fe14fcc3 2187#ifdef HAS_SETREGID
85e6fe83
LW
2188 (void)setregid((Gid_t)-1,statbuf.st_gid);
2189#else
2190#ifdef HAS_SETRESGID
2191 (void)setresgid((Gid_t)-1,statbuf.st_gid,(Gid_t)-1);
a687059c 2192#else
76e3520e 2193 PerlProc_setgid(statbuf.st_gid);
a687059c
LW
2194#endif
2195#endif
85e6fe83 2196#endif
76e3520e 2197 if (PerlProc_getegid() != statbuf.st_gid)
463ee0b2 2198 croak("Can't do setegid!\n");
83025b21 2199 }
a687059c
LW
2200 if (statbuf.st_mode & S_ISUID) {
2201 if (statbuf.st_uid != euid)
fe14fcc3 2202#ifdef HAS_SETEUID
a687059c
LW
2203 (void)seteuid(statbuf.st_uid); /* all that for this */
2204#else
fe14fcc3 2205#ifdef HAS_SETREUID
85e6fe83
LW
2206 (void)setreuid((Uid_t)-1,statbuf.st_uid);
2207#else
2208#ifdef HAS_SETRESUID
2209 (void)setresuid((Uid_t)-1,statbuf.st_uid,(Uid_t)-1);
a687059c 2210#else
76e3520e 2211 PerlProc_setuid(statbuf.st_uid);
a687059c
LW
2212#endif
2213#endif
85e6fe83 2214#endif
76e3520e 2215 if (PerlProc_geteuid() != statbuf.st_uid)
463ee0b2 2216 croak("Can't do seteuid!\n");
a687059c 2217 }
83025b21 2218 else if (uid) { /* oops, mustn't run as root */
fe14fcc3 2219#ifdef HAS_SETEUID
85e6fe83 2220 (void)seteuid((Uid_t)uid);
a687059c 2221#else
fe14fcc3 2222#ifdef HAS_SETREUID
85e6fe83 2223 (void)setreuid((Uid_t)-1,(Uid_t)uid);
a687059c 2224#else
85e6fe83
LW
2225#ifdef HAS_SETRESUID
2226 (void)setresuid((Uid_t)-1,(Uid_t)uid,(Uid_t)-1);
2227#else
76e3520e 2228 PerlProc_setuid((Uid_t)uid);
85e6fe83 2229#endif
a687059c
LW
2230#endif
2231#endif
76e3520e 2232 if (PerlProc_geteuid() != uid)
463ee0b2 2233 croak("Can't do seteuid!\n");
83025b21 2234 }
748a9306 2235 init_ids();
27e2fb84 2236 if (!cando(S_IXUSR,TRUE,&statbuf))
463ee0b2 2237 croak("Permission denied\n"); /* they can't do this */
13281fa4
LW
2238 }
2239#ifdef IAMSUID
2240 else if (preprocess)
463ee0b2 2241 croak("-P not allowed for setuid/setgid script\n");
96436eeb
PP
2242 else if (fdscript >= 0)
2243 croak("fd script not allowed in suidperl\n");
13281fa4 2244 else
463ee0b2 2245 croak("Script is not setuid/setgid in suidperl\n");
96436eeb
PP
2246
2247 /* We absolutely must clear out any saved ids here, so we */
2248 /* exec the real perl, substituting fd script for scriptname. */
2249 /* (We pass script name as "subdir" of fd, which perl will grok.) */
760ac839 2250 PerlIO_rewind(rsfp);
6ad3d225 2251 PerlLIO_lseek(PerlIO_fileno(rsfp),(Off_t)0,0); /* just in case rewind didn't */
96436eeb
PP
2252 for (which = 1; origargv[which] && origargv[which] != scriptname; which++) ;
2253 if (!origargv[which])
2254 croak("Permission denied");
46fc3d4c
PP
2255 origargv[which] = savepv(form("/dev/fd/%d/%s",
2256 PerlIO_fileno(rsfp), origargv[which]));
96436eeb 2257#if defined(HAS_FCNTL) && defined(F_SETFD)
760ac839 2258 fcntl(PerlIO_fileno(rsfp),F_SETFD,0); /* ensure no close-on-exec */
96436eeb 2259#endif
6ad3d225 2260 PerlProc_execv(form("%s/perl%s", BIN_EXP, patchlevel), origargv); /* try again */
96436eeb 2261 croak("Can't do setuid\n");
13281fa4 2262#endif /* IAMSUID */
a687059c 2263#else /* !DOSUID */
a687059c
LW
2264 if (euid != uid || egid != gid) { /* (suidperl doesn't exist, in fact) */
2265#ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
96827780 2266 dTHR;
6ad3d225 2267 PerlLIO_fstat(PerlIO_fileno(rsfp),&statbuf); /* may be either wrapped or real suid */
a687059c
LW
2268 if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
2269 ||
2270 (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
2271 )
2272 if (!do_undump)
463ee0b2 2273 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
a687059c
LW
2274FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2275#endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
2276 /* not set-id, must be wrapped */
a687059c 2277 }
13281fa4 2278#endif /* DOSUID */
79072805 2279}
13281fa4 2280
76e3520e 2281STATIC void
8ac85365 2282find_beginning(void)
79072805 2283{
6e72f9df 2284 register char *s, *s2;
33b78306
LW
2285
2286 /* skip forward in input to the real script? */
2287
bbce6d69 2288 forbid_setid("-x");
33b78306 2289 while (doextract) {
79072805 2290 if ((s = sv_gets(linestr, rsfp, 0)) == Nullch)
463ee0b2 2291 croak("No Perl script found in input\n");
6e72f9df 2292 if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
760ac839 2293 PerlIO_ungetc(rsfp, '\n'); /* to keep line count right */
33b78306 2294 doextract = FALSE;
6e72f9df
PP
2295 while (*s && !(isSPACE (*s) || *s == '#')) s++;
2296 s2 = s;
2297 while (*s == ' ' || *s == '\t') s++;
2298 if (*s++ == '-') {
2299 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
2300 if (strnEQ(s2-4,"perl",4))
2301 /*SUPPRESS 530*/
2302 while (s = moreswitches(s)) ;
33b78306 2303 }
6ad3d225 2304 if (cddir && PerlDir_chdir(cddir) < 0)
463ee0b2 2305 croak("Can't chdir to %s",cddir);
83025b21
LW
2306 }
2307 }
2308}
2309
afe37c7d 2310
76e3520e 2311STATIC void
8ac85365 2312init_ids(void)
352d5a3a 2313{
76e3520e
GS
2314 uid = (int)PerlProc_getuid();
2315 euid = (int)PerlProc_geteuid();
2316 gid = (int)PerlProc_getgid();
2317 egid = (int)PerlProc_getegid();
748a9306
LW
2318#ifdef VMS
2319 uid |= gid << 16;
2320 euid |= egid << 16;
2321#endif
4633a7c4 2322 tainting |= (uid && (euid != uid || egid != gid));
748a9306 2323}
79072805 2324
76e3520e 2325STATIC void
8ac85365 2326forbid_setid(char *s)
bbce6d69
PP
2327{
2328 if (euid != uid)
2329 croak("No %s allowed while running setuid", s);
2330 if (egid != gid)
2331 croak("No %s allowed while running setgid", s);
2332}
2333
76e3520e 2334STATIC void
8ac85365 2335init_debugger(void)
748a9306 2336{
11343788 2337 dTHR;
79072805 2338 curstash = debstash;
748a9306 2339 dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
79072805 2340 AvREAL_off(dbargs);
a0d0e21e
LW
2341 DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
2342 DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
748a9306
LW
2343 DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
2344 DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
c07a80fd 2345 sv_setiv(DBsingle, 0);
748a9306 2346 DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
c07a80fd 2347 sv_setiv(DBtrace, 0);
748a9306 2348 DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
c07a80fd 2349 sv_setiv(DBsignal, 0);
79072805 2350 curstash = defstash;
352d5a3a
LW
2351}
2352
2ce36478
SM
2353#ifndef STRESS_REALLOC
2354#define REASONABLE(size) (size)
2355#else
2356#define REASONABLE(size) (1) /* unreasonable */
2357#endif
2358
11343788 2359void
8ac85365 2360init_stacks(ARGSproto)
79072805 2361{
e336de0d
GS
2362 /* start with 128-item stack and 8K cxstack */
2363 curstackinfo = new_stackinfo(REASONABLE(128),
2364 REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
e788e7d3 2365 curstackinfo->si_type = PERLSI_MAIN;
e336de0d 2366 curstack = curstackinfo->si_stack;
5f05dabc 2367 mainstack = curstack; /* remember in case we switch stacks */
79072805 2368
6e72f9df 2369 stack_base = AvARRAY(curstack);
79072805 2370 stack_sp = stack_base;
e336de0d 2371 stack_max = stack_base + AvMAX(curstack);
8990e307 2372
2ce36478 2373 New(50,tmps_stack,REASONABLE(128),SV*);
6d4ff0d2 2374 tmps_floor = -1;
8990e307 2375 tmps_ix = -1;
2ce36478 2376 tmps_max = REASONABLE(128);
8990e307 2377
cb68f92d
GS
2378 New(54,markstack,REASONABLE(32),I32);
2379 markstack_ptr = markstack;
2380 markstack_max = markstack + REASONABLE(32);
79072805 2381
e336de0d
GS
2382 SET_MARKBASE;
2383
cb68f92d
GS
2384 New(54,scopestack,REASONABLE(32),I32);
2385 scopestack_ix = 0;
2386 scopestack_max = REASONABLE(32);
79072805 2387
cb68f92d
GS
2388 New(54,savestack,REASONABLE(128),ANY);
2389 savestack_ix = 0;
2390 savestack_max = REASONABLE(128);
79072805 2391
cb68f92d
GS
2392 New(54,retstack,REASONABLE(16),OP*);
2393 retstack_ix = 0;
2394 retstack_max = REASONABLE(16);
378cc40b 2395}
33b78306 2396
2ce36478
SM
2397#undef REASONABLE
2398
76e3520e 2399STATIC void
8ac85365 2400nuke_stacks(void)
6e72f9df 2401{
e858de61 2402 dTHR;
e336de0d
GS
2403 while (curstackinfo->si_next)
2404 curstackinfo = curstackinfo->si_next;
2405 while (curstackinfo) {
2406 PERL_SI *p = curstackinfo->si_prev;
bac4b2ad 2407 /* curstackinfo->si_stack got nuked by sv_free_arenas() */
e336de0d
GS
2408 Safefree(curstackinfo->si_cxstack);
2409 Safefree(curstackinfo);
2410 curstackinfo = p;
2411 }
6e72f9df 2412 Safefree(tmps_stack);
00db4c45
GS
2413 Safefree(markstack);
2414 Safefree(scopestack);
2415 Safefree(savestack);
2416 Safefree(retstack);
5f05dabc
PP
2417 DEBUG( {
2418 Safefree(debname);
2419 Safefree(debdelim);
2420 } )
378cc40b 2421}
33b78306 2422
76e3520e 2423#ifndef PERL_OBJECT
760ac839 2424static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
76e3520e 2425#endif
7aa04957 2426
76e3520e 2427STATIC void
8ac85365 2428init_lexer(void)
8990e307 2429{
76e3520e
GS
2430#ifdef PERL_OBJECT
2431 PerlIO *tmpfp;
2432#endif
a0d0e21e 2433 tmpfp = rsfp;
90248788 2434 rsfp = Nullfp;
8990e307
LW
2435 lex_start(linestr);
2436 rsfp = tmpfp;
2437 subname = newSVpv("main",4);
2438}
2439
76e3520e 2440STATIC void
8ac85365 2441init_predump_symbols(void)
45d8adaa 2442{
11343788 2443 dTHR;
93a17b20 2444 GV *tmpgv;
a0d0e21e 2445 GV *othergv;
79072805 2446
e1c148c2 2447 sv_setpvn(perl_get_sv("\"", TRUE), " ", 1);
85e6fe83 2448 stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
a5f75d66 2449 GvMULTI_on(stdingv);
760ac839 2450 IoIFP(GvIOp(stdingv)) = PerlIO_stdin();
adbc6bb1 2451 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
a5f75d66 2452 GvMULTI_on(tmpgv);
a0d0e21e 2453 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(stdingv));
79072805 2454
85e6fe83 2455 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
a5f75d66 2456 GvMULTI_on(tmpgv);
760ac839 2457 IoOFP(GvIOp(tmpgv)) = IoIFP(GvIOp(tmpgv)) = PerlIO_stdout();
4633a7c4 2458 setdefout(tmpgv);
adbc6bb1 2459 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
a5f75d66 2460 GvMULTI_on(tmpgv);
a0d0e21e 2461 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(defoutgv));
79072805 2462
a0d0e21e 2463 othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
a5f75d66 2464 GvMULTI_on(othergv);
760ac839 2465 IoOFP(GvIOp(othergv)) = IoIFP(GvIOp(othergv)) = PerlIO_stderr();
adbc6bb1 2466 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
a5f75d66 2467 GvMULTI_on(tmpgv);
a0d0e21e 2468 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(othergv));
79072805
LW
2469
2470 statname = NEWSV(66,0); /* last filename we did stat on */
ab821d7f 2471
6e72f9df
PP
2472 if (!osname)
2473 osname = savepv(OSNAME);
79072805 2474}
33b78306 2475
76e3520e 2476STATIC void
8ac85365 2477init_postdump_symbols(register int argc, register char **argv, register char **env)
33b78306 2478{
a863c7d1 2479 dTHR;
79072805
LW
2480 char *s;
2481 SV *sv;
2482 GV* tmpgv;
fe14fcc3 2483
79072805
LW
2484 argc--,argv++; /* skip name of script */
2485 if (doswitches) {
2486 for (; argc > 0 && **argv == '-'; argc--,argv++) {
2487 if (!argv[0][1])
2488 break;
2489 if (argv[0][1] == '-') {
2490 argc--,argv++;
2491 break;
2492 }
93a17b20 2493 if (s = strchr(argv[0], '=')) {
79072805 2494 *s++ = '\0';
85e6fe83 2495 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
79072805
LW
2496 }
2497 else
85e6fe83 2498 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
fe14fcc3 2499 }
79072805
LW
2500 }
2501 toptarget = NEWSV(0,0);
2502 sv_upgrade(toptarget, SVt_PVFM);
2503 sv_setpvn(toptarget, "", 0);
748a9306 2504 bodytarget = NEWSV(0,0);
79072805
LW
2505 sv_upgrade(bodytarget, SVt_PVFM);
2506 sv_setpvn(bodytarget, "", 0);
2507 formtarget = bodytarget;
2508
bbce6d69 2509 TAINT;
85e6fe83 2510 if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
79072805
LW
2511 sv_setpv(GvSV(tmpgv),origfilename);
2512 magicname("0", "0", 1);
2513 }
85e6fe83 2514 if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
79072805 2515 sv_setpv(GvSV(tmpgv),origargv[0]);
85e6fe83 2516 if (argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
a5f75d66 2517 GvMULTI_on(argvgv);
79072805
LW
2518 (void)gv_AVadd(argvgv);
2519 av_clear(GvAVn(argvgv));
2520 for (; argc > 0; argc--,argv++) {
a0d0e21e 2521 av_push(GvAVn(argvgv),newSVpv(argv[0],0));
79072805
LW
2522 }
2523 }
85e6fe83 2524 if (envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
79072805 2525 HV *hv;
a5f75d66 2526 GvMULTI_on(envgv);
79072805 2527 hv = GvHVn(envgv);
5aabfad6 2528 hv_magic(hv, envgv, 'E');
a0d0e21e 2529#ifndef VMS /* VMS doesn't have environ array */
4633a7c4
LW
2530 /* Note that if the supplied env parameter is actually a copy
2531 of the global environ then it may now point to free'd memory
2532 if the environment has been modified since. To avoid this
2533 problem we treat env==NULL as meaning 'use the default'
2534 */
2535 if (!env)
2536 env = environ;
5aabfad6 2537 if (env != environ)
79072805
LW
2538 environ[0] = Nullch;
2539 for (; *env; env++) {
93a17b20 2540 if (!(s = strchr(*env,'=')))
79072805
LW
2541 continue;
2542 *s++ = '\0';
60ce6247 2543#if defined(MSDOS)
137443ea
PP
2544 (void)strupr(*env);
2545#endif
79072805
LW
2546 sv = newSVpv(s--,0);
2547 (void)hv_store(hv, *env, s - *env, sv, 0);
2548 *s = '=';
3e3baf6d
TB
2549#if defined(__BORLANDC__) && defined(USE_WIN32_RTL_ENV)
2550 /* Sins of the RTL. See note in my_setenv(). */
76e3520e 2551 (void)PerlEnv_putenv(savepv(*env));
3e3baf6d 2552#endif
fe14fcc3 2553 }
4550b24a
PP
2554#endif
2555#ifdef DYNAMIC_ENV_FETCH
2556 HvNAME(hv) = savepv(ENV_HV_NAME);
2557#endif
79072805 2558 }
bbce6d69 2559 TAINT_NOT;
85e6fe83 2560 if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
1e422769 2561 sv_setiv(GvSV(tmpgv), (IV)getpid());
33b78306 2562}
34de22dd 2563
76e3520e 2564STATIC void
8ac85365 2565init_perllib(void)
34de22dd 2566{
85e6fe83
LW
2567 char *s;
2568 if (!tainting) {
552a7a9b 2569#ifndef VMS
76e3520e 2570 s = PerlEnv_getenv("PERL5LIB");
85e6fe83 2571 if (s)
774d564b 2572 incpush(s, TRUE);
85e6fe83 2573 else
76e3520e 2574 incpush(PerlEnv_getenv("PERLLIB"), FALSE);
552a7a9b
PP
2575#else /* VMS */
2576 /* Treat PERL5?LIB as a possible search list logical name -- the
2577 * "natural" VMS idiom for a Unix path string. We allow each
2578 * element to be a set of |-separated directories for compatibility.
2579 */
2580 char buf[256];
2581 int idx = 0;
2582 if (my_trnlnm("PERL5LIB",buf,0))
774d564b 2583 do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
552a7a9b 2584 else
774d564b 2585 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE);
552a7a9b 2586#endif /* VMS */
85e6fe83 2587 }
34de22dd 2588
c90c0ff4 2589/* Use the ~-expanded versions of APPLLIB (undocumented),
dfe9444c 2590 ARCHLIB PRIVLIB SITEARCH and SITELIB
df5cef82 2591*/
4633a7c4 2592#ifdef APPLLIB_EXP
43051805 2593 incpush(APPLLIB_EXP, TRUE);
16d20bd9 2594#endif
4633a7c4 2595
fed7345c 2596#ifdef ARCHLIB_EXP
774d564b 2597 incpush(ARCHLIB_EXP, FALSE);
a0d0e21e 2598#endif
fed7345c
AD
2599#ifndef PRIVLIB_EXP
2600#define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
34de22dd 2601#endif
00dc2f4f
GS
2602#if defined(WIN32)
2603 incpush(PRIVLIB_EXP, TRUE);
2604#else
774d564b 2605 incpush(PRIVLIB_EXP, FALSE);
00dc2f4f 2606#endif
4633a7c4
LW
2607
2608#ifdef SITEARCH_EXP
774d564b 2609 incpush(SITEARCH_EXP, FALSE);
4633a7c4
LW
2610#endif
2611#ifdef SITELIB_EXP
00dc2f4f
GS
2612#if defined(WIN32)
2613 incpush(SITELIB_EXP, TRUE);
2614#else
774d564b 2615 incpush(SITELIB_EXP, FALSE);
4633a7c4 2616#endif
00dc2f4f 2617#endif
4633a7c4 2618 if (!tainting)
774d564b
PP
2619 incpush(".", FALSE);
2620}
2621
2622#if defined(DOSISH)
2623# define PERLLIB_SEP ';'
2624#else
2625# if defined(VMS)
2626# define PERLLIB_SEP '|'
2627# else
2628# define PERLLIB_SEP ':'
2629# endif
2630#endif
2631#ifndef PERLLIB_MANGLE
2632# define PERLLIB_MANGLE(s,n) (s)
2633#endif
2634
76e3520e 2635STATIC void
8ac85365 2636incpush(char *p, int addsubdirs)
774d564b
PP
2637{
2638 SV *subdir = Nullsv;
774d564b
PP
2639
2640 if (!p)
2641 return;
2642
2643 if (addsubdirs) {
00db4c45 2644 subdir = sv_newmortal();
774d564b
PP
2645 if (!archpat_auto) {
2646 STRLEN len = (sizeof(ARCHNAME) + strlen(patchlevel)
2647 + sizeof("//auto"));
2648 New(55, archpat_auto, len, char);
2649 sprintf(archpat_auto, "/%s/%s/auto", ARCHNAME, patchlevel);
aa689395
PP
2650#ifdef VMS
2651 for (len = sizeof(ARCHNAME) + 2;
2652 archpat_auto[len] != '\0' && archpat_auto[len] != '/'; len++)
2653 if (archpat_auto[len] == '.') archpat_auto[len] = '_';
2654#endif
774d564b
PP
2655 }
2656 }
2657
2658 /* Break at all separators */
2659 while (p && *p) {
8c52afec 2660 SV *libdir = NEWSV(55,0);
774d564b
PP
2661 char *s;
2662
2663 /* skip any consecutive separators */
2664 while ( *p == PERLLIB_SEP ) {
2665 /* Uncomment the next line for PATH semantics */
2666 /* av_push(GvAVn(incgv), newSVpv(".", 1)); */
2667 p++;
2668 }
2669
2670 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
2671 sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
2672 (STRLEN)(s - p));
2673 p = s + 1;
2674 }
2675 else {
2676 sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
2677 p = Nullch; /* break out */
2678 }
2679
2680 /*
2681 * BEFORE pushing libdir onto @INC we may first push version- and
2682 * archname-specific sub-directories.
2683 */
2684 if (addsubdirs) {
2685 struct stat tmpstatbuf;
aa689395
PP
2686#ifdef VMS
2687 char *unix;
2688 STRLEN len;
774d564b 2689
aa689395
PP
2690 if ((unix = tounixspec_ts(SvPV(libdir,na),Nullch)) != Nullch) {
2691 len = strlen(unix);
2692 while (unix[len-1] == '/') len--; /* Cosmetic */
2693 sv_usepvn(libdir,unix,len);
2694 }
2695 else
2696 PerlIO_printf(PerlIO_stderr(),
2697 "Failed to unixify @INC element \"%s\"\n",
2698 SvPV(libdir,na));
2699#endif
4fdae800 2700 /* .../archname/version if -d .../archname/version/auto */
774d564b
PP
2701 sv_setsv(subdir, libdir);
2702 sv_catpv(subdir, archpat_auto);
76e3520e 2703 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
774d564b
PP
2704 S_ISDIR(tmpstatbuf.st_mode))
2705 av_push(GvAVn(incgv),
2706 newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2707
4fdae800 2708 /* .../archname if -d .../archname/auto */
774d564b
PP
2709 sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME),
2710 strlen(patchlevel) + 1, "", 0);
76e3520e 2711 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
774d564b
PP
2712 S_ISDIR(tmpstatbuf.st_mode))
2713 av_push(GvAVn(incgv),
2714 newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2715 }
2716
2717 /* finally push this lib directory on the end of @INC */
2718 av_push(GvAVn(incgv), libdir);
2719 }
34de22dd 2720}
93a17b20 2721
199100c8 2722#ifdef USE_THREADS
76e3520e 2723STATIC struct perl_thread *
199100c8
MB
2724init_main_thread()
2725{
52e1cb5e 2726 struct perl_thread *thr;
199100c8
MB
2727 XPV *xpv;
2728
52e1cb5e 2729 Newz(53, thr, 1, struct perl_thread);
199100c8
MB
2730 curcop = &compiling;
2731 thr->cvcache = newHV();
54b9620d 2732 thr->threadsv = newAV();
940cb80d 2733 /* thr->threadsvp is set when find_threadsv is called */
199100c8 2734 thr->specific = newAV();
38a03e6e 2735 thr->errhv = newHV();
199100c8
MB
2736 thr->flags = THRf_R_JOINABLE;
2737 MUTEX_INIT(&thr->mutex);
2738 /* Handcraft thrsv similarly to mess_sv */
2739 New(53, thrsv, 1, SV);
2740 Newz(53, xpv, 1, XPV);
2741 SvFLAGS(thrsv) = SVt_PV;
2742 SvANY(thrsv) = (void*)xpv;
2743 SvREFCNT(thrsv) = 1 << 30; /* practically infinite */
2744 SvPVX(thrsv) = (char*)thr;
2745 SvCUR_set(thrsv, sizeof(thr));
2746 SvLEN_set(thrsv, sizeof(thr));
2747 *SvEND(thrsv) = '\0'; /* in the trailing_nul field */
2748 thr->oursv = thrsv;
199100c8
MB
2749 chopset = " \n-";
2750
2751 MUTEX_LOCK(&threads_mutex);
2752 nthreads++;
2753 thr->tid = 0;
2754 thr->next = thr;
2755 thr->prev = thr;
2756 MUTEX_UNLOCK(&threads_mutex);
2757
4b026b9e
GS
2758#ifdef HAVE_THREAD_INTERN
2759 init_thread_intern(thr);
235db74f
GS
2760#endif
2761
2762#ifdef SET_THREAD_SELF
2763 SET_THREAD_SELF(thr);
199100c8
MB
2764#else
2765 thr->self = pthread_self();
235db74f 2766#endif /* SET_THREAD_SELF */
199100c8
MB
2767 SET_THR(thr);
2768
2769 /*
2770 * These must come after the SET_THR because sv_setpvn does
2771 * SvTAINT and the taint fields require dTHR.
2772 */
2773 toptarget = NEWSV(0,0);
2774 sv_upgrade(toptarget, SVt_PVFM);
2775 sv_setpvn(toptarget, "", 0);
2776 bodytarget = NEWSV(0,0);
2777 sv_upgrade(bodytarget, SVt_PVFM);
2778 sv_setpvn(bodytarget, "", 0);
2779 formtarget = bodytarget;
2faa37cc 2780 thr->errsv = newSVpv("", 0);
78857c3c 2781 (void) find_threadsv("@"); /* Ensure $@ is initialised early */
5c0ca799
GS
2782
2783 maxscream = -1;
2784 regcompp = FUNC_NAME_TO_PTR(pregcomp);
2785 regexecp = FUNC_NAME_TO_PTR(regexec_flags);
2786 regindent = 0;
2787 reginterp_cnt = 0;
2788
199100c8
MB
2789 return thr;
2790}
2791#endif /* USE_THREADS */
2792
93a17b20 2793void
76e3520e 2794call_list(I32 oldscope, AV *paramList)
93a17b20 2795{
11343788 2796 dTHR;
a0d0e21e 2797 line_t oldline = curcop->cop_line;
22921e25
CS
2798 STRLEN len;
2799 dJMPENV;
6224f72b 2800 int ret;
93a17b20 2801
76e3520e
GS
2802 while (AvFILL(paramList) >= 0) {
2803 CV *cv = (CV*)av_shift(paramList);
93a17b20 2804
8990e307 2805 SAVEFREESV(cv);
a0d0e21e 2806
6224f72b
GS
2807 JMPENV_PUSH(ret);
2808 switch (ret) {
2809 case 0: {
38a03e6e 2810 SV* atsv = ERRSV;
748a9306
LW
2811 PUSHMARK(stack_sp);
2812 perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
12f917ad 2813 (void)SvPV(atsv, len);
748a9306 2814 if (len) {
54310121 2815 JMPENV_POP;
748a9306
LW
2816 curcop = &compiling;
2817 curcop->cop_line = oldline;
76e3520e 2818 if (paramList == beginav)
12f917ad 2819 sv_catpv(atsv, "BEGIN failed--compilation aborted");
748a9306 2820 else
12f917ad 2821 sv_catpv(atsv, "END failed--cleanup aborted");
2ae324a7
PP
2822 while (scopestack_ix > oldscope)
2823 LEAVE;
12f917ad 2824 croak("%s", SvPVX(atsv));
748a9306 2825 }
a0d0e21e 2826 }
85e6fe83 2827 break;
6224f72b 2828 case 1:
f86702cc 2829 STATUS_ALL_FAILURE;
85e6fe83 2830 /* FALL THROUGH */
6224f72b 2831 case 2:
85e6fe83 2832 /* my_exit() was called */
2ae324a7
PP
2833 while (scopestack_ix > oldscope)
2834 LEAVE;
84902520 2835 FREETMPS;
85e6fe83
LW
2836 curstash = defstash;
2837 if (endav)
68dc0745 2838 call_list(oldscope, endav);
54310121 2839 JMPENV_POP;
a0d0e21e
LW
2840 curcop = &compiling;
2841 curcop->cop_line = oldline;
85e6fe83 2842 if (statusvalue) {
76e3520e 2843 if (paramList == beginav)
a0d0e21e 2844 croak("BEGIN failed--compilation aborted");
85e6fe83 2845 else
a0d0e21e 2846 croak("END failed--cleanup aborted");
85e6fe83 2847 }
f86702cc 2848 my_exit_jump();
85e6fe83 2849 /* NOTREACHED */
6224f72b 2850 case 3:
85e6fe83 2851 if (!restartop) {
760ac839 2852 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
a0d0e21e 2853 FREETMPS;
85e6fe83
LW
2854 break;
2855 }
54310121 2856 JMPENV_POP;
a0d0e21e
LW
2857 curcop = &compiling;
2858 curcop->cop_line = oldline;
6224f72b 2859 JMPENV_JUMP(3);
8990e307 2860 }
54310121 2861 JMPENV_POP;
93a17b20 2862 }
93a17b20 2863}
93a17b20 2864
f86702cc 2865void
8ac85365 2866my_exit(U32 status)
f86702cc 2867{
5dc0d613
MB
2868 dTHR;
2869
2870#ifdef USE_THREADS
a863c7d1
MB
2871 DEBUG_L(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
2872 thr, (unsigned long) status));
5dc0d613 2873#endif /* USE_THREADS */
f86702cc
PP
2874 switch (status) {
2875 case 0:
2876 STATUS_ALL_SUCCESS;
2877 break;
2878 case 1:
2879 STATUS_ALL_FAILURE;
2880 break;
2881 default:
2882 STATUS_NATIVE_SET(status);
2883 break;
2884 }
2885 my_exit_jump();
2886}
2887
2888void
8ac85365 2889my_failure_exit(void)
f86702cc
PP
2890{
2891#ifdef VMS
2892 if (vaxc$errno & 1) {
4fdae800
PP
2893 if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
2894 STATUS_NATIVE_SET(44);
f86702cc
PP
2895 }
2896 else {
ff0cee69 2897 if (!vaxc$errno && errno) /* unlikely */
4fdae800 2898 STATUS_NATIVE_SET(44);
f86702cc 2899 else
4fdae800 2900 STATUS_NATIVE_SET(vaxc$errno);
f86702cc
PP
2901 }
2902#else
9b599b2a 2903 int exitstatus;
f86702cc
PP
2904 if (errno & 255)
2905 STATUS_POSIX_SET(errno);
9b599b2a
GS
2906 else {
2907 exitstatus = STATUS_POSIX >> 8;
2908 if (exitstatus & 255)
2909 STATUS_POSIX_SET(exitstatus);
2910 else
2911 STATUS_POSIX_SET(255);
2912 }
f86702cc
PP
2913#endif
2914 my_exit_jump();
93a17b20
LW
2915}
2916
76e3520e 2917STATIC void
8ac85365 2918my_exit_jump(void)
f86702cc 2919{
bac4b2ad 2920 dSP;
c09156bb 2921 register PERL_CONTEXT *cx;
f86702cc
PP
2922 I32 gimme;
2923 SV **newsp;
2924
afe37c7d
GS
2925 if (e_script) {
2926 SvREFCNT_dec(e_script);
2927 e_script = Nullsv;
f86702cc
PP
2928 }
2929
bac4b2ad 2930 POPSTACK_TO(mainstack);
f86702cc
PP
2931 if (cxstack_ix >= 0) {
2932 if (cxstack_ix > 0)
2933 dounwind(0);
2934 POPBLOCK(cx,curpm);
2935 LEAVE;
2936 }
ff0cee69 2937
6224f72b 2938 JMPENV_JUMP(2);
f86702cc 2939}
873ef191
GS
2940
2941
2942#include "XSUB.h"
2943
2944static I32
6224f72b
GS
2945#ifdef PERL_OBJECT
2946read_e_script(CPerlObj *pPerl, int idx, SV *buf_sv, int maxlen)
2947#else
2948read_e_script(int idx, SV *buf_sv, int maxlen)
2949#endif
873ef191
GS
2950{
2951 char *p, *nl;
873ef191
GS
2952 p = SvPVX(e_script);
2953 nl = strchr(p, '\n');
2954 nl = (nl) ? nl+1 : SvEND(e_script);
2955 if (nl-p == 0)
2956 return 0;
2957 sv_catpvn(buf_sv, p, nl-p);
2958 sv_chop(e_script, nl);
2959 return 1;
2960}
2961
1163b5c4 2962