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