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