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