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