This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
perl.h: Add debugging statements for mutex ops
[perl5.git] / perl.c
<
CommitLineData
4b88f280 1#line 2 "perl.c"
a0d0e21e
LW
2/* perl.c
3 *
737f4459 4 * Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001
2eee27d7 5 * 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012
e84cc8c8 6 * 2013, 2014, 2015, 2016, 2017, 2018 by Larry Wall and others
a687059c 7 *
352d5a3a
LW
8 * You may distribute under the terms of either the GNU General Public
9 * License or the Artistic License, as specified in the README file.
a687059c 10 *
8d063cd8
LW
11 */
12
a0d0e21e 13/*
4ac71550
TC
14 * A ship then new they built for him
15 * of mithril and of elven-glass
cdad3b53 16 * --from Bilbo's song of Eärendil
4ac71550
TC
17 *
18 * [p.236 of _The Lord of the Rings_, II/i: "Many Meetings"]
a0d0e21e 19 */
45d8adaa 20
166f8a29
DM
21/* This file contains the top-level functions that are used to create, use
22 * and destroy a perl interpreter, plus the functions used by XS code to
23 * call back into perl. Note that it does not contain the actual main()
ddfa107c 24 * function of the interpreter; that can be found in perlmain.c
a1b69980
DM
25 *
26 * Note that at build time this file is also linked to as perlmini.c,
27 * and perlmini.o is then built with PERL_IS_MINIPERL defined, which is
28 * then used to create the miniperl executable, rather than perl.o.
166f8a29
DM
29 */
30
c44493f1 31#if defined(PERL_IS_MINIPERL) && !defined(USE_SITECUSTOMIZE)
43c0c913
NC
32# define USE_SITECUSTOMIZE
33#endif
34
378cc40b 35#include "EXTERN.h"
864dbfa3 36#define PERL_IN_PERL_C
378cc40b 37#include "perl.h"
e3321bb0 38#include "patchlevel.h" /* for local_patches */
4a5df386 39#include "XSUB.h"
378cc40b 40
011f1a1a
JH
41#ifdef NETWARE
42#include "nwutil.h"
011f1a1a
JH
43#endif
44
2aa47728 45#ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
bf357333
NC
46# ifdef I_SYSUIO
47# include <sys/uio.h>
48# endif
49
50union control_un {
51 struct cmsghdr cm;
52 char control[CMSG_SPACE(sizeof(int))];
53};
54
2aa47728
NC
55#endif
56
5311654c
JH
57#ifndef HZ
58# ifdef CLK_TCK
59# define HZ CLK_TCK
60# else
61# define HZ 60
62# endif
63#endif
64
acfe0abc 65static I32 read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen);
0cb96387 66
cc69b689 67#ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
b24bc095 68# define validate_suid(rsfp) NOOP
cc69b689 69#else
b24bc095 70# define validate_suid(rsfp) S_validate_suid(aTHX_ rsfp)
a687059c 71#endif
8d063cd8 72
d6f07c05
AL
73#define CALL_BODY_SUB(myop) \
74 if (PL_op == (myop)) \
139d0ce6 75 PL_op = PL_ppaddr[OP_ENTERSUB](aTHX); \
d6f07c05
AL
76 if (PL_op) \
77 CALLRUNOPS(aTHX);
78
79#define CALL_LIST_BODY(cv) \
80 PUSHMARK(PL_stack_sp); \
9a8aa25b 81 call_sv(MUTABLE_SV((cv)), G_EVAL|G_DISCARD|G_VOID);
d6f07c05 82
e6827a76 83static void
daa7d858 84S_init_tls_and_interp(PerlInterpreter *my_perl)
e6827a76 85{
27da23d5 86 dVAR;
e6827a76
NC
87 if (!PL_curinterp) {
88 PERL_SET_INTERP(my_perl);
3db8f154 89#if defined(USE_ITHREADS)
e6827a76
NC
90 INIT_THREADS;
91 ALLOC_THREAD_KEY;
92 PERL_SET_THX(my_perl);
93 OP_REFCNT_INIT;
e8570548 94 OP_CHECK_MUTEX_INIT;
1e5c5f69 95 KEYWORD_PLUGIN_MUTEX_INIT;
71ad1b0c 96 HINTS_REFCNT_INIT;
929e1213 97 LOCALE_INIT;
e6827a76 98 MUTEX_INIT(&PL_dollarzero_mutex);
016af4f1
DM
99 MUTEX_INIT(&PL_my_ctx_mutex);
100# endif
e6827a76 101 }
c0bce9aa
NC
102#if defined(USE_ITHREADS)
103 else
104#else
105 /* This always happens for non-ithreads */
106#endif
107 {
e6827a76
NC
108 PERL_SET_THX(my_perl);
109 }
110}
06d86050 111
cbec8ebe
DM
112
113/* these implement the PERL_SYS_INIT, PERL_SYS_INIT3, PERL_SYS_TERM macros */
114
115void
116Perl_sys_init(int* argc, char*** argv)
117{
4fc0badb 118 dVAR;
7918f24d
NC
119
120 PERL_ARGS_ASSERT_SYS_INIT;
121
cbec8ebe
DM
122 PERL_UNUSED_ARG(argc); /* may not be used depending on _BODY macro */
123 PERL_UNUSED_ARG(argv);
124 PERL_SYS_INIT_BODY(argc, argv);
125}
126
127void
128Perl_sys_init3(int* argc, char*** argv, char*** env)
129{
4fc0badb 130 dVAR;
7918f24d
NC
131
132 PERL_ARGS_ASSERT_SYS_INIT3;
133
cbec8ebe
DM
134 PERL_UNUSED_ARG(argc); /* may not be used depending on _BODY macro */
135 PERL_UNUSED_ARG(argv);
136 PERL_UNUSED_ARG(env);
137 PERL_SYS_INIT3_BODY(argc, argv, env);
138}
139
140void
88772978 141Perl_sys_term(void)
cbec8ebe 142{
4fc0badb 143 dVAR;
bf81751b
DM
144 if (!PL_veto_cleanup) {
145 PERL_SYS_TERM_BODY();
146 }
cbec8ebe
DM
147}
148
149
32e30700
GS
150#ifdef PERL_IMPLICIT_SYS
151PerlInterpreter *
7766f137
GS
152perl_alloc_using(struct IPerlMem* ipM, struct IPerlMem* ipMS,
153 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
32e30700
GS
154 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
155 struct IPerlDir* ipD, struct IPerlSock* ipS,
156 struct IPerlProc* ipP)
157{
158 PerlInterpreter *my_perl;
7918f24d
NC
159
160 PERL_ARGS_ASSERT_PERL_ALLOC_USING;
161
9f653bb5 162 /* Newx() needs interpreter, so call malloc() instead */
32e30700 163 my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
e6827a76 164 S_init_tls_and_interp(my_perl);
32e30700
GS
165 Zero(my_perl, 1, PerlInterpreter);
166 PL_Mem = ipM;
7766f137
GS
167 PL_MemShared = ipMS;
168 PL_MemParse = ipMP;
32e30700
GS
169 PL_Env = ipE;
170 PL_StdIO = ipStd;
171 PL_LIO = ipLIO;
172 PL_Dir = ipD;
173 PL_Sock = ipS;
174 PL_Proc = ipP;
7cb608b5 175 INIT_TRACK_MEMPOOL(PL_memory_debug_header, my_perl);
7766f137 176
32e30700
GS
177 return my_perl;
178}
179#else
954c1994
GS
180
181/*
ccfc67b7
JH
182=head1 Embedding Functions
183
954c1994
GS
184=for apidoc perl_alloc
185
186Allocates a new Perl interpreter. See L<perlembed>.
187
188=cut
189*/
190
93a17b20 191PerlInterpreter *
cea2e8a9 192perl_alloc(void)
79072805 193{
cea2e8a9 194 PerlInterpreter *my_perl;
79072805 195
9f653bb5 196 /* Newx() needs interpreter, so call malloc() instead */
e8ee3774 197 my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
ba869deb 198
e6827a76 199 S_init_tls_and_interp(my_perl);
7cb608b5 200#ifndef PERL_TRACK_MEMPOOL
07409e01 201 return (PerlInterpreter *) ZeroD(my_perl, 1, PerlInterpreter);
7cb608b5
NC
202#else
203 Zero(my_perl, 1, PerlInterpreter);
204 INIT_TRACK_MEMPOOL(PL_memory_debug_header, my_perl);
205 return my_perl;
206#endif
79072805 207}
32e30700 208#endif /* PERL_IMPLICIT_SYS */
79072805 209
954c1994
GS
210/*
211=for apidoc perl_construct
212
213Initializes a new Perl interpreter. See L<perlembed>.
214
215=cut
216*/
217
0927ade0 218static void
219S_fixup_platform_bugs(void)
220{
221#if defined(__GLIBC__) && IVSIZE == 8 \
222 && ( __GLIBC__ < 2 || (__GLIBC__ == 2 && __GLIBC_MINOR__ < 8))
223 {
224 IV l = 3;
225 IV r = -10;
226 /* Cannot do this check with inlined IV constants since
227 * that seems to work correctly even with the buggy glibc. */
228 if (l % r == -3) {
229 dTHX;
230 /* Yikes, we have the bug.
231 * Patch in the workaround version. */
232 PL_ppaddr[OP_I_MODULO] = &Perl_pp_i_modulo_glibc_bugfix;
233 }
234 }
235#endif
236}
237
79072805 238void
0cb96387 239perl_construct(pTHXx)
79072805 240{
27da23d5 241 dVAR;
7918f24d
NC
242
243 PERL_ARGS_ASSERT_PERL_CONSTRUCT;
244
8990e307 245#ifdef MULTIPLICITY
54aff467 246 init_interp();
ac27b0f5 247 PL_perl_destruct_level = 1;
54aff467 248#else
7918f24d 249 PERL_UNUSED_ARG(my_perl);
54aff467
GS
250 if (PL_perl_destruct_level > 0)
251 init_interp();
252#endif
34caed6d
DM
253 PL_curcop = &PL_compiling; /* needed by ckWARN, right away */
254
75d476e2
SM
255#ifdef PERL_TRACE_OPS
256 Zero(PL_op_exec_cnt, OP_max+2, UV);
257#endif
258
0d96b528 259 init_constants();
34caed6d 260
e04fc1aa
CB
261 SvREADONLY_on(&PL_sv_placeholder);
262 SvREFCNT(&PL_sv_placeholder) = SvREFCNT_IMMORTAL;
263
264 PL_sighandlerp = (Sighandler_t) Perl_sighandler;
265#ifdef PERL_USES_PL_PIDSTATUS
266 PL_pidstatus = newHV();
267#endif
268
269 PL_rs = newSVpvs("\n");
270
271 init_stacks();
272
273/* The PERL_INTERNAL_RAND_SEED set-up must be after init_stacks because it calls
274 * things that may put SVs on the stack.
275 */
276
d6295071 277#ifdef NO_PERL_INTERNAL_RAND_SEED
f26b33bd 278 Perl_drand48_init_r(&PL_internal_random_state, seed());
d6295071
TC
279#else
280 {
281 UV seed;
282 const char *env_pv;
283 if (PerlProc_getuid() != PerlProc_geteuid() ||
284 PerlProc_getgid() != PerlProc_getegid() ||
285 !(env_pv = PerlEnv_getenv("PERL_INTERNAL_RAND_SEED")) ||
286 grok_number(env_pv, strlen(env_pv), &seed) != IS_NUMBER_IN_UV) {
287 seed = seed();
288 }
289 Perl_drand48_init_r(&PL_internal_random_state, (U32)seed);
290 }
291#endif
f26b33bd 292
748a9306 293 init_ids();
a5f75d66 294
0927ade0 295 S_fixup_platform_bugs();
296
312caa8e 297 JMPENV_BOOTSTRAP;
f86702cc
PP
298 STATUS_ALL_SUCCESS;
299
01649ba4
KW
300 PL_XPosix_ptrs[_CC_ASCII] = _new_invlist_C_array(ASCII_invlist);
301 PL_XPosix_ptrs[_CC_ALPHANUMERIC] = _new_invlist_C_array(XPosixAlnum_invlist);
302 PL_XPosix_ptrs[_CC_ALPHA] = _new_invlist_C_array(XPosixAlpha_invlist);
303 PL_XPosix_ptrs[_CC_BLANK] = _new_invlist_C_array(XPosixBlank_invlist);
304 PL_XPosix_ptrs[_CC_CASED] = _new_invlist_C_array(Cased_invlist);
305 PL_XPosix_ptrs[_CC_CNTRL] = _new_invlist_C_array(XPosixCntrl_invlist);
306 PL_XPosix_ptrs[_CC_DIGIT] = _new_invlist_C_array(XPosixDigit_invlist);
307 PL_XPosix_ptrs[_CC_GRAPH] = _new_invlist_C_array(XPosixGraph_invlist);
308 PL_XPosix_ptrs[_CC_LOWER] = _new_invlist_C_array(XPosixLower_invlist);
309 PL_XPosix_ptrs[_CC_PRINT] = _new_invlist_C_array(XPosixPrint_invlist);
310 PL_XPosix_ptrs[_CC_PUNCT] = _new_invlist_C_array(XPosixPunct_invlist);
311 PL_XPosix_ptrs[_CC_SPACE] = _new_invlist_C_array(XPerlSpace_invlist);
312 PL_XPosix_ptrs[_CC_UPPER] = _new_invlist_C_array(XPosixUpper_invlist);
313 PL_XPosix_ptrs[_CC_VERTSPACE] = _new_invlist_C_array(VertSpace_invlist);
314 PL_XPosix_ptrs[_CC_WORDCHAR] = _new_invlist_C_array(XPosixWord_invlist);
315 PL_XPosix_ptrs[_CC_XDIGIT] = _new_invlist_C_array(XPosixXDigit_invlist);
316 PL_GCB_invlist = _new_invlist_C_array(_Perl_GCB_invlist);
317 PL_SB_invlist = _new_invlist_C_array(_Perl_SB_invlist);
318 PL_WB_invlist = _new_invlist_C_array(_Perl_WB_invlist);
319 PL_LB_invlist = _new_invlist_C_array(_Perl_LB_invlist);
320 PL_Assigned_invlist = _new_invlist_C_array(Assigned_invlist);
321 PL_SCX_invlist = _new_invlist_C_array(_Perl_SCX_invlist);
322
0672f40e 323 init_i18nl10n(1);
0b5b802d 324
ab821d7f 325#if defined(LOCAL_PATCH_COUNT)
3280af22 326 PL_localpatches = local_patches; /* For possible -v */
ab821d7f
PP
327#endif
328
fa2e4594
TC
329#if defined(LIBM_LIB_VERSION)
330 /*
331 * Some BSDs and Cygwin default to POSIX math instead of IEEE.
332 * This switches them over to IEEE.
333 */
334 _LIB_VERSION = _IEEE_;
335#endif
336
52853b95
GS
337#ifdef HAVE_INTERP_INTERN
338 sys_intern_init();
339#endif
340
3a1ee7e8 341 PerlIO_init(aTHX); /* Hook to IO system */
760ac839 342
3280af22
NIS
343 PL_fdpid = newAV(); /* for remembering popen pids by fd */
344 PL_modglobal = newHV(); /* pointers to per-interpreter module globals */
396482e1 345 PL_errors = newSVpvs("");
854da30f
YO
346 SvPVCLEAR(PERL_DEBUG_PAD(0)); /* For regex debugging. */
347 SvPVCLEAR(PERL_DEBUG_PAD(1)); /* ext/re needs these */
348 SvPVCLEAR(PERL_DEBUG_PAD(2)); /* even without DEBUGGING. */
1fcf4c12 349#ifdef USE_ITHREADS
402d2eb1
NC
350 /* First entry is a list of empty elements. It needs to be initialised
351 else all hell breaks loose in S_find_uninit_var(). */
352 Perl_av_create_and_push(aTHX_ &PL_regex_padav, newSVpvs(""));
13137afc 353 PL_regex_pad = AvARRAY(PL_regex_padav);
d4d03940 354 Newxz(PL_stashpad, PL_stashpadmax, HV *);
1fcf4c12 355#endif
e5dd39fc 356#ifdef USE_REENTRANT_API
59bd0823 357 Perl_reentrant_init(aTHX);
e5dd39fc 358#endif
e6a172f3 359 if (PL_hash_seed_set == FALSE) {
9d5e3f1a
YO
360 /* Initialize the hash seed and state at startup. This must be
361 * done very early, before ANY hashes are constructed, and once
362 * setup is fixed for the lifetime of the process.
363 *
364 * If you decide to disable the seeding process you should choose
365 * a suitable seed yourself and define PERL_HASH_SEED to a well chosen
366 * string. See hv_func.h for details.
367 */
1a237f4f 368#if defined(USE_HASH_SEED)
9d5e3f1a 369 /* get the hash seed from the environment or from an RNG */
7dc86639 370 Perl_get_hash_seed(aTHX_ PL_hash_seed);
1a237f4f 371#else
9d5e3f1a
YO
372 /* they want a hard coded seed, check that it is long enough */
373 assert( strlen(PERL_HASH_SEED) >= PERL_HASH_SEED_BYTES );
1a237f4f 374#endif
e6a172f3 375
9d5e3f1a
YO
376 /* now we use the chosen seed to initialize the state -
377 * in some configurations this may be a relatively speaking
378 * expensive operation, but we only have to do it once at startup */
379 PERL_HASH_SEED_STATE(PERL_HASH_SEED,PL_hash_state);
380
381#ifdef PERL_USE_SINGLE_CHAR_HASH_CACHE
382 /* we can build a special cache for 0/1 byte keys, if people choose
383 * I suspect most of the time it is not worth it */
384 {
385 char str[2]="\0";
386 int i;
387 for (i=0;i<256;i++) {
388 str[0]= i;
389 PERL_HASH_WITH_STATE(PL_hash_state,PL_hash_chars[i],str,1);
390 }
391 PERL_HASH_WITH_STATE(PL_hash_state,PL_hash_chars[256],str,0);
392 }
393#endif
394 /* at this point we have initialezed the hash function, and we can start
395 * constructing hashes */
396 PL_hash_seed_set= TRUE;
397 }
c82f4881
N
398
399 /* Allow PL_strtab to be pre-initialized before calling perl_construct.
400 * can use a custom optimized PL_strtab hash before calling perl_construct */
401 if (!PL_strtab) {
402 /* Note that strtab is a rather special HV. Assumptions are made
403 about not iterating on it, and not adding tie magic to it.
404 It is properly deallocated in perl_destruct() */
405 PL_strtab = newHV();
406
407 /* SHAREKEYS tells us that the hash has its keys shared with PL_strtab,
408 * which is not the case with PL_strtab itself */
409 HvSHAREKEYS_off(PL_strtab); /* mandatory */
410 hv_ksplit(PL_strtab, 1 << 11);
411 }
3d47000e 412
a38ab475
RZ
413 Zero(PL_sv_consts, SV_CONSTS_COUNT, SV*);
414
2f42fcb0
JH
415#ifndef PERL_MICRO
416# ifdef USE_ENVIRON_ARRAY
0631ea03 417 PL_origenviron = environ;
2f42fcb0 418# endif
0631ea03
AB
419#endif
420
5311654c 421 /* Use sysconf(_SC_CLK_TCK) if available, if not
dbc1d986 422 * available or if the sysconf() fails, use the HZ.
27da23d5
JH
423 * The HZ if not originally defined has been by now
424 * been defined as CLK_TCK, if available. */
b6c36746 425#if defined(HAS_SYSCONF) && defined(_SC_CLK_TCK)
5311654c
JH
426 PL_clocktick = sysconf(_SC_CLK_TCK);
427 if (PL_clocktick <= 0)
428#endif
429 PL_clocktick = HZ;
430
081fc587
AB
431 PL_stashcache = newHV();
432
e8e3635e 433 PL_patchlevel = newSVpvs("v" PERL_VERSION_STRING);
d7aa5382 434
27da23d5
JH
435#ifdef HAS_MMAP
436 if (!PL_mmap_page_size) {
437#if defined(HAS_SYSCONF) && (defined(_SC_PAGESIZE) || defined(_SC_MMAP_PAGE_SIZE))
438 {
439 SETERRNO(0, SS_NORMAL);
440# ifdef _SC_PAGESIZE
441 PL_mmap_page_size = sysconf(_SC_PAGESIZE);
442# else
443 PL_mmap_page_size = sysconf(_SC_MMAP_PAGE_SIZE);
444# endif
445 if ((long) PL_mmap_page_size < 0) {
f63f4036
Z
446 Perl_croak(aTHX_ "panic: sysconf: %s",
447 errno ? Strerror(errno) : "pagesize unknown");
27da23d5
JH
448 }
449 }
39bb759e 450#elif defined(HAS_GETPAGESIZE)
27da23d5 451 PL_mmap_page_size = getpagesize();
39bb759e 452#elif defined(I_SYS_PARAM) && defined(PAGESIZE)
27da23d5 453 PL_mmap_page_size = PAGESIZE; /* compiletime, bad */
27da23d5
JH
454#endif
455 if (PL_mmap_page_size <= 0)
456 Perl_croak(aTHX_ "panic: bad pagesize %" IVdf,
457 (IV) PL_mmap_page_size);
458 }
459#endif /* HAS_MMAP */
460
461#if defined(HAS_TIMES) && defined(PERL_NEED_TIMESBASE)
462 PL_timesbase.tms_utime = 0;
463 PL_timesbase.tms_stime = 0;
464 PL_timesbase.tms_cutime = 0;
465 PL_timesbase.tms_cstime = 0;
466#endif
467
7d113631
NC
468 PL_osname = Perl_savepvn(aTHX_ STR_WITH_LEN(OSNAME));
469
a3e6e81e 470 PL_registered_mros = newHV();
9e169432
NC
471 /* Start with 1 bucket, for DFS. It's unlikely we'll need more. */
472 HvMAX(PL_registered_mros) = 0;
a3e6e81e 473
5acc3fa5 474#ifdef HAS_POSIX_2008_LOCALE
6ebbc862
KW
475 PL_C_locale_obj = newlocale(LC_ALL_MASK, "C", NULL);
476#endif
7b8dd5f4 477
8990e307 478 ENTER;
79072805
LW
479}
480
954c1994 481/*
62375a60
NIS
482=for apidoc nothreadhook
483
484Stub that provides thread hook for perl_destruct when there are
485no threads.
486
487=cut
488*/
489
490int
4e9e3734 491Perl_nothreadhook(pTHX)
62375a60 492{
96a5add6 493 PERL_UNUSED_CONTEXT;
62375a60
NIS
494 return 0;
495}
496
41e4abd8
NC
497#ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
498void
499Perl_dump_sv_child(pTHX_ SV *sv)
500{
501 ssize_t got;
bf357333
NC
502 const int sock = PL_dumper_fd;
503 const int debug_fd = PerlIO_fileno(Perl_debug_log);
bf357333
NC
504 union control_un control;
505 struct msghdr msg;
808ad2d0 506 struct iovec vec[2];
bf357333 507 struct cmsghdr *cmptr;
808ad2d0
NC
508 int returned_errno;
509 unsigned char buffer[256];
41e4abd8 510
7918f24d
NC
511 PERL_ARGS_ASSERT_DUMP_SV_CHILD;
512
bf357333 513 if(sock == -1 || debug_fd == -1)
41e4abd8
NC
514 return;
515
516 PerlIO_flush(Perl_debug_log);
517
bf357333
NC
518 /* All these shenanigans are to pass a file descriptor over to our child for
519 it to dump out to. We can't let it hold open the file descriptor when it
520 forks, as the file descriptor it will dump to can turn out to be one end
521 of pipe that some other process will wait on for EOF. (So as it would
b293a5f8 522 be open, the wait would be forever.) */
bf357333
NC
523
524 msg.msg_control = control.control;
525 msg.msg_controllen = sizeof(control.control);
526 /* We're a connected socket so we don't need a destination */
527 msg.msg_name = NULL;
528 msg.msg_namelen = 0;
529 msg.msg_iov = vec;
808ad2d0 530 msg.msg_iovlen = 1;
bf357333
NC
531
532 cmptr = CMSG_FIRSTHDR(&msg);
533 cmptr->cmsg_len = CMSG_LEN(sizeof(int));
534 cmptr->cmsg_level = SOL_SOCKET;
535 cmptr->cmsg_type = SCM_RIGHTS;
536 *((int *)CMSG_DATA(cmptr)) = 1;
537
538 vec[0].iov_base = (void*)&sv;
539 vec[0].iov_len = sizeof(sv);
540 got = sendmsg(sock, &msg, 0);
41e4abd8
NC
541
542 if(got < 0) {
bf357333 543 perror("Debug leaking scalars parent sendmsg failed");
41e4abd8
NC
544 abort();
545 }
bf357333
NC
546 if(got < sizeof(sv)) {
547 perror("Debug leaking scalars parent short sendmsg");
41e4abd8
NC
548 abort();
549 }
550
808ad2d0
NC
551 /* Return protocol is
552 int: errno value
553 unsigned char: length of location string (0 for empty)
554 unsigned char*: string (not terminated)
555 */
556 vec[0].iov_base = (void*)&returned_errno;
557 vec[0].iov_len = sizeof(returned_errno);
558 vec[1].iov_base = buffer;
559 vec[1].iov_len = 1;
560
561 got = readv(sock, vec, 2);
41e4abd8
NC
562
563 if(got < 0) {
564 perror("Debug leaking scalars parent read failed");
808ad2d0 565 PerlIO_flush(PerlIO_stderr());
41e4abd8
NC
566 abort();
567 }
808ad2d0 568 if(got < sizeof(returned_errno) + 1) {
41e4abd8 569 perror("Debug leaking scalars parent short read");
808ad2d0 570 PerlIO_flush(PerlIO_stderr());
41e4abd8
NC
571 abort();
572 }
573
808ad2d0
NC
574 if (*buffer) {
575 got = read(sock, buffer + 1, *buffer);
576 if(got < 0) {
577 perror("Debug leaking scalars parent read 2 failed");
578 PerlIO_flush(PerlIO_stderr());
579 abort();
580 }
581
582 if(got < *buffer) {
583 perror("Debug leaking scalars parent short read 2");
584 PerlIO_flush(PerlIO_stderr());
585 abort();
586 }
587 }
588
589 if (returned_errno || *buffer) {
590 Perl_warn(aTHX_ "Debug leaking scalars child failed%s%.*s with errno"
591 " %d: %s", (*buffer ? " at " : ""), (int) *buffer, buffer + 1,
0c0d42ff 592 returned_errno, Strerror(returned_errno));
41e4abd8
NC
593 }
594}
595#endif
596
62375a60 597/*
0301e899
Z
598=for apidoc Am|int|perl_destruct|PerlInterpreter *my_perl
599
600Shuts down a Perl interpreter. See L<perlembed> for a tutorial.
601
602C<my_perl> points to the Perl interpreter. It must have been previously
603created through the use of L</perl_alloc> and L</perl_construct>. It may
604have been initialised through L</perl_parse>, and may have been used
605through L</perl_run> and other means. This function should be called for
606any Perl interpreter that has been constructed with L</perl_construct>,
607even if subsequent operations on it failed, for example if L</perl_parse>
608returned a non-zero value.
609
610If the interpreter's C<PL_exit_flags> word has the
611C<PERL_EXIT_DESTRUCT_END> flag set, then this function will execute code
612in C<END> blocks before performing the rest of destruction. If it is
613desired to make any use of the interpreter between L</perl_parse> and
614L</perl_destruct> other than just calling L</perl_run>, then this flag
615should be set early on. This matters if L</perl_run> will not be called,
616or if anything else will be done in addition to calling L</perl_run>.
617
618Returns a value be a suitable value to pass to the C library function
619C<exit> (or to return from C<main>), to serve as an exit code indicating
620the nature of the way the interpreter terminated. This takes into account
621any failure of L</perl_parse> and any early exit from L</perl_run>.
622The exit code is of the type required by the host operating system,
623so because of differing exit code conventions it is not portable to
624interpret specific numeric values as having specific meanings.
954c1994
GS
625
626=cut
627*/
628
31d77e54 629int
0cb96387 630perl_destruct(pTHXx)
79072805 631{
27da23d5 632 dVAR;
8162b70e 633 volatile signed char destruct_level; /* see possible values in intrpvar.h */
a0d0e21e 634 HV *hv;
2aa47728 635#ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
2aa47728
NC
636 pid_t child;
637#endif
9c0b6888 638 int i;
8990e307 639
7918f24d
NC
640 PERL_ARGS_ASSERT_PERL_DESTRUCT;
641#ifndef MULTIPLICITY
ed6c66dd 642 PERL_UNUSED_ARG(my_perl);
7918f24d 643#endif
9d4ba2ae 644
3d22c4f0
GG
645 assert(PL_scopestack_ix == 1);
646
7766f137
GS
647 /* wait for all pseudo-forked children to finish */
648 PERL_WAIT_FOR_CHILDREN;
649
3280af22 650 destruct_level = PL_perl_destruct_level;
36e77d41 651#if defined(DEBUGGING) || defined(PERL_TRACK_MEMPOOL)
4633a7c4 652 {
9d4ba2ae
AL
653 const char * const s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL");
654 if (s) {
96e440d2
JH
655 int i;
656 if (strEQ(s, "-1")) { /* Special case: modperl folklore. */
657 i = -1;
658 } else {
22ff3130
HS
659 UV uv;
660 if (grok_atoUV(s, &uv, NULL) && uv <= INT_MAX)
661 i = (int)uv;
662 else
663 i = 0;
96e440d2 664 }
36e77d41
DD
665#ifdef DEBUGGING
666 if (destruct_level < i) destruct_level = i;
667#endif
668#ifdef PERL_TRACK_MEMPOOL
f5199772
KW
669 /* RT #114496, for perl_free */
670 PL_perl_destruct_level = i;
36e77d41 671#endif
5f05dabc 672 }
4633a7c4
LW
673 }
674#endif
675
27da23d5 676 if (PL_exit_flags & PERL_EXIT_DESTRUCT_END) {
f3faeb53
AB
677 dJMPENV;
678 int x = 0;
679
680 JMPENV_PUSH(x);
1b6737cc 681 PERL_UNUSED_VAR(x);
9ebf26ad 682 if (PL_endav && !PL_minus_c) {
ca7b837b 683 PERL_SET_PHASE(PERL_PHASE_END);
f3faeb53 684 call_list(PL_scopestack_ix, PL_endav);
9ebf26ad 685 }
f3faeb53 686 JMPENV_POP;
26f423df 687 }
f3faeb53 688 LEAVE;
a0d0e21e 689 FREETMPS;
3d22c4f0 690 assert(PL_scopestack_ix == 0);
a0d0e21e 691
e00b64d4 692 /* Need to flush since END blocks can produce output */
8abddda3
TC
693 /* flush stdout separately, since we can identify it */
694#ifdef USE_PERLIO
695 {
696 PerlIO *stdo = PerlIO_stdout();
697 if (*stdo && PerlIO_flush(stdo)) {
698 PerlIO_restore_errno(stdo);
675c73ca 699 if (errno)
37537123 700 PerlIO_printf(PerlIO_stderr(), "Unable to flush stdout: %s\n",
675c73ca 701 Strerror(errno));
8abddda3
TC
702 if (!STATUS_UNIX)
703 STATUS_ALL_FAILURE;
704 }
705 }
706#endif
f13a2bc0 707 my_fflush_all();
e00b64d4 708
75d476e2 709#ifdef PERL_TRACE_OPS
e71f25b3
JC
710 /* dump OP-counts if $ENV{PERL_TRACE_OPS} > 0 */
711 {
712 const char * const ptoenv = PerlEnv_getenv("PERL_TRACE_OPS");
713 UV uv;
714
715 if (!ptoenv || !Perl_grok_atoUV(ptoenv, &uv, NULL)
716 || !(uv > 0))
717 goto no_trace_out;
718 }
75d476e2
SM
719 PerlIO_printf(Perl_debug_log, "Trace of all OPs executed:\n");
720 for (i = 0; i <= OP_max; ++i) {
e71f25b3 721 if (PL_op_exec_cnt[i])
147e3846 722 PerlIO_printf(Perl_debug_log, " %s: %" UVuf "\n", PL_op_name[i], PL_op_exec_cnt[i]);
75d476e2
SM
723 }
724 /* Utility slot for easily doing little tracing experiments in the runloop: */
725 if (PL_op_exec_cnt[OP_max+1] != 0)
147e3846 726 PerlIO_printf(Perl_debug_log, " SPECIAL: %" UVuf "\n", PL_op_exec_cnt[OP_max+1]);
75d476e2 727 PerlIO_printf(Perl_debug_log, "\n");
e71f25b3 728 no_trace_out:
75d476e2
SM
729#endif
730
731
16c91539 732 if (PL_threadhook(aTHX)) {
62375a60 733 /* Threads hook has vetoed further cleanup */
c301d606 734 PL_veto_cleanup = TRUE;
37038d91 735 return STATUS_EXIT;
62375a60
NIS
736 }
737
2aa47728
NC
738#ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
739 if (destruct_level != 0) {
740 /* Fork here to create a child. Our child's job is to preserve the
741 state of scalars prior to destruction, so that we can instruct it
742 to dump any scalars that we later find have leaked.
743 There's no subtlety in this code - it assumes POSIX, and it doesn't
744 fail gracefully */
745 int fd[2];
746
49836294 747 if(PerlSock_socketpair_cloexec(AF_UNIX, SOCK_STREAM, 0, fd)) {
2aa47728
NC
748 perror("Debug leaking scalars socketpair failed");
749 abort();
750 }
751
752 child = fork();
753 if(child == -1) {
754 perror("Debug leaking scalars fork failed");
755 abort();
756 }
757 if (!child) {
758 /* We are the child */
3125a5a4
NC
759 const int sock = fd[1];
760 const int debug_fd = PerlIO_fileno(Perl_debug_log);
761 int f;
808ad2d0
NC
762 const char *where;
763 /* Our success message is an integer 0, and a char 0 */
b61433a9 764 static const char success[sizeof(int) + 1] = {0};
3125a5a4 765
2aa47728 766 close(fd[0]);
2aa47728 767
3125a5a4
NC
768 /* We need to close all other file descriptors otherwise we end up
769 with interesting hangs, where the parent closes its end of a
770 pipe, and sits waiting for (another) child to terminate. Only
771 that child never terminates, because it never gets EOF, because
bf357333
NC
772 we also have the far end of the pipe open. We even need to
773 close the debugging fd, because sometimes it happens to be one
774 end of a pipe, and a process is waiting on the other end for
775 EOF. Normally it would be closed at some point earlier in
776 destruction, but if we happen to cause the pipe to remain open,
777 EOF never occurs, and we get an infinite hang. Hence all the
778 games to pass in a file descriptor if it's actually needed. */
3125a5a4
NC
779
780 f = sysconf(_SC_OPEN_MAX);
781 if(f < 0) {
808ad2d0
NC
782 where = "sysconf failed";
783 goto abort;
3125a5a4
NC
784 }
785 while (f--) {
786 if (f == sock)
787 continue;
3125a5a4
NC
788 close(f);
789 }
790
2aa47728
NC
791 while (1) {
792 SV *target;
bf357333
NC
793 union control_un control;
794 struct msghdr msg;
795 struct iovec vec[1];
796 struct cmsghdr *cmptr;
797 ssize_t got;
798 int got_fd;
799
800 msg.msg_control = control.control;
801 msg.msg_controllen = sizeof(control.control);
802 /* We're a connected socket so we don't need a source */
803 msg.msg_name = NULL;
804 msg.msg_namelen = 0;
805 msg.msg_iov = vec;
c3caa5c3 806 msg.msg_iovlen = C_ARRAY_LENGTH(vec);
bf357333
NC
807
808 vec[0].iov_base = (void*)&target;
809 vec[0].iov_len = sizeof(target);
810
811 got = recvmsg(sock, &msg, 0);
2aa47728
NC
812
813 if(got == 0)
814 break;
815 if(got < 0) {
808ad2d0
NC
816 where = "recv failed";
817 goto abort;
2aa47728
NC
818 }
819 if(got < sizeof(target)) {
808ad2d0
NC
820 where = "short recv";
821 goto abort;
2aa47728 822 }
bf357333 823
808ad2d0
NC
824 if(!(cmptr = CMSG_FIRSTHDR(&msg))) {
825 where = "no cmsg";
826 goto abort;
827 }
828 if(cmptr->cmsg_len != CMSG_LEN(sizeof(int))) {
829 where = "wrong cmsg_len";
830 goto abort;
831 }
832 if(cmptr->cmsg_level != SOL_SOCKET) {
833 where = "wrong cmsg_level";
834 goto abort;
835 }
836 if(cmptr->cmsg_type != SCM_RIGHTS) {
837 where = "wrong cmsg_type";
838 goto abort;
839 }
bf357333
NC
840
841 got_fd = *(int*)CMSG_DATA(cmptr);
842 /* For our last little bit of trickery, put the file descriptor
843 back into Perl_debug_log, as if we never actually closed it
844 */
808ad2d0 845 if(got_fd != debug_fd) {
884fc2d3 846 if (PerlLIO_dup2_cloexec(got_fd, debug_fd) == -1) {
808ad2d0
NC
847 where = "dup2";
848 goto abort;
849 }
850 }
2aa47728 851 sv_dump(target);
bf357333 852
2aa47728
NC
853 PerlIO_flush(Perl_debug_log);
854
808ad2d0 855 got = write(sock, &success, sizeof(success));
2aa47728
NC
856
857 if(got < 0) {
808ad2d0
NC
858 where = "write failed";
859 goto abort;
2aa47728 860 }
808ad2d0
NC
861 if(got < sizeof(success)) {
862 where = "short write";
863 goto abort;
2aa47728
NC
864 }
865 }
866 _exit(0);
808ad2d0
NC
867 abort:
868 {
869 int send_errno = errno;
870 unsigned char length = (unsigned char) strlen(where);
871 struct iovec failure[3] = {
872 {(void*)&send_errno, sizeof(send_errno)},
873 {&length, 1},
874 {(void*)where, length}
875 };
876 int got = writev(sock, failure, 3);
877 /* Bad news travels fast. Faster than data. We'll get a SIGPIPE
878 in the parent if we try to read from the socketpair after the
879 child has exited, even if there was data to read.
880 So sleep a bit to give the parent a fighting chance of
881 reading the data. */
882 sleep(2);
883 _exit((got == -1) ? errno : 0);
884 }
bf357333 885 /* End of child. */
2aa47728 886 }
41e4abd8 887 PL_dumper_fd = fd[0];
2aa47728
NC
888 close(fd[1]);
889 }
890#endif
891
ff0cee69
PP
892 /* We must account for everything. */
893
894 /* Destroy the main CV and syntax tree */
37e77c23
FC
895 /* Set PL_curcop now, because destroying ops can cause new SVs
896 to be generated in Perl_pad_swipe, and when running with
897 -DDEBUG_LEAKING_SCALARS they expect PL_curcop to point to a valid
898 op from which the filename structure member is copied. */
17fbfdf6 899 PL_curcop = &PL_compiling;
3280af22 900 if (PL_main_root) {
4e380990
DM
901 /* ensure comppad/curpad to refer to main's pad */
902 if (CvPADLIST(PL_main_cv)) {
903 PAD_SET_CUR_NOSAVE(CvPADLIST(PL_main_cv), 1);
325e1816 904 PL_comppad_name = PadlistNAMES(CvPADLIST(PL_main_cv));
4e380990 905 }
3280af22 906 op_free(PL_main_root);
5f66b61c 907 PL_main_root = NULL;
a0d0e21e 908 }
5f66b61c 909 PL_main_start = NULL;
aac9d523
DM
910 /* note that PL_main_cv isn't usually actually freed at this point,
911 * due to the CvOUTSIDE refs from subs compiled within it. It will
912 * get freed once all the subs are freed in sv_clean_all(), for
913 * destruct_level > 0 */
3280af22 914 SvREFCNT_dec(PL_main_cv);
601f1833 915 PL_main_cv = NULL;
ca7b837b 916 PERL_SET_PHASE(PERL_PHASE_DESTRUCT);
ff0cee69 917
13621cfb
NIS
918 /* Tell PerlIO we are about to tear things apart in case
919 we have layers which are using resources that should
920 be cleaned up now.
921 */
922
923 PerlIO_destruct(aTHX);
924
ddf23d4a
SM
925 /*
926 * Try to destruct global references. We do this first so that the
927 * destructors and destructees still exist. Some sv's might remain.
928 * Non-referenced objects are on their own.
929 */
930 sv_clean_objs();
8990e307 931
5cd24f17 932 /* unhook hooks which will soon be, or use, destroyed data */
3280af22 933 SvREFCNT_dec(PL_warnhook);
a0714e2c 934 PL_warnhook = NULL;
3280af22 935 SvREFCNT_dec(PL_diehook);
a0714e2c 936 PL_diehook = NULL;
5cd24f17 937
4b556e6c 938 /* call exit list functions */
3280af22 939 while (PL_exitlistlen-- > 0)
acfe0abc 940 PL_exitlist[PL_exitlistlen].fn(aTHX_ PL_exitlist[PL_exitlistlen].ptr);
4b556e6c 941
3280af22 942 Safefree(PL_exitlist);
4b556e6c 943
1c4916e5
CB
944 PL_exitlist = NULL;
945 PL_exitlistlen = 0;
946
a3e6e81e
NC
947 SvREFCNT_dec(PL_registered_mros);
948
551a8b83 949 /* jettison our possibly duplicated environment */
4b647fb0
DM
950 /* if PERL_USE_SAFE_PUTENV is defined environ will not have been copied
951 * so we certainly shouldn't free it here
952 */
2f42fcb0 953#ifndef PERL_MICRO
4b647fb0 954#if defined(USE_ENVIRON_ARRAY) && !defined(PERL_USE_SAFE_PUTENV)
50acdf95 955 if (environ != PL_origenviron && !PL_use_safe_putenv
4efc5df6
GS
956#ifdef USE_ITHREADS
957 /* only main thread can free environ[0] contents */
958 && PL_curinterp == aTHX
959#endif
960 )
961 {
551a8b83
JH
962 I32 i;
963
964 for (i = 0; environ[i]; i++)
4b420006 965 safesysfree(environ[i]);
0631ea03 966
4b420006
JH
967 /* Must use safesysfree() when working with environ. */
968 safesysfree(environ);
551a8b83
JH
969
970 environ = PL_origenviron;
971 }
972#endif
2f42fcb0 973#endif /* !PERL_MICRO */
551a8b83 974
30985c42
JH
975 if (destruct_level == 0) {
976
977 DEBUG_P(debprofdump());
978
979#if defined(PERLIO_LAYERS)
980 /* No more IO - including error messages ! */
981 PerlIO_cleanup(aTHX);
982#endif
983
984 CopFILE_free(&PL_compiling);
30985c42
JH
985
986 /* The exit() function will do everything that needs doing. */
987 return STATUS_EXIT;
988 }
989
9fa9f06b
KW
990 /* Below, do clean up for when PERL_DESTRUCT_LEVEL is not 0 */
991
5f8cb046
DM
992#ifdef USE_ITHREADS
993 /* the syntax tree is shared between clones
994 * so op_free(PL_main_root) only ReREFCNT_dec's
995 * REGEXPs in the parent interpreter
996 * we need to manually ReREFCNT_dec for the clones
997 */
0547a729
DM
998 {
999 I32 i = AvFILLp(PL_regex_padav);
1000 SV **ary = AvARRAY(PL_regex_padav);
1001
1002 for (; i; i--) {
1003 SvREFCNT_dec(ary[i]);
1004 ary[i] = &PL_sv_undef;
1005 }
1006 }
5f8cb046
DM
1007#endif
1008
0547a729 1009
ad64d0ec 1010 SvREFCNT_dec(MUTABLE_SV(PL_stashcache));
081fc587
AB
1011 PL_stashcache = NULL;
1012
5f05dabc
PP
1013 /* loosen bonds of global variables */
1014
2f9285f8
DM
1015 /* XXX can PL_parser still be non-null here? */
1016 if(PL_parser && PL_parser->rsfp) {
1017 (void)PerlIO_close(PL_parser->rsfp);
1018 PL_parser->rsfp = NULL;
8ebc5c01
PP
1019 }
1020
84386e14
RGS
1021 if (PL_minus_F) {
1022 Safefree(PL_splitstr);
1023 PL_splitstr = NULL;
1024 }
1025
8ebc5c01 1026 /* switches */
3280af22
NIS
1027 PL_minus_n = FALSE;
1028 PL_minus_p = FALSE;
1029 PL_minus_l = FALSE;
1030 PL_minus_a = FALSE;
1031 PL_minus_F = FALSE;
1032 PL_doswitches = FALSE;
599cee73 1033 PL_dowarn = G_WARN_OFF;
1a904fc8 1034#ifdef PERL_SAWAMPERSAND
d3b97530 1035 PL_sawampersand = 0; /* must save all match strings */
1a904fc8 1036#endif
3280af22
NIS
1037 PL_unsafe = FALSE;
1038
1039 Safefree(PL_inplace);
bd61b366 1040 PL_inplace = NULL;
a7cb1f99 1041 SvREFCNT_dec(PL_patchlevel);
3280af22
NIS
1042
1043 if (PL_e_script) {
1044 SvREFCNT_dec(PL_e_script);
a0714e2c 1045 PL_e_script = NULL;
8ebc5c01
PP
1046 }
1047
bf9cdc68
RG
1048 PL_perldb = 0;
1049
8ebc5c01
PP
1050 /* magical thingies */
1051
e23d9e2f
CS
1052 SvREFCNT_dec(PL_ofsgv); /* *, */
1053 PL_ofsgv = NULL;
5f05dabc 1054
7889fe52 1055 SvREFCNT_dec(PL_ors_sv); /* $\ */
a0714e2c 1056 PL_ors_sv = NULL;
8ebc5c01 1057
3280af22 1058 SvREFCNT_dec(PL_rs); /* $/ */
a0714e2c 1059 PL_rs = NULL;
dc92893f 1060
d33b2eba 1061 Safefree(PL_osname); /* $^O */
bd61b366 1062 PL_osname = NULL;
5f05dabc 1063
3280af22 1064 SvREFCNT_dec(PL_statname);
a0714e2c
SS
1065 PL_statname = NULL;
1066 PL_statgv = NULL;
5f05dabc 1067
8ebc5c01
PP
1068 /* defgv, aka *_ should be taken care of elsewhere */
1069
7d5ea4e7
GS
1070 /* float buffer */
1071 Safefree(PL_efloatbuf);
bd61b366 1072 PL_efloatbuf = NULL;
7d5ea4e7
GS
1073 PL_efloatsize = 0;
1074
8ebc5c01 1075 /* startup and shutdown function lists */
3280af22 1076 SvREFCNT_dec(PL_beginav);
5a837c8f 1077 SvREFCNT_dec(PL_beginav_save);
3280af22 1078 SvREFCNT_dec(PL_endav);
7d30b5c4 1079 SvREFCNT_dec(PL_checkav);
ece599bd 1080 SvREFCNT_dec(PL_checkav_save);
3c10abe3
AG
1081 SvREFCNT_dec(PL_unitcheckav);
1082 SvREFCNT_dec(PL_unitcheckav_save);
3280af22 1083 SvREFCNT_dec(PL_initav);
7d49f689
NC
1084 PL_beginav = NULL;
1085 PL_beginav_save = NULL;
1086 PL_endav = NULL;
1087 PL_checkav = NULL;
1088 PL_checkav_save = NULL;
3c10abe3
AG
1089 PL_unitcheckav = NULL;
1090 PL_unitcheckav_save = NULL;
7d49f689 1091 PL_initav = NULL;
5618dfe8 1092
8ebc5c01 1093 /* shortcuts just get cleared */
a0714e2c
SS
1094 PL_hintgv = NULL;
1095 PL_errgv = NULL;
a0714e2c
SS
1096 PL_argvoutgv = NULL;
1097 PL_stdingv = NULL;
1098 PL_stderrgv = NULL;
1099 PL_last_in_gv = NULL;
a0714e2c
SS
1100 PL_DBsingle = NULL;
1101 PL_DBtrace = NULL;
1102 PL_DBsignal = NULL;
a6d69523
TC
1103 PL_DBsingle_iv = 0;
1104 PL_DBtrace_iv = 0;
1105 PL_DBsignal_iv = 0;
601f1833 1106 PL_DBcv = NULL;
7d49f689 1107 PL_dbargs = NULL;
5c284bb0 1108 PL_debstash = NULL;
8ebc5c01 1109
cf93a474 1110 SvREFCNT_dec(PL_envgv);
f03015cd 1111 SvREFCNT_dec(PL_incgv);
722fa0e9 1112 SvREFCNT_dec(PL_argvgv);
475b1e90 1113 SvREFCNT_dec(PL_replgv);
8cece913
FC
1114 SvREFCNT_dec(PL_DBgv);
1115 SvREFCNT_dec(PL_DBline);
1116 SvREFCNT_dec(PL_DBsub);
cf93a474 1117 PL_envgv = NULL;
f03015cd 1118 PL_incgv = NULL;
722fa0e9 1119 PL_argvgv = NULL;
475b1e90 1120 PL_replgv = NULL;
8cece913
FC
1121 PL_DBgv = NULL;
1122 PL_DBline = NULL;
1123 PL_DBsub = NULL;
1124
7a1c5554 1125 SvREFCNT_dec(PL_argvout_stack);
7d49f689 1126 PL_argvout_stack = NULL;
8ebc5c01 1127
5c831c24 1128 SvREFCNT_dec(PL_modglobal);
5c284bb0 1129 PL_modglobal = NULL;
5c831c24 1130 SvREFCNT_dec(PL_preambleav);
7d49f689 1131 PL_preambleav = NULL;
5c831c24 1132 SvREFCNT_dec(PL_subname);
a0714e2c 1133 PL_subname = NULL;
ca0c25f6 1134#ifdef PERL_USES_PL_PIDSTATUS
5c831c24 1135 SvREFCNT_dec(PL_pidstatus);
5c284bb0 1136 PL_pidstatus = NULL;
ca0c25f6 1137#endif
5c831c24 1138 SvREFCNT_dec(PL_toptarget);
a0714e2c 1139 PL_toptarget = NULL;
5c831c24 1140 SvREFCNT_dec(PL_bodytarget);
a0714e2c
SS
1141 PL_bodytarget = NULL;
1142 PL_formtarget = NULL;
5c831c24 1143
d33b2eba 1144 /* free locale stuff */
b9582b6a 1145#ifdef USE_LOCALE_COLLATE
d33b2eba 1146 Safefree(PL_collation_name);
bd61b366 1147 PL_collation_name = NULL;
b9582b6a 1148#endif
d33b2eba 1149
b9582b6a 1150#ifdef USE_LOCALE_NUMERIC
d33b2eba 1151 Safefree(PL_numeric_name);
bd61b366 1152 PL_numeric_name = NULL;
a453c169 1153 SvREFCNT_dec(PL_numeric_radix_sv);
a0714e2c 1154 PL_numeric_radix_sv = NULL;
e1aa2579 1155
7e5377f7 1156# ifdef HAS_POSIX_2008_LOCALE
e1aa2579
KW
1157 if (PL_underlying_numeric_obj) {
1158 /* Make sure we aren't using the locale space we are about to free */
1159 uselocale(LC_GLOBAL_LOCALE);
1160 freelocale(PL_underlying_numeric_obj);
1161 PL_underlying_numeric_obj = (locale_t) NULL;
1162 }
e1aa2579
KW
1163# endif
1164#endif
1165
9aac5db8
KW
1166 if (PL_setlocale_buf) {
1167 Safefree(PL_setlocale_buf);
1168 PL_setlocale_buf = NULL;
1169 }
1170
7e5377f7
KW
1171 if (PL_langinfo_buf) {
1172 Safefree(PL_langinfo_buf);
1173 PL_langinfo_buf = NULL;
1174 }
1175
9c0b6888
KW
1176 /* clear character classes */
1177 for (i = 0; i < POSIX_SWASH_COUNT; i++) {
1178 SvREFCNT_dec(PL_utf8_swash_ptrs[i]);
1179 PL_utf8_swash_ptrs[i] = NULL;
1180 }
5c831c24
GS
1181 SvREFCNT_dec(PL_utf8_mark);
1182 SvREFCNT_dec(PL_utf8_toupper);
4dbdbdc2 1183 SvREFCNT_dec(PL_utf8_totitle);
5c831c24 1184 SvREFCNT_dec(PL_utf8_tolower);
b4e400f9 1185 SvREFCNT_dec(PL_utf8_tofold);
82686b01
JH
1186 SvREFCNT_dec(PL_utf8_idstart);
1187 SvREFCNT_dec(PL_utf8_idcont);
c60f4405 1188 SvREFCNT_dec(PL_utf8_foldable);
2726813d 1189 SvREFCNT_dec(PL_utf8_foldclosures);
9fa9f06b 1190 SvREFCNT_dec(PL_AboveLatin1);
e0a1ff7a 1191 SvREFCNT_dec(PL_InBitmap);
9fa9f06b
KW
1192 SvREFCNT_dec(PL_UpperLatin1);
1193 SvREFCNT_dec(PL_Latin1);
1194 SvREFCNT_dec(PL_NonL1NonFinalFold);
1195 SvREFCNT_dec(PL_HasMultiCharFold);
5b7de470 1196#ifdef USE_LOCALE_CTYPE
780fcc9f 1197 SvREFCNT_dec(PL_warn_locale);
5b7de470 1198#endif
a0714e2c
SS
1199 PL_utf8_mark = NULL;
1200 PL_utf8_toupper = NULL;
1201 PL_utf8_totitle = NULL;
1202 PL_utf8_tolower = NULL;
1203 PL_utf8_tofold = NULL;
1204 PL_utf8_idstart = NULL;
1205 PL_utf8_idcont = NULL;
2726813d 1206 PL_utf8_foldclosures = NULL;
9fa9f06b 1207 PL_AboveLatin1 = NULL;
e0a1ff7a 1208 PL_InBitmap = NULL;
9fa9f06b 1209 PL_HasMultiCharFold = NULL;
5b7de470 1210#ifdef USE_LOCALE_CTYPE
780fcc9f 1211 PL_warn_locale = NULL;
5b7de470 1212#endif
9fa9f06b
KW
1213 PL_Latin1 = NULL;
1214 PL_NonL1NonFinalFold = NULL;
1215 PL_UpperLatin1 = NULL;
86f72d56 1216 for (i = 0; i < POSIX_CC_COUNT; i++) {
cac6e0ca
KW
1217 SvREFCNT_dec(PL_XPosix_ptrs[i]);
1218 PL_XPosix_ptrs[i] = NULL;
86f72d56 1219 }
64935bc6 1220 PL_GCB_invlist = NULL;
6b659339 1221 PL_LB_invlist = NULL;
06ae2722 1222 PL_SB_invlist = NULL;
034602eb 1223 PL_SCX_invlist = NULL;
ae3bb8ea 1224 PL_WB_invlist = NULL;
9e7ded3f 1225 PL_Assigned_invlist = NULL;
5c831c24 1226
971a9dd3 1227 if (!specialWARN(PL_compiling.cop_warnings))
72dc9ed5 1228 PerlMemShared_free(PL_compiling.cop_warnings);
a0714e2c 1229 PL_compiling.cop_warnings = NULL;
20439bc7
Z
1230 cophh_free(CopHINTHASH_get(&PL_compiling));
1231 CopHINTHASH_set(&PL_compiling, cophh_new_empty());
05ec9bb3 1232 CopFILE_free(&PL_compiling);
5c831c24 1233
a0d0e21e 1234 /* Prepare to destruct main symbol table. */
5f05dabc 1235
3280af22 1236 hv = PL_defstash;
ca556bcd 1237 /* break ref loop *:: <=> %:: */
854da30f 1238 (void)hv_deletes(hv, "main::", G_DISCARD);
3280af22 1239 PL_defstash = 0;
a0d0e21e 1240 SvREFCNT_dec(hv);
5c831c24 1241 SvREFCNT_dec(PL_curstname);
a0714e2c 1242 PL_curstname = NULL;
a0d0e21e 1243
5a844595
GS
1244 /* clear queued errors */
1245 SvREFCNT_dec(PL_errors);
a0714e2c 1246 PL_errors = NULL;
5a844595 1247
dd69841b
BB
1248 SvREFCNT_dec(PL_isarev);
1249
a0d0e21e 1250 FREETMPS;
9b387841 1251 if (destruct_level >= 2) {
3280af22 1252 if (PL_scopestack_ix != 0)
9b387841
NC
1253 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
1254 "Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
1255 (long)PL_scopestack_ix);
3280af22 1256 if (PL_savestack_ix != 0)
9b387841
NC
1257 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
1258 "Unbalanced saves: %ld more saves than restores\n",
1259 (long)PL_savestack_ix);
3280af22 1260 if (PL_tmps_floor != -1)
9b387841
NC
1261 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),"Unbalanced tmps: %ld more allocs than frees\n",
1262 (long)PL_tmps_floor + 1);
a0d0e21e 1263 if (cxstack_ix != -1)
9b387841
NC
1264 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),"Unbalanced context: %ld more PUSHes than POPs\n",
1265 (long)cxstack_ix + 1);
a0d0e21e 1266 }
8990e307 1267
0547a729
DM
1268#ifdef USE_ITHREADS
1269 SvREFCNT_dec(PL_regex_padav);
1270 PL_regex_padav = NULL;
1271 PL_regex_pad = NULL;
1272#endif
1273
776df701 1274#ifdef PERL_IMPLICIT_CONTEXT
57bb2458
JH
1275 /* the entries in this list are allocated via SV PVX's, so get freed
1276 * in sv_clean_all */
1277 Safefree(PL_my_cxt_list);
776df701 1278#endif
57bb2458 1279
8990e307 1280 /* Now absolutely destruct everything, somehow or other, loops or no. */
5226ed68
JH
1281
1282 /* the 2 is for PL_fdpid and PL_strtab */
d17ea597 1283 while (sv_clean_all() > 2)
5226ed68
JH
1284 ;
1285
23083432
FC
1286#ifdef USE_ITHREADS
1287 Safefree(PL_stashpad); /* must come after sv_clean_all */
1288#endif
1289
d4777f27
GS
1290 AvREAL_off(PL_fdpid); /* no surviving entries */
1291 SvREFCNT_dec(PL_fdpid); /* needed in io_close() */
7d49f689 1292 PL_fdpid = NULL;
d33b2eba 1293
6c644e78
GS
1294#ifdef HAVE_INTERP_INTERN
1295 sys_intern_clear();
1296#endif
1297
a38ab475
RZ
1298 /* constant strings */
1299 for (i = 0; i < SV_CONSTS_COUNT; i++) {
1300 SvREFCNT_dec(PL_sv_consts[i]);
1301 PL_sv_consts[i] = NULL;
1302 }
1303
6e72f9df
PP
1304 /* Destruct the global string table. */
1305 {
1306 /* Yell and reset the HeVAL() slots that are still holding refcounts,
1307 * so that sv_free() won't fail on them.
80459961
NC
1308 * Now that the global string table is using a single hunk of memory
1309 * for both HE and HEK, we either need to explicitly unshare it the
1310 * correct way, or actually free things here.
6e72f9df 1311 */
80459961
NC
1312 I32 riter = 0;
1313 const I32 max = HvMAX(PL_strtab);
c4420975 1314 HE * const * const array = HvARRAY(PL_strtab);
80459961
NC
1315 HE *hent = array[0];
1316
6e72f9df 1317 for (;;) {
0453d815 1318 if (hent && ckWARN_d(WARN_INTERNAL)) {
44f8325f 1319 HE * const next = HeNEXT(hent);
9014280d 1320 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
44f8325f 1321 "Unbalanced string table refcount: (%ld) for \"%s\"",
de616631 1322 (long)hent->he_valu.hent_refcount, HeKEY(hent));
80459961
NC
1323 Safefree(hent);
1324 hent = next;
6e72f9df
PP
1325 }
1326 if (!hent) {
1327 if (++riter > max)
1328 break;
1329 hent = array[riter];
1330 }
1331 }
80459961
NC
1332
1333 Safefree(array);
1334 HvARRAY(PL_strtab) = 0;
1335 HvTOTALKEYS(PL_strtab) = 0;
6e72f9df 1336 }
3280af22 1337 SvREFCNT_dec(PL_strtab);
6e72f9df 1338
e652bb2f 1339#ifdef USE_ITHREADS
c21d1a0f 1340 /* free the pointer tables used for cloning */
a0739874 1341 ptr_table_free(PL_ptr_table);
bf9cdc68 1342 PL_ptr_table = (PTR_TBL_t*)NULL;
53186e96 1343#endif
a0739874 1344
d33b2eba
GS
1345 /* free special SVs */
1346
1347 SvREFCNT(&PL_sv_yes) = 0;
1348 sv_clear(&PL_sv_yes);
1349 SvANY(&PL_sv_yes) = NULL;
4c5e2b0d 1350 SvFLAGS(&PL_sv_yes) = 0;
d33b2eba
GS
1351
1352 SvREFCNT(&PL_sv_no) = 0;
1353 sv_clear(&PL_sv_no);
1354 SvANY(&PL_sv_no) = NULL;
4c5e2b0d 1355 SvFLAGS(&PL_sv_no) = 0;
01724ea0 1356
5a6c2837
DM
1357 SvREFCNT(&PL_sv_zero) = 0;
1358 sv_clear(&PL_sv_zero);
1359 SvANY(&PL_sv_zero) = NULL;
1360 SvFLAGS(&PL_sv_zero) = 0;
1361
9f375a43
DM
1362 {
1363 int i;
1364 for (i=0; i<=2; i++) {
1365 SvREFCNT(PERL_DEBUG_PAD(i)) = 0;
1366 sv_clear(PERL_DEBUG_PAD(i));
1367 SvANY(PERL_DEBUG_PAD(i)) = NULL;
1368 SvFLAGS(PERL_DEBUG_PAD(i)) = 0;
1369 }
1370 }
1371
0453d815 1372 if (PL_sv_count != 0 && ckWARN_d(WARN_INTERNAL))
9014280d 1373 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Scalars leaked: %ld\n", (long)PL_sv_count);
6e72f9df 1374
eba0f806
DM
1375#ifdef DEBUG_LEAKING_SCALARS
1376 if (PL_sv_count != 0) {
1377 SV* sva;
1378 SV* sv;
eb578fdb 1379 SV* svend;
eba0f806 1380
ad64d0ec 1381 for (sva = PL_sv_arenaroot; sva; sva = MUTABLE_SV(SvANY(sva))) {
eba0f806
DM
1382 svend = &sva[SvREFCNT(sva)];
1383 for (sv = sva + 1; sv < svend; ++sv) {
e4787c0c 1384 if (SvTYPE(sv) != (svtype)SVTYPEMASK) {
a548cda8 1385 PerlIO_printf(Perl_debug_log, "leaked: sv=0x%p"
61b61456 1386 " flags=0x%"UVxf
fd0854ff 1387 " refcnt=%"UVuf pTHX__FORMAT "\n"
147e3846
KW
1388 "\tallocated at %s:%d %s %s (parent 0x%" UVxf ");"
1389 "serial %" UVuf "\n",
574b8821
NC
1390 (void*)sv, (UV)sv->sv_flags, (UV)sv->sv_refcnt
1391 pTHX__VALUE,
fd0854ff
DM
1392 sv->sv_debug_file ? sv->sv_debug_file : "(unknown)",
1393 sv->sv_debug_line,
1394 sv->sv_debug_inpad ? "for" : "by",
1395 sv->sv_debug_optype ?
1396 PL_op_name[sv->sv_debug_optype]: "(none)",
cd676548 1397 PTR2UV(sv->sv_debug_parent),
cbe56f1d 1398 sv->sv_debug_serial
fd0854ff 1399 );
2aa47728 1400#ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
41e4abd8 1401 Perl_dump_sv_child(aTHX_ sv);
2aa47728 1402#endif
eba0f806
DM
1403 }
1404 }
1405 }
1406 }
2aa47728
NC
1407#ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
1408 {
1409 int status;
1410 fd_set rset;
1411 /* Wait for up to 4 seconds for child to terminate.
1412 This seems to be the least effort way of timing out on reaping
1413 its exit status. */
1414 struct timeval waitfor = {4, 0};
41e4abd8 1415 int sock = PL_dumper_fd;
2aa47728
NC
1416
1417 shutdown(sock, 1);
1418 FD_ZERO(&rset);
1419 FD_SET(sock, &rset);
1420 select(sock + 1, &rset, NULL, NULL, &waitfor);
1421 waitpid(child, &status, WNOHANG);
1422 close(sock);
1423 }
1424#endif
eba0f806 1425#endif
77abb4c6
NC
1426#ifdef DEBUG_LEAKING_SCALARS_ABORT
1427 if (PL_sv_count)
1428 abort();
1429#endif
bf9cdc68 1430 PL_sv_count = 0;
eba0f806 1431
56a2bab7 1432#if defined(PERLIO_LAYERS)
3a1ee7e8
NIS
1433 /* No more IO - including error messages ! */
1434 PerlIO_cleanup(aTHX);
1435#endif
1436
9f4bd222 1437 /* sv_undef needs to stay immortal until after PerlIO_cleanup
a0714e2c 1438 as currently layers use it rather than NULL as a marker
9f4bd222
NIS
1439 for no arg - and will try and SvREFCNT_dec it.
1440 */
1441 SvREFCNT(&PL_sv_undef) = 0;
1442 SvREADONLY_off(&PL_sv_undef);
1443
3280af22 1444 Safefree(PL_origfilename);
bd61b366 1445 PL_origfilename = NULL;
43c5f42d 1446 Safefree(PL_reg_curpm);
dd28f7bb 1447 free_tied_hv_pool();
3280af22 1448 Safefree(PL_op_mask);
cf36064f 1449 Safefree(PL_psig_name);
bf9cdc68 1450 PL_psig_name = (SV**)NULL;
d525a7b2 1451 PL_psig_ptr = (SV**)NULL;
31c91b43
LR
1452 {
1453 /* We need to NULL PL_psig_pend first, so that
1454 signal handlers know not to use it */
1455 int *psig_save = PL_psig_pend;
1456 PL_psig_pend = (int*)NULL;
1457 Safefree(psig_save);
1458 }
6e72f9df 1459 nuke_stacks();
284167a5
SM
1460 TAINTING_set(FALSE);
1461 TAINT_WARN_set(FALSE);
3280af22 1462 PL_hints = 0; /* Reset hints. Should hints be per-interpreter ? */
ac27b0f5 1463
a0d0e21e 1464 DEBUG_P(debprofdump());
d33b2eba 1465
b173165c
FC
1466 PL_debug = 0;
1467
e5dd39fc 1468#ifdef USE_REENTRANT_API
10bc17b6 1469 Perl_reentrant_free(aTHX);
e5dd39fc
AB
1470#endif
1471
a24da70b
NC
1472 /* These all point to HVs that are about to be blown away.
1473 Code in core and on CPAN assumes that if the interpreter is re-started
1474 that they will be cleanly NULL or pointing to a valid HV. */
1475 PL_custom_op_names = NULL;
1476 PL_custom_op_descs = NULL;
1477 PL_custom_ops = NULL;
1478
612f20c3
GS
1479 sv_free_arenas();
1480
5d9a96ca
DM
1481 while (PL_regmatch_slab) {
1482 regmatch_slab *s = PL_regmatch_slab;
1483 PL_regmatch_slab = PL_regmatch_slab->next;
1484 Safefree(s);
1485 }
1486
fc36a67e
PP
1487 /* As the absolutely last thing, free the non-arena SV for mess() */
1488
3280af22 1489 if (PL_mess_sv) {
f350b448
NC
1490 /* we know that type == SVt_PVMG */
1491
9c63abab 1492 /* it could have accumulated taint magic */
f350b448
NC
1493 MAGIC* mg;
1494 MAGIC* moremagic;
1495 for (mg = SvMAGIC(PL_mess_sv); mg; mg = moremagic) {
1496 moremagic = mg->mg_moremagic;
1497 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global
1498 && mg->mg_len >= 0)
1499 Safefree(mg->mg_ptr);
1500 Safefree(mg);
9c63abab 1501 }
f350b448 1502
fc36a67e 1503 /* we know that type >= SVt_PV */
8bd4d4c5 1504 SvPV_free(PL_mess_sv);
3280af22
NIS
1505 Safefree(SvANY(PL_mess_sv));
1506 Safefree(PL_mess_sv);
a0714e2c 1507 PL_mess_sv = NULL;
fc36a67e 1508 }
37038d91 1509 return STATUS_EXIT;
79072805
LW
1510}
1511
954c1994
GS
1512/*
1513=for apidoc perl_free
1514
1515Releases a Perl interpreter. See L<perlembed>.
1516
1517=cut
1518*/
1519
79072805 1520void
0cb96387 1521perl_free(pTHXx)
79072805 1522{
5174512c
NC
1523 dVAR;
1524
7918f24d
NC
1525 PERL_ARGS_ASSERT_PERL_FREE;
1526
c301d606
DM
1527 if (PL_veto_cleanup)
1528 return;
1529
7cb608b5 1530#ifdef PERL_TRACK_MEMPOOL
55ef9aae
MHM
1531 {
1532 /*
1533 * Don't free thread memory if PERL_DESTRUCT_LEVEL is set to a non-zero
1534 * value as we're probably hunting memory leaks then
1535 */
36e77d41 1536 if (PL_perl_destruct_level == 0) {
4fd0a9b8 1537 const U32 old_debug = PL_debug;
55ef9aae
MHM
1538 /* Emulate the PerlHost behaviour of free()ing all memory allocated in this
1539 thread at thread exit. */
4fd0a9b8
NC
1540 if (DEBUG_m_TEST) {
1541 PerlIO_puts(Perl_debug_log, "Disabling memory debugging as we "
1542 "free this thread's memory\n");
1543 PL_debug &= ~ DEBUG_m_FLAG;
1544 }
6edcbed6
DD
1545 while(aTHXx->Imemory_debug_header.next != &(aTHXx->Imemory_debug_header)){
1546 char * next = (char *)(aTHXx->Imemory_debug_header.next);
1547 Malloc_t ptr = PERL_MEMORY_DEBUG_HEADER_SIZE + next;
1548 safesysfree(ptr);
1549 }
4fd0a9b8 1550 PL_debug = old_debug;
55ef9aae
MHM
1551 }
1552 }
7cb608b5
NC
1553#endif
1554
acfe0abc 1555#if defined(WIN32) || defined(NETWARE)
ce3e5b80 1556# if defined(PERL_IMPLICIT_SYS)
b36c9a52 1557 {
acfe0abc 1558# ifdef NETWARE
7af12a34 1559 void *host = nw_internal_host;
7af12a34 1560 PerlMem_free(aTHXx);
7af12a34 1561 nw_delete_internal_host(host);
acfe0abc 1562# else
bdb50480
NC
1563 void *host = w32_internal_host;
1564 PerlMem_free(aTHXx);
7af12a34 1565 win32_delete_internal_host(host);
acfe0abc 1566# endif
7af12a34 1567 }
1c0ca838
GS
1568# else
1569 PerlMem_free(aTHXx);
1570# endif
acfe0abc
GS
1571#else
1572 PerlMem_free(aTHXx);
76e3520e 1573#endif
79072805
LW
1574}
1575
b7f7fff6 1576#if defined(USE_ITHREADS)
aebd1ac7
GA
1577/* provide destructors to clean up the thread key when libperl is unloaded */
1578#ifndef WIN32 /* handled during DLL_PROCESS_DETACH in win32/perllib.c */
1579
826955bd 1580#if defined(__hpux) && !(defined(__ux_version) && __ux_version <= 1020) && !defined(__GNUC__)
aebd1ac7 1581#pragma fini "perl_fini"
666ad1ec
GA
1582#elif defined(__sun) && !defined(__GNUC__)
1583#pragma fini (perl_fini)
aebd1ac7
GA
1584#endif
1585
0dbb1585
AL
1586static void
1587#if defined(__GNUC__)
1588__attribute__((destructor))
aebd1ac7 1589#endif
de009b76 1590perl_fini(void)
aebd1ac7 1591{
27da23d5 1592 dVAR;
5c64bffd
NC
1593 if (
1594#ifdef PERL_GLOBAL_STRUCT_PRIVATE
1595 my_vars &&
1596#endif
1597 PL_curinterp && !PL_veto_cleanup)
aebd1ac7
GA
1598 FREE_THREAD_KEY;
1599}
1600
1601#endif /* WIN32 */
1602#endif /* THREADS */
1603
4b556e6c 1604void
864dbfa3 1605Perl_call_atexit(pTHX_ ATEXIT_t fn, void *ptr)
4b556e6c 1606{
3280af22
NIS
1607 Renew(PL_exitlist, PL_exitlistlen+1, PerlExitListEntry);
1608 PL_exitlist[PL_exitlistlen].fn = fn;
1609 PL_exitlist[PL_exitlistlen].ptr = ptr;
1610 ++PL_exitlistlen;
4b556e6c
JD
1611}
1612
954c1994 1613/*
0301e899
Z
1614=for apidoc Am|int|perl_parse|PerlInterpreter *my_perl|XSINIT_t xsinit|int argc|char **argv|char **env
1615
1616Tells a Perl interpreter to parse a Perl script. This performs most
1617of the initialisation of a Perl interpreter. See L<perlembed> for
1618a tutorial.
1619
1620C<my_perl> points to the Perl interpreter that is to parse the script.
1621It must have been previously created through the use of L</perl_alloc>
1622and L</perl_construct>. C<xsinit> points to a callback function that
1623will be called to set up the ability for this Perl interpreter to load
1624XS extensions, or may be null to perform no such setup.
1625
1626C<argc> and C<argv> supply a set of command-line arguments to the Perl
1627interpreter, as would normally be passed to the C<main> function of
1628a C program. C<argv[argc]> must be null. These arguments are where
1629the script to parse is specified, either by naming a script file or by
1630providing a script in a C<-e> option.
a3e261d5
Z
1631If L<C<$0>|perlvar/$0> will be written to in the Perl interpreter, then
1632the argument strings must be in writable memory, and so mustn't just be
1633string constants.
0301e899
Z
1634
1635C<env> specifies a set of environment variables that will be used by
1636this Perl interpreter. If non-null, it must point to a null-terminated
1637array of environment strings. If null, the Perl interpreter will use
1638the environment supplied by the C<environ> global variable.
1639
1640This function initialises the interpreter, and parses and compiles the
1641script specified by the command-line arguments. This includes executing
1642code in C<BEGIN>, C<UNITCHECK>, and C<CHECK> blocks. It does not execute
1643C<INIT> blocks or the main program.
1644
1645Returns an integer of slightly tricky interpretation. The correct
1646use of the return value is as a truth value indicating whether there
1647was a failure in initialisation. If zero is returned, this indicates
1648that initialisation was successful, and it is safe to proceed to call
1649L</perl_run> and make other use of it. If a non-zero value is returned,
1650this indicates some problem that means the interpreter wants to terminate.
1651The interpreter should not be just abandoned upon such failure; the caller
1652should proceed to shut the interpreter down cleanly with L</perl_destruct>
1653and free it with L</perl_free>.
1654
1655For historical reasons, the non-zero return value also attempts to
1656be a suitable value to pass to the C library function C<exit> (or to
1657return from C<main>), to serve as an exit code indicating the nature
1658of the way initialisation terminated. However, this isn't portable,
857320cb
Z
1659due to differing exit code conventions. A historical bug is preserved
1660for the time being: if the Perl built-in C<exit> is called during this
1661function's execution, with a type of exit entailing a zero exit code
1662under the host operating system's conventions, then this function
1663returns zero rather than a non-zero value. This bug, [perl #2754],
1664leads to C<perl_run> being called (and therefore C<INIT> blocks and the
1665main program running) despite a call to C<exit>. It has been preserved
1666because a popular module-installing module has come to rely on it and
1667needs time to be fixed. This issue is [perl #132577], and the original
1668bug is due to be fixed in Perl 5.30.
0301e899 1669
954c1994
GS
1670=cut
1671*/
1672
03d9f026
FC
1673#define SET_CURSTASH(newstash) \
1674 if (PL_curstash != newstash) { \
1675 SvREFCNT_dec(PL_curstash); \
1676 PL_curstash = (HV *)SvREFCNT_inc(newstash); \
1677 }
1678
79072805 1679int
0cb96387 1680perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env)
8d063cd8 1681{
27da23d5 1682 dVAR;
6224f72b 1683 I32 oldscope;
6224f72b 1684 int ret;
db36c5a1 1685 dJMPENV;
8d063cd8 1686
7918f24d
NC
1687 PERL_ARGS_ASSERT_PERL_PARSE;
1688#ifndef MULTIPLICITY
ed6c66dd 1689 PERL_UNUSED_ARG(my_perl);
7918f24d 1690#endif
1a237f4f 1691#if (defined(USE_HASH_SEED) || defined(USE_HASH_SEED_DEBUG)) && !defined(NO_PERL_HASH_SEED_DEBUG)
b0891165 1692 {
7dc86639
YO
1693 const char * const s = PerlEnv_getenv("PERL_HASH_SEED_DEBUG");
1694
22ff3130 1695 if (s && strEQ(s, "1")) {
25c1b134
TC
1696 const unsigned char *seed= PERL_HASH_SEED;
1697 const unsigned char *seed_end= PERL_HASH_SEED + PERL_HASH_SEED_BYTES;
7dc86639
YO
1698 PerlIO_printf(Perl_debug_log, "HASH_FUNCTION = %s HASH_SEED = 0x", PERL_HASH_FUNC);
1699 while (seed < seed_end) {
1700 PerlIO_printf(Perl_debug_log, "%02x", *seed++);
1701 }
6a5b4183
YO
1702#ifdef PERL_HASH_RANDOMIZE_KEYS
1703 PerlIO_printf(Perl_debug_log, " PERTURB_KEYS = %d (%s)",
1704 PL_HASH_RAND_BITS_ENABLED,
1705 PL_HASH_RAND_BITS_ENABLED == 0 ? "NO" : PL_HASH_RAND_BITS_ENABLED == 1 ? "RANDOM" : "DETERMINISTIC");
1706#endif
7dc86639
YO
1707 PerlIO_printf(Perl_debug_log, "\n");
1708 }
b0891165 1709 }
1a237f4f 1710#endif /* #if (defined(USE_HASH_SEED) ... */
43238333 1711
ea34f6bd 1712#ifdef __amigaos4__
43238333
AB
1713 {
1714 struct NameTranslationInfo nti;
1715 __translate_amiga_to_unix_path_name(&argv[0],&nti);
1716 }
1717#endif
1718
cc85e83f
Z
1719 {
1720 int i;
1721 assert(argc >= 0);
1722 for(i = 0; i != argc; i++)
1723 assert(argv[i]);
1724 assert(!argv[argc]);
1725 }
3280af22 1726 PL_origargc = argc;
e2975953 1727 PL_origargv = argv;
a0d0e21e 1728
a2722ac9
GA
1729 if (PL_origalen != 0) {
1730 PL_origalen = 1; /* don't use old PL_origalen if perl_parse() is called again */
1731 }
1732 else {
3cb9023d
JH
1733 /* Set PL_origalen be the sum of the contiguous argv[]
1734 * elements plus the size of the env in case that it is
e9137a8e 1735 * contiguous with the argv[]. This is used in mg.c:Perl_magic_set()
3cb9023d
JH
1736 * as the maximum modifiable length of $0. In the worst case
1737 * the area we are able to modify is limited to the size of
43c32782 1738 * the original argv[0]. (See below for 'contiguous', though.)
3cb9023d 1739 * --jhi */
e1ec3a88 1740 const char *s = NULL;
b7249aaf 1741 const UV mask = ~(UV)(PTRSIZE-1);
43c32782 1742 /* Do the mask check only if the args seem like aligned. */
1b6737cc 1743 const UV aligned =
43c32782
JH
1744 (mask < ~(UV)0) && ((PTR2UV(argv[0]) & mask) == PTR2UV(argv[0]));
1745
1746 /* See if all the arguments are contiguous in memory. Note
1747 * that 'contiguous' is a loose term because some platforms
1748 * align the argv[] and the envp[]. If the arguments look
1749 * like non-aligned, assume that they are 'strictly' or
1750 * 'traditionally' contiguous. If the arguments look like
1751 * aligned, we just check that they are within aligned
1752 * PTRSIZE bytes. As long as no system has something bizarre
1753 * like the argv[] interleaved with some other data, we are
1754 * fine. (Did I just evoke Murphy's Law?) --jhi */
c8941eeb 1755 if (PL_origargv && PL_origargc >= 1 && (s = PL_origargv[0])) {
19742f39 1756 int i;
c8941eeb
JH
1757 while (*s) s++;
1758 for (i = 1; i < PL_origargc; i++) {
1759 if ((PL_origargv[i] == s + 1
43c32782 1760#ifdef OS2
c8941eeb 1761 || PL_origargv[i] == s + 2
43c32782 1762#endif
c8941eeb
JH
1763 )
1764 ||
1765 (aligned &&
1766 (PL_origargv[i] > s &&
1767 PL_origargv[i] <=
1768 INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask)))
1769 )
1770 {
1771 s = PL_origargv[i];
1772 while (*s) s++;
1773 }
1774 else
1775 break;
54bfe034 1776 }
54bfe034 1777 }
a4a109c2
JD
1778
1779#ifndef PERL_USE_SAFE_PUTENV
3cb9023d 1780 /* Can we grab env area too to be used as the area for $0? */
a4a109c2 1781 if (s && PL_origenviron && !PL_use_safe_putenv) {
9d419b5f 1782 if ((PL_origenviron[0] == s + 1)
43c32782
JH
1783 ||
1784 (aligned &&
1785 (PL_origenviron[0] > s &&
1786 PL_origenviron[0] <=
1787 INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask)))
1788 )
1789 {
19742f39 1790 int i;
9d419b5f 1791#ifndef OS2 /* ENVIRON is read by the kernel too. */
43c32782
JH
1792 s = PL_origenviron[0];
1793 while (*s) s++;
1794#endif
bd61b366 1795 my_setenv("NoNe SuCh", NULL);
43c32782
JH
1796 /* Force copy of environment. */
1797 for (i = 1; PL_origenviron[i]; i++) {
1798 if (PL_origenviron[i] == s + 1
1799 ||
1800 (aligned &&
1801 (PL_origenviron[i] > s &&
1802 PL_origenviron[i] <=
1803 INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask)))
1804 )
1805 {
1806 s = PL_origenviron[i];
1807 while (*s) s++;
1808 }
1809 else
1810 break;
54bfe034 1811 }
43c32782 1812 }
54bfe034 1813 }
a4a109c2
JD
1814#endif /* !defined(PERL_USE_SAFE_PUTENV) */
1815
2d2af554 1816 PL_origalen = s ? s - PL_origargv[0] + 1 : 0;
54bfe034
JH
1817 }
1818
3280af22 1819 if (PL_do_undump) {
a0d0e21e
LW
1820
1821 /* Come here if running an undumped a.out. */
1822
3280af22
NIS
1823 PL_origfilename = savepv(argv[0]);
1824 PL_do_undump = FALSE;
a0d0e21e 1825 cxstack_ix = -1; /* start label stack again */
748a9306 1826 init_ids();
284167a5 1827 assert (!TAINT_get);
b7975bdd 1828 TAINT;
e2051532 1829 set_caret_X();
b7975bdd 1830 TAINT_NOT;
a0d0e21e
LW
1831 init_postdump_symbols(argc,argv,env);
1832 return 0;
1833 }
1834
3280af22 1835 if (PL_main_root) {
3280af22 1836 op_free(PL_main_root);
5f66b61c 1837 PL_main_root = NULL;
ff0cee69 1838 }
5f66b61c 1839 PL_main_start = NULL;
3280af22 1840 SvREFCNT_dec(PL_main_cv);
601f1833 1841 PL_main_cv = NULL;
79072805 1842
3280af22
NIS
1843 time(&PL_basetime);
1844 oldscope = PL_scopestack_ix;
599cee73 1845 PL_dowarn = G_WARN_OFF;
f86702cc 1846
14dd3ad8 1847 JMPENV_PUSH(ret);
6224f72b 1848 switch (ret) {
312caa8e 1849 case 0:
14dd3ad8 1850 parse_body(env,xsinit);
9ebf26ad 1851 if (PL_unitcheckav) {
3c10abe3 1852 call_list(oldscope, PL_unitcheckav);
9ebf26ad
FR
1853 }
1854 if (PL_checkav) {
ca7b837b 1855 PERL_SET_PHASE(PERL_PHASE_CHECK);
7d30b5c4 1856 call_list(oldscope, PL_checkav);
9ebf26ad 1857 }
14dd3ad8
GS
1858 ret = 0;
1859 break;
6224f72b
GS
1860 case 1:
1861 STATUS_ALL_FAILURE;
924ba076 1862 /* FALLTHROUGH */
6224f72b
GS
1863 case 2:
1864 /* my_exit() was called */
3280af22 1865 while (PL_scopestack_ix > oldscope)
6224f72b
GS
1866 LEAVE;
1867 FREETMPS;
03d9f026 1868 SET_CURSTASH(PL_defstash);
9ebf26ad 1869 if (PL_unitcheckav) {
3c10abe3 1870 call_list(oldscope, PL_unitcheckav);
9ebf26ad
FR
1871 }
1872 if (PL_checkav) {
ca7b837b 1873 PERL_SET_PHASE(PERL_PHASE_CHECK);
7d30b5c4 1874 call_list(oldscope, PL_checkav);
9ebf26ad 1875 }
37038d91 1876 ret = STATUS_EXIT;
857320cb
Z
1877 if (ret == 0) {
1878 /*
1879 * At this point we should do
1880 * ret = 0x100;
1881 * to avoid [perl #2754], but that bugfix has been postponed
1882 * because of the Module::Install breakage it causes
1883 * [perl #132577].
1884 */
1885 }
14dd3ad8 1886 break;
6224f72b 1887 case 3:
bf49b057 1888 PerlIO_printf(Perl_error_log, "panic: top_env\n");
14dd3ad8
GS
1889 ret = 1;
1890 break;
6224f72b 1891 }
14dd3ad8
GS
1892 JMPENV_POP;
1893 return ret;
1894}
1895
4a5df386
NC
1896/* This needs to stay in perl.c, as perl.c is compiled with different flags for
1897 miniperl, and we need to see those flags reflected in the values here. */
1898
1899/* What this returns is subject to change. Use the public interface in Config.
1900 */
1901static void
1902S_Internals_V(pTHX_ CV *cv)
1903{
1904 dXSARGS;
1905#ifdef LOCAL_PATCH_COUNT
1906 const int local_patch_count = LOCAL_PATCH_COUNT;
1907#else
1908 const int local_patch_count = 0;
1909#endif
2dc296d2 1910 const int entries = 3 + local_patch_count;
4a5df386 1911 int i;
fe1c5936 1912 static const char non_bincompat_options[] =
4a5df386
NC
1913# ifdef DEBUGGING
1914 " DEBUGGING"
1915# endif
1916# ifdef NO_MATHOMS
0d311fbe 1917 " NO_MATHOMS"
4a5df386 1918# endif
59b86f4b
DM
1919# ifdef NO_HASH_SEED
1920 " NO_HASH_SEED"
1921# endif
3b0e4ee2
MB
1922# ifdef NO_TAINT_SUPPORT
1923 " NO_TAINT_SUPPORT"
1924# endif
cb26ef7a
MB
1925# ifdef PERL_BOOL_AS_CHAR
1926 " PERL_BOOL_AS_CHAR"
1927# endif
93c10d60
FC
1928# ifdef PERL_COPY_ON_WRITE
1929 " PERL_COPY_ON_WRITE"
1930# endif
4a5df386
NC
1931# ifdef PERL_DISABLE_PMC
1932 " PERL_DISABLE_PMC"
1933# endif
1934# ifdef PERL_DONT_CREATE_GVSV
1935 " PERL_DONT_CREATE_GVSV"
1936# endif
9a044a43
NC
1937# ifdef PERL_EXTERNAL_GLOB
1938 " PERL_EXTERNAL_GLOB"
1939# endif
59b86f4b
DM
1940# ifdef PERL_HASH_FUNC_SIPHASH
1941 " PERL_HASH_FUNC_SIPHASH"
1942# endif
1943# ifdef PERL_HASH_FUNC_SDBM
1944 " PERL_HASH_FUNC_SDBM"
1945# endif
1946# ifdef PERL_HASH_FUNC_DJB2
1947 " PERL_HASH_FUNC_DJB2"
1948# endif
1949# ifdef PERL_HASH_FUNC_SUPERFAST
1950 " PERL_HASH_FUNC_SUPERFAST"
1951# endif
1952# ifdef PERL_HASH_FUNC_MURMUR3
1953 " PERL_HASH_FUNC_MURMUR3"
1954# endif
1955# ifdef PERL_HASH_FUNC_ONE_AT_A_TIME
1956 " PERL_HASH_FUNC_ONE_AT_A_TIME"
1957# endif
1958# ifdef PERL_HASH_FUNC_ONE_AT_A_TIME_HARD
1959 " PERL_HASH_FUNC_ONE_AT_A_TIME_HARD"
1960# endif
1961# ifdef PERL_HASH_FUNC_ONE_AT_A_TIME_OLD
1962 " PERL_HASH_FUNC_ONE_AT_A_TIME_OLD"
1963# endif
4a5df386
NC
1964# ifdef PERL_IS_MINIPERL
1965 " PERL_IS_MINIPERL"
1966# endif
1967# ifdef PERL_MALLOC_WRAP
1968 " PERL_MALLOC_WRAP"
1969# endif
1970# ifdef PERL_MEM_LOG
1971 " PERL_MEM_LOG"
1972# endif
1973# ifdef PERL_MEM_LOG_NOIMPL
1974 " PERL_MEM_LOG_NOIMPL"
1975# endif
4e499636
DM
1976# ifdef PERL_OP_PARENT
1977 " PERL_OP_PARENT"
1978# endif
59b86f4b
DM
1979# ifdef PERL_PERTURB_KEYS_DETERMINISTIC
1980 " PERL_PERTURB_KEYS_DETERMINISTIC"
1981# endif
1982# ifdef PERL_PERTURB_KEYS_DISABLED
1983 " PERL_PERTURB_KEYS_DISABLED"
1984# endif
1985# ifdef PERL_PERTURB_KEYS_RANDOM
1986 " PERL_PERTURB_KEYS_RANDOM"
1987# endif
c3cf41ec
NC
1988# ifdef PERL_PRESERVE_IVUV
1989 " PERL_PRESERVE_IVUV"
1990# endif
c051e30b
NC
1991# ifdef PERL_RELOCATABLE_INCPUSH
1992 " PERL_RELOCATABLE_INCPUSH"
1993# endif
4a5df386
NC
1994# ifdef PERL_USE_DEVEL
1995 " PERL_USE_DEVEL"
1996# endif
1997# ifdef PERL_USE_SAFE_PUTENV
1998 " PERL_USE_SAFE_PUTENV"
1999# endif
102b7877
YO
2000# ifdef SILENT_NO_TAINT_SUPPORT
2001 " SILENT_NO_TAINT_SUPPORT"
2002# endif
a3749cf3
NC
2003# ifdef UNLINK_ALL_VERSIONS
2004 " UNLINK_ALL_VERSIONS"
2005# endif
de618ee4
NC
2006# ifdef USE_ATTRIBUTES_FOR_PERLIO
2007 " USE_ATTRIBUTES_FOR_PERLIO"
2008# endif
4a5df386
NC
2009# ifdef USE_FAST_STDIO
2010 " USE_FAST_STDIO"
2011# endif
98548bdf
NC
2012# ifdef USE_LOCALE
2013 " USE_LOCALE"
2014# endif
98548bdf
NC
2015# ifdef USE_LOCALE_CTYPE
2016 " USE_LOCALE_CTYPE"
2017# endif
6937817d
DD
2018# ifdef WIN32_NO_REGISTRY
2019 " USE_NO_REGISTRY"
2020# endif
5a8d8935
NC
2021# ifdef USE_PERL_ATOF
2022 " USE_PERL_ATOF"
2023# endif
0d311fbe
NC
2024# ifdef USE_SITECUSTOMIZE
2025 " USE_SITECUSTOMIZE"
2026# endif
4a5df386
NC
2027 ;
2028 PERL_UNUSED_ARG(cv);
d3db1514 2029 PERL_UNUSED_VAR(items);
4a5df386
NC
2030
2031 EXTEND(SP, entries);
2032
2033 PUSHs(sv_2mortal(newSVpv(PL_bincompat_options, 0)));
2034 PUSHs(Perl_newSVpvn_flags(aTHX_ non_bincompat_options,
2035 sizeof(non_bincompat_options) - 1, SVs_TEMP));
2036
6baa8dbd
NT
2037#ifndef PERL_BUILD_DATE
2038# ifdef __DATE__
2039# ifdef __TIME__
2040# define PERL_BUILD_DATE __DATE__ " " __TIME__
2041# else
2042# define PERL_BUILD_DATE __DATE__
2043# endif
2044# endif
2045#endif
2046
2047#ifdef PERL_BUILD_DATE
4a5df386 2048 PUSHs(Perl_newSVpvn_flags(aTHX_
6baa8dbd 2049 STR_WITH_LEN("Compiled at " PERL_BUILD_DATE),
4a5df386 2050 SVs_TEMP));
4a5df386
NC
2051#else
2052 PUSHs(&PL_sv_undef);
2053#endif
2054
4a5df386
NC
2055 for (i = 1; i <= local_patch_count; i++) {
2056 /* This will be an undef, if PL_localpatches[i] is NULL. */
2057 PUSHs(sv_2mortal(newSVpv(PL_localpatches[i], 0)));
2058 }
2059
2060 XSRETURN(entries);
2061}
2062
be71fc8f
NC
2063#define INCPUSH_UNSHIFT 0x01
2064#define INCPUSH_ADD_OLD_VERS 0x02
2065#define INCPUSH_ADD_VERSIONED_SUB_DIRS 0x04
2066#define INCPUSH_ADD_ARCHONLY_SUB_DIRS 0x08
2067#define INCPUSH_NOT_BASEDIR 0x10
2068#define INCPUSH_CAN_RELOCATE 0x20
1e3208d8
NC
2069#define INCPUSH_ADD_SUB_DIRS \
2070 (INCPUSH_ADD_VERSIONED_SUB_DIRS|INCPUSH_ADD_ARCHONLY_SUB_DIRS)
e28f3139 2071
312caa8e 2072STATIC void *
14dd3ad8 2073S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
312caa8e 2074{
27da23d5 2075 dVAR;
2f9285f8 2076 PerlIO *rsfp;
312caa8e 2077 int argc = PL_origargc;
8f42b153 2078 char **argv = PL_origargv;
e1ec3a88 2079 const char *scriptname = NULL;
402582ca 2080 bool dosearch = FALSE;
eb578fdb 2081 char c;
737c24fc 2082 bool doextract = FALSE;
bd61b366 2083 const char *cddir = NULL;
ab019eaa 2084#ifdef USE_SITECUSTOMIZE
20ef40cf 2085 bool minus_f = FALSE;
ab019eaa 2086#endif
95670bde 2087 SV *linestr_sv = NULL;
5486870f 2088 bool add_read_e_script = FALSE;
87606032 2089 U32 lex_start_flags = 0;
009d90df 2090
ca7b837b 2091 PERL_SET_PHASE(PERL_PHASE_START);
9ebf26ad 2092
6224f72b 2093 init_main_stash();
54310121 2094
c7030b81
NC
2095 {
2096 const char *s;
6224f72b
GS
2097 for (argc--,argv++; argc > 0; argc--,argv++) {
2098 if (argv[0][0] != '-' || !argv[0][1])
2099 break;
6224f72b
GS
2100 s = argv[0]+1;
2101 reswitch:
47f56822 2102 switch ((c = *s)) {
729a02f2 2103 case 'C':
1d5472a9
GS
2104#ifndef PERL_STRICT_CR
2105 case '\r':
2106#endif
6224f72b
GS
2107 case ' ':
2108 case '0':
2109 case 'F':
2110 case 'a':
2111 case 'c':
2112 case 'd':
2113 case 'D':
2114 case 'h':
2115 case 'i':
2116 case 'l':
2117 case 'M':
2118 case 'm':
2119 case 'n':
2120 case 'p':
2121 case 's':
2122 case 'u':
2123 case 'U':
2124 case 'v':
599cee73
PM
2125 case 'W':
2126 case 'X':
6224f72b 2127 case 'w':
97bd5664 2128 if ((s = moreswitches(s)))
6224f72b
GS
2129 goto reswitch;
2130 break;
33b78306 2131
1dbad523 2132 case 't':
dc6d7f5c 2133#if defined(SILENT_NO_TAINT_SUPPORT)
284167a5 2134 /* silently ignore */
dc6d7f5c 2135#elif defined(NO_TAINT_SUPPORT)
3231f579 2136 Perl_croak_nocontext("This perl was compiled without taint support. "
284167a5
SM
2137 "Cowardly refusing to run with -t or -T flags");
2138#else
22f7c9c9 2139 CHECK_MALLOC_TOO_LATE_FOR('t');
284167a5
SM
2140 if( !TAINTING_get ) {
2141 TAINT_WARN_set(TRUE);
2142 TAINTING_set(TRUE);
317ea90d 2143 }
284167a5 2144#endif
317ea90d
MS
2145 s++;
2146 goto reswitch;
6224f72b 2147 case 'T':
dc6d7f5c 2148#if defined(SILENT_NO_TAINT_SUPPORT)
284167a5 2149 /* silently ignore */
dc6d7f5c 2150#elif defined(NO_TAINT_SUPPORT)
3231f579 2151 Perl_croak_nocontext("This perl was compiled without taint support. "
284167a5
SM
2152 "Cowardly refusing to run with -t or -T flags");
2153#else
22f7c9c9 2154 CHECK_MALLOC_TOO_LATE_FOR('T');
284167a5
SM
2155 TAINTING_set(TRUE);
2156 TAINT_WARN_set(FALSE);
2157#endif
6224f72b
GS
2158 s++;
2159 goto reswitch;
f86702cc 2160
bc9b29db
RH
2161 case 'E':
2162 PL_minus_E = TRUE;
924ba076 2163 /* FALLTHROUGH */
6224f72b 2164 case 'e':
f20b2998 2165 forbid_setid('e', FALSE);
3280af22 2166 if (!PL_e_script) {
396482e1 2167 PL_e_script = newSVpvs("");
5486870f 2168 add_read_e_script = TRUE;
6224f72b
GS
2169 }
2170 if (*++s)
3280af22 2171 sv_catpv(PL_e_script, s);
6224f72b 2172 else if (argv[1]) {
3280af22 2173 sv_catpv(PL_e_script, argv[1]);
6224f72b
GS
2174 argc--,argv++;
2175 }
2176 else
47f56822 2177 Perl_croak(aTHX_ "No code specified for -%c", c);
396482e1 2178 sv_catpvs(PL_e_script, "\n");
6224f72b 2179 break;
afe37c7d 2180
20ef40cf 2181 case 'f':
f5542d3a 2182#ifdef USE_SITECUSTOMIZE
20ef40cf 2183 minus_f = TRUE;
f5542d3a 2184#endif
20ef40cf
GA
2185 s++;
2186 goto reswitch;
2187
6224f72b 2188 case 'I': /* -I handled both here and in moreswitches() */
f20b2998 2189 forbid_setid('I', FALSE);
bd61b366 2190 if (!*++s && (s=argv[1]) != NULL) {
6224f72b
GS
2191 argc--,argv++;
2192 }
6224f72b 2193 if (s && *s) {
0df16ed7 2194 STRLEN len = strlen(s);
55b4bc1c 2195 incpush(s, len, INCPUSH_ADD_SUB_DIRS|INCPUSH_ADD_OLD_VERS);
0df16ed7
GS
2196 }
2197 else
a67e862a 2198 Perl_croak(aTHX_ "No directory specified for -I");
6224f72b 2199 break;
6224f72b 2200 case 'S':
f20b2998 2201 forbid_setid('S', FALSE);
6224f72b
GS
2202 dosearch = TRUE;
2203 s++;
2204 goto reswitch;
2205 case 'V':
7edfd0ef
NC
2206 {
2207 SV *opts_prog;
2208
7edfd0ef 2209 if (*++s != ':') {
37ca4a5b 2210 opts_prog = newSVpvs("use Config; Config::_V()");
7edfd0ef
NC
2211 }
2212 else {
2213 ++s;
2214 opts_prog = Perl_newSVpvf(aTHX_
37ca4a5b 2215 "use Config; Config::config_vars(qw%c%s%c)",
7edfd0ef
NC
2216 0, s, 0);
2217 s += strlen(s);
2218 }
37ca4a5b 2219 Perl_av_create_and_push(aTHX_ &PL_preambleav, opts_prog);
7edfd0ef
NC
2220 /* don't look for script or read stdin */
2221 scriptname = BIT_BUCKET;
2222 goto reswitch;
6224f72b 2223 }
6224f72b 2224 case 'x':
737c24fc 2225 doextract = TRUE;
6224f72b 2226 s++;
304334da 2227 if (*s)
f4c556ac 2228 cddir = s;
6224f72b
GS
2229 break;
2230 case 0:
2231 break;
2232 case '-':
2233 if (!*++s || isSPACE(*s)) {
2234 argc--,argv++;
2235 goto switch_end;
2236 }
ee8bc8b7
NC
2237 /* catch use of gnu style long options.
2238 Both of these exit immediately. */
2239 if (strEQ(s, "version"))
2240 minus_v();
2241 if (strEQ(s, "help"))
2242 usage();
6224f72b 2243 s--;
924ba076 2244 /* FALLTHROUGH */
6224f72b 2245 default:
cea2e8a9 2246 Perl_croak(aTHX_ "Unrecognized switch: -%s (-h will show valid options)",s);
8d063cd8
LW
2247 }
2248 }
c7030b81
NC
2249 }
2250
6224f72b 2251 switch_end:
54310121 2252
c7030b81
NC
2253 {
2254 char *s;
2255
f675dbe5
CB
2256 if (
2257#ifndef SECURE_INTERNAL_GETENV
284167a5 2258 !TAINTING_get &&
f675dbe5 2259#endif
cf756827 2260 (s = PerlEnv_getenv("PERL5OPT")))
0df16ed7 2261 {
9e0b0d62
KW
2262 /* s points to static memory in getenv(), which may be overwritten at
2263 * any time; use a mortal copy instead */
2264 s = SvPVX(sv_2mortal(newSVpv(s, 0)));
2265
74288ac8
GS
2266 while (isSPACE(*s))
2267 s++;
317ea90d 2268 if (*s == '-' && *(s+1) == 'T') {
dc6d7f5c 2269#if defined(SILENT_NO_TAINT_SUPPORT)
284167a5 2270 /* silently ignore */
dc6d7f5c 2271#elif defined(NO_TAINT_SUPPORT)
3231f579 2272 Perl_croak_nocontext("This perl was compiled without taint support. "
284167a5
SM
2273 "Cowardly refusing to run with -t or -T flags");
2274#else
22f7c9c9 2275 CHECK_MALLOC_TOO_LATE_FOR('T');
284167a5
SM
2276 TAINTING_set(TRUE);
2277 TAINT_WARN_set(FALSE);
2278#endif
317ea90d 2279 }
74288ac8 2280 else {
bd61b366 2281 char *popt_copy = NULL;
74288ac8 2282 while (s && *s) {
54913509 2283 const char *d;
74288ac8
GS
2284 while (isSPACE(*s))
2285 s++;
2286 if (*s == '-') {
2287 s++;
2288 if (isSPACE(*s))
2289 continue;
2290 }
4ea8f8fb 2291 d = s;
74288ac8
GS
2292 if (!*s)
2293 break;
2b622f1a 2294 if (!strchr("CDIMUdmtwW", *s))
cea2e8a9 2295 Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s);
4ea8f8fb
MS
2296 while (++s && *s) {
2297 if (isSPACE(*s)) {
cf756827 2298 if (!popt_copy) {
bfa6c418
NC
2299 popt_copy = SvPVX(sv_2mortal(newSVpv(d,0)));
2300 s = popt_copy + (s - d);
2301 d = popt_copy;
cf756827 2302 }
4ea8f8fb
MS
2303 *s++ = '\0';
2304 break;
2305 }
2306 }
1c4db469 2307 if (*d == 't') {
dc6d7f5c 2308#if defined(SILENT_NO_TAINT_SUPPORT)
284167a5 2309 /* silently ignore */
dc6d7f5c 2310#elif defined(NO_TAINT_SUPPORT)
3231f579 2311 Perl_croak_nocontext("This perl was compiled without taint support. "
284167a5
SM
2312 "Cowardly refusing to run with -t or -T flags");
2313#else
2314 if( !TAINTING_get) {
2315 TAINT_WARN_set(TRUE);
2316 TAINTING_set(TRUE);
317ea90d 2317 }
284167a5 2318#endif
1c4db469 2319 } else {
97bd5664 2320 moreswitches(d);
1c4db469 2321 }
6224f72b 2322 }
6224f72b
GS
2323 }
2324 }
c7030b81 2325 }
a0d0e21e 2326
d6295071
TC
2327#ifndef NO_PERL_INTERNAL_RAND_SEED
2328 /* If we're not set[ug]id, we might have honored
2329 PERL_INTERNAL_RAND_SEED in perl_construct().
2330 At this point command-line options have been parsed, so if
2331 we're now tainting and not set[ug]id re-seed.
2332 This could possibly be wasteful if PERL_INTERNAL_RAND_SEED is invalid,
2333 but avoids duplicating the logic from perl_construct().
2334 */
2335 if (PL_tainting &&
2336 PerlProc_getuid() == PerlProc_geteuid() &&
2337 PerlProc_getgid() == PerlProc_getegid()) {
2338 Perl_drand48_init_r(&PL_internal_random_state, seed());
2339 }
2340#endif
2341
c29067d7
CH
2342 /* Set $^X early so that it can be used for relocatable paths in @INC */
2343 /* and for SITELIB_EXP in USE_SITECUSTOMIZE */
284167a5 2344 assert (!TAINT_get);
c29067d7 2345 TAINT;
e2051532 2346 set_caret_X();
c29067d7
CH
2347 TAINT_NOT;
2348
43c0c913 2349#if defined(USE_SITECUSTOMIZE)
20ef40cf 2350 if (!minus_f) {
43c0c913 2351 /* The games with local $! are to avoid setting errno if there is no
fc81b718
NC
2352 sitecustomize script. "q%c...%c", 0, ..., 0 becomes "q\0...\0",
2353 ie a q() operator with a NUL byte as a the delimiter. This avoids
2354 problems with pathnames containing (say) ' */
43c0c913
NC
2355# ifdef PERL_IS_MINIPERL
2356 AV *const inc = GvAV(PL_incgv);
2357 SV **const inc0 = inc ? av_fetch(inc, 0, FALSE) : NULL;
2358
2359 if (inc0) {
15870c5c
NC
2360 /* if lib/buildcustomize.pl exists, it should not fail. If it does,
2361 it should be reported immediately as a build failure. */
43c0c913
NC
2362 (void)Perl_av_create_and_unshift_one(aTHX_ &PL_preambleav,
2363 Perl_newSVpvf(aTHX_
147e3846 2364 "BEGIN { my $f = q%c%s%" SVf "/buildcustomize.pl%c; "
af26e4f2
FC
2365 "do {local $!; -f $f }"
2366 " and do $f || die $@ || qq '$f: $!' }",
5de87db5 2367 0, (TAINTING_get ? "./" : ""), SVfARG(*inc0), 0));
43c0c913
NC
2368 }
2369# else
2370 /* SITELIB_EXP is a function call on Win32. */
c29067d7 2371 const char *const raw_sitelib = SITELIB_EXP;
bac5c4fc
JD
2372 if (raw_sitelib) {
2373 /* process .../.. if PERL_RELOCATABLE_INC is defined */
2374 SV *sitelib_sv = mayberelocate(raw_sitelib, strlen(raw_sitelib),
2375 INCPUSH_CAN_RELOCATE);
2376 const char *const sitelib = SvPVX(sitelib_sv);
2377 (void)Perl_av_create_and_unshift_one(aTHX_ &PL_preambleav,
2378 Perl_newSVpvf(aTHX_
2379 "BEGIN { do {local $!; -f q%c%s/sitecustomize.pl%c} && do q%c%s/sitecustomize.pl%c }",
c1f6cd39
BF
2380 0, SVfARG(sitelib), 0,
2381 0, SVfARG(sitelib), 0));
bac5c4fc
JD
2382 assert (SvREFCNT(sitelib_sv) == 1);
2383 SvREFCNT_dec(sitelib_sv);
2384 }
43c0c913 2385# endif
20ef40cf
GA
2386 }
2387#endif
2388
6224f72b
GS
2389 if (!scriptname)
2390 scriptname = argv[0];
3280af22 2391 if (PL_e_script) {
6224f72b
GS
2392 argc++,argv--;
2393 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
2394 }
bd61b366 2395 else if (scriptname == NULL) {
6224f72b
GS
2396#ifdef MSDOS
2397 if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) )
97bd5664 2398 moreswitches("h");
6224f72b
GS
2399#endif
2400 scriptname = "-";
2401 }
2402
284167a5 2403 assert (!TAINT_get);
2cace6ac 2404 init_perllib();
6224f72b 2405
a52eba0e 2406 {
f20b2998 2407 bool suidscript = FALSE;
829372d3 2408
8d113837 2409 rsfp = open_script(scriptname, dosearch, &suidscript);
c0b3891a
NC
2410 if (!rsfp) {
2411 rsfp = PerlIO_stdin();
87606032 2412 lex_start_flags = LEX_DONT_CLOSE_RSFP;
c0b3891a 2413 }
6224f72b 2414
b24bc095 2415 validate_suid(rsfp);
6224f72b 2416
64ca3a65 2417#ifndef PERL_MICRO
a52eba0e
NC
2418# if defined(SIGCHLD) || defined(SIGCLD)
2419 {
2420# ifndef SIGCHLD
2421# define SIGCHLD SIGCLD
2422# endif
2423 Sighandler_t sigstate = rsignal_state(SIGCHLD);
2424 if (sigstate == (Sighandler_t) SIG_IGN) {
a2a5de95
NC
2425 Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL),
2426 "Can't ignore signal CHLD, forcing to default");
a52eba0e
NC
2427 (void)rsignal(SIGCHLD, (Sighandler_t)SIG_DFL);
2428 }
0b5b802d 2429 }
a52eba0e 2430# endif
64ca3a65 2431#endif
0b5b802d 2432
737c24fc 2433 if (doextract) {
faef540c 2434
f20b2998 2435 /* This will croak if suidscript is true, as -x cannot be used with
faef540c
NC
2436 setuid scripts. */
2437 forbid_setid('x', suidscript);
f20b2998 2438 /* Hence you can't get here if suidscript is true */
faef540c 2439
95670bde
NC
2440 linestr_sv = newSV_type(SVt_PV);
2441 lex_start_flags |= LEX_START_COPIED;
2f9285f8 2442 find_beginning(linestr_sv, rsfp);
a52eba0e
NC
2443 if (cddir && PerlDir_chdir( (char *)cddir ) < 0)
2444 Perl_croak(aTHX_ "Can't chdir to %s",cddir);
2445 }
f4c556ac 2446 }
6224f72b 2447
ea726b52 2448 PL_main_cv = PL_compcv = MUTABLE_CV(newSV_type(SVt_PVCV));
3280af22
NIS
2449 CvUNIQUE_on(PL_compcv);
2450
eacbb379 2451 CvPADLIST_set(PL_compcv, pad_new(0));
6224f72b 2452
dd69841b
BB
2453 PL_isarev = newHV();
2454
0c4f7ff0 2455 boot_core_PerlIO();
6224f72b 2456 boot_core_UNIVERSAL();
e1a479c5 2457 boot_core_mro();
4a5df386 2458 newXS("Internals::V", S_Internals_V, __FILE__);
6224f72b
GS
2459
2460 if (xsinit)
acfe0abc 2461 (*xsinit)(aTHX); /* in case linked C routines want magical variables */
64ca3a65 2462#ifndef PERL_MICRO
739a0b84 2463#if defined(VMS) || defined(WIN32) || defined(DJGPP) || defined(__CYGWIN__) || defined(SYMBIAN)
c5be433b 2464 init_os_extras();
6224f72b 2465#endif
64ca3a65 2466#endif
6224f72b 2467
29209bc5 2468#ifdef USE_SOCKS
1b9c9cf5
DH
2469# ifdef HAS_SOCKS5_INIT
2470 socks5_init(argv[0]);
2471# else
29209bc5 2472 SOCKSinit(argv[0]);
1b9c9cf5 2473# endif
ac27b0f5 2474#endif
29209bc5 2475
6224f72b
GS
2476 init_predump_symbols();
2477 /* init_postdump_symbols not currently designed to be called */
2478 /* more than once (ENV isn't cleared first, for example) */
2479 /* But running with -u leaves %ENV & @ARGV undefined! XXX */
3280af22 2480 if (!PL_do_undump)
6224f72b
GS
2481 init_postdump_symbols(argc,argv,env);
2482
27da23d5
JH
2483 /* PL_unicode is turned on by -C, or by $ENV{PERL_UNICODE},
2484 * or explicitly in some platforms.
73e1bd1a 2485 * PL_utf8locale is conditionally turned on by
085a54d9 2486 * locale.c:Perl_init_i18nl10n() if the environment
a05d7ebb 2487 * look like the user wants to use UTF-8. */
a0fd4948 2488#if defined(__SYMBIAN32__)
27da23d5
JH
2489 PL_unicode = PERL_UNICODE_STD_FLAG; /* See PERL_SYMBIAN_CONSOLE_UTF8. */
2490#endif
e27b5b51 2491# ifndef PERL_IS_MINIPERL
06e66572
JH
2492 if (PL_unicode) {
2493 /* Requires init_predump_symbols(). */
a05d7ebb 2494 if (!(PL_unicode & PERL_UNICODE_LOCALE_FLAG) || PL_utf8locale) {
06e66572
JH
2495 IO* io;
2496 PerlIO* fp;
2497 SV* sv;
2498
a05d7ebb 2499 /* Turn on UTF-8-ness on STDIN, STDOUT, STDERR
06e66572 2500 * and the default open disciplines. */
a05d7ebb
JH
2501 if ((PL_unicode & PERL_UNICODE_STDIN_FLAG) &&
2502 PL_stdingv && (io = GvIO(PL_stdingv)) &&
2503 (fp = IoIFP(io)))
2504 PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
2505 if ((PL_unicode & PERL_UNICODE_STDOUT_FLAG) &&
2506 PL_defoutgv && (io = GvIO(PL_defoutgv)) &&
2507 (fp = IoOFP(io)))
2508 PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
2509 if ((PL_unicode & PERL_UNICODE_STDERR_FLAG) &&
2510 PL_stderrgv && (io = GvIO(PL_stderrgv)) &&
2511 (fp = IoOFP(io)))
2512 PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
2513 if ((PL_unicode & PERL_UNICODE_INOUT_FLAG) &&
fafc274c
NC
2514 (sv = GvSV(gv_fetchpvs("\017PEN", GV_ADD|GV_NOTQUAL,
2515 SVt_PV)))) {
a05d7ebb
JH
2516 U32 in = PL_unicode & PERL_UNICODE_IN_FLAG;
2517 U32 out = PL_unicode & PERL_UNICODE_OUT_FLAG;
2518 if (in) {
2519 if (out)
76f68e9b 2520 sv_setpvs(sv, ":utf8\0:utf8");
a05d7ebb 2521 else
76f68e9b 2522 sv_setpvs(sv, ":utf8\0");
a05d7ebb
JH
2523 }
2524 else if (out)
76f68e9b 2525 sv_setpvs(sv, "\0:utf8");
a05d7ebb
JH
2526 SvSETMAGIC(sv);
2527 }
b310b053
JH
2528 }
2529 }
e27b5b51 2530#endif
b310b053 2531
c7030b81
NC
2532 {
2533 const char *s;
4ffa73a3
JH
2534 if ((s = PerlEnv_getenv("PERL_SIGNALS"))) {
2535 if (strEQ(s, "unsafe"))
2536 PL_signals |= PERL_SIGNALS_UNSAFE_FLAG;
2537 else if (strEQ(s, "safe"))
2538 PL_signals &= ~PERL_SIGNALS_UNSAFE_FLAG;
2539 else
2540 Perl_croak(aTHX_ "PERL_SIGNALS illegal: \"%s\"", s);
2541 }
c7030b81 2542 }
4ffa73a3 2543
81d86705 2544
87606032 2545 lex_start(linestr_sv, rsfp, lex_start_flags);
d2687c98 2546 SvREFCNT_dec(linestr_sv);
95670bde 2547
219f7226 2548 PL_subname = newSVpvs("main");
6224f72b 2549
5486870f
DM
2550 if (add_read_e_script)
2551 filter_add(read_e_script, NULL);
2552
6224f72b
GS
2553 /* now parse the script */
2554
93189314 2555 SETERRNO(0,SS_NORMAL);
28ac2b49 2556 if (yyparse(GRAMPROG) || PL_parser->error_count) {
c77da5ff 2557 abort_execution("", PL_origfilename);
6224f72b 2558 }
57843af0 2559 CopLINE_set(PL_curcop, 0);
03d9f026 2560 SET_CURSTASH(PL_defstash);
3280af22
NIS
2561 if (PL_e_script) {
2562 SvREFCNT_dec(PL_e_script);
a0714e2c 2563 PL_e_script = NULL;
6224f72b
GS
2564 }
2565
3280af22 2566 if (PL_do_undump)
6224f72b
GS
2567 my_unexec();
2568
57843af0
GS
2569 if (isWARN_ONCE) {
2570 SAVECOPFILE(PL_curcop);
2571 SAVECOPLINE(PL_curcop);
3280af22 2572 gv_check(PL_defstash);
57843af0 2573 }
6224f72b
GS
2574
2575 LEAVE;
2576 FREETMPS;
2577
2578#ifdef MYMALLOC
f6a607bc
RGS
2579 {
2580 const char *s;
22ff3130
HS
2581 UV uv;
2582 s = PerlEnv_getenv("PERL_DEBUG_MSTATS");
2583 if (s && grok_atoUV(s, &uv, NULL) && uv >= 2)
96e440d2 2584 dump_mstats("after compilation:");
f6a607bc 2585 }
6224f72b
GS
2586#endif
2587
2588 ENTER;
febb3a6d 2589 PL_restartjmpenv = NULL;
3280af22 2590 PL_restartop = 0;
312caa8e 2591 return NULL;
6224f72b
GS
2592}
2593
954c1994 2594/*
0301e899
Z
2595=for apidoc Am|int|perl_run|PerlInterpreter *my_perl
2596
2597Tells a Perl interpreter to run its main program. See L<perlembed>
2598for a tutorial.
2599
2600C<my_perl> points to the Perl interpreter. It must have been previously
2601created through the use of L</perl_alloc> and L</perl_construct>, and
2602initialised through L</perl_parse>. This function should not be called
2603if L</perl_parse> returned a non-zero value, indicating a failure in
2604initialisation or compilation.
2605
2606This function executes code in C<INIT> blocks, and then executes the
2607main program. The code to be executed is that established by the prior
2608call to L</perl_parse>. If the interpreter's C<PL_exit_flags> word
2609does not have the C<PERL_EXIT_DESTRUCT_END> flag set, then this function
2610will also execute code in C<END> blocks. If it is desired to make any
2611further use of the interpreter after calling this function, then C<END>
2612blocks should be postponed to L</perl_destruct> time by setting that flag.
2613
2614Returns an integer of slightly tricky interpretation. The correct use
2615of the return value is as a truth value indicating whether the program
2616terminated non-locally. If zero is returned, this indicates that
2617the program ran to completion, and it is safe to make other use of the
2618interpreter (provided that the C<PERL_EXIT_DESTRUCT_END> flag was set as
2619described above). If a non-zero value is returned, this indicates that
2620the interpreter wants to terminate early. The interpreter should not be
2621just abandoned because of this desire to terminate; the caller should
2622proceed to shut the interpreter down cleanly with L</perl_destruct>
2623and free it with L</perl_free>.
2624
2625For historical reasons, the non-zero return value also attempts to
2626be a suitable value to pass to the C library function C<exit> (or to
2627return from C<main>), to serve as an exit code indicating the nature of
2628the way the program terminated. However, this isn't portable, due to
2629differing exit code conventions. An attempt is made to return an exit
2630code of the type required by the host operating system, but because
2631it is constrained to be non-zero, it is not necessarily possible to
2632indicate every type of exit. It is only reliable on Unix, where a zero
2633exit code can be augmented with a set bit that will be ignored. In any
2634case, this function is not the correct place to acquire an exit code:
2635one should get that from L</perl_destruct>.
954c1994
GS
2636
2637=cut
2638*/
2639
6224f72b 2640int
0cb96387 2641perl_run(pTHXx)
6224f72b 2642{
6224f72b 2643 I32 oldscope;
0301e899 2644 int ret = 0, exit_called = 0;
db36c5a1 2645 dJMPENV;
6224f72b 2646
7918f24d
NC
2647 PERL_ARGS_ASSERT_PERL_RUN;
2648#ifndef MULTIPLICITY
ed6c66dd 2649 PERL_UNUSED_ARG(my_perl);
7918f24d 2650#endif
9d4ba2ae 2651
3280af22 2652 oldscope = PL_scopestack_ix;
96e176bf
CL
2653#ifdef VMS
2654 VMSISH_HUSHED = 0;
2655#endif
6224f72b 2656
14dd3ad8 2657 JMPENV_PUSH(ret);
6224f72b
GS
2658 switch (ret) {
2659 case 1:
2660 cxstack_ix = -1; /* start context stack again */
312caa8e 2661 goto redo_body;
14dd3ad8 2662 case 0: /* normal completion */
14dd3ad8
GS
2663 redo_body:
2664 run_body(oldscope);
0301e899 2665 goto handle_exit;
14dd3ad8 2666 case 2: /* my_exit() */
0301e899
Z
2667 exit_called = 1;
2668 handle_exit:
3280af22 2669 while (PL_scopestack_ix > oldscope)
6224f72b
GS
2670 LEAVE;
2671 FREETMPS;
03d9f026 2672 SET_CURSTASH(PL_defstash);
3a1ee7e8 2673 if (!(PL_exit_flags & PERL_EXIT_DESTRUCT_END) &&
9ebf26ad 2674 PL_endav && !PL_minus_c) {
ca7b837b 2675 PERL_SET_PHASE(PERL_PHASE_END);
31d77e54 2676 call_list(oldscope, PL_endav);
9ebf26ad 2677 }
6224f72b
GS
2678#ifdef MYMALLOC
2679 if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
2680 dump_mstats("after execution: ");
2681#endif
0301e899
Z
2682 if (exit_called) {
2683 ret = STATUS_EXIT;
2684 if (ret == 0) ret = 0x100;
2685 } else {
2686 ret = 0;
2687 }
14dd3ad8 2688 break;
6224f72b 2689 case 3:
312caa8e
CS
2690 if (PL_restartop) {
2691 POPSTACK_TO(PL_mainstack);
2692 goto redo_body;
6224f72b 2693 }
5637ef5b 2694 PerlIO_printf(Perl_error_log, "panic: restartop in perl_run\n");
312caa8e 2695 FREETMPS;
14dd3ad8
GS
2696 ret = 1;
2697 break;
6224f72b
GS
2698 }
2699
14dd3ad8
GS
2700 JMPENV_POP;
2701 return ret;
312caa8e
CS
2702}
2703
dd374669 2704STATIC void
14dd3ad8
GS
2705S_run_body(pTHX_ I32 oldscope)
2706{
d3b97530
DM
2707 DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support (0x%x).\n",
2708 PL_sawampersand ? "Enabling" : "Omitting",
2709 (unsigned int)(PL_sawampersand)));
6224f72b 2710
3280af22 2711 if (!PL_restartop) {
cf2782cd 2712#ifdef DEBUGGING
f0e3f042
CS
2713 if (DEBUG_x_TEST || DEBUG_B_TEST)
2714 dump_all_perl(!DEBUG_B_TEST);
ecae49c0
NC
2715 if (!DEBUG_q_TEST)
2716 PERL_DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
cf2782cd 2717#endif
6224f72b 2718
3280af22 2719 if (PL_minus_c) {
bf49b057 2720 PerlIO_printf(Perl_error_log, "%s syntax OK\n", PL_origfilename);
6224f72b
GS
2721 my_exit(0);
2722 }
3280af22 2723 if (PERLDB_SINGLE && PL_DBsingle)
a6d69523 2724 PL_DBsingle_iv = 1;
9ebf26ad 2725 if (PL_initav) {
ca7b837b 2726 PERL_SET_PHASE(PERL_PHASE_INIT);
3280af22 2727 call_list(oldscope, PL_initav);
9ebf26ad 2728 }
f1fac472 2729#ifdef PERL_DEBUG_READONLY_OPS
3107b51f
FC
2730 if (PL_main_root && PL_main_root->op_slabbed)
2731 Slab_to_ro(OpSLAB(PL_main_root));
f1fac472 2732#endif
6224f72b
GS
2733 }
2734
2735 /* do it */
2736
ca7b837b 2737 PERL_SET_PHASE(PERL_PHASE_RUN);
9ebf26ad 2738
3280af22 2739 if (PL_restartop) {
febb3a6d 2740 PL_restartjmpenv = NULL;
533c011a 2741 PL_op = PL_restartop;
3280af22 2742 PL_restartop = 0;
cea2e8a9 2743 CALLRUNOPS(aTHX);
6224f72b 2744 }
3280af22
NIS
2745 else if (PL_main_start) {
2746 CvDEPTH(PL_main_cv) = 1;
533c011a 2747 PL_op = PL_main_start;
cea2e8a9 2748 CALLRUNOPS(aTHX);
6224f72b 2749 }
f6b3007c 2750 my_exit(0);
e5964223 2751 NOT_REACHED; /* NOTREACHED */
6224f72b
GS
2752}
2753
954c1994 2754/*
ccfc67b7
JH
2755=head1 SV Manipulation Functions
2756
954c1994
GS
2757=for apidoc p||get_sv
2758
64ace3f8 2759Returns the SV of the specified Perl scalar. C<flags> are passed to
72d33970 2760C<gv_fetchpv>. If C<GV_ADD> is set and the
64ace3f8
NC
2761Perl variable does not exist then it will be created. If C<flags> is zero
2762and the variable does not exist then NULL is returned.
954c1994
GS
2763
2764=cut
2765*/
2766
6224f72b 2767SV*
64ace3f8 2768Perl_get_sv(pTHX_ const char *name, I32 flags)
6224f72b
GS
2769{
2770 GV *gv;
7918f24d
NC
2771
2772 PERL_ARGS_ASSERT_GET_SV;
2773
64ace3f8 2774 gv = gv_fetchpv(name, flags, SVt_PV);
6224f72b
GS
2775 if (gv)
2776 return GvSV(gv);
a0714e2c 2777 return NULL;
6224f72b
GS
2778}
2779
954c1994 2780/*
ccfc67b7
JH
2781=head1 Array Manipulation Functions
2782
954c1994
GS
2783=for apidoc p||get_av
2784
f0b90de1
SF
2785Returns the AV of the specified Perl global or package array with the given
2786name (so it won't work on lexical variables). C<flags> are passed
72d33970 2787to C<gv_fetchpv>. If C<GV_ADD> is set and the
cbfd0a87
NC
2788Perl variable does not exist then it will be created. If C<flags> is zero
2789and the variable does not exist then NULL is returned.
954c1994 2790
f0b90de1
SF
2791Perl equivalent: C<@{"$name"}>.
2792
954c1994
GS
2793=cut
2794*/
2795
6224f72b 2796AV*
cbfd0a87 2797Perl_get_av(pTHX_ const char *name, I32 flags)
6224f72b 2798{
cbfd0a87 2799 GV* const gv = gv_fetchpv(name, flags, SVt_PVAV);
7918f24d
NC
2800
2801 PERL_ARGS_ASSERT_GET_AV;
2802
cbfd0a87 2803 if (flags)
6224f72b
GS
2804 return GvAVn(gv);
2805 if (gv)
2806 return GvAV(gv);
7d49f689 2807 return NULL;
6224f72b
GS
2808}
2809
954c1994 2810/*
ccfc67b7
JH
2811=head1 Hash Manipulation Functions
2812
954c1994
GS
2813=for apidoc p||get_hv
2814
6673a63c 2815Returns the HV of the specified Perl hash. C<flags> are passed to
72d33970 2816C<gv_fetchpv>. If C<GV_ADD> is set and the
6673a63c 2817Perl variable does not exist then it will be created. If C<flags> is zero
796b6530 2818and the variable does not exist then C<NULL> is returned.
954c1994
GS
2819
2820=cut
2821*/
2822
6224f72b 2823HV*
6673a63c 2824Perl_get_hv(pTHX_ const char *name, I32 flags)
6224f72b 2825{
6673a63c 2826 GV* const gv = gv_fetchpv(name, flags, SVt_PVHV);
7918f24d
NC
2827
2828 PERL_ARGS_ASSERT_GET_HV;
2829
6673a63c 2830 if (flags)
a0d0e21e
LW
2831 return GvHVn(gv);
2832 if (gv)
2833 return GvHV(gv);
5c284bb0 2834 return NULL;
a0d0e21e
LW
2835}
2836
954c1994 2837/*
ccfc67b7
JH
2838=head1 CV Manipulation Functions
2839
780a5241
NC
2840=for apidoc p||get_cvn_flags
2841
2842Returns the CV of the specified Perl subroutine. C<flags> are passed to
72d33970 2843C<gv_fetchpvn_flags>. If C<GV_ADD> is set and the Perl subroutine does not
780a5241
NC
2844exist then it will be declared (which has the same effect as saying
2845C<sub name;>). If C<GV_ADD> is not set and the subroutine does not exist
2846then NULL is returned.
2847
954c1994
GS
2848=for apidoc p||get_cv
2849
780a5241 2850Uses C<strlen> to get the length of C<name>, then calls C<get_cvn_flags>.
954c1994
GS
2851
2852=cut
2853*/
2854
a0d0e21e 2855CV*
780a5241 2856Perl_get_cvn_flags(pTHX_ const char *name, STRLEN len, I32 flags)
a0d0e21e 2857{
780a5241 2858 GV* const gv = gv_fetchpvn_flags(name, len, flags, SVt_PVCV);
7918f24d
NC
2859
2860 PERL_ARGS_ASSERT_GET_CVN_FLAGS;
2861
a385812b 2862 if (gv && UNLIKELY(SvROK(gv)) && SvTYPE(SvRV((SV *)gv)) == SVt_PVCV)
e05a85b2 2863 return (CV*)SvRV((SV *)gv);
a385812b 2864
334dda80
FC
2865 /* XXX this is probably not what they think they're getting.
2866 * It has the same effect as "sub name;", i.e. just a forward
2867 * declaration! */
780a5241 2868 if ((flags & ~GV_NOADD_MASK) && !GvCVu(gv)) {
186a5ba8 2869 return newSTUB(gv,0);
780a5241 2870 }
a0d0e21e 2871 if (gv)
8ebc5c01 2872 return GvCVu(gv);
601f1833 2873 return NULL;
a0d0e21e
LW
2874}
2875
2c67934f
NC
2876/* Nothing in core calls this now, but we can't replace it with a macro and
2877 move it to mathoms.c as a macro would evaluate name twice. */
780a5241
NC
2878CV*
2879Perl_get_cv(pTHX_ const char *name, I32 flags)
2880{
7918f24d
NC
2881 PERL_ARGS_ASSERT_GET_CV;
2882
780a5241
NC
2883 return get_cvn_flags(name, strlen(name), flags);
2884}
2885
79072805
LW
2886/* Be sure to refetch the stack pointer after calling these routines. */
2887
954c1994 2888/*
ccfc67b7
JH
2889
2890=head1 Callback Functions
2891
954c1994
GS
2892=for apidoc p||call_argv
2893
f0b90de1 2894Performs a callback to the specified named and package-scoped Perl subroutine
796b6530 2895with C<argv> (a C<NULL>-terminated array of strings) as arguments. See
72d33970 2896L<perlcall>.
f0b90de1
SF
2897
2898Approximate Perl equivalent: C<&{"$sub_name"}(@$argv)>.
954c1994
GS
2899
2900=cut
2901*/
2902
a0d0e21e 2903I32
5aaab254 2904Perl_call_argv(pTHX_ const char *sub_name, I32 flags, char **argv)
ac27b0f5 2905
8ac85365
NIS
2906 /* See G_* flags in cop.h */
2907 /* null terminated arg list */
8990e307 2908{
a0d0e21e 2909 dSP;
8990e307 2910
7918f24d
NC
2911 PERL_ARGS_ASSERT_CALL_ARGV;
2912
924508f0 2913 PUSHMARK(SP);
3dc78631
DM
2914 while (*argv) {
2915 mXPUSHs(newSVpv(*argv,0));
2916 argv++;
8990e307 2917 }
3dc78631 2918 PUTBACK;
864dbfa3 2919 return call_pv(sub_name, flags);
8990e307
LW
2920}
2921
954c1994
GS
2922/*
2923=for apidoc p||call_pv
2924
2925Performs a callback to the specified Perl sub. See L<perlcall>.
2926
2927=cut
2928*/
2929
a0d0e21e 2930I32
864dbfa3 2931Perl_call_pv(pTHX_ const char *sub_name, I32 flags)
8ac85365
NIS
2932 /* name of the subroutine */
2933 /* See G_* flags in cop.h */
a0d0e21e 2934{
7918f24d
NC
2935 PERL_ARGS_ASSERT_CALL_PV;
2936
0da0e728 2937 return call_sv(MUTABLE_SV(get_cv(sub_name, GV_ADD)), flags);
a0d0e21e
LW
2938}
2939
954c1994
GS
2940/*
2941=for apidoc p||call_method
2942
2943Performs a callback to the specified Perl method. The blessed object must
2944be on the stack. See L<perlcall>.
2945
2946=cut
2947*/
2948
a0d0e21e 2949I32
864dbfa3 2950Perl_call_method(pTHX_ const char *methname, I32 flags)
8ac85365
NIS
2951 /* name of the subroutine */
2952 /* See G_* flags in cop.h */
a0d0e21e 2953{
46ca9bac 2954 STRLEN len;
c106c2be 2955 SV* sv;
7918f24d
NC
2956 PERL_ARGS_ASSERT_CALL_METHOD;
2957
46ca9bac 2958 len = strlen(methname);
c106c2be
RZ
2959 sv = flags & G_METHOD_NAMED
2960 ? sv_2mortal(newSVpvn_share(methname, len,0))
2961 : newSVpvn_flags(methname, len, SVs_TEMP);
46ca9bac 2962
c106c2be 2963 return call_sv(sv, flags | G_METHOD);
a0d0e21e
LW
2964}
2965
2966/* May be called with any of a CV, a GV, or an SV containing the name. */
954c1994
GS
2967/*
2968=for apidoc p||call_sv
2969
078e2213
TC
2970Performs a callback to the Perl sub specified by the SV.
2971
7c0c544c 2972If neither the C<G_METHOD> nor C<G_METHOD_NAMED> flag is supplied, the
078e2213
TC
2973SV may be any of a CV, a GV, a reference to a CV, a reference to a GV
2974or C<SvPV(sv)> will be used as the name of the sub to call.
2975
2976If the C<G_METHOD> flag is supplied, the SV may be a reference to a CV or
2977C<SvPV(sv)> will be used as the name of the method to call.
2978
2979If the C<G_METHOD_NAMED> flag is supplied, C<SvPV(sv)> will be used as
2980the name of the method to call.
2981
2982Some other values are treated specially for internal use and should
2983not be depended on.
2984
2985See L<perlcall>.
954c1994
GS
2986
2987=cut
2988*/
2989
a0d0e21e 2990I32
8162b70e 2991Perl_call_sv(pTHX_ SV *sv, volatile I32 flags)
8ac85365 2992 /* See G_* flags in cop.h */
a0d0e21e 2993{
5b434c73 2994 dVAR;
a0d0e21e 2995 LOGOP myop; /* fake syntax tree node */
b46e009d 2996 METHOP method_op;
aa689395 2997 I32 oldmark;
8162b70e 2998 volatile I32 retval = 0;
54310121 2999 bool oldcatch = CATCH_GET;
6224f72b 3000 int ret;
c4420975 3001 OP* const oldop = PL_op;
db36c5a1 3002 dJMPENV;
1e422769 3003
7918f24d
NC
3004 PERL_ARGS_ASSERT_CALL_SV;
3005
a0d0e21e
LW
3006 if (flags & G_DISCARD) {
3007 ENTER;
3008 SAVETMPS;
3009 }
2f8edad0
NC
3010 if (!(flags & G_WANT)) {
3011 /* Backwards compatibility - as G_SCALAR was 0, it could be omitted.
3012 */
3013 flags |= G_SCALAR;
3014 }
a0d0e21e 3015
aa689395 3016 Zero(&myop, 1, LOGOP);
f51d4af5 3017 if (!(flags & G_NOARGS))
aa689395 3018 myop.op_flags |= OPf_STACKED;
4f911530 3019 myop.op_flags |= OP_GIMME_REVERSE(flags);
462e5cf6 3020 SAVEOP();
533c011a 3021 PL_op = (OP*)&myop;
aa689395 3022
8c9009ad 3023 if (!(flags & G_METHOD_NAMED)) {
5b434c73
DD
3024 dSP;
3025 EXTEND(SP, 1);
8c9009ad
DD
3026 PUSHs(sv);
3027 PUTBACK;
5b434c73 3028 }
aa689395 3029 oldmark = TOPMARK;
a0d0e21e 3030
3280af22 3031 if (PERLDB_SUB && PL_curstash != PL_debstash
36477c24 3032 /* Handle first BEGIN of -d. */
3280af22 3033 && (PL_DBcv || (PL_DBcv = GvCV(PL_DBsub)))
36477c24
PP
3034 /* Try harder, since this may have been a sighandler, thus
3035 * curstash may be meaningless. */
ea726b52 3036 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((const CV *)sv) != PL_debstash)
491527d0 3037 && !(flags & G_NODEBUG))
5ff48db8 3038 myop.op_private |= OPpENTERSUB_DB;
a0d0e21e 3039
c106c2be 3040 if (flags & (G_METHOD|G_METHOD_NAMED)) {
b46e009d 3041 Zero(&method_op, 1, METHOP);
3042 method_op.op_next = (OP*)&myop;
3043 PL_op = (OP*)&method_op;
c106c2be 3044 if ( flags & G_METHOD_NAMED ) {
b46e009d 3045 method_op.op_ppaddr = PL_ppaddr[OP_METHOD_NAMED];
3046 method_op.op_type = OP_METHOD_NAMED;
3047 method_op.op_u.op_meth_sv = sv;
c106c2be 3048 } else {
b46e009d 3049 method_op.op_ppaddr = PL_ppaddr[OP_METHOD];
3050 method_op.op_type = OP_METHOD;
c106c2be
RZ
3051 }
3052 myop.op_ppaddr = PL_ppaddr[OP_ENTERSUB];
3053 myop.op_type = OP_ENTERSUB;
968b3946
GS
3054 }
3055
312caa8e 3056 if (!(flags & G_EVAL)) {
0cdb2077 3057 CATCH_SET(TRUE);
d6f07c05 3058 CALL_BODY_SUB((OP*)&myop);
312caa8e 3059 retval = PL_stack_sp - (PL_stack_base + oldmark);
0253cb41 3060 CATCH_SET(oldcatch);
312caa8e
CS
3061 }
3062 else {
8e90e786 3063 I32 old_cxix;
d78bda3d 3064 myop.op_other = (OP*)&myop;
101d6365 3065 (void)POPMARK;
8e90e786 3066 old_cxix = cxstack_ix;
274ed8ae 3067 create_eval_scope(NULL, flags|G_FAKINGEVAL);
c318a6ee 3068 INCMARK;
a0d0e21e 3069
14dd3ad8 3070 JMPENV_PUSH(ret);
edb2152a 3071
6224f72b
GS
3072 switch (ret) {
3073 case 0:
14dd3ad8 3074 redo_body:
d6f07c05 3075 CALL_BODY_SUB((OP*)&myop);
312caa8e 3076 retval = PL_stack_sp - (PL_stack_base + oldmark);
8433848b 3077 if (!(flags & G_KEEPERR)) {
ab69dbc2 3078 CLEAR_ERRSV();
8433848b 3079 }
a0d0e21e 3080 break;
6224f72b 3081 case 1:
f86702cc 3082 STATUS_ALL_FAILURE;
924ba076 3083 /* FALLTHROUGH */
6224f72b 3084 case 2:
a0d0e21e 3085 /* my_exit() was called */
03d9f026 3086 SET_CURSTASH(PL_defstash);
a0d0e21e 3087 FREETMPS;
14dd3ad8 3088 JMPENV_POP;
f86702cc 3089 my_exit_jump();
e5964223 3090 NOT_REACHED; /* NOTREACHED */
6224f72b 3091 case 3:
3280af22 3092 if (PL_restartop) {
febb3a6d 3093 PL_restartjmpenv = NULL;
533c011a 3094 PL_op = PL_restartop;
3280af22 3095 PL_restartop = 0;
312caa8e 3096 goto redo_body;
a0d0e21e 3097 }
3280af22 3098 PL_stack_sp = PL_stack_base + oldmark;
51ce5529 3099 if ((flags & G_WANT) == G_ARRAY)
a0d0e21e
LW
3100 retval = 0;
3101 else {
3102 retval = 1;
3280af22 3103 *++PL_stack_sp = &PL_sv_undef;
a0d0e21e 3104 }
312caa8e 3105 break;
a0d0e21e 3106 }
a0d0e21e 3107
8e90e786
DM
3108 /* if we croaked, depending on how we croaked the eval scope
3109 * may or may not have already been popped */
3110 if (cxstack_ix > old_cxix) {
3111 assert(cxstack_ix == old_cxix + 1);
4ebe6e95 3112 assert(CxTYPE(CX_CUR()) == CXt_EVAL);
edb2152a 3113 delete_eval_scope();
8e90e786 3114 }
14dd3ad8 3115 JMPENV_POP;
a0d0e21e 3116 }
1e422769 3117
a0d0e21e 3118 if (flags & G_DISCARD) {
3280af22 3119 PL_stack_sp = PL_stack_base + oldmark;
a0d0e21e
LW
3120 retval = 0;
3121 FREETMPS;
3122 LEAVE;
3123 }
533c011a 3124 PL_op = oldop;
a0d0e21e
LW
3125 return retval;
3126}
3127
6e72f9df 3128/* Eval a string. The G_EVAL flag is always assumed. */
8990e307 3129
954c1994
GS
3130/*
3131=for apidoc p||eval_sv
3132
72d33970 3133Tells Perl to C<eval> the string in the SV. It supports the same flags
796b6530 3134as C<call_sv>, with the obvious exception of C<G_EVAL>. See L<perlcall>.
954c1994
GS
3135
3136=cut
3137*/
3138
a0d0e21e 3139I32
864dbfa3 3140Perl_eval_sv(pTHX_ SV *sv, I32 flags)
ac27b0f5 3141
8ac85365 3142 /* See G_* flags in cop.h */
a0d0e21e 3143{
97aff369 3144 dVAR;
a0d0e21e 3145 UNOP myop; /* fake syntax tree node */
8162b70e
AC
3146 volatile I32 oldmark;
3147 volatile I32 retval = 0;
6224f72b 3148 int ret;
c4420975 3149 OP* const oldop = PL_op;
db36c5a1 3150 dJMPENV;
84902520 3151
7918f24d
NC
3152 PERL_ARGS_ASSERT_EVAL_SV;
3153
4633a7c4
LW
3154 if (flags & G_DISCARD) {
3155 ENTER;
3156 SAVETMPS;
3157 }
3158
462e5cf6 3159 SAVEOP();
533c011a 3160 PL_op = (OP*)&myop;
5ff48db8 3161 Zero(&myop, 1, UNOP);
5b434c73
DD
3162 {
3163 dSP;
3164 oldmark = SP - PL_stack_base;
3165 EXTEND(SP, 1);
3166 PUSHs(sv);
3167 PUTBACK;
3168 }
79072805 3169
4633a7c4
LW
3170 if (!(flags & G_NOARGS))
3171 myop.op_flags = OPf_STACKED;
6e72f9df 3172 myop.op_type = OP_ENTEREVAL;
4f911530 3173 myop.op_flags |= OP_GIMME_REVERSE(flags);
6e72f9df
PP
3174 if (flags & G_KEEPERR)
3175 myop.op_flags |= OPf_SPECIAL;
a1941760
DM
3176
3177 if (flags & G_RE_REPARSING)
3178 myop.op_private = (OPpEVAL_COPHH | OPpEVAL_RE_REPARSING);
4633a7c4 3179
dedbcade 3180 /* fail now; otherwise we could fail after the JMPENV_PUSH but
13febba5 3181 * before a cx_pusheval(), which corrupts the stack after a croak */
dedbcade
DM
3182 TAINT_PROPER("eval_sv()");
3183
14dd3ad8 3184 JMPENV_PUSH(ret);
6224f72b
GS
3185 switch (ret) {
3186 case 0:
14dd3ad8 3187 redo_body:
2ba65d5f
DM
3188 if (PL_op == (OP*)(&myop)) {
3189 PL_op = PL_ppaddr[OP_ENTEREVAL](aTHX);
3190 if (!PL_op)
3191 goto fail; /* failed in compilation */
3192 }
4aca2f62 3193 CALLRUNOPS(aTHX);
312caa8e 3194 retval = PL_stack_sp - (PL_stack_base + oldmark);
8433848b 3195 if (!(flags & G_KEEPERR)) {
ab69dbc2 3196 CLEAR_ERRSV();
8433848b 3197 }
4633a7c4 3198 break;
6224f72b 3199 case 1:
f86702cc 3200 STATUS_ALL_FAILURE;
924ba076 3201 /* FALLTHROUGH */
6224f72b 3202 case 2:
4633a7c4 3203 /* my_exit() was called */
03d9f026 3204 SET_CURSTASH(PL_defstash);
4633a7c4 3205 FREETMPS;
14dd3ad8 3206 JMPENV_POP;
f86702cc 3207 my_exit_jump();
e5964223 3208 NOT_REACHED; /* NOTREACHED */
6224f72b 3209 case 3:
3280af22 3210 if (PL_restartop) {
febb3a6d 3211 PL_restartjmpenv = NULL;
533c011a 3212 PL_op = PL_restartop;
3280af22 3213 PL_restartop = 0;
312caa8e 3214 goto redo_body;
4633a7c4 3215 }
4aca2f62 3216 fail:
3280af22 3217 PL_stack_sp = PL_stack_base + oldmark;
51ce5529 3218 if ((flags & G_WANT) == G_ARRAY)
4633a7c4
LW
3219 retval = 0;
3220 else {
3221 retval = 1;
3280af22 3222 *++PL_stack_sp = &PL_sv_undef;
4633a7c4 3223 }
312caa8e 3224 break;
4633a7c4
LW
3225 }
3226
14dd3ad8 3227 JMPENV_POP;
4633a7c4 3228 if (flags & G_DISCARD) {
3280af22 3229 PL_stack_sp = PL_stack_base + oldmark;
4633a7c4
LW
3230 retval = 0;
3231 FREETMPS;
3232 LEAVE;
3233 }
533c011a 3234 PL_op = oldop;
4633a7c4
LW
3235 return retval;
3236}
3237
954c1994
GS
3238/*
3239=for apidoc p||eval_pv
3240
422791e4 3241Tells Perl to C<eval> the given string in scalar context and return an SV* result.
954c1994
GS
3242
3243=cut
3244*/
3245
137443ea 3246SV*
864dbfa3 3247Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error)
137443ea 3248{
137443ea
PP
3249 SV* sv = newSVpv(p, 0);
3250
7918f24d
NC
3251 PERL_ARGS_ASSERT_EVAL_PV;
3252
864dbfa3 3253 eval_sv(sv, G_SCALAR);
137443ea
PP
3254 SvREFCNT_dec(sv);
3255
ed1786ad
DD
3256 {
3257 dSP;
3258 sv = POPs;
3259 PUTBACK;
3260 }
137443ea 3261
eed484f9
DD
3262 /* just check empty string or undef? */
3263 if (croak_on_error) {
3264 SV * const errsv = ERRSV;
3265 if(SvTRUE_NN(errsv))
3266 /* replace with croak_sv? */
3267 Perl_croak_nocontext("%s", SvPV_nolen_const(errsv));
2d8e6c8d 3268 }
137443ea
PP
3269
3270 return sv;
3271}
3272
4633a7c4
LW
3273/* Require a module. */
3274
954c1994 3275/*
ccfc67b7
JH
3276=head1 Embedding Functions
3277
954c1994
GS
3278=for apidoc p||require_pv
3279
7d3fb230
BS
3280Tells Perl to C<require> the file named by the string argument. It is
3281analogous to the Perl code C<eval "require '$file'">. It's even
2307c6d0 3282implemented that way; consider using load_module instead.
954c1994 3283
7d3fb230 3284=cut */
954c1994 3285
4633a7c4 3286void
864dbfa3 3287Perl_require_pv(pTHX_ const char *pv)
4633a7c4 3288{
d3acc0f7 3289 dSP;
97aff369 3290 SV* sv;
7918f24d
NC
3291
3292 PERL_ARGS_ASSERT_REQUIRE_PV;
3293
e788e7d3 3294 PUSHSTACKi(PERLSI_REQUIRE);
be41e5d9
NC
3295 sv = Perl_newSVpvf(aTHX_ "require q%c%s%c", 0, pv, 0);
3296 eval_sv(sv_2mortal(sv), G_DISCARD);
d3acc0f7 3297 POPSTACK;
79072805
LW
3298}
3299
76e3520e 3300STATIC void
b6f82619 3301S_usage(pTHX) /* XXX move this out into a module ? */
4633a7c4 3302{
ab821d7f 3303 /* This message really ought to be max 23 lines.
75c72d73 3304 * Removed -h because the user already knows that option. Others? */
fb73857a 3305
1566c39d
NC
3306 /* Grouped as 6 lines per C string literal, to keep under the ANSI C 89
3307 minimum of 509 character string literals. */
27da23d5 3308 static const char * const usage_msg[] = {
1566c39d
NC
3309" -0[octal] specify record separator (\\0, if no argument)\n"
3310" -a autosplit mode with -n or -p (splits $_ into @F)\n"
3311" -C[number/list] enables the listed Unicode features\n"
3312" -c check syntax only (runs BEGIN and CHECK blocks)\n"
3313" -d[:debugger] run program under debugger\n"
3314" -D[number/list] set debugging flags (argument is a bit mask or alphabets)\n",
3315" -e program one line of program (several -e's allowed, omit programfile)\n"
3316" -E program like -e, but enables all optional features\n"
3317" -f don't do $sitelib/sitecustomize.pl at startup\n"
3318" -F/pattern/ split() pattern for -a switch (//'s are optional)\n"
3319" -i[extension] edit <> files in place (makes backup if extension supplied)\n"
3320" -Idirectory specify @INC/#include directory (several -I's allowed)\n",
3321" -l[octal] enable line ending processing, specifies line terminator\n"
3322" -[mM][-]module execute \"use/no module...\" before executing program\n"
3323" -n assume \"while (<>) { ... }\" loop around program\n"
3324" -p assume loop like -n but print line also, like sed\n"
3325" -s enable rudimentary parsing for switches after programfile\n"
3326" -S look for programfile using PATH environment variable\n",
3327" -t enable tainting warnings\n"
3328" -T enable tainting checks\n"
3329" -u dump core after parsing program\n"
3330" -U allow unsafe operations\n"
3331" -v print version, patchlevel and license\n"
3332" -V[:variable] print configuration summary (or a single Config.pm variable)\n",
60eaec42 3333" -w enable many useful warnings\n"
1566c39d
NC
3334" -W enable all warnings\n"
3335" -x[directory] ignore text before #!perl line (optionally cd to directory)\n"
3336" -X disable all warnings\n"
3337" \n"
3338"Run 'perldoc perl' for more help with Perl.\n\n",
fb73857a
PP
3339NULL
3340};
27da23d5 3341 const char * const *p = usage_msg;
1566c39d 3342 PerlIO *out = PerlIO_stdout();
fb73857a 3343
1566c39d
NC
3344 PerlIO_printf(out,
3345 "\nUsage: %s [switches] [--] [programfile] [arguments]\n",
b6f82619 3346 PL_origargv[0]);
fb73857a 3347 while (*p)
1566c39d 3348 PerlIO_puts(out, *p++);
b6f82619 3349 my_exit(0);
4633a7c4
LW
3350}
3351
b4ab917c
DM
3352/* convert a string of -D options (or digits) into an int.
3353 * sets *s to point to the char after the options */
3354
3355#ifdef DEBUGGING
3356int
e1ec3a88 3357Perl_get_debug_opts(pTHX_ const char **s, bool givehelp)
b4ab917c 3358{
27da23d5 3359 static const char * const usage_msgd[] = {
651b8f1a
NC
3360 " Debugging flag values: (see also -d)\n"
3361 " p Tokenizing and parsing (with v, displays parse stack)\n"
3362 " s Stack snapshots (with v, displays all stacks)\n"
3363 " l Context (loop) stack processing\n"
3364 " t Trace execution\n"
3365 " o Method and overloading resolution\n",
3366 " c String/numeric conversions\n"
3367 " P Print profiling info, source file input state\n"
3368 " m Memory and SV allocation\n"
3369 " f Format processing\n"
3370 " r Regular expression parsing and execution\n"
3371 " x Syntax tree dump\n",
3372 " u Tainting checks\n"
3373 " H Hash dump -- usurps values()\n"
3374 " X Scratchpad allocation\n"
3375 " D Cleaning up\n"
56967202 3376 " S Op slab allocation\n"
651b8f1a
NC
3377 " T Tokenising\n"
3378 " R Include reference counts of dumped variables (eg when using -Ds)\n",
3379 " J Do not s,t,P-debug (Jump over) opcodes within package DB\n"
3380 " v Verbose: use in conjunction with other flags\n"
3381 " C Copy On Write\n"
3382 " A Consistency checks on internal structures\n"
3383 " q quiet - currently only suppresses the 'EXECUTING' message\n"
3384 " M trace smart match resolution\n"
3385 " B dump suBroutine definitions, including special Blocks like BEGIN\n",
69014004 3386 " L trace some locale setting information--for Perl core development\n",
e17bc05a 3387 " i trace PerlIO layer processing\n",
e6e64d9b
JC
3388 NULL
3389 };
22ff3130 3390 UV uv = 0;
7918f24d
NC
3391
3392 PERL_ARGS_ASSERT_GET_DEBUG_OPTS;
3393
b4ab917c
DM
3394 if (isALPHA(**s)) {
3395 /* if adding extra options, remember to update DEBUG_MASK */
e17bc05a 3396 static const char debopts[] = "psltocPmfrxuUHXDSTRJvCAqMBLi";
b4ab917c 3397
0eb30aeb 3398 for (; isWORDCHAR(**s); (*s)++) {
c4420975 3399 const char * const d = strchr(debopts,**s);
b4ab917c 3400 if (d)
22ff3130 3401 uv |= 1 << (d - debopts);
b4ab917c 3402 else if (ckWARN_d(WARN_DEBUGGING))
e6e64d9b
JC
3403 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
3404 "invalid option -D%c, use -D'' to see choices\n", **s);
b4ab917c
DM
3405 }
3406 }
e6e64d9b 3407 else if (isDIGIT(**s)) {
96e440d2 3408 const char* e;
22ff3130 3409 if (grok_atoUV(*s, &uv, &e))
96e440d2 3410 *s = e;
0eb30aeb 3411 for (; isWORDCHAR(**s); (*s)++) ;
b4ab917c 3412 }
ddcf8bc1 3413 else if (givehelp) {
06e869a4 3414 const char *const *p = usage_msgd;
651b8f1a 3415 while (*p) PerlIO_puts(PerlIO_stdout(), *p++);
e6e64d9b 3416 }
22ff3130 3417 return (int)uv; /* ignore any UV->int conversion loss */
b4ab917c
DM
3418}
3419#endif
3420
79072805
LW
3421/* This routine handles any switches that can be given during run */
3422
c7030b81
NC
3423const char *
3424Perl_moreswitches(pTHX_ const char *s)
79072805 3425{
27da23d5 3426 dVAR;
84c133a0 3427 UV rschar;
0544e6df 3428 const char option = *s; /* used to remember option in -m/-M code */
79072805 3429
7918f24d
NC
3430 PERL_ARGS_ASSERT_MORESWITCHES;
3431
79072805
LW
3432 switch (*s) {
3433 case '0':
a863c7d1 3434 {
f2095865 3435 I32 flags = 0;
a3b680e6 3436 STRLEN numlen;
f2095865
JH
3437
3438 SvREFCNT_dec(PL_rs);
3439 if (s[1] == 'x' && s[2]) {
a3b680e6 3440 const char *e = s+=2;
f2095865
JH
3441 U8 *tmps;
3442
a3b680e6
AL
3443 while (*e)
3444 e++;
f2095865
JH
3445 numlen = e - s;
3446 flags = PERL_SCAN_SILENT_ILLDIGIT;
3447 rschar = (U32)grok_hex(s, &numlen, &flags, NULL);
3448 if (s + numlen < e) {
3449 rschar = 0; /* Grandfather -0xFOO as -0 -xFOO. */
3450 numlen = 0;
3451 s--;
3452 }
396482e1 3453 PL_rs = newSVpvs("");
10656159 3454 tmps = (U8*) SvGROW(PL_rs, (STRLEN)(UVCHR_SKIP(rschar) + 1));
f2095865 3455 uvchr_to_utf8(tmps, rschar);
5f560d8a 3456 SvCUR_set(PL_rs, UVCHR_SKIP(rschar));
f2095865
JH
3457 SvUTF8_on(PL_rs);
3458 }
3459 else {
3460 numlen = 4;
3461 rschar = (U32)grok_oct(s, &numlen, &flags, NULL);
3462 if (rschar & ~((U8)~0))
3463 PL_rs = &PL_sv_undef;
3464 else if (!rschar && numlen >= 2)
396482e1 3465 PL_rs = newSVpvs("");
f2095865
JH
3466 else {
3467 char ch = (char)rschar;
3468 PL_rs = newSVpvn(&ch, 1);
3469 }
3470 }
64ace3f8 3471 sv_setsv(get_sv("/", GV_ADD), PL_rs);
f2095865 3472 return s + numlen;
a863c7d1 3473 }
46487f74 3474 case 'C':
a05d7ebb 3475 s++;
dd374669 3476 PL_unicode = parse_unicode_opts( (const char **)&s );
5a22a2bb
NC
3477 if (PL_unicode & PERL_UNICODE_UTF8CACHEASSERT_FLAG)
3478 PL_utf8cache = -1;
46487f74 3479 return s;
2304df62 3480 case 'F':
5fc691f1 3481 PL_minus_a = TRUE;
3280af22 3482 PL_minus_F = TRUE;
24ffa309 3483 PL_minus_n = TRUE;
ebce5377
RGS
3484 PL_splitstr = ++s;
3485 while (*s && !isSPACE(*s)) ++s;
e49e380e 3486 PL_splitstr = savepvn(PL_splitstr, s - PL_splitstr);
2304df62 3487 return s;
79072805 3488 case 'a':
3280af22 3489 PL_minus_a = TRUE;
24ffa309 3490 PL_minus_n = TRUE;
79072805
LW
3491 s++;
3492 return s;
3493 case 'c':
3280af22 3494 PL_minus_c = TRUE;
79072805
LW
3495 s++;
3496 return s;
3497 case 'd':
f20b2998 3498 forbid_setid('d', FALSE);
4633a7c4 3499 s++;
2cbb2ee1
RGS
3500
3501 /* -dt indicates to the debugger that threads will be used */
0eb30aeb 3502 if (*s == 't' && !isWORDCHAR(s[1])) {
2cbb2ee1
RGS
3503 ++s;
3504 my_setenv("PERL5DB_THREADED", "1");
3505 }
3506
70c94a19
RR
3507 /* The following permits -d:Mod to accepts arguments following an =
3508 in the fashion that -MSome::Mod does. */
3509 if (*s == ':' || *s == '=') {
b19934fb
NC
3510 const char *start;
3511 const char *end;
3512 SV *sv;
3513
3514 if (*++s == '-') {
3515 ++s;
3516 sv = newSVpvs("no Devel::");
3517 } else {
3518 sv = newSVpvs("use Devel::");
3519 }
3520
3521 start = s;
3522 end = s + strlen(s);
f85893a1 3523