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