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