This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
factor out remaining fcntl F_SETFD calls
[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 218static void
219S_fixup_platform_bugs(void)
220{
221#if defined(__GLIBC__) && IVSIZE == 8 \
222 && ( __GLIBC__ < 2 || (__GLIBC__ == 2 && __GLIBC_MINOR__ < 8))
223 {
224 IV l = 3;
225 IV r = -10;
226 /* Cannot do this check with inlined IV constants since
227 * that seems to work correctly even with the buggy glibc. */
228 if (l % r == -3) {
229 dTHX;
230 /* Yikes, we have the bug.
231 * Patch in the workaround version. */
232 PL_ppaddr[OP_I_MODULO] = &Perl_pp_i_modulo_glibc_bugfix;
233 }
234 }
235#endif
236}
237
79072805 238void
0cb96387 239perl_construct(pTHXx)
79072805 240{
27da23d5 241 dVAR;
7918f24d
NC
242
243 PERL_ARGS_ASSERT_PERL_CONSTRUCT;
244
8990e307 245#ifdef MULTIPLICITY
54aff467 246 init_interp();
ac27b0f5 247 PL_perl_destruct_level = 1;
54aff467 248#else
7918f24d 249 PERL_UNUSED_ARG(my_perl);
54aff467
GS
250 if (PL_perl_destruct_level > 0)
251 init_interp();
252#endif
34caed6d
DM
253 PL_curcop = &PL_compiling; /* needed by ckWARN, right away */
254
75d476e2
SM
255#ifdef PERL_TRACE_OPS
256 Zero(PL_op_exec_cnt, OP_max+2, UV);
257#endif
258
0d96b528 259 init_constants();
34caed6d 260
e04fc1aa
CB
261 SvREADONLY_on(&PL_sv_placeholder);
262 SvREFCNT(&PL_sv_placeholder) = SvREFCNT_IMMORTAL;
263
264 PL_sighandlerp = (Sighandler_t) Perl_sighandler;
265#ifdef PERL_USES_PL_PIDSTATUS
266 PL_pidstatus = newHV();
267#endif
268
269 PL_rs = newSVpvs("\n");
270
271 init_stacks();
272
273/* The PERL_INTERNAL_RAND_SEED set-up must be after init_stacks because it calls
274 * things that may put SVs on the stack.
275 */
276
d6295071 277#ifdef NO_PERL_INTERNAL_RAND_SEED
f26b33bd 278 Perl_drand48_init_r(&PL_internal_random_state, seed());
d6295071
TC
279#else
280 {
281 UV seed;
282 const char *env_pv;
283 if (PerlProc_getuid() != PerlProc_geteuid() ||
284 PerlProc_getgid() != PerlProc_getegid() ||
285 !(env_pv = PerlEnv_getenv("PERL_INTERNAL_RAND_SEED")) ||
286 grok_number(env_pv, strlen(env_pv), &seed) != IS_NUMBER_IN_UV) {
287 seed = seed();
288 }
289 Perl_drand48_init_r(&PL_internal_random_state, (U32)seed);
290 }
291#endif
f26b33bd 292
748a9306 293 init_ids();
a5f75d66 294
0927ade0 295 S_fixup_platform_bugs();
296
312caa8e 297 JMPENV_BOOTSTRAP;
f86702cc
PP
298 STATUS_ALL_SUCCESS;
299
0672f40e 300 init_i18nl10n(1);
0b5b802d 301
ab821d7f 302#if defined(LOCAL_PATCH_COUNT)
3280af22 303 PL_localpatches = local_patches; /* For possible -v */
ab821d7f
PP
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
SM
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
SM
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
SM
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
PP
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
SM
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
PP
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
PP
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
PP
1044 }
1045
bf9cdc68
RG
1046 PL_perldb = 0;
1047
8ebc5c01
PP
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
PP
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
PP
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
PP
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
SM
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
PP
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
cc85e83f
Z
1696 {
1697 int i;
1698 assert(argc >= 0);
1699 for(i = 0; i != argc; i++)
1700 assert(argv[i]);
1701 assert(!argv[argc]);
1702 }
3280af22 1703 PL_origargc = argc;
e2975953 1704 PL_origargv = argv;
a0d0e21e 1705
a2722ac9
GA
1706 if (PL_origalen != 0) {
1707 PL_origalen = 1; /* don't use old PL_origalen if perl_parse() is called again */
1708 }
1709 else {
3cb9023d
JH
1710 /* Set PL_origalen be the sum of the contiguous argv[]
1711 * elements plus the size of the env in case that it is
e9137a8e 1712 * contiguous with the argv[]. This is used in mg.c:Perl_magic_set()
3cb9023d
JH
1713 * as the maximum modifiable length of $0. In the worst case
1714 * the area we are able to modify is limited to the size of
43c32782 1715 * the original argv[0]. (See below for 'contiguous', though.)
3cb9023d 1716 * --jhi */
e1ec3a88 1717 const char *s = NULL;
b7249aaf 1718 const UV mask = ~(UV)(PTRSIZE-1);
43c32782 1719 /* Do the mask check only if the args seem like aligned. */
1b6737cc 1720 const UV aligned =
43c32782
JH
1721 (mask < ~(UV)0) && ((PTR2UV(argv[0]) & mask) == PTR2UV(argv[0]));
1722
1723 /* See if all the arguments are contiguous in memory. Note
1724 * that 'contiguous' is a loose term because some platforms
1725 * align the argv[] and the envp[]. If the arguments look
1726 * like non-aligned, assume that they are 'strictly' or
1727 * 'traditionally' contiguous. If the arguments look like
1728 * aligned, we just check that they are within aligned
1729 * PTRSIZE bytes. As long as no system has something bizarre
1730 * like the argv[] interleaved with some other data, we are
1731 * fine. (Did I just evoke Murphy's Law?) --jhi */
c8941eeb 1732 if (PL_origargv && PL_origargc >= 1 && (s = PL_origargv[0])) {
19742f39 1733 int i;
c8941eeb
JH
1734 while (*s) s++;
1735 for (i = 1; i < PL_origargc; i++) {
1736 if ((PL_origargv[i] == s + 1
43c32782 1737#ifdef OS2
c8941eeb 1738 || PL_origargv[i] == s + 2
43c32782 1739#endif
c8941eeb
JH
1740 )
1741 ||
1742 (aligned &&
1743 (PL_origargv[i] > s &&
1744 PL_origargv[i] <=
1745 INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask)))
1746 )
1747 {
1748 s = PL_origargv[i];
1749 while (*s) s++;
1750 }
1751 else
1752 break;
54bfe034 1753 }
54bfe034 1754 }
a4a109c2
JD
1755
1756#ifndef PERL_USE_SAFE_PUTENV
3cb9023d 1757 /* Can we grab env area too to be used as the area for $0? */
a4a109c2 1758 if (s && PL_origenviron && !PL_use_safe_putenv) {
9d419b5f 1759 if ((PL_origenviron[0] == s + 1)
43c32782
JH
1760 ||
1761 (aligned &&
1762 (PL_origenviron[0] > s &&
1763 PL_origenviron[0] <=
1764 INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask)))
1765 )
1766 {
19742f39 1767 int i;
9d419b5f 1768#ifndef OS2 /* ENVIRON is read by the kernel too. */
43c32782
JH
1769 s = PL_origenviron[0];
1770 while (*s) s++;
1771#endif
bd61b366 1772 my_setenv("NoNe SuCh", NULL);
43c32782
JH
1773 /* Force copy of environment. */
1774 for (i = 1; PL_origenviron[i]; i++) {
1775 if (PL_origenviron[i] == s + 1
1776 ||
1777 (aligned &&
1778 (PL_origenviron[i] > s &&
1779 PL_origenviron[i] <=
1780 INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask)))
1781 )
1782 {
1783 s = PL_origenviron[i];
1784 while (*s) s++;
1785 }
1786 else
1787 break;
54bfe034 1788 }
43c32782 1789 }
54bfe034 1790 }
a4a109c2
JD
1791#endif /* !defined(PERL_USE_SAFE_PUTENV) */
1792
2d2af554 1793 PL_origalen = s ? s - PL_origargv[0] + 1 : 0;
54bfe034
JH
1794 }
1795
3280af22 1796 if (PL_do_undump) {
a0d0e21e
LW
1797
1798 /* Come here if running an undumped a.out. */
1799
3280af22
NIS
1800 PL_origfilename = savepv(argv[0]);
1801 PL_do_undump = FALSE;
a0d0e21e 1802 cxstack_ix = -1; /* start label stack again */
748a9306 1803 init_ids();
284167a5 1804 assert (!TAINT_get);
b7975bdd 1805 TAINT;
e2051532 1806 set_caret_X();
b7975bdd 1807 TAINT_NOT;
a0d0e21e
LW
1808 init_postdump_symbols(argc,argv,env);
1809 return 0;
1810 }
1811
3280af22 1812 if (PL_main_root) {
3280af22 1813 op_free(PL_main_root);
5f66b61c 1814 PL_main_root = NULL;
ff0cee69 1815 }
5f66b61c 1816 PL_main_start = NULL;
3280af22 1817 SvREFCNT_dec(PL_main_cv);
601f1833 1818 PL_main_cv = NULL;
79072805 1819
3280af22
NIS
1820 time(&PL_basetime);
1821 oldscope = PL_scopestack_ix;
599cee73 1822 PL_dowarn = G_WARN_OFF;
f86702cc 1823
14dd3ad8 1824 JMPENV_PUSH(ret);
6224f72b 1825 switch (ret) {
312caa8e 1826 case 0:
14dd3ad8 1827 parse_body(env,xsinit);
9ebf26ad 1828 if (PL_unitcheckav) {
3c10abe3 1829 call_list(oldscope, PL_unitcheckav);
9ebf26ad
FR
1830 }
1831 if (PL_checkav) {
ca7b837b 1832 PERL_SET_PHASE(PERL_PHASE_CHECK);
7d30b5c4 1833 call_list(oldscope, PL_checkav);
9ebf26ad 1834 }
14dd3ad8
GS
1835 ret = 0;
1836 break;
6224f72b
GS
1837 case 1:
1838 STATUS_ALL_FAILURE;
924ba076 1839 /* FALLTHROUGH */
6224f72b
GS
1840 case 2:
1841 /* my_exit() was called */
3280af22 1842 while (PL_scopestack_ix > oldscope)
6224f72b
GS
1843 LEAVE;
1844 FREETMPS;
03d9f026 1845 SET_CURSTASH(PL_defstash);
9ebf26ad 1846 if (PL_unitcheckav) {
3c10abe3 1847 call_list(oldscope, PL_unitcheckav);
9ebf26ad
FR
1848 }
1849 if (PL_checkav) {
ca7b837b 1850 PERL_SET_PHASE(PERL_PHASE_CHECK);
7d30b5c4 1851 call_list(oldscope, PL_checkav);
9ebf26ad 1852 }
37038d91 1853 ret = STATUS_EXIT;
0301e899 1854 if (ret == 0) ret = 0x100;
14dd3ad8 1855 break;
6224f72b 1856 case 3:
bf49b057 1857 PerlIO_printf(Perl_error_log, "panic: top_env\n");
14dd3ad8
GS
1858 ret = 1;
1859 break;
6224f72b 1860 }
14dd3ad8
GS
1861 JMPENV_POP;
1862 return ret;
1863}
1864
4a5df386
NC
1865/* This needs to stay in perl.c, as perl.c is compiled with different flags for
1866 miniperl, and we need to see those flags reflected in the values here. */
1867
1868/* What this returns is subject to change. Use the public interface in Config.
1869 */
1870static void
1871S_Internals_V(pTHX_ CV *cv)
1872{
1873 dXSARGS;
1874#ifdef LOCAL_PATCH_COUNT
1875 const int local_patch_count = LOCAL_PATCH_COUNT;
1876#else
1877 const int local_patch_count = 0;
1878#endif
2dc296d2 1879 const int entries = 3 + local_patch_count;
4a5df386 1880 int i;
fe1c5936 1881 static const char non_bincompat_options[] =
4a5df386
NC
1882# ifdef DEBUGGING
1883 " DEBUGGING"
1884# endif
1885# ifdef NO_MATHOMS
0d311fbe 1886 " NO_MATHOMS"
4a5df386 1887# endif
59b86f4b
DM
1888# ifdef NO_HASH_SEED
1889 " NO_HASH_SEED"
1890# endif
3b0e4ee2
MB
1891# ifdef NO_TAINT_SUPPORT
1892 " NO_TAINT_SUPPORT"
1893# endif
cb26ef7a
MB
1894# ifdef PERL_BOOL_AS_CHAR
1895 " PERL_BOOL_AS_CHAR"
1896# endif
93c10d60
FC
1897# ifdef PERL_COPY_ON_WRITE
1898 " PERL_COPY_ON_WRITE"
1899# endif
4a5df386
NC
1900# ifdef PERL_DISABLE_PMC
1901 " PERL_DISABLE_PMC"
1902# endif
1903# ifdef PERL_DONT_CREATE_GVSV
1904 " PERL_DONT_CREATE_GVSV"
1905# endif
9a044a43
NC
1906# ifdef PERL_EXTERNAL_GLOB
1907 " PERL_EXTERNAL_GLOB"
1908# endif
59b86f4b
DM
1909# ifdef PERL_HASH_FUNC_SIPHASH
1910 " PERL_HASH_FUNC_SIPHASH"
1911# endif
1912# ifdef PERL_HASH_FUNC_SDBM
1913 " PERL_HASH_FUNC_SDBM"
1914# endif
1915# ifdef PERL_HASH_FUNC_DJB2
1916 " PERL_HASH_FUNC_DJB2"
1917# endif
1918# ifdef PERL_HASH_FUNC_SUPERFAST
1919 " PERL_HASH_FUNC_SUPERFAST"
1920# endif
1921# ifdef PERL_HASH_FUNC_MURMUR3
1922 " PERL_HASH_FUNC_MURMUR3"
1923# endif
1924# ifdef PERL_HASH_FUNC_ONE_AT_A_TIME
1925 " PERL_HASH_FUNC_ONE_AT_A_TIME"
1926# endif
1927# ifdef PERL_HASH_FUNC_ONE_AT_A_TIME_HARD
1928 " PERL_HASH_FUNC_ONE_AT_A_TIME_HARD"
1929# endif
1930# ifdef PERL_HASH_FUNC_ONE_AT_A_TIME_OLD
1931 " PERL_HASH_FUNC_ONE_AT_A_TIME_OLD"
1932# endif
4a5df386
NC
1933# ifdef PERL_IS_MINIPERL
1934 " PERL_IS_MINIPERL"
1935# endif
1936# ifdef PERL_MALLOC_WRAP
1937 " PERL_MALLOC_WRAP"
1938# endif
1939# ifdef PERL_MEM_LOG
1940 " PERL_MEM_LOG"
1941# endif
1942# ifdef PERL_MEM_LOG_NOIMPL
1943 " PERL_MEM_LOG_NOIMPL"
1944# endif
4e499636
DM
1945# ifdef PERL_OP_PARENT
1946 " PERL_OP_PARENT"
1947# endif
59b86f4b
DM
1948# ifdef PERL_PERTURB_KEYS_DETERMINISTIC
1949 " PERL_PERTURB_KEYS_DETERMINISTIC"
1950# endif
1951# ifdef PERL_PERTURB_KEYS_DISABLED
1952 " PERL_PERTURB_KEYS_DISABLED"
1953# endif
1954# ifdef PERL_PERTURB_KEYS_RANDOM
1955 " PERL_PERTURB_KEYS_RANDOM"
1956# endif
c3cf41ec
NC
1957# ifdef PERL_PRESERVE_IVUV
1958 " PERL_PRESERVE_IVUV"
1959# endif
c051e30b
NC
1960# ifdef PERL_RELOCATABLE_INCPUSH
1961 " PERL_RELOCATABLE_INCPUSH"
1962# endif
4a5df386
NC
1963# ifdef PERL_USE_DEVEL
1964 " PERL_USE_DEVEL"
1965# endif
1966# ifdef PERL_USE_SAFE_PUTENV
1967 " PERL_USE_SAFE_PUTENV"
1968# endif
102b7877
YO
1969# ifdef SILENT_NO_TAINT_SUPPORT
1970 " SILENT_NO_TAINT_SUPPORT"
1971# endif
a3749cf3
NC
1972# ifdef UNLINK_ALL_VERSIONS
1973 " UNLINK_ALL_VERSIONS"
1974# endif
de618ee4
NC
1975# ifdef USE_ATTRIBUTES_FOR_PERLIO
1976 " USE_ATTRIBUTES_FOR_PERLIO"
1977# endif
4a5df386
NC
1978# ifdef USE_FAST_STDIO
1979 " USE_FAST_STDIO"
1980# endif
98548bdf
NC
1981# ifdef USE_LOCALE
1982 " USE_LOCALE"
1983# endif
98548bdf
NC
1984# ifdef USE_LOCALE_CTYPE
1985 " USE_LOCALE_CTYPE"
1986# endif
6937817d
DD
1987# ifdef WIN32_NO_REGISTRY
1988 " USE_NO_REGISTRY"
1989# endif
5a8d8935
NC
1990# ifdef USE_PERL_ATOF
1991 " USE_PERL_ATOF"
1992# endif
0d311fbe
NC
1993# ifdef USE_SITECUSTOMIZE
1994 " USE_SITECUSTOMIZE"
1995# endif
4a5df386
NC
1996 ;
1997 PERL_UNUSED_ARG(cv);
d3db1514 1998 PERL_UNUSED_VAR(items);
4a5df386
NC
1999
2000 EXTEND(SP, entries);
2001
2002 PUSHs(sv_2mortal(newSVpv(PL_bincompat_options, 0)));
2003 PUSHs(Perl_newSVpvn_flags(aTHX_ non_bincompat_options,
2004 sizeof(non_bincompat_options) - 1, SVs_TEMP));
2005
6baa8dbd
NT
2006#ifndef PERL_BUILD_DATE
2007# ifdef __DATE__
2008# ifdef __TIME__
2009# define PERL_BUILD_DATE __DATE__ " " __TIME__
2010# else
2011# define PERL_BUILD_DATE __DATE__
2012# endif
2013# endif
2014#endif
2015
2016#ifdef PERL_BUILD_DATE
4a5df386 2017 PUSHs(Perl_newSVpvn_flags(aTHX_
6baa8dbd 2018 STR_WITH_LEN("Compiled at " PERL_BUILD_DATE),
4a5df386 2019 SVs_TEMP));
4a5df386
NC
2020#else
2021 PUSHs(&PL_sv_undef);
2022#endif
2023
4a5df386
NC
2024 for (i = 1; i <= local_patch_count; i++) {
2025 /* This will be an undef, if PL_localpatches[i] is NULL. */
2026 PUSHs(sv_2mortal(newSVpv(PL_localpatches[i], 0)));
2027 }
2028
2029 XSRETURN(entries);
2030}
2031
be71fc8f
NC
2032#define INCPUSH_UNSHIFT 0x01
2033#define INCPUSH_ADD_OLD_VERS 0x02
2034#define INCPUSH_ADD_VERSIONED_SUB_DIRS 0x04
2035#define INCPUSH_ADD_ARCHONLY_SUB_DIRS 0x08
2036#define INCPUSH_NOT_BASEDIR 0x10
2037#define INCPUSH_CAN_RELOCATE 0x20
1e3208d8
NC
2038#define INCPUSH_ADD_SUB_DIRS \
2039 (INCPUSH_ADD_VERSIONED_SUB_DIRS|INCPUSH_ADD_ARCHONLY_SUB_DIRS)
e28f3139 2040
312caa8e 2041STATIC void *
14dd3ad8 2042S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
312caa8e 2043{
27da23d5 2044 dVAR;
2f9285f8 2045 PerlIO *rsfp;
312caa8e 2046 int argc = PL_origargc;
8f42b153 2047 char **argv = PL_origargv;
e1ec3a88 2048 const char *scriptname = NULL;
402582ca 2049 bool dosearch = FALSE;
eb578fdb 2050 char c;
737c24fc 2051 bool doextract = FALSE;
bd61b366 2052 const char *cddir = NULL;
ab019eaa 2053#ifdef USE_SITECUSTOMIZE
20ef40cf 2054 bool minus_f = FALSE;
ab019eaa 2055#endif
95670bde 2056 SV *linestr_sv = NULL;
5486870f 2057 bool add_read_e_script = FALSE;
87606032 2058 U32 lex_start_flags = 0;
009d90df 2059
ca7b837b 2060 PERL_SET_PHASE(PERL_PHASE_START);
9ebf26ad 2061
6224f72b 2062 init_main_stash();
54310121 2063
c7030b81
NC
2064 {
2065 const char *s;
6224f72b
GS
2066 for (argc--,argv++; argc > 0; argc--,argv++) {
2067 if (argv[0][0] != '-' || !argv[0][1])
2068 break;
6224f72b
GS
2069 s = argv[0]+1;
2070 reswitch:
47f56822 2071 switch ((c = *s)) {
729a02f2 2072 case 'C':
1d5472a9
GS
2073#ifndef PERL_STRICT_CR
2074 case '\r':
2075#endif
6224f72b
GS
2076 case ' ':
2077 case '0':
2078 case 'F':
2079 case 'a':
2080 case 'c':
2081 case 'd':
2082 case 'D':
2083 case 'h':
2084 case 'i':
2085 case 'l':
2086 case 'M':
2087 case 'm':
2088 case 'n':
2089 case 'p':
2090 case 's':
2091 case 'u':
2092 case 'U':
2093 case 'v':
599cee73
PM
2094 case 'W':
2095 case 'X':
6224f72b 2096 case 'w':
97bd5664 2097 if ((s = moreswitches(s)))
6224f72b
GS
2098 goto reswitch;
2099 break;
33b78306 2100
1dbad523 2101 case 't':
dc6d7f5c 2102#if defined(SILENT_NO_TAINT_SUPPORT)
284167a5 2103 /* silently ignore */
dc6d7f5c 2104#elif defined(NO_TAINT_SUPPORT)
3231f579 2105 Perl_croak_nocontext("This perl was compiled without taint support. "
284167a5
SM
2106 "Cowardly refusing to run with -t or -T flags");
2107#else
22f7c9c9 2108 CHECK_MALLOC_TOO_LATE_FOR('t');
284167a5
SM
2109 if( !TAINTING_get ) {
2110 TAINT_WARN_set(TRUE);
2111 TAINTING_set(TRUE);
317ea90d 2112 }
284167a5 2113#endif
317ea90d
MS
2114 s++;
2115 goto reswitch;
6224f72b 2116 case 'T':
dc6d7f5c 2117#if defined(SILENT_NO_TAINT_SUPPORT)
284167a5 2118 /* silently ignore */
dc6d7f5c 2119#elif defined(NO_TAINT_SUPPORT)
3231f579 2120 Perl_croak_nocontext("This perl was compiled without taint support. "
284167a5
SM
2121 "Cowardly refusing to run with -t or -T flags");
2122#else
22f7c9c9 2123 CHECK_MALLOC_TOO_LATE_FOR('T');
284167a5
SM
2124 TAINTING_set(TRUE);
2125 TAINT_WARN_set(FALSE);
2126#endif
6224f72b
GS
2127 s++;
2128 goto reswitch;
f86702cc 2129
bc9b29db
RH
2130 case 'E':
2131 PL_minus_E = TRUE;
924ba076 2132 /* FALLTHROUGH */
6224f72b 2133 case 'e':
f20b2998 2134 forbid_setid('e', FALSE);
3280af22 2135 if (!PL_e_script) {
396482e1 2136 PL_e_script = newSVpvs("");
5486870f 2137 add_read_e_script = TRUE;
6224f72b
GS
2138 }
2139 if (*++s)
3280af22 2140 sv_catpv(PL_e_script, s);
6224f72b 2141 else if (argv[1]) {
3280af22 2142 sv_catpv(PL_e_script, argv[1]);
6224f72b
GS
2143 argc--,argv++;
2144 }
2145 else
47f56822 2146 Perl_croak(aTHX_ "No code specified for -%c", c);
396482e1 2147 sv_catpvs(PL_e_script, "\n");
6224f72b 2148 break;
afe37c7d 2149
20ef40cf 2150 case 'f':
f5542d3a 2151#ifdef USE_SITECUSTOMIZE
20ef40cf 2152 minus_f = TRUE;
f5542d3a 2153#endif
20ef40cf
GA
2154 s++;
2155 goto reswitch;
2156
6224f72b 2157 case 'I': /* -I handled both here and in moreswitches() */
f20b2998 2158 forbid_setid('I', FALSE);
bd61b366 2159 if (!*++s && (s=argv[1]) != NULL) {
6224f72b
GS
2160 argc--,argv++;
2161 }
6224f72b 2162 if (s && *s) {
0df16ed7 2163 STRLEN len = strlen(s);
55b4bc1c 2164 incpush(s, len, INCPUSH_ADD_SUB_DIRS|INCPUSH_ADD_OLD_VERS);
0df16ed7
GS
2165 }
2166 else
a67e862a 2167 Perl_croak(aTHX_ "No directory specified for -I");
6224f72b 2168 break;
6224f72b 2169 case 'S':
f20b2998 2170 forbid_setid('S', FALSE);
6224f72b
GS
2171 dosearch = TRUE;
2172 s++;
2173 goto reswitch;
2174 case 'V':
7edfd0ef
NC
2175 {
2176 SV *opts_prog;
2177
7edfd0ef 2178 if (*++s != ':') {
37ca4a5b 2179 opts_prog = newSVpvs("use Config; Config::_V()");
7edfd0ef
NC
2180 }
2181 else {
2182 ++s;
2183 opts_prog = Perl_newSVpvf(aTHX_
37ca4a5b 2184 "use Config; Config::config_vars(qw%c%s%c)",
7edfd0ef
NC
2185 0, s, 0);
2186 s += strlen(s);
2187 }
37ca4a5b 2188 Perl_av_create_and_push(aTHX_ &PL_preambleav, opts_prog);
7edfd0ef
NC
2189 /* don't look for script or read stdin */
2190 scriptname = BIT_BUCKET;
2191 goto reswitch;
6224f72b 2192 }
6224f72b 2193 case 'x':
737c24fc 2194 doextract = TRUE;
6224f72b 2195 s++;
304334da 2196 if (*s)
f4c556ac 2197 cddir = s;
6224f72b
GS
2198 break;
2199 case 0:
2200 break;
2201 case '-':
2202 if (!*++s || isSPACE(*s)) {
2203 argc--,argv++;
2204 goto switch_end;
2205 }
ee8bc8b7
NC
2206 /* catch use of gnu style long options.
2207 Both of these exit immediately. */
2208 if (strEQ(s, "version"))
2209 minus_v();
2210 if (strEQ(s, "help"))
2211 usage();
6224f72b 2212 s--;
924ba076 2213 /* FALLTHROUGH */
6224f72b 2214 default:
cea2e8a9 2215 Perl_croak(aTHX_ "Unrecognized switch: -%s (-h will show valid options)",s);
8d063cd8
LW
2216 }
2217 }
c7030b81
NC
2218 }
2219
6224f72b 2220 switch_end:
54310121 2221
c7030b81
NC
2222 {
2223 char *s;
2224
f675dbe5
CB
2225 if (
2226#ifndef SECURE_INTERNAL_GETENV
284167a5 2227 !TAINTING_get &&
f675dbe5 2228#endif
cf756827 2229 (s = PerlEnv_getenv("PERL5OPT")))
0df16ed7 2230 {
9e0b0d62
KW
2231 /* s points to static memory in getenv(), which may be overwritten at
2232 * any time; use a mortal copy instead */
2233 s = SvPVX(sv_2mortal(newSVpv(s, 0)));
2234
74288ac8
GS
2235 while (isSPACE(*s))
2236 s++;
317ea90d 2237 if (*s == '-' && *(s+1) == 'T') {
dc6d7f5c 2238#if defined(SILENT_NO_TAINT_SUPPORT)
284167a5 2239 /* silently ignore */
dc6d7f5c 2240#elif defined(NO_TAINT_SUPPORT)
3231f579 2241 Perl_croak_nocontext("This perl was compiled without taint support. "
284167a5
SM
2242 "Cowardly refusing to run with -t or -T flags");
2243#else
22f7c9c9 2244 CHECK_MALLOC_TOO_LATE_FOR('T');
284167a5
SM
2245 TAINTING_set(TRUE);
2246 TAINT_WARN_set(FALSE);
2247#endif
317ea90d 2248 }
74288ac8 2249 else {
bd61b366 2250 char *popt_copy = NULL;
74288ac8 2251 while (s && *s) {
54913509 2252 const char *d;
74288ac8
GS
2253 while (isSPACE(*s))
2254 s++;
2255 if (*s == '-') {
2256 s++;
2257 if (isSPACE(*s))
2258 continue;
2259 }
4ea8f8fb 2260 d = s;
74288ac8
GS
2261 if (!*s)
2262 break;
2b622f1a 2263 if (!strchr("CDIMUdmtwW", *s))
cea2e8a9 2264 Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s);
4ea8f8fb
MS
2265 while (++s && *s) {
2266 if (isSPACE(*s)) {
cf756827 2267 if (!popt_copy) {
bfa6c418
NC
2268 popt_copy = SvPVX(sv_2mortal(newSVpv(d,0)));
2269 s = popt_copy + (s - d);
2270 d = popt_copy;
cf756827 2271 }
4ea8f8fb
MS
2272 *s++ = '\0';
2273 break;
2274 }
2275 }
1c4db469 2276 if (*d == 't') {
dc6d7f5c 2277#if defined(SILENT_NO_TAINT_SUPPORT)
284167a5 2278 /* silently ignore */
dc6d7f5c 2279#elif defined(NO_TAINT_SUPPORT)
3231f579 2280 Perl_croak_nocontext("This perl was compiled without taint support. "
284167a5
SM
2281 "Cowardly refusing to run with -t or -T flags");
2282#else
2283 if( !TAINTING_get) {
2284 TAINT_WARN_set(TRUE);
2285 TAINTING_set(TRUE);
317ea90d 2286 }
284167a5 2287#endif
1c4db469 2288 } else {
97bd5664 2289 moreswitches(d);
1c4db469 2290 }
6224f72b 2291 }
6224f72b
GS
2292 }
2293 }
c7030b81 2294 }
a0d0e21e 2295
d6295071
TC
2296#ifndef NO_PERL_INTERNAL_RAND_SEED
2297 /* If we're not set[ug]id, we might have honored
2298 PERL_INTERNAL_RAND_SEED in perl_construct().
2299 At this point command-line options have been parsed, so if
2300 we're now tainting and not set[ug]id re-seed.
2301 This could possibly be wasteful if PERL_INTERNAL_RAND_SEED is invalid,
2302 but avoids duplicating the logic from perl_construct().
2303 */
2304 if (PL_tainting &&
2305 PerlProc_getuid() == PerlProc_geteuid() &&
2306 PerlProc_getgid() == PerlProc_getegid()) {
2307 Perl_drand48_init_r(&PL_internal_random_state, seed());
2308 }
2309#endif
2310
c29067d7
CH
2311 /* Set $^X early so that it can be used for relocatable paths in @INC */
2312 /* and for SITELIB_EXP in USE_SITECUSTOMIZE */
284167a5 2313 assert (!TAINT_get);
c29067d7 2314 TAINT;
e2051532 2315 set_caret_X();
c29067d7
CH
2316 TAINT_NOT;
2317
43c0c913 2318#if defined(USE_SITECUSTOMIZE)
20ef40cf 2319 if (!minus_f) {
43c0c913 2320 /* The games with local $! are to avoid setting errno if there is no
fc81b718
NC
2321 sitecustomize script. "q%c...%c", 0, ..., 0 becomes "q\0...\0",
2322 ie a q() operator with a NUL byte as a the delimiter. This avoids
2323 problems with pathnames containing (say) ' */
43c0c913
NC
2324# ifdef PERL_IS_MINIPERL
2325 AV *const inc = GvAV(PL_incgv);
2326 SV **const inc0 = inc ? av_fetch(inc, 0, FALSE) : NULL;
2327
2328 if (inc0) {
15870c5c
NC
2329 /* if lib/buildcustomize.pl exists, it should not fail. If it does,
2330 it should be reported immediately as a build failure. */
43c0c913
NC
2331 (void)Perl_av_create_and_unshift_one(aTHX_ &PL_preambleav,
2332 Perl_newSVpvf(aTHX_
147e3846 2333 "BEGIN { my $f = q%c%s%" SVf "/buildcustomize.pl%c; "
af26e4f2
FC
2334 "do {local $!; -f $f }"
2335 " and do $f || die $@ || qq '$f: $!' }",
5de87db5 2336 0, (TAINTING_get ? "./" : ""), SVfARG(*inc0), 0));
43c0c913
NC
2337 }
2338# else
2339 /* SITELIB_EXP is a function call on Win32. */
c29067d7 2340 const char *const raw_sitelib = SITELIB_EXP;
bac5c4fc
JD
2341 if (raw_sitelib) {
2342 /* process .../.. if PERL_RELOCATABLE_INC is defined */
2343 SV *sitelib_sv = mayberelocate(raw_sitelib, strlen(raw_sitelib),
2344 INCPUSH_CAN_RELOCATE);
2345 const char *const sitelib = SvPVX(sitelib_sv);
2346 (void)Perl_av_create_and_unshift_one(aTHX_ &PL_preambleav,
2347 Perl_newSVpvf(aTHX_
2348 "BEGIN { do {local $!; -f q%c%s/sitecustomize.pl%c} && do q%c%s/sitecustomize.pl%c }",
c1f6cd39
BF
2349 0, SVfARG(sitelib), 0,
2350 0, SVfARG(sitelib), 0));
bac5c4fc
JD
2351 assert (SvREFCNT(sitelib_sv) == 1);
2352 SvREFCNT_dec(sitelib_sv);
2353 }
43c0c913 2354# endif
20ef40cf
GA
2355 }
2356#endif
2357
6224f72b
GS
2358 if (!scriptname)
2359 scriptname = argv[0];
3280af22 2360 if (PL_e_script) {
6224f72b
GS
2361 argc++,argv--;
2362 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
2363 }
bd61b366 2364 else if (scriptname == NULL) {
6224f72b
GS
2365#ifdef MSDOS
2366 if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) )
97bd5664 2367 moreswitches("h");
6224f72b
GS
2368#endif
2369 scriptname = "-";
2370 }
2371
284167a5 2372 assert (!TAINT_get);
2cace6ac 2373 init_perllib();
6224f72b 2374
a52eba0e 2375 {
f20b2998 2376 bool suidscript = FALSE;
829372d3 2377
8d113837 2378 rsfp = open_script(scriptname, dosearch, &suidscript);
c0b3891a
NC
2379 if (!rsfp) {
2380 rsfp = PerlIO_stdin();
87606032 2381 lex_start_flags = LEX_DONT_CLOSE_RSFP;
c0b3891a 2382 }
6224f72b 2383
b24bc095 2384 validate_suid(rsfp);
6224f72b 2385
64ca3a65 2386#ifndef PERL_MICRO
a52eba0e
NC
2387# if defined(SIGCHLD) || defined(SIGCLD)
2388 {
2389# ifndef SIGCHLD
2390# define SIGCHLD SIGCLD
2391# endif
2392 Sighandler_t sigstate = rsignal_state(SIGCHLD);
2393 if (sigstate == (Sighandler_t) SIG_IGN) {
a2a5de95
NC
2394 Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL),
2395 "Can't ignore signal CHLD, forcing to default");
a52eba0e
NC
2396 (void)rsignal(SIGCHLD, (Sighandler_t)SIG_DFL);
2397 }
0b5b802d 2398 }
a52eba0e 2399# endif
64ca3a65 2400#endif
0b5b802d 2401
737c24fc 2402 if (doextract) {
faef540c 2403
f20b2998 2404 /* This will croak if suidscript is true, as -x cannot be used with
faef540c
NC
2405 setuid scripts. */
2406 forbid_setid('x', suidscript);
f20b2998 2407 /* Hence you can't get here if suidscript is true */
faef540c 2408
95670bde
NC
2409 linestr_sv = newSV_type(SVt_PV);
2410 lex_start_flags |= LEX_START_COPIED;
2f9285f8 2411 find_beginning(linestr_sv, rsfp);
a52eba0e
NC
2412 if (cddir && PerlDir_chdir( (char *)cddir ) < 0)
2413 Perl_croak(aTHX_ "Can't chdir to %s",cddir);
2414 }
f4c556ac 2415 }
6224f72b 2416
ea726b52 2417 PL_main_cv = PL_compcv = MUTABLE_CV(newSV_type(SVt_PVCV));
3280af22
NIS
2418 CvUNIQUE_on(PL_compcv);
2419
eacbb379 2420 CvPADLIST_set(PL_compcv, pad_new(0));
6224f72b 2421
dd69841b
BB
2422 PL_isarev = newHV();
2423
0c4f7ff0 2424 boot_core_PerlIO();
6224f72b 2425 boot_core_UNIVERSAL();
e1a479c5 2426 boot_core_mro();
4a5df386 2427 newXS("Internals::V", S_Internals_V, __FILE__);
6224f72b
GS
2428
2429 if (xsinit)
acfe0abc 2430 (*xsinit)(aTHX); /* in case linked C routines want magical variables */
64ca3a65 2431#ifndef PERL_MICRO
739a0b84 2432#if defined(VMS) || defined(WIN32) || defined(DJGPP) || defined(__CYGWIN__) || defined(SYMBIAN)
c5be433b 2433 init_os_extras();
6224f72b 2434#endif
64ca3a65 2435#endif
6224f72b 2436
29209bc5 2437#ifdef USE_SOCKS
1b9c9cf5
DH
2438# ifdef HAS_SOCKS5_INIT
2439 socks5_init(argv[0]);
2440# else
29209bc5 2441 SOCKSinit(argv[0]);
1b9c9cf5 2442# endif
ac27b0f5 2443#endif
29209bc5 2444
6224f72b
GS
2445 init_predump_symbols();
2446 /* init_postdump_symbols not currently designed to be called */
2447 /* more than once (ENV isn't cleared first, for example) */
2448 /* But running with -u leaves %ENV & @ARGV undefined! XXX */
3280af22 2449 if (!PL_do_undump)
6224f72b
GS
2450 init_postdump_symbols(argc,argv,env);
2451
27da23d5
JH
2452 /* PL_unicode is turned on by -C, or by $ENV{PERL_UNICODE},
2453 * or explicitly in some platforms.
73e1bd1a 2454 * PL_utf8locale is conditionally turned on by
085a54d9 2455 * locale.c:Perl_init_i18nl10n() if the environment
a05d7ebb 2456 * look like the user wants to use UTF-8. */
a0fd4948 2457#if defined(__SYMBIAN32__)
27da23d5
JH
2458 PL_unicode = PERL_UNICODE_STD_FLAG; /* See PERL_SYMBIAN_CONSOLE_UTF8. */
2459#endif
e27b5b51 2460# ifndef PERL_IS_MINIPERL
06e66572
JH
2461 if (PL_unicode) {
2462 /* Requires init_predump_symbols(). */
a05d7ebb 2463 if (!(PL_unicode & PERL_UNICODE_LOCALE_FLAG) || PL_utf8locale) {
06e66572
JH
2464 IO* io;
2465 PerlIO* fp;
2466 SV* sv;
2467
a05d7ebb 2468 /* Turn on UTF-8-ness on STDIN, STDOUT, STDERR
06e66572 2469 * and the default open disciplines. */
a05d7ebb
JH
2470 if ((PL_unicode & PERL_UNICODE_STDIN_FLAG) &&
2471 PL_stdingv && (io = GvIO(PL_stdingv)) &&
2472 (fp = IoIFP(io)))
2473 PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
2474 if ((PL_unicode & PERL_UNICODE_STDOUT_FLAG) &&
2475 PL_defoutgv && (io = GvIO(PL_defoutgv)) &&
2476 (fp = IoOFP(io)))
2477 PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
2478 if ((PL_unicode & PERL_UNICODE_STDERR_FLAG) &&
2479 PL_stderrgv && (io = GvIO(PL_stderrgv)) &&
2480 (fp = IoOFP(io)))
2481 PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
2482 if ((PL_unicode & PERL_UNICODE_INOUT_FLAG) &&
fafc274c
NC
2483 (sv = GvSV(gv_fetchpvs("\017PEN", GV_ADD|GV_NOTQUAL,
2484 SVt_PV)))) {
a05d7ebb
JH
2485 U32 in = PL_unicode & PERL_UNICODE_IN_FLAG;
2486 U32 out = PL_unicode & PERL_UNICODE_OUT_FLAG;
2487 if (in) {
2488 if (out)
76f68e9b 2489 sv_setpvs(sv, ":utf8\0:utf8");
a05d7ebb 2490 else
76f68e9b 2491 sv_setpvs(sv, ":utf8\0");
a05d7ebb
JH
2492 }
2493 else if (out)
76f68e9b 2494 sv_setpvs(sv, "\0:utf8");
a05d7ebb
JH
2495 SvSETMAGIC(sv);
2496 }
b310b053
JH
2497 }
2498 }
e27b5b51 2499#endif
b310b053 2500
c7030b81
NC
2501 {
2502 const char *s;
4ffa73a3
JH
2503 if ((s = PerlEnv_getenv("PERL_SIGNALS"))) {
2504 if (strEQ(s, "unsafe"))
2505 PL_signals |= PERL_SIGNALS_UNSAFE_FLAG;
2506 else if (strEQ(s, "safe"))
2507 PL_signals &= ~PERL_SIGNALS_UNSAFE_FLAG;
2508 else
2509 Perl_croak(aTHX_ "PERL_SIGNALS illegal: \"%s\"", s);
2510 }
c7030b81 2511 }
4ffa73a3 2512
81d86705 2513
87606032 2514 lex_start(linestr_sv, rsfp, lex_start_flags);
d2687c98 2515 SvREFCNT_dec(linestr_sv);
95670bde 2516
219f7226 2517 PL_subname = newSVpvs("main");
6224f72b 2518
5486870f
DM
2519 if (add_read_e_script)
2520 filter_add(read_e_script, NULL);
2521
6224f72b
GS
2522 /* now parse the script */
2523
93189314 2524 SETERRNO(0,SS_NORMAL);
28ac2b49 2525 if (yyparse(GRAMPROG) || PL_parser->error_count) {
c77da5ff 2526 abort_execution("", PL_origfilename);
6224f72b 2527 }
57843af0 2528 CopLINE_set(PL_curcop, 0);
03d9f026 2529 SET_CURSTASH(PL_defstash);
3280af22
NIS
2530 if (PL_e_script) {
2531 SvREFCNT_dec(PL_e_script);
a0714e2c 2532 PL_e_script = NULL;
6224f72b
GS
2533 }
2534
3280af22 2535 if (PL_do_undump)
6224f72b
GS
2536 my_unexec();
2537
57843af0
GS
2538 if (isWARN_ONCE) {
2539 SAVECOPFILE(PL_curcop);
2540 SAVECOPLINE(PL_curcop);
3280af22 2541 gv_check(PL_defstash);
57843af0 2542 }
6224f72b
GS
2543
2544 LEAVE;
2545 FREETMPS;
2546
2547#ifdef MYMALLOC
f6a607bc
RGS
2548 {
2549 const char *s;
22ff3130
HS
2550 UV uv;
2551 s = PerlEnv_getenv("PERL_DEBUG_MSTATS");
2552 if (s && grok_atoUV(s, &uv, NULL) && uv >= 2)
96e440d2 2553 dump_mstats("after compilation:");
f6a607bc 2554 }
6224f72b
GS
2555#endif
2556
2557 ENTER;
febb3a6d 2558 PL_restartjmpenv = NULL;
3280af22 2559 PL_restartop = 0;
312caa8e 2560 return NULL;
6224f72b
GS
2561}
2562
954c1994 2563/*
0301e899
Z
2564=for apidoc Am|int|perl_run|PerlInterpreter *my_perl
2565
2566Tells a Perl interpreter to run its main program. See L<perlembed>
2567for a tutorial.
2568
2569C<my_perl> points to the Perl interpreter. It must have been previously
2570created through the use of L</perl_alloc> and L</perl_construct>, and
2571initialised through L</perl_parse>. This function should not be called
2572if L</perl_parse> returned a non-zero value, indicating a failure in
2573initialisation or compilation.
2574
2575This function executes code in C<INIT> blocks, and then executes the
2576main program. The code to be executed is that established by the prior
2577call to L</perl_parse>. If the interpreter's C<PL_exit_flags> word
2578does not have the C<PERL_EXIT_DESTRUCT_END> flag set, then this function
2579will also execute code in C<END> blocks. If it is desired to make any
2580further use of the interpreter after calling this function, then C<END>
2581blocks should be postponed to L</perl_destruct> time by setting that flag.
2582
2583Returns an integer of slightly tricky interpretation. The correct use
2584of the return value is as a truth value indicating whether the program
2585terminated non-locally. If zero is returned, this indicates that
2586the program ran to completion, and it is safe to make other use of the
2587interpreter (provided that the C<PERL_EXIT_DESTRUCT_END> flag was set as
2588described above). If a non-zero value is returned, this indicates that
2589the interpreter wants to terminate early. The interpreter should not be
2590just abandoned because of this desire to terminate; the caller should
2591proceed to shut the interpreter down cleanly with L</perl_destruct>
2592and free it with L</perl_free>.
2593
2594For historical reasons, the non-zero return value also attempts to
2595be a suitable value to pass to the C library function C<exit> (or to
2596return from C<main>), to serve as an exit code indicating the nature of
2597the way the program terminated. However, this isn't portable, due to
2598differing exit code conventions. An attempt is made to return an exit
2599code of the type required by the host operating system, but because
2600it is constrained to be non-zero, it is not necessarily possible to
2601indicate every type of exit. It is only reliable on Unix, where a zero
2602exit code can be augmented with a set bit that will be ignored. In any
2603case, this function is not the correct place to acquire an exit code:
2604one should get that from L</perl_destruct>.
954c1994
GS
2605
2606=cut
2607*/
2608
6224f72b 2609int
0cb96387 2610perl_run(pTHXx)
6224f72b 2611{
6224f72b 2612 I32 oldscope;
0301e899 2613 int ret = 0, exit_called = 0;
db36c5a1 2614 dJMPENV;
6224f72b 2615
7918f24d
NC
2616 PERL_ARGS_ASSERT_PERL_RUN;
2617#ifndef MULTIPLICITY
ed6c66dd 2618 PERL_UNUSED_ARG(my_perl);
7918f24d 2619#endif
9d4ba2ae 2620
3280af22 2621 oldscope = PL_scopestack_ix;
96e176bf
CL
2622#ifdef VMS
2623 VMSISH_HUSHED = 0;
2624#endif
6224f72b 2625
14dd3ad8 2626 JMPENV_PUSH(ret);
6224f72b
GS
2627 switch (ret) {
2628 case 1:
2629 cxstack_ix = -1; /* start context stack again */
312caa8e 2630 goto redo_body;
14dd3ad8 2631 case 0: /* normal completion */
14dd3ad8
GS
2632 redo_body:
2633 run_body(oldscope);
0301e899 2634 goto handle_exit;
14dd3ad8 2635 case 2: /* my_exit() */
0301e899
Z
2636 exit_called = 1;
2637 handle_exit:
3280af22 2638 while (PL_scopestack_ix > oldscope)
6224f72b
GS
2639 LEAVE;
2640 FREETMPS;
03d9f026 2641 SET_CURSTASH(PL_defstash);
3a1ee7e8 2642 if (!(PL_exit_flags & PERL_EXIT_DESTRUCT_END) &&
9ebf26ad 2643 PL_endav && !PL_minus_c) {
ca7b837b 2644 PERL_SET_PHASE(PERL_PHASE_END);
31d77e54 2645 call_list(oldscope, PL_endav);
9ebf26ad 2646 }
6224f72b
GS
2647#ifdef MYMALLOC
2648 if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
2649 dump_mstats("after execution: ");
2650#endif
0301e899
Z
2651 if (exit_called) {
2652 ret = STATUS_EXIT;
2653 if (ret == 0) ret = 0x100;
2654 } else {
2655 ret = 0;
2656 }
14dd3ad8 2657 break;
6224f72b 2658 case 3:
312caa8e
CS
2659 if (PL_restartop) {
2660 POPSTACK_TO(PL_mainstack);
2661 goto redo_body;
6224f72b 2662 }
5637ef5b 2663 PerlIO_printf(Perl_error_log, "panic: restartop in perl_run\n");
312caa8e 2664 FREETMPS;
14dd3ad8
GS
2665 ret = 1;
2666 break;
6224f72b
GS
2667 }
2668
14dd3ad8
GS
2669 JMPENV_POP;
2670 return ret;
312caa8e
CS
2671}
2672
dd374669 2673STATIC void
14dd3ad8
GS
2674S_run_body(pTHX_ I32 oldscope)
2675{
d3b97530
DM
2676 DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support (0x%x).\n",
2677 PL_sawampersand ? "Enabling" : "Omitting",
2678 (unsigned int)(PL_sawampersand)));
6224f72b 2679
3280af22 2680 if (!PL_restartop) {
cf2782cd 2681#ifdef DEBUGGING
f0e3f042
CS
2682 if (DEBUG_x_TEST || DEBUG_B_TEST)
2683 dump_all_perl(!DEBUG_B_TEST);
ecae49c0
NC
2684 if (!DEBUG_q_TEST)
2685 PERL_DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
cf2782cd 2686#endif
6224f72b 2687
3280af22 2688 if (PL_minus_c) {
bf49b057 2689 PerlIO_printf(Perl_error_log, "%s syntax OK\n", PL_origfilename);
6224f72b
GS
2690 my_exit(0);
2691 }
3280af22 2692 if (PERLDB_SINGLE && PL_DBsingle)
a6d69523 2693 PL_DBsingle_iv = 1;
9ebf26ad 2694 if (PL_initav) {
ca7b837b 2695 PERL_SET_PHASE(PERL_PHASE_INIT);
3280af22 2696 call_list(oldscope, PL_initav);
9ebf26ad 2697 }
f1fac472 2698#ifdef PERL_DEBUG_READONLY_OPS
3107b51f
FC
2699 if (PL_main_root && PL_main_root->op_slabbed)
2700 Slab_to_ro(OpSLAB(PL_main_root));
f1fac472 2701#endif
6224f72b
GS
2702 }
2703
2704 /* do it */
2705
ca7b837b 2706 PERL_SET_PHASE(PERL_PHASE_RUN);
9ebf26ad 2707
3280af22 2708 if (PL_restartop) {
febb3a6d 2709 PL_restartjmpenv = NULL;
533c011a 2710 PL_op = PL_restartop;
3280af22 2711 PL_restartop = 0;
cea2e8a9 2712 CALLRUNOPS(aTHX);
6224f72b 2713 }
3280af22
NIS
2714 else if (PL_main_start) {
2715 CvDEPTH(PL_main_cv) = 1;
533c011a 2716 PL_op = PL_main_start;
cea2e8a9 2717 CALLRUNOPS(aTHX);
6224f72b 2718 }
f6b3007c 2719 my_exit(0);
e5964223 2720 NOT_REACHED; /* NOTREACHED */
6224f72b
GS
2721}
2722
954c1994 2723/*
ccfc67b7
JH
2724=head1 SV Manipulation Functions
2725
954c1994
GS
2726=for apidoc p||get_sv
2727
64ace3f8 2728Returns the SV of the specified Perl scalar. C<flags> are passed to
72d33970 2729C<gv_fetchpv>. If C<GV_ADD> is set and the
64ace3f8
NC
2730Perl variable does not exist then it will be created. If C<flags> is zero
2731and the variable does not exist then NULL is returned.
954c1994
GS
2732
2733=cut
2734*/
2735
6224f72b 2736SV*
64ace3f8 2737Perl_get_sv(pTHX_ const char *name, I32 flags)
6224f72b
GS
2738{
2739 GV *gv;
7918f24d
NC
2740
2741 PERL_ARGS_ASSERT_GET_SV;
2742
64ace3f8 2743 gv = gv_fetchpv(name, flags, SVt_PV);
6224f72b
GS
2744 if (gv)
2745 return GvSV(gv);
a0714e2c 2746 return NULL;
6224f72b
GS
2747}
2748
954c1994 2749/*
ccfc67b7
JH
2750=head1 Array Manipulation Functions
2751
954c1994
GS
2752=for apidoc p||get_av
2753
f0b90de1
SF
2754Returns the AV of the specified Perl global or package array with the given
2755name (so it won't work on lexical variables). C<flags> are passed
72d33970 2756to C<gv_fetchpv>. If C<GV_ADD> is set and the
cbfd0a87
NC
2757Perl variable does not exist then it will be created. If C<flags> is zero
2758and the variable does not exist then NULL is returned.
954c1994 2759
f0b90de1
SF
2760Perl equivalent: C<@{"$name"}>.
2761
954c1994
GS
2762=cut
2763*/
2764
6224f72b 2765AV*
cbfd0a87 2766Perl_get_av(pTHX_ const char *name, I32 flags)
6224f72b 2767{
cbfd0a87 2768 GV* const gv = gv_fetchpv(name, flags, SVt_PVAV);
7918f24d
NC
2769
2770 PERL_ARGS_ASSERT_GET_AV;
2771
cbfd0a87 2772 if (flags)
6224f72b
GS
2773 return GvAVn(gv);
2774 if (gv)
2775 return GvAV(gv);
7d49f689 2776 return NULL;
6224f72b
GS
2777}
2778
954c1994 2779/*
ccfc67b7
JH
2780=head1 Hash Manipulation Functions
2781
954c1994
GS
2782=for apidoc p||get_hv
2783
6673a63c 2784Returns the HV of the specified Perl hash. C<flags> are passed to
72d33970 2785C<gv_fetchpv>. If C<GV_ADD> is set and the
6673a63c 2786Perl variable does not exist then it will be created. If C<flags> is zero
796b6530 2787and the variable does not exist then C<NULL> is returned.
954c1994
GS
2788
2789=cut
2790*/
2791
6224f72b 2792HV*
6673a63c 2793Perl_get_hv(pTHX_ const char *name, I32 flags)
6224f72b 2794{
6673a63c 2795 GV* const gv = gv_fetchpv(name, flags, SVt_PVHV);
7918f24d
NC
2796
2797 PERL_ARGS_ASSERT_GET_HV;
2798
6673a63c 2799 if (flags)
a0d0e21e
LW
2800 return GvHVn(gv);
2801 if (gv)
2802 return GvHV(gv);
5c284bb0 2803 return NULL;
a0d0e21e
LW
2804}
2805
954c1994 2806/*
ccfc67b7
JH
2807=head1 CV Manipulation Functions
2808
780a5241
NC
2809=for apidoc p||get_cvn_flags
2810
2811Returns the CV of the specified Perl subroutine. C<flags> are passed to
72d33970 2812C<gv_fetchpvn_flags>. If C<GV_ADD> is set and the Perl subroutine does not
780a5241
NC
2813exist then it will be declared (which has the same effect as saying
2814C<sub name;>). If C<GV_ADD> is not set and the subroutine does not exist
2815then NULL is returned.
2816
954c1994
GS
2817=for apidoc p||get_cv
2818
780a5241 2819Uses C<strlen> to get the length of C<name>, then calls C<get_cvn_flags>.
954c1994
GS
2820
2821=cut
2822*/
2823
a0d0e21e 2824CV*
780a5241 2825Perl_get_cvn_flags(pTHX_ const char *name, STRLEN len, I32 flags)
a0d0e21e 2826{
780a5241 2827 GV* const gv = gv_fetchpvn_flags(name, len, flags, SVt_PVCV);
7918f24d
NC
2828
2829 PERL_ARGS_ASSERT_GET_CVN_FLAGS;
2830
a385812b 2831 if (gv && UNLIKELY(SvROK(gv)) && SvTYPE(SvRV((SV *)gv)) == SVt_PVCV)
e05a85b2 2832 return (CV*)SvRV((SV *)gv);
a385812b 2833
334dda80
FC
2834 /* XXX this is probably not what they think they're getting.
2835 * It has the same effect as "sub name;", i.e. just a forward
2836 * declaration! */
780a5241 2837 if ((flags & ~GV_NOADD_MASK) && !GvCVu(gv)) {
186a5ba8 2838 return newSTUB(gv,0);
780a5241 2839 }
a0d0e21e 2840 if (gv)
8ebc5c01 2841 return GvCVu(gv);
601f1833 2842 return NULL;
a0d0e21e
LW
2843}
2844
2c67934f
NC
2845/* Nothing in core calls this now, but we can't replace it with a macro and
2846 move it to mathoms.c as a macro would evaluate name twice. */
780a5241
NC
2847CV*
2848Perl_get_cv(pTHX_ const char *name, I32 flags)
2849{
7918f24d
NC
2850 PERL_ARGS_ASSERT_GET_CV;
2851
780a5241
NC
2852 return get_cvn_flags(name, strlen(name), flags);
2853}
2854
79072805
LW
2855/* Be sure to refetch the stack pointer after calling these routines. */
2856
954c1994 2857/*
ccfc67b7
JH
2858
2859=head1 Callback Functions
2860
954c1994
GS
2861=for apidoc p||call_argv
2862
f0b90de1 2863Performs a callback to the specified named and package-scoped Perl subroutine
796b6530 2864with C<argv> (a C<NULL>-terminated array of strings) as arguments. See
72d33970 2865L<perlcall>.
f0b90de1
SF
2866
2867Approximate Perl equivalent: C<&{"$sub_name"}(@$argv)>.
954c1994
GS
2868
2869=cut
2870*/
2871
a0d0e21e 2872I32
5aaab254 2873Perl_call_argv(pTHX_ const char *sub_name, I32 flags, char **argv)
ac27b0f5 2874
8ac85365
NIS
2875 /* See G_* flags in cop.h */
2876 /* null terminated arg list */
8990e307 2877{
a0d0e21e 2878 dSP;
8990e307 2879
7918f24d
NC
2880 PERL_ARGS_ASSERT_CALL_ARGV;
2881
924508f0 2882 PUSHMARK(SP);
3dc78631
DM
2883 while (*argv) {
2884 mXPUSHs(newSVpv(*argv,0));
2885 argv++;
8990e307 2886 }
3dc78631 2887 PUTBACK;
864dbfa3 2888 return call_pv(sub_name, flags);
8990e307
LW
2889}
2890
954c1994
GS
2891/*
2892=for apidoc p||call_pv
2893
2894Performs a callback to the specified Perl sub. See L<perlcall>.
2895
2896=cut
2897*/
2898
a0d0e21e 2899I32
864dbfa3 2900Perl_call_pv(pTHX_ const char *sub_name, I32 flags)
8ac85365
NIS
2901 /* name of the subroutine */
2902 /* See G_* flags in cop.h */
a0d0e21e 2903{
7918f24d
NC
2904 PERL_ARGS_ASSERT_CALL_PV;
2905
0da0e728 2906 return call_sv(MUTABLE_SV(get_cv(sub_name, GV_ADD)), flags);
a0d0e21e
LW
2907}
2908
954c1994
GS
2909/*
2910=for apidoc p||call_method
2911
2912Performs a callback to the specified Perl method. The blessed object must
2913be on the stack. See L<perlcall>.
2914
2915=cut
2916*/
2917
a0d0e21e 2918I32
864dbfa3 2919Perl_call_method(pTHX_ const char *methname, I32 flags)
8ac85365
NIS
2920 /* name of the subroutine */
2921 /* See G_* flags in cop.h */
a0d0e21e 2922{
46ca9bac 2923 STRLEN len;
c106c2be 2924 SV* sv;
7918f24d
NC
2925 PERL_ARGS_ASSERT_CALL_METHOD;
2926
46ca9bac 2927 len = strlen(methname);
c106c2be
RZ
2928 sv = flags & G_METHOD_NAMED
2929 ? sv_2mortal(newSVpvn_share(methname, len,0))
2930 : newSVpvn_flags(methname, len, SVs_TEMP);
46ca9bac 2931
c106c2be 2932 return call_sv(sv, flags | G_METHOD);
a0d0e21e
LW
2933}
2934
2935/* May be called with any of a CV, a GV, or an SV containing the name. */
954c1994
GS
2936/*
2937=for apidoc p||call_sv
2938
078e2213
TC
2939Performs a callback to the Perl sub specified by the SV.
2940
7c0c544c 2941If neither the C<G_METHOD> nor C<G_METHOD_NAMED> flag is supplied, the
078e2213
TC
2942SV may be any of a CV, a GV, a reference to a CV, a reference to a GV
2943or C<SvPV(sv)> will be used as the name of the sub to call.
2944
2945If the C<G_METHOD> flag is supplied, the SV may be a reference to a CV or
2946C<SvPV(sv)> will be used as the name of the method to call.
2947
2948If the C<G_METHOD_NAMED> flag is supplied, C<SvPV(sv)> will be used as
2949the name of the method to call.
2950
2951Some other values are treated specially for internal use and should
2952not be depended on.
2953
2954See L<perlcall>.
954c1994
GS
2955
2956=cut
2957*/
2958
a0d0e21e 2959I32
8162b70e 2960Perl_call_sv(pTHX_ SV *sv, volatile I32 flags)
8ac85365 2961 /* See G_* flags in cop.h */
a0d0e21e 2962{
5b434c73 2963 dVAR;
a0d0e21e 2964 LOGOP myop; /* fake syntax tree node */
b46e009d 2965 METHOP method_op;
aa689395 2966 I32 oldmark;
8162b70e 2967 volatile I32 retval = 0;
54310121 2968 bool oldcatch = CATCH_GET;
6224f72b 2969 int ret;
c4420975 2970 OP* const oldop = PL_op;
db36c5a1 2971 dJMPENV;
1e422769 2972
7918f24d
NC
2973 PERL_ARGS_ASSERT_CALL_SV;
2974
a0d0e21e
LW
2975 if (flags & G_DISCARD) {
2976 ENTER;
2977 SAVETMPS;
2978 }
2f8edad0
NC
2979 if (!(flags & G_WANT)) {
2980 /* Backwards compatibility - as G_SCALAR was 0, it could be omitted.
2981 */
2982 flags |= G_SCALAR;
2983 }
a0d0e21e 2984
aa689395 2985 Zero(&myop, 1, LOGOP);
f51d4af5 2986 if (!(flags & G_NOARGS))
aa689395 2987 myop.op_flags |= OPf_STACKED;
4f911530 2988 myop.op_flags |= OP_GIMME_REVERSE(flags);
462e5cf6 2989 SAVEOP();
533c011a 2990 PL_op = (OP*)&myop;
aa689395 2991
8c9009ad 2992 if (!(flags & G_METHOD_NAMED)) {
5b434c73
DD
2993 dSP;
2994 EXTEND(SP, 1);
8c9009ad
DD
2995 PUSHs(sv);
2996 PUTBACK;
5b434c73 2997 }
aa689395 2998 oldmark = TOPMARK;
a0d0e21e 2999
3280af22 3000 if (PERLDB_SUB && PL_curstash != PL_debstash
36477c24 3001 /* Handle first BEGIN of -d. */
3280af22 3002 && (PL_DBcv || (PL_DBcv = GvCV(PL_DBsub)))
36477c24
PP
3003 /* Try harder, since this may have been a sighandler, thus
3004 * curstash may be meaningless. */
ea726b52 3005 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((const CV *)sv) != PL_debstash)
491527d0 3006 && !(flags & G_NODEBUG))
5ff48db8 3007 myop.op_private |= OPpENTERSUB_DB;
a0d0e21e 3008
c106c2be 3009 if (flags & (G_METHOD|G_METHOD_NAMED)) {
b46e009d 3010 Zero(&method_op, 1, METHOP);
3011 method_op.op_next = (OP*)&myop;
3012 PL_op = (OP*)&method_op;
c106c2be 3013 if ( flags & G_METHOD_NAMED ) {
b46e009d 3014 method_op.op_ppaddr = PL_ppaddr[OP_METHOD_NAMED];
3015 method_op.op_type = OP_METHOD_NAMED;
3016 method_op.op_u.op_meth_sv = sv;
c106c2be 3017 } else {
b46e009d 3018 method_op.op_ppaddr = PL_ppaddr[OP_METHOD];
3019 method_op.op_type = OP_METHOD;
c106c2be
RZ
3020 }
3021 myop.op_ppaddr = PL_ppaddr[OP_ENTERSUB];
3022 myop.op_type = OP_ENTERSUB;
968b3946
GS
3023 }
3024
312caa8e 3025 if (!(flags & G_EVAL)) {
0cdb2077 3026 CATCH_SET(TRUE);
d6f07c05 3027 CALL_BODY_SUB((OP*)&myop);
312caa8e 3028 retval = PL_stack_sp - (PL_stack_base + oldmark);
0253cb41 3029 CATCH_SET(oldcatch);
312caa8e
CS
3030 }
3031 else {
8e90e786 3032 I32 old_cxix;
d78bda3d 3033 myop.op_other = (OP*)&myop;
101d6365 3034 (void)POPMARK;
8e90e786 3035 old_cxix = cxstack_ix;
274ed8ae 3036 create_eval_scope(NULL, flags|G_FAKINGEVAL);
c318a6ee 3037 INCMARK;
a0d0e21e 3038
14dd3ad8 3039 JMPENV_PUSH(ret);
edb2152a 3040
6224f72b
GS
3041 switch (ret) {
3042 case 0:
14dd3ad8 3043 redo_body:
d6f07c05 3044 CALL_BODY_SUB((OP*)&myop);
312caa8e 3045 retval = PL_stack_sp - (PL_stack_base + oldmark);
8433848b 3046 if (!(flags & G_KEEPERR)) {
ab69dbc2 3047 CLEAR_ERRSV();
8433848b 3048 }
a0d0e21e 3049 break;
6224f72b 3050 case 1:
f86702cc 3051 STATUS_ALL_FAILURE;
924ba076 3052 /* FALLTHROUGH */
6224f72b 3053 case 2:
a0d0e21e 3054 /* my_exit() was called */
03d9f026 3055 SET_CURSTASH(PL_defstash);
a0d0e21e 3056 FREETMPS;
14dd3ad8 3057 JMPENV_POP;
f86702cc 3058 my_exit_jump();
e5964223 3059 NOT_REACHED; /* NOTREACHED */
6224f72b 3060 case 3:
3280af22 3061 if (PL_restartop) {
febb3a6d 3062 PL_restartjmpenv = NULL;
533c011a 3063 PL_op = PL_restartop;
3280af22 3064 PL_restartop = 0;
312caa8e 3065 goto redo_body;
a0d0e21e 3066 }
3280af22 3067 PL_stack_sp = PL_stack_base + oldmark;
51ce5529 3068 if ((flags & G_WANT) == G_ARRAY)
a0d0e21e
LW
3069 retval = 0;
3070 else {
3071 retval = 1;
3280af22 3072 *++PL_stack_sp = &PL_sv_undef;
a0d0e21e 3073 }
312caa8e 3074 break;
a0d0e21e 3075 }
a0d0e21e 3076
8e90e786
DM
3077 /* if we croaked, depending on how we croaked the eval scope
3078 * may or may not have already been popped */
3079 if (cxstack_ix > old_cxix) {
3080 assert(cxstack_ix == old_cxix + 1);
4ebe6e95 3081 assert(CxTYPE(CX_CUR()) == CXt_EVAL);
edb2152a 3082 delete_eval_scope();
8e90e786 3083 }
14dd3ad8 3084 JMPENV_POP;
a0d0e21e 3085 }
1e422769 3086
a0d0e21e 3087 if (flags & G_DISCARD) {
3280af22 3088 PL_stack_sp = PL_stack_base + oldmark;
a0d0e21e
LW
3089 retval = 0;
3090 FREETMPS;
3091 LEAVE;
3092 }
533c011a 3093 PL_op = oldop;
a0d0e21e
LW
3094 return retval;
3095}
3096
6e72f9df 3097/* Eval a string. The G_EVAL flag is always assumed. */
8990e307 3098
954c1994
GS
3099/*
3100=for apidoc p||eval_sv
3101
72d33970 3102Tells Perl to C<eval> the string in the SV. It supports the same flags
796b6530 3103as C<call_sv>, with the obvious exception of C<G_EVAL>. See L<perlcall>.
954c1994
GS
3104
3105=cut
3106*/
3107
a0d0e21e 3108I32
864dbfa3 3109Perl_eval_sv(pTHX_ SV *sv, I32 flags)
ac27b0f5 3110
8ac85365 3111 /* See G_* flags in cop.h */
a0d0e21e 3112{
97aff369 3113 dVAR;
a0d0e21e 3114 UNOP myop; /* fake syntax tree node */
8162b70e
AC
3115 volatile I32 oldmark;
3116 volatile I32 retval = 0;
6224f72b 3117 int ret;
c4420975 3118 OP* const oldop = PL_op;
db36c5a1 3119 dJMPENV;
84902520 3120
7918f24d
NC
3121 PERL_ARGS_ASSERT_EVAL_SV;
3122
4633a7c4
LW
3123 if (flags & G_DISCARD) {
3124 ENTER;
3125 SAVETMPS;
3126 }
3127
462e5cf6 3128 SAVEOP();
533c011a 3129 PL_op = (OP*)&myop;
5ff48db8 3130 Zero(&myop, 1, UNOP);
5b434c73
DD
3131 {
3132 dSP;
3133 oldmark = SP - PL_stack_base;
3134 EXTEND(SP, 1);
3135 PUSHs(sv);
3136 PUTBACK;
3137 }
79072805 3138
4633a7c4
LW
3139 if (!(flags & G_NOARGS))
3140 myop.op_flags = OPf_STACKED;
6e72f9df 3141 myop.op_type = OP_ENTEREVAL;
4f911530 3142 myop.op_flags |= OP_GIMME_REVERSE(flags);
6e72f9df
PP
3143 if (flags & G_KEEPERR)
3144 myop.op_flags |= OPf_SPECIAL;
a1941760
DM
3145
3146 if (flags & G_RE_REPARSING)
3147 myop.op_private = (OPpEVAL_COPHH | OPpEVAL_RE_REPARSING);
4633a7c4 3148
dedbcade 3149 /* fail now; otherwise we could fail after the JMPENV_PUSH but
13febba5 3150 * before a cx_pusheval(), which corrupts the stack after a croak */
dedbcade
DM
3151 TAINT_PROPER("eval_sv()");
3152
14dd3ad8 3153 JMPENV_PUSH(ret);
6224f72b
GS
3154 switch (ret) {
3155 case 0:
14dd3ad8 3156 redo_body:
2ba65d5f
DM
3157 if (PL_op == (OP*)(&myop)) {
3158 PL_op = PL_ppaddr[OP_ENTEREVAL](aTHX);
3159 if (!PL_op)
3160 goto fail; /* failed in compilation */
3161 }
4aca2f62 3162 CALLRUNOPS(aTHX);
312caa8e 3163 retval = PL_stack_sp - (PL_stack_base + oldmark);
8433848b 3164 if (!(flags & G_KEEPERR)) {
ab69dbc2 3165 CLEAR_ERRSV();
8433848b 3166 }
4633a7c4 3167 break;
6224f72b 3168 case 1:
f86702cc 3169 STATUS_ALL_FAILURE;
924ba076 3170 /* FALLTHROUGH */
6224f72b 3171 case 2:
4633a7c4 3172 /* my_exit() was called */
03d9f026 3173 SET_CURSTASH(PL_defstash);
4633a7c4 3174 FREETMPS;
14dd3ad8 3175 JMPENV_POP;
f86702cc 3176 my_exit_jump();
e5964223 3177 NOT_REACHED; /* NOTREACHED */
6224f72b 3178 case 3:
3280af22 3179 if (PL_restartop) {
febb3a6d 3180 PL_restartjmpenv = NULL;
533c011a 3181 PL_op = PL_restartop;
3280af22 3182 PL_restartop = 0;
312caa8e 3183 goto redo_body;
4633a7c4 3184 }
4aca2f62 3185 fail:
3280af22 3186 PL_stack_sp = PL_stack_base + oldmark;
51ce5529 3187 if ((flags & G_WANT) == G_ARRAY)
4633a7c4
LW
3188 retval = 0;
3189 else {
3190 retval = 1;
3280af22 3191 *++PL_stack_sp = &PL_sv_undef;
4633a7c4 3192 }
312caa8e 3193 break;
4633a7c4
LW
3194 }
3195
14dd3ad8 3196 JMPENV_POP;
4633a7c4 3197 if (flags & G_DISCARD) {
3280af22 3198 PL_stack_sp = PL_stack_base + oldmark;
4633a7c4
LW
3199 retval = 0;
3200 FREETMPS;
3201 LEAVE;
3202 }
533c011a 3203 PL_op = oldop;
4633a7c4
LW
3204 return retval;
3205}
3206
954c1994
GS
3207/*
3208=for apidoc p||eval_pv
3209
422791e4 3210Tells Perl to C<eval> the given string in scalar context and return an SV* result.
954c1994
GS
3211
3212=cut
3213*/
3214
137443ea 3215SV*
864dbfa3 3216Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error)
137443ea 3217{
137443ea
PP
3218 SV* sv = newSVpv(p, 0);
3219
7918f24d
NC
3220 PERL_ARGS_ASSERT_EVAL_PV;
3221
864dbfa3 3222 eval_sv(sv, G_SCALAR);
137443ea
PP
3223 SvREFCNT_dec(sv);
3224
ed1786ad
DD
3225 {
3226 dSP;
3227 sv = POPs;
3228 PUTBACK;
3229 }
137443ea 3230
eed484f9
DD
3231 /* just check empty string or undef? */
3232 if (croak_on_error) {
3233 SV * const errsv = ERRSV;
3234 if(SvTRUE_NN(errsv))
3235 /* replace with croak_sv? */
3236 Perl_croak_nocontext("%s", SvPV_nolen_const(errsv));
2d8e6c8d 3237 }
137443ea
PP
3238
3239 return sv;
3240}
3241
4633a7c4
LW
3242/* Require a module. */
3243
954c1994 3244/*
ccfc67b7
JH
3245=head1 Embedding Functions
3246
954c1994
GS
3247=for apidoc p||require_pv
3248
7d3fb230
BS
3249Tells Perl to C<require> the file named by the string argument. It is
3250analogous to the Perl code C<eval "require '$file'">. It's even
2307c6d0 3251implemented that way; consider using load_module instead.
954c1994 3252
7d3fb230 3253=cut */
954c1994 3254
4633a7c4 3255void
864dbfa3 3256Perl_require_pv(pTHX_ const char *pv)
4633a7c4 3257{
d3acc0f7 3258 dSP;
97aff369 3259 SV* sv;
7918f24d
NC
3260
3261 PERL_ARGS_ASSERT_REQUIRE_PV;
3262
e788e7d3 3263 PUSHSTACKi(PERLSI_REQUIRE);
be41e5d9
NC
3264 sv = Perl_newSVpvf(aTHX_ "require q%c%s%c", 0, pv, 0);
3265 eval_sv(sv_2mortal(sv), G_DISCARD);
d3acc0f7 3266 POPSTACK;
79072805
LW
3267}
3268
76e3520e 3269STATIC void
b6f82619 3270S_usage(pTHX) /* XXX move this out into a module ? */
4633a7c4 3271{
ab821d7f 3272 /* This message really ought to be max 23 lines.
75c72d73 3273 * Removed -h because the user already knows that option. Others? */
fb73857a 3274
1566c39d
NC
3275 /* Grouped as 6 lines per C string literal, to keep under the ANSI C 89
3276 minimum of 509 character string literals. */
27da23d5 3277 static const char * const usage_msg[] = {
1566c39d
NC
3278" -0[octal] specify record separator (\\0, if no argument)\n"
3279" -a autosplit mode with -n or -p (splits $_ into @F)\n"
3280" -C[number/list] enables the listed Unicode features\n"
3281" -c check syntax only (runs BEGIN and CHECK blocks)\n"
3282" -d[:debugger] run program under debugger\n"
3283" -D[number/list] set debugging flags (argument is a bit mask or alphabets)\n",
3284" -e program one line of program (several -e's allowed, omit programfile)\n"
3285" -E program like -e, but enables all optional features\n"
3286" -f don't do $sitelib/sitecustomize.pl at startup\n"
3287" -F/pattern/ split() pattern for -a switch (//'s are optional)\n"
3288" -i[extension] edit <> files in place (makes backup if extension supplied)\n"
3289" -Idirectory specify @INC/#include directory (several -I's allowed)\n",
3290" -l[octal] enable line ending processing, specifies line terminator\n"
3291" -[mM][-]module execute \"use/no module...\" before executing program\n"
3292" -n assume \"while (<>) { ... }\" loop around program\n"
3293" -p assume loop like -n but print line also, like sed\n"
3294" -s enable rudimentary parsing for switches after programfile\n"
3295" -S look for programfile using PATH environment variable\n",
3296" -t enable tainting warnings\n"
3297" -T enable tainting checks\n"
3298" -u dump core after parsing program\n"
3299" -U allow unsafe operations\n"
3300" -v print version, patchlevel and license\n"
3301" -V[:variable] print configuration summary (or a single Config.pm variable)\n",
60eaec42 3302" -w enable many useful warnings\n"
1566c39d
NC
3303" -W enable all warnings\n"
3304" -x[directory] ignore text before #!perl line (optionally cd to directory)\n"
3305" -X disable all warnings\n"
3306" \n"
3307"Run 'perldoc perl' for more help with Perl.\n\n",
fb73857a
PP
3308NULL
3309};
27da23d5 3310 const char * const *p = usage_msg;
1566c39d 3311 PerlIO *out = PerlIO_stdout();
fb73857a 3312
1566c39d
NC
3313 PerlIO_printf(out,
3314 "\nUsage: %s [switches] [--] [programfile] [arguments]\n",
b6f82619 3315 PL_origargv[0]);
fb73857a 3316 while (*p)
1566c39d 3317 PerlIO_puts(out, *p++);
b6f82619 3318 my_exit(0);
4633a7c4
LW
3319}
3320
b4ab917c
DM
3321/* convert a string of -D options (or digits) into an int.
3322 * sets *s to point to the char after the options */
3323
3324#ifdef DEBUGGING
3325int
e1ec3a88 3326Perl_get_debug_opts(pTHX_ const char **s, bool givehelp)
b4ab917c 3327{
27da23d5 3328 static const char * const usage_msgd[] = {
651b8f1a
NC
3329 " Debugging flag values: (see also -d)\n"
3330 " p Tokenizing and parsing (with v, displays parse stack)\n"
3331 " s Stack snapshots (with v, displays all stacks)\n"
3332 " l Context (loop) stack processing\n"
3333 " t Trace execution\n"
3334 " o Method and overloading resolution\n",
3335 " c String/numeric conversions\n"
3336 " P Print profiling info, source file input state\n"
3337 " m Memory and SV allocation\n"
3338 " f Format processing\n"
3339 " r Regular expression parsing and execution\n"
3340 " x Syntax tree dump\n",
3341 " u Tainting checks\n"
3342 " H Hash dump -- usurps values()\n"
3343 " X Scratchpad allocation\n"
3344 " D Cleaning up\n"
56967202 3345 " S Op slab allocation\n"
651b8f1a
NC
3346 " T Tokenising\n"
3347 " R Include reference counts of dumped variables (eg when using -Ds)\n",
3348 " J Do not s,t,P-debug (Jump over) opcodes within package DB\n"
3349 " v Verbose: use in conjunction with other flags\n"
3350 " C Copy On Write\n"
3351 " A Consistency checks on internal structures\n"
3352 " q quiet - currently only suppresses the 'EXECUTING' message\n"
3353 " M trace smart match resolution\n"
3354 " B dump suBroutine definitions, including special Blocks like BEGIN\n",
69014004 3355 " L trace some locale setting information--for Perl core development\n",
e17bc05a 3356 " i trace PerlIO layer processing\n",
e6e64d9b
JC
3357 NULL
3358 };
22ff3130 3359 UV uv = 0;
7918f24d
NC
3360
3361 PERL_ARGS_ASSERT_GET_DEBUG_OPTS;
3362
b4ab917c
DM
3363 if (isALPHA(**s)) {
3364 /* if adding extra options, remember to update DEBUG_MASK */
e17bc05a 3365 static const char debopts[] = "psltocPmfrxuUHXDSTRJvCAqMBLi";
b4ab917c 3366
0eb30aeb 3367 for (; isWORDCHAR(**s); (*s)++) {
c4420975 3368 const char * const d = strchr(debopts,**s);
b4ab917c 3369 if (d)
22ff3130 3370 uv |= 1 << (d - debopts);
b4ab917c 3371 else if (ckWARN_d(WARN_DEBUGGING))
e6e64d9b
JC
3372 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
3373 "invalid option -D%c, use -D'' to see choices\n", **s);
b4ab917c
DM
3374 }
3375 }
e6e64d9b 3376 else if (isDIGIT(**s)) {
96e440d2 3377 const char* e;
22ff3130 3378 if (grok_atoUV(*s, &uv, &e))
96e440d2 3379 *s = e;
0eb30aeb 3380 for (; isWORDCHAR(**s); (*s)++) ;
b4ab917c 3381 }
ddcf8bc1 3382 else if (givehelp) {
06e869a4 3383 const char *const *p = usage_msgd;
651b8f1a 3384 while (*p) PerlIO_puts(PerlIO_stdout(), *p++);
e6e64d9b 3385 }
22ff3130 3386 return (int)uv; /* ignore any UV->int conversion loss */
b4ab917c
DM
3387}
3388#endif
3389
79072805
LW
3390/* This routine handles any switches that can be given during run */
3391
c7030b81
NC
3392const char *
3393Perl_moreswitches(pTHX_ const char *s)
79072805 3394{
27da23d5 3395 dVAR;
84c133a0 3396 UV rschar;
0544e6df 3397 const char option = *s; /* used to remember option in -m/-M code */
79072805 3398
7918f24d
NC
3399 PERL_ARGS_ASSERT_MORESWITCHES;
3400
79072805
LW
3401 switch (*s) {
3402 case '0':
a863c7d1 3403 {
f2095865 3404 I32 flags = 0;
a3b680e6 3405 STRLEN numlen;
f2095865
JH
3406
3407 SvREFCNT_dec(PL_rs);
3408 if (s[1] == 'x' && s[2]) {
a3b680e6 3409 const char *e = s+=2;
f2095865
JH
3410 U8 *tmps;
3411
a3b680e6
AL
3412 while (*e)
3413 e++;
f2095865
JH
3414 numlen = e - s;
3415 flags = PERL_SCAN_SILENT_ILLDIGIT;
3416 rschar = (U32)grok_hex(s, &numlen, &flags, NULL);
3417 if (s + numlen < e) {
3418 rschar = 0; /* Grandfather -0xFOO as -0 -xFOO. */
3419 numlen = 0;
3420 s--;
3421 }
396482e1 3422 PL_rs = newSVpvs("");
10656159 3423 tmps = (U8*) SvGROW(PL_rs, (STRLEN)(UVCHR_SKIP(rschar) + 1));
f2095865 3424 uvchr_to_utf8(tmps, rschar);
5f560d8a 3425 SvCUR_set(PL_rs, UVCHR_SKIP(rschar));
f2095865
JH
3426 SvUTF8_on(PL_rs);
3427 }
3428 else {
3429 numlen = 4;
3430 rschar = (U32)grok_oct(s, &numlen, &flags, NULL);
3431 if (rschar & ~((U8)~0))
3432 PL_rs = &PL_sv_undef;
3433 else if (!rschar && numlen >= 2)
396482e1 3434 PL_rs = newSVpvs("");
f2095865
JH
3435 else {
3436 char ch = (char)rschar;
3437 PL_rs = newSVpvn(&ch, 1);
3438 }
3439 }
64ace3f8 3440 sv_setsv(get_sv("/", GV_ADD), PL_rs);
f2095865 3441 return s + numlen;
a863c7d1 3442 }
46487f74 3443 case 'C':
a05d7ebb 3444 s++;
dd374669 3445 PL_unicode = parse_unicode_opts( (const char **)&s );
5a22a2bb
NC
3446 if (PL_unicode & PERL_UNICODE_UTF8CACHEASSERT_FLAG)
3447 PL_utf8cache = -1;
46487f74 3448 return s;
2304df62 3449 case 'F':
5fc691f1 3450 PL_minus_a = TRUE;
3280af22 3451 PL_minus_F = TRUE;
24ffa309 3452 PL_minus_n = TRUE;
ebce5377
RGS
3453 PL_splitstr = ++s;
3454 while (*s && !isSPACE(*s)) ++s;
e49e380e 3455 PL_splitstr = savepvn(PL_splitstr, s - PL_splitstr);
2304df62 3456 return s;
79072805 3457 case 'a':
3280af22 3458 PL_minus_a = TRUE;
24ffa309 3459 PL_minus_n = TRUE;
79072805
LW
3460 s++;
3461 return s;
3462 case 'c':
3280af22 3463 PL_minus_c = TRUE;
79072805
LW
3464 s++;
3465 return s;
3466 case 'd':
f20b2998 3467 forbid_setid('d', FALSE);
4633a7c4 3468 s++;
2cbb2ee1
RGS
3469
3470 /* -dt indicates to the debugger that threads will be used */
0eb30aeb 3471 if (*s == 't' && !isWORDCHAR(s[1])) {
2cbb2ee1
RGS
3472 ++s;
3473 my_setenv("PERL5DB_THREADED", "1");
3474 }
3475
70c94a19
RR
3476 /* The following permits -d:Mod to accepts arguments following an =
3477 in the fashion that -MSome::Mod does. */
3478 if (*s == ':' || *s == '=') {
b19934fb
NC
3479 const char *start;
3480 const char *end;
3481 SV *sv;
3482
3483 if (*++s == '-') {
3484 ++s;
3485 sv = newSVpvs("no Devel::");
3486 } else {
3487 sv = newSVpvs("use Devel::");
3488 }
3489
3490 start = s;
3491 end = s + strlen(s);
f85893a1 3492
b19934fb 3493 /* We now allow -d:Module=Foo,Bar and -d:-Module */
0eb30aeb 3494 while(isWORDCHAR(*s) || *s==':') ++s;
70c94a19 3495 if (*s != '=')
f85893a1 3496 sv_catpvn(sv, start, end - start);
70c94a19
RR
3497 else {
3498 sv_catpvn(sv, start, s-start);
95a2b409
RGS
3499 /* Don't use NUL as q// delimiter here, this string goes in the
3500 * environment. */
3501 Perl_sv_catpvf(aTHX_ sv, " split(/,/,q{%s});", ++s);
70c94a19 3502 }
f85893a1 3503 s = end;
184f32ec 3504 my_setenv("PERL5DB", SvPV_nolen_const(sv));
c4db126b 3505 SvREFCNT_dec(sv);
4633a7c4 3506 }
ed094faf 3507 if (!PL_perldb) {
3280af22 3508 PL_perldb = PERLDB_ALL;
a0d0e21e 3509 init_debugger();
ed094faf 3510 }
79072805
LW
3511 return s;
3512 case 'D':
0453d815 3513 {
79072805 3514#ifdef DEBUGGING
f20b2998 3515 forbid_setid('D', FALSE);
b4ab917c