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