This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
msgrcv: properly downgrade the receive buffer
[perl5.git] / perl.c
1 #line 2 "perl.c"
2 /*    perl.c
3  *
4  *    Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001
5  *    2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012
6  *    2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 by Larry Wall and others
7  *
8  *    You may distribute under the terms of either the GNU General Public
9  *    License or the Artistic License, as specified in the README file.
10  *
11  */
12
13 /*
14  *      A ship then new they built for him
15  *      of mithril and of elven-glass
16  *              --from Bilbo's song of EƤrendil
17  *
18  *     [p.236 of _The Lord of the Rings_, II/i: "Many Meetings"]
19  */
20
21 /* This file contains the top-level functions that are used to create, use
22  * and destroy a perl interpreter, plus the functions used by XS code to
23  * call back into perl. Note that it does not contain the actual main()
24  * function of the interpreter; that can be found in perlmain.c
25  *
26  * Note that at build time this file is also linked to as perlmini.c,
27  * and perlmini.o is then built with PERL_IS_MINIPERL defined, which is
28  * then used to create the miniperl executable, rather than perl.o.
29  */
30
31 #if defined(PERL_IS_MINIPERL) && !defined(USE_SITECUSTOMIZE)
32 #  define USE_SITECUSTOMIZE
33 #endif
34
35 #include "EXTERN.h"
36 #define PERL_IN_PERL_C
37 #include "perl.h"
38 #include "patchlevel.h"                 /* for local_patches */
39 #include "XSUB.h"
40
41 #ifdef NETWARE
42 #include "nwutil.h"     
43 #endif
44
45 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
46 #  ifdef I_SYSUIO
47 #    include <sys/uio.h>
48 #  endif
49
50 union control_un {
51   struct cmsghdr cm;
52   char control[CMSG_SPACE(sizeof(int))];
53 };
54
55 #endif
56
57 #ifndef HZ
58 #  ifdef CLK_TCK
59 #    define HZ CLK_TCK
60 #  else
61 #    define HZ 60
62 #  endif
63 #endif
64
65 static I32 read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen);
66
67 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
68 #  define validate_suid(rsfp) NOOP
69 #else
70 #  define validate_suid(rsfp) S_validate_suid(aTHX_ rsfp)
71 #endif
72
73 #define CALL_BODY_SUB(myop) \
74     if (PL_op == (myop)) \
75         PL_op = PL_ppaddr[OP_ENTERSUB](aTHX); \
76     if (PL_op) \
77         CALLRUNOPS(aTHX);
78
79 #define CALL_LIST_BODY(cv) \
80     PUSHMARK(PL_stack_sp); \
81     call_sv(MUTABLE_SV((cv)), G_EVAL|G_DISCARD|G_VOID);
82
83 static void
84 S_init_tls_and_interp(PerlInterpreter *my_perl)
85 {
86     if (!PL_curinterp) {                        
87         PERL_SET_INTERP(my_perl);
88 #if defined(USE_ITHREADS)
89         INIT_THREADS;
90         ALLOC_THREAD_KEY;
91         PERL_SET_THX(my_perl);
92         OP_REFCNT_INIT;
93         OP_CHECK_MUTEX_INIT;
94         KEYWORD_PLUGIN_MUTEX_INIT;
95         HINTS_REFCNT_INIT;
96         LOCALE_INIT;
97         USER_PROP_MUTEX_INIT;
98         ENV_INIT;
99         MUTEX_INIT(&PL_dollarzero_mutex);
100         MUTEX_INIT(&PL_my_ctx_mutex);
101 #  endif
102     }
103 #if defined(USE_ITHREADS)
104     else
105 #else
106     /* This always happens for non-ithreads  */
107 #endif
108     {
109         PERL_SET_THX(my_perl);
110     }
111 }
112
113
114 /* these implement the PERL_SYS_INIT, PERL_SYS_INIT3, PERL_SYS_TERM macros */
115
116 void
117 Perl_sys_init(int* argc, char*** argv)
118 {
119
120     PERL_ARGS_ASSERT_SYS_INIT;
121
122     PERL_UNUSED_ARG(argc); /* may not be used depending on _BODY macro */
123     PERL_UNUSED_ARG(argv);
124     PERL_SYS_INIT_BODY(argc, argv);
125 }
126
127 void
128 Perl_sys_init3(int* argc, char*** argv, char*** env)
129 {
130
131     PERL_ARGS_ASSERT_SYS_INIT3;
132
133     PERL_UNUSED_ARG(argc); /* may not be used depending on _BODY macro */
134     PERL_UNUSED_ARG(argv);
135     PERL_UNUSED_ARG(env);
136     PERL_SYS_INIT3_BODY(argc, argv, env);
137 }
138
139 void
140 Perl_sys_term(void)
141 {
142     if (!PL_veto_cleanup) {
143         PERL_SYS_TERM_BODY();
144     }
145 }
146
147
148 #ifdef PERL_IMPLICIT_SYS
149 PerlInterpreter *
150 perl_alloc_using(struct IPerlMem* ipM, struct IPerlMem* ipMS,
151                  struct IPerlMem* ipMP, struct IPerlEnv* ipE,
152                  struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
153                  struct IPerlDir* ipD, struct IPerlSock* ipS,
154                  struct IPerlProc* ipP)
155 {
156     PerlInterpreter *my_perl;
157
158     PERL_ARGS_ASSERT_PERL_ALLOC_USING;
159
160     /* Newx() needs interpreter, so call malloc() instead */
161     my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
162     S_init_tls_and_interp(my_perl);
163     Zero(my_perl, 1, PerlInterpreter);
164     PL_Mem = ipM;
165     PL_MemShared = ipMS;
166     PL_MemParse = ipMP;
167     PL_Env = ipE;
168     PL_StdIO = ipStd;
169     PL_LIO = ipLIO;
170     PL_Dir = ipD;
171     PL_Sock = ipS;
172     PL_Proc = ipP;
173     INIT_TRACK_MEMPOOL(PL_memory_debug_header, my_perl);
174
175     return my_perl;
176 }
177 #else
178
179 /*
180 =for apidoc_section $embedding
181
182 =for apidoc perl_alloc
183
184 Allocates a new Perl interpreter.  See L<perlembed>.
185
186 =cut
187 */
188
189 PerlInterpreter *
190 perl_alloc(void)
191 {
192     PerlInterpreter *my_perl;
193
194     /* Newx() needs interpreter, so call malloc() instead */
195     my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
196
197     S_init_tls_and_interp(my_perl);
198 #ifndef PERL_TRACK_MEMPOOL
199     return (PerlInterpreter *) ZeroD(my_perl, 1, PerlInterpreter);
200 #else
201     Zero(my_perl, 1, PerlInterpreter);
202     INIT_TRACK_MEMPOOL(PL_memory_debug_header, my_perl);
203     return my_perl;
204 #endif
205 }
206 #endif /* PERL_IMPLICIT_SYS */
207
208 /*
209 =for apidoc perl_construct
210
211 Initializes a new Perl interpreter.  See L<perlembed>.
212
213 =cut
214 */
215
216 void
217 perl_construct(pTHXx)
218 {
219
220     PERL_ARGS_ASSERT_PERL_CONSTRUCT;
221
222 #ifdef MULTIPLICITY
223     init_interp();
224     PL_perl_destruct_level = 1;
225 #else
226     PERL_UNUSED_ARG(my_perl);
227    if (PL_perl_destruct_level > 0)
228        init_interp();
229 #endif
230     PL_curcop = &PL_compiling;  /* needed by ckWARN, right away */
231
232 #ifdef PERL_TRACE_OPS
233     Zero(PL_op_exec_cnt, OP_max+2, UV);
234 #endif
235
236     init_constants();
237
238     SvREADONLY_on(&PL_sv_placeholder);
239     SvREFCNT(&PL_sv_placeholder) = SvREFCNT_IMMORTAL;
240
241     PL_sighandlerp  = Perl_sighandler;
242     PL_sighandler1p = Perl_sighandler1;
243     PL_sighandler3p = Perl_sighandler3;
244
245 #ifdef PERL_USES_PL_PIDSTATUS
246     PL_pidstatus = newHV();
247 #endif
248
249     PL_rs = newSVpvs("\n");
250
251     init_stacks();
252
253 /* The PERL_INTERNAL_RAND_SEED set-up must be after init_stacks because it calls
254  * things that may put SVs on the stack.
255  */
256
257 #ifdef NO_PERL_INTERNAL_RAND_SEED
258     Perl_drand48_init_r(&PL_internal_random_state, seed());
259 #else
260     {
261         UV seed;
262         const char *env_pv;
263         if (PerlProc_getuid() != PerlProc_geteuid() ||
264             PerlProc_getgid() != PerlProc_getegid() ||
265             !(env_pv = PerlEnv_getenv("PERL_INTERNAL_RAND_SEED")) ||
266             grok_number(env_pv, strlen(env_pv), &seed) != IS_NUMBER_IN_UV) {
267             seed = seed();
268         }
269         Perl_drand48_init_r(&PL_internal_random_state, (U32)seed);
270     }
271 #endif
272
273     init_ids();
274
275     JMPENV_BOOTSTRAP;
276     STATUS_ALL_SUCCESS;
277
278     init_uniprops();
279     (void) uvchr_to_utf8_flags((U8 *) PL_TR_SPECIAL_HANDLING_UTF8,
280                                TR_SPECIAL_HANDLING,
281                                UNICODE_ALLOW_ABOVE_IV_MAX);
282
283 #if defined(LOCAL_PATCH_COUNT)
284     PL_localpatches = local_patches;    /* For possible -v */
285 #endif
286
287 #if defined(LIBM_LIB_VERSION)
288     /*
289      * Some BSDs and Cygwin default to POSIX math instead of IEEE.
290      * This switches them over to IEEE.
291      */
292     _LIB_VERSION = _IEEE_;
293 #endif
294
295 #ifdef HAVE_INTERP_INTERN
296     sys_intern_init();
297 #endif
298
299     PerlIO_init(aTHX);                  /* Hook to IO system */
300
301     PL_fdpid = newAV();                 /* for remembering popen pids by fd */
302     PL_modglobal = newHV();             /* pointers to per-interpreter module globals */
303     PL_errors = newSVpvs("");
304     SvPVCLEAR(PERL_DEBUG_PAD(0));        /* For regex debugging. */
305     SvPVCLEAR(PERL_DEBUG_PAD(1));        /* ext/re needs these */
306     SvPVCLEAR(PERL_DEBUG_PAD(2));        /* even without DEBUGGING. */
307 #ifdef USE_ITHREADS
308     /* First entry is a list of empty elements. It needs to be initialised
309        else all hell breaks loose in S_find_uninit_var().  */
310     Perl_av_create_and_push(aTHX_ &PL_regex_padav, newSVpvs(""));
311     PL_regex_pad = AvARRAY(PL_regex_padav);
312     Newxz(PL_stashpad, PL_stashpadmax, HV *);
313 #endif
314 #ifdef USE_REENTRANT_API
315     Perl_reentrant_init(aTHX);
316 #endif
317     if (PL_hash_seed_set == FALSE) {
318         /* Initialize the hash seed and state at startup. This must be
319          * done very early, before ANY hashes are constructed, and once
320          * setup is fixed for the lifetime of the process.
321          *
322          * If you decide to disable the seeding process you should choose
323          * a suitable seed yourself and define PERL_HASH_SEED to a well chosen
324          * string. See hv_func.h for details.
325          */
326 #if defined(USE_HASH_SEED)
327         /* get the hash seed from the environment or from an RNG */
328         Perl_get_hash_seed(aTHX_ PL_hash_seed);
329 #else
330         /* they want a hard coded seed, check that it is long enough */
331         assert( strlen(PERL_HASH_SEED) >= PERL_HASH_SEED_BYTES );
332 #endif
333
334         /* now we use the chosen seed to initialize the state -
335          * in some configurations this may be a relatively speaking
336          * expensive operation, but we only have to do it once at startup */
337         PERL_HASH_SEED_STATE(PERL_HASH_SEED,PL_hash_state);
338
339 #ifdef PERL_USE_SINGLE_CHAR_HASH_CACHE
340         /* we can build a special cache for 0/1 byte keys, if people choose
341          * I suspect most of the time it is not worth it */
342         {
343             char str[2]="\0";
344             int i;
345             for (i=0;i<256;i++) {
346                 str[0]= i;
347                 PERL_HASH_WITH_STATE(PL_hash_state,PL_hash_chars[i],str,1);
348             }
349             PERL_HASH_WITH_STATE(PL_hash_state,PL_hash_chars[256],str,0);
350         }
351 #endif
352         /* at this point we have initialezed the hash function, and we can start
353          * constructing hashes */
354         PL_hash_seed_set= TRUE;
355     }
356
357     /* Allow PL_strtab to be pre-initialized before calling perl_construct.
358     * can use a custom optimized PL_strtab hash before calling perl_construct */
359     if (!PL_strtab) {
360         /* Note that strtab is a rather special HV.  Assumptions are made
361            about not iterating on it, and not adding tie magic to it.
362            It is properly deallocated in perl_destruct() */
363         PL_strtab = newHV();
364
365         /* SHAREKEYS tells us that the hash has its keys shared with PL_strtab,
366          * which is not the case with PL_strtab itself */
367         HvSHAREKEYS_off(PL_strtab);                     /* mandatory */
368         hv_ksplit(PL_strtab, 1 << 11);
369     }
370
371     Zero(PL_sv_consts, SV_CONSTS_COUNT, SV*);
372
373 #ifndef PERL_MICRO
374 #   ifdef  USE_ENVIRON_ARRAY
375     PL_origenviron = environ;
376 #   endif
377 #endif
378
379     /* Use sysconf(_SC_CLK_TCK) if available, if not
380      * available or if the sysconf() fails, use the HZ.
381      * The HZ if not originally defined has been by now
382      * been defined as CLK_TCK, if available. */
383 #if defined(HAS_SYSCONF) && defined(_SC_CLK_TCK)
384     PL_clocktick = sysconf(_SC_CLK_TCK);
385     if (PL_clocktick <= 0)
386 #endif
387          PL_clocktick = HZ;
388
389     PL_stashcache = newHV();
390
391     PL_patchlevel = newSVpvs("v" PERL_VERSION_STRING);
392
393 #ifdef HAS_MMAP
394     if (!PL_mmap_page_size) {
395 #if defined(HAS_SYSCONF) && (defined(_SC_PAGESIZE) || defined(_SC_MMAP_PAGE_SIZE))
396       {
397         SETERRNO(0, SS_NORMAL);
398 #   ifdef _SC_PAGESIZE
399         PL_mmap_page_size = sysconf(_SC_PAGESIZE);
400 #   else
401         PL_mmap_page_size = sysconf(_SC_MMAP_PAGE_SIZE);
402 #   endif
403         if ((long) PL_mmap_page_size < 0) {
404             Perl_croak(aTHX_ "panic: sysconf: %s",
405                 errno ? Strerror(errno) : "pagesize unknown");
406         }
407       }
408 #elif defined(HAS_GETPAGESIZE)
409       PL_mmap_page_size = getpagesize();
410 #elif defined(I_SYS_PARAM) && defined(PAGESIZE)
411       PL_mmap_page_size = PAGESIZE;       /* compiletime, bad */
412 #endif
413       if (PL_mmap_page_size <= 0)
414         Perl_croak(aTHX_ "panic: bad pagesize %" IVdf,
415                    (IV) PL_mmap_page_size);
416     }
417 #endif /* HAS_MMAP */
418
419     PL_osname = Perl_savepvn(aTHX_ STR_WITH_LEN(OSNAME));
420
421     PL_registered_mros = newHV();
422     /* Start with 1 bucket, for DFS.  It's unlikely we'll need more.  */
423     HvMAX(PL_registered_mros) = 0;
424
425 #ifdef USE_POSIX_2008_LOCALE
426     PL_C_locale_obj = newlocale(LC_ALL_MASK, "C", NULL);
427 #endif
428
429     ENTER;
430     init_i18nl10n(1);
431 }
432
433 /*
434 =for apidoc nothreadhook
435
436 Stub that provides thread hook for perl_destruct when there are
437 no threads.
438
439 =cut
440 */
441
442 int
443 Perl_nothreadhook(pTHX)
444 {
445     PERL_UNUSED_CONTEXT;
446     return 0;
447 }
448
449 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
450 void
451 Perl_dump_sv_child(pTHX_ SV *sv)
452 {
453     ssize_t got;
454     const int sock = PL_dumper_fd;
455     const int debug_fd = PerlIO_fileno(Perl_debug_log);
456     union control_un control;
457     struct msghdr msg;
458     struct iovec vec[2];
459     struct cmsghdr *cmptr;
460     int returned_errno;
461     unsigned char buffer[256];
462
463     PERL_ARGS_ASSERT_DUMP_SV_CHILD;
464
465     if(sock == -1 || debug_fd == -1)
466         return;
467
468     PerlIO_flush(Perl_debug_log);
469
470     /* All these shenanigans are to pass a file descriptor over to our child for
471        it to dump out to.  We can't let it hold open the file descriptor when it
472        forks, as the file descriptor it will dump to can turn out to be one end
473        of pipe that some other process will wait on for EOF. (So as it would
474        be open, the wait would be forever.)  */
475
476     msg.msg_control = control.control;
477     msg.msg_controllen = sizeof(control.control);
478     /* We're a connected socket so we don't need a destination  */
479     msg.msg_name = NULL;
480     msg.msg_namelen = 0;
481     msg.msg_iov = vec;
482     msg.msg_iovlen = 1;
483
484     cmptr = CMSG_FIRSTHDR(&msg);
485     cmptr->cmsg_len = CMSG_LEN(sizeof(int));
486     cmptr->cmsg_level = SOL_SOCKET;
487     cmptr->cmsg_type = SCM_RIGHTS;
488     *((int *)CMSG_DATA(cmptr)) = 1;
489
490     vec[0].iov_base = (void*)&sv;
491     vec[0].iov_len = sizeof(sv);
492     got = sendmsg(sock, &msg, 0);
493
494     if(got < 0) {
495         perror("Debug leaking scalars parent sendmsg failed");
496         abort();
497     }
498     if(got < sizeof(sv)) {
499         perror("Debug leaking scalars parent short sendmsg");
500         abort();
501     }
502
503     /* Return protocol is
504        int:             errno value
505        unsigned char:   length of location string (0 for empty)
506        unsigned char*:  string (not terminated)
507     */
508     vec[0].iov_base = (void*)&returned_errno;
509     vec[0].iov_len = sizeof(returned_errno);
510     vec[1].iov_base = buffer;
511     vec[1].iov_len = 1;
512
513     got = readv(sock, vec, 2);
514
515     if(got < 0) {
516         perror("Debug leaking scalars parent read failed");
517         PerlIO_flush(PerlIO_stderr());
518         abort();
519     }
520     if(got < sizeof(returned_errno) + 1) {
521         perror("Debug leaking scalars parent short read");
522         PerlIO_flush(PerlIO_stderr());
523         abort();
524     }
525
526     if (*buffer) {
527         got = read(sock, buffer + 1, *buffer);
528         if(got < 0) {
529             perror("Debug leaking scalars parent read 2 failed");
530             PerlIO_flush(PerlIO_stderr());
531             abort();
532         }
533
534         if(got < *buffer) {
535             perror("Debug leaking scalars parent short read 2");
536             PerlIO_flush(PerlIO_stderr());
537             abort();
538         }
539     }
540
541     if (returned_errno || *buffer) {
542         Perl_warn(aTHX_ "Debug leaking scalars child failed%s%.*s with errno"
543                   " %d: %s", (*buffer ? " at " : ""), (int) *buffer, buffer + 1,
544                   returned_errno, Strerror(returned_errno));
545     }
546 }
547 #endif
548
549 /*
550 =for apidoc perl_destruct
551
552 Shuts down a Perl interpreter.  See L<perlembed> for a tutorial.
553
554 C<my_perl> points to the Perl interpreter.  It must have been previously
555 created through the use of L</perl_alloc> and L</perl_construct>.  It may
556 have been initialised through L</perl_parse>, and may have been used
557 through L</perl_run> and other means.  This function should be called for
558 any Perl interpreter that has been constructed with L</perl_construct>,
559 even if subsequent operations on it failed, for example if L</perl_parse>
560 returned a non-zero value.
561
562 If the interpreter's C<PL_exit_flags> word has the
563 C<PERL_EXIT_DESTRUCT_END> flag set, then this function will execute code
564 in C<END> blocks before performing the rest of destruction.  If it is
565 desired to make any use of the interpreter between L</perl_parse> and
566 L</perl_destruct> other than just calling L</perl_run>, then this flag
567 should be set early on.  This matters if L</perl_run> will not be called,
568 or if anything else will be done in addition to calling L</perl_run>.
569
570 Returns a value be a suitable value to pass to the C library function
571 C<exit> (or to return from C<main>), to serve as an exit code indicating
572 the nature of the way the interpreter terminated.  This takes into account
573 any failure of L</perl_parse> and any early exit from L</perl_run>.
574 The exit code is of the type required by the host operating system,
575 so because of differing exit code conventions it is not portable to
576 interpret specific numeric values as having specific meanings.
577
578 =cut
579 */
580
581 int
582 perl_destruct(pTHXx)
583 {
584     volatile signed char destruct_level;  /* see possible values in intrpvar.h */
585     HV *hv;
586 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
587     pid_t child;
588 #endif
589     int i;
590
591     PERL_ARGS_ASSERT_PERL_DESTRUCT;
592 #ifndef MULTIPLICITY
593     PERL_UNUSED_ARG(my_perl);
594 #endif
595
596     assert(PL_scopestack_ix == 1);
597
598     /* wait for all pseudo-forked children to finish */
599     PERL_WAIT_FOR_CHILDREN;
600
601     destruct_level = PL_perl_destruct_level;
602     {
603         const char * const s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL");
604         if (s) {
605             int i;
606             if (strEQ(s, "-1")) { /* Special case: modperl folklore. */
607                 i = -1;
608             } else {
609                 UV uv;
610                 if (grok_atoUV(s, &uv, NULL) && uv <= INT_MAX)
611                     i = (int)uv;
612                 else
613                     i = 0;
614             }
615             if (destruct_level < i) destruct_level = i;
616 #ifdef PERL_TRACK_MEMPOOL
617             /* RT #114496, for perl_free */
618             PL_perl_destruct_level = i;
619 #endif
620         }
621     }
622
623     if (PL_exit_flags & PERL_EXIT_DESTRUCT_END) {
624         dJMPENV;
625         int x = 0;
626
627         JMPENV_PUSH(x);
628         PERL_UNUSED_VAR(x);
629         if (PL_endav && !PL_minus_c) {
630             PERL_SET_PHASE(PERL_PHASE_END);
631             call_list(PL_scopestack_ix, PL_endav);
632         }
633         JMPENV_POP;
634     }
635     LEAVE;
636     FREETMPS;
637     assert(PL_scopestack_ix == 0);
638
639     /* normally when we get here, PL_parser should be null due to having
640      * its original (null) value restored by SAVEt_PARSER during leaving
641      * scope (usually before run-time starts in fact).
642      * But if a thread is created within a BEGIN block, the parser is
643      * duped, but the SAVEt_PARSER savestack entry isn't. So PL_parser
644      * never gets cleaned up.
645      * Clean it up here instead. This is a bit of a hack.
646      */
647     if (PL_parser) {
648         /* stop parser_free() stomping on PL_curcop */
649         PL_parser->saved_curcop = PL_curcop;
650         parser_free(PL_parser);
651     }
652
653
654     /* Need to flush since END blocks can produce output */
655     /* flush stdout separately, since we can identify it */
656 #ifdef USE_PERLIO
657     {
658         PerlIO *stdo = PerlIO_stdout();
659         if (*stdo && PerlIO_flush(stdo)) {
660             PerlIO_restore_errno(stdo);
661             if (errno)
662                 PerlIO_printf(PerlIO_stderr(), "Unable to flush stdout: %s\n",
663                     Strerror(errno));
664             if (!STATUS_UNIX)
665                 STATUS_ALL_FAILURE;
666         }
667     }
668 #endif
669     my_fflush_all();
670
671 #ifdef PERL_TRACE_OPS
672     /* dump OP-counts if $ENV{PERL_TRACE_OPS} > 0 */
673     {
674         const char * const ptoenv = PerlEnv_getenv("PERL_TRACE_OPS");
675         UV uv;
676
677         if (!ptoenv || !Perl_grok_atoUV(ptoenv, &uv, NULL)
678             || !(uv > 0))
679         goto no_trace_out;
680     }
681     PerlIO_printf(Perl_debug_log, "Trace of all OPs executed:\n");
682     for (i = 0; i <= OP_max; ++i) {
683         if (PL_op_exec_cnt[i])
684             PerlIO_printf(Perl_debug_log, "  %s: %" UVuf "\n", PL_op_name[i], PL_op_exec_cnt[i]);
685     }
686     /* Utility slot for easily doing little tracing experiments in the runloop: */
687     if (PL_op_exec_cnt[OP_max+1] != 0)
688         PerlIO_printf(Perl_debug_log, "  SPECIAL: %" UVuf "\n", PL_op_exec_cnt[OP_max+1]);
689     PerlIO_printf(Perl_debug_log, "\n");
690  no_trace_out:
691 #endif
692
693
694     if (PL_threadhook(aTHX)) {
695         /* Threads hook has vetoed further cleanup */
696         PL_veto_cleanup = TRUE;
697         return STATUS_EXIT;
698     }
699
700 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
701     if (destruct_level != 0) {
702         /* Fork here to create a child. Our child's job is to preserve the
703            state of scalars prior to destruction, so that we can instruct it
704            to dump any scalars that we later find have leaked.
705            There's no subtlety in this code - it assumes POSIX, and it doesn't
706            fail gracefully  */
707         int fd[2];
708
709         if(PerlSock_socketpair_cloexec(AF_UNIX, SOCK_STREAM, 0, fd)) {
710             perror("Debug leaking scalars socketpair failed");
711             abort();
712         }
713
714         child = fork();
715         if(child == -1) {
716             perror("Debug leaking scalars fork failed");
717             abort();
718         }
719         if (!child) {
720             /* We are the child */
721             const int sock = fd[1];
722             const int debug_fd = PerlIO_fileno(Perl_debug_log);
723             int f;
724             const char *where;
725             /* Our success message is an integer 0, and a char 0  */
726             static const char success[sizeof(int) + 1] = {0};
727
728             close(fd[0]);
729
730             /* We need to close all other file descriptors otherwise we end up
731                with interesting hangs, where the parent closes its end of a
732                pipe, and sits waiting for (another) child to terminate. Only
733                that child never terminates, because it never gets EOF, because
734                we also have the far end of the pipe open.  We even need to
735                close the debugging fd, because sometimes it happens to be one
736                end of a pipe, and a process is waiting on the other end for
737                EOF. Normally it would be closed at some point earlier in
738                destruction, but if we happen to cause the pipe to remain open,
739                EOF never occurs, and we get an infinite hang. Hence all the
740                games to pass in a file descriptor if it's actually needed.  */
741
742             f = sysconf(_SC_OPEN_MAX);
743             if(f < 0) {
744                 where = "sysconf failed";
745                 goto abort;
746             }
747             while (f--) {
748                 if (f == sock)
749                     continue;
750                 close(f);
751             }
752
753             while (1) {
754                 SV *target;
755                 union control_un control;
756                 struct msghdr msg;
757                 struct iovec vec[1];
758                 struct cmsghdr *cmptr;
759                 ssize_t got;
760                 int got_fd;
761
762                 msg.msg_control = control.control;
763                 msg.msg_controllen = sizeof(control.control);
764                 /* We're a connected socket so we don't need a source  */
765                 msg.msg_name = NULL;
766                 msg.msg_namelen = 0;
767                 msg.msg_iov = vec;
768                 msg.msg_iovlen = C_ARRAY_LENGTH(vec);
769
770                 vec[0].iov_base = (void*)&target;
771                 vec[0].iov_len = sizeof(target);
772       
773                 got = recvmsg(sock, &msg, 0);
774
775                 if(got == 0)
776                     break;
777                 if(got < 0) {
778                     where = "recv failed";
779                     goto abort;
780                 }
781                 if(got < sizeof(target)) {
782                     where = "short recv";
783                     goto abort;
784                 }
785
786                 if(!(cmptr = CMSG_FIRSTHDR(&msg))) {
787                     where = "no cmsg";
788                     goto abort;
789                 }
790                 if(cmptr->cmsg_len != CMSG_LEN(sizeof(int))) {
791                     where = "wrong cmsg_len";
792                     goto abort;
793                 }
794                 if(cmptr->cmsg_level != SOL_SOCKET) {
795                     where = "wrong cmsg_level";
796                     goto abort;
797                 }
798                 if(cmptr->cmsg_type != SCM_RIGHTS) {
799                     where = "wrong cmsg_type";
800                     goto abort;
801                 }
802
803                 got_fd = *(int*)CMSG_DATA(cmptr);
804                 /* For our last little bit of trickery, put the file descriptor
805                    back into Perl_debug_log, as if we never actually closed it
806                 */
807                 if(got_fd != debug_fd) {
808                     if (PerlLIO_dup2_cloexec(got_fd, debug_fd) == -1) {
809                         where = "dup2";
810                         goto abort;
811                     }
812                 }
813                 sv_dump(target);
814
815                 PerlIO_flush(Perl_debug_log);
816
817                 got = write(sock, &success, sizeof(success));
818
819                 if(got < 0) {
820                     where = "write failed";
821                     goto abort;
822                 }
823                 if(got < sizeof(success)) {
824                     where = "short write";
825                     goto abort;
826                 }
827             }
828             _exit(0);
829         abort:
830             {
831                 int send_errno = errno;
832                 unsigned char length = (unsigned char) strlen(where);
833                 struct iovec failure[3] = {
834                     {(void*)&send_errno, sizeof(send_errno)},
835                     {&length, 1},
836                     {(void*)where, length}
837                 };
838                 int got = writev(sock, failure, 3);
839                 /* Bad news travels fast. Faster than data. We'll get a SIGPIPE
840                    in the parent if we try to read from the socketpair after the
841                    child has exited, even if there was data to read.
842                    So sleep a bit to give the parent a fighting chance of
843                    reading the data.  */
844                 sleep(2);
845                 _exit((got == -1) ? errno : 0);
846             }
847             /* End of child.  */
848         }
849         PL_dumper_fd = fd[0];
850         close(fd[1]);
851     }
852 #endif
853     
854     /* We must account for everything.  */
855
856     /* Destroy the main CV and syntax tree */
857     /* Set PL_curcop now, because destroying ops can cause new SVs
858        to be generated in Perl_pad_swipe, and when running with
859       -DDEBUG_LEAKING_SCALARS they expect PL_curcop to point to a valid
860        op from which the filename structure member is copied.  */
861     PL_curcop = &PL_compiling;
862     if (PL_main_root) {
863         /* ensure comppad/curpad to refer to main's pad */
864         if (CvPADLIST(PL_main_cv)) {
865             PAD_SET_CUR_NOSAVE(CvPADLIST(PL_main_cv), 1);
866             PL_comppad_name = PadlistNAMES(CvPADLIST(PL_main_cv));
867         }
868         op_free(PL_main_root);
869         PL_main_root = NULL;
870     }
871     PL_main_start = NULL;
872     /* note that  PL_main_cv isn't usually actually freed at this point,
873      * due to the CvOUTSIDE refs from subs compiled within it. It will
874      * get freed once all the subs are freed in sv_clean_all(), for
875      * destruct_level > 0 */
876     SvREFCNT_dec(PL_main_cv);
877     PL_main_cv = NULL;
878     PERL_SET_PHASE(PERL_PHASE_DESTRUCT);
879
880     /* Tell PerlIO we are about to tear things apart in case
881        we have layers which are using resources that should
882        be cleaned up now.
883      */
884
885     PerlIO_destruct(aTHX);
886
887     /*
888      * Try to destruct global references.  We do this first so that the
889      * destructors and destructees still exist.  Some sv's might remain.
890      * Non-referenced objects are on their own.
891      */
892     sv_clean_objs();
893
894     /* unhook hooks which will soon be, or use, destroyed data */
895     SvREFCNT_dec(PL_warnhook);
896     PL_warnhook = NULL;
897     SvREFCNT_dec(PL_diehook);
898     PL_diehook = NULL;
899
900     /* call exit list functions */
901     while (PL_exitlistlen-- > 0)
902         PL_exitlist[PL_exitlistlen].fn(aTHX_ PL_exitlist[PL_exitlistlen].ptr);
903
904     Safefree(PL_exitlist);
905
906     PL_exitlist = NULL;
907     PL_exitlistlen = 0;
908
909     SvREFCNT_dec(PL_registered_mros);
910
911     /* jettison our possibly duplicated environment */
912     /* if PERL_USE_SAFE_PUTENV is defined environ will not have been copied
913      * so we certainly shouldn't free it here
914      */
915 #ifndef PERL_MICRO
916 #if defined(USE_ENVIRON_ARRAY) && !defined(PERL_USE_SAFE_PUTENV)
917     if (environ != PL_origenviron && !PL_use_safe_putenv
918 #ifdef USE_ITHREADS
919         /* only main thread can free environ[0] contents */
920         && PL_curinterp == aTHX
921 #endif
922         )
923     {
924         I32 i;
925
926         for (i = 0; environ[i]; i++)
927             safesysfree(environ[i]);
928
929         /* Must use safesysfree() when working with environ. */
930         safesysfree(environ);           
931
932         environ = PL_origenviron;
933     }
934 #endif
935 #endif /* !PERL_MICRO */
936
937     if (destruct_level == 0) {
938
939         DEBUG_P(debprofdump());
940
941 #if defined(PERLIO_LAYERS)
942         /* No more IO - including error messages ! */
943         PerlIO_cleanup(aTHX);
944 #endif
945
946         CopFILE_free(&PL_compiling);
947
948         /* The exit() function will do everything that needs doing. */
949         return STATUS_EXIT;
950     }
951
952     /* Below, do clean up for when PERL_DESTRUCT_LEVEL is not 0 */
953
954 #ifdef USE_ITHREADS
955     /* the syntax tree is shared between clones
956      * so op_free(PL_main_root) only ReREFCNT_dec's
957      * REGEXPs in the parent interpreter
958      * we need to manually ReREFCNT_dec for the clones
959      */
960     {
961         I32 i = AvFILLp(PL_regex_padav);
962         SV **ary = AvARRAY(PL_regex_padav);
963
964         for (; i; i--) {
965             SvREFCNT_dec(ary[i]);
966             ary[i] = &PL_sv_undef;
967         }
968     }
969 #endif
970
971
972     SvREFCNT_dec(MUTABLE_SV(PL_stashcache));
973     PL_stashcache = NULL;
974
975     /* loosen bonds of global variables */
976
977     /* XXX can PL_parser still be non-null here? */
978     if(PL_parser && PL_parser->rsfp) {
979         (void)PerlIO_close(PL_parser->rsfp);
980         PL_parser->rsfp = NULL;
981     }
982
983     if (PL_minus_F) {
984         Safefree(PL_splitstr);
985         PL_splitstr = NULL;
986     }
987
988     /* switches */
989     PL_minus_n      = FALSE;
990     PL_minus_p      = FALSE;
991     PL_minus_l      = FALSE;
992     PL_minus_a      = FALSE;
993     PL_minus_F      = FALSE;
994     PL_doswitches   = FALSE;
995     PL_dowarn       = G_WARN_OFF;
996 #ifdef PERL_SAWAMPERSAND
997     PL_sawampersand = 0;        /* must save all match strings */
998 #endif
999     PL_unsafe       = FALSE;
1000
1001     Safefree(PL_inplace);
1002     PL_inplace = NULL;
1003     SvREFCNT_dec(PL_patchlevel);
1004
1005     if (PL_e_script) {
1006         SvREFCNT_dec(PL_e_script);
1007         PL_e_script = NULL;
1008     }
1009
1010     PL_perldb = 0;
1011
1012     /* magical thingies */
1013
1014     SvREFCNT_dec(PL_ofsgv);     /* *, */
1015     PL_ofsgv = NULL;
1016
1017     SvREFCNT_dec(PL_ors_sv);    /* $\ */
1018     PL_ors_sv = NULL;
1019
1020     SvREFCNT_dec(PL_rs);        /* $/ */
1021     PL_rs = NULL;
1022
1023     Safefree(PL_osname);        /* $^O */
1024     PL_osname = NULL;
1025
1026     SvREFCNT_dec(PL_statname);
1027     PL_statname = NULL;
1028     PL_statgv = NULL;
1029
1030     /* defgv, aka *_ should be taken care of elsewhere */
1031
1032     /* float buffer */
1033     Safefree(PL_efloatbuf);
1034     PL_efloatbuf = NULL;
1035     PL_efloatsize = 0;
1036
1037     /* startup and shutdown function lists */
1038     SvREFCNT_dec(PL_beginav);
1039     SvREFCNT_dec(PL_beginav_save);
1040     SvREFCNT_dec(PL_endav);
1041     SvREFCNT_dec(PL_checkav);
1042     SvREFCNT_dec(PL_checkav_save);
1043     SvREFCNT_dec(PL_unitcheckav);
1044     SvREFCNT_dec(PL_unitcheckav_save);
1045     SvREFCNT_dec(PL_initav);
1046     PL_beginav = NULL;
1047     PL_beginav_save = NULL;
1048     PL_endav = NULL;
1049     PL_checkav = NULL;
1050     PL_checkav_save = NULL;
1051     PL_unitcheckav = NULL;
1052     PL_unitcheckav_save = NULL;
1053     PL_initav = NULL;
1054
1055     /* shortcuts just get cleared */
1056     PL_hintgv = NULL;
1057     PL_errgv = NULL;
1058     PL_argvoutgv = NULL;
1059     PL_stdingv = NULL;
1060     PL_stderrgv = NULL;
1061     PL_last_in_gv = NULL;
1062     PL_DBsingle = NULL;
1063     PL_DBtrace = NULL;
1064     PL_DBsignal = NULL;
1065     PL_DBsingle_iv = 0;
1066     PL_DBtrace_iv = 0;
1067     PL_DBsignal_iv = 0;
1068     PL_DBcv = NULL;
1069     PL_dbargs = NULL;
1070     PL_debstash = NULL;
1071
1072     SvREFCNT_dec(PL_envgv);
1073     SvREFCNT_dec(PL_incgv);
1074     SvREFCNT_dec(PL_argvgv);
1075     SvREFCNT_dec(PL_replgv);
1076     SvREFCNT_dec(PL_DBgv);
1077     SvREFCNT_dec(PL_DBline);
1078     SvREFCNT_dec(PL_DBsub);
1079     PL_envgv = NULL;
1080     PL_incgv = NULL;
1081     PL_argvgv = NULL;
1082     PL_replgv = NULL;
1083     PL_DBgv = NULL;
1084     PL_DBline = NULL;
1085     PL_DBsub = NULL;
1086
1087     SvREFCNT_dec(PL_argvout_stack);
1088     PL_argvout_stack = NULL;
1089
1090     SvREFCNT_dec(PL_modglobal);
1091     PL_modglobal = NULL;
1092     SvREFCNT_dec(PL_preambleav);
1093     PL_preambleav = NULL;
1094     SvREFCNT_dec(PL_subname);
1095     PL_subname = NULL;
1096 #ifdef PERL_USES_PL_PIDSTATUS
1097     SvREFCNT_dec(PL_pidstatus);
1098     PL_pidstatus = NULL;
1099 #endif
1100     SvREFCNT_dec(PL_toptarget);
1101     PL_toptarget = NULL;
1102     SvREFCNT_dec(PL_bodytarget);
1103     PL_bodytarget = NULL;
1104     PL_formtarget = NULL;
1105
1106     /* free locale stuff */
1107 #ifdef USE_LOCALE_COLLATE
1108     Safefree(PL_collation_name);
1109     PL_collation_name = NULL;
1110 #endif
1111 #if   defined(USE_POSIX_2008_LOCALE)      \
1112  &&   defined(USE_THREAD_SAFE_LOCALE)     \
1113  && ! defined(HAS_QUERYLOCALE)
1114     for (i = 0; i < (int) C_ARRAY_LENGTH(PL_curlocales); i++) {
1115         Safefree(PL_curlocales[i]);
1116         PL_curlocales[i] = NULL;
1117     }
1118 #endif
1119 #ifdef HAS_POSIX_2008_LOCALE
1120     {
1121         /* This also makes sure we aren't using a locale object that gets freed
1122          * below */
1123         const locale_t old_locale = uselocale(LC_GLOBAL_LOCALE);
1124         if (   old_locale != LC_GLOBAL_LOCALE
1125 #  ifdef USE_POSIX_2008_LOCALE
1126             && old_locale != PL_C_locale_obj
1127 #  endif
1128         ) {
1129             DEBUG_Lv(PerlIO_printf(Perl_debug_log,
1130                      "%s:%d: Freeing %p\n", __FILE__, __LINE__, old_locale));
1131             freelocale(old_locale);
1132         }
1133     }
1134 #  ifdef USE_LOCALE_NUMERIC
1135     if (PL_underlying_numeric_obj) {
1136         DEBUG_Lv(PerlIO_printf(Perl_debug_log,
1137                     "%s:%d: Freeing %p\n", __FILE__, __LINE__,
1138                     PL_underlying_numeric_obj));
1139         freelocale(PL_underlying_numeric_obj);
1140         PL_underlying_numeric_obj = (locale_t) NULL;
1141     }
1142 #  endif
1143 #endif
1144 #ifdef USE_LOCALE_NUMERIC
1145     Safefree(PL_numeric_name);
1146     PL_numeric_name = NULL;
1147     SvREFCNT_dec(PL_numeric_radix_sv);
1148     PL_numeric_radix_sv = NULL;
1149 #endif
1150
1151     if (PL_setlocale_buf) {
1152         Safefree(PL_setlocale_buf);
1153         PL_setlocale_buf = NULL;
1154     }
1155
1156     if (PL_langinfo_buf) {
1157         Safefree(PL_langinfo_buf);
1158         PL_langinfo_buf = NULL;
1159     }
1160
1161 #ifdef USE_LOCALE_CTYPE
1162     SvREFCNT_dec(PL_warn_locale);
1163     PL_warn_locale       = NULL;
1164 #endif
1165
1166     SvREFCNT_dec(PL_AboveLatin1);
1167     PL_AboveLatin1 = NULL;
1168     SvREFCNT_dec(PL_Assigned_invlist);
1169     PL_Assigned_invlist = NULL;
1170     SvREFCNT_dec(PL_GCB_invlist);
1171     PL_GCB_invlist = NULL;
1172     SvREFCNT_dec(PL_HasMultiCharFold);
1173     PL_HasMultiCharFold = NULL;
1174     SvREFCNT_dec(PL_InMultiCharFold);
1175     PL_InMultiCharFold = NULL;
1176     SvREFCNT_dec(PL_Latin1);
1177     PL_Latin1 = NULL;
1178     SvREFCNT_dec(PL_LB_invlist);
1179     PL_LB_invlist = NULL;
1180     SvREFCNT_dec(PL_SB_invlist);
1181     PL_SB_invlist = NULL;
1182     SvREFCNT_dec(PL_SCX_invlist);
1183     PL_SCX_invlist = NULL;
1184     SvREFCNT_dec(PL_UpperLatin1);
1185     PL_UpperLatin1 = NULL;
1186     SvREFCNT_dec(PL_in_some_fold);
1187     PL_in_some_fold = NULL;
1188     SvREFCNT_dec(PL_utf8_foldclosures);
1189     PL_utf8_foldclosures = NULL;
1190     SvREFCNT_dec(PL_utf8_idcont);
1191     PL_utf8_idcont = NULL;
1192     SvREFCNT_dec(PL_utf8_idstart);
1193     PL_utf8_idstart = NULL;
1194     SvREFCNT_dec(PL_utf8_perl_idcont);
1195     PL_utf8_perl_idcont = NULL;
1196     SvREFCNT_dec(PL_utf8_perl_idstart);
1197     PL_utf8_perl_idstart = NULL;
1198     SvREFCNT_dec(PL_utf8_xidcont);
1199     PL_utf8_xidcont = NULL;
1200     SvREFCNT_dec(PL_utf8_xidstart);
1201     PL_utf8_xidstart = NULL;
1202     SvREFCNT_dec(PL_WB_invlist);
1203     PL_WB_invlist = NULL;
1204     SvREFCNT_dec(PL_utf8_toupper);
1205     PL_utf8_toupper = NULL;
1206     SvREFCNT_dec(PL_utf8_totitle);
1207     PL_utf8_totitle = NULL;
1208     SvREFCNT_dec(PL_utf8_tolower);
1209     PL_utf8_tolower = NULL;
1210     SvREFCNT_dec(PL_utf8_tofold);
1211     PL_utf8_tofold = NULL;
1212     SvREFCNT_dec(PL_utf8_tosimplefold);
1213     PL_utf8_tosimplefold = NULL;
1214     SvREFCNT_dec(PL_utf8_charname_begin);
1215     PL_utf8_charname_begin = NULL;
1216     SvREFCNT_dec(PL_utf8_charname_continue);
1217     PL_utf8_charname_continue = NULL;
1218     SvREFCNT_dec(PL_utf8_mark);
1219     PL_utf8_mark = NULL;
1220     SvREFCNT_dec(PL_InBitmap);
1221     PL_InBitmap = NULL;
1222     SvREFCNT_dec(PL_CCC_non0_non230);
1223     PL_CCC_non0_non230 = NULL;
1224     SvREFCNT_dec(PL_Private_Use);
1225     PL_Private_Use = NULL;
1226
1227     for (i = 0; i < POSIX_CC_COUNT; i++) {
1228         SvREFCNT_dec(PL_XPosix_ptrs[i]);
1229         PL_XPosix_ptrs[i] = NULL;
1230
1231         if (i != _CC_CASED) {   /* A copy of Alpha */
1232             SvREFCNT_dec(PL_Posix_ptrs[i]);
1233             PL_Posix_ptrs[i] = NULL;
1234         }
1235     }
1236
1237     free_and_set_cop_warnings(&PL_compiling, NULL);
1238     cophh_free(CopHINTHASH_get(&PL_compiling));
1239     CopHINTHASH_set(&PL_compiling, cophh_new_empty());
1240     CopFILE_free(&PL_compiling);
1241
1242     /* Prepare to destruct main symbol table.  */
1243
1244     hv = PL_defstash;
1245     /* break ref loop  *:: <=> %:: */
1246     (void)hv_deletes(hv, "main::", G_DISCARD);
1247     PL_defstash = 0;
1248     SvREFCNT_dec(hv);
1249     SvREFCNT_dec(PL_curstname);
1250     PL_curstname = NULL;
1251
1252     /* clear queued errors */
1253     SvREFCNT_dec(PL_errors);
1254     PL_errors = NULL;
1255
1256     SvREFCNT_dec(PL_isarev);
1257
1258     FREETMPS;
1259     if (destruct_level >= 2) {
1260         if (PL_scopestack_ix != 0)
1261             Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
1262                              "Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
1263                              (long)PL_scopestack_ix);
1264         if (PL_savestack_ix != 0)
1265             Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
1266                              "Unbalanced saves: %ld more saves than restores\n",
1267                              (long)PL_savestack_ix);
1268         if (PL_tmps_floor != -1)
1269             Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),"Unbalanced tmps: %ld more allocs than frees\n",
1270                              (long)PL_tmps_floor + 1);
1271         if (cxstack_ix != -1)
1272             Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),"Unbalanced context: %ld more PUSHes than POPs\n",
1273                              (long)cxstack_ix + 1);
1274     }
1275
1276 #ifdef USE_ITHREADS
1277     SvREFCNT_dec(PL_regex_padav);
1278     PL_regex_padav = NULL;
1279     PL_regex_pad = NULL;
1280 #endif
1281
1282 #ifdef PERL_IMPLICIT_CONTEXT
1283     /* the entries in this list are allocated via SV PVX's, so get freed
1284      * in sv_clean_all */
1285     Safefree(PL_my_cxt_list);
1286 #endif
1287
1288     /* Now absolutely destruct everything, somehow or other, loops or no. */
1289
1290     /* the 2 is for PL_fdpid and PL_strtab */
1291     while (sv_clean_all() > 2)
1292         ;
1293
1294 #ifdef USE_ITHREADS
1295     Safefree(PL_stashpad); /* must come after sv_clean_all */
1296 #endif
1297
1298     AvREAL_off(PL_fdpid);               /* no surviving entries */
1299     SvREFCNT_dec(PL_fdpid);             /* needed in io_close() */
1300     PL_fdpid = NULL;
1301
1302 #ifdef HAVE_INTERP_INTERN
1303     sys_intern_clear();
1304 #endif
1305
1306     /* constant strings */
1307     for (i = 0; i < SV_CONSTS_COUNT; i++) {
1308         SvREFCNT_dec(PL_sv_consts[i]);
1309         PL_sv_consts[i] = NULL;
1310     }
1311
1312     /* Destruct the global string table. */
1313     {
1314         /* Yell and reset the HeVAL() slots that are still holding refcounts,
1315          * so that sv_free() won't fail on them.
1316          * Now that the global string table is using a single hunk of memory
1317          * for both HE and HEK, we either need to explicitly unshare it the
1318          * correct way, or actually free things here.
1319          */
1320         I32 riter = 0;
1321         const I32 max = HvMAX(PL_strtab);
1322         HE * const * const array = HvARRAY(PL_strtab);
1323         HE *hent = array[0];
1324
1325         for (;;) {
1326             if (hent && ckWARN_d(WARN_INTERNAL)) {
1327                 HE * const next = HeNEXT(hent);
1328                 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
1329                      "Unbalanced string table refcount: (%ld) for \"%s\"",
1330                      (long)hent->he_valu.hent_refcount, HeKEY(hent));
1331                 Safefree(hent);
1332                 hent = next;
1333             }
1334             if (!hent) {
1335                 if (++riter > max)
1336                     break;
1337                 hent = array[riter];
1338             }
1339         }
1340
1341         Safefree(array);
1342         HvARRAY(PL_strtab) = 0;
1343         HvTOTALKEYS(PL_strtab) = 0;
1344     }
1345     SvREFCNT_dec(PL_strtab);
1346
1347 #ifdef USE_ITHREADS
1348     /* free the pointer tables used for cloning */
1349     ptr_table_free(PL_ptr_table);
1350     PL_ptr_table = (PTR_TBL_t*)NULL;
1351 #endif
1352
1353     /* free special SVs */
1354
1355     SvREFCNT(&PL_sv_yes) = 0;
1356     sv_clear(&PL_sv_yes);
1357     SvANY(&PL_sv_yes) = NULL;
1358     SvFLAGS(&PL_sv_yes) = 0;
1359
1360     SvREFCNT(&PL_sv_no) = 0;
1361     sv_clear(&PL_sv_no);
1362     SvANY(&PL_sv_no) = NULL;
1363     SvFLAGS(&PL_sv_no) = 0;
1364
1365     SvREFCNT(&PL_sv_zero) = 0;
1366     sv_clear(&PL_sv_zero);
1367     SvANY(&PL_sv_zero) = NULL;
1368     SvFLAGS(&PL_sv_zero) = 0;
1369
1370     {
1371         int i;
1372         for (i=0; i<=2; i++) {
1373             SvREFCNT(PERL_DEBUG_PAD(i)) = 0;
1374             sv_clear(PERL_DEBUG_PAD(i));
1375             SvANY(PERL_DEBUG_PAD(i)) = NULL;
1376             SvFLAGS(PERL_DEBUG_PAD(i)) = 0;
1377         }
1378     }
1379
1380     if (PL_sv_count != 0 && ckWARN_d(WARN_INTERNAL))
1381         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Scalars leaked: %ld\n", (long)PL_sv_count);
1382
1383 #ifdef DEBUG_LEAKING_SCALARS
1384     if (PL_sv_count != 0) {
1385         SV* sva;
1386         SV* sv;
1387         SV* svend;
1388
1389         for (sva = PL_sv_arenaroot; sva; sva = MUTABLE_SV(SvANY(sva))) {
1390             svend = &sva[SvREFCNT(sva)];
1391             for (sv = sva + 1; sv < svend; ++sv) {
1392                 if (SvTYPE(sv) != (svtype)SVTYPEMASK) {
1393                     PerlIO_printf(Perl_debug_log, "leaked: sv=0x%p"
1394                         " flags=0x%" UVxf
1395                         " refcnt=%" UVuf pTHX__FORMAT "\n"
1396                         "\tallocated at %s:%d %s %s (parent 0x%" UVxf ");"
1397                         "serial %" UVuf "\n",
1398                         (void*)sv, (UV)sv->sv_flags, (UV)sv->sv_refcnt
1399                         pTHX__VALUE,
1400                         sv->sv_debug_file ? sv->sv_debug_file : "(unknown)",
1401                         sv->sv_debug_line,
1402                         sv->sv_debug_inpad ? "for" : "by",
1403                         sv->sv_debug_optype ?
1404                             PL_op_name[sv->sv_debug_optype]: "(none)",
1405                         PTR2UV(sv->sv_debug_parent),
1406                         sv->sv_debug_serial
1407                     );
1408 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
1409                     Perl_dump_sv_child(aTHX_ sv);
1410 #endif
1411                 }
1412             }
1413         }
1414     }
1415 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
1416     {
1417         int status;
1418         fd_set rset;
1419         /* Wait for up to 4 seconds for child to terminate.
1420            This seems to be the least effort way of timing out on reaping
1421            its exit status.  */
1422         struct timeval waitfor = {4, 0};
1423         int sock = PL_dumper_fd;
1424
1425         shutdown(sock, 1);
1426         FD_ZERO(&rset);
1427         FD_SET(sock, &rset);
1428         select(sock + 1, &rset, NULL, NULL, &waitfor);
1429         waitpid(child, &status, WNOHANG);
1430         close(sock);
1431     }
1432 #endif
1433 #endif
1434 #ifdef DEBUG_LEAKING_SCALARS_ABORT
1435     if (PL_sv_count)
1436         abort();
1437 #endif
1438     PL_sv_count = 0;
1439
1440 #if defined(PERLIO_LAYERS)
1441     /* No more IO - including error messages ! */
1442     PerlIO_cleanup(aTHX);
1443 #endif
1444
1445     /* sv_undef needs to stay immortal until after PerlIO_cleanup
1446        as currently layers use it rather than NULL as a marker
1447        for no arg - and will try and SvREFCNT_dec it.
1448      */
1449     SvREFCNT(&PL_sv_undef) = 0;
1450     SvREADONLY_off(&PL_sv_undef);
1451
1452     Safefree(PL_origfilename);
1453     PL_origfilename = NULL;
1454     Safefree(PL_reg_curpm);
1455     free_tied_hv_pool();
1456     Safefree(PL_op_mask);
1457     Safefree(PL_psig_name);
1458     PL_psig_name = (SV**)NULL;
1459     PL_psig_ptr = (SV**)NULL;
1460     {
1461         /* We need to NULL PL_psig_pend first, so that
1462            signal handlers know not to use it */
1463         int *psig_save = PL_psig_pend;
1464         PL_psig_pend = (int*)NULL;
1465         Safefree(psig_save);
1466     }
1467     nuke_stacks();
1468     TAINTING_set(FALSE);
1469     TAINT_WARN_set(FALSE);
1470     PL_hints = 0;               /* Reset hints. Should hints be per-interpreter ? */
1471
1472     DEBUG_P(debprofdump());
1473
1474     PL_debug = 0;
1475
1476 #ifdef USE_REENTRANT_API
1477     Perl_reentrant_free(aTHX);
1478 #endif
1479
1480     /* These all point to HVs that are about to be blown away.
1481        Code in core and on CPAN assumes that if the interpreter is re-started
1482        that they will be cleanly NULL or pointing to a valid HV.  */
1483     PL_custom_op_names = NULL;
1484     PL_custom_op_descs = NULL;
1485     PL_custom_ops = NULL;
1486
1487     sv_free_arenas();
1488
1489     while (PL_regmatch_slab) {
1490         regmatch_slab  *s = PL_regmatch_slab;
1491         PL_regmatch_slab = PL_regmatch_slab->next;
1492         Safefree(s);
1493     }
1494
1495     /* As the absolutely last thing, free the non-arena SV for mess() */
1496
1497     if (PL_mess_sv) {
1498         /* we know that type == SVt_PVMG */
1499
1500         /* it could have accumulated taint magic */
1501         MAGIC* mg;
1502         MAGIC* moremagic;
1503         for (mg = SvMAGIC(PL_mess_sv); mg; mg = moremagic) {
1504             moremagic = mg->mg_moremagic;
1505             if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global
1506                 && mg->mg_len >= 0)
1507                 Safefree(mg->mg_ptr);
1508             Safefree(mg);
1509         }
1510
1511         /* we know that type >= SVt_PV */
1512         SvPV_free(PL_mess_sv);
1513         Safefree(SvANY(PL_mess_sv));
1514         Safefree(PL_mess_sv);
1515         PL_mess_sv = NULL;
1516     }
1517     return STATUS_EXIT;
1518 }
1519
1520 /*
1521 =for apidoc perl_free
1522
1523 Releases a Perl interpreter.  See L<perlembed>.
1524
1525 =cut
1526 */
1527
1528 void
1529 perl_free(pTHXx)
1530 {
1531
1532     PERL_ARGS_ASSERT_PERL_FREE;
1533
1534     if (PL_veto_cleanup)
1535         return;
1536
1537 #ifdef PERL_TRACK_MEMPOOL
1538     {
1539         /*
1540          * Don't free thread memory if PERL_DESTRUCT_LEVEL is set to a non-zero
1541          * value as we're probably hunting memory leaks then
1542          */
1543         if (PL_perl_destruct_level == 0) {
1544             const U32 old_debug = PL_debug;
1545             /* Emulate the PerlHost behaviour of free()ing all memory allocated in this
1546                thread at thread exit.  */
1547             if (DEBUG_m_TEST) {
1548                 PerlIO_puts(Perl_debug_log, "Disabling memory debugging as we "
1549                             "free this thread's memory\n");
1550                 PL_debug &= ~ DEBUG_m_FLAG;
1551             }
1552             while(aTHXx->Imemory_debug_header.next != &(aTHXx->Imemory_debug_header)){
1553                 char * next = (char *)(aTHXx->Imemory_debug_header.next);
1554                 Malloc_t ptr = PERL_MEMORY_DEBUG_HEADER_SIZE + next;
1555                 safesysfree(ptr);
1556             }
1557             PL_debug = old_debug;
1558         }
1559     }
1560 #endif
1561
1562 #if defined(WIN32) || defined(NETWARE)
1563 #  if defined(PERL_IMPLICIT_SYS)
1564     {
1565 #    ifdef NETWARE
1566         void *host = nw_internal_host;
1567         PerlMem_free(aTHXx);
1568         nw_delete_internal_host(host);
1569 #    else
1570         void *host = w32_internal_host;
1571         PerlMem_free(aTHXx);
1572         win32_delete_internal_host(host);
1573 #    endif
1574     }
1575 #  else
1576     PerlMem_free(aTHXx);
1577 #  endif
1578 #else
1579     PerlMem_free(aTHXx);
1580 #endif
1581 }
1582
1583 #if defined(USE_ITHREADS)
1584 /* provide destructors to clean up the thread key when libperl is unloaded */
1585 #ifndef WIN32 /* handled during DLL_PROCESS_DETACH in win32/perllib.c */
1586
1587 #if defined(__hpux) && !(defined(__ux_version) && __ux_version <= 1020) && !defined(__GNUC__)
1588 #pragma fini "perl_fini"
1589 #elif defined(__sun) && !defined(__GNUC__)
1590 #pragma fini (perl_fini)
1591 #endif
1592
1593 static void
1594 #if defined(__GNUC__)
1595 __attribute__((destructor))
1596 #endif
1597 perl_fini(void)
1598 {
1599     if (
1600         PL_curinterp && !PL_veto_cleanup)
1601         FREE_THREAD_KEY;
1602 }
1603
1604 #endif /* WIN32 */
1605 #endif /* THREADS */
1606
1607 void
1608 Perl_call_atexit(pTHX_ ATEXIT_t fn, void *ptr)
1609 {
1610     Renew(PL_exitlist, PL_exitlistlen+1, PerlExitListEntry);
1611     PL_exitlist[PL_exitlistlen].fn = fn;
1612     PL_exitlist[PL_exitlistlen].ptr = ptr;
1613     ++PL_exitlistlen;
1614 }
1615
1616 /*
1617 =for apidoc perl_parse
1618
1619 Tells a Perl interpreter to parse a Perl script.  This performs most
1620 of the initialisation of a Perl interpreter.  See L<perlembed> for
1621 a tutorial.
1622
1623 C<my_perl> points to the Perl interpreter that is to parse the script.
1624 It must have been previously created through the use of L</perl_alloc>
1625 and L</perl_construct>.  C<xsinit> points to a callback function that
1626 will be called to set up the ability for this Perl interpreter to load
1627 XS extensions, or may be null to perform no such setup.
1628
1629 C<argc> and C<argv> supply a set of command-line arguments to the Perl
1630 interpreter, as would normally be passed to the C<main> function of
1631 a C program.  C<argv[argc]> must be null.  These arguments are where
1632 the script to parse is specified, either by naming a script file or by
1633 providing a script in a C<-e> option.
1634 If L<C<$0>|perlvar/$0> will be written to in the Perl interpreter, then
1635 the argument strings must be in writable memory, and so mustn't just be
1636 string constants.
1637
1638 C<env> specifies a set of environment variables that will be used by
1639 this Perl interpreter.  If non-null, it must point to a null-terminated
1640 array of environment strings.  If null, the Perl interpreter will use
1641 the environment supplied by the C<environ> global variable.
1642
1643 This function initialises the interpreter, and parses and compiles the
1644 script specified by the command-line arguments.  This includes executing
1645 code in C<BEGIN>, C<UNITCHECK>, and C<CHECK> blocks.  It does not execute
1646 C<INIT> blocks or the main program.
1647
1648 Returns an integer of slightly tricky interpretation.  The correct
1649 use of the return value is as a truth value indicating whether there
1650 was a failure in initialisation.  If zero is returned, this indicates
1651 that initialisation was successful, and it is safe to proceed to call
1652 L</perl_run> and make other use of it.  If a non-zero value is returned,
1653 this indicates some problem that means the interpreter wants to terminate.
1654 The interpreter should not be just abandoned upon such failure; the caller
1655 should proceed to shut the interpreter down cleanly with L</perl_destruct>
1656 and free it with L</perl_free>.
1657
1658 For historical reasons, the non-zero return value also attempts to
1659 be a suitable value to pass to the C library function C<exit> (or to
1660 return from C<main>), to serve as an exit code indicating the nature
1661 of the way initialisation terminated.  However, this isn't portable,
1662 due to differing exit code conventions.  A historical bug is preserved
1663 for the time being: if the Perl built-in C<exit> is called during this
1664 function's execution, with a type of exit entailing a zero exit code
1665 under the host operating system's conventions, then this function
1666 returns zero rather than a non-zero value.  This bug, [perl #2754],
1667 leads to C<perl_run> being called (and therefore C<INIT> blocks and the
1668 main program running) despite a call to C<exit>.  It has been preserved
1669 because a popular module-installing module has come to rely on it and
1670 needs time to be fixed.  This issue is [perl #132577], and the original
1671 bug is due to be fixed in Perl 5.30.
1672
1673 =cut
1674 */
1675
1676 #define SET_CURSTASH(newstash)                       \
1677         if (PL_curstash != newstash) {                \
1678             SvREFCNT_dec(PL_curstash);                 \
1679             PL_curstash = (HV *)SvREFCNT_inc(newstash); \
1680         }
1681
1682 int
1683 perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env)
1684 {
1685     I32 oldscope;
1686     int ret;
1687     dJMPENV;
1688
1689     PERL_ARGS_ASSERT_PERL_PARSE;
1690 #ifndef MULTIPLICITY
1691     PERL_UNUSED_ARG(my_perl);
1692 #endif
1693 #if (defined(USE_HASH_SEED) || defined(USE_HASH_SEED_DEBUG)) && !defined(NO_PERL_HASH_SEED_DEBUG)
1694     {
1695         const char * const s = PerlEnv_getenv("PERL_HASH_SEED_DEBUG");
1696
1697         if (s && strEQ(s, "1")) {
1698             const unsigned char *seed= PERL_HASH_SEED;
1699             const unsigned char *seed_end= PERL_HASH_SEED + PERL_HASH_SEED_BYTES;
1700             PerlIO_printf(Perl_debug_log, "HASH_FUNCTION = %s HASH_SEED = 0x", PERL_HASH_FUNC);
1701             while (seed < seed_end) {
1702                 PerlIO_printf(Perl_debug_log, "%02x", *seed++);
1703             }
1704 #ifdef PERL_HASH_RANDOMIZE_KEYS
1705             PerlIO_printf(Perl_debug_log, " PERTURB_KEYS = %d (%s)",
1706                     PL_HASH_RAND_BITS_ENABLED,
1707                     PL_HASH_RAND_BITS_ENABLED == 0 ? "NO" : PL_HASH_RAND_BITS_ENABLED == 1 ? "RANDOM" : "DETERMINISTIC");
1708 #endif
1709             PerlIO_printf(Perl_debug_log, "\n");
1710         }
1711     }
1712 #endif /* #if (defined(USE_HASH_SEED) ... */
1713
1714 #ifdef __amigaos4__
1715     {
1716         struct NameTranslationInfo nti;
1717         __translate_amiga_to_unix_path_name(&argv[0],&nti); 
1718     }
1719 #endif
1720
1721     {
1722         int i;
1723         assert(argc >= 0);
1724         for(i = 0; i != argc; i++)
1725             assert(argv[i]);
1726         assert(!argv[argc]);
1727     }
1728     PL_origargc = argc;
1729     PL_origargv = argv;
1730
1731     if (PL_origalen != 0) {
1732         PL_origalen = 1; /* don't use old PL_origalen if perl_parse() is called again */
1733     }
1734     else {
1735         /* Set PL_origalen be the sum of the contiguous argv[]
1736          * elements plus the size of the env in case that it is
1737          * contiguous with the argv[].  This is used in mg.c:Perl_magic_set()
1738          * as the maximum modifiable length of $0.  In the worst case
1739          * the area we are able to modify is limited to the size of
1740          * the original argv[0].  (See below for 'contiguous', though.)
1741          * --jhi */
1742          const char *s = NULL;
1743          const UV mask = ~(UV)(PTRSIZE-1);
1744          /* Do the mask check only if the args seem like aligned. */
1745          const UV aligned =
1746            (mask < ~(UV)0) && ((PTR2UV(argv[0]) & mask) == PTR2UV(argv[0]));
1747
1748          /* See if all the arguments are contiguous in memory.  Note
1749           * that 'contiguous' is a loose term because some platforms
1750           * align the argv[] and the envp[].  If the arguments look
1751           * like non-aligned, assume that they are 'strictly' or
1752           * 'traditionally' contiguous.  If the arguments look like
1753           * aligned, we just check that they are within aligned
1754           * PTRSIZE bytes.  As long as no system has something bizarre
1755           * like the argv[] interleaved with some other data, we are
1756           * fine.  (Did I just evoke Murphy's Law?)  --jhi */
1757          if (PL_origargv && PL_origargc >= 1 && (s = PL_origargv[0])) {
1758               int i;
1759               while (*s) s++;
1760               for (i = 1; i < PL_origargc; i++) {
1761                    if ((PL_origargv[i] == s + 1
1762 #ifdef OS2
1763                         || PL_origargv[i] == s + 2
1764 #endif 
1765                             )
1766                        ||
1767                        (aligned &&
1768                         (PL_origargv[i] >  s &&
1769                          PL_origargv[i] <=
1770                          INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask)))
1771                         )
1772                    {
1773                         s = PL_origargv[i];
1774                         while (*s) s++;
1775                    }
1776                    else
1777                         break;
1778               }
1779          }
1780
1781 #ifndef PERL_USE_SAFE_PUTENV
1782          /* Can we grab env area too to be used as the area for $0? */
1783          if (s && PL_origenviron && !PL_use_safe_putenv) {
1784               if ((PL_origenviron[0] == s + 1)
1785                   ||
1786                   (aligned &&
1787                    (PL_origenviron[0] >  s &&
1788                     PL_origenviron[0] <=
1789                     INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask)))
1790                  )
1791               {
1792                    int i;
1793 #ifndef OS2             /* ENVIRON is read by the kernel too. */
1794                    s = PL_origenviron[0];
1795                    while (*s) s++;
1796 #endif
1797                    my_setenv("NoNe  SuCh", NULL);
1798                    /* Force copy of environment. */
1799                    for (i = 1; PL_origenviron[i]; i++) {
1800                         if (PL_origenviron[i] == s + 1
1801                             ||
1802                             (aligned &&
1803                              (PL_origenviron[i] >  s &&
1804                               PL_origenviron[i] <=
1805                               INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask)))
1806                            )
1807                         {
1808                              s = PL_origenviron[i];
1809                              while (*s) s++;
1810                         }
1811                         else
1812                              break;
1813                    }
1814               }
1815          }
1816 #endif /* !defined(PERL_USE_SAFE_PUTENV) */
1817
1818          PL_origalen = s ? s - PL_origargv[0] + 1 : 0;
1819     }
1820
1821     if (PL_do_undump) {
1822
1823         /* Come here if running an undumped a.out. */
1824
1825         PL_origfilename = savepv(argv[0]);
1826         PL_do_undump = FALSE;
1827         cxstack_ix = -1;                /* start label stack again */
1828         init_ids();
1829         assert (!TAINT_get);
1830         TAINT;
1831         set_caret_X();
1832         TAINT_NOT;
1833         init_postdump_symbols(argc,argv,env);
1834         return 0;
1835     }
1836
1837     if (PL_main_root) {
1838         op_free(PL_main_root);
1839         PL_main_root = NULL;
1840     }
1841     PL_main_start = NULL;
1842     SvREFCNT_dec(PL_main_cv);
1843     PL_main_cv = NULL;
1844
1845     time(&PL_basetime);
1846     oldscope = PL_scopestack_ix;
1847     PL_dowarn = G_WARN_OFF;
1848
1849     JMPENV_PUSH(ret);
1850     switch (ret) {
1851     case 0:
1852         parse_body(env,xsinit);
1853         if (PL_unitcheckav) {
1854             call_list(oldscope, PL_unitcheckav);
1855         }
1856         if (PL_checkav) {
1857             PERL_SET_PHASE(PERL_PHASE_CHECK);
1858             call_list(oldscope, PL_checkav);
1859         }
1860         ret = 0;
1861         break;
1862     case 1:
1863         STATUS_ALL_FAILURE;
1864         /* FALLTHROUGH */
1865     case 2:
1866         /* my_exit() was called */
1867         while (PL_scopestack_ix > oldscope)
1868             LEAVE;
1869         FREETMPS;
1870         SET_CURSTASH(PL_defstash);
1871         if (PL_unitcheckav) {
1872             call_list(oldscope, PL_unitcheckav);
1873         }
1874         if (PL_checkav) {
1875             PERL_SET_PHASE(PERL_PHASE_CHECK);
1876             call_list(oldscope, PL_checkav);
1877         }
1878         ret = STATUS_EXIT;
1879         if (ret == 0) {
1880             /*
1881              * At this point we should do
1882              *     ret = 0x100;
1883              * to avoid [perl #2754], but that bugfix has been postponed
1884              * because of the Module::Install breakage it causes
1885              * [perl #132577].
1886              */
1887         }
1888         break;
1889     case 3:
1890         PerlIO_printf(Perl_error_log, "panic: top_env\n");
1891         ret = 1;
1892         break;
1893     }
1894     JMPENV_POP;
1895     return ret;
1896 }
1897
1898 /* This needs to stay in perl.c, as perl.c is compiled with different flags for
1899    miniperl, and we need to see those flags reflected in the values here.  */
1900
1901 /* What this returns is subject to change.  Use the public interface in Config.
1902  */
1903 static void
1904 S_Internals_V(pTHX_ CV *cv)
1905 {
1906     dXSARGS;
1907 #ifdef LOCAL_PATCH_COUNT
1908     const int local_patch_count = LOCAL_PATCH_COUNT;
1909 #else
1910     const int local_patch_count = 0;
1911 #endif
1912     const int entries = 3 + local_patch_count;
1913     int i;
1914     static const char non_bincompat_options[] = 
1915 #  ifdef DEBUGGING
1916                              " DEBUGGING"
1917 #  endif
1918 #  ifdef NO_MATHOMS
1919                              " NO_MATHOMS"
1920 #  endif
1921 #  ifdef NO_HASH_SEED
1922                              " NO_HASH_SEED"
1923 #  endif
1924 #  ifdef NO_TAINT_SUPPORT
1925                              " NO_TAINT_SUPPORT"
1926 #  endif
1927 #  ifdef PERL_BOOL_AS_CHAR
1928                              " PERL_BOOL_AS_CHAR"
1929 #  endif
1930 #  ifdef PERL_COPY_ON_WRITE
1931                              " PERL_COPY_ON_WRITE"
1932 #  endif
1933 #  ifdef PERL_DISABLE_PMC
1934                              " PERL_DISABLE_PMC"
1935 #  endif
1936 #  ifdef PERL_DONT_CREATE_GVSV
1937                              " PERL_DONT_CREATE_GVSV"
1938 #  endif
1939 #  ifdef PERL_EXTERNAL_GLOB
1940                              " PERL_EXTERNAL_GLOB"
1941 #  endif
1942 #  ifdef PERL_HASH_FUNC_SIPHASH
1943                              " PERL_HASH_FUNC_SIPHASH"
1944 #  endif
1945 #  ifdef PERL_HASH_FUNC_SDBM
1946                              " PERL_HASH_FUNC_SDBM"
1947 #  endif
1948 #  ifdef PERL_HASH_FUNC_DJB2
1949                              " PERL_HASH_FUNC_DJB2"
1950 #  endif
1951 #  ifdef PERL_HASH_FUNC_SUPERFAST
1952                              " PERL_HASH_FUNC_SUPERFAST"
1953 #  endif
1954 #  ifdef PERL_HASH_FUNC_MURMUR3
1955                              " PERL_HASH_FUNC_MURMUR3"
1956 #  endif
1957 #  ifdef PERL_HASH_FUNC_ONE_AT_A_TIME
1958                              " PERL_HASH_FUNC_ONE_AT_A_TIME"
1959 #  endif
1960 #  ifdef PERL_HASH_FUNC_ONE_AT_A_TIME_HARD
1961                              " PERL_HASH_FUNC_ONE_AT_A_TIME_HARD"
1962 #  endif
1963 #  ifdef PERL_HASH_FUNC_ONE_AT_A_TIME_OLD
1964                              " PERL_HASH_FUNC_ONE_AT_A_TIME_OLD"
1965 #  endif
1966 #  ifdef PERL_IS_MINIPERL
1967                              " PERL_IS_MINIPERL"
1968 #  endif
1969 #  ifdef PERL_MALLOC_WRAP
1970                              " PERL_MALLOC_WRAP"
1971 #  endif
1972 #  ifdef PERL_MEM_LOG
1973                              " PERL_MEM_LOG"
1974 #  endif
1975 #  ifdef PERL_MEM_LOG_NOIMPL
1976                              " PERL_MEM_LOG_NOIMPL"
1977 #  endif
1978 #  ifdef PERL_OP_PARENT
1979                              " PERL_OP_PARENT"
1980 #  endif
1981 #  ifdef PERL_PERTURB_KEYS_DETERMINISTIC
1982                              " PERL_PERTURB_KEYS_DETERMINISTIC"
1983 #  endif
1984 #  ifdef PERL_PERTURB_KEYS_DISABLED
1985                              " PERL_PERTURB_KEYS_DISABLED"
1986 #  endif
1987 #  ifdef PERL_PERTURB_KEYS_RANDOM
1988                              " PERL_PERTURB_KEYS_RANDOM"
1989 #  endif
1990 #  ifdef PERL_PRESERVE_IVUV
1991                              " PERL_PRESERVE_IVUV"
1992 #  endif
1993 #  ifdef PERL_RELOCATABLE_INCPUSH
1994                              " PERL_RELOCATABLE_INCPUSH"
1995 #  endif
1996 #  ifdef PERL_USE_DEVEL
1997                              " PERL_USE_DEVEL"
1998 #  endif
1999 #  ifdef PERL_USE_SAFE_PUTENV
2000                              " PERL_USE_SAFE_PUTENV"
2001 #  endif
2002 #  ifdef SILENT_NO_TAINT_SUPPORT
2003                              " SILENT_NO_TAINT_SUPPORT"
2004 #  endif
2005 #  ifdef UNLINK_ALL_VERSIONS
2006                              " UNLINK_ALL_VERSIONS"
2007 #  endif
2008 #  ifdef USE_ATTRIBUTES_FOR_PERLIO
2009                              " USE_ATTRIBUTES_FOR_PERLIO"
2010 #  endif
2011 #  ifdef USE_FAST_STDIO
2012                              " USE_FAST_STDIO"
2013 #  endif               
2014 #  ifdef USE_LOCALE
2015                              " USE_LOCALE"
2016 #  endif
2017 #  ifdef USE_LOCALE_CTYPE
2018                              " USE_LOCALE_CTYPE"
2019 #  endif
2020 #  ifdef WIN32_NO_REGISTRY
2021                              " USE_NO_REGISTRY"
2022 #  endif
2023 #  ifdef USE_PERL_ATOF
2024                              " USE_PERL_ATOF"
2025 #  endif               
2026 #  ifdef USE_SITECUSTOMIZE
2027                              " USE_SITECUSTOMIZE"
2028 #  endif               
2029 #  ifdef USE_THREAD_SAFE_LOCALE
2030                              " USE_THREAD_SAFE_LOCALE"
2031 #  endif
2032         ;
2033     PERL_UNUSED_ARG(cv);
2034     PERL_UNUSED_VAR(items);
2035
2036     EXTEND(SP, entries);
2037
2038     PUSHs(sv_2mortal(newSVpv(PL_bincompat_options, 0)));
2039     PUSHs(Perl_newSVpvn_flags(aTHX_ non_bincompat_options,
2040                               sizeof(non_bincompat_options) - 1, SVs_TEMP));
2041
2042 #ifndef PERL_BUILD_DATE
2043 #  ifdef __DATE__
2044 #    ifdef __TIME__
2045 #      define PERL_BUILD_DATE __DATE__ " " __TIME__
2046 #    else
2047 #      define PERL_BUILD_DATE __DATE__
2048 #    endif
2049 #  endif
2050 #endif
2051
2052 #ifdef PERL_BUILD_DATE
2053     PUSHs(Perl_newSVpvn_flags(aTHX_
2054                               STR_WITH_LEN("Compiled at " PERL_BUILD_DATE),
2055                               SVs_TEMP));
2056 #else
2057     PUSHs(&PL_sv_undef);
2058 #endif
2059
2060     for (i = 1; i <= local_patch_count; i++) {
2061         /* This will be an undef, if PL_localpatches[i] is NULL.  */
2062         PUSHs(sv_2mortal(newSVpv(PL_localpatches[i], 0)));
2063     }
2064
2065     XSRETURN(entries);
2066 }
2067
2068 #define INCPUSH_UNSHIFT                 0x01
2069 #define INCPUSH_ADD_OLD_VERS            0x02
2070 #define INCPUSH_ADD_VERSIONED_SUB_DIRS  0x04
2071 #define INCPUSH_ADD_ARCHONLY_SUB_DIRS   0x08
2072 #define INCPUSH_NOT_BASEDIR             0x10
2073 #define INCPUSH_CAN_RELOCATE            0x20
2074 #define INCPUSH_ADD_SUB_DIRS    \
2075     (INCPUSH_ADD_VERSIONED_SUB_DIRS|INCPUSH_ADD_ARCHONLY_SUB_DIRS)
2076
2077 STATIC void *
2078 S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
2079 {
2080     PerlIO *rsfp;
2081     int argc = PL_origargc;
2082     char **argv = PL_origargv;
2083     const char *scriptname = NULL;
2084     bool dosearch = FALSE;
2085     char c;
2086     bool doextract = FALSE;
2087     const char *cddir = NULL;
2088     bool minus_e = FALSE; /* both -e and -E */
2089 #ifdef USE_SITECUSTOMIZE
2090     bool minus_f = FALSE;
2091 #endif
2092     SV *linestr_sv = NULL;
2093     bool add_read_e_script = FALSE;
2094     U32 lex_start_flags = 0;
2095
2096     PERL_SET_PHASE(PERL_PHASE_START);
2097
2098     init_main_stash();
2099
2100     {
2101         const char *s;
2102     for (argc--,argv++; argc > 0; argc--,argv++) {
2103         if (argv[0][0] != '-' || !argv[0][1])
2104             break;
2105         s = argv[0]+1;
2106       reswitch:
2107         switch ((c = *s)) {
2108         case 'C':
2109 #ifndef PERL_STRICT_CR
2110         case '\r':
2111 #endif
2112         case ' ':
2113         case '0':
2114         case 'F':
2115         case 'a':
2116         case 'c':
2117         case 'd':
2118         case 'D':
2119         case 'h':
2120         case 'i':
2121         case 'l':
2122         case 'M':
2123         case 'm':
2124         case 'n':
2125         case 'p':
2126         case 's':
2127         case 'u':
2128         case 'U':
2129         case 'v':
2130         case 'W':
2131         case 'X':
2132         case 'w':
2133             if ((s = moreswitches(s)))
2134                 goto reswitch;
2135             break;
2136
2137         case 't':
2138 #if defined(SILENT_NO_TAINT_SUPPORT)
2139             /* silently ignore */
2140 #elif defined(NO_TAINT_SUPPORT)
2141             Perl_croak_nocontext("This perl was compiled without taint support. "
2142                        "Cowardly refusing to run with -t or -T flags");
2143 #else
2144             CHECK_MALLOC_TOO_LATE_FOR('t');
2145             if( !TAINTING_get ) {
2146                  TAINT_WARN_set(TRUE);
2147                  TAINTING_set(TRUE);
2148             }
2149 #endif
2150             s++;
2151             goto reswitch;
2152         case 'T':
2153 #if defined(SILENT_NO_TAINT_SUPPORT)
2154             /* silently ignore */
2155 #elif defined(NO_TAINT_SUPPORT)
2156             Perl_croak_nocontext("This perl was compiled without taint support. "
2157                        "Cowardly refusing to run with -t or -T flags");
2158 #else
2159             CHECK_MALLOC_TOO_LATE_FOR('T');
2160             TAINTING_set(TRUE);
2161             TAINT_WARN_set(FALSE);
2162 #endif
2163             s++;
2164             goto reswitch;
2165
2166         case 'E':
2167             PL_minus_E = TRUE;
2168             /* FALLTHROUGH */
2169         case 'e':
2170             forbid_setid('e', FALSE);
2171         minus_e = TRUE;
2172             if (!PL_e_script) {
2173                 PL_e_script = newSVpvs("");
2174                 add_read_e_script = TRUE;
2175             }
2176             if (*++s)
2177                 sv_catpv(PL_e_script, s);
2178             else if (argv[1]) {
2179                 sv_catpv(PL_e_script, argv[1]);
2180                 argc--,argv++;
2181             }
2182             else
2183                 Perl_croak(aTHX_ "No code specified for -%c", c);
2184             sv_catpvs(PL_e_script, "\n");
2185             break;
2186
2187         case 'f':
2188 #ifdef USE_SITECUSTOMIZE
2189             minus_f = TRUE;
2190 #endif
2191             s++;
2192             goto reswitch;
2193
2194         case 'I':       /* -I handled both here and in moreswitches() */
2195             forbid_setid('I', FALSE);
2196             if (!*++s && (s=argv[1]) != NULL) {
2197                 argc--,argv++;
2198             }
2199             if (s && *s) {
2200                 STRLEN len = strlen(s);
2201                 incpush(s, len, INCPUSH_ADD_SUB_DIRS|INCPUSH_ADD_OLD_VERS);
2202             }
2203             else
2204                 Perl_croak(aTHX_ "No directory specified for -I");
2205             break;
2206         case 'S':
2207             forbid_setid('S', FALSE);
2208             dosearch = TRUE;
2209             s++;
2210             goto reswitch;
2211         case 'V':
2212             {
2213                 SV *opts_prog;
2214
2215                 if (*++s != ':')  {
2216                     opts_prog = newSVpvs("use Config; Config::_V()");
2217                 }
2218                 else {
2219                     ++s;
2220                     opts_prog = Perl_newSVpvf(aTHX_
2221                                               "use Config; Config::config_vars(qw%c%s%c)",
2222                                               0, s, 0);
2223                     s += strlen(s);
2224                 }
2225                 Perl_av_create_and_push(aTHX_ &PL_preambleav, opts_prog);
2226                 /* don't look for script or read stdin */
2227                 scriptname = BIT_BUCKET;
2228                 goto reswitch;
2229             }
2230         case 'x':
2231             doextract = TRUE;
2232             s++;
2233             if (*s)
2234                 cddir = s;
2235             break;
2236         case 0:
2237             break;
2238         case '-':
2239             if (!*++s || isSPACE(*s)) {
2240                 argc--,argv++;
2241                 goto switch_end;
2242             }
2243             /* catch use of gnu style long options.
2244                Both of these exit immediately.  */
2245             if (strEQ(s, "version"))
2246                 minus_v();
2247             if (strEQ(s, "help"))
2248                 usage();
2249             s--;
2250             /* FALLTHROUGH */
2251         default:
2252             Perl_croak(aTHX_ "Unrecognized switch: -%s  (-h will show valid options)",s);
2253         }
2254     }
2255     }
2256
2257   switch_end:
2258
2259     {
2260         char *s;
2261
2262     if (
2263 #ifndef SECURE_INTERNAL_GETENV
2264         !TAINTING_get &&
2265 #endif
2266         (s = PerlEnv_getenv("PERL5OPT")))
2267     {
2268         while (isSPACE(*s))
2269             s++;
2270         if (*s == '-' && *(s+1) == 'T') {
2271 #if defined(SILENT_NO_TAINT_SUPPORT)
2272             /* silently ignore */
2273 #elif defined(NO_TAINT_SUPPORT)
2274             Perl_croak_nocontext("This perl was compiled without taint support. "
2275                        "Cowardly refusing to run with -t or -T flags");
2276 #else
2277             CHECK_MALLOC_TOO_LATE_FOR('T');
2278             TAINTING_set(TRUE);
2279             TAINT_WARN_set(FALSE);
2280 #endif
2281         }
2282         else {
2283             char *popt_copy = NULL;
2284             while (s && *s) {
2285                 const char *d;
2286                 while (isSPACE(*s))
2287                     s++;
2288                 if (*s == '-') {
2289                     s++;
2290                     if (isSPACE(*s))
2291                         continue;
2292                 }
2293                 d = s;
2294                 if (!*s)
2295                     break;
2296                 if (!memCHRs("CDIMUdmtwW", *s))
2297                     Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s);
2298                 while (++s && *s) {
2299                     if (isSPACE(*s)) {
2300                         if (!popt_copy) {
2301                             popt_copy = SvPVX(sv_2mortal(newSVpv(d,0)));
2302                             s = popt_copy + (s - d);
2303                             d = popt_copy;
2304                         }
2305                         *s++ = '\0';
2306                         break;
2307                     }
2308                 }
2309                 if (*d == 't') {
2310 #if defined(SILENT_NO_TAINT_SUPPORT)
2311             /* silently ignore */
2312 #elif defined(NO_TAINT_SUPPORT)
2313                     Perl_croak_nocontext("This perl was compiled without taint support. "
2314                                "Cowardly refusing to run with -t or -T flags");
2315 #else
2316                     if( !TAINTING_get) {
2317                         TAINT_WARN_set(TRUE);
2318                         TAINTING_set(TRUE);
2319                     }
2320 #endif
2321                 } else {
2322                     moreswitches(d);
2323                 }
2324             }
2325         }
2326     }
2327     }
2328
2329 #ifndef NO_PERL_INTERNAL_RAND_SEED
2330     /* If we're not set[ug]id, we might have honored
2331        PERL_INTERNAL_RAND_SEED in perl_construct().
2332        At this point command-line options have been parsed, so if
2333        we're now tainting and not set[ug]id re-seed.
2334        This could possibly be wasteful if PERL_INTERNAL_RAND_SEED is invalid,
2335        but avoids duplicating the logic from perl_construct().
2336     */
2337     if (TAINT_get &&
2338         PerlProc_getuid() == PerlProc_geteuid() &&
2339         PerlProc_getgid() == PerlProc_getegid()) {
2340         Perl_drand48_init_r(&PL_internal_random_state, seed());
2341     }
2342 #endif
2343
2344     /* Set $^X early so that it can be used for relocatable paths in @INC  */
2345     /* and for SITELIB_EXP in USE_SITECUSTOMIZE                            */
2346     assert (!TAINT_get);
2347     TAINT;
2348     set_caret_X();
2349     TAINT_NOT;
2350
2351 #if defined(USE_SITECUSTOMIZE)
2352     if (!minus_f) {
2353         /* The games with local $! are to avoid setting errno if there is no
2354            sitecustomize script.  "q%c...%c", 0, ..., 0 becomes "q\0...\0",
2355            ie a q() operator with a NUL byte as a the delimiter. This avoids
2356            problems with pathnames containing (say) '  */
2357 #  ifdef PERL_IS_MINIPERL
2358         AV *const inc = GvAV(PL_incgv);
2359         SV **const inc0 = inc ? av_fetch(inc, 0, FALSE) : NULL;
2360
2361         if (inc0) {
2362             /* if lib/buildcustomize.pl exists, it should not fail. If it does,
2363                it should be reported immediately as a build failure.  */
2364             (void)Perl_av_create_and_unshift_one(aTHX_ &PL_preambleav,
2365                                                  Perl_newSVpvf(aTHX_
2366                 "BEGIN { my $f = q%c%s%" SVf "/buildcustomize.pl%c; "
2367                         "do {local $!; -f $f }"
2368                         " and do $f || die $@ || qq '$f: $!' }",
2369                                 0, (TAINTING_get ? "./" : ""), SVfARG(*inc0), 0));
2370         }
2371 #  else
2372         /* SITELIB_EXP is a function call on Win32.  */
2373         const char *const raw_sitelib = SITELIB_EXP;
2374         if (raw_sitelib) {
2375             /* process .../.. if PERL_RELOCATABLE_INC is defined */
2376             SV *sitelib_sv = mayberelocate(raw_sitelib, strlen(raw_sitelib),
2377                                            INCPUSH_CAN_RELOCATE);
2378             const char *const sitelib = SvPVX(sitelib_sv);
2379             (void)Perl_av_create_and_unshift_one(aTHX_ &PL_preambleav,
2380                                                  Perl_newSVpvf(aTHX_
2381                                                                "BEGIN { do {local $!; -f q%c%s/sitecustomize.pl%c} && do q%c%s/sitecustomize.pl%c }",
2382                                                                0, SVfARG(sitelib), 0,
2383                                                                0, SVfARG(sitelib), 0));
2384             assert (SvREFCNT(sitelib_sv) == 1);
2385             SvREFCNT_dec(sitelib_sv);
2386         }
2387 #  endif
2388     }
2389 #endif
2390
2391     if (!scriptname)
2392         scriptname = argv[0];
2393     if (PL_e_script) {
2394         argc++,argv--;
2395         scriptname = BIT_BUCKET;        /* don't look for script or read stdin */
2396     }
2397     else if (scriptname == NULL) {
2398 #ifdef MSDOS
2399         if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) )
2400             moreswitches("h");
2401 #endif
2402         scriptname = "-";
2403     }
2404
2405     assert (!TAINT_get);
2406     init_perllib();
2407
2408     {
2409         bool suidscript = FALSE;
2410
2411         rsfp = open_script(scriptname, dosearch, &suidscript);
2412         if (!rsfp) {
2413             rsfp = PerlIO_stdin();
2414             lex_start_flags = LEX_DONT_CLOSE_RSFP;
2415         }
2416
2417         validate_suid(rsfp);
2418
2419 #ifndef PERL_MICRO
2420 #  if defined(SIGCHLD) || defined(SIGCLD)
2421         {
2422 #  ifndef SIGCHLD
2423 #    define SIGCHLD SIGCLD
2424 #  endif
2425             Sighandler_t sigstate = rsignal_state(SIGCHLD);
2426             if (sigstate == (Sighandler_t) SIG_IGN) {
2427                 Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL),
2428                                "Can't ignore signal CHLD, forcing to default");
2429                 (void)rsignal(SIGCHLD, (Sighandler_t)SIG_DFL);
2430             }
2431         }
2432 #  endif
2433 #endif
2434
2435         if (doextract) {
2436
2437             /* This will croak if suidscript is true, as -x cannot be used with
2438                setuid scripts.  */
2439             forbid_setid('x', suidscript);
2440             /* Hence you can't get here if suidscript is true */
2441
2442             linestr_sv = newSV_type(SVt_PV);
2443             lex_start_flags |= LEX_START_COPIED;
2444             find_beginning(linestr_sv, rsfp);
2445             if (cddir && PerlDir_chdir( (char *)cddir ) < 0)
2446                 Perl_croak(aTHX_ "Can't chdir to %s",cddir);
2447         }
2448     }
2449
2450     PL_main_cv = PL_compcv = MUTABLE_CV(newSV_type(SVt_PVCV));
2451     CvUNIQUE_on(PL_compcv);
2452
2453     CvPADLIST_set(PL_compcv, pad_new(0));
2454
2455     PL_isarev = newHV();
2456
2457     boot_core_PerlIO();
2458     boot_core_UNIVERSAL();
2459     boot_core_mro();
2460     newXS("Internals::V", S_Internals_V, __FILE__);
2461
2462     if (xsinit)
2463         (*xsinit)(aTHX);        /* in case linked C routines want magical variables */
2464 #ifndef PERL_MICRO
2465 #if defined(VMS) || defined(WIN32) || defined(DJGPP) || defined(__CYGWIN__)
2466     init_os_extras();
2467 #endif
2468 #endif
2469
2470 #ifdef USE_SOCKS
2471 #   ifdef HAS_SOCKS5_INIT
2472     socks5_init(argv[0]);
2473 #   else
2474     SOCKSinit(argv[0]);
2475 #   endif
2476 #endif
2477
2478     init_predump_symbols();
2479     /* init_postdump_symbols not currently designed to be called */
2480     /* more than once (ENV isn't cleared first, for example)     */
2481     /* But running with -u leaves %ENV & @ARGV undefined!    XXX */
2482     if (!PL_do_undump)
2483         init_postdump_symbols(argc,argv,env);
2484
2485     /* PL_unicode is turned on by -C, or by $ENV{PERL_UNICODE},
2486      * or explicitly in some platforms.
2487      * PL_utf8locale is conditionally turned on by
2488      * locale.c:Perl_init_i18nl10n() if the environment
2489      * look like the user wants to use UTF-8. */
2490 #  ifndef PERL_IS_MINIPERL
2491     if (PL_unicode) {
2492          /* Requires init_predump_symbols(). */
2493          if (!(PL_unicode & PERL_UNICODE_LOCALE_FLAG) || PL_utf8locale) {
2494               IO* io;
2495               PerlIO* fp;
2496               SV* sv;
2497
2498               /* Turn on UTF-8-ness on STDIN, STDOUT, STDERR
2499                * and the default open disciplines. */
2500               if ((PL_unicode & PERL_UNICODE_STDIN_FLAG) &&
2501                   PL_stdingv  && (io = GvIO(PL_stdingv)) &&
2502                   (fp = IoIFP(io)))
2503                    PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
2504               if ((PL_unicode & PERL_UNICODE_STDOUT_FLAG) &&
2505                   PL_defoutgv && (io = GvIO(PL_defoutgv)) &&
2506                   (fp = IoOFP(io)))
2507                    PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
2508               if ((PL_unicode & PERL_UNICODE_STDERR_FLAG) &&
2509                   PL_stderrgv && (io = GvIO(PL_stderrgv)) &&
2510                   (fp = IoOFP(io)))
2511                    PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
2512               if ((PL_unicode & PERL_UNICODE_INOUT_FLAG) &&
2513                   (sv = GvSV(gv_fetchpvs("\017PEN", GV_ADD|GV_NOTQUAL,
2514                                          SVt_PV)))) {
2515                    U32 in  = PL_unicode & PERL_UNICODE_IN_FLAG;
2516                    U32 out = PL_unicode & PERL_UNICODE_OUT_FLAG;
2517                    if (in) {
2518                         if (out)
2519                              sv_setpvs(sv, ":utf8\0:utf8");
2520                         else
2521                              sv_setpvs(sv, ":utf8\0");
2522                    }
2523                    else if (out)
2524                         sv_setpvs(sv, "\0:utf8");
2525                    SvSETMAGIC(sv);
2526               }
2527          }
2528     }
2529 #endif
2530
2531     {
2532         const char *s;
2533     if ((s = PerlEnv_getenv("PERL_SIGNALS"))) {
2534          if (strEQ(s, "unsafe"))
2535               PL_signals |=  PERL_SIGNALS_UNSAFE_FLAG;
2536          else if (strEQ(s, "safe"))
2537               PL_signals &= ~PERL_SIGNALS_UNSAFE_FLAG;
2538          else
2539               Perl_croak(aTHX_ "PERL_SIGNALS illegal: \"%s\"", s);
2540     }
2541     }
2542
2543
2544     lex_start(linestr_sv, rsfp, lex_start_flags);
2545     SvREFCNT_dec(linestr_sv);
2546
2547     PL_subname = newSVpvs("main");
2548
2549     if (add_read_e_script)
2550         filter_add(read_e_script, NULL);
2551
2552     /* now parse the script */
2553     if (minus_e == FALSE)
2554         PL_hints |= HINTS_DEFAULT; /* after init_main_stash ; need to be after init_predump_symbols */
2555
2556     SETERRNO(0,SS_NORMAL);
2557     if (yyparse(GRAMPROG) || PL_parser->error_count) {
2558         abort_execution("", PL_origfilename);
2559     }
2560     CopLINE_set(PL_curcop, 0);
2561     SET_CURSTASH(PL_defstash);
2562     if (PL_e_script) {
2563         SvREFCNT_dec(PL_e_script);
2564         PL_e_script = NULL;
2565     }
2566
2567     if (PL_do_undump)
2568         my_unexec();
2569
2570     if (isWARN_ONCE) {
2571         SAVECOPFILE(PL_curcop);
2572         SAVECOPLINE(PL_curcop);
2573         gv_check(PL_defstash);
2574     }
2575
2576     LEAVE;
2577     FREETMPS;
2578
2579 #ifdef MYMALLOC
2580     {
2581         const char *s;
2582         UV uv;
2583         s = PerlEnv_getenv("PERL_DEBUG_MSTATS");
2584         if (s && grok_atoUV(s, &uv, NULL) && uv >= 2)
2585             dump_mstats("after compilation:");
2586     }
2587 #endif
2588
2589     ENTER;
2590     PL_restartjmpenv = NULL;
2591     PL_restartop = 0;
2592     return NULL;
2593 }
2594
2595 /*
2596 =for apidoc perl_run
2597
2598 Tells a Perl interpreter to run its main program.  See L<perlembed>
2599 for a tutorial.
2600
2601 C<my_perl> points to the Perl interpreter.  It must have been previously
2602 created through the use of L</perl_alloc> and L</perl_construct>, and
2603 initialised through L</perl_parse>.  This function should not be called
2604 if L</perl_parse> returned a non-zero value, indicating a failure in
2605 initialisation or compilation.
2606
2607 This function executes code in C<INIT> blocks, and then executes the
2608 main program.  The code to be executed is that established by the prior
2609 call to L</perl_parse>.  If the interpreter's C<PL_exit_flags> word
2610 does not have the C<PERL_EXIT_DESTRUCT_END> flag set, then this function
2611 will also execute code in C<END> blocks.  If it is desired to make any
2612 further use of the interpreter after calling this function, then C<END>
2613 blocks should be postponed to L</perl_destruct> time by setting that flag.
2614
2615 Returns an integer of slightly tricky interpretation.  The correct use
2616 of the return value is as a truth value indicating whether the program
2617 terminated non-locally.  If zero is returned, this indicates that
2618 the program ran to completion, and it is safe to make other use of the
2619 interpreter (provided that the C<PERL_EXIT_DESTRUCT_END> flag was set as
2620 described above).  If a non-zero value is returned, this indicates that
2621 the interpreter wants to terminate early.  The interpreter should not be
2622 just abandoned because of this desire to terminate; the caller should
2623 proceed to shut the interpreter down cleanly with L</perl_destruct>
2624 and free it with L</perl_free>.
2625
2626 For historical reasons, the non-zero return value also attempts to
2627 be a suitable value to pass to the C library function C<exit> (or to
2628 return from C<main>), to serve as an exit code indicating the nature of
2629 the way the program terminated.  However, this isn't portable, due to
2630 differing exit code conventions.  An attempt is made to return an exit
2631 code of the type required by the host operating system, but because
2632 it is constrained to be non-zero, it is not necessarily possible to
2633 indicate every type of exit.  It is only reliable on Unix, where a zero
2634 exit code can be augmented with a set bit that will be ignored.  In any
2635 case, this function is not the correct place to acquire an exit code:
2636 one should get that from L</perl_destruct>.
2637
2638 =cut
2639 */
2640
2641 int
2642 perl_run(pTHXx)
2643 {
2644     I32 oldscope;
2645     int ret = 0;
2646     dJMPENV;
2647
2648     PERL_ARGS_ASSERT_PERL_RUN;
2649 #ifndef MULTIPLICITY
2650     PERL_UNUSED_ARG(my_perl);
2651 #endif
2652
2653     oldscope = PL_scopestack_ix;
2654 #ifdef VMS
2655     VMSISH_HUSHED = 0;
2656 #endif
2657
2658     JMPENV_PUSH(ret);
2659     switch (ret) {
2660     case 1:
2661         cxstack_ix = -1;                /* start context stack again */
2662         goto redo_body;
2663     case 0:                             /* normal completion */
2664  redo_body:
2665         run_body(oldscope);
2666         /* FALLTHROUGH */
2667     case 2:                             /* my_exit() */
2668         while (PL_scopestack_ix > oldscope)
2669             LEAVE;
2670         FREETMPS;
2671         SET_CURSTASH(PL_defstash);
2672         if (!(PL_exit_flags & PERL_EXIT_DESTRUCT_END) &&
2673             PL_endav && !PL_minus_c) {
2674             PERL_SET_PHASE(PERL_PHASE_END);
2675             call_list(oldscope, PL_endav);
2676         }
2677 #ifdef MYMALLOC
2678         if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
2679             dump_mstats("after execution:  ");
2680 #endif
2681         ret = STATUS_EXIT;
2682         break;
2683     case 3:
2684         if (PL_restartop) {
2685             POPSTACK_TO(PL_mainstack);
2686             goto redo_body;
2687         }
2688         PerlIO_printf(Perl_error_log, "panic: restartop in perl_run\n");
2689         FREETMPS;
2690         ret = 1;
2691         break;
2692     }
2693
2694     JMPENV_POP;
2695     return ret;
2696 }
2697
2698 STATIC void
2699 S_run_body(pTHX_ I32 oldscope)
2700 {
2701     DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support (0x%x).\n",
2702                     PL_sawampersand ? "Enabling" : "Omitting",
2703                     (unsigned int)(PL_sawampersand)));
2704
2705     if (!PL_restartop) {
2706 #ifdef DEBUGGING
2707         if (DEBUG_x_TEST || DEBUG_B_TEST)
2708             dump_all_perl(!DEBUG_B_TEST);
2709         if (!DEBUG_q_TEST)
2710           PERL_DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
2711 #endif
2712
2713         if (PL_minus_c) {
2714             PerlIO_printf(Perl_error_log, "%s syntax OK\n", PL_origfilename);
2715             my_exit(0);
2716         }
2717         if (PERLDB_SINGLE && PL_DBsingle)
2718             PL_DBsingle_iv = 1;
2719         if (PL_initav) {
2720             PERL_SET_PHASE(PERL_PHASE_INIT);
2721             call_list(oldscope, PL_initav);
2722         }
2723 #ifdef PERL_DEBUG_READONLY_OPS
2724         if (PL_main_root && PL_main_root->op_slabbed)
2725             Slab_to_ro(OpSLAB(PL_main_root));
2726 #endif
2727     }
2728
2729     /* do it */
2730
2731     PERL_SET_PHASE(PERL_PHASE_RUN);
2732
2733     if (PL_restartop) {
2734         PL_restartjmpenv = NULL;
2735         PL_op = PL_restartop;
2736         PL_restartop = 0;
2737         CALLRUNOPS(aTHX);
2738     }
2739     else if (PL_main_start) {
2740         CvDEPTH(PL_main_cv) = 1;
2741         PL_op = PL_main_start;
2742         CALLRUNOPS(aTHX);
2743     }
2744     my_exit(0);
2745     NOT_REACHED; /* NOTREACHED */
2746 }
2747
2748 /*
2749 =for apidoc_section $SV
2750
2751 =for apidoc get_sv
2752
2753 Returns the SV of the specified Perl scalar.  C<flags> are passed to
2754 C<gv_fetchpv>.  If C<GV_ADD> is set and the
2755 Perl variable does not exist then it will be created.  If C<flags> is zero
2756 and the variable does not exist then NULL is returned.
2757
2758 =cut
2759 */
2760
2761 SV*
2762 Perl_get_sv(pTHX_ const char *name, I32 flags)
2763 {
2764     GV *gv;
2765
2766     PERL_ARGS_ASSERT_GET_SV;
2767
2768     gv = gv_fetchpv(name, flags, SVt_PV);
2769     if (gv)
2770         return GvSV(gv);
2771     return NULL;
2772 }
2773
2774 /*
2775 =for apidoc_section $AV
2776
2777 =for apidoc get_av
2778
2779 Returns the AV of the specified Perl global or package array with the given
2780 name (so it won't work on lexical variables).  C<flags> are passed 
2781 to C<gv_fetchpv>.  If C<GV_ADD> is set and the
2782 Perl variable does not exist then it will be created.  If C<flags> is zero
2783 and the variable does not exist then NULL is returned.
2784
2785 Perl equivalent: C<@{"$name"}>.
2786
2787 =cut
2788 */
2789
2790 AV*
2791 Perl_get_av(pTHX_ const char *name, I32 flags)
2792 {
2793     GV* const gv = gv_fetchpv(name, flags, SVt_PVAV);
2794
2795     PERL_ARGS_ASSERT_GET_AV;
2796
2797     if (flags)
2798         return GvAVn(gv);
2799     if (gv)
2800         return GvAV(gv);
2801     return NULL;
2802 }
2803
2804 /*
2805 =for apidoc_section $HV
2806
2807 =for apidoc get_hv
2808
2809 Returns the HV of the specified Perl hash.  C<flags> are passed to
2810 C<gv_fetchpv>.  If C<GV_ADD> is set and the
2811 Perl variable does not exist then it will be created.  If C<flags> is zero
2812 and the variable does not exist then C<NULL> is returned.
2813
2814 =cut
2815 */
2816
2817 HV*
2818 Perl_get_hv(pTHX_ const char *name, I32 flags)
2819 {
2820     GV* const gv = gv_fetchpv(name, flags, SVt_PVHV);
2821
2822     PERL_ARGS_ASSERT_GET_HV;
2823
2824     if (flags)
2825         return GvHVn(gv);
2826     if (gv)
2827         return GvHV(gv);
2828     return NULL;
2829 }
2830
2831 /*
2832 =for apidoc_section $CV
2833
2834 =for apidoc get_cvn_flags
2835
2836 Returns the CV of the specified Perl subroutine.  C<flags> are passed to
2837 C<gv_fetchpvn_flags>.  If C<GV_ADD> is set and the Perl subroutine does not
2838 exist then it will be declared (which has the same effect as saying
2839 C<sub name;>).  If C<GV_ADD> is not set and the subroutine does not exist
2840 then NULL is returned.
2841
2842 =for apidoc get_cv
2843
2844 Uses C<strlen> to get the length of C<name>, then calls C<get_cvn_flags>.
2845
2846 =cut
2847 */
2848
2849 CV*
2850 Perl_get_cvn_flags(pTHX_ const char *name, STRLEN len, I32 flags)
2851 {
2852     GV* const gv = gv_fetchpvn_flags(name, len, flags, SVt_PVCV);
2853
2854     PERL_ARGS_ASSERT_GET_CVN_FLAGS;
2855
2856     if (gv && UNLIKELY(SvROK(gv)) && SvTYPE(SvRV((SV *)gv)) == SVt_PVCV)
2857         return (CV*)SvRV((SV *)gv);
2858
2859     /* XXX this is probably not what they think they're getting.
2860      * It has the same effect as "sub name;", i.e. just a forward
2861      * declaration! */
2862     if ((flags & ~GV_NOADD_MASK) && !GvCVu(gv)) {
2863         return newSTUB(gv,0);
2864     }
2865     if (gv)
2866         return GvCVu(gv);
2867     return NULL;
2868 }
2869
2870 /* Nothing in core calls this now, but we can't replace it with a macro and
2871    move it to mathoms.c as a macro would evaluate name twice.  */
2872 CV*
2873 Perl_get_cv(pTHX_ const char *name, I32 flags)
2874 {
2875     PERL_ARGS_ASSERT_GET_CV;
2876
2877     return get_cvn_flags(name, strlen(name), flags);
2878 }
2879
2880 /* Be sure to refetch the stack pointer after calling these routines. */
2881
2882 /*
2883
2884 =for apidoc_section $callback
2885
2886 =for apidoc call_argv
2887
2888 Performs a callback to the specified named and package-scoped Perl subroutine 
2889 with C<argv> (a C<NULL>-terminated array of strings) as arguments.  See
2890 L<perlcall>.
2891
2892 Approximate Perl equivalent: C<&{"$sub_name"}(@$argv)>.
2893
2894 =cut
2895 */
2896
2897 I32
2898 Perl_call_argv(pTHX_ const char *sub_name, I32 flags, char **argv)
2899
2900                         /* See G_* flags in cop.h */
2901                         /* null terminated arg list */
2902 {
2903     dSP;
2904
2905     PERL_ARGS_ASSERT_CALL_ARGV;
2906
2907     PUSHMARK(SP);
2908     while (*argv) {
2909         mXPUSHs(newSVpv(*argv,0));
2910         argv++;
2911     }
2912     PUTBACK;
2913     return call_pv(sub_name, flags);
2914 }
2915
2916 /*
2917 =for apidoc call_pv
2918
2919 Performs a callback to the specified Perl sub.  See L<perlcall>.
2920
2921 =cut
2922 */
2923
2924 I32
2925 Perl_call_pv(pTHX_ const char *sub_name, I32 flags)
2926                         /* name of the subroutine */
2927                         /* See G_* flags in cop.h */
2928 {
2929     PERL_ARGS_ASSERT_CALL_PV;
2930
2931     return call_sv(MUTABLE_SV(get_cv(sub_name, GV_ADD)), flags);
2932 }
2933
2934 /*
2935 =for apidoc call_method
2936
2937 Performs a callback to the specified Perl method.  The blessed object must
2938 be on the stack.  See L<perlcall>.
2939
2940 =cut
2941 */
2942
2943 I32
2944 Perl_call_method(pTHX_ const char *methname, I32 flags)
2945                         /* name of the subroutine */
2946                         /* See G_* flags in cop.h */
2947 {
2948     STRLEN len;
2949     SV* sv;
2950     PERL_ARGS_ASSERT_CALL_METHOD;
2951
2952     len = strlen(methname);
2953     sv = flags & G_METHOD_NAMED
2954         ? sv_2mortal(newSVpvn_share(methname, len,0))
2955         : newSVpvn_flags(methname, len, SVs_TEMP);
2956
2957     return call_sv(sv, flags | G_METHOD);
2958 }
2959
2960 /* May be called with any of a CV, a GV, or an SV containing the name. */
2961 /*
2962 =for apidoc call_sv
2963
2964 Performs a callback to the Perl sub specified by the SV.
2965
2966 If neither the C<G_METHOD> nor C<G_METHOD_NAMED> flag is supplied, the
2967 SV may be any of a CV, a GV, a reference to a CV, a reference to a GV
2968 or C<SvPV(sv)> will be used as the name of the sub to call.
2969
2970 If the C<G_METHOD> flag is supplied, the SV may be a reference to a CV or
2971 C<SvPV(sv)> will be used as the name of the method to call.
2972
2973 If the C<G_METHOD_NAMED> flag is supplied, C<SvPV(sv)> will be used as
2974 the name of the method to call.
2975
2976 Some other values are treated specially for internal use and should
2977 not be depended on.
2978
2979 See L<perlcall>.
2980
2981 =for apidoc Amnh||G_METHOD
2982 =for apidoc Amnh||G_METHOD_NAMED
2983
2984 =cut
2985 */
2986
2987 I32
2988 Perl_call_sv(pTHX_ SV *sv, volatile I32 flags)
2989                         /* See G_* flags in cop.h */
2990 {
2991     LOGOP myop;         /* fake syntax tree node */
2992     METHOP method_op;
2993     I32 oldmark;
2994     volatile I32 retval = 0;
2995     bool oldcatch = CATCH_GET;
2996     int ret;
2997     OP* const oldop = PL_op;
2998     dJMPENV;
2999
3000     PERL_ARGS_ASSERT_CALL_SV;
3001
3002     if (flags & G_DISCARD) {
3003         ENTER;
3004         SAVETMPS;
3005     }
3006     if (!(flags & G_WANT)) {
3007         /* Backwards compatibility - as G_SCALAR was 0, it could be omitted.
3008          */
3009         flags |= G_SCALAR;
3010     }
3011
3012     Zero(&myop, 1, LOGOP);
3013     if (!(flags & G_NOARGS))
3014         myop.op_flags |= OPf_STACKED;
3015     myop.op_flags |= OP_GIMME_REVERSE(flags);
3016     SAVEOP();
3017     PL_op = (OP*)&myop;
3018
3019     if (!(flags & G_METHOD_NAMED)) {
3020         dSP;
3021         EXTEND(SP, 1);
3022         PUSHs(sv);
3023         PUTBACK;
3024     }
3025     oldmark = TOPMARK;
3026
3027     if (PERLDB_SUB && PL_curstash != PL_debstash
3028            /* Handle first BEGIN of -d. */
3029           && (PL_DBcv || (PL_DBcv = GvCV(PL_DBsub)))
3030            /* Try harder, since this may have been a sighandler, thus
3031             * curstash may be meaningless. */
3032           && (SvTYPE(sv) != SVt_PVCV || CvSTASH((const CV *)sv) != PL_debstash)
3033           && !(flags & G_NODEBUG))
3034         myop.op_private |= OPpENTERSUB_DB;
3035
3036     if (flags & (G_METHOD|G_METHOD_NAMED)) {
3037         Zero(&method_op, 1, METHOP);
3038         method_op.op_next = (OP*)&myop;
3039         PL_op = (OP*)&method_op;
3040         if ( flags & G_METHOD_NAMED ) {
3041             method_op.op_ppaddr = PL_ppaddr[OP_METHOD_NAMED];
3042             method_op.op_type = OP_METHOD_NAMED;
3043             method_op.op_u.op_meth_sv = sv;
3044         } else {
3045             method_op.op_ppaddr = PL_ppaddr[OP_METHOD];
3046             method_op.op_type = OP_METHOD;
3047         }
3048         myop.op_ppaddr = PL_ppaddr[OP_ENTERSUB];
3049         myop.op_type = OP_ENTERSUB;
3050     }
3051
3052     if (!(flags & G_EVAL)) {
3053         CATCH_SET(TRUE);
3054         CALL_BODY_SUB((OP*)&myop);
3055         retval = PL_stack_sp - (PL_stack_base + oldmark);
3056         CATCH_SET(oldcatch);
3057     }
3058     else {
3059         I32 old_cxix;
3060         myop.op_other = (OP*)&myop;
3061         (void)POPMARK;
3062         old_cxix = cxstack_ix;
3063         create_eval_scope(NULL, flags|G_FAKINGEVAL);
3064         INCMARK;
3065
3066         JMPENV_PUSH(ret);
3067
3068         switch (ret) {
3069         case 0:
3070  redo_body:
3071             CALL_BODY_SUB((OP*)&myop);
3072             retval = PL_stack_sp - (PL_stack_base + oldmark);
3073             if (!(flags & G_KEEPERR)) {
3074                 CLEAR_ERRSV();
3075             }
3076             break;
3077         case 1:
3078             STATUS_ALL_FAILURE;
3079             /* FALLTHROUGH */
3080         case 2:
3081             /* my_exit() was called */
3082             SET_CURSTASH(PL_defstash);
3083             FREETMPS;
3084             JMPENV_POP;
3085             my_exit_jump();
3086             NOT_REACHED; /* NOTREACHED */
3087         case 3:
3088             if (PL_restartop) {
3089                 PL_restartjmpenv = NULL;
3090                 PL_op = PL_restartop;
3091                 PL_restartop = 0;
3092                 goto redo_body;
3093             }
3094             PL_stack_sp = PL_stack_base + oldmark;
3095             if ((flags & G_WANT) == G_ARRAY)
3096                 retval = 0;
3097             else {
3098                 retval = 1;
3099                 *++PL_stack_sp = &PL_sv_undef;
3100             }
3101             break;
3102         }
3103
3104         /* if we croaked, depending on how we croaked the eval scope
3105          * may or may not have already been popped */
3106         if (cxstack_ix > old_cxix) {
3107             assert(cxstack_ix == old_cxix + 1);
3108             assert(CxTYPE(CX_CUR()) == CXt_EVAL);
3109             delete_eval_scope();
3110         }
3111         JMPENV_POP;
3112     }
3113
3114     if (flags & G_DISCARD) {
3115         PL_stack_sp = PL_stack_base + oldmark;
3116         retval = 0;
3117         FREETMPS;
3118         LEAVE;
3119     }
3120     PL_op = oldop;
3121     return retval;
3122 }
3123
3124 /* Eval a string. The G_EVAL flag is always assumed. */
3125
3126 /*
3127 =for apidoc eval_sv
3128
3129 Tells Perl to C<eval> the string in the SV.  It supports the same flags
3130 as C<call_sv>, with the obvious exception of C<G_EVAL>.  See L<perlcall>.
3131
3132 The C<G_RETHROW> flag can be used if you only need eval_sv() to
3133 execute code specified by a string, but not catch any errors.
3134
3135 =for apidoc Amnh||G_RETHROW
3136 =cut
3137 */
3138
3139 I32
3140 Perl_eval_sv(pTHX_ SV *sv, I32 flags)
3141
3142                         /* See G_* flags in cop.h */
3143 {
3144     UNOP myop;          /* fake syntax tree node */
3145     volatile I32 oldmark;
3146     volatile I32 retval = 0;
3147     int ret;
3148     OP* const oldop = PL_op;
3149     dJMPENV;
3150
3151     PERL_ARGS_ASSERT_EVAL_SV;
3152
3153     if (flags & G_DISCARD) {
3154         ENTER;
3155         SAVETMPS;
3156     }
3157
3158     SAVEOP();
3159     PL_op = (OP*)&myop;
3160     Zero(&myop, 1, UNOP);
3161     {
3162         dSP;
3163         oldmark = SP - PL_stack_base;
3164         EXTEND(SP, 1);
3165         PUSHs(sv);
3166         PUTBACK;
3167     }
3168
3169     if (!(flags & G_NOARGS))
3170         myop.op_flags = OPf_STACKED;
3171     myop.op_type = OP_ENTEREVAL;
3172     myop.op_flags |= OP_GIMME_REVERSE(flags);
3173     if (flags & G_KEEPERR)
3174         myop.op_flags |= OPf_SPECIAL;
3175
3176     if (flags & G_RE_REPARSING)
3177         myop.op_private = (OPpEVAL_COPHH | OPpEVAL_RE_REPARSING);
3178
3179     /* fail now; otherwise we could fail after the JMPENV_PUSH but
3180      * before a cx_pusheval(), which corrupts the stack after a croak */
3181     TAINT_PROPER("eval_sv()");
3182
3183     JMPENV_PUSH(ret);
3184     switch (ret) {
3185     case 0:
3186  redo_body:
3187         if (PL_op == (OP*)(&myop)) {
3188             PL_op = PL_ppaddr[OP_ENTEREVAL](aTHX);
3189             if (!PL_op)
3190                 goto fail; /* failed in compilation */
3191         }
3192         CALLRUNOPS(aTHX);
3193         retval = PL_stack_sp - (PL_stack_base + oldmark);
3194         if (!(flags & G_KEEPERR)) {
3195             CLEAR_ERRSV();
3196         }
3197         break;
3198     case 1:
3199         STATUS_ALL_FAILURE;
3200         /* FALLTHROUGH */
3201     case 2:
3202         /* my_exit() was called */
3203         SET_CURSTASH(PL_defstash);
3204         FREETMPS;
3205         JMPENV_POP;
3206         my_exit_jump();
3207         NOT_REACHED; /* NOTREACHED */
3208     case 3:
3209         if (PL_restartop) {
3210             PL_restartjmpenv = NULL;
3211             PL_op = PL_restartop;
3212             PL_restartop = 0;
3213             goto redo_body;
3214         }
3215       fail:
3216         if (flags & G_RETHROW) {
3217             JMPENV_POP;
3218             croak_sv(ERRSV);
3219         }
3220
3221         PL_stack_sp = PL_stack_base + oldmark;
3222         if ((flags & G_WANT) == G_ARRAY)
3223             retval = 0;
3224         else {
3225             retval = 1;
3226             *++PL_stack_sp = &PL_sv_undef;
3227         }
3228         break;
3229     }
3230
3231     JMPENV_POP;
3232     if (flags & G_DISCARD) {
3233         PL_stack_sp = PL_stack_base + oldmark;
3234         retval = 0;
3235         FREETMPS;
3236         LEAVE;
3237     }
3238     PL_op = oldop;
3239     return retval;
3240 }
3241
3242 /*
3243 =for apidoc eval_pv
3244
3245 Tells Perl to C<eval> the given string in scalar context and return an SV* result.
3246
3247 =cut
3248 */
3249
3250 SV*
3251 Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error)
3252 {
3253     SV* sv = newSVpv(p, 0);
3254
3255     PERL_ARGS_ASSERT_EVAL_PV;
3256
3257     if (croak_on_error) {
3258         sv_2mortal(sv);
3259         eval_sv(sv, G_SCALAR | G_RETHROW);
3260     }
3261     else {
3262         eval_sv(sv, G_SCALAR);
3263         SvREFCNT_dec(sv);
3264     }
3265
3266     {
3267         dSP;
3268         sv = POPs;
3269         PUTBACK;
3270     }
3271
3272     return sv;
3273 }
3274
3275 /* Require a module. */
3276
3277 /*
3278 =for apidoc_section $embedding
3279
3280 =for apidoc require_pv
3281
3282 Tells Perl to C<require> the file named by the string argument.  It is
3283 analogous to the Perl code C<eval "require '$file'">.  It's even
3284 implemented that way; consider using load_module instead.
3285
3286 =cut */
3287
3288 void
3289 Perl_require_pv(pTHX_ const char *pv)
3290 {
3291     dSP;
3292     SV* sv;
3293
3294     PERL_ARGS_ASSERT_REQUIRE_PV;
3295
3296     PUSHSTACKi(PERLSI_REQUIRE);
3297     sv = Perl_newSVpvf(aTHX_ "require q%c%s%c", 0, pv, 0);
3298     eval_sv(sv_2mortal(sv), G_DISCARD);
3299     POPSTACK;
3300 }
3301
3302 STATIC void
3303 S_usage(pTHX)           /* XXX move this out into a module ? */
3304 {
3305     /* This message really ought to be max 23 lines.
3306      * Removed -h because the user already knows that option. Others? */
3307
3308     /* Grouped as 6 lines per C string literal, to keep under the ANSI C 89
3309        minimum of 509 character string literals.  */
3310     static const char * const usage_msg[] = {
3311 "  -0[octal/hexadecimal] specify record separator (\\0, if no argument)\n"
3312 "  -a                    autosplit mode with -n or -p (splits $_ into @F)\n"
3313 "  -C[number/list]       enables the listed Unicode features\n"
3314 "  -c                    check syntax only (runs BEGIN and CHECK blocks)\n"
3315 "  -d[t][:MOD]           run program under debugger or module Devel::MOD\n"
3316 "  -D[number/letters]    set debugging flags (argument is a bit mask or alphabets)\n",
3317 "  -e commandline        one line of program (several -e's allowed, omit programfile)\n"
3318 "  -E commandline        like -e, but enables all optional features\n"
3319 "  -f                    don't do $sitelib/sitecustomize.pl at startup\n"
3320 "  -F/pattern/           split() pattern for -a switch (//'s are optional)\n"
3321 "  -i[extension]         edit <> files in place (makes backup if extension supplied)\n"
3322 "  -Idirectory           specify @INC/#include directory (several -I's allowed)\n",
3323 "  -l[octnum]            enable line ending processing, specifies line terminator\n"
3324 "  -[mM][-]module        execute \"use/no module...\" before executing program\n"
3325 "  -n                    assume \"while (<>) { ... }\" loop around program\n"
3326 "  -p                    assume loop like -n but print line also, like sed\n"
3327 "  -s                    enable rudimentary parsing for switches after programfile\n"
3328 "  -S                    look for programfile using PATH environment variable\n",
3329 "  -t                    enable tainting warnings\n"
3330 "  -T                    enable tainting checks\n"
3331 "  -u                    dump core after parsing program\n"
3332 "  -U                    allow unsafe operations\n"
3333 "  -v                    print version, patchlevel and license\n"
3334 "  -V[:configvar]        print configuration summary (or a single Config.pm variable)\n",
3335 "  -w                    enable many useful warnings\n"
3336 "  -W                    enable all warnings\n"
3337 "  -x[directory]         ignore text before #!perl line (optionally cd to directory)\n"
3338 "  -X                    disable all warnings\n"
3339 "  \n"
3340 "Run 'perldoc perl' for more help with Perl.\n\n",
3341 NULL
3342 };
3343     const char * const *p = usage_msg;
3344     PerlIO *out = PerlIO_stdout();
3345
3346     PerlIO_printf(out,
3347                   "\nUsage: %s [switches] [--] [programfile] [arguments]\n",
3348                   PL_origargv[0]);
3349     while (*p)
3350         PerlIO_puts(out, *p++);
3351     my_exit(0);
3352 }
3353
3354 /* convert a string of -D options (or digits) into an int.
3355  * sets *s to point to the char after the options */
3356
3357 #ifdef DEBUGGING
3358 int
3359 Perl_get_debug_opts(pTHX_ const char **s, bool givehelp)
3360 {
3361     static const char * const usage_msgd[] = {
3362       " Debugging flag values: (see also -d)\n"
3363       "  p  Tokenizing and parsing (with v, displays parse stack)\n"
3364       "  s  Stack snapshots (with v, displays all stacks)\n"
3365       "  l  Context (loop) stack processing\n"
3366       "  t  Trace execution\n"
3367       "  o  Method and overloading resolution\n",
3368       "  c  String/numeric conversions\n"
3369       "  P  Print profiling info, source file input state\n"
3370       "  m  Memory and SV allocation\n"
3371       "  f  Format processing\n"
3372       "  r  Regular expression parsing and execution\n"
3373       "  x  Syntax tree dump\n",
3374       "  u  Tainting checks\n"
3375       "  H  Hash dump -- usurps values()\n"
3376       "  X  Scratchpad allocation\n"
3377       "  D  Cleaning up\n"
3378       "  S  Op slab allocation\n"
3379       "  T  Tokenising\n"
3380       "  R  Include reference counts of dumped variables (eg when using -Ds)\n",
3381       "  J  Do not s,t,P-debug (Jump over) opcodes within package DB\n"
3382       "  v  Verbose: use in conjunction with other flags\n"
3383       "  C  Copy On Write\n"
3384       "  A  Consistency checks on internal structures\n"
3385       "  q  quiet - currently only suppresses the 'EXECUTING' message\n"
3386       "  M  trace smart match resolution\n"
3387       "  B  dump suBroutine definitions, including special Blocks like BEGIN\n",
3388       "  L  trace some locale setting information--for Perl core development\n",
3389       "  i  trace PerlIO layer processing\n",
3390       "  y  trace y///, tr/// compilation and execution\n",
3391       NULL
3392     };
3393     UV uv = 0;
3394
3395     PERL_ARGS_ASSERT_GET_DEBUG_OPTS;
3396
3397     if (isALPHA(**s)) {
3398         /* if adding extra options, remember to update DEBUG_MASK */
3399         static const char debopts[] = "psltocPmfrxuUHXDSTRJvCAqMBLiy";
3400
3401         for (; isWORDCHAR(**s); (*s)++) {
3402             const char * const d = strchr(debopts,**s);
3403             if (d)
3404                 uv |= 1 << (d - debopts);
3405             else if (ckWARN_d(WARN_DEBUGGING))
3406                 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
3407                     "invalid option -D%c, use -D'' to see choices\n", **s);
3408         }
3409     }
3410     else if (isDIGIT(**s)) {
3411         const char* e = *s + strlen(*s);
3412         if (grok_atoUV(*s, &uv, &e))
3413             *s = e;
3414         for (; isWORDCHAR(**s); (*s)++) ;
3415     }
3416     else if (givehelp) {
3417       const char *const *p = usage_msgd;
3418       while (*p) PerlIO_puts(PerlIO_stdout(), *p++);
3419     }
3420     return (int)uv; /* ignore any UV->int conversion loss */
3421 }
3422 #endif
3423
3424 /* This routine handles any switches that can be given during run */
3425
3426 const char *
3427 Perl_moreswitches(pTHX_ const char *s)
3428 {
3429     UV rschar;
3430     const char option = *s; /* used to remember option in -m/-M code */
3431
3432     PERL_ARGS_ASSERT_MORESWITCHES;
3433
3434     switch (*s) {
3435     case '0':
3436     {
3437          I32 flags = 0;
3438          STRLEN numlen;
3439
3440          SvREFCNT_dec(PL_rs);
3441          if (s[1] == 'x' && s[2]) {
3442               const char *e = s+=2;
3443               U8 *tmps;
3444
3445               while (*e)
3446                 e++;
3447               numlen = e - s;
3448               flags = PERL_SCAN_SILENT_ILLDIGIT;
3449               rschar = (U32)grok_hex(s, &numlen, &flags, NULL);
3450               if (s + numlen < e) {
3451                    rschar = 0; /* Grandfather -0xFOO as -0 -xFOO. */
3452                    numlen = 0;
3453                    s--;
3454               }
3455               PL_rs = newSVpvs("");
3456               tmps = (U8*) SvGROW(PL_rs, (STRLEN)(UVCHR_SKIP(rschar) + 1));
3457               uvchr_to_utf8(tmps, rschar);
3458               SvCUR_set(PL_rs, UVCHR_SKIP(rschar));
3459               SvUTF8_on(PL_rs);
3460          }
3461          else {
3462               numlen = 4;
3463               rschar = (U32)grok_oct(s, &numlen, &flags, NULL);
3464               if (rschar & ~((U8)~0))
3465                    PL_rs = &PL_sv_undef;
3466               else if (!rschar && numlen >= 2)
3467                    PL_rs = newSVpvs("");
3468               else {
3469                    char ch = (char)rschar;
3470                    PL_rs = newSVpvn(&ch, 1);
3471               }
3472          }
3473          sv_setsv(get_sv("/", GV_ADD), PL_rs);
3474          return s + numlen;
3475     }
3476     case 'C':
3477         s++;
3478         PL_unicode = parse_unicode_opts( (const char **)&s );
3479         if (PL_unicode & PERL_UNICODE_UTF8CACHEASSERT_FLAG)
3480             PL_utf8cache = -1;
3481         return s;
3482     case 'F':
3483         PL_minus_a = TRUE;
3484         PL_minus_F = TRUE;
3485         PL_minus_n = TRUE;
3486         PL_splitstr = ++s;
3487         while (*s && !isSPACE(*s)) ++s;
3488         PL_splitstr = savepvn(PL_splitstr, s - PL_splitstr);
3489         return s;
3490     case 'a':
3491         PL_minus_a = TRUE;
3492         PL_minus_n = TRUE;
3493         s++;
3494         return s;
3495     case 'c':
3496         PL_minus_c = TRUE;
3497         s++;
3498         return s;
3499     case 'd':
3500         forbid_setid('d', FALSE);
3501         s++;
3502
3503         /* -dt indicates to the debugger that threads will be used */
3504         if (*s == 't' && !isWORDCHAR(s[1])) {
3505             ++s;
3506             my_setenv("PERL5DB_THREADED", "1");
3507         }
3508
3509         /* The following permits -d:Mod to accepts arguments following an =
3510            in the fashion that -MSome::Mod does. */
3511         if (*s == ':' || *s == '=') {
3512             const char *start;
3513             const char *end;
3514             SV *sv;
3515
3516             if (*++s == '-') {
3517                 ++s;
3518                 sv = newSVpvs("no Devel::");
3519             } else {
3520                 sv = newSVpvs("use Devel::");
3521             }
3522
3523             start = s;
3524             end = s + strlen(s);
3525
3526             /* We now allow -d:Module=Foo,Bar and -d:-Module */
3527             while(isWORDCHAR(*s) || *s==':') ++s;
3528             if (*s != '=')
3529                 sv_catpvn(sv, start, end - start);
3530             else {
3531                 sv_catpvn(sv, start, s-start);
3532                 /* Don't use NUL as q// delimiter here, this string goes in the
3533                  * environment. */
3534                 Perl_sv_catpvf(aTHX_ sv, " split(/,/,q{%s});", ++s);
3535             }
3536             s = end;
3537             my_setenv("PERL5DB", SvPV_nolen_const(sv));
3538             SvREFCNT_dec(sv);
3539         }
3540         if (!PL_perldb) {
3541             PL_perldb = PERLDB_ALL;
3542             init_debugger();
3543         }
3544         return s;
3545     case 'D':
3546     {   
3547 #ifdef DEBUGGING
3548         forbid_setid('D', FALSE);
3549         s++;
3550         PL_debug = get_debug_opts( (const char **)&s, 1) | DEBUG_TOP_FLAG;
3551 #else /* !DEBUGGING */
3552         if (ckWARN_d(WARN_DEBUGGING))
3553             Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
3554                    "Recompile perl with -DDEBUGGING to use -D switch (did you mean -d ?)\n");
3555         for (s++; isWORDCHAR(*s); s++) ;
3556 #endif
3557         return s;
3558         NOT_REACHED; /* NOTREACHED */
3559     }   
3560     case 'h':
3561         usage();
3562         NOT_REACHED; /* NOTREACHED */
3563
3564     case 'i':
3565         Safefree(PL_inplace);
3566         {
3567             const char * const start = ++s;
3568             while (*s && !isSPACE(*s))
3569                 ++s;
3570
3571             PL_inplace = savepvn(start, s - start);
3572         }
3573         return s;
3574     case 'I':   /* -I handled both here and in parse_body() */
3575         forbid_setid('I', FALSE);
3576         ++s;
3577         while (*s && isSPACE(*s))
3578             ++s;
3579         if (*s) {
3580             const char *e, *p;
3581             p = s;
3582             /* ignore trailing spaces (possibly followed by other switches) */
3583             do {
3584                 for (e = p; *e && !isSPACE(*e); e++) ;
3585                 p = e;
3586                 while (isSPACE(*p))
3587                     p++;
3588             } while (*p && *p != '-');
3589             incpush(s, e-s,
3590                     INCPUSH_ADD_SUB_DIRS|INCPUSH_ADD_OLD_VERS|INCPUSH_UNSHIFT);
3591             s = p;
3592             if (*s == '-')
3593                 s++;
3594         }
3595         else
3596             Perl_croak(aTHX_ "No directory specified for -I");
3597         return s;
3598     case 'l':
3599         PL_minus_l = TRUE;
3600         s++;
3601         if (PL_ors_sv) {
3602             SvREFCNT_dec(PL_ors_sv);
3603             PL_ors_sv = NULL;
3604         }
3605         if (isDIGIT(*s)) {
3606             I32 flags = 0;
3607             STRLEN numlen;
3608             PL_ors_sv = newSVpvs("\n");
3609             numlen = 3 + (*s == '0');
3610             *SvPVX(PL_ors_sv) = (char)grok_oct(s, &numlen, &flags, NULL);
3611             s += numlen;
3612         }
3613         else {
3614             if (RsPARA(PL_rs)) {
3615                 PL_ors_sv = newSVpvs("\n\n");
3616             }
3617             else {
3618                 PL_ors_sv = newSVsv(PL_rs);
3619             }
3620         }
3621         return s;
3622     case 'M':
3623         forbid_setid('M', FALSE);       /* XXX ? */
3624         /* FALLTHROUGH */
3625     case 'm':
3626         forbid_setid('m', FALSE);       /* XXX ? */
3627         if (*++s) {
3628             const char *start;
3629             const char *end;
3630             SV *sv;
3631             const char *use = "use ";
3632             bool colon = FALSE;
3633             /* -M-foo == 'no foo'       */
3634             /* Leading space on " no " is deliberate, to make both
3635                possibilities the same length.  */
3636             if (*s == '-') { use = " no "; ++s; }
3637             sv = newSVpvn(use,4);
3638             start = s;
3639             /* We allow -M'Module qw(Foo Bar)'  */
3640             while(isWORDCHAR(*s) || *s==':') {
3641                 if( *s++ == ':' ) {
3642                     if( *s == ':' ) 
3643                         s++;
3644                     else
3645                         colon = TRUE;
3646                 }
3647             }
3648             if (s == start)
3649                 Perl_croak(aTHX_ "Module name required with -%c option",
3650                                     option);
3651             if (colon) 
3652                 Perl_croak(aTHX_ "Invalid module name %.*s with -%c option: "
3653                                     "contains single ':'",
3654                                     (int)(s - start), start, option);
3655             end = s + strlen(s);
3656             if (*s != '=') {
3657                 sv_catpvn(sv, start, end - start);
3658                 if (option == 'm') {
3659                     if (*s != '\0')
3660                         Perl_croak(aTHX_ "Can't use '%c' after -mname", *s);
3661                     sv_catpvs( sv, " ()");
3662                 }
3663             } else {
3664                 sv_catpvn(sv, start, s-start);
3665                 /* Use NUL as q''-delimiter.  */
3666                 sv_catpvs(sv, " split(/,/,q\0");
3667                 ++s;
3668                 sv_catpvn(sv, s, end - s);
3669                 sv_catpvs(sv,  "\0)");
3670             }
3671             s = end;
3672             Perl_av_create_and_push(aTHX_ &PL_preambleav, sv);
3673         }
3674         else
3675             Perl_croak(aTHX_ "Missing argument to -%c", option);
3676         return s;
3677     case 'n':
3678         PL_minus_n = TRUE;
3679         s++;
3680         return s;
3681     case 'p':
3682         PL_minus_p = TRUE;
3683         s++;
3684         return s;
3685     case 's':
3686         forbid_setid('s', FALSE);
3687         PL_doswitches = TRUE;
3688         s++;
3689         return s;
3690     case 't':
3691     case 'T':
3692 #if defined(SILENT_NO_TAINT_SUPPORT)
3693             /* silently ignore */
3694 #elif defined(NO_TAINT_SUPPORT)
3695         Perl_croak_nocontext("This perl was compiled without taint support. "
3696                    "Cowardly refusing to run with -t or -T flags");
3697 #else
3698         if (!TAINTING_get)
3699             TOO_LATE_FOR(*s);
3700 #endif
3701         s++;
3702         return s;
3703     case 'u':
3704         PL_do_undump = TRUE;
3705         s++;
3706         return s;
3707     case 'U':
3708         PL_unsafe = TRUE;
3709         s++;
3710         return s;
3711     case 'v':
3712         minus_v();
3713     case 'w':
3714         if (! (PL_dowarn & G_WARN_ALL_MASK)) {
3715             PL_dowarn |= G_WARN_ON;
3716         }
3717         s++;
3718         return s;
3719     case 'W':
3720         PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
3721     free_and_set_cop_warnings(&PL_compiling, pWARN_ALL);
3722         s++;
3723         return s;
3724     case 'X':
3725         PL_dowarn = G_WARN_ALL_OFF;
3726     free_and_set_cop_warnings(&PL_compiling, pWARN_NONE);
3727         s++;
3728         return s;
3729     case '*':
3730     case ' ':
3731         while( *s == ' ' )
3732           ++s;
3733         if (s[0] == '-')        /* Additional switches on #! line. */
3734             return s+1;
3735         break;
3736     case '-':
3737     case 0:
3738 #if defined(WIN32) || !defined(PERL_STRICT_CR)
3739     case '\r':
3740 #endif
3741     case '\n':
3742     case '\t':
3743         break;
3744 #ifdef ALTERNATE_SHEBANG
3745     case 'S':                   /* OS/2 needs -S on "extproc" line. */
3746         break;
3747 #endif
3748     case 'e': case 'f': case 'x': case 'E':
3749 #ifndef ALTERNATE_SHEBANG
3750     case 'S':
3751 #endif
3752     case 'V':
3753         Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s);
3754     default:
3755         Perl_croak(aTHX_
3756             "Unrecognized switch: -%.1s  (-h will show valid options)",s
3757         );
3758     }
3759     return NULL;
3760 }
3761
3762
3763 STATIC void
3764 S_minus_v(pTHX)
3765 {
3766         PerlIO * PIO_stdout;
3767         {
3768             const char * const level_str = "v" PERL_VERSION_STRING;
3769             const STRLEN level_len = sizeof("v" PERL_VERSION_STRING)-1;
3770 #ifdef PERL_PATCHNUM
3771             SV* level;
3772 #  ifdef PERL_GIT_UNCOMMITTED_CHANGES
3773             static const char num [] = PERL_PATCHNUM "*";
3774 #  else
3775             static const char num [] = PERL_PATCHNUM;
3776 #  endif
3777             {
3778                 const STRLEN num_len = sizeof(num)-1;
3779                 /* A very advanced compiler would fold away the strnEQ
3780                    and this whole conditional, but most (all?) won't do it.
3781                    SV level could also be replaced by with preprocessor
3782                    catenation.
3783                 */
3784                 if (num_len >= level_len && strnEQ(num,level_str,level_len)) {
3785                     /* per 46807d8e80, PERL_PATCHNUM is outside of the control
3786                        of the interp so it might contain format characters
3787                     */
3788                     level = newSVpvn(num, num_len);
3789                 } else {
3790                     level = Perl_newSVpvf_nocontext("%s (%s)", level_str, num);
3791                 }
3792             }
3793 #else
3794         SV* level = newSVpvn(level_str, level_len);
3795 #endif /* #ifdef PERL_PATCHNUM */
3796         PIO_stdout =  PerlIO_stdout();
3797             PerlIO_printf(PIO_stdout,
3798                 "\nThis is perl "       STRINGIFY(PERL_REVISION)
3799                 ", version "            STRINGIFY(PERL_VERSION)
3800                 ", subversion "         STRINGIFY(PERL_SUBVERSION)
3801                 " (%" SVf ") built for "        ARCHNAME, SVfARG(level)
3802                 );
3803             SvREFCNT_dec_NN(level);
3804         }
3805 #if defined(LOCAL_PATCH_COUNT)
3806         if (LOCAL_PATCH_COUNT > 0)
3807             PerlIO_printf(PIO_stdout,
3808                           "\n(with %d registered patch%s, "
3809                           "see perl -V for more detail)",
3810                           LOCAL_PATCH_COUNT,
3811                           (LOCAL_PATCH_COUNT!=1) ? "es" : "");
3812 #endif
3813
3814         PerlIO_printf(PIO_stdout,
3815                       "\n\nCopyright 1987-2020, Larry Wall\n");
3816 #ifdef MSDOS
3817         PerlIO_printf(PIO_stdout,
3818                       "\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
3819 #endif
3820 #ifdef DJGPP
3821         PerlIO_printf(PIO_stdout,
3822                       "djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n"
3823                       "djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n");
3824 #endif
3825 #ifdef OS2
3826         PerlIO_printf(PIO_stdout,
3827                       "\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
3828                       "Version 5 port Copyright (c) 1994-2002, Andreas Kaiser, Ilya Zakharevich\n");
3829 #endif
3830 #ifdef OEMVS
3831         PerlIO_printf(PIO_stdout,
3832                       "MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
3833 #endif
3834 #ifdef __VOS__
3835         PerlIO_printf(PIO_stdout,
3836                       "Stratus OpenVOS port by Paul.Green@stratus.com, 1997-2013\n");
3837 #endif
3838 #ifdef POSIX_BC
3839         PerlIO_printf(PIO_stdout,
3840                       "BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
3841 #endif
3842 #ifdef BINARY_BUILD_NOTICE
3843         BINARY_BUILD_NOTICE;
3844 #endif
3845         PerlIO_printf(PIO_stdout,
3846                       "\n\
3847 Perl may be copied only under the terms of either the Artistic License or the\n\
3848 GNU General Public License, which may be found in the Perl 5 source kit.\n\n\
3849 Complete documentation for Perl, including FAQ lists, should be found on\n\
3850 this system using \"man perl\" or \"perldoc perl\".  If you have access to the\n\
3851 Internet, point your browser at http://www.perl.org/, the Perl Home Page.\n\n");
3852         my_exit(0);
3853 }
3854
3855 /* compliments of Tom Christiansen */
3856
3857 /* unexec() can be found in the Gnu emacs distribution */
3858 /* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
3859
3860 #ifdef VMS
3861 #include <lib$routines.h>
3862 #endif
3863
3864 void
3865 Perl_my_unexec(pTHX)
3866 {
3867 #ifdef UNEXEC
3868     SV *    prog = newSVpv(BIN_EXP, 0);
3869     SV *    file = newSVpv(PL_origfilename, 0);
3870     int    status = 1;
3871     extern int etext;
3872
3873     sv_catpvs(prog, "/perl");
3874     sv_catpvs(file, ".perldump");
3875
3876     unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
3877     /* unexec prints msg to stderr in case of failure */
3878     PerlProc_exit(status);
3879 #else
3880     PERL_UNUSED_CONTEXT;
3881 #  ifdef VMS
3882      lib$signal(SS$_DEBUG);  /* ssdef.h #included from vmsish.h */
3883 #  elif defined(WIN32) || defined(__CYGWIN__)
3884     Perl_croak_nocontext("dump is not supported");
3885 #  else
3886     ABORT();            /* for use with undump */
3887 #  endif
3888 #endif
3889 }
3890
3891 /* initialize curinterp */
3892 STATIC void
3893 S_init_interp(pTHX)
3894 {
3895 #ifdef MULTIPLICITY
3896 #  define PERLVAR(prefix,var,type)
3897 #  define PERLVARA(prefix,var,n,type)
3898 #  if defined(PERL_IMPLICIT_CONTEXT)
3899 #    define PERLVARI(prefix,var,type,init)      aTHX->prefix##var = init;
3900 #    define PERLVARIC(prefix,var,type,init)     aTHX->prefix##var = init;
3901 #  else
3902 #    define PERLVARI(prefix,var,type,init)      PERL_GET_INTERP->var = init;
3903 #    define PERLVARIC(prefix,var,type,init)     PERL_GET_INTERP->var = init;
3904 #  endif
3905 #  include "intrpvar.h"
3906 #  undef PERLVAR
3907 #  undef PERLVARA
3908 #  undef PERLVARI
3909 #  undef PERLVARIC
3910 #else
3911 #  define PERLVAR(prefix,var,type)
3912 #  define PERLVARA(prefix,var,n,type)
3913 #  define PERLVARI(prefix,var,type,init)        PL_##var = init;
3914 #  define PERLVARIC(prefix,var,type,init)       PL_##var = init;
3915 #  include "intrpvar.h"
3916 #  undef PERLVAR
3917 #  undef PERLVARA
3918 #  undef PERLVARI
3919 #  undef PERLVARIC
3920 #endif
3921
3922 }
3923
3924 STATIC void
3925 S_init_main_stash(pTHX)
3926 {
3927     GV *gv;
3928     HV *hv = newHV();
3929
3930     PL_curstash = PL_defstash = (HV *)SvREFCNT_inc_simple_NN(hv);
3931     /* We know that the string "main" will be in the global shared string
3932        table, so it's a small saving to use it rather than allocate another
3933        8 bytes.  */
3934     PL_curstname = newSVpvs_share("main");
3935     gv = gv_fetchpvs("main::", GV_ADD|GV_NOTQUAL, SVt_PVHV);
3936     /* If we hadn't caused another reference to "main" to be in the shared
3937        string table above, then it would be worth reordering these two,
3938        because otherwise all we do is delete "main" from it as a consequence
3939        of the SvREFCNT_dec, only to add it again with hv_name_set */
3940     SvREFCNT_dec(GvHV(gv));
3941     hv_name_sets(PL_defstash, "main", 0);
3942     GvHV(gv) = MUTABLE_HV(SvREFCNT_inc_simple(PL_defstash));
3943     SvREADONLY_on(gv);
3944     PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpvs("INC", GV_ADD|GV_NOTQUAL,
3945                                              SVt_PVAV)));
3946     SvREFCNT_inc_simple_void(PL_incgv); /* Don't allow it to be freed */
3947     GvMULTI_on(PL_incgv);
3948     PL_hintgv = gv_fetchpvs("\010", GV_ADD|GV_NOTQUAL, SVt_PV); /* ^H */
3949     SvREFCNT_inc_simple_void(PL_hintgv);
3950     GvMULTI_on(PL_hintgv);
3951     PL_defgv = gv_fetchpvs("_", GV_ADD|GV_NOTQUAL, SVt_PVAV);
3952     SvREFCNT_inc_simple_void(PL_defgv);
3953     PL_errgv = gv_fetchpvs("@", GV_ADD|GV_NOTQUAL, SVt_PV);
3954     SvREFCNT_inc_simple_void(PL_errgv);
3955     GvMULTI_on(PL_errgv);
3956     PL_replgv = gv_fetchpvs("\022", GV_ADD|GV_NOTQUAL, SVt_PV); /* ^R */
3957     SvREFCNT_inc_simple_void(PL_replgv);
3958     GvMULTI_on(PL_replgv);
3959     (void)Perl_form(aTHX_ "%240s","");  /* Preallocate temp - for immediate signals. */
3960 #ifdef PERL_DONT_CREATE_GVSV
3961     (void)gv_SVadd(PL_errgv);
3962 #endif
3963     sv_grow(ERRSV, 240);        /* Preallocate - for immediate signals. */
3964     CLEAR_ERRSV();
3965     CopSTASH_set(&PL_compiling, PL_defstash);
3966     PL_debstash = GvHV(gv_fetchpvs("DB::", GV_ADDMULTI, SVt_PVHV));
3967     PL_globalstash = GvHV(gv_fetchpvs("CORE::GLOBAL::", GV_ADDMULTI,
3968                                       SVt_PVHV));
3969     /* We must init $/ before switches are processed. */
3970     sv_setpvs(get_sv("/", GV_ADD), "\n");
3971 }
3972
3973 STATIC PerlIO *
3974 S_open_script(pTHX_ const char *scriptname, bool dosearch, bool *suidscript)
3975 {
3976     int fdscript = -1;
3977     PerlIO *rsfp = NULL;
3978     Stat_t tmpstatbuf;
3979     int fd;
3980
3981     PERL_ARGS_ASSERT_OPEN_SCRIPT;
3982
3983     if (PL_e_script) {
3984         PL_origfilename = savepvs("-e");
3985     }
3986     else {
3987         const char *s;
3988         UV uv;
3989         /* if find_script() returns, it returns a malloc()-ed value */
3990         scriptname = PL_origfilename = find_script(scriptname, dosearch, NULL, 1);
3991         s = scriptname + strlen(scriptname);
3992
3993         if (strBEGINs(scriptname, "/dev/fd/")
3994             && isDIGIT(scriptname[8])
3995             && grok_atoUV(scriptname + 8, &uv, &s)
3996             && uv <= PERL_INT_MAX
3997         ) {
3998             fdscript = (int)uv;
3999             if (*s) {
4000                 /* PSz 18 Feb 04
4001                  * Tell apart "normal" usage of fdscript, e.g.
4002                  * with bash on FreeBSD:
4003                  *   perl <( echo '#!perl -DA'; echo 'print "$0\n"')
4004                  * from usage in suidperl.
4005                  * Does any "normal" usage leave garbage after the number???
4006                  * Is it a mistake to use a similar /dev/fd/ construct for
4007                  * suidperl?
4008                  */
4009                 *suidscript = TRUE;
4010                 /* PSz 20 Feb 04  
4011                  * Be supersafe and do some sanity-checks.
4012                  * Still, can we be sure we got the right thing?
4013                  */
4014                 if (*s != '/') {
4015                     Perl_croak(aTHX_ "Wrong syntax (suid) fd script name \"%s\"\n", s);
4016                 }
4017                 if (! *(s+1)) {
4018                     Perl_croak(aTHX_ "Missing (suid) fd script name\n");
4019                 }
4020                 scriptname = savepv(s + 1);
4021                 Safefree(PL_origfilename);
4022                 PL_origfilename = (char *)scriptname;
4023             }
4024         }
4025     }
4026
4027     CopFILE_free(PL_curcop);
4028     CopFILE_set(PL_curcop, PL_origfilename);
4029     if (*PL_origfilename == '-' && PL_origfilename[1] == '\0')
4030         scriptname = (char *)"";
4031     if (fdscript >= 0) {
4032         rsfp = PerlIO_fdopen(fdscript,PERL_SCRIPT_MODE);
4033     }
4034     else if (!*scriptname) {
4035         forbid_setid(0, *suidscript);
4036         return NULL;
4037     }
4038     else {
4039 #ifdef FAKE_BIT_BUCKET
4040         /* This hack allows one not to have /dev/null (or BIT_BUCKET as it
4041          * is called) and still have the "-e" work.  (Believe it or not,
4042          * a /dev/null is required for the "-e" to work because source
4043          * filter magic is used to implement it. ) This is *not* a general
4044          * replacement for a /dev/null.  What we do here is create a temp
4045          * file (an empty file), open up that as the script, and then
4046          * immediately close and unlink it.  Close enough for jazz. */ 
4047 #define FAKE_BIT_BUCKET_PREFIX "/tmp/perlnull-"
4048 #define FAKE_BIT_BUCKET_SUFFIX "XXXXXXXX"
4049 #define FAKE_BIT_BUCKET_TEMPLATE FAKE_BIT_BUCKET_PREFIX FAKE_BIT_BUCKET_SUFFIX
4050         char tmpname[sizeof(FAKE_BIT_BUCKET_TEMPLATE)] = {
4051             FAKE_BIT_BUCKET_TEMPLATE
4052         };
4053         const char * const err = "Failed to create a fake bit bucket";
4054         if (strEQ(scriptname, BIT_BUCKET)) {
4055             int tmpfd = Perl_my_mkstemp_cloexec(tmpname);
4056             if (tmpfd > -1) {
4057                 scriptname = tmpname;
4058                 close(tmpfd);
4059             } else
4060                 Perl_croak(aTHX_ err);
4061         }
4062 #endif
4063         rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
4064 #ifdef FAKE_BIT_BUCKET
4065         if (   strBEGINs(scriptname, FAKE_BIT_BUCKET_PREFIX)
4066             && strlen(scriptname) == sizeof(tmpname) - 1)
4067         {
4068             unlink(scriptname);
4069         }
4070         scriptname = BIT_BUCKET;
4071 #endif
4072     }
4073     if (!rsfp) {
4074         /* PSz 16 Sep 03  Keep neat error message */
4075         if (PL_e_script)
4076             Perl_croak(aTHX_ "Can't open " BIT_BUCKET ": %s\n", Strerror(errno));
4077         else
4078             Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
4079                     CopFILE(PL_curcop), Strerror(errno));
4080     }
4081     fd = PerlIO_fileno(rsfp);
4082
4083     if (fd < 0 ||
4084         (PerlLIO_fstat(fd, &tmpstatbuf) >= 0
4085          && S_ISDIR(tmpstatbuf.st_mode)))
4086         Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
4087             CopFILE(PL_curcop),
4088             Strerror(EISDIR));
4089
4090     return rsfp;
4091 }
4092
4093 /* In the days of suidperl, we refused to execute a setuid script stored on
4094  * a filesystem mounted nosuid and/or noexec. This meant that we probed for the
4095  * existence of the appropriate filesystem-statting function, and behaved
4096  * accordingly. But even though suidperl is long gone, we must still include
4097  * those probes for the benefit of modules like Filesys::Df, which expect the
4098  * results of those probes to be stored in %Config; see RT#126368. So mention
4099  * the relevant cpp symbols here, to ensure that metaconfig will include their
4100  * probes in the generated Configure:
4101  *
4102  * I_SYSSTATVFS HAS_FSTATVFS
4103  * I_SYSMOUNT
4104  * I_STATFS     HAS_FSTATFS     HAS_GETFSSTAT
4105  * I_MNTENT     HAS_GETMNTENT   HAS_HASMNTOPT
4106  */
4107
4108
4109 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
4110 /* Don't even need this function.  */
4111 #else
4112 STATIC void
4113 S_validate_suid(pTHX_ PerlIO *rsfp)
4114 {
4115     const Uid_t  my_uid = PerlProc_getuid();
4116     const Uid_t my_euid = PerlProc_geteuid();
4117     const Gid_t  my_gid = PerlProc_getgid();
4118     const Gid_t my_egid = PerlProc_getegid();
4119
4120     PERL_ARGS_ASSERT_VALIDATE_SUID;
4121
4122     if (my_euid != my_uid || my_egid != my_gid) {       /* (suidperl doesn't exist, in fact) */
4123         int fd = PerlIO_fileno(rsfp);
4124         Stat_t statbuf;
4125         if (fd < 0 || PerlLIO_fstat(fd, &statbuf) < 0) { /* may be either wrapped or real suid */
4126             Perl_croak_nocontext( "Illegal suidscript");
4127         }
4128         if ((my_euid != my_uid && my_euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
4129             ||
4130             (my_egid != my_gid && my_egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
4131             )
4132             if (!PL_do_undump)
4133                 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
4134 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
4135         /* not set-id, must be wrapped */
4136     }
4137 }
4138 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
4139
4140 STATIC void
4141 S_find_beginning(pTHX_ SV* linestr_sv, PerlIO *rsfp)
4142 {
4143     const char *s;
4144     const char *s2;
4145
4146     PERL_ARGS_ASSERT_FIND_BEGINNING;
4147
4148     /* skip forward in input to the real script? */
4149
4150     do {
4151         if ((s = sv_gets(linestr_sv, rsfp, 0)) == NULL)
4152             Perl_croak(aTHX_ "No Perl script found in input\n");
4153         s2 = s;
4154     } while (!(*s == '#' && s[1] == '!' && ((s = instr(s,"perl")) || (s = instr(s2,"PERL")))));
4155     PerlIO_ungetc(rsfp, '\n');          /* to keep line count right */
4156     while (*s && !(isSPACE (*s) || *s == '#')) s++;
4157     s2 = s;
4158     while (*s == ' ' || *s == '\t') s++;
4159     if (*s++ == '-') {
4160         while (isDIGIT(s2[-1]) || s2[-1] == '-' || s2[-1] == '.'
4161                || s2[-1] == '_') s2--;
4162         if (strBEGINs(s2-4,"perl"))
4163             while ((s = moreswitches(s)))
4164                 ;
4165     }
4166 }
4167
4168
4169 STATIC void
4170 S_init_ids(pTHX)
4171 {
4172     /* no need to do anything here any more if we don't
4173      * do tainting. */
4174 #ifndef NO_TAINT_SUPPORT
4175     const Uid_t my_uid = PerlProc_getuid();
4176     const Uid_t my_euid = PerlProc_geteuid();
4177     const Gid_t my_gid = PerlProc_getgid();
4178     const Gid_t my_egid = PerlProc_getegid();
4179
4180     PERL_UNUSED_CONTEXT;
4181
4182     /* Should not happen: */
4183     CHECK_MALLOC_TAINT(my_uid && (my_euid != my_uid || my_egid != my_gid));
4184     TAINTING_set( TAINTING_get | (my_uid && (my_euid != my_uid || my_egid != my_gid)) );
4185 #endif
4186     /* BUG */
4187     /* PSz 27 Feb 04
4188      * Should go by suidscript, not uid!=euid: why disallow
4189      * system("ls") in scripts run from setuid things?
4190      * Or, is this run before we check arguments and set suidscript?
4191      * What about SETUID_SCRIPTS_ARE_SECURE_NOW: could we use fdscript then?
4192      * (We never have suidscript, can we be sure to have fdscript?)
4193      * Or must then go by UID checks? See comments in forbid_setid also.
4194      */
4195 }
4196
4197 /* This is used very early in the lifetime of the program,
4198  * before even the options are parsed, so PL_tainting has
4199  * not been initialized properly.  */
4200 bool
4201 Perl_doing_taint(int argc, char *argv[], char *envp[])
4202 {
4203 #ifndef PERL_IMPLICIT_SYS
4204     /* If we have PERL_IMPLICIT_SYS we can't call getuid() et alia
4205      * before we have an interpreter-- and the whole point of this
4206      * function is to be called at such an early stage.  If you are on
4207      * a system with PERL_IMPLICIT_SYS but you do have a concept of
4208      * "tainted because running with altered effective ids', you'll
4209      * have to add your own checks somewhere in here.  The two most
4210      * known samples of 'implicitness' are Win32 and NetWare, neither
4211      * of which has much of concept of 'uids'. */
4212     Uid_t uid  = PerlProc_getuid();
4213     Uid_t euid = PerlProc_geteuid();
4214     Gid_t gid  = PerlProc_getgid();
4215     Gid_t egid = PerlProc_getegid();
4216     (void)envp;
4217
4218 #ifdef VMS
4219     uid  |=  gid << 16;
4220     euid |= egid << 16;
4221 #endif
4222     if (uid && (euid != uid || egid != gid))
4223         return 1;
4224 #endif /* !PERL_IMPLICIT_SYS */
4225     /* This is a really primitive check; environment gets ignored only
4226      * if -T are the first chars together; otherwise one gets
4227      *  "Too late" message. */
4228     if ( argc > 1 && argv[1][0] == '-'
4229          && isALPHA_FOLD_EQ(argv[1][1], 't'))
4230         return 1;
4231     return 0;
4232 }
4233
4234 /* Passing the flag as a single char rather than a string is a slight space
4235    optimisation.  The only message that isn't /^-.$/ is
4236    "program input from stdin", which is substituted in place of '\0', which
4237    could never be a command line flag.  */
4238 STATIC void
4239 S_forbid_setid(pTHX_ const char flag, const bool suidscript) /* g */
4240 {
4241     char string[3] = "-x";
4242     const char *message = "program input from stdin";
4243
4244     PERL_UNUSED_CONTEXT;
4245     if (flag) {
4246         string[1] = flag;
4247         message = string;
4248     }
4249
4250 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
4251     if (PerlProc_getuid() != PerlProc_geteuid())
4252         Perl_croak(aTHX_ "No %s allowed while running setuid", message);
4253     if (PerlProc_getgid() != PerlProc_getegid())
4254         Perl_croak(aTHX_ "No %s allowed while running setgid", message);
4255 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
4256     if (suidscript)
4257         Perl_croak(aTHX_ "No %s allowed with (suid) fdscript", message);
4258 }
4259
4260 void
4261 Perl_init_dbargs(pTHX)
4262 {
4263     AV *const args = PL_dbargs = GvAV(gv_AVadd((gv_fetchpvs("DB::args",
4264                                                             GV_ADDMULTI,
4265                                                             SVt_PVAV))));
4266
4267     if (AvREAL(args)) {
4268         /* Someone has already created it.
4269            It might have entries, and if we just turn off AvREAL(), they will
4270            "leak" until global destruction.  */
4271         av_clear(args);
4272         if (SvTIED_mg((const SV *)args, PERL_MAGIC_tied))
4273             Perl_croak(aTHX_ "Cannot set tied @DB::args");
4274     }
4275     AvREIFY_only(PL_dbargs);
4276 }
4277
4278 void
4279 Perl_init_debugger(pTHX)
4280 {
4281     HV * const ostash = PL_curstash;
4282     MAGIC *mg;
4283
4284     PL_curstash = (HV *)SvREFCNT_inc_simple(PL_debstash);
4285
4286     Perl_init_dbargs(aTHX);
4287     PL_DBgv = MUTABLE_GV(
4288         SvREFCNT_inc(gv_fetchpvs("DB::DB", GV_ADDMULTI, SVt_PVGV))
4289     );
4290     PL_DBline = MUTABLE_GV(
4291         SvREFCNT_inc(gv_fetchpvs("DB::dbline", GV_ADDMULTI, SVt_PVAV))
4292     );
4293     PL_DBsub = MUTABLE_GV(SvREFCNT_inc(
4294         gv_HVadd(gv_fetchpvs("DB::sub", GV_ADDMULTI, SVt_PVHV))
4295     ));
4296     PL_DBsingle = GvSV((gv_fetchpvs("DB::single", GV_ADDMULTI, SVt_PV)));
4297     if (!SvIOK(PL_DBsingle))
4298         sv_setiv(PL_DBsingle, 0);
4299     mg = sv_magicext(PL_DBsingle, NULL, PERL_MAGIC_debugvar, &PL_vtbl_debugvar, 0, 0);
4300     mg->mg_private = DBVARMG_SINGLE;
4301     SvSETMAGIC(PL_DBsingle);
4302
4303     PL_DBtrace = GvSV((gv_fetchpvs("DB::trace", GV_ADDMULTI, SVt_PV)));
4304     if (!SvIOK(PL_DBtrace))
4305         sv_setiv(PL_DBtrace, 0);
4306     mg = sv_magicext(PL_DBtrace, NULL, PERL_MAGIC_debugvar, &PL_vtbl_debugvar, 0, 0);
4307     mg->mg_private = DBVARMG_TRACE;
4308     SvSETMAGIC(PL_DBtrace);
4309
4310     PL_DBsignal = GvSV((gv_fetchpvs("DB::signal", GV_ADDMULTI, SVt_PV)));
4311     if (!SvIOK(PL_DBsignal))
4312         sv_setiv(PL_DBsignal, 0);
4313     mg = sv_magicext(PL_DBsignal, NULL, PERL_MAGIC_debugvar, &PL_vtbl_debugvar, 0, 0);
4314     mg->mg_private = DBVARMG_SIGNAL;
4315     SvSETMAGIC(PL_DBsignal);
4316
4317     SvREFCNT_dec(PL_curstash);
4318     PL_curstash = ostash;
4319 }
4320
4321 #ifndef STRESS_REALLOC
4322 #define REASONABLE(size) (size)
4323 #define REASONABLE_but_at_least(size,min) (size)
4324 #else
4325 #define REASONABLE(size) (1) /* unreasonable */
4326 #define REASONABLE_but_at_least(size,min) (min)
4327 #endif
4328
4329 void
4330 Perl_init_stacks(pTHX)
4331 {
4332     SSize_t size;
4333
4334     /* start with 128-item stack and 8K cxstack */
4335     PL_curstackinfo = new_stackinfo(REASONABLE(128),
4336                                  REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
4337     PL_curstackinfo->si_type = PERLSI_MAIN;
4338 #if defined DEBUGGING && !defined DEBUGGING_RE_ONLY
4339     PL_curstackinfo->si_stack_hwm = 0;
4340 #endif
4341     PL_curstack = PL_curstackinfo->si_stack;
4342     PL_mainstack = PL_curstack;         /* remember in case we switch stacks */
4343
4344     PL_stack_base = AvARRAY(PL_curstack);
4345     PL_stack_sp = PL_stack_base;
4346     PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
4347
4348     Newx(PL_tmps_stack,REASONABLE(128),SV*);
4349     PL_tmps_floor = -1;
4350     PL_tmps_ix = -1;
4351     PL_tmps_max = REASONABLE(128);
4352
4353     Newx(PL_markstack,REASONABLE(32),I32);
4354     PL_markstack_ptr = PL_markstack;
4355     PL_markstack_max = PL_markstack + REASONABLE(32);
4356
4357     SET_MARK_OFFSET;
4358
4359     Newx(PL_scopestack,REASONABLE(32),I32);
4360 #ifdef DEBUGGING
4361     Newx(PL_scopestack_name,REASONABLE(32),const char*);
4362 #endif
4363     PL_scopestack_ix = 0;
4364     PL_scopestack_max = REASONABLE(32);
4365
4366     size = REASONABLE_but_at_least(128,SS_MAXPUSH);
4367     Newx(PL_savestack, size, ANY);
4368     PL_savestack_ix = 0;
4369     /*PL_savestack_max lies: it always has SS_MAXPUSH more than it claims */
4370     PL_savestack_max = size - SS_MAXPUSH;
4371 }
4372
4373 #undef REASONABLE
4374
4375 STATIC void
4376 S_nuke_stacks(pTHX)
4377 {
4378     while (PL_curstackinfo->si_next)
4379         PL_curstackinfo = PL_curstackinfo->si_next;
4380     while (PL_curstackinfo) {
4381         PERL_SI *p = PL_curstackinfo->si_prev;
4382         /* curstackinfo->si_stack got nuked by sv_free_arenas() */
4383         Safefree(PL_curstackinfo->si_cxstack);
4384         Safefree(PL_curstackinfo);
4385         PL_curstackinfo = p;
4386     }
4387     Safefree(PL_tmps_stack);
4388     Safefree(PL_markstack);
4389     Safefree(PL_scopestack);
4390 #ifdef DEBUGGING
4391     Safefree(PL_scopestack_name);
4392 #endif
4393     Safefree(PL_savestack);
4394 }
4395
4396 void
4397 Perl_populate_isa(pTHX_ const char *name, STRLEN len, ...)
4398 {
4399     GV *const gv = gv_fetchpvn(name, len, GV_ADD | GV_ADDMULTI, SVt_PVAV);
4400     AV *const isa = GvAVn(gv);
4401     va_list args;
4402
4403     PERL_ARGS_ASSERT_POPULATE_ISA;
4404
4405     if(AvFILLp(isa) != -1)
4406         return;
4407
4408     /* NOTE: No support for tied ISA */
4409
4410     va_start(args, len);
4411     do {
4412         const char *const parent = va_arg(args, const char*);
4413         size_t parent_len;
4414
4415         if (!parent)
4416             break;
4417         parent_len = va_arg(args, size_t);
4418
4419         /* Arguments are supplied with a trailing ::  */
4420         assert(parent_len > 2);
4421         assert(parent[parent_len - 1] == ':');
4422         assert(parent[parent_len - 2] == ':');
4423         av_push(isa, newSVpvn(parent, parent_len - 2));
4424         (void) gv_fetchpvn(parent, parent_len, GV_ADD, SVt_PVGV);
4425     } while (1);
4426     va_end(args);
4427 }
4428
4429
4430 STATIC void
4431 S_init_predump_symbols(pTHX)
4432 {
4433     GV *tmpgv;
4434     IO *io;
4435
4436     sv_setpvs(get_sv("\"", GV_ADD), " ");
4437     PL_ofsgv = (GV*)SvREFCNT_inc(gv_fetchpvs(",", GV_ADD|GV_NOTQUAL, SVt_PV));
4438
4439
4440     /* Historically, PVIOs were blessed into IO::Handle, unless
4441        FileHandle was loaded, in which case they were blessed into
4442        that. Action at a distance.
4443        However, if we simply bless into IO::Handle, we break code
4444        that assumes that PVIOs will have (among others) a seek
4445        method. IO::File inherits from IO::Handle and IO::Seekable,
4446        and provides the needed methods. But if we simply bless into
4447        it, then we break code that assumed that by loading
4448        IO::Handle, *it* would work.
4449        So a compromise is to set up the correct @IO::File::ISA,
4450        so that code that does C<use IO::Handle>; will still work.
4451     */
4452                    
4453     Perl_populate_isa(aTHX_ STR_WITH_LEN("IO::File::ISA"),
4454                       STR_WITH_LEN("IO::Handle::"),
4455                       STR_WITH_LEN("IO::Seekable::"),
4456                       STR_WITH_LEN("Exporter::"),
4457                       NULL);
4458
4459     PL_stdingv = gv_fetchpvs("STDIN", GV_ADD|GV_NOTQUAL, SVt_PVIO);
4460     GvMULTI_on(PL_stdingv);
4461     io = GvIOp(PL_stdingv);
4462     IoTYPE(io) = IoTYPE_RDONLY;
4463     IoIFP(io) = PerlIO_stdin();
4464     tmpgv = gv_fetchpvs("stdin", GV_ADD|GV_NOTQUAL, SVt_PV);
4465     GvMULTI_on(tmpgv);
4466     GvIOp(tmpgv) = MUTABLE_IO(SvREFCNT_inc_simple(io));
4467
4468     tmpgv = gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVIO);
4469     GvMULTI_on(tmpgv);
4470     io = GvIOp(tmpgv);
4471     IoTYPE(io) = IoTYPE_WRONLY;
4472     IoOFP(io) = IoIFP(io) = PerlIO_stdout();
4473     setdefout(tmpgv);
4474     tmpgv = gv_fetchpvs("stdout", GV_ADD|GV_NOTQUAL, SVt_PV);
4475     GvMULTI_on(tmpgv);
4476     GvIOp(tmpgv) = MUTABLE_IO(SvREFCNT_inc_simple(io));
4477
4478     PL_stderrgv = gv_fetchpvs("STDERR", GV_ADD|GV_NOTQUAL, SVt_PVIO);
4479     GvMULTI_on(PL_stderrgv);
4480     io = GvIOp(PL_stderrgv);
4481     IoTYPE(io) = IoTYPE_WRONLY;
4482     IoOFP(io) = IoIFP(io) = PerlIO_stderr();
4483     tmpgv = gv_fetchpvs("stderr", GV_ADD|GV_NOTQUAL, SVt_PV);
4484     GvMULTI_on(tmpgv);
4485     GvIOp(tmpgv) = MUTABLE_IO(SvREFCNT_inc_simple(io));
4486
4487     PL_statname = newSVpvs("");         /* last filename we did stat on */
4488 }
4489
4490 void
4491 Perl_init_argv_symbols(pTHX_ int argc, char **argv)
4492 {
4493     PERL_ARGS_ASSERT_INIT_ARGV_SYMBOLS;
4494
4495     argc--,argv++;      /* skip name of script */
4496     if (PL_doswitches) {
4497         for (; argc > 0 && **argv == '-'; argc--,argv++) {
4498             char *s;
4499             if (!argv[0][1])
4500                 break;
4501             if (argv[0][1] == '-' && !argv[0][2]) {
4502                 argc--,argv++;
4503                 break;
4504             }
4505             if ((s = strchr(argv[0], '='))) {
4506                 const char *const start_name = argv[0] + 1;
4507                 sv_setpv(GvSV(gv_fetchpvn_flags(start_name, s - start_name,
4508                                                 TRUE, SVt_PV)), s + 1);
4509             }
4510             else
4511                 sv_setiv(GvSV(gv_fetchpv(argv[0]+1, GV_ADD, SVt_PV)),1);
4512         }
4513     }
4514     if ((PL_argvgv = gv_fetchpvs("ARGV", GV_ADD|GV_NOTQUAL, SVt_PVAV))) {
4515         SvREFCNT_inc_simple_void_NN(PL_argvgv);
4516         GvMULTI_on(PL_argvgv);
4517         av_clear(GvAVn(PL_argvgv));
4518         for (; argc > 0; argc--,argv++) {
4519             SV * const sv = newSVpv(argv[0],0);
4520             av_push(GvAV(PL_argvgv),sv);
4521             if (!(PL_unicode & PERL_UNICODE_LOCALE_FLAG) || PL_utf8locale) {
4522                  if (PL_unicode & PERL_UNICODE_ARGV_FLAG)
4523                       SvUTF8_on(sv);
4524             }
4525             if (PL_unicode & PERL_UNICODE_WIDESYSCALLS_FLAG) /* Sarathy? */
4526                  (void)sv_utf8_decode(sv);
4527         }
4528     }
4529
4530     if (PL_inplace && (!PL_argvgv || AvFILL(GvAV(PL_argvgv)) == -1))
4531         Perl_ck_warner_d(aTHX_ packWARN(WARN_INPLACE),
4532                          "-i used with no filenames on the command line, "
4533                          "reading from STDIN");
4534 }
4535
4536 STATIC void
4537 S_init_postdump_symbols(pTHX_ int argc, char **argv, char **env)
4538 {
4539 #ifdef USE_ITHREADS
4540 #endif
4541     GV* tmpgv;
4542
4543     PERL_ARGS_ASSERT_INIT_POSTDUMP_SYMBOLS;
4544
4545     PL_toptarget = newSV_type(SVt_PVIV);
4546     SvPVCLEAR(PL_toptarget);
4547     PL_bodytarget = newSV_type(SVt_PVIV);
4548     SvPVCLEAR(PL_bodytarget);
4549     PL_formtarget = PL_bodytarget;
4550
4551     TAINT;
4552
4553     init_argv_symbols(argc,argv);
4554
4555     if ((tmpgv = gv_fetchpvs("0", GV_ADD|GV_NOTQUAL, SVt_PV))) {
4556         sv_setpv(GvSV(tmpgv),PL_origfilename);
4557     }
4558     if ((PL_envgv = gv_fetchpvs("ENV", GV_ADD|GV_NOTQUAL, SVt_PVHV))) {
4559         HV *hv;
4560         bool env_is_not_environ;
4561         SvREFCNT_inc_simple_void_NN(PL_envgv);
4562         GvMULTI_on(PL_envgv);
4563         hv = GvHVn(PL_envgv);
4564         hv_magic(hv, NULL, PERL_MAGIC_env);
4565 #ifndef PERL_MICRO
4566 #ifdef USE_ENVIRON_ARRAY
4567         /* Note that if the supplied env parameter is actually a copy
4568            of the global environ then it may now point to free'd memory
4569            if the environment has been modified since. To avoid this
4570            problem we treat env==NULL as meaning 'use the default'
4571         */
4572         if (!env)
4573             env = environ;
4574         env_is_not_environ = env != environ;
4575         if (env_is_not_environ
4576 #  ifdef USE_ITHREADS
4577             && PL_curinterp == aTHX
4578 #  endif
4579            )
4580         {
4581             environ[0] = NULL;
4582         }
4583         if (env) {
4584           char *s, *old_var;
4585           STRLEN nlen;
4586           SV *sv;
4587           HV *dups = newHV();
4588
4589           for (; *env; env++) {
4590             old_var = *env;
4591
4592             if (!(s = strchr(old_var,'=')) || s == old_var)
4593                 continue;
4594             nlen = s - old_var;
4595
4596 #if defined(MSDOS) && !defined(DJGPP)
4597             *s = '\0';
4598             (void)strupr(old_var);
4599             *s = '=';
4600 #endif
4601             if (hv_exists(hv, old_var, nlen)) {
4602                 const char *name = savepvn(old_var, nlen);
4603
4604                 /* make sure we use the same value as getenv(), otherwise code that
4605                    uses getenv() (like setlocale()) might see a different value to %ENV
4606                  */
4607                 sv = newSVpv(PerlEnv_getenv(name), 0);
4608
4609                 /* keep a count of the dups of this name so we can de-dup environ later */
4610                 if (hv_exists(dups, name, nlen))
4611                     ++SvIVX(*hv_fetch(dups, name, nlen, 0));
4612                 else
4613                     (void)hv_store(dups, name, nlen, newSViv(1), 0);
4614
4615                 Safefree(name);
4616             }
4617             else {
4618                 sv = newSVpv(s+1, 0);
4619             }
4620             (void)hv_store(hv, old_var, nlen, sv, 0);
4621             if (env_is_not_environ)
4622                 mg_set(sv);
4623           }
4624           if (HvKEYS(dups)) {
4625               /* environ has some duplicate definitions, remove them */
4626               HE *entry;
4627               hv_iterinit(dups);
4628               while ((entry = hv_iternext_flags(dups, 0))) {
4629                   STRLEN nlen;
4630                   const char *name = HePV(entry, nlen);
4631                   IV count = SvIV(HeVAL(entry));
4632                   IV i;
4633                   SV **valp = hv_fetch(hv, name, nlen, 0);
4634
4635                   assert(valp);
4636
4637                   /* try to remove any duplicate names, depending on the
4638                    * implementation used in my_setenv() the iteration might
4639                    * not be necessary, but let's be safe.
4640                    */
4641                   for (i = 0; i < count; ++i)
4642                       my_setenv(name, 0);
4643
4644                   /* and set it back to the value we set $ENV{name} to */
4645                   my_setenv(name, SvPV_nolen(*valp));
4646               }
4647           }
4648           SvREFCNT_dec_NN(dups);
4649       }
4650 #endif /* USE_ENVIRON_ARRAY */
4651 #endif /* !PERL_MICRO */
4652     }
4653     TAINT_NOT;
4654
4655     /* touch @F array to prevent spurious warnings 20020415 MJD */
4656     if (PL_minus_a) {
4657       (void) get_av("main::F", GV_ADD | GV_ADDMULTI);
4658     }
4659 }
4660
4661 STATIC void
4662 S_init_perllib(pTHX)
4663 {
4664 #ifndef VMS
4665     const char *perl5lib = NULL;
4666 #endif
4667     const char *s;
4668 #if defined(WIN32) && !defined(PERL_IS_MINIPERL)
4669     STRLEN len;
4670 #endif
4671
4672     if (!TAINTING_get) {
4673 #ifndef VMS
4674         perl5lib = PerlEnv_getenv("PERL5LIB");
4675 /*
4676  * It isn't possible to delete an environment variable with
4677  * PERL_USE_SAFE_PUTENV set unless unsetenv() is also available, so in that
4678  * case we treat PERL5LIB as undefined if it has a zero-length value.
4679  */
4680 #if defined(PERL_USE_SAFE_PUTENV) && ! defined(HAS_UNSETENV)
4681         if (perl5lib && *perl5lib != '\0')
4682 #else
4683         if (perl5lib)
4684 #endif
4685             incpush_use_sep(perl5lib, 0, INCPUSH_ADD_SUB_DIRS);
4686         else {
4687             s = PerlEnv_getenv("PERLLIB");
4688             if (s)
4689                 incpush_use_sep(s, 0, 0);
4690         }
4691 #else /* VMS */
4692         /* Treat PERL5?LIB as a possible search list logical name -- the
4693          * "natural" VMS idiom for a Unix path string.  We allow each
4694          * element to be a set of |-separated directories for compatibility.
4695          */
4696         char buf[256];
4697         int idx = 0;
4698         if (vmstrnenv("PERL5LIB",buf,0,NULL,0))
4699             do {
4700                 incpush_use_sep(buf, 0, INCPUSH_ADD_SUB_DIRS);
4701             } while (vmstrnenv("PERL5LIB",buf,++idx,NULL,0));
4702         else {
4703             while (vmstrnenv("PERLLIB",buf,idx++,NULL,0))
4704                 incpush_use_sep(buf, 0, 0);
4705         }
4706 #endif /* VMS */
4707     }
4708
4709 #ifndef PERL_IS_MINIPERL
4710     /* miniperl gets just -I..., the split of $ENV{PERL5LIB}, and "." in @INC
4711        (and not the architecture specific directories from $ENV{PERL5LIB}) */
4712
4713 #include "perl_inc_macro.h"
4714 /* Use the ~-expanded versions of APPLLIB (undocumented),
4715     SITEARCH, SITELIB, VENDORARCH, VENDORLIB, ARCHLIB and PRIVLIB
4716 */
4717     INCPUSH_APPLLIB_EXP
4718     INCPUSH_SITEARCH_EXP
4719     INCPUSH_SITELIB_EXP
4720     INCPUSH_PERL_VENDORARCH_EXP
4721     INCPUSH_PERL_VENDORLIB_EXP
4722     INCPUSH_ARCHLIB_EXP
4723     INCPUSH_PRIVLIB_EXP
4724     INCPUSH_PERL_OTHERLIBDIRS
4725     INCPUSH_PERL5LIB
4726     INCPUSH_APPLLIB_OLD_EXP
4727     INCPUSH_SITELIB_STEM
4728     INCPUSH_PERL_VENDORLIB_STEM
4729     INCPUSH_PERL_OTHERLIBDIRS_ARCHONLY
4730
4731 #endif /* !PERL_IS_MINIPERL */
4732
4733     if (!TAINTING_get) {
4734 #if !defined(PERL_IS_MINIPERL) && defined(DEFAULT_INC_EXCLUDES_DOT)
4735         const char * const unsafe = PerlEnv_getenv("PERL_USE_UNSAFE_INC");
4736         if (unsafe && strEQ(unsafe, "1"))
4737 #endif
4738           S_incpush(aTHX_ STR_WITH_LEN("."), 0);
4739     }
4740 }
4741
4742 #if defined(DOSISH)
4743 #    define PERLLIB_SEP ';'
4744 #elif defined(__VMS)
4745 #    define PERLLIB_SEP PL_perllib_sep
4746 #else
4747 #    define PERLLIB_SEP ':'
4748 #endif
4749 #ifndef PERLLIB_MANGLE
4750 #  define PERLLIB_MANGLE(s,n) (s)
4751 #endif
4752
4753 #ifndef PERL_IS_MINIPERL
4754 /* Push a directory onto @INC if it exists.
4755    Generate a new SV if we do this, to save needing to copy the SV we push
4756    onto @INC  */
4757 STATIC SV *
4758 S_incpush_if_exists(pTHX_ AV *const av, SV *dir, SV *const stem)
4759 {
4760     Stat_t tmpstatbuf;
4761
4762     PERL_ARGS_ASSERT_INCPUSH_IF_EXISTS;
4763
4764     if (PerlLIO_stat(SvPVX_const(dir), &tmpstatbuf) >= 0 &&
4765         S_ISDIR(tmpstatbuf.st_mode)) {
4766         av_push(av, dir);
4767         dir = newSVsv(stem);
4768     } else {
4769         /* Truncate dir back to stem.  */
4770         SvCUR_set(dir, SvCUR(stem));
4771     }
4772     return dir;
4773 }
4774 #endif
4775
4776 STATIC SV *
4777 S_mayberelocate(pTHX_ const char *const dir, STRLEN len, U32 flags)
4778 {
4779     const U8 canrelocate = (U8)flags & INCPUSH_CAN_RELOCATE;
4780     SV *libdir;
4781
4782     PERL_ARGS_ASSERT_MAYBERELOCATE;
4783     assert(len > 0);
4784
4785     /* I am not convinced that this is valid when PERLLIB_MANGLE is
4786        defined to so something (in os2/os2.c), but the code has been
4787        this way, ignoring any possible changed of length, since
4788        760ac839baf413929cd31cc32ffd6dba6b781a81 (5.003_02) so I'll leave
4789        it be.  */
4790     libdir = newSVpvn(PERLLIB_MANGLE(dir, len), len);
4791
4792 #ifdef VMS
4793     {
4794         char *unix;
4795
4796         if ((unix = tounixspec_ts(SvPV(libdir,len),NULL)) != NULL) {
4797             len = strlen(unix);
4798             while (len > 1 && unix[len-1] == '/') len--;  /* Cosmetic */
4799             sv_usepvn(libdir,unix,len);
4800         }
4801         else
4802             PerlIO_printf(Perl_error_log,
4803                           "Failed to unixify @INC element \"%s\"\n",
4804                           SvPV_nolen_const(libdir));
4805     }
4806 #endif
4807
4808         /* Do the if() outside the #ifdef to avoid warnings about an unused
4809            parameter.  */
4810         if (canrelocate) {
4811 #ifdef PERL_RELOCATABLE_INC
4812         /*
4813          * Relocatable include entries are marked with a leading .../
4814          *
4815          * The algorithm is
4816          * 0: Remove that leading ".../"
4817          * 1: Remove trailing executable name (anything after the last '/')
4818          *    from the perl path to give a perl prefix
4819          * Then
4820          * While the @INC element starts "../" and the prefix ends with a real
4821          * directory (ie not . or ..) chop that real directory off the prefix
4822          * and the leading "../" from the @INC element. ie a logical "../"
4823          * cleanup
4824          * Finally concatenate the prefix and the remainder of the @INC element
4825          * The intent is that /usr/local/bin/perl and .../../lib/perl5
4826          * generates /usr/local/lib/perl5
4827          */
4828             const char *libpath = SvPVX(libdir);
4829             STRLEN libpath_len = SvCUR(libdir);
4830             if (memBEGINs(libpath, libpath_len, ".../")) {
4831                 /* Game on!  */
4832                 SV * const caret_X = get_sv("\030", 0);
4833                 /* Going to use the SV just as a scratch buffer holding a C
4834                    string:  */
4835                 SV *prefix_sv;
4836                 char *prefix;
4837                 char *lastslash;
4838
4839                 /* $^X is *the* source of taint if tainting is on, hence
4840                    SvPOK() won't be true.  */
4841                 assert(caret_X);
4842                 assert(SvPOKp(caret_X));
4843                 prefix_sv = newSVpvn_flags(SvPVX(caret_X), SvCUR(caret_X),
4844                                            SvUTF8(caret_X));