This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Don't use t/TEST to test a "read only file", repeatedly chmod-ing it a-w.
[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
6224f72b 2256 DEBUG_x(dump_all());
cf2782cd 2257#ifdef DEBUGGING
ecae49c0
NC
2258 if (!DEBUG_q_TEST)
2259 PERL_DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
cf2782cd 2260#endif
6224f72b 2261
3280af22 2262 if (PL_minus_c) {
bf49b057 2263 PerlIO_printf(Perl_error_log, "%s syntax OK\n", PL_origfilename);
6224f72b
GS
2264 my_exit(0);
2265 }
3280af22 2266 if (PERLDB_SINGLE && PL_DBsingle)
ac27b0f5 2267 sv_setiv(PL_DBsingle, 1);
3280af22
NIS
2268 if (PL_initav)
2269 call_list(oldscope, PL_initav);
f1fac472
NC
2270#ifdef PERL_DEBUG_READONLY_OPS
2271 Perl_pending_Slabs_to_ro(aTHX);
2272#endif
6224f72b
GS
2273 }
2274
2275 /* do it */
2276
3280af22 2277 if (PL_restartop) {
533c011a 2278 PL_op = PL_restartop;
3280af22 2279 PL_restartop = 0;
cea2e8a9 2280 CALLRUNOPS(aTHX);
6224f72b 2281 }
3280af22
NIS
2282 else if (PL_main_start) {
2283 CvDEPTH(PL_main_cv) = 1;
533c011a 2284 PL_op = PL_main_start;
cea2e8a9 2285 CALLRUNOPS(aTHX);
6224f72b 2286 }
f6b3007c
JH
2287 my_exit(0);
2288 /* NOTREACHED */
6224f72b
GS
2289}
2290
954c1994 2291/*
ccfc67b7
JH
2292=head1 SV Manipulation Functions
2293
954c1994
GS
2294=for apidoc p||get_sv
2295
64ace3f8
NC
2296Returns the SV of the specified Perl scalar. C<flags> are passed to
2297C<gv_fetchpv>. If C<GV_ADD> is set and the
2298Perl variable does not exist then it will be created. If C<flags> is zero
2299and the variable does not exist then NULL is returned.
954c1994
GS
2300
2301=cut
2302*/
2303
6224f72b 2304SV*
64ace3f8 2305Perl_get_sv(pTHX_ const char *name, I32 flags)
6224f72b
GS
2306{
2307 GV *gv;
7918f24d
NC
2308
2309 PERL_ARGS_ASSERT_GET_SV;
2310
64ace3f8 2311 gv = gv_fetchpv(name, flags, SVt_PV);
6224f72b
GS
2312 if (gv)
2313 return GvSV(gv);
a0714e2c 2314 return NULL;
6224f72b
GS
2315}
2316
954c1994 2317/*
ccfc67b7
JH
2318=head1 Array Manipulation Functions
2319
954c1994
GS
2320=for apidoc p||get_av
2321
cbfd0a87
NC
2322Returns the AV of the specified Perl array. C<flags> are passed to
2323C<gv_fetchpv>. If C<GV_ADD> is set and the
2324Perl variable does not exist then it will be created. If C<flags> is zero
2325and the variable does not exist then NULL is returned.
954c1994
GS
2326
2327=cut
2328*/
2329
6224f72b 2330AV*
cbfd0a87 2331Perl_get_av(pTHX_ const char *name, I32 flags)
6224f72b 2332{
cbfd0a87 2333 GV* const gv = gv_fetchpv(name, flags, SVt_PVAV);
7918f24d
NC
2334
2335 PERL_ARGS_ASSERT_GET_AV;
2336
cbfd0a87 2337 if (flags)
6224f72b
GS
2338 return GvAVn(gv);
2339 if (gv)
2340 return GvAV(gv);
7d49f689 2341 return NULL;
6224f72b
GS
2342}
2343
954c1994 2344/*
ccfc67b7
JH
2345=head1 Hash Manipulation Functions
2346
954c1994
GS
2347=for apidoc p||get_hv
2348
6673a63c
NC
2349Returns the HV of the specified Perl hash. C<flags> are passed to
2350C<gv_fetchpv>. If C<GV_ADD> is set and the
2351Perl variable does not exist then it will be created. If C<flags> is zero
2352and the variable does not exist then NULL is returned.
954c1994
GS
2353
2354=cut
2355*/
2356
6224f72b 2357HV*
6673a63c 2358Perl_get_hv(pTHX_ const char *name, I32 flags)
6224f72b 2359{
6673a63c 2360 GV* const gv = gv_fetchpv(name, flags, SVt_PVHV);
7918f24d
NC
2361
2362 PERL_ARGS_ASSERT_GET_HV;
2363
6673a63c 2364 if (flags)
a0d0e21e
LW
2365 return GvHVn(gv);
2366 if (gv)
2367 return GvHV(gv);
5c284bb0 2368 return NULL;
a0d0e21e
LW
2369}
2370
954c1994 2371/*
ccfc67b7
JH
2372=head1 CV Manipulation Functions
2373
780a5241
NC
2374=for apidoc p||get_cvn_flags
2375
2376Returns the CV of the specified Perl subroutine. C<flags> are passed to
2377C<gv_fetchpvn_flags>. If C<GV_ADD> is set and the Perl subroutine does not
2378exist then it will be declared (which has the same effect as saying
2379C<sub name;>). If C<GV_ADD> is not set and the subroutine does not exist
2380then NULL is returned.
2381
954c1994
GS
2382=for apidoc p||get_cv
2383
780a5241 2384Uses C<strlen> to get the length of C<name>, then calls C<get_cvn_flags>.
954c1994
GS
2385
2386=cut
2387*/
2388
a0d0e21e 2389CV*
780a5241 2390Perl_get_cvn_flags(pTHX_ const char *name, STRLEN len, I32 flags)
a0d0e21e 2391{
780a5241 2392 GV* const gv = gv_fetchpvn_flags(name, len, flags, SVt_PVCV);
f6ec51f7
GS
2393 /* XXX this is probably not what they think they're getting.
2394 * It has the same effect as "sub name;", i.e. just a forward
2395 * declaration! */
7918f24d
NC
2396
2397 PERL_ARGS_ASSERT_GET_CVN_FLAGS;
2398
780a5241 2399 if ((flags & ~GV_NOADD_MASK) && !GvCVu(gv)) {
740cce10 2400 SV *const sv = newSVpvn_flags(name, len, flags & SVf_UTF8);
774d564b 2401 return newSUB(start_subparse(FALSE, 0),
780a5241 2402 newSVOP(OP_CONST, 0, sv),
5f66b61c 2403 NULL, NULL);
780a5241 2404 }
a0d0e21e 2405 if (gv)
8ebc5c01 2406 return GvCVu(gv);
601f1833 2407 return NULL;
a0d0e21e
LW
2408}
2409
2c67934f
NC
2410/* Nothing in core calls this now, but we can't replace it with a macro and
2411 move it to mathoms.c as a macro would evaluate name twice. */
780a5241
NC
2412CV*
2413Perl_get_cv(pTHX_ const char *name, I32 flags)
2414{
7918f24d
NC
2415 PERL_ARGS_ASSERT_GET_CV;
2416
780a5241
NC
2417 return get_cvn_flags(name, strlen(name), flags);
2418}
2419
79072805
LW
2420/* Be sure to refetch the stack pointer after calling these routines. */
2421
954c1994 2422/*
ccfc67b7
JH
2423
2424=head1 Callback Functions
2425
954c1994
GS
2426=for apidoc p||call_argv
2427
2428Performs a callback to the specified Perl sub. See L<perlcall>.
2429
2430=cut
2431*/
2432
a0d0e21e 2433I32
8f42b153 2434Perl_call_argv(pTHX_ const char *sub_name, I32 flags, register char **argv)
ac27b0f5 2435
8ac85365
NIS
2436 /* See G_* flags in cop.h */
2437 /* null terminated arg list */
8990e307 2438{
97aff369 2439 dVAR;
a0d0e21e 2440 dSP;
8990e307 2441
7918f24d
NC
2442 PERL_ARGS_ASSERT_CALL_ARGV;
2443
924508f0 2444 PUSHMARK(SP);
a0d0e21e 2445 if (argv) {
8990e307 2446 while (*argv) {
6e449a3a 2447 mXPUSHs(newSVpv(*argv,0));
8990e307
LW
2448 argv++;
2449 }
a0d0e21e 2450 PUTBACK;
8990e307 2451 }
864dbfa3 2452 return call_pv(sub_name, flags);
8990e307
LW
2453}
2454
954c1994
GS
2455/*
2456=for apidoc p||call_pv
2457
2458Performs a callback to the specified Perl sub. See L<perlcall>.
2459
2460=cut
2461*/
2462
a0d0e21e 2463I32
864dbfa3 2464Perl_call_pv(pTHX_ const char *sub_name, I32 flags)
8ac85365
NIS
2465 /* name of the subroutine */
2466 /* See G_* flags in cop.h */
a0d0e21e 2467{
7918f24d
NC
2468 PERL_ARGS_ASSERT_CALL_PV;
2469
0da0e728 2470 return call_sv(MUTABLE_SV(get_cv(sub_name, GV_ADD)), flags);
a0d0e21e
LW
2471}
2472
954c1994
GS
2473/*
2474=for apidoc p||call_method
2475
2476Performs a callback to the specified Perl method. The blessed object must
2477be on the stack. See L<perlcall>.
2478
2479=cut
2480*/
2481
a0d0e21e 2482I32
864dbfa3 2483Perl_call_method(pTHX_ const char *methname, I32 flags)
8ac85365
NIS
2484 /* name of the subroutine */
2485 /* See G_* flags in cop.h */
a0d0e21e 2486{
7918f24d
NC
2487 PERL_ARGS_ASSERT_CALL_METHOD;
2488
968b3946 2489 return call_sv(sv_2mortal(newSVpv(methname,0)), flags | G_METHOD);
a0d0e21e
LW
2490}
2491
2492/* May be called with any of a CV, a GV, or an SV containing the name. */
954c1994
GS
2493/*
2494=for apidoc p||call_sv
2495
2496Performs a callback to the Perl sub whose name is in the SV. See
2497L<perlcall>.
2498
2499=cut
2500*/
2501
a0d0e21e 2502I32
001d637e 2503Perl_call_sv(pTHX_ SV *sv, VOL I32 flags)
8ac85365 2504 /* See G_* flags in cop.h */
a0d0e21e 2505{
27da23d5 2506 dVAR; dSP;
a0d0e21e 2507 LOGOP myop; /* fake syntax tree node */
968b3946 2508 UNOP method_op;
aa689395 2509 I32 oldmark;
8ea43dc8 2510 VOL I32 retval = 0;
a0d0e21e 2511 I32 oldscope;
54310121 2512 bool oldcatch = CATCH_GET;
6224f72b 2513 int ret;
c4420975 2514 OP* const oldop = PL_op;
db36c5a1 2515 dJMPENV;
1e422769 2516
7918f24d
NC
2517 PERL_ARGS_ASSERT_CALL_SV;
2518
a0d0e21e
LW
2519 if (flags & G_DISCARD) {
2520 ENTER;
2521 SAVETMPS;
2522 }
2f8edad0
NC
2523 if (!(flags & G_WANT)) {
2524 /* Backwards compatibility - as G_SCALAR was 0, it could be omitted.
2525 */
2526 flags |= G_SCALAR;
2527 }
a0d0e21e 2528
aa689395 2529 Zero(&myop, 1, LOGOP);
5f66b61c 2530 myop.op_next = NULL;
f51d4af5 2531 if (!(flags & G_NOARGS))
aa689395 2532 myop.op_flags |= OPf_STACKED;
4f911530 2533 myop.op_flags |= OP_GIMME_REVERSE(flags);
462e5cf6 2534 SAVEOP();
533c011a 2535 PL_op = (OP*)&myop;
aa689395 2536
3280af22
NIS
2537 EXTEND(PL_stack_sp, 1);
2538 *++PL_stack_sp = sv;
aa689395 2539 oldmark = TOPMARK;
3280af22 2540 oldscope = PL_scopestack_ix;
a0d0e21e 2541
3280af22 2542 if (PERLDB_SUB && PL_curstash != PL_debstash
36477c24 2543 /* Handle first BEGIN of -d. */
3280af22 2544 && (PL_DBcv || (PL_DBcv = GvCV(PL_DBsub)))
36477c24
PP
2545 /* Try harder, since this may have been a sighandler, thus
2546 * curstash may be meaningless. */
ea726b52 2547 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((const CV *)sv) != PL_debstash)
491527d0 2548 && !(flags & G_NODEBUG))
533c011a 2549 PL_op->op_private |= OPpENTERSUB_DB;
a0d0e21e 2550
968b3946
GS
2551 if (flags & G_METHOD) {
2552 Zero(&method_op, 1, UNOP);
2553 method_op.op_next = PL_op;
2554 method_op.op_ppaddr = PL_ppaddr[OP_METHOD];
377b1098 2555 method_op.op_type = OP_METHOD;
968b3946 2556 myop.op_ppaddr = PL_ppaddr[OP_ENTERSUB];
377b1098 2557 myop.op_type = OP_ENTERSUB;
f39d0b86 2558 PL_op = (OP*)&method_op;
968b3946
GS
2559 }
2560
312caa8e 2561 if (!(flags & G_EVAL)) {
0cdb2077 2562 CATCH_SET(TRUE);
d6f07c05 2563 CALL_BODY_SUB((OP*)&myop);
312caa8e 2564 retval = PL_stack_sp - (PL_stack_base + oldmark);
0253cb41 2565 CATCH_SET(oldcatch);
312caa8e
CS
2566 }
2567 else {
d78bda3d 2568 myop.op_other = (OP*)&myop;
3280af22 2569 PL_markstack_ptr--;
edb2152a 2570 create_eval_scope(flags|G_FAKINGEVAL);
3280af22 2571 PL_markstack_ptr++;
a0d0e21e 2572
14dd3ad8 2573 JMPENV_PUSH(ret);
edb2152a 2574
6224f72b
GS
2575 switch (ret) {
2576 case 0:
14dd3ad8 2577 redo_body:
d6f07c05 2578 CALL_BODY_SUB((OP*)&myop);
312caa8e 2579 retval = PL_stack_sp - (PL_stack_base + oldmark);
8433848b 2580 if (!(flags & G_KEEPERR)) {
ab69dbc2 2581 CLEAR_ERRSV();
8433848b 2582 }
a0d0e21e 2583 break;
6224f72b 2584 case 1:
f86702cc 2585 STATUS_ALL_FAILURE;
a0d0e21e 2586 /* FALL THROUGH */
6224f72b 2587 case 2:
a0d0e21e 2588 /* my_exit() was called */
3280af22 2589 PL_curstash = PL_defstash;
a0d0e21e 2590 FREETMPS;
14dd3ad8 2591 JMPENV_POP;
cc3604b1 2592 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
cea2e8a9 2593 Perl_croak(aTHX_ "Callback called exit");
f86702cc 2594 my_exit_jump();
a0d0e21e 2595 /* NOTREACHED */
6224f72b 2596 case 3:
3280af22 2597 if (PL_restartop) {
533c011a 2598 PL_op = PL_restartop;
3280af22 2599 PL_restartop = 0;
312caa8e 2600 goto redo_body;
a0d0e21e 2601 }
3280af22 2602 PL_stack_sp = PL_stack_base + oldmark;
51ce5529 2603 if ((flags & G_WANT) == G_ARRAY)
a0d0e21e
LW
2604 retval = 0;
2605 else {
2606 retval = 1;
3280af22 2607 *++PL_stack_sp = &PL_sv_undef;
a0d0e21e 2608 }
312caa8e 2609 break;
a0d0e21e 2610 }
a0d0e21e 2611
edb2152a
NC
2612 if (PL_scopestack_ix > oldscope)
2613 delete_eval_scope();
14dd3ad8 2614 JMPENV_POP;
a0d0e21e 2615 }
1e422769 2616
a0d0e21e 2617 if (flags & G_DISCARD) {
3280af22 2618 PL_stack_sp = PL_stack_base + oldmark;
a0d0e21e
LW
2619 retval = 0;
2620 FREETMPS;
2621 LEAVE;
2622 }
533c011a 2623 PL_op = oldop;
a0d0e21e
LW
2624 return retval;
2625}
2626
6e72f9df 2627/* Eval a string. The G_EVAL flag is always assumed. */
8990e307 2628
954c1994
GS
2629/*
2630=for apidoc p||eval_sv
2631
2632Tells Perl to C<eval> the string in the SV.
2633
2634=cut
2635*/
2636
a0d0e21e 2637I32
864dbfa3 2638Perl_eval_sv(pTHX_ SV *sv, I32 flags)
ac27b0f5 2639
8ac85365 2640 /* See G_* flags in cop.h */
a0d0e21e 2641{
97aff369 2642 dVAR;
924508f0 2643 dSP;
a0d0e21e 2644 UNOP myop; /* fake syntax tree node */
8ea43dc8
SP
2645 VOL I32 oldmark = SP - PL_stack_base;
2646 VOL I32 retval = 0;
6224f72b 2647 int ret;
c4420975 2648 OP* const oldop = PL_op;
db36c5a1 2649 dJMPENV;
84902520 2650
7918f24d
NC
2651 PERL_ARGS_ASSERT_EVAL_SV;
2652
4633a7c4
LW
2653 if (flags & G_DISCARD) {
2654 ENTER;
2655 SAVETMPS;
2656 }
2657
462e5cf6 2658 SAVEOP();
533c011a
NIS
2659 PL_op = (OP*)&myop;
2660 Zero(PL_op, 1, UNOP);
3280af22
NIS
2661 EXTEND(PL_stack_sp, 1);
2662 *++PL_stack_sp = sv;
79072805 2663
4633a7c4
LW
2664 if (!(flags & G_NOARGS))
2665 myop.op_flags = OPf_STACKED;
5f66b61c 2666 myop.op_next = NULL;
6e72f9df 2667 myop.op_type = OP_ENTEREVAL;
4f911530 2668 myop.op_flags |= OP_GIMME_REVERSE(flags);
6e72f9df
PP
2669 if (flags & G_KEEPERR)
2670 myop.op_flags |= OPf_SPECIAL;
4633a7c4 2671
dedbcade
DM
2672 /* fail now; otherwise we could fail after the JMPENV_PUSH but
2673 * before a PUSHEVAL, which corrupts the stack after a croak */
2674 TAINT_PROPER("eval_sv()");
2675
14dd3ad8 2676 JMPENV_PUSH(ret);
6224f72b
GS
2677 switch (ret) {
2678 case 0:
14dd3ad8 2679 redo_body:
d6f07c05 2680 CALL_BODY_EVAL((OP*)&myop);
312caa8e 2681 retval = PL_stack_sp - (PL_stack_base + oldmark);
8433848b 2682 if (!(flags & G_KEEPERR)) {
ab69dbc2 2683 CLEAR_ERRSV();
8433848b 2684 }
4633a7c4 2685 break;
6224f72b 2686 case 1:
f86702cc 2687 STATUS_ALL_FAILURE;
4633a7c4 2688 /* FALL THROUGH */
6224f72b 2689 case 2:
4633a7c4 2690 /* my_exit() was called */
3280af22 2691 PL_curstash = PL_defstash;
4633a7c4 2692 FREETMPS;
14dd3ad8 2693 JMPENV_POP;
cc3604b1 2694 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
cea2e8a9 2695 Perl_croak(aTHX_ "Callback called exit");
f86702cc 2696 my_exit_jump();
4633a7c4 2697 /* NOTREACHED */
6224f72b 2698 case 3:
3280af22 2699 if (PL_restartop) {
533c011a 2700 PL_op = PL_restartop;
3280af22 2701 PL_restartop = 0;
312caa8e 2702 goto redo_body;
4633a7c4 2703 }
3280af22 2704 PL_stack_sp = PL_stack_base + oldmark;
51ce5529 2705 if ((flags & G_WANT) == G_ARRAY)
4633a7c4
LW
2706 retval = 0;
2707 else {
2708 retval = 1;
3280af22 2709 *++PL_stack_sp = &PL_sv_undef;
4633a7c4 2710 }
312caa8e 2711 break;
4633a7c4
LW
2712 }
2713
14dd3ad8 2714 JMPENV_POP;
4633a7c4 2715 if (flags & G_DISCARD) {
3280af22 2716 PL_stack_sp = PL_stack_base + oldmark;
4633a7c4
LW
2717 retval = 0;
2718 FREETMPS;
2719 LEAVE;
2720 }
533c011a 2721 PL_op = oldop;
4633a7c4
LW
2722 return retval;
2723}
2724
954c1994
GS
2725/*
2726=for apidoc p||eval_pv
2727
2728Tells Perl to C<eval> the given string and return an SV* result.
2729
2730=cut
2731*/
2732
137443ea 2733SV*
864dbfa3 2734Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error)
137443ea 2735{
97aff369 2736 dVAR;
137443ea
PP
2737 dSP;
2738 SV* sv = newSVpv(p, 0);
2739
7918f24d
NC
2740 PERL_ARGS_ASSERT_EVAL_PV;
2741
864dbfa3 2742 eval_sv(sv, G_SCALAR);
137443ea
PP
2743 SvREFCNT_dec(sv);
2744
2745 SPAGAIN;
2746 sv = POPs;
2747 PUTBACK;
2748
2d8e6c8d 2749 if (croak_on_error && SvTRUE(ERRSV)) {
f1f66076 2750 Perl_croak(aTHX_ "%s", SvPVx_nolen_const(ERRSV));
2d8e6c8d 2751 }
137443ea
PP
2752
2753 return sv;
2754}
2755
4633a7c4
LW
2756/* Require a module. */
2757
954c1994 2758/*
ccfc67b7
JH
2759=head1 Embedding Functions
2760
954c1994
GS
2761=for apidoc p||require_pv
2762
7d3fb230
BS
2763Tells Perl to C<require> the file named by the string argument. It is
2764analogous to the Perl code C<eval "require '$file'">. It's even
2307c6d0 2765implemented that way; consider using load_module instead.
954c1994 2766
7d3fb230 2767=cut */
954c1994 2768
4633a7c4 2769void
864dbfa3 2770Perl_require_pv(pTHX_ const char *pv)
4633a7c4 2771{
97aff369 2772 dVAR;
d3acc0f7 2773 dSP;
97aff369 2774 SV* sv;
7918f24d
NC
2775
2776 PERL_ARGS_ASSERT_REQUIRE_PV;
2777
e788e7d3 2778 PUSHSTACKi(PERLSI_REQUIRE);
d3acc0f7 2779 PUTBACK;
be41e5d9
NC
2780 sv = Perl_newSVpvf(aTHX_ "require q%c%s%c", 0, pv, 0);
2781 eval_sv(sv_2mortal(sv), G_DISCARD);
d3acc0f7
JP
2782 SPAGAIN;
2783 POPSTACK;
79072805
LW
2784}
2785
76e3520e 2786STATIC void
e1ec3a88 2787S_usage(pTHX_ const char *name) /* XXX move this out into a module ? */
4633a7c4 2788{
ab821d7f 2789 /* This message really ought to be max 23 lines.
75c72d73 2790 * Removed -h because the user already knows that option. Others? */
fb73857a 2791
27da23d5 2792 static const char * const usage_msg[] = {
aefc56c5 2793"-0[octal] specify record separator (\\0, if no argument)",
aefc56c5
SF
2794"-a autosplit mode with -n or -p (splits $_ into @F)",
2795"-C[number/list] enables the listed Unicode features",
2796"-c check syntax only (runs BEGIN and CHECK blocks)",
2797"-d[:debugger] run program under debugger",
2798"-D[number/list] set debugging flags (argument is a bit mask or alphabets)",
2799"-e program one line of program (several -e's allowed, omit programfile)",
bc9b29db 2800"-E program like -e, but enables all optional features",
aefc56c5 2801"-f don't do $sitelib/sitecustomize.pl at startup",
aefc56c5
SF
2802"-F/pattern/ split() pattern for -a switch (//'s are optional)",
2803"-i[extension] edit <> files in place (makes backup if extension supplied)",
2804"-Idirectory specify @INC/#include directory (several -I's allowed)",
2805"-l[octal] enable line ending processing, specifies line terminator",
2806"-[mM][-]module execute \"use/no module...\" before executing program",
2807"-n assume \"while (<>) { ... }\" loop around program",
2808"-p assume loop like -n but print line also, like sed",
aefc56c5
SF
2809"-s enable rudimentary parsing for switches after programfile",
2810"-S look for programfile using PATH environment variable",
2811"-t enable tainting warnings",
2812"-T enable tainting checks",
2813"-u dump core after parsing program",
2814"-U allow unsafe operations",
2815"-v print version, subversion (includes VERY IMPORTANT perl info)",
2816"-V[:variable] print configuration summary (or a single Config.pm variable)",
2817"-w enable many useful warnings (RECOMMENDED)",
2818"-W enable all warnings",
2819"-x[directory] strip off text before #!perl line and perhaps cd to directory",
2820"-X disable all warnings",
fb73857a
PP
2821"\n",
2822NULL
2823};
27da23d5 2824 const char * const *p = usage_msg;
fb73857a 2825
7918f24d
NC
2826 PERL_ARGS_ASSERT_USAGE;
2827
b0e47665
GS
2828 PerlIO_printf(PerlIO_stdout(),
2829 "\nUsage: %s [switches] [--] [programfile] [arguments]",
2830 name);
fb73857a 2831 while (*p)
b0e47665 2832 PerlIO_printf(PerlIO_stdout(), "\n %s", *p++);
4633a7c4
LW
2833}
2834
b4ab917c
DM
2835/* convert a string of -D options (or digits) into an int.
2836 * sets *s to point to the char after the options */
2837
2838#ifdef DEBUGGING
2839int
e1ec3a88 2840Perl_get_debug_opts(pTHX_ const char **s, bool givehelp)
b4ab917c 2841{
27da23d5 2842 static const char * const usage_msgd[] = {
e6e64d9b
JC
2843 " Debugging flag values: (see also -d)",
2844 " p Tokenizing and parsing (with v, displays parse stack)",
3679267a 2845 " s Stack snapshots (with v, displays all stacks)",
e6e64d9b
JC
2846 " l Context (loop) stack processing",
2847 " t Trace execution",
2848 " o Method and overloading resolution",
2849 " c String/numeric conversions",
4c84d7f2 2850 " P Print profiling info, source file input state",
d7a2c63c 2851 " m Memory and SV allocation",
e6e64d9b
JC
2852 " f Format processing",
2853 " r Regular expression parsing and execution",
2854 " x Syntax tree dump",
3679267a 2855 " u Tainting checks",
e6e64d9b
JC
2856 " H Hash dump -- usurps values()",
2857 " X Scratchpad allocation",
2858 " D Cleaning up",
e6e64d9b
JC
2859 " T Tokenising",
2860 " R Include reference counts of dumped variables (eg when using -Ds)",
2861 " J Do not s,t,P-debug (Jump over) opcodes within package DB",
2862 " v Verbose: use in conjunction with other flags",
2863 " C Copy On Write",
2864 " A Consistency checks on internal structures",
3679267a 2865 " q quiet - currently only suppresses the 'EXECUTING' message",
d7c0d282 2866 " M trace smart match resolution",
cc8773c0 2867 " B dump suBroutine definitions, including special Blocks like BEGIN",
e6e64d9b
JC
2868 NULL
2869 };
b4ab917c 2870 int i = 0;
7918f24d
NC
2871
2872 PERL_ARGS_ASSERT_GET_DEBUG_OPTS;
2873
b4ab917c
DM
2874 if (isALPHA(**s)) {
2875 /* if adding extra options, remember to update DEBUG_MASK */
cc8773c0 2876 static const char debopts[] = "psltocPmfrxuUHXDSTRJvCAqMB";
b4ab917c
DM
2877
2878 for (; isALNUM(**s); (*s)++) {
c4420975 2879 const char * const d = strchr(debopts,**s);
b4ab917c
DM
2880 if (d)
2881 i |= 1 << (d - debopts);
2882 else if (ckWARN_d(WARN_DEBUGGING))
e6e64d9b
JC
2883 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
2884 "invalid option -D%c, use -D'' to see choices\n", **s);
b4ab917c
DM
2885 }
2886 }
e6e64d9b 2887 else if (isDIGIT(**s)) {
b4ab917c
DM
2888 i = atoi(*s);
2889 for (; isALNUM(**s); (*s)++) ;
2890 }
ddcf8bc1 2891 else if (givehelp) {
06e869a4 2892 const char *const *p = usage_msgd;
e6e64d9b
JC
2893 while (*p) PerlIO_printf(PerlIO_stdout(), "%s\n", *p++);
2894 }
b4ab917c
DM
2895# ifdef EBCDIC
2896 if ((i & DEBUG_p_FLAG) && ckWARN_d(WARN_DEBUGGING))
2897 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
2898 "-Dp not implemented on this platform\n");
2899# endif
2900 return i;
2901}
2902#endif
2903
79072805
LW
2904/* This routine handles any switches that can be given during run */
2905
c7030b81
NC
2906const char *
2907Perl_moreswitches(pTHX_ const char *s)
79072805 2908{
27da23d5 2909 dVAR;
84c133a0 2910 UV rschar;
0544e6df 2911 const char option = *s; /* used to remember option in -m/-M code */
79072805 2912
7918f24d
NC
2913 PERL_ARGS_ASSERT_MORESWITCHES;
2914
79072805
LW
2915 switch (*s) {
2916 case '0':
a863c7d1 2917 {
f2095865 2918 I32 flags = 0;
a3b680e6 2919 STRLEN numlen;
f2095865
JH
2920
2921 SvREFCNT_dec(PL_rs);
2922 if (s[1] == 'x' && s[2]) {
a3b680e6 2923 const char *e = s+=2;
f2095865
JH
2924 U8 *tmps;
2925
a3b680e6
AL
2926 while (*e)
2927 e++;
f2095865
JH
2928 numlen = e - s;
2929 flags = PERL_SCAN_SILENT_ILLDIGIT;
2930 rschar = (U32)grok_hex(s, &numlen, &flags, NULL);
2931 if (s + numlen < e) {
2932 rschar = 0; /* Grandfather -0xFOO as -0 -xFOO. */
2933 numlen = 0;
2934 s--;
2935 }
396482e1 2936 PL_rs = newSVpvs("");
c5661c80 2937 SvGROW(PL_rs, (STRLEN)(UNISKIP(rschar) + 1));
f2095865
JH
2938 tmps = (U8*)SvPVX(PL_rs);
2939 uvchr_to_utf8(tmps, rschar);
2940 SvCUR_set(PL_rs, UNISKIP(rschar));
2941 SvUTF8_on(PL_rs);
2942 }
2943 else {
2944 numlen = 4;
2945 rschar = (U32)grok_oct(s, &numlen, &flags, NULL);
2946 if (rschar & ~((U8)~0))
2947 PL_rs = &PL_sv_undef;
2948 else if (!rschar && numlen >= 2)
396482e1 2949 PL_rs = newSVpvs("");
f2095865
JH
2950 else {
2951 char ch = (char)rschar;
2952 PL_rs = newSVpvn(&ch, 1);
2953 }
2954 }
64ace3f8 2955 sv_setsv(get_sv("/", GV_ADD), PL_rs);
f2095865 2956 return s + numlen;
a863c7d1 2957 }
46487f74 2958 case 'C':
a05d7ebb 2959 s++;
dd374669 2960 PL_unicode = parse_unicode_opts( (const char **)&s );
5a22a2bb
NC
2961 if (PL_unicode & PERL_UNICODE_UTF8CACHEASSERT_FLAG)
2962 PL_utf8cache = -1;
46487f74 2963 return s;
2304df62 2964 case 'F':
3280af22 2965 PL_minus_F = TRUE;
ebce5377
RGS
2966 PL_splitstr = ++s;
2967 while (*s && !isSPACE(*s)) ++s;
e49e380e 2968 PL_splitstr = savepvn(PL_splitstr, s - PL_splitstr);
2304df62 2969 return s;
79072805 2970 case 'a':
3280af22 2971 PL_minus_a = TRUE;
79072805
LW
2972 s++;
2973 return s;
2974 case 'c':
3280af22 2975 PL_minus_c = TRUE;
79072805
LW
2976 s++;
2977 return s;
2978 case 'd':
f20b2998 2979 forbid_setid('d', FALSE);
4633a7c4 2980 s++;
2cbb2ee1
RGS
2981
2982 /* -dt indicates to the debugger that threads will be used */
2983 if (*s == 't' && !isALNUM(s[1])) {
2984 ++s;
2985 my_setenv("PERL5DB_THREADED", "1");
2986 }
2987
70c94a19
RR
2988 /* The following permits -d:Mod to accepts arguments following an =
2989 in the fashion that -MSome::Mod does. */
2990 if (*s == ':' || *s == '=') {
f85893a1
NC
2991 const char *start = ++s;
2992 const char *const end = s + strlen(s);
396482e1 2993 SV * const sv = newSVpvs("use Devel::");
f85893a1 2994
70c94a19
RR
2995 /* We now allow -d:Module=Foo,Bar */
2996 while(isALNUM(*s) || *s==':') ++s;
2997 if (*s != '=')
f85893a1 2998 sv_catpvn(sv, start, end - start);
70c94a19
RR
2999 else {
3000 sv_catpvn(sv, start, s-start);
95a2b409
RGS
3001 /* Don't use NUL as q// delimiter here, this string goes in the
3002 * environment. */
3003 Perl_sv_catpvf(aTHX_ sv, " split(/,/,q{%s});", ++s);
70c94a19 3004 }
f85893a1 3005 s = end;
184f32ec 3006 my_setenv("PERL5DB", SvPV_nolen_const(sv));
c4db126b 3007 SvREFCNT_dec(sv);
4633a7c4 3008 }
ed094faf 3009 if (!PL_perldb) {
3280af22 3010 PL_perldb = PERLDB_ALL;
a0d0e21e 3011 init_debugger();
ed094faf 3012 }
79072805
LW
3013 return s;
3014 case 'D':
0453d815 3015 {
79072805 3016#ifdef DEBUGGING
f20b2998 3017 forbid_setid('D', FALSE);
b4ab917c 3018 s++;
dd374669 3019 PL_debug = get_debug_opts( (const char **)&s, 1) | DEBUG_TOP_FLAG;
12a43e32 3020#else /* !DEBUGGING */
0453d815 3021 if (ckWARN_d(WARN_DEBUGGING))
9014280d 3022 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
e6e64d9b 3023 "Recompile perl with -DDEBUGGING to use -D switch (did you mean -d ?)\n");
a0d0e21e 3024 for (s++; isALNUM(*s); s++) ;
79072805 3025#endif
79072805 3026 return s;
0453d815 3027 }
4633a7c4 3028 case 'h':
ac27b0f5 3029 usage(PL_origargv[0]);
7ca617d0 3030 my_exit(0);
79072805 3031 case 'i':
43c5f42d 3032 Safefree(PL_inplace);
c030f24b
GH
3033#if defined(__CYGWIN__) /* do backup extension automagically */
3034 if (*(s+1) == '\0') {
c86a4f2e 3035 PL_inplace = savepvs(".bak");
c030f24b
GH
3036 return s+1;
3037 }
3038#endif /* __CYGWIN__ */
5ef5d758 3039 {
d4c19fe8 3040 const char * const start = ++s;
5ef5d758
NC
3041 while (*s && !isSPACE(*s))
3042 ++s;
3043
3044 PL_inplace = savepvn(start, s - start);
3045 }
7b8d334a 3046 if (*s) {
5ef5d758 3047 ++s;
7b8d334a 3048 if (*s == '-') /* Additional switches on #! line. */
5ef5d758 3049 s++;
7b8d334a 3050 }
fb73857a 3051 return s;
4e49a025 3052 case 'I': /* -I handled both here and in parse_body() */
f20b2998 3053 forbid_setid('I', FALSE);
fb73857a
PP
3054 ++s;
3055 while (*s && isSPACE(*s))
3056 ++s;
3057 if (*s) {
c7030b81 3058 const char *e, *p;
0df16ed7
GS
3059 p = s;
3060 /* ignore trailing spaces (possibly followed by other switches) */
3061 do {
3062 for (e = p; *e && !isSPACE(*e); e++) ;
3063 p = e;
3064 while (isSPACE(*p))
3065 p++;
3066 } while (*p && *p != '-');
55b4bc1c 3067 incpush(s, e-s,
e28f3139 3068 INCPUSH_ADD_SUB_DIRS|INCPUSH_ADD_OLD_VERS|INCPUSH_UNSHIFT);
0df16ed7
GS
3069 s = p;
3070 if (*s == '-')
3071 s++;
79072805
LW
3072 }
3073 else
a67e862a 3074 Perl_croak(aTHX_ "No directory specified for -I");
fb73857a 3075 return s;
79072805 3076 case 'l':
3280af22 3077 PL_minus_l = TRUE;
79072805 3078 s++;
7889fe52
NIS
3079 if (PL_ors_sv) {
3080 SvREFCNT_dec(PL_ors_sv);
a0714e2c 3081 PL_ors_sv = NULL;
7889fe52 3082 }
79072805 3083 if (isDIGIT(*s)) {
53305cf1 3084 I32 flags = 0;
a3b680e6 3085 STRLEN numlen;
396482e1 3086 PL_ors_sv = newSVpvs("\n");
53305cf1
NC
3087 numlen = 3 + (*s == '0');
3088 *SvPVX(PL_ors_sv) = (char)grok_oct(s, &numlen, &flags, NULL);
79072805
LW
3089 s += numlen;
3090 }
3091 else {
8bfdd7d9 3092 if (RsPARA(PL_rs)) {
396482e1 3093 PL_ors_sv = newSVpvs("\n\n");
7889fe52
NIS
3094 }
3095 else {
8bfdd7d9 3096 PL_ors_sv = newSVsv(PL_rs);
c07a80fd 3097 }
79072805
LW
3098 }
3099 return s;
1a30305b 3100 case 'M':
f20b2998 3101 forbid_setid('M', FALSE); /* XXX ? */
1a30305b
PP
3102 /* FALL THROUGH */
3103 case 'm':
f20b2998 3104 forbid_setid('m', FALSE); /* XXX ? */
1a30305b 3105 if (*++s) {
c7030b81 3106 const char *start;
b64cb68c 3107 const char *end;
11343788 3108 SV *sv;
e1ec3a88 3109 const char *use = "use ";
0544e6df 3110 bool colon = FALSE;
a5f75d66 3111 /* -M-foo == 'no foo' */
d0043bd1
NC
3112 /* Leading space on " no " is deliberate, to make both
3113 possibilities the same length. */
3114 if (*s == '-') { use = " no "; ++s; }
3115 sv = newSVpvn(use,4);
a5f75d66 3116 start = s;
1a30305b 3117 /* We allow -M'Module qw(Foo Bar)' */
0544e6df
RB
3118 while(isALNUM(*s) || *s==':') {
3119 if( *s++ == ':' ) {
3120 if( *s == ':' )
3121 s++;
3122 else
3123 colon = TRUE;
3124 }
3125 }
3126 if (s == start)
3127 Perl_croak(aTHX_ "Module name required with -%c option",
3128 option);
3129 if (colon)
3130 Perl_croak(aTHX_ "Invalid module name %.*s with -%c option: "
3131 "contains single ':'",
63da6837 3132 (int)(s - start), start, option);
b64cb68c 3133 end = s + strlen(s);
c07a80fd 3134 if (*s != '=') {
b64cb68c 3135 sv_catpvn(sv, start, end - start);
0544e6df 3136 if (option == 'm') {
c07a80fd 3137 if (*s != '\0')
cea2e8a9 3138 Perl_croak(aTHX_ "Can't use '%c' after -mname", *s);
396482e1 3139 sv_catpvs( sv, " ()");
c07a80fd
PP
3140 }
3141 } else {
11343788 3142 sv_catpvn(sv, start, s-start);
b64cb68c
NC
3143 /* Use NUL as q''-delimiter. */
3144 sv_catpvs(sv, " split(/,/,q\0");
3145 ++s;
3146 sv_catpvn(sv, s, end - s);
396482e1 3147 sv_catpvs(sv, "\0)");
c07a80fd 3148 }
b64cb68c 3149 s = end;
29a861e7 3150 Perl_av_create_and_push(aTHX_ &PL_preambleav, sv);
1a30305b
PP
3151 }
3152 else
0544e6df 3153 Perl_croak(aTHX_ "Missing argument to -%c", option);
1a30305b 3154 return s;
79072805 3155 case 'n':
3280af22 3156 PL_minus_n = TRUE;
79072805
LW
3157 s++;
3158 return s;
3159 case 'p':
3280af22 3160 PL_minus_p = TRUE;
79072805
LW
3161 s++;
3162 return s;
3163 case 's':
f20b2998 3164 forbid_setid('s', FALSE);
3280af22 3165 PL_doswitches = TRUE;
79072805
LW
3166 s++;
3167 return s;
6537fe72
MS
3168 case 't':
3169 if (!PL_tainting)
22f7c9c9 3170 TOO_LATE_FOR('t');
6537fe72
MS
3171 s++;
3172 return s;
463ee0b2 3173 case 'T':
3280af22 3174 if (!PL_tainting)
22f7c9c9 3175 TOO_LATE_FOR('T');
463ee0b2
LW
3176 s++;
3177 return s;
79072805 3178 case 'u':
3280af22 3179 PL_do_undump = TRUE;
79072805
LW
3180 s++;
3181 return s;
3182 case 'U':
3280af22 3183 PL_unsafe = TRUE;
79072805
LW
3184 s++;
3185 return s;
3186 case 'v':
d7aa5382 3187 if (!sv_derived_from(PL_patchlevel, "version"))
ac0e6a2f 3188 upg_version(PL_patchlevel, TRUE);
8e9464f1 3189#if !defined(DGUX)
46807d8e
YO
3190 {
3191 SV* level= vstringify(PL_patchlevel);
3192#ifdef PERL_PATCHNUM
23d483e2
NC
3193# ifdef PERL_GIT_UNCOMMITTED_CHANGES
3194 SV *num = newSVpvs(PERL_PATCHNUM "*");
3195# else
3196 SV *num = newSVpvs(PERL_PATCHNUM);
3197# endif
46807d8e
YO
3198
3199 if (sv_len(num)>=sv_len(level) && strnEQ(SvPV_nolen(num),SvPV_nolen(level),sv_len(level))) {
3200 SvREFCNT_dec(level);
3201 level= num;
3202 } else {
d0a9311f 3203 Perl_sv_catpvf(aTHX_ level, " (%"SVf")", num);
46807d8e
YO
3204 SvREFCNT_dec(num);
3205 }
3206 #endif
3207 PerlIO_printf(PerlIO_stdout(),
f1f66076 3208 "\nThis is perl, %"SVf
f1f66076 3209 " built for %s",
46807d8e 3210 level,
f1f66076 3211 ARCHNAME);
46807d8e
YO
3212 SvREFCNT_dec(level);
3213 }
8e9464f1
JH
3214#else /* DGUX */
3215/* Adjust verbose output as in the perl that ships with the DG/UX OS from EMC */
3216 PerlIO_printf(PerlIO_stdout(),
52ea0aec 3217 Perl_form(aTHX_ "\nThis is perl, %"SVf"\n",
be2597df 3218 SVfARG(vstringify(PL_patchlevel))));
8e9464f1
JH
3219 PerlIO_printf(PerlIO_stdout(),
3220 Perl_form(aTHX_ " built under %s at %s %s\n",
3221 OSNAME, __DATE__, __TIME__));
3222 PerlIO_printf(PerlIO_stdout(),
3223 Perl_form(aTHX_ " OS Specific Release: %s\n",
40a39f85 3224 OSVERS));
8e9464f1 3225#endif /* !DGUX */
fb73857a
PP
3226#if defined(LOCAL_PATCH_COUNT)
3227 if (LOCAL_PATCH_COUNT > 0)
b0e47665
GS
3228 PerlIO_printf(PerlIO_stdout(),
3229 "\n(with %d registered patch%s, "
3230 "see perl -V for more detail)",
bb7a0f54 3231 LOCAL_PATCH_COUNT,
b0e47665 3232 (LOCAL_PATCH_COUNT!=1) ? "es" : "");
a5f75d66 3233#endif
1a30305b 3234
b0e47665 3235 PerlIO_printf(PerlIO_stdout(),
737f4459 3236 "\n\nCopyright 1987-2009, Larry Wall\n");
79072805 3237#ifdef MSDOS
b0e47665
GS
3238 PerlIO_printf(PerlIO_stdout(),
3239 "\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
55497cff
PP
3240#endif
3241#ifdef DJGPP
b0e47665
GS
3242 PerlIO_printf(PerlIO_stdout(),
3243 "djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n"
3244 "djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n");
4633a7c4 3245#endif
79072805 3246#ifdef OS2
b0e47665
GS
3247 PerlIO_printf(PerlIO_stdout(),
3248 "\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
be3c0a43 3249 "Version 5 port Copyright (c) 1994-2002, Andreas Kaiser, Ilya Zakharevich\n");
79072805 3250#endif
79072805 3251#ifdef atarist
b0e47665
GS
3252 PerlIO_printf(PerlIO_stdout(),
3253 "atariST series port, ++jrb bammi@cadence.com\n");
79072805 3254#endif
a3f9223b 3255#ifdef __BEOS__
b0e47665
GS
3256 PerlIO_printf(PerlIO_stdout(),
3257 "BeOS port Copyright Tom Spindler, 1997-1999\n");
a3f9223b 3258#endif
1d84e8df 3259#ifdef MPE
b0e47665 3260 PerlIO_printf(PerlIO_stdout(),
e583a879 3261 "MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-2003\n");
1d84e8df 3262#endif
9d116dd7 3263#ifdef OEMVS
b0e47665
GS
3264 PerlIO_printf(PerlIO_stdout(),
3265 "MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
9d116dd7 3266#endif
495c5fdc 3267#ifdef __VOS__
b0e47665 3268 PerlIO_printf(PerlIO_stdout(),
94efb9fb 3269 "Stratus VOS port by Paul.Green@stratus.com, 1997-2002\n");
495c5fdc 3270#endif
092bebab 3271#ifdef __OPEN_VM
b0e47665
GS
3272 PerlIO_printf(PerlIO_stdout(),
3273 "VM/ESA port by Neale Ferguson, 1998-1999\n");
092bebab 3274#endif
a1a0e61e 3275#ifdef POSIX_BC
b0e47665
GS
3276 PerlIO_printf(PerlIO_stdout(),
3277 "BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
a1a0e61e 3278#endif
f83d2536 3279#ifdef EPOC
b0e47665 3280 PerlIO_printf(PerlIO_stdout(),
be3c0a43 3281 "EPOC port by Olaf Flebbe, 1999-2002\n");
f83d2536 3282#endif
e1caacb4 3283#ifdef UNDER_CE
b475b3e6
JH
3284 PerlIO_printf(PerlIO_stdout(),"WINCE port by Rainer Keuchel, 2001-2002\n");
3285 PerlIO_printf(PerlIO_stdout(),"Built on " __DATE__ " " __TIME__ "\n\n");
e1caacb4
JH
3286 wce_hitreturn();
3287#endif
a0fd4948 3288#ifdef __SYMBIAN32__
27da23d5
JH
3289 PerlIO_printf(PerlIO_stdout(),
3290 "Symbian port by Nokia, 2004-2005\n");
3291#endif
baed7233
DL
3292#ifdef BINARY_BUILD_NOTICE
3293 BINARY_BUILD_NOTICE;
3294#endif
b0e47665
GS
3295 PerlIO_printf(PerlIO_stdout(),
3296 "\n\
79072805 3297Perl may be copied only under the terms of either the Artistic License or the\n\
3d6f292d 3298GNU General Public License, which may be found in the Perl 5 source kit.\n\n\
95103687 3299Complete documentation for Perl, including FAQ lists, should be found on\n\
a0288114 3300this system using \"man perl\" or \"perldoc perl\". If you have access to the\n\
c9e30dd8 3301Internet, point your browser at http://www.perl.org/, the Perl Home Page.\n\n");
7ca617d0 3302 my_exit(0);
79072805 3303 case 'w':
b2e5e6ba 3304 if (! (PL_dowarn & G_WARN_ALL_MASK)) {
ac27b0f5 3305 PL_dowarn |= G_WARN_ON;
b2e5e6ba 3306 }
599cee73
PM
3307 s++;
3308 return s;
3309 case 'W':
ac27b0f5 3310 PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
317ea90d 3311 if (!specialWARN(PL_compiling.cop_warnings))
72dc9ed5 3312 PerlMemShared_free(PL_compiling.cop_warnings);
d3a7d8c7 3313 PL_compiling.cop_warnings = pWARN_ALL ;
599cee73
PM
3314 s++;
3315 return s;
3316 case 'X':
ac27b0f5 3317 PL_dowarn = G_WARN_ALL_OFF;
317ea90d 3318 if (!specialWARN(PL_compiling.cop_warnings))
72dc9ed5 3319 PerlMemShared_free(PL_compiling.cop_warnings);
d3a7d8c7 3320 PL_compiling.cop_warnings = pWARN_NONE ;
79072805
LW
3321 s++;
3322 return s;
a0d0e21e 3323 case '*':
79072805 3324 case ' ':
d3133c89
NC
3325 while( *s == ' ' )
3326 ++s;
3327 if (s[0] == '-') /* Additional switches on #! line. */
3328 return s+1;
79072805 3329 break;
a0d0e21e 3330 case '-':
79072805 3331 case 0:
51882d45 3332#if defined(WIN32) || !defined(PERL_STRICT_CR)
a868473f
NIS
3333 case '\r':
3334#endif
79072805
LW
3335 case '\n':
3336 case '\t':
3337 break;
aa689395
PP
3338#ifdef ALTERNATE_SHEBANG
3339 case 'S': /* OS/2 needs -S on "extproc" line. */
3340 break;
3341#endif
79072805 3342 default:
cea2e8a9 3343 Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s);
79072805 3344 }
bd61b366 3345 return NULL;
79072805
LW
3346}
3347
3348/* compliments of Tom Christiansen */
3349
3350/* unexec() can be found in the Gnu emacs distribution */
ee580363 3351/* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
79072805
LW
3352
3353void
864dbfa3 3354Perl_my_unexec(pTHX)
79072805 3355{
b37c2d43 3356 PERL_UNUSED_CONTEXT;
79072805 3357#ifdef UNEXEC
b37c2d43
AL
3358 SV * prog = newSVpv(BIN_EXP, 0);
3359 SV * file = newSVpv(PL_origfilename, 0);
ee580363 3360 int status = 1;
79072805
LW
3361 extern int etext;
3362
396482e1 3363 sv_catpvs(prog, "/perl");
396482e1 3364 sv_catpvs(file, ".perldump");
79072805 3365
ee580363
GS
3366 unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
3367 /* unexec prints msg to stderr in case of failure */
6ad3d225 3368 PerlProc_exit(status);
79072805 3369#else
a5f75d66
AD
3370# ifdef VMS
3371# include <lib$routines.h>
3372 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
84d78eb7
YO
3373# elif defined(WIN32) || defined(__CYGWIN__)
3374 Perl_croak(aTHX_ "dump is not supported");
aa689395 3375# else
79072805 3376 ABORT(); /* for use with undump */
aa689395 3377# endif
a5f75d66 3378#endif
79072805
LW
3379}
3380
cb68f92d
GS
3381/* initialize curinterp */
3382STATIC void
cea2e8a9 3383S_init_interp(pTHX)
cb68f92d 3384{
97aff369 3385 dVAR;
acfe0abc
GS
3386#ifdef MULTIPLICITY
3387# define PERLVAR(var,type)
3388# define PERLVARA(var,n,type)
3389# if defined(PERL_IMPLICIT_CONTEXT)
b7f7fff6
NC
3390# define PERLVARI(var,type,init) aTHX->var = init;
3391# define PERLVARIC(var,type,init) aTHX->var = init;
3967c732 3392# else
acfe0abc
GS
3393# define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
3394# define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
066ef5b5 3395# endif
acfe0abc 3396# include "intrpvar.h"
acfe0abc
GS
3397# undef PERLVAR
3398# undef PERLVARA
3399# undef PERLVARI
3400# undef PERLVARIC
3401#else
3402# define PERLVAR(var,type)
3403# define PERLVARA(var,n,type)
3404# define PERLVARI(var,type,init) PL_##var = init;
3405# define PERLVARIC(var,type,init) PL_##var = init;
3406# include "intrpvar.h"
acfe0abc
GS
3407# undef PERLVAR
3408# undef PERLVARA
3409# undef PERLVARI
3410# undef PERLVARIC
cb68f92d
GS
3411#endif
3412
46ab3289
NC
3413 /* As these are inside a structure, PERLVARI isn't capable of initialising
3414 them */
6c3f0a89
NC
3415 PL_reg_oldcurpm = PL_reg_curpm = NULL;
3416 PL_reg_poscache = PL_reg_starttry = NULL;
cb68f92d
GS
3417}
3418
76e3520e 3419STATIC void
cea2e8a9 3420S_init_main_stash(pTHX)
79072805 3421{
97aff369 3422 dVAR;
463ee0b2 3423 GV *gv;
6e72f9df 3424
3280af22 3425 PL_curstash = PL_defstash = newHV();
23579a14
NC
3426 /* We know that the string "main" will be in the global shared string
3427 table, so it's a small saving to use it rather than allocate another
3428 8 bytes. */
18916d0d 3429 PL_curstname = newSVpvs_share("main");
fafc274c 3430 gv = gv_fetchpvs("main::", GV_ADD|GV_NOTQUAL, SVt_PVHV);
23579a14
NC
3431 /* If we hadn't caused another reference to "main" to be in the shared
3432 string table above, then it would be worth reordering these two,
3433 because otherwise all we do is delete "main" from it as a consequence
3434 of the SvREFCNT_dec, only to add it again with hv_name_set */
adbc6bb1 3435 SvREFCNT_dec(GvHV(gv));
23579a14 3436 hv_name_set(PL_defstash, "main", 4, 0);
85fbaab2 3437 GvHV(gv) = MUTABLE_HV(SvREFCNT_inc_simple(PL_defstash));
463ee0b2 3438 SvREADONLY_on(gv);
fafc274c
NC
3439 PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpvs("INC", GV_ADD|GV_NOTQUAL,
3440 SVt_PVAV)));
5a5094bd 3441 SvREFCNT_inc_simple_void(PL_incgv); /* Don't allow it to be freed */
3280af22 3442 GvMULTI_on(PL_incgv);
fafc274c 3443 PL_hintgv = gv_fetchpvs("\010", GV_ADD|GV_NOTQUAL, SVt_PV); /* ^H */
3280af22 3444 GvMULTI_on(PL_hintgv);
fafc274c 3445 PL_defgv = gv_fetchpvs("_", GV_ADD|GV_NOTQUAL, SVt_PVAV);
5a5094bd 3446 SvREFCNT_inc_simple_void(PL_defgv);
fafc274c 3447 PL_errgv = gv_HVadd(gv_fetchpvs("@", GV_ADD|GV_NOTQUAL, SVt_PV));
5a5094bd 3448 SvREFCNT_inc_simple_void(PL_errgv);
3280af22 3449 GvMULTI_on(PL_errgv);
fafc274c 3450 PL_replgv = gv_fetchpvs("\022", GV_ADD|GV_NOTQUAL, SVt_PV); /* ^R */
3280af22 3451 GvMULTI_on(PL_replgv);
cea2e8a9 3452 (void)Perl_form(aTHX_ "%240s",""); /* Preallocate temp - for immediate signals. */
c69033f2
NC
3453#ifdef PERL_DONT_CREATE_GVSV
3454 gv_SVadd(PL_errgv);
3455#endif
38a03e6e 3456 sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */
ab69dbc2 3457 CLEAR_ERRSV();
3280af22 3458 PL_curstash = PL_defstash;
11faa288 3459 CopSTASH_set(&PL_compiling, PL_defstash);
5c1737d1
NC
3460 PL_debstash = GvHV(gv_fetchpvs("DB::", GV_ADDMULTI, SVt_PVHV));
3461 PL_globalstash = GvHV(gv_fetchpvs("CORE::GLOBAL::", GV_ADDMULTI,
3462 SVt_PVHV));
4633a7c4 3463 /* We must init $/ before switches are processed. */
64ace3f8 3464 sv_setpvs(get_sv("/", GV_ADD), "\n");
79072805
LW
3465}
3466
fdf5d70d 3467STATIC int
2f352907 3468S_open_script(pTHX_ const char *scriptname, bool dosearch,
f20b2998 3469 bool *suidscript, PerlIO **rsfpp)