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