HTTP/2 302 server: nginx date: Thu, 31 Jul 2025 02:05:34 GMT content-type: text/plain; charset=utf-8 content-length: 0 x-archive-redirect-reason: found capture at 20210117104031 location: https://web.archive.org/web/20210117104031/https://perl5.git.perl.org/perl5.git/blame/HEAD:/perl.c server-timing: captures_list;dur=0.656463, exclusion.robots;dur=0.024192, exclusion.robots.policy;dur=0.010615, esindex;dur=0.013454, cdx.remote;dur=12.627438, LoadShardBlock;dur=528.493367, PetaboxLoader3.datanode;dur=474.277755 x-app-server: wwwb-app217 x-ts: 302 x-tr: 570 server-timing: TR;dur=0,Tw;dur=0,Tc;dur=0 set-cookie: SERVER=wwwb-app217; path=/ x-location: All x-rl: 0 x-na: 0 x-page-cache: MISS server-timing: MISS x-nid: DigitalOcean referrer-policy: no-referrer-when-downgrade permissions-policy: interest-cohort=() HTTP/2 200 server: nginx date: Thu, 31 Jul 2025 02:05:36 GMT content-type: application/xhtml+xml; charset=utf-8 x-archive-orig-date: Sun, 17 Jan 2021 10:40:24 GMT x-archive-orig-server: Apache/2.4.6 (CentOS) OpenSSL/1.0.2k-fips x-archive-orig-keep-alive: timeout=5, max=100 x-archive-orig-connection: Keep-Alive x-archive-orig-x-crawler-transfer-encoding: chunked x-archive-orig-content-length: 1048576 x-archive-guessed-content-type: text/html x-archive-guessed-charset: iso-8859-13 memento-datetime: Sun, 17 Jan 2021 10:40:31 GMT link: ; rel="original", ; rel="timemap"; type="application/link-format", ; rel="timegate", ; rel="first memento"; datetime="Sun, 17 Jan 2021 10:40:31 GMT", ; rel="memento"; datetime="Sun, 17 Jan 2021 10:40:31 GMT", ; rel="last memento"; datetime="Sun, 17 Jan 2021 10:40:31 GMT" content-security-policy: default-src 'self' 'unsafe-eval' 'unsafe-inline' data: blob: archive.org web.archive.org web-static.archive.org wayback-api.archive.org athena.archive.org analytics.archive.org pragma.archivelab.org wwwb-events.archive.org x-archive-src: CC-MAIN-2021-04-1610703511903.11-0015/CC-MAIN-20210117081748-20210117111748-00308.warc.gz server-timing: captures_list;dur=0.486091, exclusion.robots;dur=0.020439, exclusion.robots.policy;dur=0.008559, esindex;dur=0.009805, cdx.remote;dur=14.526725, LoadShardBlock;dur=602.462303, PetaboxLoader3.resolve;dur=459.503500, PetaboxLoader3.datanode;dur=353.340343, load_resource;dur=311.390910 x-app-server: wwwb-app217 x-ts: 200 x-tr: 2405 server-timing: TR;dur=0,Tw;dur=0,Tc;dur=0 x-location: All x-rl: 0 x-na: 0 x-page-cache: MISS server-timing: MISS x-nid: DigitalOcean referrer-policy: no-referrer-when-downgrade permissions-policy: interest-cohort=() This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5

https://perl5.git.perl.org / perl5.git / blame

commit grep author committer pickaxe ^? search: re

summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD

t/lib/Cname.pm: Comment, white-space only

[perl5.git] / perl.c

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