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