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
perldelta for 5afb921fc188
[perl5.git] / perl.c
CommitLineData
4b88f280 1#line 2 "perl.c"
a0d0e21e
LW		 2/* perl.c
3 *
737f4459 4 * Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001
2eee27d7 5 * 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012
010d7370 6 * by Larry Wall and others
a687059c 7 *
352d5a3a
LW		 8 * You may distribute under the terms of either the GNU General Public
9 * License or the Artistic License, as specified in the README file.
a687059c 10 *
8d063cd8
LW		 11 */
12
a0d0e21e 13/*
4ac71550
TC		 14 * A ship then new they built for him
15 * of mithril and of elven-glass
cdad3b53 16 * --from Bilbo's song of Eärendil
4ac71550
TC		 17 *
18 * [p.236 of _The Lord of the Rings_, II/i: "Many Meetings"]
a0d0e21e 19 */
45d8adaa 20
166f8a29
DM		 21/* This file contains the top-level functions that are used to create, use
22 * and destroy a perl interpreter, plus the functions used by XS code to
23 * call back into perl. Note that it does not contain the actual main()
ddfa107c 24 * function of the interpreter; that can be found in perlmain.c
166f8a29
DM		 25 */
26
c44493f1 27#if defined(PERL_IS_MINIPERL) && !defined(USE_SITECUSTOMIZE)
43c0c913
NC		 28# define USE_SITECUSTOMIZE
29#endif
30
378cc40b 31#include "EXTERN.h"
864dbfa3 32#define PERL_IN_PERL_C
378cc40b 33#include "perl.h"
e3321bb0 34#include "patchlevel.h" /* for local_patches */
4a5df386 35#include "XSUB.h"
7b8dd5f4 36#include "charclass_invlists.h"
378cc40b 37
011f1a1a
JH		 38#ifdef NETWARE
39#include "nwutil.h"
011f1a1a
JH		 40#endif
41
2aa47728 42#ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
bf357333
NC		 43# ifdef I_SYSUIO
44# include <sys/uio.h>
45# endif
46
47union control_un {
48 struct cmsghdr cm;
49 char control[CMSG_SPACE(sizeof(int))];
50};
51
2aa47728
NC		 52#endif
53
5311654c
JH		 54#ifndef HZ
55# ifdef CLK_TCK
56# define HZ CLK_TCK
57# else
58# define HZ 60
59# endif
60#endif
61
7114a2d2 62#if !defined(STANDARD_C) && !defined(HAS_GETENV_PROTOTYPE) && !defined(PERL_MICRO)
20ce7b12 63char *getenv (char *); /* Usually in <stdlib.h> */
54310121 64#endif
65
acfe0abc 66static I32 read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen);
0cb96387 67
cc69b689 68#ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
b24bc095 69# define validate_suid(rsfp) NOOP
cc69b689 70#else
b24bc095 71# define validate_suid(rsfp) S_validate_suid(aTHX_ rsfp)
a687059c 72#endif
8d063cd8 73
d6f07c05
AL		 74#define CALL_BODY_SUB(myop) \
75 if (PL_op == (myop)) \
139d0ce6 76 PL_op = PL_ppaddr[OP_ENTERSUB](aTHX); \
d6f07c05
AL		 77 if (PL_op) \
78 CALLRUNOPS(aTHX);
79
80#define CALL_LIST_BODY(cv) \
81 PUSHMARK(PL_stack_sp); \
9a8aa25b 82 call_sv(MUTABLE_SV((cv)), G_EVAL|G_DISCARD|G_VOID);
d6f07c05 83
e6827a76 84static void
daa7d858 85S_init_tls_and_interp(PerlInterpreter *my_perl)
e6827a76 86{
27da23d5 87 dVAR;
e6827a76
NC		 88 if (!PL_curinterp) {
89 PERL_SET_INTERP(my_perl);
3db8f154 90#if defined(USE_ITHREADS)
e6827a76
NC		 91 INIT_THREADS;
92 ALLOC_THREAD_KEY;
93 PERL_SET_THX(my_perl);
94 OP_REFCNT_INIT;
e8570548 95 OP_CHECK_MUTEX_INIT;
71ad1b0c 96 HINTS_REFCNT_INIT;
e6827a76 97 MUTEX_INIT(&PL_dollarzero_mutex);
016af4f1
DM		 98 MUTEX_INIT(&PL_my_ctx_mutex);
99# endif
e6827a76 100 }
c0bce9aa
NC		 101#if defined(USE_ITHREADS)
102 else
103#else
104 /* This always happens for non-ithreads */
105#endif
106 {
e6827a76
NC		 107 PERL_SET_THX(my_perl);
108 }
109}
06d86050 110
cbec8ebe
DM		 111
112/* these implement the PERL_SYS_INIT, PERL_SYS_INIT3, PERL_SYS_TERM macros */
113
114void
115Perl_sys_init(int* argc, char*** argv)
116{
4fc0badb 117 dVAR;
7918f24d
NC		 118
119 PERL_ARGS_ASSERT_SYS_INIT;
120
cbec8ebe
DM		 121 PERL_UNUSED_ARG(argc); /* may not be used depending on _BODY macro */
122 PERL_UNUSED_ARG(argv);
123 PERL_SYS_INIT_BODY(argc, argv);
124}
125
126void
127Perl_sys_init3(int* argc, char*** argv, char*** env)
128{
4fc0badb 129 dVAR;
7918f24d
NC		 130
131 PERL_ARGS_ASSERT_SYS_INIT3;
132
cbec8ebe
DM		 133 PERL_UNUSED_ARG(argc); /* may not be used depending on _BODY macro */
134 PERL_UNUSED_ARG(argv);
135 PERL_UNUSED_ARG(env);
136 PERL_SYS_INIT3_BODY(argc, argv, env);
137}
138
139void
88772978 140Perl_sys_term(void)
cbec8ebe 141{
4fc0badb 142 dVAR;
bf81751b
DM		 143 if (!PL_veto_cleanup) {
144 PERL_SYS_TERM_BODY();
145 }
cbec8ebe
DM		 146}
147
148
32e30700
GS		 149#ifdef PERL_IMPLICIT_SYS
150PerlInterpreter *
7766f137
GS		 151perl_alloc_using(struct IPerlMem* ipM, struct IPerlMem* ipMS,
152 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
32e30700
GS		 153 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
154 struct IPerlDir* ipD, struct IPerlSock* ipS,
155 struct IPerlProc* ipP)
156{
157 PerlInterpreter *my_perl;
7918f24d
NC		 158
159 PERL_ARGS_ASSERT_PERL_ALLOC_USING;
160
9f653bb5 161 /* Newx() needs interpreter, so call malloc() instead */
32e30700 162 my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
e6827a76 163 S_init_tls_and_interp(my_perl);
32e30700
GS		 164 Zero(my_perl, 1, PerlInterpreter);
165 PL_Mem = ipM;
7766f137
GS		 166 PL_MemShared = ipMS;
167 PL_MemParse = ipMP;
32e30700
GS		 168 PL_Env = ipE;
169 PL_StdIO = ipStd;
170 PL_LIO = ipLIO;
171 PL_Dir = ipD;
172 PL_Sock = ipS;
173 PL_Proc = ipP;
7cb608b5 174 INIT_TRACK_MEMPOOL(PL_memory_debug_header, my_perl);
7766f137 175
32e30700
GS		 176 return my_perl;
177}
178#else
954c1994
GS		 179
180/*
ccfc67b7
JH		 181=head1 Embedding Functions
182
954c1994
GS		 183=for apidoc perl_alloc
184
185Allocates a new Perl interpreter. See L<perlembed>.
186
187=cut
188*/
189
93a17b20 190PerlInterpreter *
cea2e8a9 191perl_alloc(void)
79072805 192{
cea2e8a9 193 PerlInterpreter *my_perl;
79072805 194
9f653bb5 195 /* Newx() needs interpreter, so call malloc() instead */
e8ee3774 196 my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
ba869deb 197
e6827a76 198 S_init_tls_and_interp(my_perl);
7cb608b5 199#ifndef PERL_TRACK_MEMPOOL
07409e01 200 return (PerlInterpreter *) ZeroD(my_perl, 1, PerlInterpreter);
7cb608b5
NC		 201#else
202 Zero(my_perl, 1, PerlInterpreter);
203 INIT_TRACK_MEMPOOL(PL_memory_debug_header, my_perl);
204 return my_perl;
205#endif
79072805 206}
32e30700 207#endif /* PERL_IMPLICIT_SYS */
79072805 208
954c1994
GS		 209/*
210=for apidoc perl_construct
211
212Initializes a new Perl interpreter. See L<perlembed>.
213
214=cut
215*/
216
79072805 217void
0cb96387 218perl_construct(pTHXx)
79072805 219{
27da23d5 220 dVAR;
7918f24d
NC		 221
222 PERL_ARGS_ASSERT_PERL_CONSTRUCT;
223
8990e307 224#ifdef MULTIPLICITY
54aff467 225 init_interp();
ac27b0f5 226 PL_perl_destruct_level = 1;
54aff467 227#else
7918f24d 228 PERL_UNUSED_ARG(my_perl);
54aff467
GS		 229 if (PL_perl_destruct_level > 0)
230 init_interp();
231#endif
34caed6d
DM		 232 PL_curcop = &PL_compiling; /* needed by ckWARN, right away */
233
75d476e2
S		 234#ifdef PERL_TRACE_OPS
235 Zero(PL_op_exec_cnt, OP_max+2, UV);
236#endif
237
0d96b528 238 init_constants();
34caed6d
DM		 239
240 SvREADONLY_on(&PL_sv_placeholder);
fe54beba 241 SvREFCNT(&PL_sv_placeholder) = SvREFCNT_IMMORTAL;
34caed6d
DM		 242
243 PL_sighandlerp = (Sighandler_t) Perl_sighandler;
ca0c25f6 244#ifdef PERL_USES_PL_PIDSTATUS
34caed6d 245 PL_pidstatus = newHV();
ca0c25f6 246#endif
79072805 247
396482e1 248 PL_rs = newSVpvs("\n");
dc92893f 249
cea2e8a9 250 init_stacks();
79072805 251
748a9306 252 init_ids();
a5f75d66 253
312caa8e 254 JMPENV_BOOTSTRAP;
f86702cc 255 STATUS_ALL_SUCCESS;
256
0672f40e 257 init_i18nl10n(1);
0b5b802d 258
ab821d7f 259#if defined(LOCAL_PATCH_COUNT)
3280af22 260 PL_localpatches = local_patches; /* For possible -v */
ab821d7f 261#endif
262
52853b95
GS		 263#ifdef HAVE_INTERP_INTERN
264 sys_intern_init();
265#endif
266
3a1ee7e8 267 PerlIO_init(aTHX); /* Hook to IO system */
760ac839 268
3280af22
NIS		 269 PL_fdpid = newAV(); /* for remembering popen pids by fd */
270 PL_modglobal = newHV(); /* pointers to per-interpreter module globals */
396482e1 271 PL_errors = newSVpvs("");
76f68e9b
MHM		 272 sv_setpvs(PERL_DEBUG_PAD(0), ""); /* For regex debugging. */
273 sv_setpvs(PERL_DEBUG_PAD(1), ""); /* ext/re needs these */
274 sv_setpvs(PERL_DEBUG_PAD(2), ""); /* even without DEBUGGING. */
1fcf4c12 275#ifdef USE_ITHREADS
402d2eb1
NC		 276 /* First entry is a list of empty elements. It needs to be initialised
277 else all hell breaks loose in S_find_uninit_var(). */
278 Perl_av_create_and_push(aTHX_ &PL_regex_padav, newSVpvs(""));
13137afc 279 PL_regex_pad = AvARRAY(PL_regex_padav);
d4d03940 280 Newxz(PL_stashpad, PL_stashpadmax, HV *);
1fcf4c12 281#endif
e5dd39fc 282#ifdef USE_REENTRANT_API
59bd0823 283 Perl_reentrant_init(aTHX);
e5dd39fc 284#endif
7dc86639
YO		 285#if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT)
286 /* [perl #22371] Algorimic Complexity Attack on Perl 5.6.1, 5.8.0
287 * This MUST be done before any hash stores or fetches take place.
288 * If you set PL_hash_seed (and presumably also PL_hash_seed_set)
289 * yourself, it is your responsibility to provide a good random seed!
290 * You can also define PERL_HASH_SEED in compile time, see hv.h.
291 *
292 * XXX: fix this comment */
293 if (PL_hash_seed_set == FALSE) {
294 Perl_get_hash_seed(aTHX_ PL_hash_seed);
295 PL_hash_seed_set= TRUE;
296 }
297#endif /* #if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT) */
3d47000e
AB		 298
299 /* Note that strtab is a rather special HV. Assumptions are made
300 about not iterating on it, and not adding tie magic to it.
301 It is properly deallocated in perl_destruct() */
302 PL_strtab = newHV();
303
3d47000e
AB		 304 HvSHAREKEYS_off(PL_strtab); /* mandatory */
305 hv_ksplit(PL_strtab, 512);
306
a38ab475
RZ		 307 Zero(PL_sv_consts, SV_CONSTS_COUNT, SV*);
308
2f42fcb0
JH		 309#ifndef PERL_MICRO
310# ifdef USE_ENVIRON_ARRAY
0631ea03 311 PL_origenviron = environ;
2f42fcb0 312# endif
0631ea03
AB		 313#endif
314
5311654c 315 /* Use sysconf(_SC_CLK_TCK) if available, if not
dbc1d986 316 * available or if the sysconf() fails, use the HZ.
27da23d5
JH		 317 * The HZ if not originally defined has been by now
318 * been defined as CLK_TCK, if available. */
b6c36746 319#if defined(HAS_SYSCONF) && defined(_SC_CLK_TCK)
5311654c
JH		 320 PL_clocktick = sysconf(_SC_CLK_TCK);
321 if (PL_clocktick <= 0)
322#endif
323 PL_clocktick = HZ;
324
081fc587
AB		 325 PL_stashcache = newHV();
326
e8e3635e 327 PL_patchlevel = newSVpvs("v" PERL_VERSION_STRING);
1e8125c6 328 PL_apiversion = newSVpvs("v" PERL_API_VERSION_STRING);
d7aa5382 329
27da23d5
JH		 330#ifdef HAS_MMAP
331 if (!PL_mmap_page_size) {
332#if defined(HAS_SYSCONF) && (defined(_SC_PAGESIZE) || defined(_SC_MMAP_PAGE_SIZE))
333 {
334 SETERRNO(0, SS_NORMAL);
335# ifdef _SC_PAGESIZE
336 PL_mmap_page_size = sysconf(_SC_PAGESIZE);
337# else
338 PL_mmap_page_size = sysconf(_SC_MMAP_PAGE_SIZE);
339# endif
340 if ((long) PL_mmap_page_size < 0) {
341 if (errno) {
44f8325f 342 SV * const error = ERRSV;
d4c19fe8 343 SvUPGRADE(error, SVt_PV);
0510663f 344 Perl_croak(aTHX_ "panic: sysconf: %s", SvPV_nolen_const(error));
27da23d5
JH		 345 }
346 else
347 Perl_croak(aTHX_ "panic: sysconf: pagesize unknown");
348 }
349 }
350#else
351# ifdef HAS_GETPAGESIZE
352 PL_mmap_page_size = getpagesize();
353# else
354# if defined(I_SYS_PARAM) && defined(PAGESIZE)
355 PL_mmap_page_size = PAGESIZE; /* compiletime, bad */
356# endif
357# endif
358#endif
359 if (PL_mmap_page_size <= 0)
360 Perl_croak(aTHX_ "panic: bad pagesize %" IVdf,
361 (IV) PL_mmap_page_size);
362 }
363#endif /* HAS_MMAP */
364
365#if defined(HAS_TIMES) && defined(PERL_NEED_TIMESBASE)
366 PL_timesbase.tms_utime = 0;
367 PL_timesbase.tms_stime = 0;
368 PL_timesbase.tms_cutime = 0;
369 PL_timesbase.tms_cstime = 0;
370#endif
371
7d113631
NC		 372 PL_osname = Perl_savepvn(aTHX_ STR_WITH_LEN(OSNAME));
373
a3e6e81e 374 PL_registered_mros = newHV();
9e169432
NC		 375 /* Start with 1 bucket, for DFS. It's unlikely we'll need more. */
376 HvMAX(PL_registered_mros) = 0;
a3e6e81e 377
7b8dd5f4
KW		 378 PL_XPosix_ptrs[_CC_ASCII] = _new_invlist_C_array(ASCII_invlist);
379 PL_XPosix_ptrs[_CC_ALPHANUMERIC] = _new_invlist_C_array(XPosixAlnum_invlist);
380 PL_XPosix_ptrs[_CC_ALPHA] = _new_invlist_C_array(XPosixAlpha_invlist);
381 PL_XPosix_ptrs[_CC_BLANK] = _new_invlist_C_array(XPosixBlank_invlist);
382 PL_XPosix_ptrs[_CC_CASED] = _new_invlist_C_array(Cased_invlist);
383 PL_XPosix_ptrs[_CC_CNTRL] = _new_invlist_C_array(XPosixCntrl_invlist);
384 PL_XPosix_ptrs[_CC_DIGIT] = _new_invlist_C_array(XPosixDigit_invlist);
385 PL_XPosix_ptrs[_CC_GRAPH] = _new_invlist_C_array(XPosixGraph_invlist);
386 PL_XPosix_ptrs[_CC_LOWER] = _new_invlist_C_array(XPosixLower_invlist);
387 PL_XPosix_ptrs[_CC_PRINT] = _new_invlist_C_array(XPosixPrint_invlist);
388 PL_XPosix_ptrs[_CC_PUNCT] = _new_invlist_C_array(XPosixPunct_invlist);
389 PL_XPosix_ptrs[_CC_SPACE] = _new_invlist_C_array(XPerlSpace_invlist);
390 PL_XPosix_ptrs[_CC_PSXSPC] = _new_invlist_C_array(XPosixSpace_invlist);
391 PL_XPosix_ptrs[_CC_UPPER] = _new_invlist_C_array(XPosixUpper_invlist);
392 PL_XPosix_ptrs[_CC_VERTSPACE] = _new_invlist_C_array(VertSpace_invlist);
393 PL_XPosix_ptrs[_CC_WORDCHAR] = _new_invlist_C_array(XPosixWord_invlist);
394 PL_XPosix_ptrs[_CC_XDIGIT] = _new_invlist_C_array(XPosixXDigit_invlist);
395
8990e307 396 ENTER;
79072805
LW		 397}
398
954c1994 399/*
62375a60
NIS		 400=for apidoc nothreadhook
401
402Stub that provides thread hook for perl_destruct when there are
403no threads.
404
405=cut
406*/
407
408int
4e9e3734 409Perl_nothreadhook(pTHX)
62375a60 410{
96a5add6 411 PERL_UNUSED_CONTEXT;
62375a60
NIS		 412 return 0;
413}
414
41e4abd8
NC		 415#ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
416void
417Perl_dump_sv_child(pTHX_ SV *sv)
418{
419 ssize_t got;
bf357333
NC		 420 const int sock = PL_dumper_fd;
421 const int debug_fd = PerlIO_fileno(Perl_debug_log);
bf357333
NC		 422 union control_un control;
423 struct msghdr msg;
808ad2d0 424 struct iovec vec[2];
bf357333 425 struct cmsghdr *cmptr;
808ad2d0
NC		 426 int returned_errno;
427 unsigned char buffer[256];
41e4abd8 428
7918f24d
NC		 429 PERL_ARGS_ASSERT_DUMP_SV_CHILD;
430
bf357333 431 if(sock == -1 || debug_fd == -1)
41e4abd8
NC		 432 return;
433
434 PerlIO_flush(Perl_debug_log);
435
bf357333
NC		 436 /* All these shenanigans are to pass a file descriptor over to our child for
437 it to dump out to. We can't let it hold open the file descriptor when it
438 forks, as the file descriptor it will dump to can turn out to be one end
439 of pipe that some other process will wait on for EOF. (So as it would
b293a5f8 440 be open, the wait would be forever.) */
bf357333
NC		 441
442 msg.msg_control = control.control;
443 msg.msg_controllen = sizeof(control.control);
444 /* We're a connected socket so we don't need a destination */
445 msg.msg_name = NULL;
446 msg.msg_namelen = 0;
447 msg.msg_iov = vec;
808ad2d0 448 msg.msg_iovlen = 1;
bf357333
NC		 449
450 cmptr = CMSG_FIRSTHDR(&msg);
451 cmptr->cmsg_len = CMSG_LEN(sizeof(int));
452 cmptr->cmsg_level = SOL_SOCKET;
453 cmptr->cmsg_type = SCM_RIGHTS;
454 *((int *)CMSG_DATA(cmptr)) = 1;
455
456 vec[0].iov_base = (void*)&sv;
457 vec[0].iov_len = sizeof(sv);
458 got = sendmsg(sock, &msg, 0);
41e4abd8
NC		 459
460 if(got < 0) {
bf357333 461 perror("Debug leaking scalars parent sendmsg failed");
41e4abd8
NC		 462 abort();
463 }
bf357333
NC		 464 if(got < sizeof(sv)) {
465 perror("Debug leaking scalars parent short sendmsg");
41e4abd8
NC		 466 abort();
467 }
468
808ad2d0
NC		 469 /* Return protocol is
470 int: errno value
471 unsigned char: length of location string (0 for empty)
472 unsigned char*: string (not terminated)
473 */
474 vec[0].iov_base = (void*)&returned_errno;
475 vec[0].iov_len = sizeof(returned_errno);
476 vec[1].iov_base = buffer;
477 vec[1].iov_len = 1;
478
479 got = readv(sock, vec, 2);
41e4abd8
NC		 480
481 if(got < 0) {
482 perror("Debug leaking scalars parent read failed");
808ad2d0 483 PerlIO_flush(PerlIO_stderr());
41e4abd8
NC		 484 abort();
485 }
808ad2d0 486 if(got < sizeof(returned_errno) + 1) {
41e4abd8 487 perror("Debug leaking scalars parent short read");
808ad2d0 488 PerlIO_flush(PerlIO_stderr());
41e4abd8
NC		 489 abort();
490 }
491
808ad2d0
NC		 492 if (*buffer) {
493 got = read(sock, buffer + 1, *buffer);
494 if(got < 0) {
495 perror("Debug leaking scalars parent read 2 failed");
496 PerlIO_flush(PerlIO_stderr());
497 abort();
498 }
499
500 if(got < *buffer) {
501 perror("Debug leaking scalars parent short read 2");
502 PerlIO_flush(PerlIO_stderr());
503 abort();
504 }
505 }
506
507 if (returned_errno || *buffer) {
508 Perl_warn(aTHX_ "Debug leaking scalars child failed%s%.*s with errno"
509 " %d: %s", (*buffer ? " at " : ""), (int) *buffer, buffer + 1,
0c0d42ff 510 returned_errno, Strerror(returned_errno));
41e4abd8
NC		 511 }
512}
513#endif
514
62375a60 515/*
954c1994
GS		 516=for apidoc perl_destruct
517
518Shuts down a Perl interpreter. See L<perlembed>.
519
520=cut
521*/
522
31d77e54 523int
0cb96387 524perl_destruct(pTHXx)
79072805 525{
27da23d5 526 dVAR;
be2ea8ed 527 VOL signed char destruct_level; /* see possible values in intrpvar.h */
a0d0e21e 528 HV *hv;
2aa47728 529#ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
2aa47728
NC		 530 pid_t child;
531#endif
9c0b6888 532 int i;
8990e307 533
7918f24d
NC		 534 PERL_ARGS_ASSERT_PERL_DESTRUCT;
535#ifndef MULTIPLICITY
ed6c66dd 536 PERL_UNUSED_ARG(my_perl);
7918f24d 537#endif
9d4ba2ae 538
3d22c4f0
GG		 539 assert(PL_scopestack_ix == 1);
540
7766f137
GS		 541 /* wait for all pseudo-forked children to finish */
542 PERL_WAIT_FOR_CHILDREN;
543
3280af22 544 destruct_level = PL_perl_destruct_level;
36e77d41 545#if defined(DEBUGGING) || defined(PERL_TRACK_MEMPOOL)
4633a7c4 546 {
9d4ba2ae
AL		 547 const char * const s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL");
548 if (s) {
f5199772 549 const int i = atoi(s);
36e77d41
DD		 550#ifdef DEBUGGING
551 if (destruct_level < i) destruct_level = i;
552#endif
553#ifdef PERL_TRACK_MEMPOOL
f5199772
KW		 554 /* RT #114496, for perl_free */
555 PL_perl_destruct_level = i;
36e77d41 556#endif
5f05dabc 557 }
4633a7c4
LW		 558 }
559#endif
560
27da23d5 561 if (PL_exit_flags & PERL_EXIT_DESTRUCT_END) {
f3faeb53
AB		 562 dJMPENV;
563 int x = 0;
564
565 JMPENV_PUSH(x);
1b6737cc 566 PERL_UNUSED_VAR(x);
9ebf26ad 567 if (PL_endav && !PL_minus_c) {
ca7b837b 568 PERL_SET_PHASE(PERL_PHASE_END);
f3faeb53 569 call_list(PL_scopestack_ix, PL_endav);
9ebf26ad 570 }
f3faeb53 571 JMPENV_POP;
26f423df 572 }
f3faeb53 573 LEAVE;
a0d0e21e 574 FREETMPS;
3d22c4f0 575 assert(PL_scopestack_ix == 0);
a0d0e21e 576
e00b64d4 577 /* Need to flush since END blocks can produce output */
f13a2bc0 578 my_fflush_all();
e00b64d4 579
75d476e2
S		 580#ifdef PERL_TRACE_OPS
581 /* If we traced all Perl OP usage, report and clean up */
582 PerlIO_printf(Perl_debug_log, "Trace of all OPs executed:\n");
583 for (i = 0; i <= OP_max; ++i) {
584 PerlIO_printf(Perl_debug_log, " %s: %"UVuf"\n", PL_op_name[i], PL_op_exec_cnt[i]);
585 PL_op_exec_cnt[i] = 0;
586 }
587 /* Utility slot for easily doing little tracing experiments in the runloop: */
588 if (PL_op_exec_cnt[OP_max+1] != 0)
589 PerlIO_printf(Perl_debug_log, " SPECIAL: %"UVuf"\n", PL_op_exec_cnt[OP_max+1]);
590 PerlIO_printf(Perl_debug_log, "\n");
591#endif
592
593
16c91539 594 if (PL_threadhook(aTHX)) {
62375a60 595 /* Threads hook has vetoed further cleanup */
c301d606 596 PL_veto_cleanup = TRUE;
37038d91 597 return STATUS_EXIT;
62375a60
NIS		 598 }
599
2aa47728
NC		 600#ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
601 if (destruct_level != 0) {
602 /* Fork here to create a child. Our child's job is to preserve the
603 state of scalars prior to destruction, so that we can instruct it
604 to dump any scalars that we later find have leaked.
605 There's no subtlety in this code - it assumes POSIX, and it doesn't
606 fail gracefully */
607 int fd[2];
608
609 if(socketpair(AF_UNIX, SOCK_STREAM, 0, fd)) {
610 perror("Debug leaking scalars socketpair failed");
611 abort();
612 }
613
614 child = fork();
615 if(child == -1) {
616 perror("Debug leaking scalars fork failed");
617 abort();
618 }
619 if (!child) {
620 /* We are the child */
3125a5a4
NC		 621 const int sock = fd[1];
622 const int debug_fd = PerlIO_fileno(Perl_debug_log);
623 int f;
808ad2d0
NC		 624 const char *where;
625 /* Our success message is an integer 0, and a char 0 */
b61433a9 626 static const char success[sizeof(int) + 1] = {0};
3125a5a4 627
2aa47728 628 close(fd[0]);
2aa47728 629
3125a5a4
NC		 630 /* We need to close all other file descriptors otherwise we end up
631 with interesting hangs, where the parent closes its end of a
632 pipe, and sits waiting for (another) child to terminate. Only
633 that child never terminates, because it never gets EOF, because
bf357333
NC		 634 we also have the far end of the pipe open. We even need to
635 close the debugging fd, because sometimes it happens to be one
636 end of a pipe, and a process is waiting on the other end for
637 EOF. Normally it would be closed at some point earlier in
638 destruction, but if we happen to cause the pipe to remain open,
639 EOF never occurs, and we get an infinite hang. Hence all the
640 games to pass in a file descriptor if it's actually needed. */
3125a5a4
NC		 641
642 f = sysconf(_SC_OPEN_MAX);
643 if(f < 0) {
808ad2d0
NC		 644 where = "sysconf failed";
645 goto abort;
3125a5a4
NC		 646 }
647 while (f--) {
648 if (f == sock)
649 continue;
3125a5a4
NC		 650 close(f);
651 }
652
2aa47728
NC		 653 while (1) {
654 SV *target;
bf357333
NC		 655 union control_un control;
656 struct msghdr msg;
657 struct iovec vec[1];
658 struct cmsghdr *cmptr;
659 ssize_t got;
660 int got_fd;
661
662 msg.msg_control = control.control;
663 msg.msg_controllen = sizeof(control.control);
664 /* We're a connected socket so we don't need a source */
665 msg.msg_name = NULL;
666 msg.msg_namelen = 0;
667 msg.msg_iov = vec;
c3caa5c3 668 msg.msg_iovlen = C_ARRAY_LENGTH(vec);
bf357333
NC		 669
670 vec[0].iov_base = (void*)&target;
671 vec[0].iov_len = sizeof(target);
672
673 got = recvmsg(sock, &msg, 0);
2aa47728
NC		 674
675 if(got == 0)
676 break;
677 if(got < 0) {
808ad2d0
NC		 678 where = "recv failed";
679 goto abort;
2aa47728
NC		 680 }
681 if(got < sizeof(target)) {
808ad2d0
NC		 682 where = "short recv";
683 goto abort;
2aa47728 684 }
bf357333 685
808ad2d0
NC		 686 if(!(cmptr = CMSG_FIRSTHDR(&msg))) {
687 where = "no cmsg";
688 goto abort;
689 }
690 if(cmptr->cmsg_len != CMSG_LEN(sizeof(int))) {
691 where = "wrong cmsg_len";
692 goto abort;
693 }
694 if(cmptr->cmsg_level != SOL_SOCKET) {
695 where = "wrong cmsg_level";
696 goto abort;
697 }
698 if(cmptr->cmsg_type != SCM_RIGHTS) {
699 where = "wrong cmsg_type";
700 goto abort;
701 }
bf357333
NC		 702
703 got_fd = *(int*)CMSG_DATA(cmptr);
704 /* For our last little bit of trickery, put the file descriptor
705 back into Perl_debug_log, as if we never actually closed it
706 */
808ad2d0
NC		 707 if(got_fd != debug_fd) {
708 if (dup2(got_fd, debug_fd) == -1) {
709 where = "dup2";
710 goto abort;
711 }
712 }
2aa47728 713 sv_dump(target);
bf357333 714
2aa47728
NC		 715 PerlIO_flush(Perl_debug_log);
716
808ad2d0 717 got = write(sock, &success, sizeof(success));
2aa47728
NC		 718
719 if(got < 0) {
808ad2d0
NC		 720 where = "write failed";
721 goto abort;
2aa47728 722 }
808ad2d0
NC		 723 if(got < sizeof(success)) {
724 where = "short write";
725 goto abort;
2aa47728
NC		 726 }
727 }
728 _exit(0);
808ad2d0
NC		 729 abort:
730 {
731 int send_errno = errno;
732 unsigned char length = (unsigned char) strlen(where);
733 struct iovec failure[3] = {
734 {(void*)&send_errno, sizeof(send_errno)},
735 {&length, 1},
736 {(void*)where, length}
737 };
738 int got = writev(sock, failure, 3);
739 /* Bad news travels fast. Faster than data. We'll get a SIGPIPE
740 in the parent if we try to read from the socketpair after the
741 child has exited, even if there was data to read.
742 So sleep a bit to give the parent a fighting chance of
743 reading the data. */
744 sleep(2);
745 _exit((got == -1) ? errno : 0);
746 }
bf357333 747 /* End of child. */
2aa47728 748 }
41e4abd8 749 PL_dumper_fd = fd[0];
2aa47728
NC		 750 close(fd[1]);
751 }
752#endif
753
ff0cee69 754 /* We must account for everything. */
755
756 /* Destroy the main CV and syntax tree */
37e77c23
FC		 757 /* Set PL_curcop now, because destroying ops can cause new SVs
758 to be generated in Perl_pad_swipe, and when running with
759 -DDEBUG_LEAKING_SCALARS they expect PL_curcop to point to a valid
760 op from which the filename structure member is copied. */
17fbfdf6 761 PL_curcop = &PL_compiling;
3280af22 762 if (PL_main_root) {
4e380990
DM		 763 /* ensure comppad/curpad to refer to main's pad */
764 if (CvPADLIST(PL_main_cv)) {
765 PAD_SET_CUR_NOSAVE(CvPADLIST(PL_main_cv), 1);
325e1816 766 PL_comppad_name = PadlistNAMES(CvPADLIST(PL_main_cv));
4e380990 767 }
3280af22 768 op_free(PL_main_root);
5f66b61c 769 PL_main_root = NULL;
a0d0e21e 770 }
5f66b61c 771 PL_main_start = NULL;
aac9d523
DM		 772 /* note that PL_main_cv isn't usually actually freed at this point,
773 * due to the CvOUTSIDE refs from subs compiled within it. It will
774 * get freed once all the subs are freed in sv_clean_all(), for
775 * destruct_level > 0 */
3280af22 776 SvREFCNT_dec(PL_main_cv);
601f1833 777 PL_main_cv = NULL;
ca7b837b 778 PERL_SET_PHASE(PERL_PHASE_DESTRUCT);
ff0cee69 779
13621cfb
NIS		 780 /* Tell PerlIO we are about to tear things apart in case
781 we have layers which are using resources that should
782 be cleaned up now.
783 */
784
785 PerlIO_destruct(aTHX);
786
ddf23d4a
S		 787 /*
788 * Try to destruct global references. We do this first so that the
789 * destructors and destructees still exist. Some sv's might remain.
790 * Non-referenced objects are on their own.
791 */
792 sv_clean_objs();
8990e307 793
5cd24f17 794 /* unhook hooks which will soon be, or use, destroyed data */
3280af22 795 SvREFCNT_dec(PL_warnhook);
a0714e2c 796 PL_warnhook = NULL;
3280af22 797 SvREFCNT_dec(PL_diehook);
a0714e2c 798 PL_diehook = NULL;
5cd24f17 799
4b556e6c 800 /* call exit list functions */
3280af22 801 while (PL_exitlistlen-- > 0)
acfe0abc 802 PL_exitlist[PL_exitlistlen].fn(aTHX_ PL_exitlist[PL_exitlistlen].ptr);
4b556e6c 803
3280af22 804 Safefree(PL_exitlist);
4b556e6c 805
1c4916e5
CB		 806 PL_exitlist = NULL;
807 PL_exitlistlen = 0;
808
a3e6e81e
NC		 809 SvREFCNT_dec(PL_registered_mros);
810
551a8b83 811 /* jettison our possibly duplicated environment */
4b647fb0
DM		 812 /* if PERL_USE_SAFE_PUTENV is defined environ will not have been copied
813 * so we certainly shouldn't free it here
814 */
2f42fcb0 815#ifndef PERL_MICRO
4b647fb0 816#if defined(USE_ENVIRON_ARRAY) && !defined(PERL_USE_SAFE_PUTENV)
50acdf95 817 if (environ != PL_origenviron && !PL_use_safe_putenv
4efc5df6
GS		 818#ifdef USE_ITHREADS
819 /* only main thread can free environ[0] contents */
820 && PL_curinterp == aTHX
821#endif
822 )
823 {
551a8b83
JH		 824 I32 i;
825
826 for (i = 0; environ[i]; i++)
4b420006 827 safesysfree(environ[i]);
0631ea03 828
4b420006
JH		 829 /* Must use safesysfree() when working with environ. */
830 safesysfree(environ);
551a8b83
JH		 831
832 environ = PL_origenviron;
833 }
834#endif
2f42fcb0 835#endif /* !PERL_MICRO */
551a8b83 836
30985c42
JH		 837 if (destruct_level == 0) {
838
839 DEBUG_P(debprofdump());
840
841#if defined(PERLIO_LAYERS)
842 /* No more IO - including error messages ! */
843 PerlIO_cleanup(aTHX);
844#endif
845
846 CopFILE_free(&PL_compiling);
30985c42
JH		 847
848 /* The exit() function will do everything that needs doing. */
849 return STATUS_EXIT;
850 }
851
9fa9f06b
KW		 852 /* Below, do clean up for when PERL_DESTRUCT_LEVEL is not 0 */
853
5f8cb046
DM		 854#ifdef USE_ITHREADS
855 /* the syntax tree is shared between clones
856 * so op_free(PL_main_root) only ReREFCNT_dec's
857 * REGEXPs in the parent interpreter
858 * we need to manually ReREFCNT_dec for the clones
859 */
0547a729
DM		 860 {
861 I32 i = AvFILLp(PL_regex_padav);
862 SV **ary = AvARRAY(PL_regex_padav);
863
864 for (; i; i--) {
865 SvREFCNT_dec(ary[i]);
866 ary[i] = &PL_sv_undef;
867 }
868 }
5f8cb046
DM		 869#endif
870
0547a729 871
ad64d0ec 872 SvREFCNT_dec(MUTABLE_SV(PL_stashcache));
081fc587
AB		 873 PL_stashcache = NULL;
874
5f05dabc 875 /* loosen bonds of global variables */
876
2f9285f8
DM		 877 /* XXX can PL_parser still be non-null here? */
878 if(PL_parser && PL_parser->rsfp) {
879 (void)PerlIO_close(PL_parser->rsfp);
880 PL_parser->rsfp = NULL;
8ebc5c01 881 }
882
84386e14
RGS		 883 if (PL_minus_F) {
884 Safefree(PL_splitstr);
885 PL_splitstr = NULL;
886 }
887
8ebc5c01 888 /* switches */
3280af22
NIS		 889 PL_minus_n = FALSE;
890 PL_minus_p = FALSE;
891 PL_minus_l = FALSE;
892 PL_minus_a = FALSE;
893 PL_minus_F = FALSE;
894 PL_doswitches = FALSE;
599cee73 895 PL_dowarn = G_WARN_OFF;
1a904fc8 896#ifdef PERL_SAWAMPERSAND
d3b97530 897 PL_sawampersand = 0; /* must save all match strings */
1a904fc8 898#endif
3280af22
NIS		 899 PL_unsafe = FALSE;
900
901 Safefree(PL_inplace);
bd61b366 902 PL_inplace = NULL;
a7cb1f99 903 SvREFCNT_dec(PL_patchlevel);
1e8125c6 904 SvREFCNT_dec(PL_apiversion);
3280af22
NIS		 905
906 if (PL_e_script) {
907 SvREFCNT_dec(PL_e_script);
a0714e2c 908 PL_e_script = NULL;
8ebc5c01 909 }
910
bf9cdc68
RG		 911 PL_perldb = 0;
912
8ebc5c01 913 /* magical thingies */
914
e23d9e2f
CS		 915 SvREFCNT_dec(PL_ofsgv); /* *, */
916 PL_ofsgv = NULL;
5f05dabc 917
7889fe52 918 SvREFCNT_dec(PL_ors_sv); /* $\ */
a0714e2c 919 PL_ors_sv = NULL;
8ebc5c01 920
3280af22 921 SvREFCNT_dec(PL_rs); /* $/ */
a0714e2c 922 PL_rs = NULL;
dc92893f 923
d33b2eba 924 Safefree(PL_osname); /* $^O */
bd61b366 925 PL_osname = NULL;
5f05dabc 926
3280af22 927 SvREFCNT_dec(PL_statname);
a0714e2c
SS		 928 PL_statname = NULL;
929 PL_statgv = NULL;
5f05dabc 930
8ebc5c01 931 /* defgv, aka *_ should be taken care of elsewhere */
932
7d5ea4e7
GS		 933 /* float buffer */
934 Safefree(PL_efloatbuf);
bd61b366 935 PL_efloatbuf = NULL;
7d5ea4e7
GS		 936 PL_efloatsize = 0;
937
8ebc5c01 938 /* startup and shutdown function lists */
3280af22 939 SvREFCNT_dec(PL_beginav);
5a837c8f 940 SvREFCNT_dec(PL_beginav_save);
3280af22 941 SvREFCNT_dec(PL_endav);
7d30b5c4 942 SvREFCNT_dec(PL_checkav);
ece599bd 943 SvREFCNT_dec(PL_checkav_save);
3c10abe3
AG		 944 SvREFCNT_dec(PL_unitcheckav);
945 SvREFCNT_dec(PL_unitcheckav_save);
3280af22 946 SvREFCNT_dec(PL_initav);
7d49f689
NC		 947 PL_beginav = NULL;
948 PL_beginav_save = NULL;
949 PL_endav = NULL;
950 PL_checkav = NULL;
951 PL_checkav_save = NULL;
3c10abe3
AG		 952 PL_unitcheckav = NULL;
953 PL_unitcheckav_save = NULL;
7d49f689 954 PL_initav = NULL;
5618dfe8 955
8ebc5c01 956 /* shortcuts just get cleared */
a0714e2c
SS		 957 PL_hintgv = NULL;
958 PL_errgv = NULL;
a0714e2c
SS		 959 PL_argvoutgv = NULL;
960 PL_stdingv = NULL;
961 PL_stderrgv = NULL;
962 PL_last_in_gv = NULL;
a0714e2c
SS		 963 PL_DBsingle = NULL;
964 PL_DBtrace = NULL;
965 PL_DBsignal = NULL;
601f1833 966 PL_DBcv = NULL;
7d49f689 967 PL_dbargs = NULL;
5c284bb0 968 PL_debstash = NULL;
8ebc5c01 969
cf93a474 970 SvREFCNT_dec(PL_envgv);
f03015cd 971 SvREFCNT_dec(PL_incgv);
722fa0e9 972 SvREFCNT_dec(PL_argvgv);
475b1e90 973 SvREFCNT_dec(PL_replgv);
8cece913
FC		 974 SvREFCNT_dec(PL_DBgv);
975 SvREFCNT_dec(PL_DBline);
976 SvREFCNT_dec(PL_DBsub);
cf93a474 977 PL_envgv = NULL;
f03015cd 978 PL_incgv = NULL;
722fa0e9 979 PL_argvgv = NULL;
475b1e90 980 PL_replgv = NULL;
8cece913
FC		 981 PL_DBgv = NULL;
982 PL_DBline = NULL;
983 PL_DBsub = NULL;
984
7a1c5554 985 SvREFCNT_dec(PL_argvout_stack);
7d49f689 986 PL_argvout_stack = NULL;
8ebc5c01 987
5c831c24 988 SvREFCNT_dec(PL_modglobal);
5c284bb0 989 PL_modglobal = NULL;
5c831c24 990 SvREFCNT_dec(PL_preambleav);
7d49f689 991 PL_preambleav = NULL;
5c831c24 992 SvREFCNT_dec(PL_subname);
a0714e2c 993 PL_subname = NULL;
ca0c25f6 994#ifdef PERL_USES_PL_PIDSTATUS
5c831c24 995 SvREFCNT_dec(PL_pidstatus);
5c284bb0 996 PL_pidstatus = NULL;
ca0c25f6 997#endif
5c831c24 998 SvREFCNT_dec(PL_toptarget);
a0714e2c 999 PL_toptarget = NULL;
5c831c24 1000 SvREFCNT_dec(PL_bodytarget);
a0714e2c
SS		 1001 PL_bodytarget = NULL;
1002 PL_formtarget = NULL;
5c831c24 1003
d33b2eba 1004 /* free locale stuff */
b9582b6a 1005#ifdef USE_LOCALE_COLLATE
d33b2eba 1006 Safefree(PL_collation_name);
bd61b366 1007 PL_collation_name = NULL;
b9582b6a 1008#endif
d33b2eba 1009
b9582b6a 1010#ifdef USE_LOCALE_NUMERIC
d33b2eba 1011 Safefree(PL_numeric_name);
bd61b366 1012 PL_numeric_name = NULL;
a453c169 1013 SvREFCNT_dec(PL_numeric_radix_sv);
a0714e2c 1014 PL_numeric_radix_sv = NULL;
b9582b6a 1015#endif
d33b2eba 1016
9c0b6888
KW		 1017 /* clear character classes */
1018 for (i = 0; i < POSIX_SWASH_COUNT; i++) {
1019 SvREFCNT_dec(PL_utf8_swash_ptrs[i]);
1020 PL_utf8_swash_ptrs[i] = NULL;
1021 }
5c831c24
GS		 1022 SvREFCNT_dec(PL_utf8_mark);
1023 SvREFCNT_dec(PL_utf8_toupper);
4dbdbdc2 1024 SvREFCNT_dec(PL_utf8_totitle);
5c831c24 1025 SvREFCNT_dec(PL_utf8_tolower);
b4e400f9 1026 SvREFCNT_dec(PL_utf8_tofold);
82686b01
JH		 1027 SvREFCNT_dec(PL_utf8_idstart);
1028 SvREFCNT_dec(PL_utf8_idcont);
c60f4405 1029 SvREFCNT_dec(PL_utf8_foldable);
2726813d 1030 SvREFCNT_dec(PL_utf8_foldclosures);
9fa9f06b
KW		 1031 SvREFCNT_dec(PL_AboveLatin1);
1032 SvREFCNT_dec(PL_UpperLatin1);
1033 SvREFCNT_dec(PL_Latin1);
1034 SvREFCNT_dec(PL_NonL1NonFinalFold);
1035 SvREFCNT_dec(PL_HasMultiCharFold);
a0714e2c
SS		 1036 PL_utf8_mark = NULL;
1037 PL_utf8_toupper = NULL;
1038 PL_utf8_totitle = NULL;
1039 PL_utf8_tolower = NULL;
1040 PL_utf8_tofold = NULL;
1041 PL_utf8_idstart = NULL;
1042 PL_utf8_idcont = NULL;
2726813d 1043 PL_utf8_foldclosures = NULL;
9fa9f06b
KW		 1044 PL_AboveLatin1 = NULL;
1045 PL_HasMultiCharFold = NULL;
1046 PL_Latin1 = NULL;
1047 PL_NonL1NonFinalFold = NULL;
1048 PL_UpperLatin1 = NULL;
86f72d56 1049 for (i = 0; i < POSIX_CC_COUNT; i++) {
cac6e0ca
KW		 1050 SvREFCNT_dec(PL_XPosix_ptrs[i]);
1051 PL_XPosix_ptrs[i] = NULL;
86f72d56 1052 }
5c831c24 1053
971a9dd3 1054 if (!specialWARN(PL_compiling.cop_warnings))
72dc9ed5 1055 PerlMemShared_free(PL_compiling.cop_warnings);
a0714e2c 1056 PL_compiling.cop_warnings = NULL;
20439bc7
Z		 1057 cophh_free(CopHINTHASH_get(&PL_compiling));
1058 CopHINTHASH_set(&PL_compiling, cophh_new_empty());
05ec9bb3 1059 CopFILE_free(&PL_compiling);
5c831c24 1060
a0d0e21e 1061 /* Prepare to destruct main symbol table. */
5f05dabc 1062
3280af22 1063 hv = PL_defstash;
ca556bcd
DM		 1064 /* break ref loop *:: <=> %:: */
1065 (void)hv_delete(hv, "main::", 6, G_DISCARD);
3280af22 1066 PL_defstash = 0;
a0d0e21e 1067 SvREFCNT_dec(hv);
5c831c24 1068 SvREFCNT_dec(PL_curstname);
a0714e2c 1069 PL_curstname = NULL;
a0d0e21e 1070
5a844595
GS		 1071 /* clear queued errors */
1072 SvREFCNT_dec(PL_errors);
a0714e2c 1073 PL_errors = NULL;
5a844595 1074
dd69841b
BB		 1075 SvREFCNT_dec(PL_isarev);
1076
a0d0e21e 1077 FREETMPS;
9b387841 1078 if (destruct_level >= 2) {
3280af22 1079 if (PL_scopestack_ix != 0)
9b387841
NC		 1080 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
1081 "Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
1082 (long)PL_scopestack_ix);
3280af22 1083 if (PL_savestack_ix != 0)
9b387841
NC		 1084 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
1085 "Unbalanced saves: %ld more saves than restores\n",
1086 (long)PL_savestack_ix);
3280af22 1087 if (PL_tmps_floor != -1)
9b387841
NC		 1088 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),"Unbalanced tmps: %ld more allocs than frees\n",
1089 (long)PL_tmps_floor + 1);
a0d0e21e 1090 if (cxstack_ix != -1)
9b387841
NC		 1091 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),"Unbalanced context: %ld more PUSHes than POPs\n",
1092 (long)cxstack_ix + 1);
a0d0e21e 1093 }
8990e307 1094
0547a729
DM		 1095#ifdef USE_ITHREADS
1096 SvREFCNT_dec(PL_regex_padav);
1097 PL_regex_padav = NULL;
1098 PL_regex_pad = NULL;
1099#endif
1100
776df701 1101#ifdef PERL_IMPLICIT_CONTEXT
57bb2458
JH		 1102 /* the entries in this list are allocated via SV PVX's, so get freed
1103 * in sv_clean_all */
1104 Safefree(PL_my_cxt_list);
776df701 1105#endif
57bb2458 1106
8990e307 1107 /* Now absolutely destruct everything, somehow or other, loops or no. */
5226ed68
JH		 1108
1109 /* the 2 is for PL_fdpid and PL_strtab */
d17ea597 1110 while (sv_clean_all() > 2)
5226ed68
JH		 1111 ;
1112
23083432
FC		 1113#ifdef USE_ITHREADS
1114 Safefree(PL_stashpad); /* must come after sv_clean_all */
1115#endif
1116
d4777f27
GS		 1117 AvREAL_off(PL_fdpid); /* no surviving entries */
1118 SvREFCNT_dec(PL_fdpid); /* needed in io_close() */
7d49f689 1119 PL_fdpid = NULL;
d33b2eba 1120
6c644e78
GS		 1121#ifdef HAVE_INTERP_INTERN
1122 sys_intern_clear();
1123#endif
1124
a38ab475
RZ		 1125 /* constant strings */
1126 for (i = 0; i < SV_CONSTS_COUNT; i++) {
1127 SvREFCNT_dec(PL_sv_consts[i]);
1128 PL_sv_consts[i] = NULL;
1129 }
1130
6e72f9df 1131 /* Destruct the global string table. */
1132 {
1133 /* Yell and reset the HeVAL() slots that are still holding refcounts,
1134 * so that sv_free() won't fail on them.
80459961
NC		 1135 * Now that the global string table is using a single hunk of memory
1136 * for both HE and HEK, we either need to explicitly unshare it the
1137 * correct way, or actually free things here.
6e72f9df 1138 */
80459961
NC		 1139 I32 riter = 0;
1140 const I32 max = HvMAX(PL_strtab);
c4420975 1141 HE * const * const array = HvARRAY(PL_strtab);
80459961
NC		 1142 HE *hent = array[0];
1143
6e72f9df 1144 for (;;) {
0453d815 1145 if (hent && ckWARN_d(WARN_INTERNAL)) {
44f8325f 1146 HE * const next = HeNEXT(hent);
9014280d 1147 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
44f8325f 1148 "Unbalanced string table refcount: (%ld) for \"%s\"",
de616631 1149 (long)hent->he_valu.hent_refcount, HeKEY(hent));
80459961
NC		 1150 Safefree(hent);
1151 hent = next;
6e72f9df 1152 }
1153 if (!hent) {
1154 if (++riter > max)
1155 break;
1156 hent = array[riter];
1157 }
1158 }
80459961
NC		 1159
1160 Safefree(array);
1161 HvARRAY(PL_strtab) = 0;
1162 HvTOTALKEYS(PL_strtab) = 0;
6e72f9df 1163 }
3280af22 1164 SvREFCNT_dec(PL_strtab);
6e72f9df 1165
e652bb2f 1166#ifdef USE_ITHREADS
c21d1a0f 1167 /* free the pointer tables used for cloning */
a0739874 1168 ptr_table_free(PL_ptr_table);
bf9cdc68 1169 PL_ptr_table = (PTR_TBL_t*)NULL;
53186e96 1170#endif
a0739874 1171
d33b2eba
GS		 1172 /* free special SVs */
1173
1174 SvREFCNT(&PL_sv_yes) = 0;
1175 sv_clear(&PL_sv_yes);
1176 SvANY(&PL_sv_yes) = NULL;
4c5e2b0d 1177 SvFLAGS(&PL_sv_yes) = 0;
d33b2eba
GS		 1178
1179 SvREFCNT(&PL_sv_no) = 0;
1180 sv_clear(&PL_sv_no);
1181 SvANY(&PL_sv_no) = NULL;
4c5e2b0d 1182 SvFLAGS(&PL_sv_no) = 0;
01724ea0 1183
9f375a43
DM		 1184 {
1185 int i;
1186 for (i=0; i<=2; i++) {
1187 SvREFCNT(PERL_DEBUG_PAD(i)) = 0;
1188 sv_clear(PERL_DEBUG_PAD(i));
1189 SvANY(PERL_DEBUG_PAD(i)) = NULL;
1190 SvFLAGS(PERL_DEBUG_PAD(i)) = 0;
1191 }
1192 }
1193
0453d815 1194 if (PL_sv_count != 0 && ckWARN_d(WARN_INTERNAL))
9014280d 1195 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Scalars leaked: %ld\n", (long)PL_sv_count);
6e72f9df 1196
eba0f806
DM		 1197#ifdef DEBUG_LEAKING_SCALARS
1198 if (PL_sv_count != 0) {
1199 SV* sva;
1200 SV* sv;
eb578fdb 1201 SV* svend;
eba0f806 1202
ad64d0ec 1203 for (sva = PL_sv_arenaroot; sva; sva = MUTABLE_SV(SvANY(sva))) {
eba0f806
DM		 1204 svend = &sva[SvREFCNT(sva)];
1205 for (sv = sva + 1; sv < svend; ++sv) {
e4787c0c 1206 if (SvTYPE(sv) != (svtype)SVTYPEMASK) {
a548cda8 1207 PerlIO_printf(Perl_debug_log, "leaked: sv=0x%p"
61b61456 1208 " flags=0x%"UVxf
fd0854ff 1209 " refcnt=%"UVuf pTHX__FORMAT "\n"
cd676548
DM		 1210 "\tallocated at %s:%d %s %s (parent 0x%"UVxf");"
1211 "serial %"UVuf"\n",
574b8821
NC		 1212 (void*)sv, (UV)sv->sv_flags, (UV)sv->sv_refcnt
1213 pTHX__VALUE,
fd0854ff
DM		 1214 sv->sv_debug_file ? sv->sv_debug_file : "(unknown)",
1215 sv->sv_debug_line,
1216 sv->sv_debug_inpad ? "for" : "by",
1217 sv->sv_debug_optype ?
1218 PL_op_name[sv->sv_debug_optype]: "(none)",
cd676548 1219 PTR2UV(sv->sv_debug_parent),
cbe56f1d 1220 sv->sv_debug_serial
fd0854ff 1221 );
2aa47728 1222#ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
41e4abd8 1223 Perl_dump_sv_child(aTHX_ sv);
2aa47728 1224#endif
eba0f806
DM		 1225 }
1226 }
1227 }
1228 }
2aa47728
NC		 1229#ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
1230 {
1231 int status;
1232 fd_set rset;
1233 /* Wait for up to 4 seconds for child to terminate.
1234 This seems to be the least effort way of timing out on reaping
1235 its exit status. */
1236 struct timeval waitfor = {4, 0};
41e4abd8 1237 int sock = PL_dumper_fd;
2aa47728
NC		 1238
1239 shutdown(sock, 1);
1240 FD_ZERO(&rset);
1241 FD_SET(sock, &rset);
1242 select(sock + 1, &rset, NULL, NULL, &waitfor);
1243 waitpid(child, &status, WNOHANG);
1244 close(sock);
1245 }
1246#endif
eba0f806 1247#endif
77abb4c6
NC		 1248#ifdef DEBUG_LEAKING_SCALARS_ABORT
1249 if (PL_sv_count)
1250 abort();
1251#endif
bf9cdc68 1252 PL_sv_count = 0;
eba0f806 1253
56a2bab7 1254#if defined(PERLIO_LAYERS)
3a1ee7e8
NIS		 1255 /* No more IO - including error messages ! */
1256 PerlIO_cleanup(aTHX);
1257#endif
1258
9f4bd222 1259 /* sv_undef needs to stay immortal until after PerlIO_cleanup
a0714e2c 1260 as currently layers use it rather than NULL as a marker
9f4bd222
NIS		 1261 for no arg - and will try and SvREFCNT_dec it.
1262 */
1263 SvREFCNT(&PL_sv_undef) = 0;
1264 SvREADONLY_off(&PL_sv_undef);
1265
3280af22 1266 Safefree(PL_origfilename);
bd61b366 1267 PL_origfilename = NULL;
43c5f42d 1268 Safefree(PL_reg_curpm);
dd28f7bb 1269 free_tied_hv_pool();
3280af22 1270 Safefree(PL_op_mask);
cf36064f 1271 Safefree(PL_psig_name);
bf9cdc68 1272 PL_psig_name = (SV**)NULL;
d525a7b2 1273 PL_psig_ptr = (SV**)NULL;
31c91b43
LR		 1274 {
1275 /* We need to NULL PL_psig_pend first, so that
1276 signal handlers know not to use it */
1277 int *psig_save = PL_psig_pend;
1278 PL_psig_pend = (int*)NULL;
1279 Safefree(psig_save);
1280 }
6e72f9df 1281 nuke_stacks();
284167a5
S		 1282 TAINTING_set(FALSE);
1283 TAINT_WARN_set(FALSE);
3280af22 1284 PL_hints = 0; /* Reset hints. Should hints be per-interpreter ? */
bf9cdc68 1285 PL_debug = 0;
ac27b0f5 1286
a0d0e21e 1287 DEBUG_P(debprofdump());
d33b2eba 1288
e5dd39fc 1289#ifdef USE_REENTRANT_API
10bc17b6 1290 Perl_reentrant_free(aTHX);
e5dd39fc
AB		 1291#endif
1292
612f20c3
GS		 1293 sv_free_arenas();
1294
5d9a96ca
DM		 1295 while (PL_regmatch_slab) {
1296 regmatch_slab *s = PL_regmatch_slab;
1297 PL_regmatch_slab = PL_regmatch_slab->next;
1298 Safefree(s);
1299 }
1300
fc36a67e 1301 /* As the absolutely last thing, free the non-arena SV for mess() */
1302
3280af22 1303 if (PL_mess_sv) {
f350b448
NC		 1304 /* we know that type == SVt_PVMG */
1305
9c63abab 1306 /* it could have accumulated taint magic */
f350b448
NC		 1307 MAGIC* mg;
1308 MAGIC* moremagic;
1309 for (mg = SvMAGIC(PL_mess_sv); mg; mg = moremagic) {
1310 moremagic = mg->mg_moremagic;
1311 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global
1312 && mg->mg_len >= 0)
1313 Safefree(mg->mg_ptr);
1314 Safefree(mg);
9c63abab 1315 }
f350b448 1316
fc36a67e 1317 /* we know that type >= SVt_PV */
8bd4d4c5 1318 SvPV_free(PL_mess_sv);
3280af22
NIS		 1319 Safefree(SvANY(PL_mess_sv));
1320 Safefree(PL_mess_sv);
a0714e2c 1321 PL_mess_sv = NULL;
fc36a67e 1322 }
37038d91 1323 return STATUS_EXIT;
79072805
LW		 1324}
1325
954c1994
GS		 1326/*
1327=for apidoc perl_free
1328
1329Releases a Perl interpreter. See L<perlembed>.
1330
1331=cut
1332*/
1333
79072805 1334void
0cb96387 1335perl_free(pTHXx)
79072805 1336{
5174512c
NC		 1337 dVAR;
1338
7918f24d
NC		 1339 PERL_ARGS_ASSERT_PERL_FREE;
1340
c301d606
DM		 1341 if (PL_veto_cleanup)
1342 return;
1343
7cb608b5 1344#ifdef PERL_TRACK_MEMPOOL
55ef9aae
MHM		 1345 {
1346 /*
1347 * Don't free thread memory if PERL_DESTRUCT_LEVEL is set to a non-zero
1348 * value as we're probably hunting memory leaks then
1349 */
36e77d41 1350 if (PL_perl_destruct_level == 0) {
4fd0a9b8 1351 const U32 old_debug = PL_debug;
55ef9aae
MHM		 1352 /* Emulate the PerlHost behaviour of free()ing all memory allocated in this
1353 thread at thread exit. */
4fd0a9b8
NC		 1354 if (DEBUG_m_TEST) {
1355 PerlIO_puts(Perl_debug_log, "Disabling memory debugging as we "
1356 "free this thread's memory\n");
1357 PL_debug &= ~ DEBUG_m_FLAG;
1358 }
55ef9aae 1359 while(aTHXx->Imemory_debug_header.next != &(aTHXx->Imemory_debug_header))
a78adc84 1360 safesysfree(PERL_MEMORY_DEBUG_HEADER_SIZE + (char *)(aTHXx->Imemory_debug_header.next));
4fd0a9b8 1361 PL_debug = old_debug;
55ef9aae
MHM		 1362 }
1363 }
7cb608b5
NC		 1364#endif
1365
acfe0abc 1366#if defined(WIN32) || defined(NETWARE)
ce3e5b80 1367# if defined(PERL_IMPLICIT_SYS)
b36c9a52 1368 {
acfe0abc 1369# ifdef NETWARE
7af12a34 1370 void *host = nw_internal_host;
7af12a34 1371 PerlMem_free(aTHXx);
7af12a34 1372 nw_delete_internal_host(host);
acfe0abc 1373# else
bdb50480
NC		 1374 void *host = w32_internal_host;
1375 PerlMem_free(aTHXx);
7af12a34 1376 win32_delete_internal_host(host);
acfe0abc 1377# endif
7af12a34 1378 }
1c0ca838
GS		 1379# else
1380 PerlMem_free(aTHXx);
1381# endif
acfe0abc
GS		 1382#else
1383 PerlMem_free(aTHXx);
76e3520e 1384#endif
79072805
LW		 1385}
1386
b7f7fff6 1387#if defined(USE_ITHREADS)
aebd1ac7
GA		 1388/* provide destructors to clean up the thread key when libperl is unloaded */
1389#ifndef WIN32 /* handled during DLL_PROCESS_DETACH in win32/perllib.c */
1390
826955bd 1391#if defined(__hpux) && !(defined(__ux_version) && __ux_version <= 1020) && !defined(__GNUC__)
aebd1ac7 1392#pragma fini "perl_fini"
666ad1ec
GA		 1393#elif defined(__sun) && !defined(__GNUC__)
1394#pragma fini (perl_fini)
aebd1ac7
GA		 1395#endif
1396
0dbb1585
AL		 1397static void
1398#if defined(__GNUC__)
1399__attribute__((destructor))
aebd1ac7 1400#endif
de009b76 1401perl_fini(void)
aebd1ac7 1402{
27da23d5 1403 dVAR;
5c64bffd
NC		 1404 if (
1405#ifdef PERL_GLOBAL_STRUCT_PRIVATE
1406 my_vars &&
1407#endif
1408 PL_curinterp && !PL_veto_cleanup)
aebd1ac7
GA		 1409 FREE_THREAD_KEY;
1410}
1411
1412#endif /* WIN32 */
1413#endif /* THREADS */
1414
4b556e6c 1415void
864dbfa3 1416Perl_call_atexit(pTHX_ ATEXIT_t fn, void *ptr)
4b556e6c 1417{
3280af22
NIS		 1418 Renew(PL_exitlist, PL_exitlistlen+1, PerlExitListEntry);
1419 PL_exitlist[PL_exitlistlen].fn = fn;
1420 PL_exitlist[PL_exitlistlen].ptr = ptr;
1421 ++PL_exitlistlen;
4b556e6c
JD		 1422}
1423
954c1994
GS		 1424/*
1425=for apidoc perl_parse
1426
1427Tells a Perl interpreter to parse a Perl script. See L<perlembed>.
1428
1429=cut
1430*/
1431
03d9f026
FC		 1432#define SET_CURSTASH(newstash) \
1433 if (PL_curstash != newstash) { \
1434 SvREFCNT_dec(PL_curstash); \
1435 PL_curstash = (HV *)SvREFCNT_inc(newstash); \
1436 }
1437
79072805 1438int
0cb96387 1439perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env)
8d063cd8 1440{
27da23d5 1441 dVAR;
6224f72b 1442 I32 oldscope;
6224f72b 1443 int ret;
db36c5a1 1444 dJMPENV;
8d063cd8 1445
7918f24d
NC		 1446 PERL_ARGS_ASSERT_PERL_PARSE;
1447#ifndef MULTIPLICITY
ed6c66dd 1448 PERL_UNUSED_ARG(my_perl);
7918f24d 1449#endif
7dc86639 1450#if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT) || defined(USE_HASH_SEED_DEBUG)
b0891165 1451 {
7dc86639
YO		 1452 const char * const s = PerlEnv_getenv("PERL_HASH_SEED_DEBUG");
1453
1454 if (s && (atoi(s) == 1)) {
1455 unsigned char *seed= PERL_HASH_SEED;
1456 unsigned char *seed_end= PERL_HASH_SEED + PERL_HASH_SEED_BYTES;
1457 PerlIO_printf(Perl_debug_log, "HASH_FUNCTION = %s HASH_SEED = 0x", PERL_HASH_FUNC);
1458 while (seed < seed_end) {
1459 PerlIO_printf(Perl_debug_log, "%02x", *seed++);
1460 }
6a5b4183
YO		 1461#ifdef PERL_HASH_RANDOMIZE_KEYS
1462 PerlIO_printf(Perl_debug_log, " PERTURB_KEYS = %d (%s)",
1463 PL_HASH_RAND_BITS_ENABLED,
1464 PL_HASH_RAND_BITS_ENABLED == 0 ? "NO" : PL_HASH_RAND_BITS_ENABLED == 1 ? "RANDOM" : "DETERMINISTIC");
1465#endif
7dc86639
YO		 1466 PerlIO_printf(Perl_debug_log, "\n");
1467 }
b0891165
JH		 1468 }
1469#endif /* #if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT) */
3280af22 1470 PL_origargc = argc;
e2975953 1471 PL_origargv = argv;
a0d0e21e 1472
a2722ac9
GA		 1473 if (PL_origalen != 0) {
1474 PL_origalen = 1; /* don't use old PL_origalen if perl_parse() is called again */
1475 }
1476 else {
3cb9023d
JH		 1477 /* Set PL_origalen be the sum of the contiguous argv[]
1478 * elements plus the size of the env in case that it is
e9137a8e 1479 * contiguous with the argv[]. This is used in mg.c:Perl_magic_set()
3cb9023d
JH		 1480 * as the maximum modifiable length of $0. In the worst case
1481 * the area we are able to modify is limited to the size of
43c32782 1482 * the original argv[0]. (See below for 'contiguous', though.)
3cb9023d 1483 * --jhi */
e1ec3a88 1484 const char *s = NULL;
54bfe034 1485 int i;
b7249aaf 1486 const UV mask = ~(UV)(PTRSIZE-1);
43c32782 1487 /* Do the mask check only if the args seem like aligned. */
1b6737cc 1488 const UV aligned =
43c32782
JH		 1489 (mask < ~(UV)0) && ((PTR2UV(argv[0]) & mask) == PTR2UV(argv[0]));
1490
1491 /* See if all the arguments are contiguous in memory. Note
1492 * that 'contiguous' is a loose term because some platforms
1493 * align the argv[] and the envp[]. If the arguments look
1494 * like non-aligned, assume that they are 'strictly' or
1495 * 'traditionally' contiguous. If the arguments look like
1496 * aligned, we just check that they are within aligned
1497 * PTRSIZE bytes. As long as no system has something bizarre
1498 * like the argv[] interleaved with some other data, we are
1499 * fine. (Did I just evoke Murphy's Law?) --jhi */
c8941eeb
JH		 1500 if (PL_origargv && PL_origargc >= 1 && (s = PL_origargv[0])) {
1501 while (*s) s++;
1502 for (i = 1; i < PL_origargc; i++) {
1503 if ((PL_origargv[i] == s + 1
43c32782 1504#ifdef OS2
c8941eeb 1505 || PL_origargv[i] == s + 2
43c32782 1506#endif
c8941eeb
JH		 1507 )
1508 ||
1509 (aligned &&
1510 (PL_origargv[i] > s &&
1511 PL_origargv[i] <=
1512 INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask)))
1513 )
1514 {
1515 s = PL_origargv[i];
1516 while (*s) s++;
1517 }
1518 else
1519 break;
54bfe034 1520 }
54bfe034 1521 }
a4a109c2
JD		 1522
1523#ifndef PERL_USE_SAFE_PUTENV
3cb9023d 1524 /* Can we grab env area too to be used as the area for $0? */
a4a109c2 1525 if (s && PL_origenviron && !PL_use_safe_putenv) {
9d419b5f 1526 if ((PL_origenviron[0] == s + 1)
43c32782
JH		 1527 ||
1528 (aligned &&
1529 (PL_origenviron[0] > s &&
1530 PL_origenviron[0] <=
1531 INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask)))
1532 )
1533 {
9d419b5f 1534#ifndef OS2 /* ENVIRON is read by the kernel too. */
43c32782
JH		 1535 s = PL_origenviron[0];
1536 while (*s) s++;
1537#endif
bd61b366 1538 my_setenv("NoNe SuCh", NULL);
43c32782
JH		 1539 /* Force copy of environment. */
1540 for (i = 1; PL_origenviron[i]; i++) {
1541 if (PL_origenviron[i] == s + 1
1542 ||
1543 (aligned &&
1544 (PL_origenviron[i] > s &&
1545 PL_origenviron[i] <=
1546 INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask)))
1547 )
1548 {
1549 s = PL_origenviron[i];
1550 while (*s) s++;
1551 }
1552 else
1553 break;
54bfe034 1554 }
43c32782 1555 }
54bfe034 1556 }
a4a109c2
JD		 1557#endif /* !defined(PERL_USE_SAFE_PUTENV) */
1558
2d2af554 1559 PL_origalen = s ? s - PL_origargv[0] + 1 : 0;
54bfe034
JH		 1560 }
1561
3280af22 1562 if (PL_do_undump) {
a0d0e21e
LW		 1563
1564 /* Come here if running an undumped a.out. */
1565
3280af22
NIS		 1566 PL_origfilename = savepv(argv[0]);
1567 PL_do_undump = FALSE;
a0d0e21e 1568 cxstack_ix = -1; /* start label stack again */
748a9306 1569 init_ids();
284167a5 1570 assert (!TAINT_get);
b7975bdd 1571 TAINT;
e2051532 1572 set_caret_X();
b7975bdd 1573 TAINT_NOT;
a0d0e21e
LW		 1574 init_postdump_symbols(argc,argv,env);
1575 return 0;
1576 }
1577
3280af22 1578 if (PL_main_root) {
3280af22 1579 op_free(PL_main_root);
5f66b61c 1580 PL_main_root = NULL;
ff0cee69 1581 }
5f66b61c 1582 PL_main_start = NULL;
3280af22 1583 SvREFCNT_dec(PL_main_cv);
601f1833 1584 PL_main_cv = NULL;
79072805 1585
3280af22
NIS		 1586 time(&PL_basetime);
1587 oldscope = PL_scopestack_ix;
599cee73 1588 PL_dowarn = G_WARN_OFF;
f86702cc 1589
14dd3ad8 1590 JMPENV_PUSH(ret);
6224f72b 1591 switch (ret) {
312caa8e 1592 case 0:
14dd3ad8 1593 parse_body(env,xsinit);
9ebf26ad 1594 if (PL_unitcheckav) {
3c10abe3 1595 call_list(oldscope, PL_unitcheckav);
9ebf26ad
FR		 1596 }
1597 if (PL_checkav) {
ca7b837b 1598 PERL_SET_PHASE(PERL_PHASE_CHECK);
7d30b5c4 1599 call_list(oldscope, PL_checkav);
9ebf26ad 1600 }
14dd3ad8
GS		 1601 ret = 0;
1602 break;
6224f72b
GS		 1603 case 1:
1604 STATUS_ALL_FAILURE;
924ba076 1605 /* FALLTHROUGH */
6224f72b
GS		 1606 case 2:
1607 /* my_exit() was called */
3280af22 1608 while (PL_scopestack_ix > oldscope)
6224f72b
GS		 1609 LEAVE;
1610 FREETMPS;
03d9f026 1611 SET_CURSTASH(PL_defstash);
9ebf26ad 1612 if (PL_unitcheckav) {
3c10abe3 1613 call_list(oldscope, PL_unitcheckav);
9ebf26ad
FR		 1614 }
1615 if (PL_checkav) {
ca7b837b 1616 PERL_SET_PHASE(PERL_PHASE_CHECK);
7d30b5c4 1617 call_list(oldscope, PL_checkav);
9ebf26ad 1618 }
37038d91 1619 ret = STATUS_EXIT;
14dd3ad8 1620 break;
6224f72b 1621 case 3:
bf49b057 1622 PerlIO_printf(Perl_error_log, "panic: top_env\n");
14dd3ad8
GS		 1623 ret = 1;
1624 break;
6224f72b 1625 }
14dd3ad8
GS		 1626 JMPENV_POP;
1627 return ret;
1628}
1629
4a5df386
NC		 1630/* This needs to stay in perl.c, as perl.c is compiled with different flags for
1631 miniperl, and we need to see those flags reflected in the values here. */
1632
1633/* What this returns is subject to change. Use the public interface in Config.
1634 */
1635static void
1636S_Internals_V(pTHX_ CV *cv)
1637{
1638 dXSARGS;
1639#ifdef LOCAL_PATCH_COUNT
1640 const int local_patch_count = LOCAL_PATCH_COUNT;
1641#else
1642 const int local_patch_count = 0;
1643#endif
2dc296d2 1644 const int entries = 3 + local_patch_count;
4a5df386 1645 int i;
fe1c5936 1646 static const char non_bincompat_options[] =
4a5df386
NC		 1647# ifdef DEBUGGING
1648 " DEBUGGING"
1649# endif
1650# ifdef NO_MATHOMS
0d311fbe 1651 " NO_MATHOMS"
4a5df386 1652# endif
59b86f4b
DM		 1653# ifdef NO_HASH_SEED
1654 " NO_HASH_SEED"
1655# endif
3b0e4ee2
MB		 1656# ifdef NO_TAINT_SUPPORT
1657 " NO_TAINT_SUPPORT"
1658# endif
cb26ef7a
MB		 1659# ifdef PERL_BOOL_AS_CHAR
1660 " PERL_BOOL_AS_CHAR"
1661# endif
4a5df386
NC		 1662# ifdef PERL_DISABLE_PMC
1663 " PERL_DISABLE_PMC"
1664# endif
1665# ifdef PERL_DONT_CREATE_GVSV
1666 " PERL_DONT_CREATE_GVSV"
1667# endif
9a044a43
NC		 1668# ifdef PERL_EXTERNAL_GLOB
1669 " PERL_EXTERNAL_GLOB"
1670# endif
59b86f4b
DM		 1671# ifdef PERL_HASH_FUNC_SIPHASH
1672 " PERL_HASH_FUNC_SIPHASH"
1673# endif
1674# ifdef PERL_HASH_FUNC_SDBM
1675 " PERL_HASH_FUNC_SDBM"
1676# endif
1677# ifdef PERL_HASH_FUNC_DJB2
1678 " PERL_HASH_FUNC_DJB2"
1679# endif
1680# ifdef PERL_HASH_FUNC_SUPERFAST
1681 " PERL_HASH_FUNC_SUPERFAST"
1682# endif
1683# ifdef PERL_HASH_FUNC_MURMUR3
1684 " PERL_HASH_FUNC_MURMUR3"
1685# endif
1686# ifdef PERL_HASH_FUNC_ONE_AT_A_TIME
1687 " PERL_HASH_FUNC_ONE_AT_A_TIME"
1688# endif
1689# ifdef PERL_HASH_FUNC_ONE_AT_A_TIME_HARD
1690 " PERL_HASH_FUNC_ONE_AT_A_TIME_HARD"
1691# endif
1692# ifdef PERL_HASH_FUNC_ONE_AT_A_TIME_OLD
1693 " PERL_HASH_FUNC_ONE_AT_A_TIME_OLD"
1694# endif
4a5df386
NC		 1695# ifdef PERL_IS_MINIPERL
1696 " PERL_IS_MINIPERL"
1697# endif
1698# ifdef PERL_MALLOC_WRAP
1699 " PERL_MALLOC_WRAP"
1700# endif
1701# ifdef PERL_MEM_LOG
1702 " PERL_MEM_LOG"
1703# endif
1704# ifdef PERL_MEM_LOG_NOIMPL
1705 " PERL_MEM_LOG_NOIMPL"
1706# endif
2542212d
DM		 1707# ifdef PERL_NEW_COPY_ON_WRITE
1708 " PERL_NEW_COPY_ON_WRITE"
1709# endif
59b86f4b
DM		 1710# ifdef PERL_PERTURB_KEYS_DETERMINISTIC
1711 " PERL_PERTURB_KEYS_DETERMINISTIC"
1712# endif
1713# ifdef PERL_PERTURB_KEYS_DISABLED
1714 " PERL_PERTURB_KEYS_DISABLED"
1715# endif
1716# ifdef PERL_PERTURB_KEYS_RANDOM
1717 " PERL_PERTURB_KEYS_RANDOM"
1718# endif
c3cf41ec
NC		 1719# ifdef PERL_PRESERVE_IVUV
1720 " PERL_PRESERVE_IVUV"
1721# endif
c051e30b
NC		 1722# ifdef PERL_RELOCATABLE_INCPUSH
1723 " PERL_RELOCATABLE_INCPUSH"
1724# endif
4a5df386
NC		 1725# ifdef PERL_USE_DEVEL
1726 " PERL_USE_DEVEL"
1727# endif
1728# ifdef PERL_USE_SAFE_PUTENV
1729 " PERL_USE_SAFE_PUTENV"
1730# endif
a3749cf3
NC		 1731# ifdef UNLINK_ALL_VERSIONS
1732 " UNLINK_ALL_VERSIONS"
1733# endif
de618ee4
NC		 1734# ifdef USE_ATTRIBUTES_FOR_PERLIO
1735 " USE_ATTRIBUTES_FOR_PERLIO"
1736# endif
4a5df386
NC		 1737# ifdef USE_FAST_STDIO
1738 " USE_FAST_STDIO"
1739# endif
59b86f4b
DM		 1740# ifdef USE_HASH_SEED_EXPLICIT
1741 " USE_HASH_SEED_EXPLICIT"
1742# endif
98548bdf
NC		 1743# ifdef USE_LOCALE
1744 " USE_LOCALE"
1745# endif
98548bdf
NC		 1746# ifdef USE_LOCALE_CTYPE
1747 " USE_LOCALE_CTYPE"
1748# endif
5a8d8935
NC		 1749# ifdef USE_PERL_ATOF
1750 " USE_PERL_ATOF"
1751# endif
0d311fbe
NC		 1752# ifdef USE_SITECUSTOMIZE
1753 " USE_SITECUSTOMIZE"
1754# endif
4a5df386
NC		 1755 ;
1756 PERL_UNUSED_ARG(cv);
1757 PERL_UNUSED_ARG(items);
1758
1759 EXTEND(SP, entries);
1760
1761 PUSHs(sv_2mortal(newSVpv(PL_bincompat_options, 0)));
1762 PUSHs(Perl_newSVpvn_flags(aTHX_ non_bincompat_options,
1763 sizeof(non_bincompat_options) - 1, SVs_TEMP));
1764
1765#ifdef __DATE__
1766# ifdef __TIME__
1767 PUSHs(Perl_newSVpvn_flags(aTHX_
1768 STR_WITH_LEN("Compiled at " __DATE__ " " __TIME__),
1769 SVs_TEMP));
1770# else
1771 PUSHs(Perl_newSVpvn_flags(aTHX_ STR_WITH_LEN("Compiled on " __DATE__),
1772 SVs_TEMP));
1773# endif
1774#else
1775 PUSHs(&PL_sv_undef);
1776#endif
1777
4a5df386
NC		 1778 for (i = 1; i <= local_patch_count; i++) {
1779 /* This will be an undef, if PL_localpatches[i] is NULL. */
1780 PUSHs(sv_2mortal(newSVpv(PL_localpatches[i], 0)));
1781 }
1782
1783 XSRETURN(entries);
1784}
1785
be71fc8f
NC		 1786#define INCPUSH_UNSHIFT 0x01
1787#define INCPUSH_ADD_OLD_VERS 0x02
1788#define INCPUSH_ADD_VERSIONED_SUB_DIRS 0x04
1789#define INCPUSH_ADD_ARCHONLY_SUB_DIRS 0x08
1790#define INCPUSH_NOT_BASEDIR 0x10
1791#define INCPUSH_CAN_RELOCATE 0x20
1e3208d8
NC		 1792#define INCPUSH_ADD_SUB_DIRS \
1793 (INCPUSH_ADD_VERSIONED_SUB_DIRS|INCPUSH_ADD_ARCHONLY_SUB_DIRS)
e28f3139 1794
312caa8e 1795STATIC void *
14dd3ad8 1796S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
312caa8e 1797{
27da23d5 1798 dVAR;
2f9285f8 1799 PerlIO *rsfp;
312caa8e 1800 int argc = PL_origargc;
8f42b153 1801 char **argv = PL_origargv;
e1ec3a88 1802 const char *scriptname = NULL;
312caa8e 1803 VOL bool dosearch = FALSE;
eb578fdb 1804 char c;
737c24fc 1805 bool doextract = FALSE;
bd61b366 1806 const char *cddir = NULL;
ab019eaa 1807#ifdef USE_SITECUSTOMIZE
20ef40cf 1808 bool minus_f = FALSE;
ab019eaa 1809#endif
95670bde 1810 SV *linestr_sv = NULL;
5486870f 1811 bool add_read_e_script = FALSE;
87606032 1812 U32 lex_start_flags = 0;
009d90df 1813
ca7b837b 1814 PERL_SET_PHASE(PERL_PHASE_START);
9ebf26ad 1815
6224f72b 1816 init_main_stash();
54310121 1817
c7030b81
NC		 1818 {
1819 const char *s;
6224f72b
GS		 1820 for (argc--,argv++; argc > 0; argc--,argv++) {
1821 if (argv[0][0] != '-' || !argv[0][1])
1822 break;
6224f72b
GS		 1823 s = argv[0]+1;
1824 reswitch:
47f56822 1825 switch ((c = *s)) {
729a02f2 1826 case 'C':
1d5472a9
GS		 1827#ifndef PERL_STRICT_CR
1828 case '\r':
1829#endif
6224f72b
GS		 1830 case ' ':
1831 case '0':
1832 case 'F':
1833 case 'a':
1834 case 'c':
1835 case 'd':
1836 case 'D':
1837 case 'h':
1838 case 'i':
1839 case 'l':
1840 case 'M':
1841 case 'm':
1842 case 'n':
1843 case 'p':
1844 case 's':
1845 case 'u':
1846 case 'U':
1847 case 'v':
599cee73
PM		 1848 case 'W':
1849 case 'X':
6224f72b 1850 case 'w':
97bd5664 1851 if ((s = moreswitches(s)))
6224f72b
GS		 1852 goto reswitch;
1853 break;
33b78306 1854
1dbad523 1855 case 't':
dc6d7f5c 1856#if defined(SILENT_NO_TAINT_SUPPORT)
284167a5 1857 /* silently ignore */
dc6d7f5c 1858#elif defined(NO_TAINT_SUPPORT)
3231f579 1859 Perl_croak_nocontext("This perl was compiled without taint support. "
284167a5
S		 1860 "Cowardly refusing to run with -t or -T flags");
1861#else
22f7c9c9 1862 CHECK_MALLOC_TOO_LATE_FOR('t');
284167a5
S		 1863 if( !TAINTING_get ) {
1864 TAINT_WARN_set(TRUE);
1865 TAINTING_set(TRUE);
317ea90d 1866 }
284167a5 1867#endif
317ea90d
MS		 1868 s++;
1869 goto reswitch;
6224f72b 1870 case 'T':
dc6d7f5c 1871#if defined(SILENT_NO_TAINT_SUPPORT)
284167a5 1872 /* silently ignore */
dc6d7f5c 1873#elif defined(NO_TAINT_SUPPORT)
3231f579 1874 Perl_croak_nocontext("This perl was compiled without taint support. "
284167a5
S		 1875 "Cowardly refusing to run with -t or -T flags");
1876#else
22f7c9c9 1877 CHECK_MALLOC_TOO_LATE_FOR('T');
284167a5
S		 1878 TAINTING_set(TRUE);
1879 TAINT_WARN_set(FALSE);
1880#endif
6224f72b
GS		 1881 s++;
1882 goto reswitch;
f86702cc 1883
bc9b29db
RH		 1884 case 'E':
1885 PL_minus_E = TRUE;
924ba076 1886 /* FALLTHROUGH */
6224f72b 1887 case 'e':
f20b2998 1888 forbid_setid('e', FALSE);
3280af22 1889 if (!PL_e_script) {
396482e1 1890 PL_e_script = newSVpvs("");
5486870f 1891 add_read_e_script = TRUE;
6224f72b
GS		 1892 }
1893 if (*++s)
3280af22 1894 sv_catpv(PL_e_script, s);
6224f72b 1895 else if (argv[1]) {
3280af22 1896 sv_catpv(PL_e_script, argv[1]);
6224f72b
GS		 1897 argc--,argv++;
1898 }
1899 else
47f56822 1900 Perl_croak(aTHX_ "No code specified for -%c", c);
396482e1 1901 sv_catpvs(PL_e_script, "\n");
6224f72b 1902 break;
afe37c7d 1903
20ef40cf 1904 case 'f':
f5542d3a 1905#ifdef USE_SITECUSTOMIZE
20ef40cf 1906 minus_f = TRUE;
f5542d3a 1907#endif
20ef40cf
GA		 1908 s++;
1909 goto reswitch;
1910
6224f72b 1911 case 'I': /* -I handled both here and in moreswitches() */
f20b2998 1912 forbid_setid('I', FALSE);
bd61b366 1913 if (!*++s && (s=argv[1]) != NULL) {
6224f72b
GS		 1914 argc--,argv++;
1915 }
6224f72b 1916 if (s && *s) {
0df16ed7 1917 STRLEN len = strlen(s);
55b4bc1c 1918 incpush(s, len, INCPUSH_ADD_SUB_DIRS|INCPUSH_ADD_OLD_VERS);
0df16ed7
GS		 1919 }
1920 else
a67e862a 1921 Perl_croak(aTHX_ "No directory specified for -I");
6224f72b 1922 break;
6224f72b 1923 case 'S':
f20b2998 1924 forbid_setid('S', FALSE);
6224f72b
GS		 1925 dosearch = TRUE;
1926 s++;
1927 goto reswitch;
1928 case 'V':
7edfd0ef
NC		 1929 {
1930 SV *opts_prog;
1931
7edfd0ef 1932 if (*++s != ':') {
37ca4a5b 1933 opts_prog = newSVpvs("use Config; Config::_V()");
7edfd0ef
NC		 1934 }
1935 else {
1936 ++s;
1937 opts_prog = Perl_newSVpvf(aTHX_
37ca4a5b 1938 "use Config; Config::config_vars(qw%c%s%c)",
7edfd0ef
NC		 1939 0, s, 0);
1940 s += strlen(s);
1941 }
37ca4a5b 1942 Perl_av_create_and_push(aTHX_ &PL_preambleav, opts_prog);
7edfd0ef
NC		 1943 /* don't look for script or read stdin */
1944 scriptname = BIT_BUCKET;
1945 goto reswitch;
6224f72b 1946 }
6224f72b 1947 case 'x':
737c24fc 1948 doextract = TRUE;
6224f72b 1949 s++;
304334da 1950 if (*s)
f4c556ac 1951 cddir = s;
6224f72b
GS		 1952 break;
1953 case 0:
1954 break;
1955 case '-':
1956 if (!*++s || isSPACE(*s)) {
1957 argc--,argv++;
1958 goto switch_end;
1959 }
ee8bc8b7
NC		 1960 /* catch use of gnu style long options.
1961 Both of these exit immediately. */
1962 if (strEQ(s, "version"))
1963 minus_v();
1964 if (strEQ(s, "help"))
1965 usage();
6224f72b 1966 s--;
924ba076 1967 /* FALLTHROUGH */
6224f72b 1968 default:
cea2e8a9 1969 Perl_croak(aTHX_ "Unrecognized switch: -%s (-h will show valid options)",s);
8d063cd8
LW		 1970 }
1971 }
c7030b81
NC		 1972 }
1973
6224f72b 1974 switch_end:
54310121 1975
c7030b81
NC		 1976 {
1977 char *s;
1978
f675dbe5
CB		 1979 if (
1980#ifndef SECURE_INTERNAL_GETENV
284167a5 1981 !TAINTING_get &&
f675dbe5 1982#endif
cf756827 1983 (s = PerlEnv_getenv("PERL5OPT")))
0df16ed7 1984 {
74288ac8
GS		 1985 while (isSPACE(*s))
1986 s++;
317ea90d 1987 if (*s == '-' && *(s+1) == 'T') {
dc6d7f5c 1988#if defined(SILENT_NO_TAINT_SUPPORT)
284167a5 1989 /* silently ignore */
dc6d7f5c 1990#elif defined(NO_TAINT_SUPPORT)
3231f579 1991 Perl_croak_nocontext("This perl was compiled without taint support. "
284167a5
S		 1992 "Cowardly refusing to run with -t or -T flags");
1993#else
22f7c9c9 1994 CHECK_MALLOC_TOO_LATE_FOR('T');
284167a5
S		 1995 TAINTING_set(TRUE);
1996 TAINT_WARN_set(FALSE);
1997#endif
317ea90d 1998 }
74288ac8 1999 else {
bd61b366 2000 char *popt_copy = NULL;
74288ac8 2001 while (s && *s) {
54913509 2002 const char *d;
74288ac8
GS		 2003 while (isSPACE(*s))
2004 s++;
2005 if (*s == '-') {
2006 s++;
2007 if (isSPACE(*s))
2008 continue;
2009 }
4ea8f8fb 2010 d = s;
74288ac8
GS		 2011 if (!*s)
2012 break;
2b622f1a 2013 if (!strchr("CDIMUdmtwW", *s))
cea2e8a9 2014 Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s);
4ea8f8fb
MS		 2015 while (++s && *s) {
2016 if (isSPACE(*s)) {
cf756827 2017 if (!popt_copy) {
bfa6c418
NC		 2018 popt_copy = SvPVX(sv_2mortal(newSVpv(d,0)));
2019 s = popt_copy + (s - d);
2020 d = popt_copy;
cf756827 2021 }
4ea8f8fb
MS		 2022 *s++ = '\0';
2023 break;
2024 }
2025 }
1c4db469 2026 if (*d == 't') {
dc6d7f5c 2027#if defined(SILENT_NO_TAINT_SUPPORT)
284167a5 2028 /* silently ignore */
dc6d7f5c 2029#elif defined(NO_TAINT_SUPPORT)
3231f579 2030 Perl_croak_nocontext("This perl was compiled without taint support. "
284167a5
S		 2031 "Cowardly refusing to run with -t or -T flags");
2032#else
2033 if( !TAINTING_get) {
2034 TAINT_WARN_set(TRUE);
2035 TAINTING_set(TRUE);
317ea90d 2036 }
284167a5 2037#endif
1c4db469 2038 } else {
97bd5664 2039 moreswitches(d);
1c4db469 2040 }
6224f72b 2041 }
6224f72b
GS		 2042 }
2043 }
c7030b81 2044 }
a0d0e21e 2045
c29067d7
CH		 2046 /* Set $^X early so that it can be used for relocatable paths in @INC */
2047 /* and for SITELIB_EXP in USE_SITECUSTOMIZE */
284167a5 2048 assert (!TAINT_get);
c29067d7 2049 TAINT;
e2051532 2050 set_caret_X();
c29067d7
CH		 2051 TAINT_NOT;
2052
43c0c913 2053#if defined(USE_SITECUSTOMIZE)
20ef40cf 2054 if (!minus_f) {
43c0c913 2055 /* The games with local $! are to avoid setting errno if there is no
fc81b718
NC		 2056 sitecustomize script. "q%c...%c", 0, ..., 0 becomes "q\0...\0",
2057 ie a q() operator with a NUL byte as a the delimiter. This avoids
2058 problems with pathnames containing (say) ' */
43c0c913
NC		 2059# ifdef PERL_IS_MINIPERL
2060 AV *const inc = GvAV(PL_incgv);
2061 SV **const inc0 = inc ? av_fetch(inc, 0, FALSE) : NULL;
2062
2063 if (inc0) {
15870c5c
NC		 2064 /* if lib/buildcustomize.pl exists, it should not fail. If it does,
2065 it should be reported immediately as a build failure. */
43c0c913
NC		 2066 (void)Perl_av_create_and_unshift_one(aTHX_ &PL_preambleav,
2067 Perl_newSVpvf(aTHX_
15870c5c 2068 "BEGIN { do {local $!; -f q%c%"SVf"/buildcustomize.pl%c} and do q%c%"SVf"/buildcustomize.pl%c || die $@ }",
c1f6cd39
BF		 2069 0, SVfARG(*inc0), 0,
2070 0, SVfARG(*inc0), 0));
43c0c913
NC		 2071 }
2072# else
2073 /* SITELIB_EXP is a function call on Win32. */
c29067d7 2074 const char *const raw_sitelib = SITELIB_EXP;
bac5c4fc
JD		 2075 if (raw_sitelib) {
2076 /* process .../.. if PERL_RELOCATABLE_INC is defined */
2077 SV *sitelib_sv = mayberelocate(raw_sitelib, strlen(raw_sitelib),
2078 INCPUSH_CAN_RELOCATE);
2079 const char *const sitelib = SvPVX(sitelib_sv);
2080 (void)Perl_av_create_and_unshift_one(aTHX_ &PL_preambleav,
2081 Perl_newSVpvf(aTHX_
2082 "BEGIN { do {local $!; -f q%c%s/sitecustomize.pl%c} && do q%c%s/sitecustomize.pl%c }",
c1f6cd39
BF		 2083 0, SVfARG(sitelib), 0,
2084 0, SVfARG(sitelib), 0));
bac5c4fc
JD		 2085 assert (SvREFCNT(sitelib_sv) == 1);
2086 SvREFCNT_dec(sitelib_sv);
2087 }
43c0c913 2088# endif
20ef40cf
GA		 2089 }
2090#endif
2091
6224f72b
GS		 2092 if (!scriptname)
2093 scriptname = argv[0];
3280af22 2094 if (PL_e_script) {
6224f72b
GS		 2095 argc++,argv--;
2096 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
2097 }
bd61b366 2098 else if (scriptname == NULL) {
6224f72b
GS		 2099#ifdef MSDOS
2100 if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) )
97bd5664 2101 moreswitches("h");
6224f72b
GS		 2102#endif
2103 scriptname = "-";
2104 }
2105
284167a5 2106 assert (!TAINT_get);
2cace6ac 2107 init_perllib();
6224f72b 2108
a52eba0e 2109 {
f20b2998 2110 bool suidscript = FALSE;
829372d3 2111
8d113837 2112 rsfp = open_script(scriptname, dosearch, &suidscript);
c0b3891a
NC		 2113 if (!rsfp) {
2114 rsfp = PerlIO_stdin();
87606032 2115 lex_start_flags = LEX_DONT_CLOSE_RSFP;
c0b3891a 2116 }
6224f72b 2117
b24bc095 2118 validate_suid(rsfp);
6224f72b 2119
64ca3a65 2120#ifndef PERL_MICRO
a52eba0e
NC		 2121# if defined(SIGCHLD) || defined(SIGCLD)
2122 {
2123# ifndef SIGCHLD
2124# define SIGCHLD SIGCLD
2125# endif
2126 Sighandler_t sigstate = rsignal_state(SIGCHLD);
2127 if (sigstate == (Sighandler_t) SIG_IGN) {
a2a5de95
NC		 2128 Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL),
2129 "Can't ignore signal CHLD, forcing to default");
a52eba0e
NC		 2130 (void)rsignal(SIGCHLD, (Sighandler_t)SIG_DFL);
2131 }
0b5b802d 2132 }
a52eba0e 2133# endif
64ca3a65 2134#endif
0b5b802d 2135
737c24fc 2136 if (doextract) {
faef540c 2137
f20b2998 2138 /* This will croak if suidscript is true, as -x cannot be used with
faef540c
NC		 2139 setuid scripts. */
2140 forbid_setid('x', suidscript);
f20b2998 2141 /* Hence you can't get here if suidscript is true */
faef540c 2142
95670bde
NC		 2143 linestr_sv = newSV_type(SVt_PV);
2144 lex_start_flags |= LEX_START_COPIED;
2f9285f8 2145 find_beginning(linestr_sv, rsfp);
a52eba0e
NC		 2146 if (cddir && PerlDir_chdir( (char *)cddir ) < 0)
2147 Perl_croak(aTHX_ "Can't chdir to %s",cddir);
2148 }
f4c556ac 2149 }
6224f72b 2150
ea726b52 2151 PL_main_cv = PL_compcv = MUTABLE_CV(newSV_type(SVt_PVCV));
3280af22
NIS		 2152 CvUNIQUE_on(PL_compcv);
2153
dd2155a4 2154 CvPADLIST(PL_compcv) = pad_new(0);
6224f72b 2155
dd69841b
BB		 2156 PL_isarev = newHV();
2157
0c4f7ff0 2158 boot_core_PerlIO();
6224f72b 2159 boot_core_UNIVERSAL();
e1a479c5 2160 boot_core_mro();
4a5df386 2161 newXS("Internals::V", S_Internals_V, __FILE__);
6224f72b
GS		 2162
2163 if (xsinit)
acfe0abc 2164 (*xsinit)(aTHX); /* in case linked C routines want magical variables */
64ca3a65 2165#ifndef PERL_MICRO
739a0b84 2166#if defined(VMS) || defined(WIN32) || defined(DJGPP) || defined(__CYGWIN__) || defined(SYMBIAN)
c5be433b 2167 init_os_extras();
6224f72b 2168#endif
64ca3a65 2169#endif
6224f72b 2170
29209bc5 2171#ifdef USE_SOCKS
1b9c9cf5
DH		 2172# ifdef HAS_SOCKS5_INIT
2173 socks5_init(argv[0]);
2174# else
29209bc5 2175 SOCKSinit(argv[0]);
1b9c9cf5 2176# endif
ac27b0f5 2177#endif
29209bc5 2178
6224f72b
GS		 2179 init_predump_symbols();
2180 /* init_postdump_symbols not currently designed to be called */
2181 /* more than once (ENV isn't cleared first, for example) */
2182 /* But running with -u leaves %ENV & @ARGV undefined! XXX */
3280af22 2183 if (!PL_do_undump)
6224f72b
GS		 2184 init_postdump_symbols(argc,argv,env);
2185
27da23d5
JH		 2186 /* PL_unicode is turned on by -C, or by $ENV{PERL_UNICODE},
2187 * or explicitly in some platforms.
085a54d9 2188 * locale.c:Perl_init_i18nl10n() if the environment
a05d7ebb 2189 * look like the user wants to use UTF-8. */
a0fd4948 2190#if defined(__SYMBIAN32__)
27da23d5
JH		 2191 PL_unicode = PERL_UNICODE_STD_FLAG; /* See PERL_SYMBIAN_CONSOLE_UTF8. */
2192#endif
e27b5b51 2193# ifndef PERL_IS_MINIPERL
06e66572
JH		 2194 if (PL_unicode) {
2195 /* Requires init_predump_symbols(). */
a05d7ebb 2196 if (!(PL_unicode & PERL_UNICODE_LOCALE_FLAG) || PL_utf8locale) {
06e66572
JH		 2197 IO* io;
2198 PerlIO* fp;
2199 SV* sv;
2200
a05d7ebb 2201 /* Turn on UTF-8-ness on STDIN, STDOUT, STDERR
06e66572 2202 * and the default open disciplines. */
a05d7ebb
JH		 2203 if ((PL_unicode & PERL_UNICODE_STDIN_FLAG) &&
2204 PL_stdingv && (io = GvIO(PL_stdingv)) &&
2205 (fp = IoIFP(io)))
2206 PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
2207 if ((PL_unicode & PERL_UNICODE_STDOUT_FLAG) &&
2208 PL_defoutgv && (io = GvIO(PL_defoutgv)) &&
2209 (fp = IoOFP(io)))
2210 PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
2211 if ((PL_unicode & PERL_UNICODE_STDERR_FLAG) &&
2212 PL_stderrgv && (io = GvIO(PL_stderrgv)) &&
2213 (fp = IoOFP(io)))
2214 PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
2215 if ((PL_unicode & PERL_UNICODE_INOUT_FLAG) &&
fafc274c
NC		 2216 (sv = GvSV(gv_fetchpvs("\017PEN", GV_ADD|GV_NOTQUAL,
2217 SVt_PV)))) {
a05d7ebb
JH		 2218 U32 in = PL_unicode & PERL_UNICODE_IN_FLAG;
2219 U32 out = PL_unicode & PERL_UNICODE_OUT_FLAG;
2220 if (in) {
2221 if (out)
76f68e9b 2222 sv_setpvs(sv, ":utf8\0:utf8");
a05d7ebb 2223 else
76f68e9b 2224 sv_setpvs(sv, ":utf8\0");
a05d7ebb
JH		 2225 }
2226 else if (out)
76f68e9b 2227 sv_setpvs(sv, "\0:utf8");
a05d7ebb
JH		 2228 SvSETMAGIC(sv);
2229 }
b310b053
JH		 2230 }
2231 }
e27b5b51 2232#endif
b310b053 2233
c7030b81
NC		 2234 {
2235 const char *s;
4ffa73a3
JH		 2236 if ((s = PerlEnv_getenv("PERL_SIGNALS"))) {
2237 if (strEQ(s, "unsafe"))
2238 PL_signals |= PERL_SIGNALS_UNSAFE_FLAG;
2239 else if (strEQ(s, "safe"))
2240 PL_signals &= ~PERL_SIGNALS_UNSAFE_FLAG;
2241 else
2242 Perl_croak(aTHX_ "PERL_SIGNALS illegal: \"%s\"", s);
2243 }
c7030b81 2244 }
4ffa73a3 2245
81d86705 2246
87606032 2247 lex_start(linestr_sv, rsfp, lex_start_flags);
d2687c98 2248 SvREFCNT_dec(linestr_sv);
95670bde 2249
219f7226 2250 PL_subname = newSVpvs("main");
6224f72b 2251
5486870f
DM		 2252 if (add_read_e_script)
2253 filter_add(read_e_script, NULL);
2254
6224f72b
GS		 2255 /* now parse the script */
2256
93189314 2257 SETERRNO(0,SS_NORMAL);
28ac2b49 2258 if (yyparse(GRAMPROG) || PL_parser->error_count) {
3280af22 2259 if (PL_minus_c)
cea2e8a9 2260 Perl_croak(aTHX_ "%s had compilation errors.\n", PL_origfilename);
6224f72b 2261 else {
cea2e8a9 2262 Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
097ee67d 2263 PL_origfilename);
6224f72b
GS		 2264 }
2265 }
57843af0 2266 CopLINE_set(PL_curcop, 0);
03d9f026 2267 SET_CURSTASH(PL_defstash);
3280af22
NIS		 2268 if (PL_e_script) {
2269 SvREFCNT_dec(PL_e_script);
a0714e2c 2270 PL_e_script = NULL;
6224f72b
GS		 2271 }
2272
3280af22 2273 if (PL_do_undump)
6224f72b
GS		 2274 my_unexec();
2275
57843af0
GS		 2276 if (isWARN_ONCE) {
2277 SAVECOPFILE(PL_curcop);
2278 SAVECOPLINE(PL_curcop);
3280af22 2279 gv_check(PL_defstash);
57843af0 2280 }
6224f72b
GS		 2281
2282 LEAVE;
2283 FREETMPS;
2284
2285#ifdef MYMALLOC
f6a607bc
RGS		 2286 {
2287 const char *s;
6224f72b
GS		 2288 if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
2289 dump_mstats("after compilation:");
f6a607bc 2290 }
6224f72b
GS		 2291#endif
2292
2293 ENTER;
febb3a6d 2294 PL_restartjmpenv = NULL;
3280af22 2295 PL_restartop = 0;
312caa8e 2296 return NULL;
6224f72b
GS		 2297}
2298
954c1994
GS		 2299/*
2300=for apidoc perl_run
2301
2302Tells a Perl interpreter to run. See L<perlembed>.
2303
2304=cut
2305*/
2306
6224f72b 2307int
0cb96387 2308perl_run(pTHXx)
6224f72b 2309{
6224f72b 2310 I32 oldscope;
14dd3ad8 2311 int ret = 0;
db36c5a1 2312 dJMPENV;
6224f72b 2313
7918f24d
NC		 2314 PERL_ARGS_ASSERT_PERL_RUN;
2315#ifndef MULTIPLICITY
ed6c66dd 2316 PERL_UNUSED_ARG(my_perl);
7918f24d 2317#endif
9d4ba2ae 2318
3280af22 2319 oldscope = PL_scopestack_ix;
96e176bf
CL		 2320#ifdef VMS
2321 VMSISH_HUSHED = 0;
2322#endif
6224f72b 2323
14dd3ad8 2324 JMPENV_PUSH(ret);
6224f72b
GS		 2325 switch (ret) {
2326 case 1:
2327 cxstack_ix = -1; /* start context stack again */
312caa8e 2328 goto redo_body;
14dd3ad8 2329 case 0: /* normal completion */
14dd3ad8
GS		 2330 redo_body:
2331 run_body(oldscope);
924ba076 2332 /* FALLTHROUGH */
14dd3ad8 2333 case 2: /* my_exit() */
3280af22 2334 while (PL_scopestack_ix > oldscope)
6224f72b
GS		 2335 LEAVE;
2336 FREETMPS;
03d9f026 2337 SET_CURSTASH(PL_defstash);
3a1ee7e8 2338 if (!(PL_exit_flags & PERL_EXIT_DESTRUCT_END) &&
9ebf26ad 2339 PL_endav && !PL_minus_c) {
ca7b837b 2340 PERL_SET_PHASE(PERL_PHASE_END);
31d77e54 2341 call_list(oldscope, PL_endav);
9ebf26ad 2342 }
6224f72b
GS		 2343#ifdef MYMALLOC
2344 if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
2345 dump_mstats("after execution: ");
2346#endif
37038d91 2347 ret = STATUS_EXIT;
14dd3ad8 2348 break;
6224f72b 2349 case 3:
312caa8e
CS		 2350 if (PL_restartop) {
2351 POPSTACK_TO(PL_mainstack);
2352 goto redo_body;
6224f72b 2353 }
5637ef5b 2354 PerlIO_printf(Perl_error_log, "panic: restartop in perl_run\n");
312caa8e 2355 FREETMPS;
14dd3ad8
GS		 2356 ret = 1;
2357 break;
6224f72b
GS		 2358 }
2359
14dd3ad8
GS		 2360 JMPENV_POP;
2361 return ret;
312caa8e
CS		 2362}
2363
dd374669 2364STATIC void
14dd3ad8
GS		 2365S_run_body(pTHX_ I32 oldscope)
2366{
d3b97530
DM		 2367 DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support (0x%x).\n",
2368 PL_sawampersand ? "Enabling" : "Omitting",
2369 (unsigned int)(PL_sawampersand)));
6224f72b 2370
3280af22 2371 if (!PL_restartop) {
cf2782cd 2372#ifdef DEBUGGING
f0e3f042
CS		 2373 if (DEBUG_x_TEST || DEBUG_B_TEST)
2374 dump_all_perl(!DEBUG_B_TEST);
ecae49c0
NC		 2375 if (!DEBUG_q_TEST)
2376 PERL_DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
cf2782cd 2377#endif
6224f72b 2378
3280af22 2379 if (PL_minus_c) {
bf49b057 2380 PerlIO_printf(Perl_error_log, "%s syntax OK\n", PL_origfilename);
6224f72b
GS		 2381 my_exit(0);
2382 }
3280af22 2383 if (PERLDB_SINGLE && PL_DBsingle)
ac27b0f5 2384 sv_setiv(PL_DBsingle, 1);
9ebf26ad 2385 if (PL_initav) {
ca7b837b 2386 PERL_SET_PHASE(PERL_PHASE_INIT);
3280af22 2387 call_list(oldscope, PL_initav);
9ebf26ad 2388 }
f1fac472 2389#ifdef PERL_DEBUG_READONLY_OPS
3107b51f
FC		 2390 if (PL_main_root && PL_main_root->op_slabbed)
2391 Slab_to_ro(OpSLAB(PL_main_root));
f1fac472 2392#endif
6224f72b
GS		 2393 }
2394
2395 /* do it */
2396
ca7b837b 2397 PERL_SET_PHASE(PERL_PHASE_RUN);
9ebf26ad 2398
3280af22 2399 if (PL_restartop) {
febb3a6d 2400 PL_restartjmpenv = NULL;
533c011a 2401 PL_op = PL_restartop;
3280af22 2402 PL_restartop = 0;
cea2e8a9 2403 CALLRUNOPS(aTHX);
6224f72b 2404 }
3280af22
NIS		 2405 else if (PL_main_start) {
2406 CvDEPTH(PL_main_cv) = 1;
533c011a 2407 PL_op = PL_main_start;
cea2e8a9 2408 CALLRUNOPS(aTHX);
6224f72b 2409 }
f6b3007c 2410 my_exit(0);
a25b5927 2411 assert(0); /* NOTREACHED */
6224f72b
GS		 2412}
2413
954c1994 2414/*
ccfc67b7
JH		 2415=head1 SV Manipulation Functions
2416
954c1994
GS		 2417=for apidoc p||get_sv
2418
64ace3f8 2419Returns the SV of the specified Perl scalar. C<flags> are passed to
72d33970 2420C<gv_fetchpv>. If C<GV_ADD> is set and the
64ace3f8
NC		 2421Perl variable does not exist then it will be created. If C<flags> is zero
2422and the variable does not exist then NULL is returned.
954c1994
GS		 2423
2424=cut
2425*/
2426
6224f72b 2427SV*
64ace3f8 2428Perl_get_sv(pTHX_ const char *name, I32 flags)
6224f72b
GS		 2429{
2430 GV *gv;
7918f24d
NC		 2431
2432 PERL_ARGS_ASSERT_GET_SV;
2433
64ace3f8 2434 gv = gv_fetchpv(name, flags, SVt_PV);
6224f72b
GS		 2435 if (gv)
2436 return GvSV(gv);
a0714e2c 2437 return NULL;
6224f72b
GS		 2438}
2439
954c1994 2440/*
ccfc67b7
JH		 2441=head1 Array Manipulation Functions
2442
954c1994
GS		 2443=for apidoc p||get_av
2444
f0b90de1
SF		 2445Returns the AV of the specified Perl global or package array with the given
2446name (so it won't work on lexical variables). C<flags> are passed
72d33970 2447to C<gv_fetchpv>. If C<GV_ADD> is set and the
cbfd0a87
NC		 2448Perl variable does not exist then it will be created. If C<flags> is zero
2449and the variable does not exist then NULL is returned.
954c1994 2450
f0b90de1
SF		 2451Perl equivalent: C<@{"$name"}>.
2452
954c1994
GS		 2453=cut
2454*/
2455
6224f72b 2456AV*
cbfd0a87 2457Perl_get_av(pTHX_ const char *name, I32 flags)
6224f72b 2458{
cbfd0a87 2459 GV* const gv = gv_fetchpv(name, flags, SVt_PVAV);
7918f24d
NC		 2460
2461 PERL_ARGS_ASSERT_GET_AV;
2462
cbfd0a87 2463 if (flags)
6224f72b
GS		 2464 return GvAVn(gv);
2465 if (gv)
2466 return GvAV(gv);
7d49f689 2467 return NULL;
6224f72b
GS		 2468}
2469
954c1994 2470/*
ccfc67b7
JH		 2471=head1 Hash Manipulation Functions
2472
954c1994
GS		 2473=for apidoc p||get_hv
2474
6673a63c 2475Returns the HV of the specified Perl hash. C<flags> are passed to
72d33970 2476C<gv_fetchpv>. If C<GV_ADD> is set and the
6673a63c
NC		 2477Perl variable does not exist then it will be created. If C<flags> is zero
2478and the variable does not exist then NULL is returned.
954c1994
GS		 2479
2480=cut
2481*/
2482
6224f72b 2483HV*
6673a63c 2484Perl_get_hv(pTHX_ const char *name, I32 flags)
6224f72b 2485{
6673a63c 2486 GV* const gv = gv_fetchpv(name, flags, SVt_PVHV);
7918f24d
NC		 2487
2488 PERL_ARGS_ASSERT_GET_HV;
2489
6673a63c 2490 if (flags)
a0d0e21e
LW		 2491 return GvHVn(gv);
2492 if (gv)
2493 return GvHV(gv);
5c284bb0 2494 return NULL;
a0d0e21e
LW		 2495}
2496
954c1994 2497/*
ccfc67b7
JH		 2498=head1 CV Manipulation Functions
2499
780a5241
NC		 2500=for apidoc p||get_cvn_flags
2501
2502Returns the CV of the specified Perl subroutine. C<flags> are passed to
72d33970 2503C<gv_fetchpvn_flags>. If C<GV_ADD> is set and the Perl subroutine does not
780a5241
NC		 2504exist then it will be declared (which has the same effect as saying
2505C<sub name;>). If C<GV_ADD> is not set and the subroutine does not exist
2506then NULL is returned.
2507
954c1994
GS		 2508=for apidoc p||get_cv
2509
780a5241 2510Uses C<strlen> to get the length of C<name>, then calls C<get_cvn_flags>.
954c1994
GS		 2511
2512=cut
2513*/
2514
a0d0e21e 2515CV*
780a5241 2516Perl_get_cvn_flags(pTHX_ const char *name, STRLEN len, I32 flags)
a0d0e21e 2517{
780a5241 2518 GV* const gv = gv_fetchpvn_flags(name, len, flags, SVt_PVCV);
7918f24d
NC		 2519
2520 PERL_ARGS_ASSERT_GET_CVN_FLAGS;
2521
334dda80
FC		 2522 /* XXX this is probably not what they think they're getting.
2523 * It has the same effect as "sub name;", i.e. just a forward
2524 * declaration! */
780a5241 2525 if ((flags & ~GV_NOADD_MASK) && !GvCVu(gv)) {
186a5ba8 2526 return newSTUB(gv,0);
780a5241 2527 }
a0d0e21e 2528 if (gv)
8ebc5c01 2529 return GvCVu(gv);
601f1833 2530 return NULL;
a0d0e21e
LW		 2531}
2532
2c67934f
NC		 2533/* Nothing in core calls this now, but we can't replace it with a macro and
2534 move it to mathoms.c as a macro would evaluate name twice. */
780a5241
NC		 2535CV*
2536Perl_get_cv(pTHX_ const char *name, I32 flags)
2537{
7918f24d
NC		 2538 PERL_ARGS_ASSERT_GET_CV;
2539
780a5241
NC		 2540 return get_cvn_flags(name, strlen(name), flags);
2541}
2542
79072805
LW		 2543/* Be sure to refetch the stack pointer after calling these routines. */
2544
954c1994 2545/*
ccfc67b7
JH		 2546
2547=head1 Callback Functions
2548
954c1994
GS		 2549=for apidoc p||call_argv
2550
f0b90de1 2551Performs a callback to the specified named and package-scoped Perl subroutine
72d33970
FC		 2552with C<argv> (a NULL-terminated array of strings) as arguments. See
2553L<perlcall>.
f0b90de1
SF		 2554
2555Approximate Perl equivalent: C<&{"$sub_name"}(@$argv)>.
954c1994
GS		 2556
2557=cut
2558*/
2559
a0d0e21e 2560I32
5aaab254 2561Perl_call_argv(pTHX_ const char *sub_name, I32 flags, char **argv)
ac27b0f5 2562
8ac85365
NIS		 2563 /* See G_* flags in cop.h */
2564 /* null terminated arg list */
8990e307 2565{
a0d0e21e 2566 dSP;
8990e307 2567
7918f24d
NC		 2568 PERL_ARGS_ASSERT_CALL_ARGV;
2569
924508f0 2570 PUSHMARK(SP);
a0d0e21e 2571 if (argv) {
8990e307 2572 while (*argv) {
6e449a3a 2573 mXPUSHs(newSVpv(*argv,0));
8990e307
LW		 2574 argv++;
2575 }
a0d0e21e 2576 PUTBACK;
8990e307 2577 }
864dbfa3 2578 return call_pv(sub_name, flags);
8990e307
LW		 2579}
2580
954c1994
GS		 2581/*
2582=for apidoc p||call_pv
2583
2584Performs a callback to the specified Perl sub. See L<perlcall>.
2585
2586=cut
2587*/
2588
a0d0e21e 2589I32
864dbfa3 2590Perl_call_pv(pTHX_ const char *sub_name, I32 flags)
8ac85365
NIS		 2591 /* name of the subroutine */
2592 /* See G_* flags in cop.h */
a0d0e21e 2593{
7918f24d
NC		 2594 PERL_ARGS_ASSERT_CALL_PV;
2595
0da0e728 2596 return call_sv(MUTABLE_SV(get_cv(sub_name, GV_ADD)), flags);
a0d0e21e
LW		 2597}
2598
954c1994
GS		 2599/*
2600=for apidoc p||call_method
2601
2602Performs a callback to the specified Perl method. The blessed object must
2603be on the stack. See L<perlcall>.
2604
2605=cut
2606*/
2607
a0d0e21e 2608I32
864dbfa3 2609Perl_call_method(pTHX_ const char *methname, I32 flags)
8ac85365
NIS		 2610 /* name of the subroutine */
2611 /* See G_* flags in cop.h */
a0d0e21e 2612{
46ca9bac 2613 STRLEN len;
c106c2be 2614 SV* sv;
7918f24d
NC		 2615 PERL_ARGS_ASSERT_CALL_METHOD;
2616
46ca9bac 2617 len = strlen(methname);
c106c2be
RZ		 2618 sv = flags & G_METHOD_NAMED
2619 ? sv_2mortal(newSVpvn_share(methname, len,0))
2620 : newSVpvn_flags(methname, len, SVs_TEMP);
46ca9bac 2621
c106c2be 2622 return call_sv(sv, flags | G_METHOD);
a0d0e21e
LW		 2623}
2624
2625/* May be called with any of a CV, a GV, or an SV containing the name. */
954c1994
GS		 2626/*
2627=for apidoc p||call_sv
2628
2629Performs a callback to the Perl sub whose name is in the SV. See
2630L<perlcall>.
2631
2632=cut
2633*/
2634
a0d0e21e 2635I32
001d637e 2636Perl_call_sv(pTHX_ SV *sv, VOL I32 flags)
8ac85365 2637 /* See G_* flags in cop.h */
a0d0e21e 2638{
27da23d5 2639 dVAR; dSP;
a0d0e21e 2640 LOGOP myop; /* fake syntax tree node */
c106c2be
RZ		 2641 UNOP method_unop;
2642 SVOP method_svop;
aa689395 2643 I32 oldmark;
8ea43dc8 2644 VOL I32 retval = 0;
a0d0e21e 2645 I32 oldscope;
54310121 2646 bool oldcatch = CATCH_GET;
6224f72b 2647 int ret;
c4420975 2648 OP* const oldop = PL_op;
db36c5a1 2649 dJMPENV;
1e422769 2650
7918f24d
NC		 2651 PERL_ARGS_ASSERT_CALL_SV;
2652
a0d0e21e
LW		 2653 if (flags & G_DISCARD) {
2654 ENTER;
2655 SAVETMPS;
2656 }
2f8edad0
NC		 2657 if (!(flags & G_WANT)) {
2658 /* Backwards compatibility - as G_SCALAR was 0, it could be omitted.
2659 */
2660 flags |= G_SCALAR;
2661 }
a0d0e21e 2662
aa689395 2663 Zero(&myop, 1, LOGOP);
f51d4af5 2664 if (!(flags & G_NOARGS))
aa689395 2665 myop.op_flags |= OPf_STACKED;
4f911530 2666 myop.op_flags |= OP_GIMME_REVERSE(flags);
462e5cf6 2667 SAVEOP();
533c011a 2668 PL_op = (OP*)&myop;
aa689395 2669
3280af22 2670 EXTEND(PL_stack_sp, 1);
c106c2be
RZ		 2671 if (!(flags & G_METHOD_NAMED))
2672 *++PL_stack_sp = sv;
aa689395 2673 oldmark = TOPMARK;
3280af22 2674 oldscope = PL_scopestack_ix;
a0d0e21e 2675
3280af22 2676 if (PERLDB_SUB && PL_curstash != PL_debstash
36477c24 2677 /* Handle first BEGIN of -d. */
3280af22 2678 && (PL_DBcv || (PL_DBcv = GvCV(PL_DBsub)))
36477c24 2679 /* Try harder, since this may have been a sighandler, thus
2680 * curstash may be meaningless. */
ea726b52 2681 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((const CV *)sv) != PL_debstash)
491527d0 2682 && !(flags & G_NODEBUG))
5ff48db8 2683 myop.op_private |= OPpENTERSUB_DB;
a0d0e21e 2684
c106c2be
RZ		 2685 if (flags & (G_METHOD|G_METHOD_NAMED)) {
2686 if ( flags & G_METHOD_NAMED ) {
2687 Zero(&method_svop, 1, SVOP);
2688 method_svop.op_next = (OP*)&myop;
2689 method_svop.op_ppaddr = PL_ppaddr[OP_METHOD_NAMED];
2690 method_svop.op_type = OP_METHOD_NAMED;
2691 method_svop.op_sv = sv;
2692 PL_op = (OP*)&method_svop;
2693 } else {
2694 Zero(&method_unop, 1, UNOP);
2695 method_unop.op_next = (OP*)&myop;
2696 method_unop.op_ppaddr = PL_ppaddr[OP_METHOD];
2697 method_unop.op_type = OP_METHOD;
2698 PL_op = (OP*)&method_unop;
2699 }
2700 myop.op_ppaddr = PL_ppaddr[OP_ENTERSUB];
2701 myop.op_type = OP_ENTERSUB;
2702
968b3946
GS		 2703 }
2704
312caa8e 2705 if (!(flags & G_EVAL)) {
0cdb2077 2706 CATCH_SET(TRUE);
d6f07c05 2707 CALL_BODY_SUB((OP*)&myop);
312caa8e 2708 retval = PL_stack_sp - (PL_stack_base + oldmark);
0253cb41 2709 CATCH_SET(oldcatch);
312caa8e
CS		 2710 }
2711 else {
d78bda3d 2712 myop.op_other = (OP*)&myop;
3280af22 2713 PL_markstack_ptr--;
edb2152a 2714 create_eval_scope(flags|G_FAKINGEVAL);
3280af22 2715 PL_markstack_ptr++;
a0d0e21e 2716
14dd3ad8 2717 JMPENV_PUSH(ret);
edb2152a 2718
6224f72b
GS		 2719 switch (ret) {
2720 case 0:
14dd3ad8 2721 redo_body:
d6f07c05 2722 CALL_BODY_SUB((OP*)&myop);
312caa8e 2723 retval = PL_stack_sp - (PL_stack_base + oldmark);
8433848b 2724 if (!(flags & G_KEEPERR)) {
ab69dbc2 2725 CLEAR_ERRSV();
8433848b 2726 }
a0d0e21e 2727 break;
6224f72b 2728 case 1:
f86702cc 2729 STATUS_ALL_FAILURE;
924ba076 2730 /* FALLTHROUGH */
6224f72b 2731 case 2:
a0d0e21e 2732 /* my_exit() was called */
03d9f026 2733 SET_CURSTASH(PL_defstash);
a0d0e21e 2734 FREETMPS;
14dd3ad8 2735 JMPENV_POP;
f86702cc 2736 my_exit_jump();
a25b5927 2737 assert(0); /* NOTREACHED */
6224f72b 2738 case 3:
3280af22 2739 if (PL_restartop) {
febb3a6d 2740 PL_restartjmpenv = NULL;
533c011a 2741 PL_op = PL_restartop;
3280af22 2742 PL_restartop = 0;
312caa8e 2743 goto redo_body;
a0d0e21e 2744 }
3280af22 2745 PL_stack_sp = PL_stack_base + oldmark;
51ce5529 2746 if ((flags & G_WANT) == G_ARRAY)
a0d0e21e
LW		 2747 retval = 0;
2748 else {
2749 retval = 1;
3280af22 2750 *++PL_stack_sp = &PL_sv_undef;
a0d0e21e 2751 }
312caa8e 2752 break;
a0d0e21e 2753 }
a0d0e21e 2754
edb2152a
NC		 2755 if (PL_scopestack_ix > oldscope)
2756 delete_eval_scope();
14dd3ad8 2757 JMPENV_POP;
a0d0e21e 2758 }
1e422769 2759
a0d0e21e 2760 if (flags & G_DISCARD) {
3280af22 2761 PL_stack_sp = PL_stack_base + oldmark;
a0d0e21e
LW		 2762 retval = 0;
2763 FREETMPS;
2764 LEAVE;
2765 }
533c011a 2766 PL_op = oldop;
a0d0e21e
LW		 2767 return retval;
2768}
2769
6e72f9df 2770/* Eval a string. The G_EVAL flag is always assumed. */
8990e307 2771
954c1994
GS		 2772/*
2773=for apidoc p||eval_sv
2774
72d33970
FC		 2775Tells Perl to C<eval> the string in the SV. It supports the same flags
2776as C<call_sv>, with the obvious exception of G_EVAL. See L<perlcall>.
954c1994
GS		 2777
2778=cut
2779*/
2780
a0d0e21e 2781I32
864dbfa3 2782Perl_eval_sv(pTHX_ SV *sv, I32 flags)
ac27b0f5 2783
8ac85365 2784 /* See G_* flags in cop.h */
a0d0e21e 2785{
97aff369 2786 dVAR;
924508f0 2787 dSP;
a0d0e21e 2788 UNOP myop; /* fake syntax tree node */
8ea43dc8
SP		 2789 VOL I32 oldmark = SP - PL_stack_base;
2790 VOL I32 retval = 0;
6224f72b 2791 int ret;
c4420975 2792 OP* const oldop = PL_op;
db36c5a1 2793 dJMPENV;
84902520 2794
7918f24d
NC		 2795 PERL_ARGS_ASSERT_EVAL_SV;
2796
4633a7c4
LW		 2797 if (flags & G_DISCARD) {
2798 ENTER;
2799 SAVETMPS;
2800 }
2801
462e5cf6 2802 SAVEOP();
533c011a 2803 PL_op = (OP*)&myop;
5ff48db8 2804 Zero(&myop, 1, UNOP);
3280af22
NIS		 2805 EXTEND(PL_stack_sp, 1);
2806 *++PL_stack_sp = sv;
79072805 2807
4633a7c4
LW		 2808 if (!(flags & G_NOARGS))
2809 myop.op_flags = OPf_STACKED;
6e72f9df 2810 myop.op_type = OP_ENTEREVAL;
4f911530 2811 myop.op_flags |= OP_GIMME_REVERSE(flags);
6e72f9df 2812 if (flags & G_KEEPERR)
2813 myop.op_flags |= OPf_SPECIAL;
a1941760
DM		 2814
2815 if (flags & G_RE_REPARSING)
2816 myop.op_private = (OPpEVAL_COPHH | OPpEVAL_RE_REPARSING);
4633a7c4 2817
dedbcade
DM		 2818 /* fail now; otherwise we could fail after the JMPENV_PUSH but
2819 * before a PUSHEVAL, which corrupts the stack after a croak */
2820 TAINT_PROPER("eval_sv()");
2821
14dd3ad8 2822 JMPENV_PUSH(ret);
6224f72b
GS		 2823 switch (ret) {
2824 case 0:
14dd3ad8 2825 redo_body:
2ba65d5f
DM		 2826 if (PL_op == (OP*)(&myop)) {
2827 PL_op = PL_ppaddr[OP_ENTEREVAL](aTHX);
2828 if (!PL_op)
2829 goto fail; /* failed in compilation */
2830 }
4aca2f62 2831 CALLRUNOPS(aTHX);
312caa8e 2832 retval = PL_stack_sp - (PL_stack_base + oldmark);
8433848b 2833 if (!(flags & G_KEEPERR)) {
ab69dbc2 2834 CLEAR_ERRSV();
8433848b 2835 }
4633a7c4 2836 break;
6224f72b 2837 case 1:
f86702cc 2838 STATUS_ALL_FAILURE;
924ba076 2839 /* FALLTHROUGH */
6224f72b 2840 case 2:
4633a7c4 2841 /* my_exit() was called */
03d9f026 2842 SET_CURSTASH(PL_defstash);
4633a7c4 2843 FREETMPS;
14dd3ad8 2844 JMPENV_POP;
f86702cc 2845 my_exit_jump();
a25b5927 2846 assert(0); /* NOTREACHED */
6224f72b 2847 case 3:
3280af22 2848 if (PL_restartop) {
febb3a6d 2849 PL_restartjmpenv = NULL;
533c011a 2850 PL_op = PL_restartop;
3280af22 2851 PL_restartop = 0;
312caa8e 2852 goto redo_body;
4633a7c4 2853 }
4aca2f62 2854 fail:
3280af22 2855 PL_stack_sp = PL_stack_base + oldmark;
51ce5529 2856 if ((flags & G_WANT) == G_ARRAY)
4633a7c4
LW		 2857 retval = 0;
2858 else {
2859 retval = 1;
3280af22 2860 *++PL_stack_sp = &PL_sv_undef;
4633a7c4 2861 }
312caa8e 2862 break;
4633a7c4
LW		 2863 }
2864
14dd3ad8 2865 JMPENV_POP;
4633a7c4 2866 if (flags & G_DISCARD) {
3280af22 2867 PL_stack_sp = PL_stack_base + oldmark;
4633a7c4
LW		 2868 retval = 0;
2869 FREETMPS;
2870 LEAVE;
2871 }
533c011a 2872 PL_op = oldop;
4633a7c4
LW		 2873 return retval;
2874}
2875
954c1994
GS		 2876/*
2877=for apidoc p||eval_pv
2878
2879Tells Perl to C<eval> the given string and return an SV* result.
2880
2881=cut
2882*/
2883
137443ea 2884SV*
864dbfa3 2885Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error)
137443ea 2886{
137443ea 2887 SV* sv = newSVpv(p, 0);
2888
7918f24d
NC		 2889 PERL_ARGS_ASSERT_EVAL_PV;
2890
864dbfa3 2891 eval_sv(sv, G_SCALAR);
137443ea 2892 SvREFCNT_dec(sv);
2893
ed1786ad
DD		 2894 {
2895 dSP;
2896 sv = POPs;
2897 PUTBACK;
2898 }
137443ea 2899
eed484f9
DD		 2900 /* just check empty string or undef? */
2901 if (croak_on_error) {
2902 SV * const errsv = ERRSV;
2903 if(SvTRUE_NN(errsv))
2904 /* replace with croak_sv? */
2905 Perl_croak_nocontext("%s", SvPV_nolen_const(errsv));
2d8e6c8d 2906 }
137443ea 2907
2908 return sv;
2909}
2910
4633a7c4
LW		 2911/* Require a module. */
2912
954c1994 2913/*
ccfc67b7
JH		 2914=head1 Embedding Functions
2915
954c1994
GS		 2916=for apidoc p||require_pv
2917
7d3fb230
BS		 2918Tells Perl to C<require> the file named by the string argument. It is
2919analogous to the Perl code C<eval "require '$file'">. It's even
2307c6d0 2920implemented that way; consider using load_module instead.
954c1994 2921
7d3fb230 2922=cut */
954c1994 2923
4633a7c4 2924void
864dbfa3 2925Perl_require_pv(pTHX_ const char *pv)
4633a7c4 2926{
d3acc0f7 2927 dSP;
97aff369 2928 SV* sv;
7918f24d
NC		 2929
2930 PERL_ARGS_ASSERT_REQUIRE_PV;
2931
e788e7d3 2932 PUSHSTACKi(PERLSI_REQUIRE);
be41e5d9
NC		 2933 sv = Perl_newSVpvf(aTHX_ "require q%c%s%c", 0, pv, 0);
2934 eval_sv(sv_2mortal(sv), G_DISCARD);
d3acc0f7 2935 POPSTACK;
79072805
LW		 2936}
2937
76e3520e 2938STATIC void
b6f82619 2939S_usage(pTHX) /* XXX move this out into a module ? */
4633a7c4 2940{
ab821d7f 2941 /* This message really ought to be max 23 lines.
75c72d73 2942 * Removed -h because the user already knows that option. Others? */
fb73857a 2943
1566c39d
NC		 2944 /* Grouped as 6 lines per C string literal, to keep under the ANSI C 89
2945 minimum of 509 character string literals. */
27da23d5 2946 static const char * const usage_msg[] = {
1566c39d
NC		 2947" -0[octal] specify record separator (\\0, if no argument)\n"
2948" -a autosplit mode with -n or -p (splits $_ into @F)\n"
2949" -C[number/list] enables the listed Unicode features\n"
2950" -c check syntax only (runs BEGIN and CHECK blocks)\n"
2951" -d[:debugger] run program under debugger\n"
2952" -D[number/list] set debugging flags (argument is a bit mask or alphabets)\n",
2953" -e program one line of program (several -e's allowed, omit programfile)\n"
2954" -E program like -e, but enables all optional features\n"
2955" -f don't do $sitelib/sitecustomize.pl at startup\n"
2956" -F/pattern/ split() pattern for -a switch (//'s are optional)\n"
2957" -i[extension] edit <> files in place (makes backup if extension supplied)\n"
2958" -Idirectory specify @INC/#include directory (several -I's allowed)\n",
2959" -l[octal] enable line ending processing, specifies line terminator\n"
2960" -[mM][-]module execute \"use/no module...\" before executing program\n"
2961" -n assume \"while (<>) { ... }\" loop around program\n"
2962" -p assume loop like -n but print line also, like sed\n"
2963" -s enable rudimentary parsing for switches after programfile\n"
2964" -S look for programfile using PATH environment variable\n",
2965" -t enable tainting warnings\n"
2966" -T enable tainting checks\n"
2967" -u dump core after parsing program\n"
2968" -U allow unsafe operations\n"
2969" -v print version, patchlevel and license\n"
2970" -V[:variable] print configuration summary (or a single Config.pm variable)\n",
60eaec42 2971" -w enable many useful warnings\n"
1566c39d
NC		 2972" -W enable all warnings\n"
2973" -x[directory] ignore text before #!perl line (optionally cd to directory)\n"
2974" -X disable all warnings\n"
2975" \n"
2976"Run 'perldoc perl' for more help with Perl.\n\n",
fb73857a 2977NULL
2978};
27da23d5 2979 const char * const *p = usage_msg;
1566c39d 2980 PerlIO *out = PerlIO_stdout();
fb73857a 2981
1566c39d
NC		 2982 PerlIO_printf(out,
2983 "\nUsage: %s [switches] [--] [programfile] [arguments]\n",
b6f82619 2984 PL_origargv[0]);
fb73857a 2985 while (*p)
1566c39d 2986 PerlIO_puts(out, *p++);
b6f82619 2987 my_exit(0);
4633a7c4
LW		 2988}
2989
b4ab917c
DM		 2990/* convert a string of -D options (or digits) into an int.
2991 * sets *s to point to the char after the options */
2992
2993#ifdef DEBUGGING
2994int
e1ec3a88 2995Perl_get_debug_opts(pTHX_ const char **s, bool givehelp)
b4ab917c 2996{
27da23d5 2997 static const char * const usage_msgd[] = {
651b8f1a
NC		 2998 " Debugging flag values: (see also -d)\n"
2999 " p Tokenizing and parsing (with v, displays parse stack)\n"
3000 " s Stack snapshots (with v, displays all stacks)\n"
3001 " l Context (loop) stack processing\n"
3002 " t Trace execution\n"
3003 " o Method and overloading resolution\n",
3004 " c String/numeric conversions\n"
3005 " P Print profiling info, source file input state\n"
3006 " m Memory and SV allocation\n"
3007 " f Format processing\n"
3008 " r Regular expression parsing and execution\n"
3009 " x Syntax tree dump\n",
3010 " u Tainting checks\n"
3011 " H Hash dump -- usurps values()\n"
3012 " X Scratchpad allocation\n"
3013 " D Cleaning up\n"
56967202 3014 " S Op slab allocation\n"
651b8f1a
NC		 3015 " T Tokenising\n"
3016 " R Include reference counts of dumped variables (eg when using -Ds)\n",
3017 " J Do not s,t,P-debug (Jump over) opcodes within package DB\n"
3018 " v Verbose: use in conjunction with other flags\n"
3019 " C Copy On Write\n"
3020 " A Consistency checks on internal structures\n"
3021 " q quiet - currently only suppresses the 'EXECUTING' message\n"
3022 " M trace smart match resolution\n"
3023 " B dump suBroutine definitions, including special Blocks like BEGIN\n",
69014004 3024 " L trace some locale setting information--for Perl core development\n",
e6e64d9b
JC		 3025 NULL
3026 };
b4ab917c 3027 int i = 0;
7918f24d
NC		 3028
3029 PERL_ARGS_ASSERT_GET_DEBUG_OPTS;
3030
b4ab917c
DM		 3031 if (isALPHA(**s)) {
3032 /* if adding extra options, remember to update DEBUG_MASK */
69014004 3033 static const char debopts[] = "psltocPmfrxuUHXDSTRJvCAqMBL";
b4ab917c 3034
0eb30aeb 3035 for (; isWORDCHAR(**s); (*s)++) {
c4420975 3036 const char * const d = strchr(debopts,**s);
b4ab917c
DM		 3037 if (d)
3038 i |= 1 << (d - debopts);
3039 else if (ckWARN_d(WARN_DEBUGGING))
e6e64d9b
JC		 3040 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
3041 "invalid option -D%c, use -D'' to see choices\n", **s);
b4ab917c
DM		 3042 }
3043 }
e6e64d9b 3044 else if (isDIGIT(**s)) {
b4ab917c 3045 i = atoi(*s);
0eb30aeb 3046 for (; isWORDCHAR(**s); (*s)++) ;
b4ab917c 3047 }
ddcf8bc1 3048 else if (givehelp) {
06e869a4 3049 const char *const *p = usage_msgd;
651b8f1a 3050 while (*p) PerlIO_puts(PerlIO_stdout(), *p++);
e6e64d9b 3051 }
b4ab917c
DM		 3052# ifdef EBCDIC
3053 if ((i & DEBUG_p_FLAG) && ckWARN_d(WARN_DEBUGGING))
3054 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
3055 "-Dp not implemented on this platform\n");
3056# endif
3057 return i;
3058}
3059#endif
3060
79072805
LW		 3061/* This routine handles any switches that can be given during run */
3062
c7030b81
NC		 3063const char *
3064Perl_moreswitches(pTHX_ const char *s)
79072805 3065{
27da23d5 3066 dVAR;
84c133a0 3067 UV rschar;
0544e6df 3068 const char option = *s; /* used to remember option in -m/-M code */
79072805 3069
7918f24d
NC		 3070 PERL_ARGS_ASSERT_MORESWITCHES;
3071
79072805
LW		 3072 switch (*s) {
3073 case '0':
a863c7d1 3074 {
f2095865 3075 I32 flags = 0;
a3b680e6 3076 STRLEN numlen;
f2095865
JH		 3077
3078 SvREFCNT_dec(PL_rs);
3079 if (s[1] == 'x' && s[2]) {
a3b680e6 3080 const char *e = s+=2;
f2095865
JH		 3081 U8 *tmps;
3082
a3b680e6
AL		 3083 while (*e)
3084 e++;
f2095865
JH		 3085 numlen = e - s;
3086 flags = PERL_SCAN_SILENT_ILLDIGIT;
3087 rschar = (U32)grok_hex(s, &numlen, &flags, NULL);
3088 if (s + numlen < e) {
3089 rschar = 0; /* Grandfather -0xFOO as -0 -xFOO. */
3090 numlen = 0;
3091 s--;
3092 }
396482e1 3093 PL_rs = newSVpvs("");
c5661c80 3094 SvGROW(PL_rs, (STRLEN)(UNISKIP(rschar) + 1));
f2095865
JH		 3095 tmps = (U8*)SvPVX(PL_rs);
3096 uvchr_to_utf8(tmps, rschar);
3097 SvCUR_set(PL_rs, UNISKIP(rschar));
3098 SvUTF8_on(PL_rs);
3099 }
3100 else {
3101 numlen = 4;
3102 rschar = (U32)grok_oct(s, &numlen, &flags, NULL);
3103 if (rschar & ~((U8)~0))
3104 PL_rs = &PL_sv_undef;
3105 else if (!rschar && numlen >= 2)
396482e1 3106 PL_rs = newSVpvs("");
f2095865
JH		 3107 else {
3108 char ch = (char)rschar;
3109 PL_rs = newSVpvn(&ch, 1);
3110 }
3111 }
64ace3f8 3112 sv_setsv(get_sv("/", GV_ADD), PL_rs);
f2095865 3113 return s + numlen;
a863c7d1 3114 }
46487f74 3115 case 'C':
a05d7ebb 3116 s++;
dd374669 3117 PL_unicode = parse_unicode_opts( (const char **)&s );
5a22a2bb
NC		 3118 if (PL_unicode & PERL_UNICODE_UTF8CACHEASSERT_FLAG)
3119 PL_utf8cache = -1;
46487f74 3120 return s;
2304df62 3121 case 'F':
5fc691f1 3122 PL_minus_a = TRUE;
3280af22 3123 PL_minus_F = TRUE;
24ffa309 3124 PL_minus_n = TRUE;
ebce5377
RGS		 3125 PL_splitstr = ++s;
3126 while (*s && !isSPACE(*s)) ++s;
e49e380e 3127 PL_splitstr = savepvn(PL_splitstr, s - PL_splitstr);
2304df62 3128 return s;
79072805 3129 case 'a':
3280af22 3130 PL_minus_a = TRUE;
24ffa309 3131 PL_minus_n = TRUE;
79072805
LW		 3132 s++;
3133 return s;
3134 case 'c':
3280af22 3135 PL_minus_c = TRUE;
79072805
LW		 3136 s++;
3137 return s;
3138 case 'd':
f20b2998 3139 forbid_setid('d', FALSE);
4633a7c4 3140 s++;
2cbb2ee1
RGS		 3141
3142 /* -dt indicates to the debugger that threads will be used */
0eb30aeb 3143 if (*s == 't' && !isWORDCHAR(s[1])) {
2cbb2ee1
RGS		 3144 ++s;
3145 my_setenv("PERL5DB_THREADED", "1");
3146 }
3147
70c94a19
RR		 3148 /* The following permits -d:Mod to accepts arguments following an =
3149 in the fashion that -MSome::Mod does. */
3150 if (*s == ':' || *s == '=') {
b19934fb
NC		 3151 const char *start;
3152 const char *end;
3153 SV *sv;
3154
3155 if (*++s == '-') {
3156 ++s;
3157 sv = newSVpvs("no Devel::");
3158 } else {
3159 sv = newSVpvs("use Devel::");
3160 }
3161
3162 start = s;
3163 end = s + strlen(s);
f85893a1 3164
b19934fb 3165 /* We now allow -d:Module=Foo,Bar and -d:-Module */
0eb30aeb 3166 while(isWORDCHAR(*s) || *s==':') ++s;
70c94a19 3167 if (*s != '=')
f85893a1 3168 sv_catpvn(sv, start, end - start);
70c94a19
RR		 3169 else {
3170 sv_catpvn(sv, start, s-start);
95a2b409
RGS		 3171 /* Don't use NUL as q// delimiter here, this string goes in the
3172 * environment. */
3173 Perl_sv_catpvf(aTHX_ sv, " split(/,/,q{%s});", ++s);
70c94a19 3174 }
f85893a1 3175 s = end;
184f32ec 3176 my_setenv("PERL5DB", SvPV_nolen_const(sv));
c4db126b 3177 SvREFCNT_dec(sv);
4633a7c4 3178 }
ed094faf 3179 if (!PL_perldb) {
3280af22 3180 PL_perldb = PERLDB_ALL;
a0d0e21e 3181 init_debugger();
ed094faf 3182 }
79072805
LW		 3183 return s;
3184 case 'D':
0453d815 3185 {
79072805 3186#ifdef DEBUGGING
f20b2998 3187 forbid_setid('D', FALSE);
b4ab917c 3188 s++;
dd374669 3189 PL_debug = get_debug_opts( (const char **)&s, 1) | DEBUG_TOP_FLAG;
12a43e32 3190#else /* !DEBUGGING */
0453d815 3191 if (ckWARN_d(WARN_DEBUGGING))
9014280d 3192 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
e6e64d9b 3193 "Recompile perl with -DDEBUGGING to use -D switch (did you mean -d ?)\n");
0eb30aeb 3194 for (s++; isWORDCHAR(*s); s++) ;
79072805 3195#endif
79072805 3196 return s;
0453d815 3197 }
4633a7c4 3198 case 'h':
b6f82619 3199 usage();
79072805 3200 case 'i':
43c5f42d 3201 Safefree(PL_inplace);
c030f24b
GH		 3202#if defined(__CYGWIN__) /* do backup extension automagically */
3203 if (*(s+1) == '\0') {
c86a4f2e 3204 PL_inplace = savepvs(".bak");
c030f24b
GH		 3205 return s+1;
3206 }
3207#endif /* __CYGWIN__ */
5ef5d758 3208 {
d4c19fe8 3209 const char * const start = ++s;
5ef5d758
NC		 3210 while (*s && !isSPACE(*s))
3211 ++s;
3212
3213 PL_inplace = savepvn(start, s - start);
3214 }
7b8d334a 3215 if (*s) {
5ef5d758 3216 ++s;
7b8d334a 3217 if (*s == '-') /* Additional switches on #! line. */
5ef5d758 3218 s++;
7b8d334a 3219 }
fb73857a 3220 return s;
4e49a025 3221 case 'I': /* -I handled both here and in parse_body() */
f20b2998 3222 forbid_setid('I', FALSE);
fb73857a 3223 ++s;
3224 while (*s && isSPACE(*s))
3225 ++s;
3226 if (*s) {
c7030b81 3227 const char *e, *p;
0df16ed7
GS		 3228 p = s;
3229 /* ignore trailing spaces (possibly followed by other switches) */
3230 do {
3231 for (e = p; *e && !isSPACE(*e); e++) ;
3232 p = e;
3233 while (isSPACE(*p))
3234 p++;
3235 } while (*p && *p != '-');
55b4bc1c 3236 incpush(s, e-s,
e28f3139 3237 INCPUSH_ADD_SUB_DIRS|INCPUSH_ADD_OLD_VERS|INCPUSH_UNSHIFT);
0df16ed7
GS		 3238 s = p;
3239 if (*s == '-')
3240 s++;
79072805
LW		 3241 }
3242 else
a67e862a 3243 Perl_croak(aTHX_ "No directory specified for -I");
fb73857a 3244 return s;
79072805 3245 case 'l':
3280af22 3246 PL_minus_l = TRUE;
79072805 3247 s++;
7889fe52
NIS		 3248 if (PL_ors_sv) {
3249 SvREFCNT_dec(PL_ors_sv);
a0714e2c 3250 PL_ors_sv = NULL;
7889fe52 3251 }
79072805 3252 if (isDIGIT(*s)) {
53305cf1 3253 I32 flags = 0;
a3b680e6 3254 STRLEN numlen;
396482e1 3255 PL_ors_sv = newSVpvs("\n");
53305cf1
NC		 3256 numlen = 3 + (*s == '0');
3257 *SvPVX(PL_ors_sv) = (char)grok_oct(s, &numlen, &flags, NULL);
79072805
LW		 3258 s += numlen;
3259 }
3260 else {
8bfdd7d9 3261 if (RsPARA(PL_rs)) {
396482e1 3262 PL_ors_sv = newSVpvs("\n\n");
7889fe52
NIS		 3263 }
3264 else {
8bfdd7d9 3265 PL_ors_sv = newSVsv(PL_rs);
c07a80fd 3266 }
79072805
LW		 3267 }
3268 return s;
1a30305b 3269 case 'M':
f20b2998 3270 forbid_setid('M', FALSE); /* XXX ? */
924ba076 3271 /* FALLTHROUGH */
1a30305b 3272 case 'm':
f20b2998 3273 forbid_setid('m', FALSE); /* XXX ? */
1a30305b 3274 if (*++s) {
c7030b81 3275 const char *start;
b64cb68c 3276 const char *end;
11343788 3277 SV *sv;
e1ec3a88 3278 const char *use = "use ";
0544e6df 3279 bool colon = FALSE;
a5f75d66 3280 /* -M-foo == 'no foo' */
d0043bd1
NC		 3281 /* Leading space on " no " is deliberate, to make both
3282 possibilities the same length. */
3283 if (*s == '-') { use = " no "; ++s; }
3284 sv = newSVpvn(use,4);
a5f75d66 3285 start = s;
1a30305b 3286 /* We allow -M'Module qw(Foo Bar)' */
0eb30aeb 3287 while(isWORDCHAR(*s) || *s==':') {
0544e6df
RB		 3288 if( *s++ == ':' ) {
3289 if( *s == ':' )
3290 s++;
3291 else
3292 colon = TRUE;
3293 }
3294 }
3295 if (s == start)
3296 Perl_croak(aTHX_ "Module name required with -%c option",
3297 option);
3298 if (colon)
3299 Perl_croak(aTHX_ "Invalid module name %.*s with -%c option: "
3300 "contains single ':'",
63da6837 3301 (int)(s - start), start, option);
b64cb68c 3302 end = s + strlen(s);
c07a80fd 3303 if (*s != '=') {
b64cb68c 3304 sv_catpvn(sv, start, end - start);
0544e6df 3305 if (option == 'm') {
c07a80fd 3306 if (*s != '\0')
cea2e8a9 3307 Perl_croak(aTHX_ "Can't use '%c' after -mname", *s);
396482e1 3308 sv_catpvs( sv, " ()");
c07a80fd 3309 }
3310 } else {
11343788 3311 sv_catpvn(sv, start, s-start);
b64cb68c
NC		 3312 /* Use NUL as q''-delimiter. */
3313 sv_catpvs(sv, " split(/,/,q\0");
3314 ++s;
3315 sv_catpvn(sv, s, end - s);
396482e1 3316 sv_catpvs(sv, "\0)");
c07a80fd 3317 }
b64cb68c 3318 s = end;
29a861e7 3319 Perl_av_create_and_push(aTHX_ &PL_preambleav, sv);
1a30305b 3320 }
3321 else
0544e6df 3322 Perl_croak(aTHX_ "Missing argument to -%c", option);
1a30305b 3323 return s;
79072805 3324 case 'n':
3280af22 3325 PL_minus_n = TRUE;
79072805
LW		 3326 s++;
3327 return s;
3328 case 'p':
3280af22 3329 PL_minus_p = TRUE;
79072805
LW		 3330 s++;
3331 return s;
3332 case 's':
f20b2998 3333 forbid_setid('s', FALSE);
3280af22 3334 PL_doswitches = TRUE;
79072805
LW		 3335 s++;
3336 return s;
6537fe72 3337 case 't':
27a6968b 3338 case 'T':
dc6d7f5c 3339#if defined(SILENT_NO_TAINT_SUPPORT)
284167a5 3340 /* silently ignore */
dc6d7f5c 3341#elif defined(NO_TAINT_SUPPORT)
3231f579 3342 Perl_croak_nocontext("This perl was compiled without taint support. "
284167a5
S		 3343 "Cowardly refusing to run with -t or -T flags");
3344#else
3345 if (!TAINTING_get)
27a6968b 3346 TOO_LATE_FOR(*s);
284167a5 3347#endif
6537fe72 3348 s++;
463ee0b2 3349 return s;
79072805 3350 case 'u':
3280af22 3351 PL_do_undump = TRUE;
79072805
LW		 3352 s++;
3353 return s;
3354 case 'U':
3280af22 3355 PL_unsafe = TRUE;
79072805
LW		 3356 s++;
3357 return s;
3358 case 'v':
c4bc78d9
NC		 3359 minus_v();
3360 case 'w':
3361 if (! (PL_dowarn & G_WARN_ALL_MASK)) {
3362 PL_dowarn |= G_WARN_ON;
3363 }
3364 s++;
3365 return s;
3366 case 'W':
3367 PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
3368 if (!specialWARN(PL_compiling.cop_warnings))
3369 PerlMemShared_free(PL_compiling.cop_warnings);
3370 PL_compiling.cop_warnings = pWARN_ALL ;
3371 s++;
3372 return s;
3373 case 'X':
3374 PL_dowarn = G_WARN_ALL_OFF;
3375 if (!specialWARN(PL_compiling.cop_warnings))
3376 PerlMemShared_free(PL_compiling.cop_warnings);
3377 PL_compiling.cop_warnings = pWARN_NONE ;
3378 s++;
3379 return s;
3380 case '*':
3381 case ' ':
3382 while( *s == ' ' )
3383 ++s;
3384 if (s[0] == '-') /* Additional switches on #! line. */
3385 return s+1;
3386 break;
3387 case '-':
3388 case 0:
3389#if defined(WIN32) || !defined(PERL_STRICT_CR)
3390 case '\r':
3391#endif
3392 case '\n':
3393 case '\t':
3394 break;
3395#ifdef ALTERNATE_SHEBANG
3396 case 'S': /* OS/2 needs -S on "extproc" line. */
3397 break;
3398#endif
4bb78d63
CB		 3399 case 'e': case 'f': case 'x': case 'E':
3400#ifndef ALTERNATE_SHEBANG
3401 case 'S':
3402#endif
3403 case 'V':
c4bc78d9 3404 Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s);
b7e077d0
FC		 3405 default:
3406 Perl_croak(aTHX_
3407 "Unrecognized switch: -%.1s (-h will show valid options)",s
3408 );
c4bc78d9
NC		 3409 }
3410 return NULL;
3411}
3412
3413
3414STATIC void
3415S_minus_v(pTHX)
3416{
fc3381af 3417 PerlIO * PIO_stdout;
46807d8e 3418 {
709aee94
DD		 3419 const char * const level_str = "v" PERL_VERSION_STRING;
3420 const STRLEN level_len = sizeof("v" PERL_VERSION_STRING)-1;
46807d8e 3421#ifdef PERL_PATCHNUM
709aee94 3422 SV* level;
23d483e2 3423# ifdef PERL_GIT_UNCOMMITTED_CHANGES
709aee94 3424 static const char num [] = PERL_PATCHNUM "*";
23d483e2 3425# else
709aee94 3426 static const char num [] = PERL_PATCHNUM;
23d483e2 3427# endif
fc3381af 3428 {
709aee94
DD		 3429 const STRLEN num_len = sizeof(num)-1;
3430 /* A very advanced compiler would fold away the strnEQ
3431 and this whole conditional, but most (all?) won't do it.
3432 SV level could also be replaced by with preprocessor
3433 catenation.
3434 */
3435 if (num_len >= level_len && strnEQ(num,level_str,level_len)) {
3436 /* per 46807d8e80, PERL_PATCHNUM is outside of the control
3437 of the interp so it might contain format characters
3438 */
3439 level = newSVpvn(num, num_len);
fc3381af 3440 } else {
709aee94 3441 level = Perl_newSVpvf_nocontext("%s (%s)", level_str, num);
fc3381af 3442 }
46807d8e 3443 }
709aee94
DD		 3444#else
3445 SV* level = newSVpvn(level_str, level_len);
3446#endif /* #ifdef PERL_PATCHNUM */
fc3381af
DD		 3447 PIO_stdout = PerlIO_stdout();
3448 PerlIO_printf(PIO_stdout,
ded326e4
DG		 3449 "\nThis is perl " STRINGIFY(PERL_REVISION)
3450 ", version " STRINGIFY(PERL_VERSION)
3451 ", subversion " STRINGIFY(PERL_SUBVERSION)
c1f6cd39 3452 " (%"SVf") built for " ARCHNAME, SVfARG(level)
ded326e4 3453 );
709aee94 3454 SvREFCNT_dec_NN(level);
46807d8e 3455 }
fb73857a 3456#if defined(LOCAL_PATCH_COUNT)
3457 if (LOCAL_PATCH_COUNT > 0)
fc3381af 3458 PerlIO_printf(PIO_stdout,
b0e47665
GS		 3459 "\n(with %d registered patch%s, "
3460 "see perl -V for more detail)",
bb7a0f54 3461 LOCAL_PATCH_COUNT,
b0e47665 3462 (LOCAL_PATCH_COUNT!=1) ? "es" : "");
a5f75d66 3463#endif
1a30305b 3464
fc3381af 3465 PerlIO_printf(PIO_stdout,
fb435042 3466 "\n\nCopyright 1987-2014, Larry Wall\n");
79072805 3467#ifdef MSDOS
fc3381af 3468 PerlIO_printf(PIO_stdout,
b0e47665 3469 "\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
55497cff 3470#endif
3471#ifdef DJGPP
fc3381af 3472 PerlIO_printf(PIO_stdout,
b0e47665
GS		 3473 "djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n"
3474 "djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n");
4633a7c4 3475#endif
79072805 3476#ifdef OS2
fc3381af 3477 PerlIO_printf(PIO_stdout,
b0e47665 3478 "\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
be3c0a43 3479 "Version 5 port Copyright (c) 1994-2002, Andreas Kaiser, Ilya Zakharevich\n");
79072805 3480#endif
9d116dd7 3481#ifdef OEMVS
fc3381af 3482 PerlIO_printf(PIO_stdout,
b0e47665 3483 "MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
9d116dd7 3484#endif
495c5fdc 3485#ifdef __VOS__
fc3381af 3486 PerlIO_printf(PIO_stdout,
c0fcb8c5 3487 "Stratus OpenVOS port by Paul.Green@stratus.com, 1997-2013\n");
495c5fdc 3488#endif
a1a0e61e 3489#ifdef POSIX_BC
fc3381af 3490 PerlIO_printf(PIO_stdout,
b0e47665 3491 "BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
a1a0e61e 3492#endif
e1caacb4 3493#ifdef UNDER_CE
fc3381af
DD		 3494 PerlIO_printf(PIO_stdout,
3495 "WINCE port by Rainer Keuchel, 2001-2002\n"
3496 "Built on " __DATE__ " " __TIME__ "\n\n");
e1caacb4
JH		 3497 wce_hitreturn();
3498#endif
a0fd4948 3499#ifdef __SYMBIAN32__
fc3381af 3500 PerlIO_printf(PIO_stdout,
27da23d5
JH		 3501 "Symbian port by Nokia, 2004-2005\n");
3502#endif
baed7233
DL		 3503#ifdef BINARY_BUILD_NOTICE
3504 BINARY_BUILD_NOTICE;
3505#endif
fc3381af 3506 PerlIO_printf(PIO_stdout,
b0e47665 3507 "\n\
79072805 3508Perl may be copied only under the terms of either the Artistic License or the\n\
3d6f292d 3509GNU General Public License, which may be found in the Perl 5 source kit.\n\n\
95103687 3510Complete documentation for Perl, including FAQ lists, should be found on\n\
a0288114 3511this system using \"man perl\" or \"perldoc perl\". If you have access to the\n\
c9e30dd8 3512Internet, point your browser at http://www.perl.org/, the Perl Home Page.\n\n");
7ca617d0 3513 my_exit(0);
79072805
LW		 3514}
3515
3516/* compliments of Tom Christiansen */
3517
3518/* unexec() can be found in the Gnu emacs distribution */
ee580363 3519/* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
79072805 3520
25bbd826
CB		 3521#ifdef VMS
3522#include <lib$routines.h>
3523#endif
3524
79072805 3525void
864dbfa3 3526Perl_my_unexec(pTHX)
79072805
LW		 3527{
3528#ifdef UNEXEC
b37c2d43
AL		 3529 SV * prog = newSVpv(BIN_EXP, 0);
3530 SV * file = newSVpv(PL_origfilename, 0);
ee580363 3531 int status = 1;
79072805
LW		 3532 extern int etext;
3533
396482e1 3534 sv_catpvs(prog, "/perl");
396482e1 3535 sv_catpvs(file, ".perldump");
79072805 3536
ee580363
GS		 3537 unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
3538 /* unexec prints msg to stderr in case of failure */
6ad3d225 3539 PerlProc_exit(status);
79072805 3540#else
ddeaf645 3541 PERL_UNUSED_CONTEXT;
a5f75d66 3542# ifdef VMS
a5f75d66 3543 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
84d78eb7 3544# elif defined(WIN32) || defined(__CYGWIN__)
ddeaf645 3545 Perl_croak_nocontext("dump is not supported");
aa689395 3546# else
79072805 3547 ABORT(); /* for use with undump */
aa689395 3548# endif
a5f75d66 3549#endif
79072805
LW		 3550}
3551
cb68f92d
GS		 3552/* initialize curinterp */
3553STATIC void
cea2e8a9 3554S_init_interp(pTHX)
cb68f92d 3555{
acfe0abc 3556#ifdef MULTIPLICITY
115ff745
NC		 3557# define PERLVAR(prefix,var,type)
3558# define PERLVARA(prefix,var,n,type)
acfe0abc 3559# if defined(PERL_IMPLICIT_CONTEXT)
115ff745
NC		 3560# define PERLVARI(prefix,var,type,init) aTHX->prefix##var = init;
3561# define PERLVARIC(prefix,var,type,init) aTHX->prefix##var = init;
3967c732 3562# else
115ff745
NC		 3563# define PERLVARI(prefix,var,type,init) PERL_GET_INTERP->var = init;
3564# define PERLVARIC(prefix,var,type,init) PERL_GET_INTERP->var = init;
066ef5b5 3565# endif
acfe0abc 3566# include "intrpvar.h"
acfe0abc
GS		 3567# undef PERLVAR
3568# undef PERLVARA
3569# undef PERLVARI
3570# undef PERLVARIC
3571#else
115ff745
NC		 3572# define PERLVAR(prefix,var,type)
3573# define PERLVARA(prefix,var,n,type)
3574# define PERLVARI(prefix,var,type,init) PL_##var = init;
3575# define PERLVARIC(prefix,var,type,init) PL_##var = init;
acfe0abc 3576# include "intrpvar.h"
acfe0abc
GS		 3577# undef PERLVAR
3578# undef PERLVARA
3579# undef PERLVARI
3580# undef PERLVARIC
cb68f92d
GS		 3581#endif
3582
cb68f92d
GS		 3583}
3584
76e3520e 3585STATIC void
cea2e8a9 3586S_init_main_stash(pTHX)
79072805 3587{
463ee0b2 3588 GV *gv;
6e72f9df 3589
03d9f026 3590 PL_curstash = PL_defstash = (HV *)SvREFCNT_inc_simple_NN(newHV());
23579a14
NC		 3591 /* We know that the string "main" will be in the global shared string
3592 table, so it's a small saving to use it rather than allocate another
3593 8 bytes. */
18916d0d 3594 PL_curstname = newSVpvs_share("main");
fafc274c 3595 gv = gv_fetchpvs("main::", GV_ADD|GV_NOTQUAL, SVt_PVHV);
23579a14
NC		 3596 /* If we hadn't caused another reference to "main" to be in the shared
3597 string table above, then it would be worth reordering these two,
3598 because otherwise all we do is delete "main" from it as a consequence
3599 of the SvREFCNT_dec, only to add it again with hv_name_set */
adbc6bb1 3600 SvREFCNT_dec(GvHV(gv));
23579a14 3601 hv_name_set(PL_defstash, "main", 4, 0);
85fbaab2 3602 GvHV(gv) = MUTABLE_HV(SvREFCNT_inc_simple(PL_defstash));
463ee0b2 3603 SvREADONLY_on(gv);
fafc274c
NC		 3604 PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpvs("INC", GV_ADD|GV_NOTQUAL,
3605 SVt_PVAV)));
5a5094bd 3606 SvREFCNT_inc_simple_void(PL_incgv); /* Don't allow it to be freed */
3280af22 3607 GvMULTI_on(PL_incgv);
fafc274c 3608 PL_hintgv = gv_fetchpvs("\010", GV_ADD|GV_NOTQUAL, SVt_PV); /* ^H */
4639d557 3609 SvREFCNT_inc_simple_void(PL_hintgv);
3280af22 3610 GvMULTI_on(PL_hintgv);
fafc274c 3611 PL_defgv = gv_fetchpvs("_", GV_ADD|GV_NOTQUAL, SVt_PVAV);
5a5094bd 3612 SvREFCNT_inc_simple_void(PL_defgv);
d456e3f4 3613 PL_errgv = gv_fetchpvs("@", GV_ADD|GV_NOTQUAL, SVt_PV);
5a5094bd 3614 SvREFCNT_inc_simple_void(PL_errgv);
3280af22 3615 GvMULTI_on(PL_errgv);
fafc274c 3616 PL_replgv = gv_fetchpvs("\022", GV_ADD|GV_NOTQUAL, SVt_PV); /* ^R */
475b1e90 3617 SvREFCNT_inc_simple_void(PL_replgv);
3280af22 3618 GvMULTI_on(PL_replgv);
cea2e8a9 3619 (void)Perl_form(aTHX_ "%240s",""); /* Preallocate temp - for immediate signals. */
c69033f2
NC		 3620#ifdef PERL_DONT_CREATE_GVSV
3621 gv_SVadd(PL_errgv);
3622#endif
38a03e6e 3623 sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */
ab69dbc2 3624 CLEAR_ERRSV();
03d9f026 3625 SET_CURSTASH(PL_defstash);
11faa288 3626 CopSTASH_set(&PL_compiling, PL_defstash);
5c1737d1
NC		 3627 PL_debstash = GvHV(gv_fetchpvs("DB::", GV_ADDMULTI, SVt_PVHV));
3628 PL_globalstash = GvHV(gv_fetchpvs("CORE::GLOBAL::", GV_ADDMULTI,
3629 SVt_PVHV));
4633a7c4 3630 /* We must init $/ before switches are processed. */
64ace3f8 3631 sv_setpvs(get_sv("/", GV_ADD), "\n");
79072805
LW		 3632}
3633
8d113837
NC		 3634STATIC PerlIO *
3635S_open_script(pTHX_ const char *scriptname, bool dosearch, bool *suidscript)
79072805 3636{
fdf5d70d 3637 int fdscript = -1;
8d113837 3638 PerlIO *rsfp = NULL;
1dfef69b 3639 Stat_t tmpstatbuf;
375ed12a 3640 int fd;
1b24ed4b 3641
7918f24d
NC		 3642 PERL_ARGS_ASSERT_OPEN_SCRIPT;
3643
3280af22 3644 if (PL_e_script) {
8afc33d6 3645 PL_origfilename = savepvs("-e");
96436eeb 3646 }
6c4ab083
GS		 3647 else {
3648 /* if find_script() returns, it returns a malloc()-ed value */
dd374669 3649 scriptname = PL_origfilename = find_script(scriptname, dosearch, NULL, 1);
6c4ab083
GS		 3650
3651 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
e1ec3a88 3652 const char *s = scriptname + 8;
fdf5d70d 3653 fdscript = atoi(s);
6c4ab083
GS		 3654 while (isDIGIT(*s))
3655 s++;
3656 if (*s) {
ae3f3efd
PS		 3657 /* PSz 18 Feb 04
3658 * Tell apart "normal" usage of fdscript, e.g.
3659 * with bash on FreeBSD:
3660 * perl <( echo '#!perl -DA'; echo 'print "$0\n"')
3661 * from usage in suidperl.
3662 * Does any "normal" usage leave garbage after the number???
3663 * Is it a mistake to use a similar /dev/fd/ construct for
3664 * suidperl?
3665 */
f20b2998 3666 *suidscript = TRUE;
ae3f3efd
PS		 3667 /* PSz 20 Feb 04
3668 * Be supersafe and do some sanity-checks.
3669 * Still, can we be sure we got the right thing?
3670 */
3671 if (*s != '/') {
3672 Perl_croak(aTHX_ "Wrong syntax (suid) fd script name \"%s\"\n", s);
3673 }
3674 if (! *(s+1)) {
3675 Perl_croak(aTHX_ "Missing (suid) fd script name\n");
3676 }
6c4ab083 3677 scriptname = savepv(s + 1);
3280af22 3678 Safefree(PL_origfilename);
dd374669 3679 PL_origfilename = (char *)scriptname;
6c4ab083
GS		 3680 }
3681 }
3682 }
3683
05ec9bb3 3684 CopFILE_free(PL_curcop);
57843af0 3685 CopFILE_set(PL_curcop, PL_origfilename);
770526c1 3686 if (*PL_origfilename == '-' && PL_origfilename[1] == '\0')
dd374669 3687 scriptname = (char *)"";
fdf5d70d 3688 if (fdscript >= 0) {
8d113837 3689 rsfp = PerlIO_fdopen(fdscript,PERL_SCRIPT_MODE);
96436eeb 3690 }
79072805 3691 else if (!*scriptname) {
cdd8118e 3692 forbid_setid(0, *suidscript);
c0b3891a 3693 return NULL;
79072805 3694 }
96436eeb 3695 else {
9c12f1e5
RGS		 3696#ifdef FAKE_BIT_BUCKET
3697 /* This hack allows one not to have /dev/null (or BIT_BUCKET as it
3698 * is called) and still have the "-e" work. (Believe it or not,
3699 * a /dev/null is required for the "-e" to work because source
3700 * filter magic is used to implement it. ) This is *not* a general
3701 * replacement for a /dev/null. What we do here is create a temp
3702 * file (an empty file), open up that as the script, and then
3703 * immediately close and unlink it. Close enough for jazz. */
3704#define FAKE_BIT_BUCKET_PREFIX "/tmp/perlnull-"
3705#define FAKE_BIT_BUCKET_SUFFIX "XXXXXXXX"
3706#define FAKE_BIT_BUCKET_TEMPLATE FAKE_BIT_BUCKET_PREFIX FAKE_BIT_BUCKET_SUFFIX
3707 char tmpname[sizeof(FAKE_BIT_BUCKET_TEMPLATE)] = {
3708 FAKE_BIT_BUCKET_TEMPLATE
3709 };
3710 const char * const err = "Failed to create a fake bit bucket";
3711 if (strEQ(scriptname, BIT_BUCKET)) {
3712#ifdef HAS_MKSTEMP /* Hopefully mkstemp() is safe here. */
60f7fc1e 3713 int old_umask = umask(0600);
9c12f1e5 3714 int tmpfd = mkstemp(tmpname);
60f7fc1e 3715 umask(old_umask);
9c12f1e5
RGS		 3716 if (tmpfd > -1) {
3717 scriptname = tmpname;
3718 close(tmpfd);
3719 } else
3720 Perl_croak(aTHX_ err);
3721#else
3722# ifdef HAS_MKTEMP
3723 scriptname = mktemp(tmpname);
3724 if (!scriptname)
3725 Perl_croak(aTHX_ err);
3726# endif
3727#endif
3728 }
3729#endif
8d113837 3730 rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
9c12f1e5
RGS		 3731#ifdef FAKE_BIT_BUCKET
3732 if (memEQ(scriptname, FAKE_BIT_BUCKET_PREFIX,
3733 sizeof(FAKE_BIT_BUCKET_PREFIX) - 1)
3734 && strlen(scriptname) == sizeof(tmpname) - 1) {
3735 unlink(scriptname);
3736 }
3737 scriptname = BIT_BUCKET;
3738#endif
96436eeb 3739 }
8d113837 3740 if (!rsfp) {
447218f8 3741 /* PSz 16 Sep 03 Keep neat error message */
b1681ed3
RGS		 3742 if (PL_e_script)
3743 Perl_croak(aTHX_ "Can't open "BIT_BUCKET": %s\n", Strerror(errno));
3744 else
3745 Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
3746 CopFILE(PL_curcop), Strerror(errno));
13281fa4 3747 }
375ed12a 3748 fd = PerlIO_fileno(rsfp);
a7c81930 3749#if defined(HAS_FCNTL) && defined(F_SETFD)
375ed12a
JH		 3750 if (fd >= 0) {
3751 /* ensure close-on-exec */
3752 if (fcntl(fd, F_SETFD, 1) < 0) {
3753 Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
3754 CopFILE(PL_curcop), Strerror(errno));
3755 }
3756 }
a7c81930 3757#endif
1dfef69b 3758
375ed12a
JH		 3759 if (fd < 0 ||
3760 (PerlLIO_fstat(fd, &tmpstatbuf) >= 0
3761 && S_ISDIR(tmpstatbuf.st_mode)))
1dfef69b
RS		 3762 Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
3763 CopFILE(PL_curcop),
0c0d42ff 3764 Strerror(EISDIR));
1dfef69b 3765
8d113837 3766 return rsfp;
79072805 3767}
8d063cd8 3768
7b89560d
JH		 3769/* Mention
3770 * I_SYSSTATVFS HAS_FSTATVFS
3771 * I_SYSMOUNT
c890dc6c 3772 * I_STATFS HAS_FSTATFS HAS_GETFSSTAT
7b89560d
JH		 3773 * I_MNTENT HAS_GETMNTENT HAS_HASMNTOPT
3774 * here so that metaconfig picks them up. */
3775
104d25b7 3776
cc69b689 3777#ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
ec2019ad 3778/* Don't even need this function. */
cc69b689 3779#else
ec2019ad
NC		 3780STATIC void
3781S_validate_suid(pTHX_ PerlIO *rsfp)
3782{
dfff4baf
BF		 3783 const Uid_t my_uid = PerlProc_getuid();
3784 const Uid_t my_euid = PerlProc_geteuid();
3785 const Gid_t my_gid = PerlProc_getgid();
3786 const Gid_t my_egid = PerlProc_getegid();
985213f2 3787
ac076a5c
NC		 3788 PERL_ARGS_ASSERT_VALIDATE_SUID;
3789
985213f2 3790 if (my_euid != my_uid || my_egid != my_gid) { /* (suidperl doesn't exist, in fact) */
a2e578da 3791 dVAR;
375ed12a
JH		 3792 int fd = PerlIO_fileno(rsfp);
3793 if (fd < 0) {
3794 Perl_croak(aTHX_ "Illegal suidscript");
3795 } else {
3796 if (PerlLIO_fstat(fd, &PL_statbuf) < 0) { /* may be either wrapped or real suid */
3797 Perl_croak(aTHX_ "Illegal suidscript");
3798 }
3799 }
3800 if ((my_euid != my_uid && my_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
3801 ||
3802 (my_egid != my_gid && my_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
3803 )
b28d0864 3804 if (!PL_do_undump)
cea2e8a9 3805 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
a687059c 3806FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
a687059c 3807 /* not set-id, must be wrapped */
a687059c 3808 }
79072805 3809}
cc69b689 3810#endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
13281fa4 3811
76e3520e 3812STATIC void
2f9285f8 3813S_find_beginning(pTHX_ SV* linestr_sv, PerlIO *rsfp)
79072805 3814{
c7030b81 3815 const char *s;
eb578fdb 3816 const char *s2;
33b78306 3817
7918f24d
NC		 3818 PERL_ARGS_ASSERT_FIND_BEGINNING;
3819
33b78306
LW		 3820 /* skip forward in input to the real script? */
3821
737c24fc 3822 do {
2f9285f8 3823 if ((s = sv_gets(linestr_sv, rsfp, 0)) == NULL)
cea2e8a9 3824 Perl_croak(aTHX_ "No Perl script found in input\n");
4f0c37ba 3825 s2 = s;
737c24fc
Z		 3826 } while (!(*s == '#' && s[1] == '!' && ((s = instr(s,"perl")) || (s = instr(s2,"PERL")))));
3827 PerlIO_ungetc(rsfp, '\n'); /* to keep line count right */
3828 while (*s && !(isSPACE (*s) || *s == '#')) s++;
3829 s2 = s;
3830 while (*s == ' ' || *s == '\t') s++;
3831 if (*s++ == '-') {
3832 while (isDIGIT(s2[-1]) || s2[-1] == '-' || s2[-1] == '.'
3833 || s2[-1] == '_') s2--;
3834 if (strnEQ(s2-4,"perl",4))
3835 while ((s = moreswitches(s)))
3836 ;
83025b21
LW		 3837 }
3838}
3839
afe37c7d 3840
76e3520e 3841STATIC void
cea2e8a9 3842S_init_ids(pTHX)
352d5a3a 3843{
284167a5
S		 3844 /* no need to do anything here any more if we don't
3845 * do tainting. */
dc6d7f5c 3846#ifndef NO_TAINT_SUPPORT
dfff4baf
BF		 3847 const Uid_t my_uid = PerlProc_getuid();
3848 const Uid_t my_euid = PerlProc_geteuid();
3849 const Gid_t my_gid = PerlProc_getgid();
3850 const Gid_t my_egid = PerlProc_getegid();
985213f2 3851
20b7effb
JH		 3852 PERL_UNUSED_CONTEXT;
3853
22f7c9c9 3854 /* Should not happen: */
985213f2 3855 CHECK_MALLOC_TAINT(my_uid && (my_euid != my_uid || my_egid != my_gid));
284167a5
S		 3856 TAINTING_set( TAINTING_get | (my_uid && (my_euid != my_uid || my_egid != my_gid)) );
3857#endif
ae3f3efd
PS		 3858 /* BUG */
3859 /* PSz 27 Feb 04
3860 * Should go by suidscript, not uid!=euid: why disallow
3861 * system("ls") in scripts run from setuid things?
3862 * Or, is this run before we check arguments and set suidscript?
3863 * What about SETUID_SCRIPTS_ARE_SECURE_NOW: could we use fdscript then?
3864 * (We never have suidscript, can we be sure to have fdscript?)
3865 * Or must then go by UID checks? See comments in forbid_setid also.
3866 */
748a9306 3867}
79072805 3868
a0643315
JH		 3869/* This is used very early in the lifetime of the program,
3870 * before even the options are parsed, so PL_tainting has
b0891165 3871 * not been initialized properly. */
af419de7 3872bool
8f42b153 3873Perl_doing_taint(int argc, char *argv[], char *envp[])
22f7c9c9 3874{
c3446a78
JH		 3875#ifndef PERL_IMPLICIT_SYS
3876 /* If we have PERL_IMPLICIT_SYS we can't call getuid() et alia
3877 * before we have an interpreter-- and the whole point of this
3878 * function is to be called at such an early stage. If you are on
3879 * a system with PERL_IMPLICIT_SYS but you do have a concept of
3880 * "tainted because running with altered effective ids', you'll
3881 * have to add your own checks somewhere in here. The two most
3882 * known samples of 'implicitness' are Win32 and NetWare, neither
3883 * of which has much of concept of 'uids'. */
dfff4baf
BF		 3884 Uid_t uid = PerlProc_getuid();
3885 Uid_t euid = PerlProc_geteuid();
3886 Gid_t gid = PerlProc_getgid();
3887 Gid_t egid = PerlProc_getegid();
6867be6d 3888 (void)envp;
22f7c9c9
JH		 3889
3890#ifdef VMS
af419de7 3891 uid |= gid << 16;
22f7c9c9
JH		 3892 euid |= egid << 16;
3893#endif
3894 if (uid && (euid != uid || egid != gid))
3895 return 1;
c3446a78 3896#endif /* !PERL_IMPLICIT_SYS */
af419de7
JH		 3897 /* This is a really primitive check; environment gets ignored only
3898 * if -T are the first chars together; otherwise one gets
3899 * "Too late" message. */
22f7c9c9
JH		 3900 if ( argc > 1 && argv[1][0] == '-'
3901 && (argv[1][1] == 't' || argv[1][1] == 'T') )
3902 return 1;
3903 return 0;
3904}
22f7c9c9 3905
d0bafe7e
NC		 3906/* Passing the flag as a single char rather than a string is a slight space
3907 optimisation. The only message that isn't /^-.$/ is
3908 "program input from stdin", which is substituted in place of '\0', which
3909 could never be a command line flag. */
76e3520e 3910STATIC void
f20b2998 3911S_forbid_setid(pTHX_ const char flag, const bool suidscript) /* g */
bbce6d69 3912{
d0bafe7e
NC		 3913 char string[3] = "-x";
3914 const char *message = "program input from stdin";
3915
20b7effb 3916 PERL_UNUSED_CONTEXT;
d0bafe7e
NC		 3917 if (flag) {
3918 string[1] = flag;
3919 message = string;
3920 }
3921
ae3f3efd 3922#ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
985213f2 3923 if (PerlProc_getuid() != PerlProc_geteuid())
d0bafe7e 3924 Perl_croak(aTHX_ "No %s allowed while running setuid", message);
985213f2 3925 if (PerlProc_getgid() != PerlProc_getegid())
d0bafe7e 3926 Perl_croak(aTHX_ "No %s allowed while running setgid", message);
ae3f3efd 3927#endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
f20b2998 3928 if (suidscript)
d0bafe7e 3929 Perl_croak(aTHX_ "No %s allowed with (suid) fdscript", message);
bbce6d69 3930}
3931
1ee4443e 3932void
5b235299
NC		 3933Perl_init_dbargs(pTHX)
3934{
3935 AV *const args = PL_dbargs = GvAV(gv_AVadd((gv_fetchpvs("DB::args",
3936 GV_ADDMULTI,
3937 SVt_PVAV))));
3938
3939 if (AvREAL(args)) {
3940 /* Someone has already created it.
3941 It might have entries, and if we just turn off AvREAL(), they will
3942 "leak" until global destruction. */
3943 av_clear(args);
3df49e2a 3944 if (SvTIED_mg((const SV *)args, PERL_MAGIC_tied))
7355df7e 3945 Perl_croak(aTHX_ "Cannot set tied @DB::args");
5b235299 3946 }
af80dd86 3947 AvREIFY_only(PL_dbargs);
5b235299
NC		 3948}
3949
3950void
1ee4443e 3951Perl_init_debugger(pTHX)
748a9306 3952{
c4420975 3953 HV * const ostash = PL_curstash;
1ee4443e 3954
03d9f026 3955 PL_curstash = (HV *)SvREFCNT_inc_simple(PL_debstash);
5b235299
NC		 3956
3957 Perl_init_dbargs(aTHX);
8cece913
FC		 3958 PL_DBgv = MUTABLE_GV(
3959 SvREFCNT_inc(gv_fetchpvs("DB::DB", GV_ADDMULTI, SVt_PVGV))
3960 );
3961 PL_DBline = MUTABLE_GV(
3962 SvREFCNT_inc(gv_fetchpvs("DB::dbline", GV_ADDMULTI, SVt_PVAV))
3963 );
3964 PL_DBsub = MUTABLE_GV(SvREFCNT_inc(
3965 gv_HVadd(gv_fetchpvs("DB::sub", GV_ADDMULTI, SVt_PVHV))
3966 ));
5c1737d1 3967 PL_DBsingle = GvSV((gv_fetchpvs("DB::single", GV_ADDMULTI, SVt_PV)));
4c0f30d6
NC		 3968 if (!SvIOK(PL_DBsingle))
3969 sv_setiv(PL_DBsingle, 0);
5c1737d1 3970 PL_DBtrace = GvSV((gv_fetchpvs("DB::trace", GV_ADDMULTI, SVt_PV)));
4c0f30d6
NC		 3971 if (!SvIOK(PL_DBtrace))
3972 sv_setiv(PL_DBtrace, 0);
5c1737d1 3973 PL_DBsignal = GvSV((gv_fetchpvs("DB::signal", GV_ADDMULTI, SVt_PV)));
4c0f30d6
NC		 3974 if (!SvIOK(PL_DBsignal))
3975 sv_setiv(PL_DBsignal, 0);
03d9f026 3976 SvREFCNT_dec(PL_curstash);
1ee4443e 3977 PL_curstash = ostash;
352d5a3a
LW		 3978}
3979
2ce36478
SM		 3980#ifndef STRESS_REALLOC
3981#define REASONABLE(size) (size)
0ff72558 3982#define REASONABLE_but_at_least(size,min) (size)
2ce36478
SM		 3983#else
3984#define REASONABLE(size) (1) /* unreasonable */
0ff72558 3985#define REASONABLE_but_at_least(size,min) (min)
2ce36478
SM		 3986#endif
3987
11343788 3988void
cea2e8a9 3989Perl_init_stacks(pTHX)
79072805 3990{
e336de0d 3991 /* start with 128-item stack and 8K cxstack */
3280af22 3992 PL_curstackinfo = new_stackinfo(REASONABLE(128),
e336de0d 3993 REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
3280af22
NIS		 3994 PL_curstackinfo->si_type = PERLSI_MAIN;
3995 PL_curstack = PL_curstackinfo->si_stack;
3996 PL_mainstack = PL_curstack; /* remember in case we switch stacks */
79072805 3997
3280af22
NIS		 3998 PL_stack_base = AvARRAY(PL_curstack);
3999 PL_stack_sp = PL_stack_base;
4000 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
8990e307 4001
a02a5408 4002 Newx(PL_tmps_stack,REASONABLE(128),SV*);
3280af22
NIS		 4003 PL_tmps_floor = -1;
4004 PL_tmps_ix = -1;
4005 PL_tmps_max = REASONABLE(128);
8990e307 4006
a02a5408 4007 Newx(PL_markstack,REASONABLE(32),I32);
3280af22
NIS		 4008 PL_markstack_ptr = PL_markstack;
4009 PL_markstack_max = PL_markstack + REASONABLE(32);
79072805 4010
ce2f7c3b 4011 SET_MARK_OFFSET;
e336de0d 4012
a02a5408 4013 Newx(PL_scopestack,REASONABLE(32),I32);
d343c3ef
GG		 4014#ifdef DEBUGGING
4015 Newx(PL_scopestack_name,REASONABLE(32),const char*);
4016#endif
3280af22
NIS		 4017 PL_scopestack_ix = 0;
4018 PL_scopestack_max = REASONABLE(32);
79072805 4019
0ff72558 4020 Newx(PL_savestack,REASONABLE_but_at_least(128,SS_MAXPUSH),ANY);
3280af22 4021 PL_savestack_ix = 0;
0ff72558 4022 PL_savestack_max = REASONABLE_but_at_least(128,SS_MAXPUSH);
378cc40b 4023}
33b78306 4024
2ce36478
SM		 4025#undef REASONABLE
4026
76e3520e 4027STATIC void
cea2e8a9 4028S_nuke_stacks(pTHX)
6e72f9df 4029{
3280af22
NIS		 4030 while (PL_curstackinfo->si_next)
4031 PL_curstackinfo = PL_curstackinfo->si_next;
4032 while (PL_curstackinfo) {
4033 PERL_SI *p = PL_curstackinfo->si_prev;
bac4b2ad 4034 /* curstackinfo->si_stack got nuked by sv_free_arenas() */
3280af22
NIS		 4035 Safefree(PL_curstackinfo->si_cxstack);
4036 Safefree(PL_curstackinfo);
4037 PL_curstackinfo = p;
e336de0d 4038 }
3280af22
NIS		 4039 Safefree(PL_tmps_stack);
4040 Safefree(PL_markstack);
4041 Safefree(PL_scopestack);
58780814
GG		 4042#ifdef DEBUGGING
4043 Safefree(PL_scopestack_name);
4044#endif
3280af22 4045 Safefree(PL_savestack);
378cc40b 4046}
33b78306 4047
74e8ce34
NC		 4048void
4049Perl_populate_isa(pTHX_ const char *name, STRLEN len, ...)
4050{
4051 GV *const gv = gv_fetchpvn(name, len, GV_ADD | GV_ADDMULTI, SVt_PVAV);
4052 AV *const isa = GvAVn(gv);
4053 va_list args;
4054
4055 PERL_ARGS_ASSERT_POPULATE_ISA;
4056
4057 if(AvFILLp(isa) != -1)
4058 return;
4059
4060 /* NOTE: No support for tied ISA */
4061
4062 va_start(args, len);
4063 do {
4064 const char *const parent = va_arg(args, const char*);
4065 size_t parent_len;
4066
4067 if (!parent)
4068 break;
4069 parent_len = va_arg(args, size_t);
4070
4071 /* Arguments are supplied with a trailing :: */
4072 assert(parent_len > 2);
4073 assert(parent[parent_len - 1] == ':');
4074 assert(parent[parent_len - 2] == ':');
4075 av_push(isa, newSVpvn(parent, parent_len - 2));
4076 (void) gv_fetchpvn(parent, parent_len, GV_ADD, SVt_PVGV);
4077 } while (1);
4078 va_end(args);
4079}
4080
8990e307 4081
76e3520e 4082STATIC void
cea2e8a9 4083S_init_predump_symbols(pTHX)
45d8adaa 4084{
93a17b20 4085 GV *tmpgv;
af8c498a 4086 IO *io;
79072805 4087
64ace3f8 4088 sv_setpvs(get_sv("\"", GV_ADD), " ");
e23d9e2f
CS		 4089 PL_ofsgv = (GV*)SvREFCNT_inc(gv_fetchpvs(",", GV_ADD|GV_NOTQUAL, SVt_PV));
4090
d963bf01
NC		 4091
4092 /* Historically, PVIOs were blessed into IO::Handle, unless
4093 FileHandle was loaded, in which case they were blessed into
4094 that. Action at a distance.
4095 However, if we simply bless into IO::Handle, we break code
4096 that assumes that PVIOs will have (among others) a seek
4097 method. IO::File inherits from IO::Handle and IO::Seekable,
4098 and provides the needed methods. But if we simply bless into
4099 it, then we break code that assumed that by loading
4100 IO::Handle, *it* would work.
4101 So a compromise is to set up the correct @IO::File::ISA,
4102 so that code that does C<use IO::Handle>; will still work.
4103 */
4104
74e8ce34
NC		 4105 Perl_populate_isa(aTHX_ STR_WITH_LEN("IO::File::ISA"),
4106 STR_WITH_LEN("IO::Handle::"),
4107 STR_WITH_LEN("IO::Seekable::"),
4108 STR_WITH_LEN("Exporter::"),
4109 NULL);
d963bf01 4110
fafc274c 4111 PL_stdingv = gv_fetchpvs("STDIN", GV_ADD|GV_NOTQUAL, SVt_PVIO);
3280af22 4112 GvMULTI_on(PL_stdingv);
af8c498a 4113 io = GvIOp(PL_stdingv);
a04651f4 4114 IoTYPE(io) = IoTYPE_RDONLY;
af8c498a 4115 IoIFP(io) = PerlIO_stdin();
fafc274c 4116 tmpgv = gv_fetchpvs("stdin", GV_ADD|GV_NOTQUAL, SVt_PV);
a5f75d66 4117 GvMULTI_on(tmpgv);
a45c7426 4118 GvIOp(tmpgv) = MUTABLE_IO(SvREFCNT_inc_simple(io));
79072805 4119
fafc274c 4120 tmpgv = gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVIO);
a5f75d66 4121 GvMULTI_on(tmpgv);
af8c498a 4122 io = GvIOp(tmpgv);
a04651f4 4123 IoTYPE(io) = IoTYPE_WRONLY;
af8c498a 4124 IoOFP(io) = IoIFP(io) = PerlIO_stdout();
4633a7c4 4125 setdefout(tmpgv);
fafc274c 4126 tmpgv = gv_fetchpvs("stdout", GV_ADD|GV_NOTQUAL, SVt_PV);
a5f75d66 4127 GvMULTI_on(tmpgv);
a45c7426 4128 GvIOp(tmpgv) = MUTABLE_IO(SvREFCNT_inc_simple(io));
79072805 4129
fafc274c 4130 PL_stderrgv = gv_fetchpvs("STDERR", GV_ADD|GV_NOTQUAL, SVt_PVIO);
bf49b057
GS		 4131 GvMULTI_on(PL_stderrgv);
4132 io = GvIOp(PL_stderrgv);
a04651f4 4133 IoTYPE(io) = IoTYPE_WRONLY;
af8c498a 4134 IoOFP(io) = IoIFP(io) = PerlIO_stderr();
fafc274c 4135 tmpgv = gv_fetchpvs("stderr", GV_ADD|GV_NOTQUAL, SVt_PV);
a5f75d66 4136 GvMULTI_on(tmpgv);
a45c7426 4137 GvIOp(tmpgv) = MUTABLE_IO(SvREFCNT_inc_simple(io));
79072805 4138
de61bf2a 4139 PL_statname = newSVpvs(""); /* last filename we did stat on */
79072805 4140}
33b78306 4141
a11ec5a9 4142void
5aaab254 4143Perl_init_argv_symbols(pTHX_ int argc, char **argv)
33b78306 4144{
7918f24d
NC		 4145 PERL_ARGS_ASSERT_INIT_ARGV_SYMBOLS;
4146
79072805 4147 argc--,argv++; /* skip name of script */
3280af22 4148 if (PL_doswitches) {
79072805 4149 for (; argc > 0 && **argv == '-'; argc--,argv++) {
aec46f14 4150 char *s;
79072805
LW		 4151 if (!argv[0][1])
4152 break;
379d538a 4153 if (argv[0][1] == '-' && !argv[0][2]) {
79072805
LW		 4154 argc--,argv++;
4155 break;
4156 }
155aba94 4157 if ((s = strchr(argv[0], '='))) {
b3d904f3
NC		 4158 const char *const start_name = argv[0] + 1;
4159 sv_setpv(GvSV(gv_fetchpvn_flags(start_name, s - start_name,
4160 TRUE, SVt_PV)), s + 1);
79072805
LW		 4161 }
4162 else
71315bf2 4163 sv_setiv(GvSV(gv_fetchpv(argv[0]+1, GV_ADD, SVt_PV)),1);
fe14fcc3 4164 }
79072805 4165 }
fafc274c 4166 if ((PL_argvgv = gv_fetchpvs("ARGV", GV_ADD|GV_NOTQUAL, SVt_PVAV))) {
722fa0e9 4167 SvREFCNT_inc_simple_void_NN(PL_argvgv);
a11ec5a9 4168 GvMULTI_on(PL_argvgv);
a11ec5a9
RGS		 4169 av_clear(GvAVn(PL_argvgv));
4170 for (; argc > 0; argc--,argv++) {
aec46f14 4171 SV * const sv = newSVpv(argv[0],0);
b188953e 4172 av_push(GvAV(PL_argvgv),sv);
ce81ff12
JH		 4173 if (!(PL_unicode & PERL_UNICODE_LOCALE_FLAG) || PL_utf8locale) {
4174 if (PL_unicode & PERL_UNICODE_ARGV_FLAG)
4175 SvUTF8_on(sv);
4176 }
a05d7ebb
JH		 4177 if (PL_unicode & PERL_UNICODE_WIDESYSCALLS_FLAG) /* Sarathy? */
4178 (void)sv_utf8_decode(sv);
a11ec5a9
RGS		 4179 }
4180 }
82f96200
JL		 4181
4182 if (PL_inplace && (!PL_argvgv || AvFILL(GvAV(PL_argvgv)) == -1))
4183 Perl_ck_warner_d(aTHX_ packWARN(WARN_INPLACE),
4184 "-i used with no filenames on the command line, "
4185 "reading from STDIN");
a11ec5a9
RGS		 4186}
4187
4188STATIC void
5aaab254 4189S_init_postdump_symbols(pTHX_ int argc, char **argv, char **env)
a11ec5a9 4190{
20b7effb 4191#ifdef USE_ITHREADS
27da23d5 4192 dVAR;
20b7effb 4193#endif
a11ec5a9 4194 GV* tmpgv;
a11ec5a9 4195
7918f24d
NC		 4196 PERL_ARGS_ASSERT_INIT_POSTDUMP_SYMBOLS;
4197
f2da823f 4198 PL_toptarget = newSV_type(SVt_PVIV);
76f68e9b 4199 sv_setpvs(PL_toptarget, "");
f2da823f 4200 PL_bodytarget = newSV_type(SVt_PVIV);
76f68e9b 4201 sv_setpvs(PL_bodytarget, "");
3280af22 4202 PL_formtarget = PL_bodytarget;
79072805 4203
bbce6d69 4204 TAINT;
a11ec5a9
RGS		 4205
4206 init_argv_symbols(argc,argv);
4207
fafc274c 4208 if ((tmpgv = gv_fetchpvs("0", GV_ADD|GV_NOTQUAL, SVt_PV))) {
3280af22 4209 sv_setpv(GvSV(tmpgv),PL_origfilename);
79072805 4210 }
fafc274c 4211 if ((PL_envgv = gv_fetchpvs("ENV", GV_ADD|GV_NOTQUAL, SVt_PVHV))) {
79072805 4212 HV *hv;
e17132c1 4213 bool env_is_not_environ;
cf93a474 4214 SvREFCNT_inc_simple_void_NN(PL_envgv);
3280af22
NIS		 4215 GvMULTI_on(PL_envgv);
4216 hv = GvHVn(PL_envgv);
a0714e2c 4217 hv_magic(hv, NULL, PERL_MAGIC_env);
2f42fcb0 4218#ifndef PERL_MICRO
fa6a1c44 4219#ifdef USE_ENVIRON_ARRAY
4633a7c4
LW		 4220 /* Note that if the supplied env parameter is actually a copy
4221 of the global environ then it may now point to free'd memory
4222 if the environment has been modified since. To avoid this
4223 problem we treat env==NULL as meaning 'use the default'
4224 */
4225 if (!env)
4226 env = environ;
e17132c1
JD		 4227 env_is_not_environ = env != environ;
4228 if (env_is_not_environ
4efc5df6
GS		 4229# ifdef USE_ITHREADS
4230 && PL_curinterp == aTHX
4231# endif
4232 )
4233 {
bd61b366 4234 environ[0] = NULL;
4efc5df6 4235 }
9b4eeda5 4236 if (env) {
9d27dca9 4237 char *s, *old_var;
27da23d5 4238 SV *sv;
764df951 4239 for (; *env; env++) {
9d27dca9
MT		 4240 old_var = *env;
4241
4242 if (!(s = strchr(old_var,'=')) || s == old_var)
79072805 4243 continue;
9d27dca9 4244
7da0e383 4245#if defined(MSDOS) && !defined(DJGPP)
61968511 4246 *s = '\0';
9d27dca9 4247 (void)strupr(old_var);
61968511 4248 *s = '=';
137443ea 4249#endif
61968511 4250 sv = newSVpv(s+1, 0);
9d27dca9 4251 (void)hv_store(hv, old_var, s - old_var, sv, 0);
e17132c1 4252 if (env_is_not_environ)
61968511 4253 mg_set(sv);
764df951 4254 }
9b4eeda5 4255 }
103a7189 4256#endif /* USE_ENVIRON_ARRAY */
2f42fcb0 4257#endif /* !PERL_MICRO */
79072805 4258 }
bbce6d69 4259 TAINT_NOT;
2710853f
MJD		 4260
4261 /* touch @F array to prevent spurious warnings 20020415 MJD */
4262 if (PL_minus_a) {
cbfd0a87 4263 (void) get_av("main::F", GV_ADD | GV_ADDMULTI);
2710853f 4264 }
33b78306 4265}
34de22dd 4266
76e3520e 4267STATIC void
2cace6ac 4268S_init_perllib(pTHX)
34de22dd 4269{
32910c7a 4270#ifndef VMS
929e5b34 4271 const char *perl5lib = NULL;
32910c7a 4272#endif
35ba5ce9 4273 const char *s;
a7560424 4274#if defined(WIN32) && !defined(PERL_IS_MINIPERL)
e6a0bbf8
NC		 4275 STRLEN len;
4276#endif
4277
284167a5 4278 if (!TAINTING_get) {
552a7a9b 4279#ifndef VMS
32910c7a 4280 perl5lib = PerlEnv_getenv("PERL5LIB");
88f5bc07
AB		 4281/*
4282 * It isn't possible to delete an environment variable with
42a3dd3a
RGS		 4283 * PERL_USE_SAFE_PUTENV set unless unsetenv() is also available, so in that
4284 * case we treat PERL5LIB as undefined if it has a zero-length value.
88f5bc07
AB		 4285 */
4286#if defined(PERL_USE_SAFE_PUTENV) && ! defined(HAS_UNSETENV)
32910c7a 4287 if (perl5lib && *perl5lib != '\0')
88f5bc07 4288#else
32910c7a 4289 if (perl5lib)
88f5bc07 4290#endif
32910c7a 4291 incpush_use_sep(perl5lib, 0, INCPUSH_ADD_SUB_DIRS);
2cace6ac 4292 else {
4705144d
NC		 4293 s = PerlEnv_getenv("PERLLIB");
4294 if (s)
50d61629 4295 incpush_use_sep(s, 0, 0);
4705144d 4296 }
552a7a9b 4297#else /* VMS */
4298 /* Treat PERL5?LIB as a possible search list logical name -- the
4299 * "natural" VMS idiom for a Unix path string. We allow each
4300 * element to be a set of |-separated directories for compatibility.
4301 */
4302 char buf[256];
4303 int idx = 0;
4304 if (my_trnlnm("PERL5LIB",buf,0))
e28f3139 4305 do {
2cace6ac 4306 incpush_use_sep(buf, 0, INCPUSH_ADD_SUB_DIRS);
e28f3139 4307 } while (my_trnlnm("PERL5LIB",buf,++idx));
f05b5874 4308 else {
e28f3139 4309 while (my_trnlnm("PERLLIB",buf,idx++))
50d61629 4310 incpush_use_sep(buf, 0, 0);
f05b5874 4311 }
552a7a9b 4312#endif /* VMS */
85e6fe83 4313 }
34de22dd 4314
b0e687f7
NC		 4315#ifndef PERL_IS_MINIPERL
4316 /* miniperl gets just -I..., the split of $ENV{PERL5LIB}, and "." in @INC
4317 (and not the architecture specific directories from $ENV{PERL5LIB}) */
4318
c90c0ff4 4319/* Use the ~-expanded versions of APPLLIB (undocumented),
826e305c 4320 SITEARCH, SITELIB, VENDORARCH, VENDORLIB, ARCHLIB and PRIVLIB
df5cef82 4321*/
4633a7c4 4322#ifdef APPLLIB_EXP
be71fc8f
NC		 4323 S_incpush_use_sep(aTHX_ STR_WITH_LEN(APPLLIB_EXP),
4324 INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE);
16d20bd9 4325#endif
4633a7c4 4326
65f19062 4327#ifdef SITEARCH_EXP
3b290362
GS		 4328 /* sitearch is always relative to sitelib on Windows for
4329 * DLL-based path intuition to work correctly */
4330# if !defined(WIN32)
be71fc8f
NC		 4331 S_incpush_use_sep(aTHX_ STR_WITH_LEN(SITEARCH_EXP),
4332 INCPUSH_CAN_RELOCATE);
65f19062
GS		 4333# endif
4334#endif
4335
4633a7c4 4336#ifdef SITELIB_EXP
65f19062 4337# if defined(WIN32)
574c798a 4338 /* this picks up sitearch as well */
e6a0bbf8 4339 s = win32_get_sitelib(PERL_FS_VERSION, &len);
1fa74d9f 4340 if (s)
e6a0bbf8 4341 incpush_use_sep(s, len, INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE);
65f19062 4342# else
50d61629 4343 S_incpush_use_sep(aTHX_ STR_WITH_LEN(SITELIB_EXP), INCPUSH_CAN_RELOCATE);
65f19062
GS		 4344# endif
4345#endif
189d1e8d 4346
65f19062 4347#ifdef PERL_VENDORARCH_EXP
4ea817c6 4348 /* vendorarch is always relative to vendorlib on Windows for
3b290362
GS		 4349 * DLL-based path intuition to work correctly */
4350# if !defined(WIN32)
be71fc8f
NC		 4351 S_incpush_use_sep(aTHX_ STR_WITH_LEN(PERL_VENDORARCH_EXP),
4352 INCPUSH_CAN_RELOCATE);
65f19062 4353# endif
4b03c463 4354#endif
65f19062
GS		 4355
4356#ifdef PERL_VENDORLIB_EXP
4357# if defined(WIN32)
e28f3139 4358 /* this picks up vendorarch as well */
e6a0bbf8 4359 s = win32_get_vendorlib(PERL_FS_VERSION, &len);
1fa74d9f 4360 if (s)
e6a0bbf8 4361 incpush_use_sep(s, len, INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE);
65f19062 4362# else
be71fc8f
NC		 4363 S_incpush_use_sep(aTHX_ STR_WITH_LEN(PERL_VENDORLIB_EXP),
4364 INCPUSH_CAN_RELOCATE);
65f19062 4365# endif
a3635516 4366#endif
65f19062 4367
b9ba2fad 4368#ifdef ARCHLIB_EXP
2cace6ac 4369 S_incpush_use_sep(aTHX_ STR_WITH_LEN(ARCHLIB_EXP), INCPUSH_CAN_RELOCATE);
b9ba2fad
NC		 4370#endif
4371
4372#ifndef PRIVLIB_EXP
4373# define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
4374#endif
4375
4376#if defined(WIN32)
2cace6ac
NC		 4377 s = win32_get_privlib(PERL_FS_VERSION, &len);
4378 if (s)
4379 incpush_use_sep(s, len, INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE);
b9ba2fad 4380#else
04c9eecc 4381# ifdef NETWARE
2cace6ac 4382 S_incpush_use_sep(aTHX_ PRIVLIB_EXP, 0, INCPUSH_CAN_RELOCATE);
04c9eecc 4383# else
2cace6ac 4384 S_incpush_use_sep(aTHX_ STR_WITH_LEN(PRIVLIB_EXP), INCPUSH_CAN_RELOCATE);
04c9eecc 4385# endif
b9ba2fad
NC		 4386#endif
4387
3b777bb4 4388#ifdef PERL_OTHERLIBDIRS
1e3208d8
NC		 4389 S_incpush_use_sep(aTHX_ STR_WITH_LEN(PERL_OTHERLIBDIRS),
4390 INCPUSH_ADD_VERSIONED_SUB_DIRS|INCPUSH_NOT_BASEDIR
2cace6ac
NC		 4391 |INCPUSH_CAN_RELOCATE);
4392#endif
2cace6ac 4393
284167a5 4394 if (!TAINTING_get) {
2cace6ac 4395#ifndef VMS
2cace6ac
NC		 4396/*
4397 * It isn't possible to delete an environment variable with
4398 * PERL_USE_SAFE_PUTENV set unless unsetenv() is also available, so in that
4399 * case we treat PERL5LIB as undefined if it has a zero-length value.
4400 */
4401#if defined(PERL_USE_SAFE_PUTENV) && ! defined(HAS_UNSETENV)
32910c7a 4402 if (perl5lib && *perl5lib != '\0')
2cace6ac 4403#else
32910c7a 4404 if (perl5lib)
2cace6ac 4405#endif
32910c7a
NC		 4406 incpush_use_sep(perl5lib, 0,
4407 INCPUSH_ADD_OLD_VERS|INCPUSH_NOT_BASEDIR);
2cace6ac
NC		 4408#else /* VMS */
4409 /* Treat PERL5?LIB as a possible search list logical name -- the
4410 * "natural" VMS idiom for a Unix path string. We allow each
4411 * element to be a set of |-separated directories for compatibility.
4412 */
4413 char buf[256];
4414 int idx = 0;
4415 if (my_trnlnm("PERL5LIB",buf,0))
4416 do {
be71fc8f
NC		 4417 incpush_use_sep(buf, 0,
4418 INCPUSH_ADD_OLD_VERS|INCPUSH_NOT_BASEDIR);
2cace6ac
NC		 4419 } while (my_trnlnm("PERL5LIB",buf,++idx));
4420#endif /* VMS */
a26c0e28 4421 }
2cace6ac
NC		 4422
4423/* Use the ~-expanded versions of APPLLIB (undocumented),
826e305c 4424 SITELIB and VENDORLIB for older versions
2cace6ac
NC		 4425*/
4426#ifdef APPLLIB_EXP
be71fc8f
NC		 4427 S_incpush_use_sep(aTHX_ STR_WITH_LEN(APPLLIB_EXP), INCPUSH_ADD_OLD_VERS
4428 |INCPUSH_NOT_BASEDIR|INCPUSH_CAN_RELOCATE);
2cace6ac
NC		 4429#endif
4430
2cace6ac
NC		 4431#if defined(SITELIB_STEM) && defined(PERL_INC_VERSION_LIST)
4432 /* Search for version-specific dirs below here */
be71fc8f
NC		 4433 S_incpush_use_sep(aTHX_ STR_WITH_LEN(SITELIB_STEM),
4434 INCPUSH_ADD_OLD_VERS|INCPUSH_CAN_RELOCATE);
2cace6ac
NC		 4435#endif
4436
4437
4438#if defined(PERL_VENDORLIB_STEM) && defined(PERL_INC_VERSION_LIST)
4439 /* Search for version-specific dirs below here */
be71fc8f
NC		 4440 S_incpush_use_sep(aTHX_ STR_WITH_LEN(PERL_VENDORLIB_STEM),
4441 INCPUSH_ADD_OLD_VERS|INCPUSH_CAN_RELOCATE);
2cace6ac
NC		 4442#endif
4443
4444#ifdef PERL_OTHERLIBDIRS
1e3208d8
NC		 4445 S_incpush_use_sep(aTHX_ STR_WITH_LEN(PERL_OTHERLIBDIRS),
4446 INCPUSH_ADD_OLD_VERS|INCPUSH_ADD_ARCHONLY_SUB_DIRS
4447 |INCPUSH_CAN_RELOCATE);
3b777bb4 4448#endif
b0e687f7 4449#endif /* !PERL_IS_MINIPERL */
3b777bb4 4450
284167a5 4451 if (!TAINTING_get)
55b4bc1c 4452 S_incpush(aTHX_ STR_WITH_LEN("."), 0);
774d564b 4453}
4454
739a0b84 4455#if defined(DOSISH) || defined(__SYMBIAN32__)
774d564b 4456# define PERLLIB_SEP ';'
4457#else
4458# if defined(VMS)
4459# define PERLLIB_SEP '|'
4460# else
e37778c2 4461# define PERLLIB_SEP ':'
774d564b 4462# endif
4463#endif
4464#ifndef PERLLIB_MANGLE
4465# define PERLLIB_MANGLE(s,n) (s)
ac27b0f5 4466#endif
774d564b 4467
59d6f6a4 4468#ifndef PERL_IS_MINIPERL
ad17a1ae
NC		 4469/* Push a directory onto @INC if it exists.
4470 Generate a new SV if we do this, to save needing to copy the SV we push
4471 onto @INC */
4472STATIC SV *
7ffdaae6 4473S_incpush_if_exists(pTHX_ AV *const av, SV *dir, SV *const stem)
ad17a1ae
NC		 4474{
4475 Stat_t tmpstatbuf;
7918f24d
NC		 4476
4477 PERL_ARGS_ASSERT_INCPUSH_IF_EXISTS;
4478
848ef955 4479 if (PerlLIO_stat(SvPVX_const(dir), &tmpstatbuf) >= 0 &&
ad17a1ae 4480 S_ISDIR(tmpstatbuf.st_mode)) {
3a9a9ba7 4481 av_push(av, dir);
7ffdaae6
NC		 4482 dir = newSVsv(stem);
4483 } else {
4484 /* Truncate dir back to stem. */
4485 SvCUR_set(dir, SvCUR(stem));
ad17a1ae
NC		 4486 }
4487 return dir;
4488}
59d6f6a4 4489#endif
ad17a1ae 4490
c29067d7
CH		 4491STATIC SV *
4492S_mayberelocate(pTHX_ const char *const dir, STRLEN len, U32 flags)
774d564b 4493{
6434436b 4494 const U8 canrelocate = (U8)flags & INCPUSH_CAN_RELOCATE;
c29067d7 4495 SV *libdir;
774d564b 4496
c29067d7 4497 PERL_ARGS_ASSERT_MAYBERELOCATE;
08d0d8ab 4498 assert(len > 0);
3a9a9ba7 4499
d2898d73
EB		 4500 /* I am not convinced that this is valid when PERLLIB_MANGLE is
4501 defined to so something (in os2/os2.c), but the code has been
4502 this way, ignoring any possible changed of length, since
4503 760ac839baf413929cd31cc32ffd6dba6b781a81 (5.003_02) so I'll leave
4504 it be. */
4505 libdir = newSVpvn(PERLLIB_MANGLE(dir, len), len);
774d564b 4506
81600524 4507#ifdef VMS
db12e2d3 4508 {
81600524 4509 char *unix;
81600524
CB		 4510
4511 if ((unix = tounixspec_ts(SvPV(libdir,len),NULL)) != NULL) {
4512 len = strlen(unix);
f420cce1 4513 while (len > 1 && unix[len-1] == '/') len--; /* Cosmetic */
81600524
CB		 4514 sv_usepvn(libdir,unix,len);
4515 }
4516 else
4517 PerlIO_printf(Perl_error_log,
4518 "Failed to unixify @INC element \"%s\"\n",
9dfa9235 4519 SvPV_nolen_const(libdir));
db12e2d3 4520 }
81600524
CB		 4521#endif
4522
dd374669
AL		 4523 /* Do the if() outside the #ifdef to avoid warnings about an unused
4524 parameter. */
4525 if (canrelocate) {
88fe16b2
NC		 4526#ifdef PERL_RELOCATABLE_INC
4527 /*
4528 * Relocatable include entries are marked with a leading .../
4529 *
4530 * The algorithm is
4531 * 0: Remove that leading ".../"
4532 * 1: Remove trailing executable name (anything after the last '/')
4533 * from the perl path to give a perl prefix
4534 * Then
4535 * While the @INC element starts "../" and the prefix ends with a real
4536 * directory (ie not . or ..) chop that real directory off the prefix
4537 * and the leading "../" from the @INC element. ie a logical "../"
4538 * cleanup
4539 * Finally concatenate the prefix and the remainder of the @INC element
4540 * The intent is that /usr/local/bin/perl and .../../lib/perl5
4541 * generates /usr/local/lib/perl5
4542 */
890ce7af 4543 const char *libpath = SvPVX(libdir);
88fe16b2
NC		 4544 STRLEN libpath_len = SvCUR(libdir);
4545 if (libpath_len >= 4 && memEQ (libpath, ".../", 4)) {
4546 /* Game on! */
890ce7af 4547 SV * const caret_X = get_sv("\030", 0);
88fe16b2
NC		 4548 /* Going to use the SV just as a scratch buffer holding a C
4549 string: */
4550 SV *prefix_sv;
4551 char *prefix;
4552 char *lastslash;
4553
4554 /* $^X is *the* source of taint if tainting is on, hence
4555 SvPOK() won't be true. */
4556 assert(caret_X);
4557 assert(SvPOKp(caret_X));
a663657d
NC		 4558 prefix_sv = newSVpvn_flags(SvPVX(caret_X), SvCUR(caret_X),
4559 SvUTF8(caret_X));
88fe16b2
NC		 4560 /* Firstly take off the leading .../
4561 If all else fail we'll do the paths relative to the current
4562 directory. */
4563 sv_chop(libdir, libpath + 4);
4564 /* Don't use SvPV as we're intentionally bypassing taining,
4565 mortal copies that the mg_get of tainting creates, and
4566 corruption that seems to come via the save stack.
4567 I guess that the save stack isn't correctly set up yet. */
4568 libpath = SvPVX(libdir);
4569 libpath_len = SvCUR(libdir);
4570
4571 /* This would work more efficiently with memrchr, but as it's
4572 only a GNU extension we'd need to probe for it and
4573 implement our own. Not hard, but maybe not worth it? */
4574
4575 prefix = SvPVX(prefix_sv);
4576 lastslash = strrchr(prefix, '/');
4577
4578 /* First time in with the *lastslash = '\0' we just wipe off
4579 the trailing /perl from (say) /usr/foo/bin/perl
4580 */
4581 if (lastslash) {
4582 SV *tempsv;
4583 while ((*lastslash = '\0'), /* Do that, come what may. */
4584 (libpath_len >= 3 && memEQ(libpath, "../", 3)
4585 && (lastslash = strrchr(prefix, '/')))) {
4586 if (lastslash[1] == '\0'
4587 || (lastslash[1] == '.'
4588 && (lastslash[2] == '/' /* ends "/." */
4589 || (lastslash[2] == '/'
4590 && lastslash[3] == '/' /* or "/.." */
4591 )))) {
4592 /* Prefix ends "/" or "/." or "/..", any of which
4593 are fishy, so don't do any more logical cleanup.
4594 */
4595 break;
4596 }
4597 /* Remove leading "../" from path */
4598 libpath += 3;
4599 libpath_len -= 3;
4600 /* Next iteration round the loop removes the last
4601 directory name from prefix by writing a '\0' in
4602 the while clause. */
4603 }
4604 /* prefix has been terminated with a '\0' to the correct
4605 length. libpath points somewhere into the libdir SV.
4606 We need to join the 2 with '/' and drop the result into
4607 libdir. */
4608 tempsv = Perl_newSVpvf(aTHX_ "%s/%s", prefix, libpath);
4609 SvREFCNT_dec(libdir);
4610 /* And this is the new libdir. */
4611 libdir = tempsv;
284167a5 4612 if (TAINTING_get &&
985213f2
AB		 4613 (PerlProc_getuid() != PerlProc_geteuid() ||
4614 PerlProc_getgid() != PerlProc_getegid())) {
486ec47a 4615 /* Need to taint relocated paths if running set ID */
88fe16b2
NC		 4616 SvTAINTED_on(libdir);
4617 }
4618 }
4619 SvREFCNT_dec(prefix_sv);
4620 }
88fe16b2 4621#endif
dd374669 4622 }
c29067d7 4623 return libdir;
c29067d7
CH		 4624}
4625
4626STATIC void
4627S_incpush(pTHX_ const char *const dir, STRLEN len, U32 flags)
4628{
c29067d7
CH		 4629#ifndef PERL_IS_MINIPERL
4630 const U8 using_sub_dirs
4631 = (U8)flags & (INCPUSH_ADD_VERSIONED_SUB_DIRS
4632 |INCPUSH_ADD_ARCHONLY_SUB_DIRS|INCPUSH_ADD_OLD_VERS);
4633 const U8 add_versioned_sub_dirs
4634 = (U8)flags & INCPUSH_ADD_VERSIONED_SUB_DIRS;
4635 const U8 add_archonly_sub_dirs
4636 = (U8)flags & INCPUSH_ADD_ARCHONLY_SUB_DIRS;
4637#ifdef PERL_INC_VERSION_LIST
4638 const U8 addoldvers = (U8)flags & INCPUSH_ADD_OLD_VERS;
4639#endif
4640#endif
4641 const U8 unshift = (U8)flags & INCPUSH_UNSHIFT;
4642 const U8 push_basedir = (flags & INCPUSH_NOT_BASEDIR) ? 0 : 1;
4643 AV *const inc = GvAVn(PL_incgv);
4644
4645 PERL_ARGS_ASSERT_INCPUSH;
4646 assert(len > 0);
4647
4648 /* Could remove this vestigial extra block, if we don't mind a lot of
4649 re-indenting diff noise. */
4650 {
5a702b9a 4651 SV *const libdir = mayberelocate(dir, len, flags);
c29067d7
CH		 4652 /* Change 20189146be79a0596543441fa369c6bf7f85103f, to fix RT#6665,
4653 arranged to unshift #! line -I onto the front of @INC. However,
4654 -I can add version and architecture specific libraries, and they
4655 need to go first. The old code assumed that it was always
4656 pushing. Hence to make it work, need to push the architecture
4657 (etc) libraries onto a temporary array, then "unshift" that onto
4658 the front of @INC. */
4659#ifndef PERL_IS_MINIPERL
4660 AV *const av = (using_sub_dirs) ? (unshift ? newAV() : inc) : NULL;
c29067d7 4661
774d564b 4662 /*
4663 * BEFORE pushing libdir onto @INC we may first push version- and
4664 * archname-specific sub-directories.
4665 */
ee80e7be 4666 if (using_sub_dirs) {
5a702b9a 4667 SV *subdir = newSVsv(libdir);
29d82f8d 4668#ifdef PERL_INC_VERSION_LIST
8353b874 4669 /* Configure terminates PERL_INC_VERSION_LIST with a NULL */
c4420975
AL		 4670 const char * const incverlist[] = { PERL_INC_VERSION_LIST };
4671 const char * const *incver;
29d82f8d 4672#endif
7ffdaae6 4673
1e3208d8 4674 if (add_versioned_sub_dirs) {
9c8a64f0 4675 /* .../version/archname if -d .../version/archname */
e51b748d 4676 sv_catpvs(subdir, "/" PERL_FS_VERSION "/" ARCHNAME);
7ffdaae6 4677 subdir = S_incpush_if_exists(aTHX_ av, subdir, libdir);
4b03c463 4678
9c8a64f0 4679 /* .../version if -d .../version */
e51b748d 4680 sv_catpvs(subdir, "/" PERL_FS_VERSION);
7ffdaae6 4681 subdir = S_incpush_if_exists(aTHX_ av, subdir, libdir);
29d82f8d 4682 }
9c8a64f0 4683
9c8a64f0 4684#ifdef PERL_INC_VERSION_LIST
ccc2aad8 4685 if (addoldvers) {
9c8a64f0
GS		 4686 for (incver = incverlist; *incver; incver++) {
4687 /* .../xxx if -d .../xxx */
e51b748d 4688 Perl_sv_catpvf(aTHX_ subdir, "/%s", *incver);
7ffdaae6 4689 subdir = S_incpush_if_exists(aTHX_ av, subdir, libdir);
9c8a64f0
GS		 4690 }
4691 }
29d82f8d 4692#endif
c992324b 4693
1e3208d8 4694 if (add_archonly_sub_dirs) {
c992324b 4695 /* .../archname if -d .../archname */
e51b748d 4696 sv_catpvs(subdir, "/" ARCHNAME);
7ffdaae6 4697 subdir = S_incpush_if_exists(aTHX_ av, subdir, libdir);
c992324b
NC		 4698
4699 }
10cc20f6
NC		 4700
4701 assert (SvREFCNT(subdir) == 1);
4702 SvREFCNT_dec(subdir);
774d564b 4703 }
59d6f6a4 4704#endif /* !PERL_IS_MINIPERL */
20189146
RGS		 4705 /* finally add this lib directory at the end of @INC */
4706 if (unshift) {
76895e89 4707#ifdef PERL_IS_MINIPERL
c70927a6 4708 const Size_t extra = 0;
76895e89 4709#else
b9f2b683 4710 Size_t extra = av_tindex(av) + 1;
76895e89 4711#endif
a26c0e28
NC		 4712 av_unshift(inc, extra + push_basedir);
4713 if (push_basedir)
4714 av_store(inc, extra, libdir);
76895e89 4715#ifndef PERL_IS_MINIPERL
3a9a9ba7
NC		 4716 while (extra--) {
4717 /* av owns a reference, av_store() expects to be donated a
4718 reference, and av expects to be sane when it's cleared.
4719 If I wanted to be naughty and wrong, I could peek inside the
4720 implementation of av_clear(), realise that it uses
4721 SvREFCNT_dec() too, so av's array could be a run of NULLs,
4722 and so directly steal from it (with a memcpy() to inc, and
4723 then memset() to NULL them out. But people copy code from the
4724 core expecting it to be best practise, so let's use the API.
4725 Although studious readers will note that I'm not checking any
4726 return codes. */
4727 av_store(inc, extra, SvREFCNT_inc(*av_fetch(av, extra, FALSE)));
4728 }
4729 SvREFCNT_dec(av);
59d6f6a4 4730#endif
20189146 4731 }
a26c0e28 4732 else if (push_basedir) {
3a9a9ba7 4733 av_push(inc, libdir);
20189146 4734 }
a26c0e28
NC		 4735
4736 if (!push_basedir) {
4737 assert (SvREFCNT(libdir) == 1);
4738 SvREFCNT_dec(libdir);
4739 }
774d564b 4740 }
34de22dd 4741}
93a17b20 4742
55b4bc1c 4743STATIC void
50d61629 4744S_incpush_use_sep(pTHX_ const char *p, STRLEN len, U32 flags)
55b4bc1c 4745{
50d61629
NC		 4746 const char *s;
4747 const char *end;
55b4bc1c
NC		 4748 /* This logic has been broken out from S_incpush(). It may be possible to
4749 simplify it. */
4750
4705144d
NC		 4751 PERL_ARGS_ASSERT_INCPUSH_USE_SEP;
4752
f31c6eed
JD		 4753 /* perl compiled with -DPERL_RELOCATABLE_INCPUSH will ignore the len
4754 * argument to incpush_use_sep. This allows creation of relocatable
4755 * Perl distributions that patch the binary at install time. Those
4756 * distributions will have to provide their own relocation tools; this
4757 * is not a feature otherwise supported by core Perl.
4758 */
4759#ifndef PERL_RELOCATABLE_INCPUSH
50d61629 4760 if (!len)
f31c6eed 4761#endif
50d61629
NC		 4762 len = strlen(p);
4763
4764 end = p + len;
4765
55b4bc1c 4766 /* Break at all separators */
e42f52dd 4767 while ((s = (const char*)memchr(p, PERLLIB_SEP, end - p))) {
50d61629
NC		 4768 if (s == p) {
4769 /* skip any consecutive separators */
55b4bc1c 4770
55b4bc1c 4771 /* Uncomment the next line for PATH semantics */
50d61629 4772 /* But you'll need to write tests */
55b4bc1c 4773 /* av_push(GvAVn(PL_incgv), newSVpvs(".")); */
50d61629 4774 } else {
55b4bc1c 4775 incpush(p, (STRLEN)(s - p), flags);
55b4bc1c 4776 }
50d61629 4777 p = s + 1;
55b4bc1c 4778 }
50d61629
NC		 4779 if (p != end)
4780 incpush(p, (STRLEN)(end - p), flags);
4781
55b4bc1c 4782}
199100c8 4783
93a17b20 4784void
864dbfa3 4785Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
93a17b20 4786{
971a9dd3 4787 SV *atsv;
5f40764f 4788 volatile const line_t oldline = PL_curcop ? CopLINE(PL_curcop) : 0;
312caa8e 4789 CV *cv;
22921e25 4790 STRLEN len;
6224f72b 4791 int ret;
db36c5a1 4792 dJMPENV;
93a17b20 4793
7918f24d
NC		 4794 PERL_ARGS_ASSERT_CALL_LIST;
4795
b9f2b683 4796 while (av_tindex(paramList) >= 0) {
ea726b52 4797 cv = MUTABLE_CV(av_shift(paramList));
ece599bd
RGS		 4798 if (PL_savebegin) {
4799 if (paramList == PL_beginav) {
059a8bb7 4800 /* save PL_beginav for compiler */
ad64d0ec 4801 Perl_av_create_and_push(aTHX_ &PL_beginav_save, MUTABLE_SV(cv));
ece599bd
RGS		 4802 }
4803 else if (paramList == PL_checkav) {
4804 /* save PL_checkav for compiler */
ad64d0ec 4805 Perl_av_create_and_push(aTHX_ &PL_checkav_save, MUTABLE_SV(cv));
ece599bd 4806 }
3c10abe3
AG		 4807 else if (paramList == PL_unitcheckav) {
4808 /* save PL_unitcheckav for compiler */
ad64d0ec 4809 Perl_av_create_and_push(aTHX_ &PL_unitcheckav_save, MUTABLE_SV(cv));
3c10abe3 4810 }
059a8bb7 4811 } else {
b5bbe64a 4812 SAVEFREESV(cv);
059a8bb7 4813 }
14dd3ad8 4814 JMPENV_PUSH(ret);
6224f72b 4815 switch (ret) {
312caa8e 4816 case 0:
d6f07c05 4817 CALL_LIST_BODY(cv);
971a9dd3 4818 atsv = ERRSV;
10516c54 4819 (void)SvPV_const(atsv, len);
312caa8e
CS		 4820 if (len) {
4821 PL_curcop = &PL_compiling;
57843af0 4822 CopLINE_set(PL_curcop, oldline);
312caa8e 4823 if (paramList == PL_beginav)
396482e1 4824 sv_catpvs(atsv, "BEGIN failed--compilation aborted");
312caa8e 4825 else
4f25aa18
GS		 4826 Perl_sv_catpvf(aTHX_ atsv,
4827 "%s failed--call queue aborted",
7d30b5c4 4828 paramList == PL_checkav ? "CHECK"
4f25aa18 4829 : paramList == PL_initav ? "INIT"
3c10abe3 4830 : paramList == PL_unitcheckav ? "UNITCHECK"
4f25aa18 4831 : "END");
312caa8e
CS		 4832 while (PL_scopestack_ix > oldscope)
4833 LEAVE;
14dd3ad8 4834 JMPENV_POP;
be2597df 4835 Perl_croak(aTHX_ "%"SVf"", SVfARG(atsv));
a0d0e21e 4836 }
85e6fe83 4837 break;
6224f72b 4838 case 1:
f86702cc 4839 STATUS_ALL_FAILURE;
924ba076 4840 /* FALLTHROUGH */
6224f72b 4841 case 2:
85e6fe83 4842 /* my_exit() was called */
3280af22 4843 while (PL_scopestack_ix > oldscope)
2ae324a7 4844 LEAVE;
84902520 4845 FREETMPS;
03d9f026 4846 SET_CURSTASH(PL_defstash);
3280af22 4847 PL_curcop = &PL_compiling;
57843af0 4848 CopLINE_set(PL_curcop, oldline);
14dd3ad8 4849 JMPENV_POP;
f86702cc 4850 my_exit_jump();
a25b5927 4851 assert(0); /* NOTREACHED */
6224f72b 4852 case 3:
312caa8e
CS		 4853 if (PL_restartop) {
4854 PL_curcop = &PL_compiling;
57843af0 4855 CopLINE_set(PL_curcop, oldline);
312caa8e 4856 JMPENV_JUMP(3);
85e6fe83 4857 }
5637ef5b 4858 PerlIO_printf(Perl_error_log, "panic: restartop in call_list\n");
312caa8e
CS		 4859 FREETMPS;
4860 break;
8990e307 4861 }
14dd3ad8 4862 JMPENV_POP;
93a17b20 4863 }
93a17b20 4864}
93a17b20 4865
f86702cc 4866void
864dbfa3 4867Perl_my_exit(pTHX_ U32 status)
f86702cc 4868{
6136213b
JGM		 4869 if (PL_exit_flags & PERL_EXIT_ABORT) {
4870 abort();
4871 }
4872 if (PL_exit_flags & PERL_EXIT_WARN) {
4873 PL_exit_flags |= PERL_EXIT_ABORT; /* Protect against reentrant calls */
7b0eb0b8 4874 Perl_warn(aTHX_ "Unexpected exit %lu", (unsigned long)status);
6136213b
JGM		 4875 PL_exit_flags &= ~PERL_EXIT_ABORT;
4876 }
f86702cc 4877 switch (status) {
4878 case 0:
4879 STATUS_ALL_SUCCESS;
4880 break;
4881 case 1:
4882 STATUS_ALL_FAILURE;
4883 break;
4884 default:
6ac6a52b 4885 STATUS_EXIT_SET(status);
f86702cc 4886 break;
4887 }
4888 my_exit_jump();
4889}
4890
4891void
864dbfa3 4892Perl_my_failure_exit(pTHX)
f86702cc 4893{
4894#ifdef VMS
fb38d079
JM		 4895 /* We have been called to fall on our sword. The desired exit code
4896 * should be already set in STATUS_UNIX, but could be shifted over
0968cdad
JM		 4897 * by 8 bits. STATUS_UNIX_EXIT_SET will handle the cases where a
4898 * that code is set.
fb38d079
JM		 4899 *
4900 * If an error code has not been set, then force the issue.
4901 */
0968cdad
JM		 4902 if (MY_POSIX_EXIT) {
4903
e08e1e1d
JM		 4904 /* According to the die_exit.t tests, if errno is non-zero */
4905 /* It should be used for the error status. */
0968cdad 4906
e08e1e1d
JM		 4907 if (errno == EVMSERR) {
4908 STATUS_NATIVE = vaxc$errno;
4909 } else {
0968cdad 4910
e08e1e1d
JM		 4911 /* According to die_exit.t tests, if the child_exit code is */
4912 /* also zero, then we need to exit with a code of 255 */
4913 if ((errno != 0) && (errno < 256))
4914 STATUS_UNIX_EXIT_SET(errno);
4915 else if (STATUS_UNIX < 255) {
0968cdad 4916 STATUS_UNIX_EXIT_SET(255);
e08e1e1d
JM		 4917 }
4918
0968cdad 4919 }
e08e1e1d
JM		 4920
4921 /* The exit code could have been set by $? or vmsish which
4922 * means that it may not have fatal set. So convert
4923 * success/warning codes to fatal with out changing
4924 * the POSIX status code. The severity makes VMS native
4925 * status handling work, while UNIX mode programs use the
4926 * the POSIX exit codes.
4927 */
4928 if ((STATUS_NATIVE & (STS$K_SEVERE|STS$K_ERROR)) == 0) {
4929 STATUS_NATIVE &= STS$M_COND_ID;
4930 STATUS_NATIVE |= STS$K_ERROR | STS$M_INHIB_MSG;
4931 }
0968cdad
JM		 4932 }
4933 else {
4934 /* Traditionally Perl on VMS always expects a Fatal Error. */
4935 if (vaxc$errno & 1) {
4936
4937 /* So force success status to failure */
4938 if (STATUS_NATIVE & 1)
4939 STATUS_ALL_FAILURE;
4940 }
4941 else {
4942 if (!vaxc$errno) {
4943 STATUS_UNIX = EINTR; /* In case something cares */
4944 STATUS_ALL_FAILURE;
4945 }
4946 else {
4947 int severity;
4948 STATUS_NATIVE = vaxc$errno; /* Should already be this */
4949
4950 /* Encode the severity code */
4951 severity = STATUS_NATIVE & STS$M_SEVERITY;
4952 STATUS_UNIX = (severity ? severity : 1) << 8;
4953
4954 /* Perl expects this to be a fatal error */
4955 if (severity != STS$K_SEVERE)
4956 STATUS_ALL_FAILURE;
4957 }
4958 }
4959 }
fb38d079 4960
f86702cc 4961#else
9b599b2a 4962 int exitstatus;
f86702cc 4963 if (errno & 255)
e5218da5 4964 STATUS_UNIX_SET(errno);
9b599b2a 4965 else {
e5218da5 4966 exitstatus = STATUS_UNIX >> 8;
9b599b2a 4967 if (exitstatus & 255)
e5218da5 4968 STATUS_UNIX_SET(exitstatus);
9b599b2a 4969 else
e5218da5 4970 STATUS_UNIX_SET(255);
9b599b2a 4971 }
f86702cc 4972#endif
6136213b
JGM		 4973 if (PL_exit_flags & PERL_EXIT_ABORT) {
4974 abort();
4975 }
4976 if (PL_exit_flags & PERL_EXIT_WARN) {
4977 PL_exit_flags |= PERL_EXIT_ABORT; /* Protect against reentrant calls */
7b0eb0b8 4978 Perl_warn(aTHX_ "Unexpected exit failure %ld", (long)PL_statusvalue);
6136213b
JGM		 4979 PL_exit_flags &= ~PERL_EXIT_ABORT;
4980 }
f86702cc 4981 my_exit_jump();
93a17b20
LW		 4982}
4983
76e3520e 4984STATIC void
cea2e8a9 4985S_my_exit_jump(pTHX)
f86702cc 4986{
3280af22
NIS		 4987 if (PL_e_script) {
4988 SvREFCNT_dec(PL_e_script);
a0714e2c 4989 PL_e_script = NULL;
f86702cc 4990 }
4991
3280af22 4992 POPSTACK_TO(PL_mainstack);
f97a0ef2
RH		 4993 dounwind(-1);
4994 LEAVE_SCOPE(0);
ff0cee69 4995
6224f72b 4996 JMPENV_JUMP(2);
f86702cc 4997}
873ef191 4998
0cb96387 4999static I32
acfe0abc 5000read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen)
873ef191 5001{
9d4ba2ae
AL		 5002 const char * const p = SvPVX_const(PL_e_script);
5003 const char *nl = strchr(p, '\n');
5004
5005 PERL_UNUSED_ARG(idx);
5006 PERL_UNUSED_ARG(maxlen);
dd374669 5007
3280af22 5008 nl = (nl) ? nl+1 : SvEND(PL_e_script);
7dfe3f66 5009 if (nl-p == 0) {
0cb96387 5010 filter_del(read_e_script);
873ef191 5011 return 0;
7dfe3f66 5012 }
873ef191 5013 sv_catpvn(buf_sv, p, nl-p);
3280af22 5014 sv_chop(PL_e_script, nl);
873ef191
GS		 5015 return 1;
5016}
66610fdd
RGS		 5017
5018/*
5019 * Local variables:
5020 * c-indentation-style: bsd
5021 * c-basic-offset: 4
14d04a33 5022 * indent-tabs-mode: nil
66610fdd
RGS		 5023 * End:
5024 *
14d04a33 5025 * ex: set ts=8 sts=4 sw=4 et:
37442d52 5026 */
Unnamed repository; edit this file 'description' to name the repository.