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