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