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