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