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