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