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