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