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