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