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