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