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