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