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