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