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