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