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