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