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