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