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