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