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