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