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