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