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