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