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