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