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