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