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