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