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