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