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