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