This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Change the hasargs return value from caller from IV to bool, as it's
[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;
829372d3 1680#ifdef DOSUID
e1ec3a88 1681 const char *validarg = "";
829372d3 1682#endif
312caa8e 1683 register SV *sv;
c7030b81 1684 register char c;
bd61b366 1685 const char *cddir = NULL;
ab019eaa 1686#ifdef USE_SITECUSTOMIZE
20ef40cf 1687 bool minus_f = FALSE;
ab019eaa 1688#endif
009d90df 1689 SV *linestr_sv = newSV_type(SVt_PVIV);
5486870f 1690 bool add_read_e_script = FALSE;
009d90df
DM
1691
1692 SvGROW(linestr_sv, 80);
1693 sv_setpvn(linestr_sv,"",0);
312caa8e 1694
396482e1 1695 sv = newSVpvs(""); /* first used for -I flags */
6224f72b
GS
1696 SAVEFREESV(sv);
1697 init_main_stash();
54310121 1698
c7030b81
NC
1699 {
1700 const char *s;
6224f72b
GS
1701 for (argc--,argv++; argc > 0; argc--,argv++) {
1702 if (argv[0][0] != '-' || !argv[0][1])
1703 break;
1704#ifdef DOSUID
1705 if (*validarg)
1706 validarg = " PHOOEY ";
1707 else
1708 validarg = argv[0];
ae3f3efd
PS
1709 /*
1710 * Can we rely on the kernel to start scripts with argv[1] set to
1711 * contain all #! line switches (the whole line)? (argv[0] is set to
1712 * the interpreter name, argv[2] to the script name; argv[3] and
1713 * above may contain other arguments.)
1714 */
13281fa4 1715#endif
6224f72b
GS
1716 s = argv[0]+1;
1717 reswitch:
47f56822 1718 switch ((c = *s)) {
729a02f2 1719 case 'C':
1d5472a9
GS
1720#ifndef PERL_STRICT_CR
1721 case '\r':
1722#endif
6224f72b
GS
1723 case ' ':
1724 case '0':
1725 case 'F':
1726 case 'a':
1727 case 'c':
1728 case 'd':
1729 case 'D':
1730 case 'h':
1731 case 'i':
1732 case 'l':
1733 case 'M':
1734 case 'm':
1735 case 'n':
1736 case 'p':
1737 case 's':
1738 case 'u':
1739 case 'U':
1740 case 'v':
599cee73
PM
1741 case 'W':
1742 case 'X':
6224f72b 1743 case 'w':
97bd5664 1744 if ((s = moreswitches(s)))
6224f72b
GS
1745 goto reswitch;
1746 break;
33b78306 1747
1dbad523 1748 case 't':
22f7c9c9 1749 CHECK_MALLOC_TOO_LATE_FOR('t');
317ea90d
MS
1750 if( !PL_tainting ) {
1751 PL_taint_warn = TRUE;
1752 PL_tainting = TRUE;
1753 }
1754 s++;
1755 goto reswitch;
6224f72b 1756 case 'T':
22f7c9c9 1757 CHECK_MALLOC_TOO_LATE_FOR('T');
3280af22 1758 PL_tainting = TRUE;
317ea90d 1759 PL_taint_warn = FALSE;
6224f72b
GS
1760 s++;
1761 goto reswitch;
f86702cc 1762
bc9b29db
RH
1763 case 'E':
1764 PL_minus_E = TRUE;
1765 /* FALL THROUGH */
6224f72b 1766 case 'e':
bf4acbe4
GS
1767#ifdef MACOS_TRADITIONAL
1768 /* ignore -e for Dev:Pseudo argument */
1769 if (argv[1] && !strcmp(argv[1], "Dev:Pseudo"))
e55ac0fa 1770 break;
bf4acbe4 1771#endif
f20b2998 1772 forbid_setid('e', FALSE);
3280af22 1773 if (!PL_e_script) {
396482e1 1774 PL_e_script = newSVpvs("");
5486870f 1775 add_read_e_script = TRUE;
6224f72b
GS
1776 }
1777 if (*++s)
3280af22 1778 sv_catpv(PL_e_script, s);
6224f72b 1779 else if (argv[1]) {
3280af22 1780 sv_catpv(PL_e_script, argv[1]);
6224f72b
GS
1781 argc--,argv++;
1782 }
1783 else
47f56822 1784 Perl_croak(aTHX_ "No code specified for -%c", c);
396482e1 1785 sv_catpvs(PL_e_script, "\n");
6224f72b 1786 break;
afe37c7d 1787
20ef40cf 1788 case 'f':
f5542d3a 1789#ifdef USE_SITECUSTOMIZE
20ef40cf 1790 minus_f = TRUE;
f5542d3a 1791#endif
20ef40cf
GA
1792 s++;
1793 goto reswitch;
1794
6224f72b 1795 case 'I': /* -I handled both here and in moreswitches() */
f20b2998 1796 forbid_setid('I', FALSE);
bd61b366 1797 if (!*++s && (s=argv[1]) != NULL) {
6224f72b
GS
1798 argc--,argv++;
1799 }
6224f72b 1800 if (s && *s) {
0df16ed7 1801 STRLEN len = strlen(s);
aec46f14 1802 const char * const p = savepvn(s, len);
88fe16b2 1803 incpush(p, TRUE, TRUE, FALSE, FALSE);
396482e1 1804 sv_catpvs(sv, "-I");
0df16ed7 1805 sv_catpvn(sv, p, len);
396482e1 1806 sv_catpvs(sv, " ");
6224f72b 1807 Safefree(p);
0df16ed7
GS
1808 }
1809 else
a67e862a 1810 Perl_croak(aTHX_ "No directory specified for -I");
6224f72b 1811 break;
6224f72b 1812 case 'S':
f20b2998 1813 forbid_setid('S', FALSE);
6224f72b
GS
1814 dosearch = TRUE;
1815 s++;
1816 goto reswitch;
1817 case 'V':
7edfd0ef
NC
1818 {
1819 SV *opts_prog;
1820
29a861e7 1821 Perl_av_create_and_push(aTHX_ &PL_preambleav, newSVpvs("use Config;"));
7edfd0ef 1822 if (*++s != ':') {
389d73ad
NC
1823 /* Can't do newSVpvs() as that would involve pre-processor
1824 condititionals inside a macro expansion. */
1825 opts_prog = Perl_newSVpv(aTHX_ "$_ = join ' ', sort qw("
6224f72b 1826# ifdef DEBUGGING
e2e4dbf1 1827 " DEBUGGING"
6224f72b 1828# endif
3bcf5ed8
SP
1829# ifdef NO_MATHOMS
1830 " NO_MATHOMS"
1831# endif
85e1fcb9 1832# ifdef PERL_DONT_CREATE_GVSV
e2e4dbf1 1833 " PERL_DONT_CREATE_GVSV"
85e1fcb9 1834# endif
85e1fcb9 1835# ifdef PERL_MALLOC_WRAP
e2e4dbf1 1836 " PERL_MALLOC_WRAP"
85e1fcb9 1837# endif
4724db38
NC
1838# ifdef PERL_MEM_LOG
1839 " PERL_MEM_LOG"
1840# endif
1841# ifdef PERL_MEM_LOG_ENV
1842 " PERL_MEM_LOG_ENV"
1843# endif
1844# ifdef PERL_MEM_LOG_ENV_FD
1845 " PERL_MEM_LOG_ENV_FD"
1846# endif
1847# ifdef PERL_MEM_LOG_STDERR
1848 " PERL_MEM_LOG_STDERR"
1849# endif
1850# ifdef PERL_MEM_LOG_TIMESTAMP
1851 " PERL_MEM_LOG_TIMESTAMP"
1852# endif
417cd4a8
SP
1853# ifdef PERL_USE_SAFE_PUTENV
1854 " PERL_USE_SAFE_PUTENV"
1855# endif
20ef40cf 1856# ifdef USE_SITECUSTOMIZE
e2e4dbf1 1857 " USE_SITECUSTOMIZE"
20ef40cf 1858# endif
389d73ad 1859 , 0);
efcaa95b 1860
b75885fd 1861 sv_catpv(opts_prog, PL_bincompat_options);
389d73ad
NC
1862 /* Terminate the qw(, and then wrap at 76 columns. */
1863 sv_catpvs(opts_prog, "); s/(?=.{53})(.{1,53}) /$1\\n /mg;print Config::myconfig(),");
1864#ifdef VMS
1865 sv_catpvs(opts_prog,"\"\\nCharacteristics of this PERLSHR image: \\n");
1866#else
1867 sv_catpvs(opts_prog,"\"\\nCharacteristics of this binary (from libperl): \\n");
1868#endif
efcaa95b 1869
389d73ad 1870 sv_catpvs(opts_prog," Compile-time options: $_\\n\",");
b363f7ed 1871
6224f72b 1872#if defined(LOCAL_PATCH_COUNT)
7edfd0ef
NC
1873 if (LOCAL_PATCH_COUNT > 0) {
1874 int i;
396482e1 1875 sv_catpvs(opts_prog,
7edfd0ef
NC
1876 "\" Locally applied patches:\\n\",");
1877 for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
1878 if (PL_localpatches[i])
1879 Perl_sv_catpvf(aTHX_ opts_prog,"q%c\t%s\n%c,",
1880 0, PL_localpatches[i], 0);
1881 }
6224f72b 1882 }
6224f72b 1883#endif
7edfd0ef 1884 Perl_sv_catpvf(aTHX_ opts_prog,
758ce194 1885 "\" Built under %s\\n",OSNAME);
6224f72b
GS
1886#ifdef __DATE__
1887# ifdef __TIME__
895aa832
NC
1888 sv_catpvs(opts_prog,
1889 " Compiled at " __DATE__ " " __TIME__ "\\n\"");
6224f72b 1890# else
895aa832 1891 sv_catpvs(opts_prog, " Compiled on " __DATE__ "\\n\"");
6224f72b
GS
1892# endif
1893#endif
396482e1 1894 sv_catpvs(opts_prog, "; $\"=\"\\n \"; "
7edfd0ef
NC
1895 "@env = map { \"$_=\\\"$ENV{$_}\\\"\" } "
1896 "sort grep {/^PERL/} keys %ENV; ");
69fcd688 1897#ifdef __CYGWIN__
396482e1 1898 sv_catpvs(opts_prog,
7edfd0ef 1899 "push @env, \"CYGWIN=\\\"$ENV{CYGWIN}\\\"\";");
69fcd688 1900#endif
396482e1 1901 sv_catpvs(opts_prog,
7edfd0ef
NC
1902 "print \" \\%ENV:\\n @env\\n\" if @env;"
1903 "print \" \\@INC:\\n @INC\\n\";");
1904 }
1905 else {
1906 ++s;
1907 opts_prog = Perl_newSVpvf(aTHX_
1908 "Config::config_vars(qw%c%s%c)",
1909 0, s, 0);
1910 s += strlen(s);
1911 }
1912 av_push(PL_preambleav, opts_prog);
1913 /* don't look for script or read stdin */
1914 scriptname = BIT_BUCKET;
1915 goto reswitch;
6224f72b 1916 }
6224f72b 1917 case 'x':
3280af22 1918 PL_doextract = TRUE;
6224f72b 1919 s++;
304334da 1920 if (*s)
f4c556ac 1921 cddir = s;
6224f72b
GS
1922 break;
1923 case 0:
1924 break;
1925 case '-':
1926 if (!*++s || isSPACE(*s)) {
1927 argc--,argv++;
1928 goto switch_end;
1929 }
1930 /* catch use of gnu style long options */
1931 if (strEQ(s, "version")) {
dd374669 1932 s = (char *)"v";
6224f72b
GS
1933 goto reswitch;
1934 }
1935 if (strEQ(s, "help")) {
dd374669 1936 s = (char *)"h";
6224f72b
GS
1937 goto reswitch;
1938 }
1939 s--;
1940 /* FALL THROUGH */
1941 default:
cea2e8a9 1942 Perl_croak(aTHX_ "Unrecognized switch: -%s (-h will show valid options)",s);
8d063cd8
LW
1943 }
1944 }
c7030b81
NC
1945 }
1946
6224f72b 1947 switch_end:
54310121 1948
c7030b81
NC
1949 {
1950 char *s;
1951
f675dbe5
CB
1952 if (
1953#ifndef SECURE_INTERNAL_GETENV
1954 !PL_tainting &&
1955#endif
cf756827 1956 (s = PerlEnv_getenv("PERL5OPT")))
0df16ed7 1957 {
e1ec3a88 1958 const char *popt = s;
74288ac8
GS
1959 while (isSPACE(*s))
1960 s++;
317ea90d 1961 if (*s == '-' && *(s+1) == 'T') {
22f7c9c9 1962 CHECK_MALLOC_TOO_LATE_FOR('T');
74288ac8 1963 PL_tainting = TRUE;
317ea90d
MS
1964 PL_taint_warn = FALSE;
1965 }
74288ac8 1966 else {
bd61b366 1967 char *popt_copy = NULL;
74288ac8 1968 while (s && *s) {
4ea8f8fb 1969 char *d;
74288ac8
GS
1970 while (isSPACE(*s))
1971 s++;
1972 if (*s == '-') {
1973 s++;
1974 if (isSPACE(*s))
1975 continue;
1976 }
4ea8f8fb 1977 d = s;
74288ac8
GS
1978 if (!*s)
1979 break;
f0d36289 1980 if (!strchr("CDIMUdmtw", *s))
cea2e8a9 1981 Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s);
4ea8f8fb
MS
1982 while (++s && *s) {
1983 if (isSPACE(*s)) {
cf756827
GS
1984 if (!popt_copy) {
1985 popt_copy = SvPVX(sv_2mortal(newSVpv(popt,0)));
1986 s = popt_copy + (s - popt);
1987 d = popt_copy + (d - popt);
1988 }
4ea8f8fb
MS
1989 *s++ = '\0';
1990 break;
1991 }
1992 }
1c4db469 1993 if (*d == 't') {
317ea90d
MS
1994 if( !PL_tainting ) {
1995 PL_taint_warn = TRUE;
1996 PL_tainting = TRUE;
1997 }
1c4db469 1998 } else {
97bd5664 1999 moreswitches(d);
1c4db469 2000 }
6224f72b 2001 }
6224f72b
GS
2002 }
2003 }
c7030b81 2004 }
a0d0e21e 2005
20ef40cf
GA
2006#ifdef USE_SITECUSTOMIZE
2007 if (!minus_f) {
29a861e7
NC
2008 (void)Perl_av_create_and_unshift_one(aTHX_ &PL_preambleav,
2009 Perl_newSVpvf(aTHX_ "BEGIN { do '%s/sitecustomize.pl' }", SITELIB_EXP));
20ef40cf
GA
2010 }
2011#endif
2012
6224f72b
GS
2013 if (!scriptname)
2014 scriptname = argv[0];
3280af22 2015 if (PL_e_script) {
6224f72b
GS
2016 argc++,argv--;
2017 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
2018 }
bd61b366 2019 else if (scriptname == NULL) {
6224f72b
GS
2020#ifdef MSDOS
2021 if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) )
97bd5664 2022 moreswitches("h");
6224f72b
GS
2023#endif
2024 scriptname = "-";
2025 }
2026
b7975bdd
NC
2027 /* Set $^X early so that it can be used for relocatable paths in @INC */
2028 assert (!PL_tainted);
2029 TAINT;
2030 S_set_caret_X(aTHX);
2031 TAINT_NOT;
6224f72b
GS
2032 init_perllib();
2033
a52eba0e 2034 {
f20b2998 2035 bool suidscript = FALSE;
829372d3
NC
2036
2037#ifdef DOSUID
2038 const int fdscript =
2039#endif
2040 open_script(scriptname, dosearch, &suidscript, &rsfp);
6224f72b 2041
2f9285f8
DM
2042 validate_suid(validarg, scriptname, fdscript, suidscript,
2043 linestr_sv, rsfp);
6224f72b 2044
64ca3a65 2045#ifndef PERL_MICRO
a52eba0e
NC
2046# if defined(SIGCHLD) || defined(SIGCLD)
2047 {
2048# ifndef SIGCHLD
2049# define SIGCHLD SIGCLD
2050# endif
2051 Sighandler_t sigstate = rsignal_state(SIGCHLD);
2052 if (sigstate == (Sighandler_t) SIG_IGN) {
2053 if (ckWARN(WARN_SIGNAL))
2054 Perl_warner(aTHX_ packWARN(WARN_SIGNAL),
2055 "Can't ignore signal CHLD, forcing to default");
2056 (void)rsignal(SIGCHLD, (Sighandler_t)SIG_DFL);
2057 }
0b5b802d 2058 }
a52eba0e 2059# endif
64ca3a65 2060#endif
0b5b802d 2061
a52eba0e 2062 if (PL_doextract
bf4acbe4 2063#ifdef MACOS_TRADITIONAL
a52eba0e 2064 || gMacPerl_AlwaysExtract
bf4acbe4 2065#endif
a52eba0e 2066 ) {
faef540c 2067
f20b2998 2068 /* This will croak if suidscript is true, as -x cannot be used with
faef540c
NC
2069 setuid scripts. */
2070 forbid_setid('x', suidscript);
f20b2998 2071 /* Hence you can't get here if suidscript is true */
faef540c 2072
2f9285f8 2073 find_beginning(linestr_sv, rsfp);
a52eba0e
NC
2074 if (cddir && PerlDir_chdir( (char *)cddir ) < 0)
2075 Perl_croak(aTHX_ "Can't chdir to %s",cddir);
2076 }
f4c556ac 2077 }
6224f72b 2078
b9f83d2f 2079 PL_main_cv = PL_compcv = (CV*)newSV_type(SVt_PVCV);
3280af22
NIS
2080 CvUNIQUE_on(PL_compcv);
2081
dd2155a4 2082 CvPADLIST(PL_compcv) = pad_new(0);
6224f72b 2083
dd69841b
BB
2084 PL_isarev = newHV();
2085
0c4f7ff0 2086 boot_core_PerlIO();
6224f72b 2087 boot_core_UNIVERSAL();
09bef843 2088 boot_core_xsutils();
e1a479c5 2089 boot_core_mro();
6224f72b
GS
2090
2091 if (xsinit)
acfe0abc 2092 (*xsinit)(aTHX); /* in case linked C routines want magical variables */
64ca3a65 2093#ifndef PERL_MICRO
d0d72822 2094#if defined(VMS) || defined(WIN32) || defined(DJGPP) || defined(__CYGWIN__) || defined(EPOC) || defined(SYMBIAN)
c5be433b 2095 init_os_extras();
6224f72b 2096#endif
64ca3a65 2097#endif
6224f72b 2098
29209bc5 2099#ifdef USE_SOCKS
1b9c9cf5
DH
2100# ifdef HAS_SOCKS5_INIT
2101 socks5_init(argv[0]);
2102# else
29209bc5 2103 SOCKSinit(argv[0]);
1b9c9cf5 2104# endif
ac27b0f5 2105#endif
29209bc5 2106
6224f72b
GS
2107 init_predump_symbols();
2108 /* init_postdump_symbols not currently designed to be called */
2109 /* more than once (ENV isn't cleared first, for example) */
2110 /* But running with -u leaves %ENV & @ARGV undefined! XXX */
3280af22 2111 if (!PL_do_undump)
6224f72b
GS
2112 init_postdump_symbols(argc,argv,env);
2113
27da23d5
JH
2114 /* PL_unicode is turned on by -C, or by $ENV{PERL_UNICODE},
2115 * or explicitly in some platforms.
085a54d9 2116 * locale.c:Perl_init_i18nl10n() if the environment
a05d7ebb 2117 * look like the user wants to use UTF-8. */
a0fd4948 2118#if defined(__SYMBIAN32__)
27da23d5
JH
2119 PL_unicode = PERL_UNICODE_STD_FLAG; /* See PERL_SYMBIAN_CONSOLE_UTF8. */
2120#endif
06e66572
JH
2121 if (PL_unicode) {
2122 /* Requires init_predump_symbols(). */
a05d7ebb 2123 if (!(PL_unicode & PERL_UNICODE_LOCALE_FLAG) || PL_utf8locale) {
06e66572
JH
2124 IO* io;
2125 PerlIO* fp;
2126 SV* sv;
2127
a05d7ebb 2128 /* Turn on UTF-8-ness on STDIN, STDOUT, STDERR
06e66572 2129 * and the default open disciplines. */
a05d7ebb
JH
2130 if ((PL_unicode & PERL_UNICODE_STDIN_FLAG) &&
2131 PL_stdingv && (io = GvIO(PL_stdingv)) &&
2132 (fp = IoIFP(io)))
2133 PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
2134 if ((PL_unicode & PERL_UNICODE_STDOUT_FLAG) &&
2135 PL_defoutgv && (io = GvIO(PL_defoutgv)) &&
2136 (fp = IoOFP(io)))
2137 PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
2138 if ((PL_unicode & PERL_UNICODE_STDERR_FLAG) &&
2139 PL_stderrgv && (io = GvIO(PL_stderrgv)) &&
2140 (fp = IoOFP(io)))
2141 PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
2142 if ((PL_unicode & PERL_UNICODE_INOUT_FLAG) &&
fafc274c
NC
2143 (sv = GvSV(gv_fetchpvs("\017PEN", GV_ADD|GV_NOTQUAL,
2144 SVt_PV)))) {
a05d7ebb
JH
2145 U32 in = PL_unicode & PERL_UNICODE_IN_FLAG;
2146 U32 out = PL_unicode & PERL_UNICODE_OUT_FLAG;
2147 if (in) {
2148 if (out)
2149 sv_setpvn(sv, ":utf8\0:utf8", 11);
2150 else
2151 sv_setpvn(sv, ":utf8\0", 6);
2152 }
2153 else if (out)
2154 sv_setpvn(sv, "\0:utf8", 6);
2155 SvSETMAGIC(sv);
2156 }
b310b053
JH
2157 }
2158 }
2159
c7030b81
NC
2160 {
2161 const char *s;
4ffa73a3
JH
2162 if ((s = PerlEnv_getenv("PERL_SIGNALS"))) {
2163 if (strEQ(s, "unsafe"))
2164 PL_signals |= PERL_SIGNALS_UNSAFE_FLAG;
2165 else if (strEQ(s, "safe"))
2166 PL_signals &= ~PERL_SIGNALS_UNSAFE_FLAG;
2167 else
2168 Perl_croak(aTHX_ "PERL_SIGNALS illegal: \"%s\"", s);
2169 }
c7030b81 2170 }
4ffa73a3 2171
81d86705 2172#ifdef PERL_MAD
c7030b81
NC
2173 {
2174 const char *s;
81d86705
NC
2175 if ((s = PerlEnv_getenv("PERL_XMLDUMP"))) {
2176 PL_madskills = 1;
2177 PL_minus_c = 1;
2178 if (!s || !s[0])
2179 PL_xmlfp = PerlIO_stdout();
2180 else {
2181 PL_xmlfp = PerlIO_open(s, "w");
2182 if (!PL_xmlfp)
2183 Perl_croak(aTHX_ "Can't open %s", s);
2184 }
1a9a51d4 2185 my_setenv("PERL_XMLDUMP", NULL); /* hide from subprocs */
81d86705 2186 }
c7030b81
NC
2187 }
2188
2189 {
2190 const char *s;
81d86705
NC
2191 if ((s = PerlEnv_getenv("PERL_MADSKILLS"))) {
2192 PL_madskills = atoi(s);
1a9a51d4 2193 my_setenv("PERL_MADSKILLS", NULL); /* hide from subprocs */
81d86705 2194 }
c7030b81 2195 }
81d86705
NC
2196#endif
2197
5486870f 2198 lex_start(linestr_sv, rsfp, TRUE);
219f7226 2199 PL_subname = newSVpvs("main");
6224f72b 2200
5486870f
DM
2201 if (add_read_e_script)
2202 filter_add(read_e_script, NULL);
2203
6224f72b
GS
2204 /* now parse the script */
2205
93189314 2206 SETERRNO(0,SS_NORMAL);
bf4acbe4 2207#ifdef MACOS_TRADITIONAL
13765c85 2208 if (gMacPerl_SyntaxError = (yyparse() || PL_parser->error_count)) {
bf4acbe4
GS
2209 if (PL_minus_c)
2210 Perl_croak(aTHX_ "%s had compilation errors.\n", MacPerl_MPWFileName(PL_origfilename));
2211 else {
2212 Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
2213 MacPerl_MPWFileName(PL_origfilename));
2214 }
2215 }
2216#else
13765c85 2217 if (yyparse() || PL_parser->error_count) {
3280af22 2218 if (PL_minus_c)
cea2e8a9 2219 Perl_croak(aTHX_ "%s had compilation errors.\n", PL_origfilename);
6224f72b 2220 else {
cea2e8a9 2221 Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
097ee67d 2222 PL_origfilename);
6224f72b
GS
2223 }
2224 }
bf4acbe4 2225#endif
57843af0 2226 CopLINE_set(PL_curcop, 0);
3280af22 2227 PL_curstash = PL_defstash;
3280af22
NIS
2228 if (PL_e_script) {
2229 SvREFCNT_dec(PL_e_script);
a0714e2c 2230 PL_e_script = NULL;
6224f72b
GS
2231 }
2232
3280af22 2233 if (PL_do_undump)
6224f72b
GS
2234 my_unexec();
2235
57843af0
GS
2236 if (isWARN_ONCE) {
2237 SAVECOPFILE(PL_curcop);
2238 SAVECOPLINE(PL_curcop);
3280af22 2239 gv_check(PL_defstash);
57843af0 2240 }
6224f72b
GS
2241
2242 LEAVE;
2243 FREETMPS;
2244
2245#ifdef MYMALLOC
f6a607bc
RGS
2246 {
2247 const char *s;
6224f72b
GS
2248 if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
2249 dump_mstats("after compilation:");
f6a607bc 2250 }
6224f72b
GS
2251#endif
2252
2253 ENTER;
3280af22 2254 PL_restartop = 0;
312caa8e 2255 return NULL;
6224f72b
GS
2256}
2257
954c1994
GS
2258/*
2259=for apidoc perl_run
2260
2261Tells a Perl interpreter to run. See L<perlembed>.
2262
2263=cut
2264*/
2265
6224f72b 2266int
0cb96387 2267perl_run(pTHXx)
6224f72b 2268{
97aff369 2269 dVAR;
6224f72b 2270 I32 oldscope;
14dd3ad8 2271 int ret = 0;
db36c5a1 2272 dJMPENV;
6224f72b 2273
ed6c66dd 2274 PERL_UNUSED_ARG(my_perl);
9d4ba2ae 2275
3280af22 2276 oldscope = PL_scopestack_ix;
96e176bf
CL
2277#ifdef VMS
2278 VMSISH_HUSHED = 0;
2279#endif
6224f72b 2280
14dd3ad8 2281 JMPENV_PUSH(ret);
6224f72b
GS
2282 switch (ret) {
2283 case 1:
2284 cxstack_ix = -1; /* start context stack again */
312caa8e 2285 goto redo_body;
14dd3ad8 2286 case 0: /* normal completion */
14dd3ad8
GS
2287 redo_body:
2288 run_body(oldscope);
14dd3ad8
GS
2289 /* FALL THROUGH */
2290 case 2: /* my_exit() */
3280af22 2291 while (PL_scopestack_ix > oldscope)
6224f72b
GS
2292 LEAVE;
2293 FREETMPS;
3280af22 2294 PL_curstash = PL_defstash;
3a1ee7e8 2295 if (!(PL_exit_flags & PERL_EXIT_DESTRUCT_END) &&
31d77e54
AB
2296 PL_endav && !PL_minus_c)
2297 call_list(oldscope, PL_endav);
6224f72b
GS
2298#ifdef MYMALLOC
2299 if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
2300 dump_mstats("after execution: ");
2301#endif
37038d91 2302 ret = STATUS_EXIT;
14dd3ad8 2303 break;
6224f72b 2304 case 3:
312caa8e
CS
2305 if (PL_restartop) {
2306 POPSTACK_TO(PL_mainstack);
2307 goto redo_body;
6224f72b 2308 }
bf49b057 2309 PerlIO_printf(Perl_error_log, "panic: restartop\n");
312caa8e 2310 FREETMPS;
14dd3ad8
GS
2311 ret = 1;
2312 break;
6224f72b
GS
2313 }
2314
14dd3ad8
GS
2315 JMPENV_POP;
2316 return ret;
312caa8e
CS
2317}
2318
dd374669 2319STATIC void
14dd3ad8
GS
2320S_run_body(pTHX_ I32 oldscope)
2321{
97aff369 2322 dVAR;
6224f72b 2323 DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
3280af22 2324 PL_sawampersand ? "Enabling" : "Omitting"));
6224f72b 2325
3280af22 2326 if (!PL_restartop) {
81d86705
NC
2327#ifdef PERL_MAD
2328 if (PL_xmlfp) {
2329 xmldump_all();
2330 exit(0); /* less likely to core dump than my_exit(0) */
2331 }
2332#endif
6224f72b 2333 DEBUG_x(dump_all());
cf2782cd 2334#ifdef DEBUGGING
ecae49c0
NC
2335 if (!DEBUG_q_TEST)
2336 PERL_DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
cf2782cd 2337#endif
b900a521
JH
2338 DEBUG_S(PerlIO_printf(Perl_debug_log, "main thread is 0x%"UVxf"\n",
2339 PTR2UV(thr)));
6224f72b 2340
3280af22 2341 if (PL_minus_c) {
bf4acbe4 2342#ifdef MACOS_TRADITIONAL
e69a2255
JH
2343 PerlIO_printf(Perl_error_log, "%s%s syntax OK\n",
2344 (gMacPerl_ErrorFormat ? "# " : ""),
2345 MacPerl_MPWFileName(PL_origfilename));
bf4acbe4 2346#else
bf49b057 2347 PerlIO_printf(Perl_error_log, "%s syntax OK\n", PL_origfilename);
bf4acbe4 2348#endif
6224f72b
GS
2349 my_exit(0);
2350 }
3280af22 2351 if (PERLDB_SINGLE && PL_DBsingle)
ac27b0f5 2352 sv_setiv(PL_DBsingle, 1);
3280af22
NIS
2353 if (PL_initav)
2354 call_list(oldscope, PL_initav);
f1fac472
NC
2355#ifdef PERL_DEBUG_READONLY_OPS
2356 Perl_pending_Slabs_to_ro(aTHX);
2357#endif
6224f72b
GS
2358 }
2359
2360 /* do it */
2361
3280af22 2362 if (PL_restartop) {
533c011a 2363 PL_op = PL_restartop;
3280af22 2364 PL_restartop = 0;
cea2e8a9 2365 CALLRUNOPS(aTHX);
6224f72b 2366 }
3280af22
NIS
2367 else if (PL_main_start) {
2368 CvDEPTH(PL_main_cv) = 1;
533c011a 2369 PL_op = PL_main_start;
cea2e8a9 2370 CALLRUNOPS(aTHX);
6224f72b 2371 }
f6b3007c
JH
2372 my_exit(0);
2373 /* NOTREACHED */
6224f72b
GS
2374}
2375
954c1994 2376/*
ccfc67b7
JH
2377=head1 SV Manipulation Functions
2378
954c1994
GS
2379=for apidoc p||get_sv
2380
2381Returns the SV of the specified Perl scalar. If C<create> is set and the
2382Perl variable does not exist then it will be created. If C<create> is not
2383set and the variable does not exist then NULL is returned.
2384
2385=cut
2386*/
2387
6224f72b 2388SV*
864dbfa3 2389Perl_get_sv(pTHX_ const char *name, I32 create)
6224f72b
GS
2390{
2391 GV *gv;
6224f72b
GS
2392 gv = gv_fetchpv(name, create, SVt_PV);
2393 if (gv)
2394 return GvSV(gv);
a0714e2c 2395 return NULL;
6224f72b
GS
2396}
2397
954c1994 2398/*
ccfc67b7
JH
2399=head1 Array Manipulation Functions
2400
954c1994
GS
2401=for apidoc p||get_av
2402
2403Returns the AV of the specified Perl array. If C<create> is set and the
2404Perl variable does not exist then it will be created. If C<create> is not
2405set and the variable does not exist then NULL is returned.
2406
2407=cut
2408*/
2409
6224f72b 2410AV*
864dbfa3 2411Perl_get_av(pTHX_ const char *name, I32 create)
6224f72b 2412{
c4420975 2413 GV* const gv = gv_fetchpv(name, create, SVt_PVAV);
6224f72b
GS
2414 if (create)
2415 return GvAVn(gv);
2416 if (gv)
2417 return GvAV(gv);
7d49f689 2418 return NULL;
6224f72b
GS
2419}
2420
954c1994 2421/*
ccfc67b7
JH
2422=head1 Hash Manipulation Functions
2423
954c1994
GS
2424=for apidoc p||get_hv
2425
2426Returns the HV of the specified Perl hash. If C<create> is set and the
2427Perl variable does not exist then it will be created. If C<create> is not
2428set and the variable does not exist then NULL is returned.
2429
2430=cut
2431*/
2432
6224f72b 2433HV*
864dbfa3 2434Perl_get_hv(pTHX_ const char *name, I32 create)
6224f72b 2435{
890ce7af 2436 GV* const gv = gv_fetchpv(name, create, SVt_PVHV);
a0d0e21e
LW
2437 if (create)
2438 return GvHVn(gv);
2439 if (gv)
2440 return GvHV(gv);
5c284bb0 2441 return NULL;
a0d0e21e
LW
2442}
2443
954c1994 2444/*
ccfc67b7
JH
2445=head1 CV Manipulation Functions
2446
780a5241
NC
2447=for apidoc p||get_cvn_flags
2448
2449Returns the CV of the specified Perl subroutine. C<flags> are passed to
2450C<gv_fetchpvn_flags>. If C<GV_ADD> is set and the Perl subroutine does not
2451exist then it will be declared (which has the same effect as saying
2452C<sub name;>). If C<GV_ADD> is not set and the subroutine does not exist
2453then NULL is returned.
2454
954c1994
GS
2455=for apidoc p||get_cv
2456
780a5241 2457Uses C<strlen> to get the length of C<name>, then calls C<get_cvn_flags>.
954c1994
GS
2458
2459=cut
2460*/
2461
a0d0e21e 2462CV*
780a5241 2463Perl_get_cvn_flags(pTHX_ const char *name, STRLEN len, I32 flags)
a0d0e21e 2464{
780a5241 2465 GV* const gv = gv_fetchpvn_flags(name, len, flags, SVt_PVCV);
f6ec51f7
GS
2466 /* XXX this is probably not what they think they're getting.
2467 * It has the same effect as "sub name;", i.e. just a forward
2468 * declaration! */
780a5241 2469 if ((flags & ~GV_NOADD_MASK) && !GvCVu(gv)) {
740cce10 2470 SV *const sv = newSVpvn_flags(name, len, flags & SVf_UTF8);
774d564b 2471 return newSUB(start_subparse(FALSE, 0),
780a5241 2472 newSVOP(OP_CONST, 0, sv),
5f66b61c 2473 NULL, NULL);
780a5241 2474 }
a0d0e21e 2475 if (gv)
8ebc5c01 2476 return GvCVu(gv);
601f1833 2477 return NULL;
a0d0e21e
LW
2478}
2479
780a5241
NC
2480CV*
2481Perl_get_cv(pTHX_ const char *name, I32 flags)
2482{
2483 return get_cvn_flags(name, strlen(name), flags);
2484}
2485
79072805
LW
2486/* Be sure to refetch the stack pointer after calling these routines. */
2487
954c1994 2488/*
ccfc67b7
JH
2489
2490=head1 Callback Functions
2491
954c1994
GS
2492=for apidoc p||call_argv
2493
2494Performs a callback to the specified Perl sub. See L<perlcall>.
2495
2496=cut
2497*/
2498
a0d0e21e 2499I32
8f42b153 2500Perl_call_argv(pTHX_ const char *sub_name, I32 flags, register char **argv)
ac27b0f5 2501
8ac85365
NIS
2502 /* See G_* flags in cop.h */
2503 /* null terminated arg list */
8990e307 2504{
97aff369 2505 dVAR;
a0d0e21e 2506 dSP;
8990e307 2507
924508f0 2508 PUSHMARK(SP);
a0d0e21e 2509 if (argv) {
8990e307 2510 while (*argv) {
6e449a3a 2511 mXPUSHs(newSVpv(*argv,0));
8990e307
LW
2512 argv++;
2513 }
a0d0e21e 2514 PUTBACK;
8990e307 2515 }
864dbfa3 2516 return call_pv(sub_name, flags);
8990e307
LW
2517}
2518
954c1994
GS
2519/*
2520=for apidoc p||call_pv
2521
2522Performs a callback to the specified Perl sub. See L<perlcall>.
2523
2524=cut
2525*/
2526
a0d0e21e 2527I32
864dbfa3 2528Perl_call_pv(pTHX_ const char *sub_name, I32 flags)
8ac85365
NIS
2529 /* name of the subroutine */
2530 /* See G_* flags in cop.h */
a0d0e21e 2531{
864dbfa3 2532 return call_sv((SV*)get_cv(sub_name, TRUE), flags);
a0d0e21e
LW
2533}
2534
954c1994
GS
2535/*
2536=for apidoc p||call_method
2537
2538Performs a callback to the specified Perl method. The blessed object must
2539be on the stack. See L<perlcall>.
2540
2541=cut
2542*/
2543
a0d0e21e 2544I32
864dbfa3 2545Perl_call_method(pTHX_ const char *methname, I32 flags)
8ac85365
NIS
2546 /* name of the subroutine */
2547 /* See G_* flags in cop.h */
a0d0e21e 2548{
968b3946 2549 return call_sv(sv_2mortal(newSVpv(methname,0)), flags | G_METHOD);
a0d0e21e
LW
2550}
2551
2552/* May be called with any of a CV, a GV, or an SV containing the name. */
954c1994
GS
2553/*
2554=for apidoc p||call_sv
2555
2556Performs a callback to the Perl sub whose name is in the SV. See
2557L<perlcall>.
2558
2559=cut
2560*/
2561
a0d0e21e 2562I32
864dbfa3 2563Perl_call_sv(pTHX_ SV *sv, I32 flags)
8ac85365 2564 /* See G_* flags in cop.h */
a0d0e21e 2565{
27da23d5 2566 dVAR; dSP;
a0d0e21e 2567 LOGOP myop; /* fake syntax tree node */
968b3946 2568 UNOP method_op;
aa689395 2569 I32 oldmark;
8ea43dc8 2570 VOL I32 retval = 0;
a0d0e21e 2571 I32 oldscope;
54310121 2572 bool oldcatch = CATCH_GET;
6224f72b 2573 int ret;
c4420975 2574 OP* const oldop = PL_op;
db36c5a1 2575 dJMPENV;
1e422769 2576
a0d0e21e
LW
2577 if (flags & G_DISCARD) {
2578 ENTER;
2579 SAVETMPS;
2580 }
2581
aa689395 2582 Zero(&myop, 1, LOGOP);
5f66b61c 2583 myop.op_next = NULL;
f51d4af5 2584 if (!(flags & G_NOARGS))
aa689395 2585 myop.op_flags |= OPf_STACKED;
54310121
PP
2586 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
2587 (flags & G_ARRAY) ? OPf_WANT_LIST :
2588 OPf_WANT_SCALAR);
462e5cf6 2589 SAVEOP();
533c011a 2590 PL_op = (OP*)&myop;
aa689395 2591
3280af22
NIS
2592 EXTEND(PL_stack_sp, 1);
2593 *++PL_stack_sp = sv;
aa689395 2594 oldmark = TOPMARK;
3280af22 2595 oldscope = PL_scopestack_ix;
a0d0e21e 2596
3280af22 2597 if (PERLDB_SUB && PL_curstash != PL_debstash
36477c24 2598 /* Handle first BEGIN of -d. */
3280af22 2599 && (PL_DBcv || (PL_DBcv = GvCV(PL_DBsub)))
36477c24
PP
2600 /* Try harder, since this may have been a sighandler, thus
2601 * curstash may be meaningless. */
3280af22 2602 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != PL_debstash)
491527d0 2603 && !(flags & G_NODEBUG))
533c011a 2604 PL_op->op_private |= OPpENTERSUB_DB;
a0d0e21e 2605
968b3946
GS
2606 if (flags & G_METHOD) {
2607 Zero(&method_op, 1, UNOP);
2608 method_op.op_next = PL_op;
2609 method_op.op_ppaddr = PL_ppaddr[OP_METHOD];
2610 myop.op_ppaddr = PL_ppaddr[OP_ENTERSUB];
f39d0b86 2611 PL_op = (OP*)&method_op;
968b3946
GS
2612 }
2613
312caa8e 2614 if (!(flags & G_EVAL)) {
0cdb2077 2615 CATCH_SET(TRUE);
d6f07c05 2616 CALL_BODY_SUB((OP*)&myop);
312caa8e 2617 retval = PL_stack_sp - (PL_stack_base + oldmark);
0253cb41 2618 CATCH_SET(oldcatch);
312caa8e
CS
2619 }
2620 else {
d78bda3d 2621 myop.op_other = (OP*)&myop;
3280af22 2622 PL_markstack_ptr--;
edb2152a 2623 create_eval_scope(flags|G_FAKINGEVAL);
3280af22 2624 PL_markstack_ptr++;
a0d0e21e 2625
14dd3ad8 2626 JMPENV_PUSH(ret);
edb2152a 2627
6224f72b
GS
2628 switch (ret) {
2629 case 0:
14dd3ad8 2630 redo_body:
d6f07c05 2631 CALL_BODY_SUB((OP*)&myop);
312caa8e
CS
2632 retval = PL_stack_sp - (PL_stack_base + oldmark);
2633 if (!(flags & G_KEEPERR))
c69006e4 2634 sv_setpvn(ERRSV,"",0);
a0d0e21e 2635 break;
6224f72b 2636 case 1:
f86702cc 2637 STATUS_ALL_FAILURE;
a0d0e21e 2638 /* FALL THROUGH */
6224f72b 2639 case 2:
a0d0e21e 2640 /* my_exit() was called */
3280af22 2641 PL_curstash = PL_defstash;
a0d0e21e 2642 FREETMPS;
14dd3ad8 2643 JMPENV_POP;
cc3604b1 2644 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
cea2e8a9 2645 Perl_croak(aTHX_ "Callback called exit");
f86702cc 2646 my_exit_jump();
a0d0e21e 2647 /* NOTREACHED */
6224f72b 2648 case 3:
3280af22 2649 if (PL_restartop) {
533c011a 2650 PL_op = PL_restartop;
3280af22 2651 PL_restartop = 0;
312caa8e 2652 goto redo_body;
a0d0e21e 2653 }
3280af22 2654 PL_stack_sp = PL_stack_base + oldmark;
a0d0e21e
LW
2655 if (flags & G_ARRAY)
2656 retval = 0;
2657 else {
2658 retval = 1;
3280af22 2659 *++PL_stack_sp = &PL_sv_undef;
a0d0e21e 2660 }
312caa8e 2661 break;
a0d0e21e 2662 }
a0d0e21e 2663
edb2152a
NC
2664 if (PL_scopestack_ix > oldscope)
2665 delete_eval_scope();
14dd3ad8 2666 JMPENV_POP;
a0d0e21e 2667 }
1e422769 2668
a0d0e21e 2669 if (flags & G_DISCARD) {
3280af22 2670 PL_stack_sp = PL_stack_base + oldmark;
a0d0e21e
LW
2671 retval = 0;
2672 FREETMPS;
2673 LEAVE;
2674 }
533c011a 2675 PL_op = oldop;
a0d0e21e
LW
2676 return retval;
2677}
2678
6e72f9df 2679/* Eval a string. The G_EVAL flag is always assumed. */
8990e307 2680
954c1994
GS
2681/*
2682=for apidoc p||eval_sv
2683
2684Tells Perl to C<eval> the string in the SV.
2685
2686=cut
2687*/
2688
a0d0e21e 2689I32
864dbfa3 2690Perl_eval_sv(pTHX_ SV *sv, I32 flags)
ac27b0f5 2691
8ac85365 2692 /* See G_* flags in cop.h */
a0d0e21e 2693{
97aff369 2694 dVAR;
924508f0 2695 dSP;
a0d0e21e 2696 UNOP myop; /* fake syntax tree node */
8ea43dc8
SP
2697 VOL I32 oldmark = SP - PL_stack_base;
2698 VOL I32 retval = 0;
6224f72b 2699 int ret;
c4420975 2700 OP* const oldop = PL_op;
db36c5a1 2701 dJMPENV;
84902520 2702
4633a7c4
LW
2703 if (flags & G_DISCARD) {
2704 ENTER;
2705 SAVETMPS;
2706 }
2707
462e5cf6 2708 SAVEOP();
533c011a
NIS
2709 PL_op = (OP*)&myop;
2710 Zero(PL_op, 1, UNOP);
3280af22
NIS
2711 EXTEND(PL_stack_sp, 1);
2712 *++PL_stack_sp = sv;
79072805 2713
4633a7c4
LW
2714 if (!(flags & G_NOARGS))
2715 myop.op_flags = OPf_STACKED;
5f66b61c 2716 myop.op_next = NULL;
6e72f9df 2717 myop.op_type = OP_ENTEREVAL;
54310121
PP
2718 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
2719 (flags & G_ARRAY) ? OPf_WANT_LIST :
2720 OPf_WANT_SCALAR);
6e72f9df
PP
2721 if (flags & G_KEEPERR)
2722 myop.op_flags |= OPf_SPECIAL;
4633a7c4 2723
dedbcade
DM
2724 /* fail now; otherwise we could fail after the JMPENV_PUSH but
2725 * before a PUSHEVAL, which corrupts the stack after a croak */
2726 TAINT_PROPER("eval_sv()");
2727
14dd3ad8 2728 JMPENV_PUSH(ret);
6224f72b
GS
2729 switch (ret) {
2730 case 0:
14dd3ad8 2731 redo_body:
d6f07c05 2732 CALL_BODY_EVAL((OP*)&myop);
312caa8e
CS
2733 retval = PL_stack_sp - (PL_stack_base + oldmark);
2734 if (!(flags & G_KEEPERR))
c69006e4 2735 sv_setpvn(ERRSV,"",0);
4633a7c4 2736 break;
6224f72b 2737 case 1:
f86702cc 2738 STATUS_ALL_FAILURE;
4633a7c4 2739 /* FALL THROUGH */
6224f72b 2740 case 2:
4633a7c4 2741 /* my_exit() was called */
3280af22 2742 PL_curstash = PL_defstash;
4633a7c4 2743 FREETMPS;
14dd3ad8 2744 JMPENV_POP;
cc3604b1 2745 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
cea2e8a9 2746 Perl_croak(aTHX_ "Callback called exit");
f86702cc 2747 my_exit_jump();
4633a7c4 2748 /* NOTREACHED */
6224f72b 2749 case 3:
3280af22 2750 if (PL_restartop) {
533c011a 2751 PL_op = PL_restartop;
3280af22 2752 PL_restartop = 0;
312caa8e 2753 goto redo_body;
4633a7c4 2754 }
3280af22 2755 PL_stack_sp = PL_stack_base + oldmark;
4633a7c4
LW
2756 if (flags & G_ARRAY)
2757 retval = 0;
2758 else {
2759 retval = 1;
3280af22 2760 *++PL_stack_sp = &PL_sv_undef;
4633a7c4 2761 }
312caa8e 2762 break;
4633a7c4
LW
2763 }
2764
14dd3ad8 2765 JMPENV_POP;
4633a7c4 2766 if (flags & G_DISCARD) {
3280af22 2767 PL_stack_sp = PL_stack_base + oldmark;
4633a7c4
LW
2768 retval = 0;
2769 FREETMPS;
2770 LEAVE;
2771 }
533c011a 2772 PL_op = oldop;
4633a7c4
LW
2773 return retval;
2774}
2775
954c1994
GS
2776/*
2777=for apidoc p||eval_pv
2778
2779Tells Perl to C<eval> the given string and return an SV* result.
2780
2781=cut
2782*/
2783
137443ea 2784SV*
864dbfa3 2785Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error)
137443ea 2786{
97aff369 2787 dVAR;
137443ea
PP
2788 dSP;
2789 SV* sv = newSVpv(p, 0);
2790
864dbfa3 2791 eval_sv(sv, G_SCALAR);
137443ea
PP
2792 SvREFCNT_dec(sv);
2793
2794 SPAGAIN;
2795 sv = POPs;
2796 PUTBACK;
2797
2d8e6c8d 2798 if (croak_on_error && SvTRUE(ERRSV)) {
0510663f 2799 Perl_croak(aTHX_ SvPVx_nolen_const(ERRSV));
2d8e6c8d 2800 }
137443ea
PP
2801
2802 return sv;
2803}
2804
4633a7c4
LW
2805/* Require a module. */
2806
954c1994 2807/*
ccfc67b7
JH
2808=head1 Embedding Functions
2809
954c1994
GS
2810=for apidoc p||require_pv
2811
7d3fb230
BS
2812Tells Perl to C<require> the file named by the string argument. It is
2813analogous to the Perl code C<eval "require '$file'">. It's even
2307c6d0 2814implemented that way; consider using load_module instead.
954c1994 2815
7d3fb230 2816=cut */
954c1994 2817
4633a7c4 2818void
864dbfa3 2819Perl_require_pv(pTHX_ const char *pv)
4633a7c4 2820{
97aff369 2821 dVAR;
d3acc0f7 2822 dSP;
97aff369 2823 SV* sv;
e788e7d3 2824 PUSHSTACKi(PERLSI_REQUIRE);
d3acc0f7 2825 PUTBACK;
be41e5d9
NC
2826 sv = Perl_newSVpvf(aTHX_ "require q%c%s%c", 0, pv, 0);
2827 eval_sv(sv_2mortal(sv), G_DISCARD);
d3acc0f7
JP
2828 SPAGAIN;
2829 POPSTACK;
79072805
LW
2830}
2831
79072805 2832void
e1ec3a88 2833Perl_magicname(pTHX_ const char *sym, const char *name, I32 namlen)
79072805 2834{
71315bf2 2835 register GV * const gv = gv_fetchpv(sym, GV_ADD, SVt_PV);
79072805 2836
c4420975 2837 if (gv)
14befaf4 2838 sv_magic(GvSV(gv), (SV*)gv, PERL_MAGIC_sv, name, namlen);
79072805
LW
2839}
2840
76e3520e 2841STATIC void
e1ec3a88 2842S_usage(pTHX_ const char *name) /* XXX move this out into a module ? */
4633a7c4 2843{
ab821d7f 2844 /* This message really ought to be max 23 lines.
75c72d73 2845 * Removed -h because the user already knows that option. Others? */
fb73857a 2846
27da23d5 2847 static const char * const usage_msg[] = {
aefc56c5 2848"-0[octal] specify record separator (\\0, if no argument)",
aefc56c5
SF
2849"-a autosplit mode with -n or -p (splits $_ into @F)",
2850"-C[number/list] enables the listed Unicode features",
2851"-c check syntax only (runs BEGIN and CHECK blocks)",
2852"-d[:debugger] run program under debugger",
2853"-D[number/list] set debugging flags (argument is a bit mask or alphabets)",
2854"-e program one line of program (several -e's allowed, omit programfile)",
bc9b29db 2855"-E program like -e, but enables all optional features",
aefc56c5 2856"-f don't do $sitelib/sitecustomize.pl at startup",
aefc56c5
SF
2857"-F/pattern/ split() pattern for -a switch (//'s are optional)",
2858"-i[extension] edit <> files in place (makes backup if extension supplied)",
2859"-Idirectory specify @INC/#include directory (several -I's allowed)",
2860"-l[octal] enable line ending processing, specifies line terminator",
2861"-[mM][-]module execute \"use/no module...\" before executing program",
2862"-n assume \"while (<>) { ... }\" loop around program",
2863"-p assume loop like -n but print line also, like sed",
aefc56c5
SF
2864"-s enable rudimentary parsing for switches after programfile",
2865"-S look for programfile using PATH environment variable",
2866"-t enable tainting warnings",
2867"-T enable tainting checks",
2868"-u dump core after parsing program",
2869"-U allow unsafe operations",
2870"-v print version, subversion (includes VERY IMPORTANT perl info)",
2871"-V[:variable] print configuration summary (or a single Config.pm variable)",
2872"-w enable many useful warnings (RECOMMENDED)",
2873"-W enable all warnings",
2874"-x[directory] strip off text before #!perl line and perhaps cd to directory",
2875"-X disable all warnings",
fb73857a
PP
2876"\n",
2877NULL
2878};
27da23d5 2879 const char * const *p = usage_msg;
fb73857a 2880
b0e47665
GS
2881 PerlIO_printf(PerlIO_stdout(),
2882 "\nUsage: %s [switches] [--] [programfile] [arguments]",
2883 name);
fb73857a 2884 while (*p)
b0e47665 2885 PerlIO_printf(PerlIO_stdout(), "\n %s", *p++);
4633a7c4
LW
2886}
2887
b4ab917c
DM
2888/* convert a string of -D options (or digits) into an int.
2889 * sets *s to point to the char after the options */
2890
2891#ifdef DEBUGGING
2892int
e1ec3a88 2893Perl_get_debug_opts(pTHX_ const char **s, bool givehelp)
b4ab917c 2894{
27da23d5 2895 static const char * const usage_msgd[] = {
e6e64d9b
JC
2896 " Debugging flag values: (see also -d)",
2897 " p Tokenizing and parsing (with v, displays parse stack)",
3679267a 2898 " s Stack snapshots (with v, displays all stacks)",
e6e64d9b
JC
2899 " l Context (loop) stack processing",
2900 " t Trace execution",
2901 " o Method and overloading resolution",
2902 " c String/numeric conversions",
4c84d7f2 2903 " P Print profiling info, source file input state",
e6e64d9b
JC
2904 " m Memory allocation",
2905 " f Format processing",
2906 " r Regular expression parsing and execution",
2907 " x Syntax tree dump",
3679267a 2908 " u Tainting checks",
e6e64d9b
JC
2909 " H Hash dump -- usurps values()",
2910 " X Scratchpad allocation",
2911 " D Cleaning up",
2912 " S Thread synchronization",
2913 " T Tokenising",
2914 " R Include reference counts of dumped variables (eg when using -Ds)",
2915 " J Do not s,t,P-debug (Jump over) opcodes within package DB",
2916 " v Verbose: use in conjunction with other flags",
2917 " C Copy On Write",
2918 " A Consistency checks on internal structures",
3679267a 2919 " q quiet - currently only suppresses the 'EXECUTING' message",
e6e64d9b
JC
2920 NULL
2921 };
b4ab917c
DM
2922 int i = 0;
2923 if (isALPHA(**s)) {
2924 /* if adding extra options, remember to update DEBUG_MASK */
88d2d28a 2925 static const char debopts[] = "psltocPmfrxuUHXDSTRJvCAq";
b4ab917c
DM
2926
2927 for (; isALNUM(**s); (*s)++) {
c4420975 2928 const char * const d = strchr(debopts,**s);
b4ab917c
DM
2929 if (d)
2930 i |= 1 << (d - debopts);
2931 else if (ckWARN_d(WARN_DEBUGGING))
e6e64d9b
JC
2932 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
2933 "invalid option -D%c, use -D'' to see choices\n", **s);
b4ab917c
DM
2934 }
2935 }
e6e64d9b 2936 else if (isDIGIT(**s)) {
b4ab917c
DM
2937 i = atoi(*s);
2938 for (; isALNUM(**s); (*s)++) ;
2939 }
ddcf8bc1 2940 else if (givehelp) {
06e869a4 2941 const char *const *p = usage_msgd;
e6e64d9b
JC
2942 while (*p) PerlIO_printf(PerlIO_stdout(), "%s\n", *p++);
2943 }
b4ab917c
DM
2944# ifdef EBCDIC
2945 if ((i & DEBUG_p_FLAG) && ckWARN_d(WARN_DEBUGGING))
2946 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
2947 "-Dp not implemented on this platform\n");
2948# endif
2949 return i;
2950}
2951#endif
2952
79072805
LW
2953/* This routine handles any switches that can be given during run */
2954
c7030b81
NC
2955const char *
2956Perl_moreswitches(pTHX_ const char *s)
79072805 2957{
27da23d5 2958 dVAR;
84c133a0 2959 UV rschar;
79072805
LW
2960
2961 switch (*s) {
2962 case '0':
a863c7d1 2963 {
f2095865 2964 I32 flags = 0;
a3b680e6 2965 STRLEN numlen;
f2095865
JH
2966
2967 SvREFCNT_dec(PL_rs);
2968 if (s[1] == 'x' && s[2]) {
a3b680e6 2969 const char *e = s+=2;
f2095865
JH
2970 U8 *tmps;
2971
a3b680e6
AL
2972 while (*e)
2973 e++;
f2095865
JH
2974 numlen = e - s;
2975 flags = PERL_SCAN_SILENT_ILLDIGIT;
2976 rschar = (U32)grok_hex(s, &numlen, &flags, NULL);
2977 if (s + numlen < e) {
2978 rschar = 0; /* Grandfather -0xFOO as -0 -xFOO. */
2979 numlen = 0;
2980 s--;
2981 }
396482e1 2982 PL_rs = newSVpvs("");
c5661c80 2983 SvGROW(PL_rs, (STRLEN)(UNISKIP(rschar) + 1));
f2095865
JH
2984 tmps = (U8*)SvPVX(PL_rs);
2985 uvchr_to_utf8(tmps, rschar);
2986 SvCUR_set(PL_rs, UNISKIP(rschar));
2987 SvUTF8_on(PL_rs);
2988 }
2989 else {
2990 numlen = 4;
2991 rschar = (U32)grok_oct(s, &numlen, &flags, NULL);
2992 if (rschar & ~((U8)~0))
2993 PL_rs = &PL_sv_undef;
2994 else if (!rschar && numlen >= 2)
396482e1 2995 PL_rs = newSVpvs("");
f2095865
JH
2996 else {
2997 char ch = (char)rschar;
2998 PL_rs = newSVpvn(&ch, 1);
2999 }
3000 }
800633c3 3001 sv_setsv(get_sv("/", TRUE), PL_rs);
f2095865 3002 return s + numlen;
a863c7d1 3003 }
46487f74 3004 case 'C':
a05d7ebb 3005 s++;
dd374669 3006 PL_unicode = parse_unicode_opts( (const char **)&s );
5a22a2bb
NC
3007 if (PL_unicode & PERL_UNICODE_UTF8CACHEASSERT_FLAG)
3008 PL_utf8cache = -1;
46487f74 3009 return s;
2304df62 3010 case 'F':
3280af22 3011 PL_minus_F = TRUE;
ebce5377
RGS
3012 PL_splitstr = ++s;
3013 while (*s && !isSPACE(*s)) ++s;
e49e380e 3014 PL_splitstr = savepvn(PL_splitstr, s - PL_splitstr);
2304df62 3015 return s;
79072805 3016 case 'a':
3280af22 3017 PL_minus_a = TRUE;
79072805
LW
3018 s++;
3019 return s;
3020 case 'c':
3280af22 3021 PL_minus_c = TRUE;
79072805
LW
3022 s++;
3023 return s;
3024 case 'd':
f20b2998 3025 forbid_setid('d', FALSE);
4633a7c4 3026 s++;
2cbb2ee1
RGS
3027
3028 /* -dt indicates to the debugger that threads will be used */
3029 if (*s == 't' && !isALNUM(s[1])) {
3030 ++s;
3031 my_setenv("PERL5DB_THREADED", "1");
3032 }
3033
70c94a19
RR
3034 /* The following permits -d:Mod to accepts arguments following an =
3035 in the fashion that -MSome::Mod does. */
3036 if (*s == ':' || *s == '=') {
f85893a1
NC
3037 const char *start = ++s;
3038 const char *const end = s + strlen(s);
396482e1 3039 SV * const sv = newSVpvs("use Devel::");
f85893a1 3040
70c94a19
RR
3041 /* We now allow -d:Module=Foo,Bar */
3042 while(isALNUM(*s) || *s==':') ++s;
3043 if (*s != '=')
f85893a1 3044 sv_catpvn(sv, start, end - start);
70c94a19
RR
3045 else {
3046 sv_catpvn(sv, start, s-start);
95a2b409
RGS
3047 /* Don't use NUL as q// delimiter here, this string goes in the
3048 * environment. */
3049 Perl_sv_catpvf(aTHX_ sv, " split(/,/,q{%s});", ++s);
70c94a19 3050 }
f85893a1 3051 s = end;
184f32ec 3052 my_setenv("PERL5DB", SvPV_nolen_const(sv));
c4db126b 3053 SvREFCNT_dec(sv);
4633a7c4 3054 }
ed094faf 3055 if (!PL_perldb) {
3280af22 3056 PL_perldb = PERLDB_ALL;
a0d0e21e 3057 init_debugger();
ed094faf 3058 }
79072805
LW
3059 return s;
3060 case 'D':
0453d815 3061 {
79072805 3062#ifdef DEBUGGING
f20b2998 3063 forbid_setid('D', FALSE);
b4ab917c 3064 s++;
dd374669 3065 PL_debug = get_debug_opts( (const char **)&s, 1) | DEBUG_TOP_FLAG;
12a43e32 3066#else /* !DEBUGGING */
0453d815 3067 if (ckWARN_d(WARN_DEBUGGING))
9014280d 3068 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
e6e64d9b 3069 "Recompile perl with -DDEBUGGING to use -D switch (did you mean -d ?)\n");
a0d0e21e 3070 for (s++; isALNUM(*s); s++) ;
79072805 3071#endif
79072805 3072 return s;
0453d815 3073 }
4633a7c4 3074 case 'h':
ac27b0f5 3075 usage(PL_origargv[0]);
7ca617d0 3076 my_exit(0);
79072805 3077 case 'i':
43c5f42d 3078 Safefree(PL_inplace);
c030f24b
GH
3079#if defined(__CYGWIN__) /* do backup extension automagically */
3080 if (*(s+1) == '\0') {
c86a4f2e 3081 PL_inplace = savepvs(".bak");
c030f24b
GH
3082 return s+1;
3083 }
3084#endif /* __CYGWIN__ */
5ef5d758 3085 {
d4c19fe8 3086 const char * const start = ++s;
5ef5d758
NC
3087 while (*s && !isSPACE(*s))
3088 ++s;
3089
3090 PL_inplace = savepvn(start, s - start);
3091 }
7b8d334a 3092 if (*s) {
5ef5d758 3093 ++s;
7b8d334a 3094 if (*s == '-') /* Additional switches on #! line. */
5ef5d758 3095 s++;
7b8d334a 3096 }
fb73857a 3097 return s;
4e49a025 3098 case 'I': /* -I handled both here and in parse_body() */
f20b2998 3099 forbid_setid('I', FALSE);
fb73857a
PP
3100 ++s;
3101 while (*s && isSPACE(*s))
3102 ++s;
3103 if (*s) {
c7030b81 3104 const char *e, *p;
0df16ed7
GS
3105 p = s;
3106 /* ignore trailing spaces (possibly followed by other switches) */
3107 do {
3108 for (e = p; *e && !isSPACE(*e); e++) ;
3109 p = e;
3110 while (isSPACE(*p))
3111 p++;
3112 } while (*p && *p != '-');
3113 e = savepvn(s, e-s);
88fe16b2 3114 incpush(e, TRUE, TRUE, FALSE, FALSE);
0df16ed7
GS
3115 Safefree(e);
3116 s = p;
3117 if (*s == '-')
3118 s++;
79072805
LW
3119 }
3120 else
a67e862a 3121 Perl_croak(aTHX_ "No directory specified for -I");
fb73857a 3122 return s;
79072805 3123 case 'l':
3280af22 3124 PL_minus_l = TRUE;
79072805 3125 s++;
7889fe52
NIS
3126 if (PL_ors_sv) {
3127 SvREFCNT_dec(PL_ors_sv);
a0714e2c 3128 PL_ors_sv = NULL;
7889fe52 3129 }
79072805 3130 if (isDIGIT(*s)) {
53305cf1 3131 I32 flags = 0;
a3b680e6 3132 STRLEN numlen;
396482e1 3133 PL_ors_sv = newSVpvs("\n");
53305cf1
NC
3134 numlen = 3 + (*s == '0');
3135 *SvPVX(PL_ors_sv) = (char)grok_oct(s, &numlen, &flags, NULL);
79072805
LW
3136 s += numlen;
3137 }
3138 else {
8bfdd7d9 3139 if (RsPARA(PL_rs)) {
396482e1 3140 PL_ors_sv = newSVpvs("\n\n");
7889fe52
NIS
3141 }
3142 else {
8bfdd7d9 3143 PL_ors_sv = newSVsv(PL_rs);
c07a80fd 3144 }
79072805
LW
3145 }
3146 return s;
1a30305b 3147 case 'M':
f20b2998 3148 forbid_setid('M', FALSE); /* XXX ? */
1a30305b
PP
3149 /* FALL THROUGH */
3150 case 'm':
f20b2998 3151 forbid_setid('m', FALSE); /* XXX ? */
1a30305b 3152 if (*++s) {
c7030b81 3153 const char *start;
b64cb68c 3154 const char *end;
11343788 3155 SV *sv;
e1ec3a88 3156 const char *use = "use ";
a5f75d66 3157 /* -M-foo == 'no foo' */
d0043bd1
NC
3158 /* Leading space on " no " is deliberate, to make both
3159 possibilities the same length. */
3160 if (*s == '-') { use = " no "; ++s; }
3161 sv = newSVpvn(use,4);
a5f75d66 3162 start = s;
1a30305b 3163 /* We allow -M'Module qw(Foo Bar)' */
c07a80fd 3164 while(isALNUM(*s) || *s==':') ++s;
b64cb68c 3165 end = s + strlen(s);
c07a80fd 3166 if (*s != '=') {
b64cb68c 3167 sv_catpvn(sv, start, end - start);
c07a80fd
PP
3168 if (*(start-1) == 'm') {
3169 if (*s != '\0')
cea2e8a9 3170 Perl_croak(aTHX_ "Can't use '%c' after -mname", *s);
396482e1 3171 sv_catpvs( sv, " ()");
c07a80fd
PP
3172 }
3173 } else {
6df41af2 3174 if (s == start)
be98fb35
GS
3175 Perl_croak(aTHX_ "Module name required with -%c option",
3176 s[-1]);
11343788 3177 sv_catpvn(sv, start, s-start);
b64cb68c
NC
3178 /* Use NUL as q''-delimiter. */
3179 sv_catpvs(sv, " split(/,/,q\0");
3180 ++s;
3181 sv_catpvn(sv, s, end - s);
396482e1 3182 sv_catpvs(sv, "\0)");
c07a80fd 3183 }
b64cb68c 3184 s = end;
29a861e7 3185 Perl_av_create_and_push(aTHX_ &PL_preambleav, sv);
1a30305b
PP
3186 }
3187 else
9e81e6a1 3188 Perl_croak(aTHX_ "Missing argument to -%c", *(s-1));
1a30305b 3189 return s;
79072805 3190 case 'n':
3280af22 3191 PL_minus_n = TRUE;
79072805
LW
3192 s++;
3193 return s;
3194 case 'p':
3280af22 3195 PL_minus_p = TRUE;
79072805
LW
3196 s++;
3197 return s;
3198 case 's':
f20b2998 3199 forbid_setid('s', FALSE);
3280af22 3200 PL_doswitches = TRUE;
79072805
LW
3201 s++;
3202 return s;
6537fe72
MS
3203 case 't':
3204 if (!PL_tainting)
22f7c9c9 3205 TOO_LATE_FOR('t');
6537fe72
MS
3206 s++;
3207 return s;
463ee0b2 3208 case 'T':
3280af22 3209 if (!PL_tainting)
22f7c9c9 3210 TOO_LATE_FOR('T');
463ee0b2
LW
3211 s++;
3212 return s;
79072805 3213 case 'u':
bf4acbe4
GS
3214#ifdef MACOS_TRADITIONAL
3215 Perl_croak(aTHX_ "Believe me, you don't want to use \"-u\" on a Macintosh");
3216#endif
3280af22 3217 PL_do_undump = TRUE;
79072805
LW
3218 s++;
3219 return s;
3220 case 'U':
3280af22 3221 PL_unsafe = TRUE;
79072805
LW
3222 s++;
3223 return s;
3224 case 'v':
d7aa5382 3225 if (!sv_derived_from(PL_patchlevel, "version"))
ac0e6a2f 3226 upg_version(PL_patchlevel, TRUE);
8e9464f1 3227#if !defined(DGUX)
b0e47665 3228 PerlIO_printf(PerlIO_stdout(),
7850f74c
GA
3229 Perl_form(aTHX_ "\nThis is perl, %"SVf
3230#ifdef PERL_PATCHNUM
3231 " DEVEL" STRINGIFY(PERL_PATCHNUM)
3232#endif
3233 " built for %s",
be2597df 3234 SVfARG(vstringify(PL_patchlevel)),
95b63a38 3235 ARCHNAME));
8e9464f1
JH
3236#else /* DGUX */
3237/* Adjust verbose output as in the perl that ships with the DG/UX OS from EMC */
3238 PerlIO_printf(PerlIO_stdout(),
52ea0aec 3239 Perl_form(aTHX_ "\nThis is perl, %"SVf"\n",
be2597df 3240 SVfARG(vstringify(PL_patchlevel))));
8e9464f1
JH
3241 PerlIO_printf(PerlIO_stdout(),
3242 Perl_form(aTHX_ " built under %s at %s %s\n",
3243 OSNAME, __DATE__, __TIME__));
3244 PerlIO_printf(PerlIO_stdout(),
3245 Perl_form(aTHX_ " OS Specific Release: %s\n",
40a39f85 3246 OSVERS));
8e9464f1
JH
3247#endif /* !DGUX */
3248
fb73857a
PP
3249#if defined(LOCAL_PATCH_COUNT)
3250 if (LOCAL_PATCH_COUNT > 0)
b0e47665
GS
3251 PerlIO_printf(PerlIO_stdout(),
3252 "\n(with %d registered patch%s, "
3253 "see perl -V for more detail)",
bb7a0f54 3254 LOCAL_PATCH_COUNT,
b0e47665 3255 (LOCAL_PATCH_COUNT!=1) ? "es" : "");
a5f75d66 3256#endif
1a30305b 3257
b0e47665 3258 PerlIO_printf(PerlIO_stdout(),
34ce1597 3259 "\n\nCopyright 1987-2007, Larry Wall\n");
eae9c151
JH
3260#ifdef MACOS_TRADITIONAL
3261 PerlIO_printf(PerlIO_stdout(),
be3c0a43 3262 "\nMac OS port Copyright 1991-2002, Matthias Neeracher;\n"
03765510 3263 "maintained by Chris Nandor\n");
eae9c151 3264#endif
79072805 3265#ifdef MSDOS
b0e47665
GS
3266 PerlIO_printf(PerlIO_stdout(),
3267 "\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
55497cff
PP
3268#endif
3269#ifdef DJGPP
b0e47665
GS
3270 PerlIO_printf(PerlIO_stdout(),
3271 "djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n"
3272 "djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n");
4633a7c4 3273#endif
79072805 3274#ifdef OS2
b0e47665
GS
3275 PerlIO_printf(PerlIO_stdout(),
3276 "\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
be3c0a43 3277 "Version 5 port Copyright (c) 1994-2002, Andreas Kaiser, Ilya Zakharevich\n");
79072805 3278#endif
79072805 3279#ifdef atarist
b0e47665
GS
3280 PerlIO_printf(PerlIO_stdout(),
3281 "atariST series port, ++jrb bammi@cadence.com\n");
79072805 3282#endif
a3f9223b 3283#ifdef __BEOS__
b0e47665
GS
3284 PerlIO_printf(PerlIO_stdout(),
3285 "BeOS port Copyright Tom Spindler, 1997-1999\n");
a3f9223b 3286#endif
1d84e8df 3287#ifdef MPE
b0e47665 3288 PerlIO_printf(PerlIO_stdout(),
e583a879 3289 "MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-2003\n");
1d84e8df 3290#endif
9d116dd7 3291#ifdef OEMVS
b0e47665
GS
3292 PerlIO_printf(PerlIO_stdout(),
3293 "MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
9d116dd7 3294#endif
495c5fdc 3295#ifdef __VOS__
b0e47665 3296 PerlIO_printf(PerlIO_stdout(),
94efb9fb 3297 "Stratus VOS port by Paul.Green@stratus.com, 1997-2002\n");
495c5fdc 3298#endif
092bebab 3299#ifdef __OPEN_VM
b0e47665
GS
3300 PerlIO_printf(PerlIO_stdout(),
3301 "VM/ESA port by Neale Ferguson, 1998-1999\n");
092bebab 3302#endif
a1a0e61e 3303#ifdef POSIX_BC
b0e47665
GS
3304 PerlIO_printf(PerlIO_stdout(),
3305 "BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
a1a0e61e 3306#endif
61ae2fbf 3307#ifdef __MINT__
b0e47665
GS
3308 PerlIO_printf(PerlIO_stdout(),
3309 "MiNT port by Guido Flohr, 1997-1999\n");
61ae2fbf 3310#endif
f83d2536 3311#ifdef EPOC
b0e47665 3312 PerlIO_printf(PerlIO_stdout(),
be3c0a43 3313 "EPOC port by Olaf Flebbe, 1999-2002\n");
f83d2536 3314#endif
e1caacb4 3315#ifdef UNDER_CE
b475b3e6
JH
3316 PerlIO_printf(PerlIO_stdout(),"WINCE port by Rainer Keuchel, 2001-2002\n");
3317 PerlIO_printf(PerlIO_stdout(),"Built on " __DATE__ " " __TIME__ "\n\n");
e1caacb4
JH
3318 wce_hitreturn();
3319#endif
a0fd4948 3320#ifdef __SYMBIAN32__
27da23d5
JH
3321 PerlIO_printf(PerlIO_stdout(),
3322 "Symbian port by Nokia, 2004-2005\n");
3323#endif
baed7233
DL
3324#ifdef BINARY_BUILD_NOTICE
3325 BINARY_BUILD_NOTICE;
3326#endif
b0e47665
GS
3327 PerlIO_printf(PerlIO_stdout(),
3328 "\n\
79072805 3329Perl may be copied only under the terms of either the Artistic License or the\n\
3d6f292d 3330GNU General Public License, which may be found in the Perl 5 source kit.\n\n\
95103687 3331Complete documentation for Perl, including FAQ lists, should be found on\n\
a0288114 3332this system using \"man perl\" or \"perldoc perl\". If you have access to the\n\
c9e30dd8 3333Internet, point your browser at http://www.perl.org/, the Perl Home Page.\n\n");
7ca617d0 3334 my_exit(0);
79072805 3335 case 'w':
b2e5e6ba 3336 if (! (PL_dowarn & G_WARN_ALL_MASK)) {
ac27b0f5 3337 PL_dowarn |= G_WARN_ON;
b2e5e6ba 3338 }
599cee73
PM
3339 s++;
3340 return s;
3341 case 'W':
ac27b0f5 3342 PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
317ea90d 3343 if (!specialWARN(PL_compiling.cop_warnings))
72dc9ed5 3344 PerlMemShared_free(PL_compiling.cop_warnings);
d3a7d8c7 3345 PL_compiling.cop_warnings = pWARN_ALL ;
599cee73
PM
3346 s++;
3347 return s;
3348 case 'X':
ac27b0f5 3349 PL_dowarn = G_WARN_ALL_OFF;
317ea90d 3350 if (!specialWARN(PL_compiling.cop_warnings))
72dc9ed5 3351 PerlMemShared_free(PL_compiling.cop_warnings);
d3a7d8c7 3352 PL_compiling.cop_warnings = pWARN_NONE ;
79072805
LW
3353 s++;
3354 return s;
a0d0e21e 3355 case '*':
79072805
LW
3356 case ' ':
3357 if (s[1] == '-') /* Additional switches on #! line. */
3358 return s+2;
3359 break;
a0d0e21e 3360 case '-':
79072805 3361 case 0:
51882d45 3362#if defined(WIN32) || !defined(PERL_STRICT_CR)
a868473f
NIS
3363 case '\r':
3364#endif
79072805
LW
3365 case '\n':
3366 case '\t':
3367 break;
aa689395
PP
3368#ifdef ALTERNATE_SHEBANG
3369 case 'S': /* OS/2 needs -S on "extproc" line. */
3370 break;
3371#endif
79072805 3372 default:
cea2e8a9 3373 Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s);
79072805 3374 }
bd61b366 3375 return NULL;
79072805
LW
3376}
3377
3378/* compliments of Tom Christiansen */
3379
3380/* unexec() can be found in the Gnu emacs distribution */
ee580363 3381/* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
79072805
LW
3382
3383void
864dbfa3 3384Perl_my_unexec(pTHX)
79072805 3385{
b37c2d43 3386 PERL_UNUSED_CONTEXT;
79072805 3387#ifdef UNEXEC
b37c2d43
AL
3388 SV * prog = newSVpv(BIN_EXP, 0);
3389 SV * file = newSVpv(PL_origfilename, 0);
ee580363 3390 int status = 1;
79072805
LW
3391 extern int etext;
3392
396482e1 3393 sv_catpvs(prog, "/perl");
396482e1 3394 sv_catpvs(file, ".perldump");
79072805 3395
ee580363
GS
3396 unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
3397 /* unexec prints msg to stderr in case of failure */
6ad3d225 3398 PerlProc_exit(status);
79072805 3399#else
a5f75d66
AD
3400# ifdef VMS
3401# include <lib$routines.h>
3402 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
84d78eb7
YO
3403# elif defined(WIN32) || defined(__CYGWIN__)
3404 Perl_croak(aTHX_ "dump is not supported");
aa689395 3405# else
79072805 3406 ABORT(); /* for use with undump */
aa689395 3407# endif
a5f75d66 3408#endif
79072805
LW
3409}
3410
cb68f92d
GS
3411/* initialize curinterp */
3412STATIC void
cea2e8a9 3413S_init_interp(pTHX)
cb68f92d 3414{
97aff369 3415 dVAR;
acfe0abc
GS
3416#ifdef MULTIPLICITY
3417# define PERLVAR(var,type)
3418# define PERLVARA(var,n,type)
3419# if defined(PERL_IMPLICIT_CONTEXT)
b7f7fff6
NC
3420# define PERLVARI(var,type,init) aTHX->var = init;
3421# define PERLVARIC(var,type,init) aTHX->var = init;
3967c732 3422# else
acfe0abc
GS
3423# define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
3424# define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
066ef5b5 3425# endif
acfe0abc 3426# include "intrpvar.h"
acfe0abc
GS
3427# undef PERLVAR
3428# undef PERLVARA
3429# undef PERLVARI
3430# undef PERLVARIC
3431#else
3432# define PERLVAR(var,type)
3433# define PERLVARA(var,n,type)
3434# define PERLVARI(var,type,init) PL_##var = init;
3435# define PERLVARIC(var,type,init) PL_##var = init;
3436# include "intrpvar.h"
acfe0abc
GS
3437# undef PERLVAR
3438# undef PERLVARA
3439# undef PERLVARI
3440# undef PERLVARIC
cb68f92d
GS
3441#endif
3442
46ab3289
NC
3443 /* As these are inside a structure, PERLVARI isn't capable of initialising
3444 them */
6c3f0a89
NC
3445 PL_reg_oldcurpm = PL_reg_curpm = NULL;
3446 PL_reg_poscache = PL_reg_starttry = NULL;
cb68f92d
GS
3447}
3448
76e3520e 3449STATIC void
cea2e8a9 3450S_init_main_stash(pTHX)
79072805 3451{
97aff369 3452 dVAR;
463ee0b2 3453 GV *gv;
6e72f9df 3454
3280af22 3455 PL_curstash = PL_defstash = newHV();
23579a14
NC
3456 /* We know that the string "main" will be in the global shared string
3457 table, so it's a small saving to use it rather than allocate another
3458 8 bytes. */
18916d0d 3459 PL_curstname = newSVpvs_share("main");
fafc274c 3460 gv = gv_fetchpvs("main::", GV_ADD|GV_NOTQUAL, SVt_PVHV);
23579a14
NC
3461 /* If we hadn't caused another reference to "main" to be in the shared
3462 string table above, then it would be worth reordering these two,
3463 because otherwise all we do is delete "main" from it as a consequence
3464 of the SvREFCNT_dec, only to add it again with hv_name_set */
adbc6bb1 3465 SvREFCNT_dec(GvHV(gv));
23579a14 3466 hv_name_set(PL_defstash, "main", 4, 0);
b37c2d43 3467 GvHV(gv) = (HV*)SvREFCNT_inc_simple(PL_defstash);
463ee0b2 3468 SvREADONLY_on(gv);
fafc274c
NC
3469 PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpvs("INC", GV_ADD|GV_NOTQUAL,
3470 SVt_PVAV)));
5a5094bd 3471 SvREFCNT_inc_simple_void(PL_incgv); /* Don't allow it to be freed */
3280af22 3472 GvMULTI_on(PL_incgv);
fafc274c 3473 PL_hintgv = gv_fetchpvs("\010", GV_ADD|GV_NOTQUAL, SVt_PV); /* ^H */
3280af22 3474 GvMULTI_on(PL_hintgv);
fafc274c 3475 PL_defgv = gv_fetchpvs("_", GV_ADD|GV_NOTQUAL, SVt_PVAV);
5a5094bd 3476 SvREFCNT_inc_simple_void(PL_defgv);
fafc274c 3477 PL_errgv = gv_HVadd(gv_fetchpvs("@", GV_ADD|GV_NOTQUAL, SVt_PV));
5a5094bd 3478 SvREFCNT_inc_simple_void(PL_errgv);
3280af22 3479 GvMULTI_on(PL_errgv);
fafc274c 3480 PL_replgv = gv_fetchpvs("\022", GV_ADD|GV_NOTQUAL, SVt_PV); /* ^R */
3280af22 3481 GvMULTI_on(PL_replgv);
cea2e8a9 3482 (void)Perl_form(aTHX_ "%240s",""); /* Preallocate temp - for immediate signals. */
c69033f2
NC
3483#ifdef PERL_DONT_CREATE_GVSV
3484 gv_SVadd(PL_errgv);
3485#endif
38a03e6e
MB
3486 sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */
3487 sv_setpvn(ERRSV, "", 0);
3280af22 3488 PL_curstash = PL_defstash;
11faa288 3489 CopSTASH_set(&PL_compiling, PL_defstash);
5c1737d1
NC
3490 PL_debstash = GvHV(gv_fetchpvs("DB::", GV_ADDMULTI, SVt_PVHV));
3491 PL_globalstash = GvHV(gv_fetchpvs("CORE::GLOBAL::", GV_ADDMULTI,
3492 SVt_PVHV));
4633a7c4 3493 /* We must init $/ before switches are processed. */
864dbfa3 3494 sv_setpvn(get_sv("/", TRUE), "\n", 1);
79072805
LW
3495}
3496
fdf5d70d 3497STATIC int
2f352907 3498S_open_script(pTHX_ const char *scriptname, bool dosearch,
f20b2998 3499 bool *suidscript, PerlIO **rsfpp)
79072805 3500{
fdf5d70d 3501 int fdscript = -1;
27da23d5 3502 dVAR;
1b24ed4b 3503