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