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