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