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