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