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