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