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