This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Consolidate and document all get_cvFOO() variants
[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_cv
2835 =for apidoc_item |CV *|get_cvs|"string"|I32 flags
2836 =for apidoc_item get_cvn_flags
2837
2838 These return the CV of the specified Perl subroutine.  C<flags> are passed to
2839 C<gv_fetchpvn_flags>.  If C<GV_ADD> is set and the Perl subroutine does not
2840 exist then it will be declared (which has the same effect as saying
2841 C<sub name;>).  If C<GV_ADD> is not set and the subroutine does not exist,
2842 then NULL is returned.
2843
2844 The forms differ only in how the subroutine is specified..  With C<get_cvs>,
2845 the name is a literal C string, enclosed in double quotes.  With C<get_cv>, the
2846 name is given by the C<name> parameter, which must be a NUL-terminated C
2847 string.  With C<get_cvn_flags>, the name is also given by the C<name>
2848 parameter, but it is a Perl string (possibly containing embedded NUL bytes),
2849 and its length in bytes is contained in the C<len> parameter.
2850
2851 =for apidoc Amnh||GV_ADD
2852
2853 =cut
2854 */
2855
2856 CV*
2857 Perl_get_cvn_flags(pTHX_ const char *name, STRLEN len, I32 flags)
2858 {
2859     GV* const gv = gv_fetchpvn_flags(name, len, flags, SVt_PVCV);
2860
2861     PERL_ARGS_ASSERT_GET_CVN_FLAGS;
2862
2863     if (gv && UNLIKELY(SvROK(gv)) && SvTYPE(SvRV((SV *)gv)) == SVt_PVCV)
2864         return (CV*)SvRV((SV *)gv);
2865
2866     /* XXX this is probably not what they think they're getting.
2867      * It has the same effect as "sub name;", i.e. just a forward
2868      * declaration! */
2869     if ((flags & ~GV_NOADD_MASK) && !GvCVu(gv)) {
2870         return newSTUB(gv,0);
2871     }
2872     if (gv)
2873         return GvCVu(gv);
2874     return NULL;
2875 }
2876
2877 /* Nothing in core calls this now, but we can't replace it with a macro and
2878    move it to mathoms.c as a macro would evaluate name twice.  */
2879 CV*
2880 Perl_get_cv(pTHX_ const char *name, I32 flags)
2881 {
2882     PERL_ARGS_ASSERT_GET_CV;
2883
2884     return get_cvn_flags(name, strlen(name), flags);
2885 }
2886
2887 /* Be sure to refetch the stack pointer after calling these routines. */
2888
2889 /*
2890
2891 =for apidoc_section $callback
2892
2893 =for apidoc call_argv
2894
2895 Performs a callback to the specified named and package-scoped Perl subroutine 
2896 with C<argv> (a C<NULL>-terminated array of strings) as arguments.  See
2897 L<perlcall>.
2898
2899 Approximate Perl equivalent: C<&{"$sub_name"}(@$argv)>.
2900
2901 =cut
2902 */
2903
2904 I32
2905 Perl_call_argv(pTHX_ const char *sub_name, I32 flags, char **argv)
2906
2907                         /* See G_* flags in cop.h */
2908                         /* null terminated arg list */
2909 {
2910     dSP;
2911
2912     PERL_ARGS_ASSERT_CALL_ARGV;
2913
2914     PUSHMARK(SP);
2915     while (*argv) {
2916         mXPUSHs(newSVpv(*argv,0));
2917         argv++;
2918     }
2919     PUTBACK;
2920     return call_pv(sub_name, flags);
2921 }
2922
2923 /*
2924 =for apidoc call_pv
2925
2926 Performs a callback to the specified Perl sub.  See L<perlcall>.
2927
2928 =cut
2929 */
2930
2931 I32
2932 Perl_call_pv(pTHX_ const char *sub_name, I32 flags)
2933                         /* name of the subroutine */
2934                         /* See G_* flags in cop.h */
2935 {
2936     PERL_ARGS_ASSERT_CALL_PV;
2937
2938     return call_sv(MUTABLE_SV(get_cv(sub_name, GV_ADD)), flags);
2939 }
2940
2941 /*
2942 =for apidoc call_method
2943
2944 Performs a callback to the specified Perl method.  The blessed object must
2945 be on the stack.  See L<perlcall>.
2946
2947 =cut
2948 */
2949
2950 I32
2951 Perl_call_method(pTHX_ const char *methname, I32 flags)
2952                         /* name of the subroutine */
2953                         /* See G_* flags in cop.h */
2954 {
2955     STRLEN len;
2956     SV* sv;
2957     PERL_ARGS_ASSERT_CALL_METHOD;
2958
2959     len = strlen(methname);
2960     sv = flags & G_METHOD_NAMED
2961         ? sv_2mortal(newSVpvn_share(methname, len,0))
2962         : newSVpvn_flags(methname, len, SVs_TEMP);
2963
2964     return call_sv(sv, flags | G_METHOD);
2965 }
2966
2967 /* May be called with any of a CV, a GV, or an SV containing the name. */
2968 /*
2969 =for apidoc call_sv
2970
2971 Performs a callback to the Perl sub specified by the SV.
2972
2973 If neither the C<G_METHOD> nor C<G_METHOD_NAMED> flag is supplied, the
2974 SV may be any of a CV, a GV, a reference to a CV, a reference to a GV
2975 or C<SvPV(sv)> will be used as the name of the sub to call.
2976
2977 If the C<G_METHOD> flag is supplied, the SV may be a reference to a CV or
2978 C<SvPV(sv)> will be used as the name of the method to call.
2979
2980 If the C<G_METHOD_NAMED> flag is supplied, C<SvPV(sv)> will be used as
2981 the name of the method to call.
2982
2983 Some other values are treated specially for internal use and should
2984 not be depended on.
2985
2986 See L<perlcall>.
2987
2988 =for apidoc Amnh||G_METHOD
2989 =for apidoc Amnh||G_METHOD_NAMED
2990
2991 =cut
2992 */
2993
2994 I32
2995 Perl_call_sv(pTHX_ SV *sv, volatile I32 flags)
2996                         /* See G_* flags in cop.h */
2997 {
2998     LOGOP myop;         /* fake syntax tree node */
2999     METHOP method_op;
3000     I32 oldmark;
3001     volatile I32 retval = 0;
3002     bool oldcatch = CATCH_GET;
3003     int ret;
3004     OP* const oldop = PL_op;
3005     dJMPENV;
3006
3007     PERL_ARGS_ASSERT_CALL_SV;
3008
3009     if (flags & G_DISCARD) {
3010         ENTER;
3011         SAVETMPS;
3012     }
3013     if (!(flags & G_WANT)) {
3014         /* Backwards compatibility - as G_SCALAR was 0, it could be omitted.
3015          */
3016         flags |= G_SCALAR;
3017     }
3018
3019     Zero(&myop, 1, LOGOP);
3020     if (!(flags & G_NOARGS))
3021         myop.op_flags |= OPf_STACKED;
3022     myop.op_flags |= OP_GIMME_REVERSE(flags);
3023     SAVEOP();
3024     PL_op = (OP*)&myop;
3025
3026     if (!(flags & G_METHOD_NAMED)) {
3027         dSP;
3028         EXTEND(SP, 1);
3029         PUSHs(sv);
3030         PUTBACK;
3031     }
3032     oldmark = TOPMARK;
3033
3034     if (PERLDB_SUB && PL_curstash != PL_debstash
3035            /* Handle first BEGIN of -d. */
3036           && (PL_DBcv || (PL_DBcv = GvCV(PL_DBsub)))
3037            /* Try harder, since this may have been a sighandler, thus
3038             * curstash may be meaningless. */
3039           && (SvTYPE(sv) != SVt_PVCV || CvSTASH((const CV *)sv) != PL_debstash)
3040           && !(flags & G_NODEBUG))
3041         myop.op_private |= OPpENTERSUB_DB;
3042
3043     if (flags & (G_METHOD|G_METHOD_NAMED)) {
3044         Zero(&method_op, 1, METHOP);
3045         method_op.op_next = (OP*)&myop;
3046         PL_op = (OP*)&method_op;
3047         if ( flags & G_METHOD_NAMED ) {
3048             method_op.op_ppaddr = PL_ppaddr[OP_METHOD_NAMED];
3049             method_op.op_type = OP_METHOD_NAMED;
3050             method_op.op_u.op_meth_sv = sv;
3051         } else {
3052             method_op.op_ppaddr = PL_ppaddr[OP_METHOD];
3053             method_op.op_type = OP_METHOD;
3054         }
3055         myop.op_ppaddr = PL_ppaddr[OP_ENTERSUB];
3056         myop.op_type = OP_ENTERSUB;
3057     }
3058
3059     if (!(flags & G_EVAL)) {
3060         CATCH_SET(TRUE);
3061         CALL_BODY_SUB((OP*)&myop);
3062         retval = PL_stack_sp - (PL_stack_base + oldmark);
3063         CATCH_SET(oldcatch);
3064     }
3065     else {
3066         I32 old_cxix;
3067         myop.op_other = (OP*)&myop;
3068         (void)POPMARK;
3069         old_cxix = cxstack_ix;
3070         create_eval_scope(NULL, flags|G_FAKINGEVAL);
3071         INCMARK;
3072
3073         JMPENV_PUSH(ret);
3074
3075         switch (ret) {
3076         case 0:
3077  redo_body:
3078             CALL_BODY_SUB((OP*)&myop);
3079             retval = PL_stack_sp - (PL_stack_base + oldmark);
3080             if (!(flags & G_KEEPERR)) {
3081                 CLEAR_ERRSV();
3082             }
3083             break;
3084         case 1:
3085             STATUS_ALL_FAILURE;
3086             /* FALLTHROUGH */
3087         case 2:
3088             /* my_exit() was called */
3089             SET_CURSTASH(PL_defstash);
3090             FREETMPS;
3091             JMPENV_POP;
3092             my_exit_jump();
3093             NOT_REACHED; /* NOTREACHED */
3094         case 3:
3095             if (PL_restartop) {
3096                 PL_restartjmpenv = NULL;
3097                 PL_op = PL_restartop;
3098                 PL_restartop = 0;
3099                 goto redo_body;
3100             }
3101             PL_stack_sp = PL_stack_base + oldmark;
3102             if ((flags & G_WANT) == G_ARRAY)
3103                 retval = 0;
3104             else {
3105                 retval = 1;
3106                 *++PL_stack_sp = &PL_sv_undef;
3107             }
3108             break;
3109         }
3110
3111         /* if we croaked, depending on how we croaked the eval scope
3112          * may or may not have already been popped */
3113         if (cxstack_ix > old_cxix) {
3114             assert(cxstack_ix == old_cxix + 1);
3115             assert(CxTYPE(CX_CUR()) == CXt_EVAL);
3116             delete_eval_scope();
3117         }
3118         JMPENV_POP;
3119     }
3120
3121     if (flags & G_DISCARD) {
3122         PL_stack_sp = PL_stack_base + oldmark;
3123         retval = 0;
3124         FREETMPS;
3125         LEAVE;
3126     }
3127     PL_op = oldop;
3128     return retval;
3129 }
3130
3131 /* Eval a string. The G_EVAL flag is always assumed. */
3132
3133 /*
3134 =for apidoc eval_sv
3135
3136 Tells Perl to C<eval> the string in the SV.  It supports the same flags
3137 as C<call_sv>, with the obvious exception of C<G_EVAL>.  See L<perlcall>.
3138
3139 The C<G_RETHROW> flag can be used if you only need eval_sv() to
3140 execute code specified by a string, but not catch any errors.
3141
3142 =for apidoc Amnh||G_RETHROW
3143 =cut
3144 */
3145
3146 I32
3147 Perl_eval_sv(pTHX_ SV *sv, I32 flags)
3148
3149                         /* See G_* flags in cop.h */
3150 {
3151     UNOP myop;          /* fake syntax tree node */
3152     volatile I32 oldmark;
3153     volatile I32 retval = 0;
3154     int ret;
3155     OP* const oldop = PL_op;
3156     dJMPENV;
3157
3158     PERL_ARGS_ASSERT_EVAL_SV;
3159
3160     if (flags & G_DISCARD) {
3161         ENTER;
3162         SAVETMPS;
3163     }
3164
3165     SAVEOP();
3166     PL_op = (OP*)&myop;
3167     Zero(&myop, 1, UNOP);
3168     {
3169         dSP;
3170         oldmark = SP - PL_stack_base;
3171         EXTEND(SP, 1);
3172         PUSHs(sv);
3173         PUTBACK;
3174     }
3175
3176     if (!(flags & G_NOARGS))
3177         myop.op_flags = OPf_STACKED;
3178     myop.op_type = OP_ENTEREVAL;
3179     myop.op_flags |= OP_GIMME_REVERSE(flags);
3180     if (flags & G_KEEPERR)
3181         myop.op_flags |= OPf_SPECIAL;
3182
3183     if (flags & G_RE_REPARSING)
3184         myop.op_private = (OPpEVAL_COPHH | OPpEVAL_RE_REPARSING);
3185
3186     /* fail now; otherwise we could fail after the JMPENV_PUSH but
3187      * before a cx_pusheval(), which corrupts the stack after a croak */
3188     TAINT_PROPER("eval_sv()");
3189
3190     JMPENV_PUSH(ret);
3191     switch (ret) {
3192     case 0:
3193  redo_body:
3194         if (PL_op == (OP*)(&myop)) {
3195             PL_op = PL_ppaddr[OP_ENTEREVAL](aTHX);
3196             if (!PL_op)
3197                 goto fail; /* failed in compilation */
3198         }
3199         CALLRUNOPS(aTHX);
3200         retval = PL_stack_sp - (PL_stack_base + oldmark);
3201         if (!(flags & G_KEEPERR)) {
3202             CLEAR_ERRSV();
3203         }
3204         break;
3205     case 1:
3206         STATUS_ALL_FAILURE;
3207         /* FALLTHROUGH */
3208     case 2:
3209         /* my_exit() was called */
3210         SET_CURSTASH(PL_defstash);
3211         FREETMPS;
3212         JMPENV_POP;
3213         my_exit_jump();
3214         NOT_REACHED; /* NOTREACHED */
3215     case 3:
3216         if (PL_restartop) {
3217             PL_restartjmpenv = NULL;
3218             PL_op = PL_restartop;
3219             PL_restartop = 0;
3220             goto redo_body;
3221         }
3222       fail:
3223         if (flags & G_RETHROW) {
3224             JMPENV_POP;
3225             croak_sv(ERRSV);
3226         }
3227
3228         PL_stack_sp = PL_stack_base + oldmark;
3229         if ((flags & G_WANT) == G_ARRAY)
3230             retval = 0;
3231         else {
3232             retval = 1;
3233             *++PL_stack_sp = &PL_sv_undef;
3234         }
3235         break;
3236     }
3237
3238     JMPENV_POP;
3239     if (flags & G_DISCARD) {
3240         PL_stack_sp = PL_stack_base + oldmark;
3241         retval = 0;
3242         FREETMPS;
3243         LEAVE;
3244     }
3245     PL_op = oldop;
3246     return retval;
3247 }
3248
3249 /*
3250 =for apidoc eval_pv
3251
3252 Tells Perl to C<eval> the given string in scalar context and return an SV* result.
3253
3254 =cut
3255 */
3256
3257 SV*
3258 Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error)
3259 {
3260     SV* sv = newSVpv(p, 0);
3261
3262     PERL_ARGS_ASSERT_EVAL_PV;
3263
3264     if (croak_on_error) {
3265         sv_2mortal(sv);
3266         eval_sv(sv, G_SCALAR | G_RETHROW);
3267     }
3268     else {
3269         eval_sv(sv, G_SCALAR);
3270         SvREFCNT_dec(sv);
3271     }
3272
3273     {
3274         dSP;
3275         sv = POPs;
3276         PUTBACK;
3277     }
3278
3279     return sv;
3280 }
3281
3282 /* Require a module. */
3283
3284 /*
3285 =for apidoc_section $embedding
3286
3287 =for apidoc require_pv
3288
3289 Tells Perl to C<require> the file named by the string argument.  It is
3290 analogous to the Perl code C<eval "require '$file'">.  It's even
3291 implemented that way; consider using load_module instead.
3292
3293 =cut */
3294
3295 void
3296 Perl_require_pv(pTHX_ const char *pv)
3297 {
3298     dSP;
3299     SV* sv;
3300
3301     PERL_ARGS_ASSERT_REQUIRE_PV;
3302
3303     PUSHSTACKi(PERLSI_REQUIRE);
3304     sv = Perl_newSVpvf(aTHX_ "require q%c%s%c", 0, pv, 0);
3305     eval_sv(sv_2mortal(sv), G_DISCARD);
3306     POPSTACK;
3307 }
3308
3309 STATIC void
3310 S_usage(pTHX)           /* XXX move this out into a module ? */
3311 {
3312     /* This message really ought to be max 23 lines.
3313      * Removed -h because the user already knows that option. Others? */
3314
3315     /* Grouped as 6 lines per C string literal, to keep under the ANSI C 89
3316        minimum of 509 character string literals.  */
3317     static const char * const usage_msg[] = {
3318 "  -0[octal/hexadecimal] specify record separator (\\0, if no argument)\n"
3319 "  -a                    autosplit mode with -n or -p (splits $_ into @F)\n"
3320 "  -C[number/list]       enables the listed Unicode features\n"
3321 "  -c                    check syntax only (runs BEGIN and CHECK blocks)\n"
3322 "  -d[t][:MOD]           run program under debugger or module Devel::MOD\n"
3323 "  -D[number/letters]    set debugging flags (argument is a bit mask or alphabets)\n",
3324 "  -e commandline        one line of program (several -e's allowed, omit programfile)\n"
3325 "  -E commandline        like -e, but enables all optional features\n"
3326 "  -f                    don't do $sitelib/sitecustomize.pl at startup\n"
3327 "  -F/pattern/           split() pattern for -a switch (//'s are optional)\n"
3328 "  -i[extension]         edit <> files in place (makes backup if extension supplied)\n"
3329 "  -Idirectory           specify @INC/#include directory (several -I's allowed)\n",
3330 "  -l[octnum]            enable line ending processing, specifies line terminator\n"
3331 "  -[mM][-]module        execute \"use/no module...\" before executing program\n"
3332 "  -n                    assume \"while (<>) { ... }\" loop around program\n"
3333 "  -p                    assume loop like -n but print line also, like sed\n"
3334 "  -s                    enable rudimentary parsing for switches after programfile\n"
3335 "  -S                    look for programfile using PATH environment variable\n",
3336 "  -t                    enable tainting warnings\n"
3337 "  -T                    enable tainting checks\n"
3338 "  -u                    dump core after parsing program\n"
3339 "  -U                    allow unsafe operations\n"
3340 "  -v                    print version, patchlevel and license\n"
3341 "  -V[:configvar]        print configuration summary (or a single Config.pm variable)\n",
3342 "  -w                    enable many useful warnings\n"
3343 "  -W                    enable all warnings\n"
3344 "  -x[directory]         ignore text before #!perl line (optionally cd to directory)\n"
3345 "  -X                    disable all warnings\n"
3346 "  \n"
3347 "Run 'perldoc perl' for more help with Perl.\n\n",
3348 NULL
3349 };
3350     const char * const *p = usage_msg;
3351     PerlIO *out = PerlIO_stdout();
3352
3353     PerlIO_printf(out,
3354                   "\nUsage: %s [switches] [--] [programfile] [arguments]\n",
3355                   PL_origargv[0]);
3356     while (*p)
3357         PerlIO_puts(out, *p++);
3358     my_exit(0);
3359 }
3360
3361 /* convert a string of -D options (or digits) into an int.
3362  * sets *s to point to the char after the options */
3363
3364 #ifdef DEBUGGING
3365 int
3366 Perl_get_debug_opts(pTHX_ const char **s, bool givehelp)
3367 {
3368     static const char * const usage_msgd[] = {
3369       " Debugging flag values: (see also -d)\n"
3370       "  p  Tokenizing and parsing (with v, displays parse stack)\n"
3371       "  s  Stack snapshots (with v, displays all stacks)\n"
3372       "  l  Context (loop) stack processing\n"
3373       "  t  Trace execution\n"
3374       "  o  Method and overloading resolution\n",
3375       "  c  String/numeric conversions\n"
3376       "  P  Print profiling info, source file input state\n"
3377       "  m  Memory and SV allocation\n"
3378       "  f  Format processing\n"
3379       "  r  Regular expression parsing and execution\n"
3380       "  x  Syntax tree dump\n",
3381       "  u  Tainting checks\n"
3382       "  H  Hash dump -- usurps values()\n"
3383       "  X  Scratchpad allocation\n"
3384       "  D  Cleaning up\n"
3385       "  S  Op slab allocation\n"
3386       "  T  Tokenising\n"
3387       "  R  Include reference counts of dumped variables (eg when using -Ds)\n",
3388       "  J  Do not s,t,P-debug (Jump over) opcodes within package DB\n"
3389       "  v  Verbose: use in conjunction with other flags\n"
3390       "  C  Copy On Write\n"
3391       "  A  Consistency checks on internal structures\n"
3392       "  q  quiet - currently only suppresses the 'EXECUTING' message\n"
3393       "  M  trace smart match resolution\n"
3394       "  B  dump suBroutine definitions, including special Blocks like BEGIN\n",
3395       "  L  trace some locale setting information--for Perl core development\n",
3396       "  i  trace PerlIO layer processing\n",
3397       "  y  trace y///, tr/// compilation and execution\n",
3398       NULL
3399     };
3400     UV uv = 0;
3401
3402     PERL_ARGS_ASSERT_GET_DEBUG_OPTS;
3403
3404     if (isALPHA(**s)) {
3405         /* if adding extra options, remember to update DEBUG_MASK */
3406         static const char debopts[] = "psltocPmfrxuUHXDSTRJvCAqMBLiy";
3407
3408         for (; isWORDCHAR(**s); (*s)++) {
3409             const char * const d = strchr(debopts,**s);
3410             if (d)
3411                 uv |= 1 << (d - debopts);
3412             else if (ckWARN_d(WARN_DEBUGGING))
3413                 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
3414                     "invalid option -D%c, use -D'' to see choices\n", **s);
3415         }
3416     }
3417     else if (isDIGIT(**s)) {
3418         const char* e = *s + strlen(*s);
3419         if (grok_atoUV(*s, &uv, &e))
3420             *s = e;
3421         for (; isWORDCHAR(**s); (*s)++) ;
3422     }
3423     else if (givehelp) {
3424       const char *const *p = usage_msgd;
3425       while (*p) PerlIO_puts(PerlIO_stdout(), *p++);
3426     }
3427     return (int)uv; /* ignore any UV->int conversion loss */
3428 }
3429 #endif
3430
3431 /* This routine handles any switches that can be given during run */
3432
3433 const char *
3434 Perl_moreswitches(pTHX_ const char *s)
3435 {
3436     UV rschar;
3437     const char option = *s; /* used to remember option in -m/-M code */
3438
3439     PERL_ARGS_ASSERT_MORESWITCHES;
3440
3441     switch (*s) {
3442     case '0':
3443     {
3444          I32 flags = 0;
3445          STRLEN numlen;
3446
3447          SvREFCNT_dec(PL_rs);
3448          if (s[1] == 'x' && s[2]) {
3449               const char *e = s+=2;
3450               U8 *tmps;
3451
3452               while (*e)
3453                 e++;
3454               numlen = e - s;
3455               flags = PERL_SCAN_SILENT_ILLDIGIT;
3456               rschar = (U32)grok_hex(s, &numlen, &flags, NULL);
3457               if (s + numlen < e) {
3458                    rschar = 0; /* Grandfather -0xFOO as -0 -xFOO. */
3459                    numlen = 0;
3460                    s--;
3461               }
3462               PL_rs = newSVpvs("");
3463               tmps = (U8*) SvGROW(PL_rs, (STRLEN)(UVCHR_SKIP(rschar) + 1));
3464               uvchr_to_utf8(tmps, rschar);
3465               SvCUR_set(PL_rs, UVCHR_SKIP(rschar));
3466               SvUTF8_on(PL_rs);
3467          }
3468          else {
3469               numlen = 4;
3470               rschar = (U32)grok_oct(s, &numlen, &flags, NULL);
3471               if (rschar & ~((U8)~0))
3472                    PL_rs = &PL_sv_undef;
3473               else if (!rschar && numlen >= 2)
3474                    PL_rs = newSVpvs("");
3475               else {
3476                    char ch = (char)rschar;
3477                    PL_rs = newSVpvn(&ch, 1);
3478               }
3479          }
3480          sv_setsv(get_sv("/", GV_ADD), PL_rs);
3481          return s + numlen;
3482     }
3483     case 'C':
3484         s++;
3485         PL_unicode = parse_unicode_opts( (const char **)&s );
3486         if (PL_unicode & PERL_UNICODE_UTF8CACHEASSERT_FLAG)
3487             PL_utf8cache = -1;
3488         return s;
3489     case 'F':
3490         PL_minus_a = TRUE;
3491         PL_minus_F = TRUE;
3492         PL_minus_n = TRUE;
3493         PL_splitstr = ++s;
3494         while (*s && !isSPACE(*s)) ++s;
3495         PL_splitstr = savepvn(PL_splitstr, s - PL_splitstr);
3496         return s;
3497     case 'a':
3498         PL_minus_a = TRUE;
3499         PL_minus_n = TRUE;
3500         s++;
3501         return s;
3502     case 'c':
3503         PL_minus_c = TRUE;
3504         s++;
3505         return s;
3506     case 'd':
3507         forbid_setid('d', FALSE);
3508         s++;
3509
3510         /* -dt indicates to the debugger that threads will be used */
3511         if (*s == 't' && !isWORDCHAR(s[1])) {
3512             ++s;
3513             my_setenv("PERL5DB_THREADED", "1");
3514         }
3515
3516         /* The following permits -d:Mod to accepts arguments following an =
3517            in the fashion that -MSome::Mod does. */
3518         if (*s == ':' || *s == '=') {
3519             const char *start;
3520             const char *end;
3521             SV *sv;
3522
3523             if (*++s == '-') {
3524                 ++s;
3525                 sv = newSVpvs("no Devel::");
3526             } else {
3527                 sv = newSVpvs("use Devel::");
3528             }
3529
3530             start = s;
3531             end = s + strlen(s);
3532
3533             /* We now allow -d:Module=Foo,Bar and -d:-Module */
3534             while(isWORDCHAR(*s) || *s==':') ++s;
3535             if (*s != '=')
3536                 sv_catpvn(sv, start, end - start);
3537             else {
3538                 sv_catpvn(sv, start, s-start);
3539                 /* Don't use NUL as q// delimiter here, this string goes in the
3540                  * environment. */
3541                 Perl_sv_catpvf(aTHX_ sv, " split(/,/,q{%s});", ++s);
3542             }
3543             s = end;
3544             my_setenv("PERL5DB", SvPV_nolen_const(sv));
3545             SvREFCNT_dec(sv);
3546         }
3547         if (!PL_perldb) {
3548             PL_perldb = PERLDB_ALL;
3549             init_debugger();
3550         }
3551         return s;
3552     case 'D':
3553     {   
3554 #ifdef DEBUGGING
3555         forbid_setid('D', FALSE);
3556         s++;
3557         PL_debug = get_debug_opts( (const char **)&s, 1) | DEBUG_TOP_FLAG;
3558 #else /* !DEBUGGING */
3559         if (ckWARN_d(WARN_DEBUGGING))
3560             Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
3561                    "Recompile perl with -DDEBUGGING to use -D switch (did you mean -d ?)\n");
3562         for (s++; isWORDCHAR(*s); s++) ;
3563 #endif
3564         return s;
3565         NOT_REACHED; /* NOTREACHED */
3566     }   
3567     case 'h':
3568         usage();
3569         NOT_REACHED; /* NOTREACHED */
3570
3571     case 'i':
3572         Safefree(PL_inplace);
3573         {
3574             const char * const start = ++s;
3575             while (*s && !isSPACE(*s))
3576                 ++s;
3577
3578             PL_inplace = savepvn(start, s - start);
3579         }
3580         return s;
3581     case 'I':   /* -I handled both here and in parse_body() */
3582         forbid_setid('I', FALSE);
3583         ++s;
3584         while (*s && isSPACE(*s))
3585             ++s;
3586         if (*s) {
3587             const char *e, *p;
3588             p = s;
3589             /* ignore trailing spaces (possibly followed by other switches) */
3590             do {
3591                 for (e = p; *e && !isSPACE(*e); e++) ;
3592                 p = e;
3593                 while (isSPACE(*p))
3594                     p++;
3595             } while (*p && *p != '-');
3596             incpush(s, e-s,
3597                     INCPUSH_ADD_SUB_DIRS|INCPUSH_ADD_OLD_VERS|INCPUSH_UNSHIFT);
3598             s = p;
3599             if (*s == '-')
3600                 s++;
3601         }
3602         else
3603             Perl_croak(aTHX_ "No directory specified for -I");
3604         return s;
3605     case 'l':
3606         PL_minus_l = TRUE;
3607         s++;
3608         if (PL_ors_sv) {
3609             SvREFCNT_dec(PL_ors_sv);
3610             PL_ors_sv = NULL;
3611         }
3612         if (isDIGIT(*s)) {
3613             I32 flags = 0;
3614             STRLEN numlen;
3615             PL_ors_sv = newSVpvs("\n");
3616             numlen = 3 + (*s == '0');
3617             *SvPVX(PL_ors_sv) = (char)grok_oct(s, &numlen, &flags, NULL);
3618             s += numlen;
3619         }
3620         else {
3621             if (RsPARA(PL_rs)) {
3622                 PL_ors_sv = newSVpvs("\n\n");
3623             }
3624             else {
3625                 PL_ors_sv = newSVsv(PL_rs);
3626             }
3627         }
3628         return s;
3629     case 'M':
3630         forbid_setid('M', FALSE);       /* XXX ? */
3631         /* FALLTHROUGH */
3632     case 'm':
3633         forbid_setid('m', FALSE);       /* XXX ? */
3634         if (*++s) {
3635             const char *start;
3636             const char *end;
3637             SV *sv;
3638             const char *use = "use ";
3639             bool colon = FALSE;
3640             /* -M-foo == 'no foo'       */
3641             /* Leading space on " no " is deliberate, to make both
3642                possibilities the same length.  */
3643             if (*s == '-') { use = " no "; ++s; }
3644             sv = newSVpvn(use,4);
3645             start = s;
3646             /* We allow -M'Module qw(Foo Bar)'  */
3647             while(isWORDCHAR(*s) || *s==':') {
3648                 if( *s++ == ':' ) {
3649                     if( *s == ':' ) 
3650                         s++;
3651                     else
3652                         colon = TRUE;
3653                 }
3654             }
3655             if (s == start)
3656                 Perl_croak(aTHX_ "Module name required with -%c option",
3657                                     option);
3658             if (colon) 
3659                 Perl_croak(aTHX_ "Invalid module name %.*s with -%c option: "
3660                                     "contains single ':'",
3661                                     (int)(s - start), start, option);
3662             end = s + strlen(s);
3663             if (*s != '=') {
3664                 sv_catpvn(sv, start, end - start);
3665                 if (option == 'm') {
3666                     if (*s != '\0')
3667                         Perl_croak(aTHX_ "Can't use '%c' after -mname", *s);
3668                     sv_catpvs( sv, " ()");
3669                 }
3670             } else {
3671                 sv_catpvn(sv, start, s-start);
3672                 /* Use NUL as q''-delimiter.  */
3673                 sv_catpvs(sv, " split(/,/,q\0");
3674                 ++s;
3675                 sv_catpvn(sv, s, end - s);
3676                 sv_catpvs(sv,  "\0)");
3677             }
3678             s = end;
3679             Perl_av_create_and_push(aTHX_ &PL_preambleav, sv);
3680         }
3681         else
3682             Perl_croak(aTHX_ "Missing argument to -%c", option);
3683         return s;
3684     case 'n':
3685         PL_minus_n = TRUE;
3686         s++;
3687         return s;
3688     case 'p':
3689         PL_minus_p = TRUE;
3690         s++;
3691         return s;
3692     case 's':
3693         forbid_setid('s', FALSE);
3694         PL_doswitches = TRUE;
3695         s++;
3696         return s;
3697     case 't':
3698     case 'T':
3699 #if defined(SILENT_NO_TAINT_SUPPORT)
3700             /* silently ignore */
3701 #elif defined(NO_TAINT_SUPPORT)
3702         Perl_croak_nocontext("This perl was compiled without taint support. "
3703                    "Cowardly refusing to run with -t or -T flags");
3704 #else
3705         if (!TAINTING_get)
3706             TOO_LATE_FOR(*s);
3707 #endif
3708         s++;
3709         return s;
3710     case 'u':
3711         PL_do_undump = TRUE;
3712         s++;
3713         return s;
3714     case 'U':
3715         PL_unsafe = TRUE;
3716         s++;
3717         return s;
3718     case 'v':
3719         minus_v();
3720     case 'w':
3721         if (! (PL_dowarn & G_WARN_ALL_MASK)) {
3722             PL_dowarn |= G_WARN_ON;
3723         }
3724         s++;
3725         return s;
3726     case 'W':
3727         PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
3728     free_and_set_cop_warnings(&PL_compiling, pWARN_ALL);
3729         s++;
3730         return s;
3731     case 'X':
3732         PL_dowarn = G_WARN_ALL_OFF;
3733     free_and_set_cop_warnings(&PL_compiling, pWARN_NONE);
3734         s++;
3735         return s;
3736     case '*':
3737     case ' ':
3738         while( *s == ' ' )
3739           ++s;
3740         if (s[0] == '-')        /* Additional switches on #! line. */
3741             return s+1;
3742         break;
3743     case '-':
3744     case 0:
3745 #if defined(WIN32) || !defined(PERL_STRICT_CR)
3746     case '\r':
3747 #endif
3748     case '\n':
3749     case '\t':
3750         break;
3751 #ifdef ALTERNATE_SHEBANG
3752     case 'S':                   /* OS/2 needs -S on "extproc" line. */
3753         break;
3754 #endif
3755     case 'e': case 'f': case 'x': case 'E':
3756 #ifndef ALTERNATE_SHEBANG
3757     case 'S':
3758 #endif
3759     case 'V':
3760         Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s);
3761     default:
3762         Perl_croak(aTHX_
3763             "Unrecognized switch: -%.1s  (-h will show valid options)",s
3764         );
3765     }
3766     return NULL;
3767 }
3768
3769
3770 STATIC void
3771 S_minus_v(pTHX)
3772 {
3773         PerlIO * PIO_stdout;
3774         {
3775             const char * const level_str = "v" PERL_VERSION_STRING;
3776             const STRLEN level_len = sizeof("v" PERL_VERSION_STRING)-1;
3777 #ifdef PERL_PATCHNUM
3778             SV* level;
3779 #  ifdef PERL_GIT_UNCOMMITTED_CHANGES
3780             static const char num [] = PERL_PATCHNUM "*";
3781 #  else
3782             static const char num [] = PERL_PATCHNUM;
3783 #  endif
3784             {
3785                 const STRLEN num_len = sizeof(num)-1;
3786                 /* A very advanced compiler would fold away the strnEQ
3787                    and this whole conditional, but most (all?) won't do it.
3788                    SV level could also be replaced by with preprocessor
3789                    catenation.
3790                 */
3791                 if (num_len >= level_len && strnEQ(num,level_str,level_len)) {
3792                     /* per 46807d8e80, PERL_PATCHNUM is outside of the control
3793                        of the interp so it might contain format characters
3794                     */
3795                     level = newSVpvn(num, num_len);
3796                 } else {
3797                     level = Perl_newSVpvf_nocontext("%s (%s)", level_str, num);
3798                 }
3799             }
3800 #else
3801         SV* level = newSVpvn(level_str, level_len);
3802 #endif /* #ifdef PERL_PATCHNUM */
3803         PIO_stdout =  PerlIO_stdout();
3804             PerlIO_printf(PIO_stdout,
3805                 "\nThis is perl "       STRINGIFY(PERL_REVISION)
3806                 ", version "            STRINGIFY(PERL_VERSION)
3807                 ", subversion "         STRINGIFY(PERL_SUBVERSION)
3808                 " (%" SVf ") built for "        ARCHNAME, SVfARG(level)
3809                 );
3810             SvREFCNT_dec_NN(level);
3811         }
3812 #if defined(LOCAL_PATCH_COUNT)
3813         if (LOCAL_PATCH_COUNT > 0)
3814             PerlIO_printf(PIO_stdout,
3815                           "\n(with %d registered patch%s, "
3816                           "see perl -V for more detail)",
3817                           LOCAL_PATCH_COUNT,
3818                           (LOCAL_PATCH_COUNT!=1) ? "es" : "");
3819 #endif
3820
3821         PerlIO_printf(PIO_stdout,
3822                       "\n\nCopyright 1987-2020, Larry Wall\n");
3823 #ifdef MSDOS
3824         PerlIO_printf(PIO_stdout,
3825                       "\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
3826 #endif
3827 #ifdef DJGPP
3828         PerlIO_printf(PIO_stdout,
3829                       "djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n"
3830                       "djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n");
3831 #endif
3832 #ifdef OS2
3833         PerlIO_printf(PIO_stdout,
3834                       "\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
3835                       "Version 5 port Copyright (c) 1994-2002, Andreas Kaiser, Ilya Zakharevich\n");
3836 #endif
3837 #ifdef OEMVS
3838         PerlIO_printf(PIO_stdout,
3839                       "MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
3840 #endif
3841 #ifdef __VOS__
3842         PerlIO_printf(PIO_stdout,
3843                       "Stratus OpenVOS port by Paul.Green@stratus.com, 1997-2013\n");
3844 #endif
3845 #ifdef POSIX_BC
3846         PerlIO_printf(PIO_stdout,
3847                       "BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
3848 #endif
3849 #ifdef BINARY_BUILD_NOTICE
3850         BINARY_BUILD_NOTICE;
3851 #endif
3852         PerlIO_printf(PIO_stdout,
3853                       "\n\
3854 Perl may be copied only under the terms of either the Artistic License or the\n\
3855 GNU General Public License, which may be found in the Perl 5 source kit.\n\n\
3856 Complete documentation for Perl, including FAQ lists, should be found on\n\
3857 this system using \"man perl\" or \"perldoc perl\".  If you have access to the\n\
3858 Internet, point your browser at http://www.perl.org/, the Perl Home Page.\n\n");
3859         my_exit(0);
3860 }
3861
3862 /* compliments of Tom Christiansen */
3863
3864 /* unexec() can be found in the Gnu emacs distribution */
3865 /* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
3866
3867 #ifdef VMS
3868 #include <lib$routines.h>
3869 #endif
3870
3871 void
3872 Perl_my_unexec(pTHX)
3873 {
3874 #ifdef UNEXEC
3875     SV *    prog = newSVpv(BIN_EXP, 0);
3876     SV *    file = newSVpv(PL_origfilename, 0);
3877     int    status = 1;
3878     extern int etext;
3879
3880     sv_catpvs(prog, "/perl");
3881     sv_catpvs(file, ".perldump");
3882
3883     unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
3884     /* unexec prints msg to stderr in case of failure */
3885     PerlProc_exit(status);
3886 #else
3887     PERL_UNUSED_CONTEXT;
3888 #  ifdef VMS
3889      lib$signal(SS$_DEBUG);  /* ssdef.h #included from vmsish.h */
3890 #  elif defined(WIN32) || defined(__CYGWIN__)
3891     Perl_croak_nocontext("dump is not supported");
3892 #  else
3893     ABORT();            /* for use with undump */
3894 #  endif
3895 #endif
3896 }
3897
3898 /* initialize curinterp */
3899 STATIC void
3900 S_init_interp(pTHX)
3901 {
3902 #ifdef MULTIPLICITY
3903 #  define PERLVAR(prefix,var,type)
3904 #  define PERLVARA(prefix,var,n,type)
3905 #  if defined(PERL_IMPLICIT_CONTEXT)
3906 #    define PERLVARI(prefix,var,type,init)      aTHX->prefix##var = init;
3907 #    define PERLVARIC(prefix,var,type,init)     aTHX->prefix##var = init;
3908 #  else
3909 #    define PERLVARI(prefix,var,type,init)      PERL_GET_INTERP->var = init;
3910 #    define PERLVARIC(prefix,var,type,init)     PERL_GET_INTERP->var = init;
3911 #  endif
3912 #  include "intrpvar.h"
3913 #  undef PERLVAR
3914 #  undef PERLVARA
3915 #  undef PERLVARI
3916 #  undef PERLVARIC
3917 #else
3918 #  define PERLVAR(prefix,var,type)
3919 #  define PERLVARA(prefix,var,n,type)
3920 #  define PERLVARI(prefix,var,type,init)        PL_##var = init;
3921 #  define PERLVARIC(prefix,var,type,init)       PL_##var = init;
3922 #  include "intrpvar.h"
3923 #  undef PERLVAR
3924 #  undef PERLVARA
3925 #  undef PERLVARI
3926 #  undef PERLVARIC
3927 #endif
3928
3929 }
3930
3931 STATIC void
3932 S_init_main_stash(pTHX)
3933 {
3934     GV *gv;
3935     HV *hv = newHV();
3936
3937     PL_curstash = PL_defstash = (HV *)SvREFCNT_inc_simple_NN(hv);
3938     /* We know that the string "main" will be in the global shared string
3939        table, so it's a small saving to use it rather than allocate another
3940        8 bytes.  */
3941     PL_curstname = newSVpvs_share("main");
3942     gv = gv_fetchpvs("main::", GV_ADD|GV_NOTQUAL, SVt_PVHV);
3943     /* If we hadn't caused another reference to "main" to be in the shared
3944        string table above, then it would be worth reordering these two,
3945        because otherwise all we do is delete "main" from it as a consequence
3946        of the SvREFCNT_dec, only to add it again with hv_name_set */
3947     SvREFCNT_dec(GvHV(gv));
3948     hv_name_sets(PL_defstash, "main", 0);
3949     GvHV(gv) = MUTABLE_HV(SvREFCNT_inc_simple(PL_defstash));
3950     SvREADONLY_on(gv);
3951     PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpvs("INC", GV_ADD|GV_NOTQUAL,
3952                                              SVt_PVAV)));
3953     SvREFCNT_inc_simple_void(PL_incgv); /* Don't allow it to be freed */
3954     GvMULTI_on(PL_incgv);
3955     PL_hintgv = gv_fetchpvs("\010", GV_ADD|GV_NOTQUAL, SVt_PV); /* ^H */
3956     SvREFCNT_inc_simple_void(PL_hintgv);
3957     GvMULTI_on(PL_hintgv);
3958     PL_defgv = gv_fetchpvs("_", GV_ADD|GV_NOTQUAL, SVt_PVAV);
3959     SvREFCNT_inc_simple_void(PL_defgv);
3960     PL_errgv = gv_fetchpvs("@", GV_ADD|GV_NOTQUAL, SVt_PV);
3961     SvREFCNT_inc_simple_void(PL_errgv);
3962     GvMULTI_on(PL_errgv);
3963     PL_replgv = gv_fetchpvs("\022", GV_ADD|GV_NOTQUAL, SVt_PV); /* ^R */
3964     SvREFCNT_inc_simple_void(PL_replgv);
3965     GvMULTI_on(PL_replgv);
3966     (void)Perl_form(aTHX_ "%240s","");  /* Preallocate temp - for immediate signals. */
3967 #ifdef PERL_DONT_CREATE_GVSV
3968     (void)gv_SVadd(PL_errgv);
3969 #endif
3970     sv_grow(ERRSV, 240);        /* Preallocate - for immediate signals. */
3971     CLEAR_ERRSV();
3972     CopSTASH_set(&PL_compiling, PL_defstash);
3973     PL_debstash = GvHV(gv_fetchpvs("DB::", GV_ADDMULTI, SVt_PVHV));
3974     PL_globalstash = GvHV(gv_fetchpvs("CORE::GLOBAL::", GV_ADDMULTI,
3975                                       SVt_PVHV));
3976     /* We must init $/ before switches are processed. */
3977     sv_setpvs(get_sv("/", GV_ADD), "\n");
3978 }
3979
3980 STATIC PerlIO *
3981 S_open_script(pTHX_ const char *scriptname, bool dosearch, bool *suidscript)
3982 {
3983     int fdscript = -1;
3984     PerlIO *rsfp = NULL;
3985     Stat_t tmpstatbuf;
3986     int fd;
3987
3988     PERL_ARGS_ASSERT_OPEN_SCRIPT;
3989
3990     if (PL_e_script) {
3991         PL_origfilename = savepvs("-e");
3992     }
3993     else {
3994         const char *s;
3995         UV uv;
3996         /* if find_script() returns, it returns a malloc()-ed value */
3997         scriptname = PL_origfilename = find_script(scriptname, dosearch, NULL, 1);
3998         s = scriptname + strlen(scriptname);
3999
4000         if (strBEGINs(scriptname, "/dev/fd/")
4001             && isDIGIT(scriptname[8])
4002             && grok_atoUV(scriptname + 8, &uv, &s)
4003             && uv <= PERL_INT_MAX
4004         ) {
4005             fdscript = (int)uv;
4006             if (*s) {
4007                 /* PSz 18 Feb 04
4008                  * Tell apart "normal" usage of fdscript, e.g.
4009                  * with bash on FreeBSD:
4010                  *   perl <( echo '#!perl -DA'; echo 'print "$0\n"')
4011                  * from usage in suidperl.
4012                  * Does any "normal" usage leave garbage after the number???
4013                  * Is it a mistake to use a similar /dev/fd/ construct for
4014                  * suidperl?
4015                  */
4016                 *suidscript = TRUE;
4017                 /* PSz 20 Feb 04  
4018                  * Be supersafe and do some sanity-checks.
4019                  * Still, can we be sure we got the right thing?
4020                  */
4021                 if (*s != '/') {
4022                     Perl_croak(aTHX_ "Wrong syntax (suid) fd script name \"%s\"\n", s);
4023                 }
4024                 if (! *(s+1)) {
4025                     Perl_croak(aTHX_ "Missing (suid) fd script name\n");
4026                 }
4027                 scriptname = savepv(s + 1);
4028                 Safefree(PL_origfilename);
4029                 PL_origfilename = (char *)scriptname;
4030             }
4031         }
4032     }
4033
4034     CopFILE_free(PL_curcop);
4035     CopFILE_set(PL_curcop, PL_origfilename);
4036     if (*PL_origfilename == '-' && PL_origfilename[1] == '\0')
4037         scriptname = (char *)"";
4038     if (fdscript >= 0) {
4039         rsfp = PerlIO_fdopen(fdscript,PERL_SCRIPT_MODE);
4040     }
4041     else if (!*scriptname) {
4042         forbid_setid(0, *suidscript);
4043         return NULL;
4044     }
4045     else {
4046 #ifdef FAKE_BIT_BUCKET
4047         /* This hack allows one not to have /dev/null (or BIT_BUCKET as it
4048          * is called) and still have the "-e" work.  (Believe it or not,
4049          * a /dev/null is required for the "-e" to work because source
4050          * filter magic is used to implement it. ) This is *not* a general
4051          * replacement for a /dev/null.  What we do here is create a temp
4052          * file (an empty file), open up that as the script, and then
4053          * immediately close and unlink it.  Close enough for jazz. */ 
4054 #define FAKE_BIT_BUCKET_PREFIX "/tmp/perlnull-"
4055 #define FAKE_BIT_BUCKET_SUFFIX "XXXXXXXX"
4056 #define FAKE_BIT_BUCKET_TEMPLATE FAKE_BIT_BUCKET_PREFIX FAKE_BIT_BUCKET_SUFFIX
4057         char tmpname[sizeof(FAKE_BIT_BUCKET_TEMPLATE)] = {
4058             FAKE_BIT_BUCKET_TEMPLATE
4059         };
4060         const char * const err = "Failed to create a fake bit bucket";
4061         if (strEQ(scriptname, BIT_BUCKET)) {
4062             int tmpfd = Perl_my_mkstemp_cloexec(tmpname);
4063             if (tmpfd > -1) {
4064                 scriptname = tmpname;
4065                 close(tmpfd);
4066             } else
4067                 Perl_croak(aTHX_ err);
4068         }
4069 #endif
4070         rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
4071 #ifdef FAKE_BIT_BUCKET
4072         if (   strBEGINs(scriptname, FAKE_BIT_BUCKET_PREFIX)
4073             && strlen(scriptname) == sizeof(tmpname) - 1)
4074         {
4075             unlink(scriptname);
4076         }
4077         scriptname = BIT_BUCKET;
4078 #endif
4079     }
4080     if (!rsfp) {
4081         /* PSz 16 Sep 03  Keep neat error message */
4082         if (PL_e_script)
4083             Perl_croak(aTHX_ "Can't open " BIT_BUCKET ": %s\n", Strerror(errno));
4084         else
4085             Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
4086                     CopFILE(PL_curcop), Strerror(errno));
4087     }
4088     fd = PerlIO_fileno(rsfp);
4089
4090     if (fd < 0 ||
4091         (PerlLIO_fstat(fd, &tmpstatbuf) >= 0
4092          && S_ISDIR(tmpstatbuf.st_mode)))
4093         Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
4094             CopFILE(PL_curcop),
4095             Strerror(EISDIR));
4096
4097     return rsfp;
4098 }
4099
4100 /* In the days of suidperl, we refused to execute a setuid script stored on
4101  * a filesystem mounted nosuid and/or noexec. This meant that we probed for the
4102  * existence of the appropriate filesystem-statting function, and behaved
4103  * accordingly. But even though suidperl is long gone, we must still include
4104  * those probes for the benefit of modules like Filesys::Df, which expect the
4105  * results of those probes to be stored in %Config; see RT#126368. So mention
4106  * the relevant cpp symbols here, to ensure that metaconfig will include their
4107  * probes in the generated Configure:
4108  *
4109  * I_SYSSTATVFS HAS_FSTATVFS
4110  * I_SYSMOUNT
4111  * I_STATFS     HAS_FSTATFS     HAS_GETFSSTAT
4112  * I_MNTENT     HAS_GETMNTENT   HAS_HASMNTOPT
4113  */
4114
4115
4116 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
4117 /* Don't even need this function.  */
4118 #else
4119 STATIC void
4120 S_validate_suid(pTHX_ PerlIO *rsfp)
4121 {
4122     const Uid_t  my_uid = PerlProc_getuid();
4123     const Uid_t my_euid = PerlProc_geteuid();
4124     const Gid_t  my_gid = PerlProc_getgid();
4125     const Gid_t my_egid = PerlProc_getegid();
4126
4127     PERL_ARGS_ASSERT_VALIDATE_SUID;
4128
4129     if (my_euid != my_uid || my_egid != my_gid) {       /* (suidperl doesn't exist, in fact) */
4130         int fd = PerlIO_fileno(rsfp);
4131         Stat_t statbuf;
4132         if (fd < 0 || PerlLIO_fstat(fd, &statbuf) < 0) { /* may be either wrapped or real suid */
4133             Perl_croak_nocontext( "Illegal suidscript");
4134         }
4135         if ((my_euid != my_uid && my_euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
4136             ||
4137             (my_egid != my_gid && my_egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
4138             )
4139             if (!PL_do_undump)
4140                 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
4141 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
4142         /* not set-id, must be wrapped */
4143     }
4144 }
4145 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
4146
4147 STATIC void
4148 S_find_beginning(pTHX_ SV* linestr_sv, PerlIO *rsfp)
4149 {
4150     const char *s;
4151     const char *s2;
4152
4153     PERL_ARGS_ASSERT_FIND_BEGINNING;
4154
4155     /* skip forward in input to the real script? */
4156
4157     do {
4158         if ((s = sv_gets(linestr_sv, rsfp, 0)) == NULL)
4159             Perl_croak(aTHX_ "No Perl script found in input\n");
4160         s2 = s;
4161     } while (!(*s == '#' && s[1] == '!' && ((s = instr(s,"perl")) || (s = instr(s2,"PERL")))));
4162     PerlIO_ungetc(rsfp, '\n');          /* to keep line count right */
4163     while (*s && !(isSPACE (*s) || *s == '#')) s++;
4164     s2 = s;
4165     while (*s == ' ' || *s == '\t') s++;
4166     if (*s++ == '-') {
4167         while (isDIGIT(s2[-1]) || s2[-1] == '-' || s2[-1] == '.'
4168                || s2[-1] == '_') s2--;
4169         if (strBEGINs(s2-4,"perl"))
4170             while ((s = moreswitches(s)))
4171                 ;
4172     }
4173 }
4174
4175
4176 STATIC void
4177 S_init_ids(pTHX)
4178 {
4179     /* no need to do anything here any more if we don't
4180      * do tainting. */
4181 #ifndef NO_TAINT_SUPPORT
4182     const Uid_t my_uid = PerlProc_getuid();
4183     const Uid_t my_euid = PerlProc_geteuid();
4184     const Gid_t my_gid = PerlProc_getgid();
4185     const Gid_t my_egid = PerlProc_getegid();
4186
4187     PERL_UNUSED_CONTEXT;
4188
4189     /* Should not happen: */
4190     CHECK_MALLOC_TAINT(my_uid && (my_euid != my_uid || my_egid != my_gid));
4191     TAINTING_set( TAINTING_get | (my_uid && (my_euid != my_uid || my_egid != my_gid)) );
4192 #endif
4193     /* BUG */
4194     /* PSz 27 Feb 04
4195      * Should go by suidscript, not uid!=euid: why disallow
4196      * system("ls") in scripts run from setuid things?
4197      * Or, is this run before we check arguments and set suidscript?
4198      * What about SETUID_SCRIPTS_ARE_SECURE_NOW: could we use fdscript then?
4199      * (We never have suidscript, can we be sure to have fdscript?)
4200      * Or must then go by UID checks? See comments in forbid_setid also.
4201      */
4202 }
4203
4204 /* This is used very early in the lifetime of the program,
4205  * before even the options are parsed, so PL_tainting has
4206  * not been initialized properly.  */
4207 bool
4208 Perl_doing_taint(int argc, char *argv[], char *envp[])
4209 {
4210 #ifndef PERL_IMPLICIT_SYS
4211     /* If we have PERL_IMPLICIT_SYS we can't call getuid() et alia
4212      * before we have an interpreter-- and the whole point of this
4213      * function is to be called at such an early stage.  If you are on
4214      * a system with PERL_IMPLICIT_SYS but you do have a concept of
4215      * "tainted because running with altered effective ids', you'll
4216      * have to add your own checks somewhere in here.  The two most
4217      * known samples of 'implicitness' are Win32 and NetWare, neither
4218      * of which has much of concept of 'uids'. */
4219     Uid_t uid  = PerlProc_getuid();
4220     Uid_t euid = PerlProc_geteuid();
4221     Gid_t gid  = PerlProc_getgid();
4222     Gid_t egid = PerlProc_getegid();
4223     (void)envp;
4224
4225 #ifdef VMS
4226     uid  |=  gid << 16;
4227     euid |= egid << 16;
4228 #endif
4229     if (uid && (euid != uid || egid != gid))
4230         return 1;
4231 #endif /* !PERL_IMPLICIT_SYS */
4232     /* This is a really primitive check; environment gets ignored only
4233      * if -T are the first chars together; otherwise one gets
4234      *  "Too late" message. */
4235     if ( argc > 1 && argv[1][0] == '-'
4236          && isALPHA_FOLD_EQ(argv[1][1], 't'))
4237         return 1;
4238     return 0;
4239 }
4240
4241 /* Passing the flag as a single char rather than a string is a slight space
4242    optimisation.  The only message that isn't /^-.$/ is
4243    "program input from stdin", which is substituted in place of '\0', which
4244    could never be a command line flag.  */
4245 STATIC void
4246 S_forbid_setid(pTHX_ const char flag, const bool suidscript) /* g */
4247 {
4248     char string[3] = "-x";
4249     const char *message = "program input from stdin";
4250
4251     PERL_UNUSED_CONTEXT;
4252     if (flag) {
4253         string[1] = flag;
4254         message = string;
4255     }
4256
4257 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
4258     if (PerlProc_getuid() != PerlProc_geteuid())
4259         Perl_croak(aTHX_ "No %s allowed while running setuid", message);
4260     if (PerlProc_getgid() != PerlProc_getegid())
4261         Perl_croak(aTHX_ "No %s allowed while running setgid", message);
4262 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
4263     if (suidscript)
4264         Perl_croak(aTHX_ "No %s allowed with (suid) fdscript", message);
4265 }
4266
4267 void
4268 Perl_init_dbargs(pTHX)
4269 {
4270     AV *const args = PL_dbargs = GvAV(gv_AVadd((gv_fetchpvs("DB::args",
4271                                                             GV_ADDMULTI,
4272                                                             SVt_PVAV))));
4273
4274     if (AvREAL(args)) {
4275         /* Someone has already created it.
4276            It might have entries, and if we just turn off AvREAL(), they will
4277            "leak" until global destruction.  */
4278         av_clear(args);
4279         if (SvTIED_mg((const SV *)args, PERL_MAGIC_tied))
4280             Perl_croak(aTHX_ "Cannot set tied @DB::args");
4281     }
4282     AvREIFY_only(PL_dbargs);
4283 }
4284
4285 void
4286 Perl_init_debugger(pTHX)
4287 {
4288     HV * const ostash = PL_curstash;
4289     MAGIC *mg;
4290
4291     PL_curstash = (HV *)SvREFCNT_inc_simple(PL_debstash);
4292
4293     Perl_init_dbargs(aTHX);
4294     PL_DBgv = MUTABLE_GV(
4295         SvREFCNT_inc(gv_fetchpvs("DB::DB", GV_ADDMULTI, SVt_PVGV))
4296     );
4297     PL_DBline = MUTABLE_GV(
4298         SvREFCNT_inc(gv_fetchpvs("DB::dbline", GV_ADDMULTI, SVt_PVAV))
4299     );
4300     PL_DBsub = MUTABLE_GV(SvREFCNT_inc(
4301         gv_HVadd(gv_fetchpvs("DB::sub", GV_ADDMULTI, SVt_PVHV))
4302     ));
4303     PL_DBsingle = GvSV((gv_fetchpvs("DB::single", GV_ADDMULTI, SVt_PV)));
4304     if (!SvIOK(PL_DBsingle))
4305         sv_setiv(PL_DBsingle, 0);
4306     mg = sv_magicext(PL_DBsingle, NULL, PERL_MAGIC_debugvar, &PL_vtbl_debugvar, 0, 0);
4307     mg->mg_private = DBVARMG_SINGLE;
4308     SvSETMAGIC(PL_DBsingle);
4309
4310     PL_DBtrace = GvSV((gv_fetchpvs("DB::trace", GV_ADDMULTI, SVt_PV)));
4311     if (!SvIOK(PL_DBtrace))
4312         sv_setiv(PL_DBtrace, 0);
4313     mg = sv_magicext(PL_DBtrace, NULL, PERL_MAGIC_debugvar, &PL_vtbl_debugvar, 0, 0);
4314     mg->mg_private = DBVARMG_TRACE;
4315     SvSETMAGIC(PL_DBtrace);
4316
4317     PL_DBsignal = GvSV((gv_fetchpvs("DB::signal", GV_ADDMULTI, SVt_PV)));
4318     if (!SvIOK(PL_DBsignal))
4319         sv_setiv(PL_DBsignal, 0);
4320     mg = sv_magicext(PL_DBsignal, NULL, PERL_MAGIC_debugvar, &PL_vtbl_debugvar, 0, 0);
4321     mg->mg_private = DBVARMG_SIGNAL;
4322     SvSETMAGIC(PL_DBsignal);
4323
4324     SvREFCNT_dec(PL_curstash);
4325     PL_curstash = ostash;
4326 }
4327
4328 #ifndef STRESS_REALLOC
4329 #define REASONABLE(size) (size)
4330 #define REASONABLE_but_at_least(size,min) (size)
4331 #else
4332 #define REASONABLE(size) (1) /* unreasonable */
4333 #define REASONABLE_but_at_least(size,min) (min)
4334 #endif
4335
4336 void
4337 Perl_init_stacks(pTHX)
4338 {
4339     SSize_t size;
4340
4341     /* start with 128-item stack and 8K cxstack */
4342     PL_curstackinfo = new_stackinfo(REASONABLE(128),
4343                                  REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
4344     PL_curstackinfo->si_type = PERLSI_MAIN;
4345 #if defined DEBUGGING && !defined DEBUGGING_RE_ONLY
4346     PL_curstackinfo->si_stack_hwm = 0;
4347 #endif
4348     PL_curstack = PL_curstackinfo->si_stack;
4349     PL_mainstack = PL_curstack;         /* remember in case we switch stacks */
4350
4351     PL_stack_base = AvARRAY(PL_curstack);
4352     PL_stack_sp = PL_stack_base;
4353     PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
4354
4355     Newx(PL_tmps_stack,REASONABLE(128),SV*);
4356     PL_tmps_floor = -1;
4357     PL_tmps_ix = -1;
4358     PL_tmps_max = REASONABLE(128);
4359
4360     Newx(PL_markstack,REASONABLE(32),I32);
4361     PL_markstack_ptr = PL_markstack;
4362     PL_markstack_max = PL_markstack + REASONABLE(32);
4363
4364     SET_MARK_OFFSET;
4365
4366     Newx(PL_scopestack,REASONABLE(32),I32);
4367 #ifdef DEBUGGING
4368     Newx(PL_scopestack_name,REASONABLE(32),const char*);
4369 #endif
4370     PL_scopestack_ix = 0;
4371     PL_scopestack_max = REASONABLE(32);
4372
4373     size = REASONABLE_but_at_least(128,SS_MAXPUSH);
4374     Newx(PL_savestack, size, ANY);
4375     PL_savestack_ix = 0;
4376     /*PL_savestack_max lies: it always has SS_MAXPUSH more than it claims */
4377     PL_savestack_max = size - SS_MAXPUSH;
4378 }
4379
4380 #undef REASONABLE
4381
4382 STATIC void
4383 S_nuke_stacks(pTHX)
4384 {
4385     while (PL_curstackinfo->si_next)
4386         PL_curstackinfo = PL_curstackinfo->si_next;
4387     while (PL_curstackinfo) {
4388         PERL_SI *p = PL_curstackinfo->si_prev;
4389         /* curstackinfo->si_stack got nuked by sv_free_arenas() */
4390         Safefree(PL_curstackinfo->si_cxstack);
4391         Safefree(PL_curstackinfo);
4392         PL_curstackinfo = p;
4393     }
4394     Safefree(PL_tmps_stack);
4395     Safefree(PL_markstack);
4396     Safefree(PL_scopestack);
4397 #ifdef DEBUGGING
4398     Safefree(PL_scopestack_name);
4399 #endif
4400     Safefree(PL_savestack);
4401 }
4402
4403 void
4404 Perl_populate_isa(pTHX_ const char *name, STRLEN len, ...)
4405 {
4406     GV *const gv = gv_fetchpvn(name, len, GV_ADD | GV_ADDMULTI, SVt_PVAV);
4407     AV *const isa = GvAVn(gv);
4408     va_list args;
4409
4410     PERL_ARGS_ASSERT_POPULATE_ISA;
4411
4412     if(AvFILLp(isa) != -1)
4413         return;
4414
4415     /* NOTE: No support for tied ISA */
4416
4417     va_start(args, len);
4418     do {
4419         const char *const parent = va_arg(args, const char*);
4420         size_t parent_len;
4421
4422         if (!parent)
4423             break;
4424         parent_len = va_arg(args, size_t);
4425
4426         /* Arguments are supplied with a trailing ::  */
4427         assert(parent_len > 2);
4428         assert(parent[parent_len - 1] == ':');
4429         assert(parent[parent_len - 2] == ':');
4430         av_push(isa, newSVpvn(parent, parent_len - 2));
4431         (void) gv_fetchpvn(parent, parent_len, GV_ADD, SVt_PVGV);
4432     } while (1);
4433     va_end(args);
4434 }
4435
4436
4437 STATIC void
4438 S_init_predump_symbols(pTHX)
4439 {
4440     GV *tmpgv;
4441     IO *io;
4442
4443     sv_setpvs(get_sv("\"", GV_ADD), " ");
4444     PL_ofsgv = (GV*)SvREFCNT_inc(gv_fetchpvs(",", GV_ADD|GV_NOTQUAL, SVt_PV));
4445
4446
4447     /* Historically, PVIOs were blessed into IO::Handle, unless
4448        FileHandle was loaded, in which case they were blessed into
4449        that. Action at a distance.
4450        However, if we simply bless into IO::Handle, we break code
4451        that assumes that PVIOs will have (among others) a seek
4452        method. IO::File inherits from IO::Handle and IO::Seekable,
4453        and provides the needed methods. But if we simply bless into
4454        it, then we break code that assumed that by loading
4455        IO::Handle, *it* would work.
4456        So a compromise is to set up the correct @IO::File::ISA,
4457        so that code that does C<use IO::Handle>; will still work.
4458     */
4459                    
4460     Perl_populate_isa(aTHX_ STR_WITH_LEN("IO::File::ISA"),
4461                       STR_WITH_LEN("IO::Handle::"),
4462                       STR_WITH_LEN("IO::Seekable::"),
4463                       STR_WITH_LEN("Exporter::"),
4464                       NULL);
4465
4466     PL_stdingv = gv_fetchpvs("STDIN", GV_ADD|GV_NOTQUAL, SVt_PVIO);
4467     GvMULTI_on(PL_stdingv);
4468     io = GvIOp(PL_stdingv);
4469     IoTYPE(io) = IoTYPE_RDONLY;
4470     IoIFP(io) = PerlIO_stdin();
4471     tmpgv = gv_fetchpvs("stdin", GV_ADD|GV_NOTQUAL, SVt_PV);
4472     GvMULTI_on(tmpgv);
4473     GvIOp(tmpgv) = MUTABLE_IO(SvREFCNT_inc_simple(io));
4474
4475     tmpgv = gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVIO);
4476     GvMULTI_on(tmpgv);
4477     io = GvIOp(tmpgv);
4478     IoTYPE(io) = IoTYPE_WRONLY;
4479     IoOFP(io) = IoIFP(io) = PerlIO_stdout();
4480     setdefout(tmpgv);
4481     tmpgv = gv_fetchpvs("stdout", GV_ADD|GV_NOTQUAL, SVt_PV);
4482     GvMULTI_on(tmpgv);
4483     GvIOp(tmpgv) = MUTABLE_IO(SvREFCNT_inc_simple(io));
4484
4485     PL_stderrgv = gv_fetchpvs("STDERR", GV_ADD|GV_NOTQUAL, SVt_PVIO);
4486     GvMULTI_on(PL_stderrgv);
4487     io = GvIOp(PL_stderrgv);
4488     IoTYPE(io) = IoTYPE_WRONLY;
4489     IoOFP(io) = IoIFP(io) = PerlIO_stderr();
4490     tmpgv = gv_fetchpvs("stderr", GV_ADD|GV_NOTQUAL, SVt_PV);
4491     GvMULTI_on(tmpgv);
4492     GvIOp(tmpgv) = MUTABLE_IO(SvREFCNT_inc_simple(io));
4493
4494     PL_statname = newSVpvs("");         /* last filename we did stat on */
4495 }
4496
4497 void
4498 Perl_init_argv_symbols(pTHX_ int argc, char **argv)
4499 {
4500     PERL_ARGS_ASSERT_INIT_ARGV_SYMBOLS;
4501
4502     argc--,argv++;      /* skip name of script */
4503     if (PL_doswitches) {
4504         for (; argc > 0 && **argv == '-'; argc--,argv++) {
4505             char *s;
4506             if (!argv[0][1])
4507                 break;
4508             if (argv[0][1] == '-' && !argv[0][2]) {
4509                 argc--,argv++;
4510                 break;
4511             }
4512             if ((s = strchr(argv[0], '='))) {
4513                 const char *const start_name = argv[0] + 1;
4514                 sv_setpv(GvSV(gv_fetchpvn_flags(start_name, s - start_name,
4515                                                 TRUE, SVt_PV)), s + 1);
4516             }
4517             else
4518                 sv_setiv(GvSV(gv_fetchpv(argv[0]+1, GV_ADD, SVt_PV)),1);
4519         }
4520     }
4521     if ((PL_argvgv = gv_fetchpvs("ARGV", GV_ADD|GV_NOTQUAL, SVt_PVAV))) {
4522         SvREFCNT_inc_simple_void_NN(PL_argvgv);
4523         GvMULTI_on(PL_argvgv);
4524         av_clear(GvAVn(PL_argvgv));
4525         for (; argc > 0; argc--,argv++) {
4526             SV * const sv = newSVpv(argv[0],0);
4527             av_push(GvAV(PL_argvgv),sv);
4528             if (!(PL_unicode & PERL_UNICODE_LOCALE_FLAG) || PL_utf8locale) {
4529                  if (PL_unicode & PERL_UNICODE_ARGV_FLAG)
4530                       SvUTF8_on(sv);
4531             }
4532             if (PL_unicode & PERL_UNICODE_WIDESYSCALLS_FLAG) /* Sarathy? */
4533                  (void)sv_utf8_decode(sv);
4534         }
4535     }
4536
4537     if (PL_inplace && (!PL_argvgv || AvFILL(GvAV(PL_argvgv)) == -1))
4538         Perl_ck_warner_d(aTHX_ packWARN(WARN_INPLACE),
4539                          "-i used with no filenames on the command line, "
4540                          "reading from STDIN");
4541 }
4542
4543 STATIC void
4544 S_init_postdump_symbols(pTHX_ int argc, char **argv, char **env)
4545 {
4546     GV* tmpgv;
4547
4548     PERL_ARGS_ASSERT_INIT_POSTDUMP_SYMBOLS;
4549
4550     PL_toptarget = newSV_type(SVt_PVIV);
4551     SvPVCLEAR(PL_toptarget);
4552     PL_bodytarget = newSV_type(SVt_PVIV);
4553     SvPVCLEAR(PL_bodytarget);
4554     PL_formtarget = PL_bodytarget;
4555
4556     TAINT;
4557
4558     init_argv_symbols(argc,argv);
4559
4560     if ((tmpgv = gv_fetchpvs("0", GV_ADD|GV_NOTQUAL, SVt_PV))) {
4561         sv_setpv(GvSV(tmpgv),PL_origfilename);
4562     }
4563     if ((PL_envgv = gv_fetchpvs("ENV", GV_ADD|GV_NOTQUAL, SVt_PVHV))) {
4564         HV *hv;
4565         bool env_is_not_environ;
4566         SvREFCNT_inc_simple_void_NN(PL_envgv);
4567         GvMULTI_on(PL_envgv);
4568         hv = GvHVn(PL_envgv);
4569         hv_magic(hv, NULL, PERL_MAGIC_env);
4570 #ifndef PERL_MICRO
4571 #ifdef USE_ENVIRON_ARRAY
4572         /* Note that if the supplied env parameter is actually a copy
4573            of the global environ then it may now point to free'd memory
4574            if the environment has been modified since. To avoid this
4575            problem we treat env==NULL as meaning 'use the default'
4576         */
4577         if (!env)
4578             env = environ;
4579         env_is_not_environ = env != environ;
4580         if (env_is_not_environ
4581 #  ifdef USE_ITHREADS
4582             && PL_curinterp == aTHX
4583 #  endif
4584            )
4585         {
4586             environ[0] = NULL;
4587         }
4588         if (env) {
4589           char *s, *old_var;
4590           STRLEN nlen;
4591           SV *sv;
4592           HV *dups = newHV();
4593
4594           for (; *env; env++) {
4595             old_var = *env;
4596
4597             if (!(s = strchr(old_var,'=')) || s == old_var)
4598                 continue;
4599             nlen = s - old_var;
4600
4601 #if defined(MSDOS) && !defined(DJGPP)
4602             *s = '\0';
4603             (void)strupr(old_var);
4604             *s = '=';
4605 #endif
4606             if (hv_exists(hv, old_var, nlen)) {
4607                 const char *name = savepvn(old_var, nlen);
4608
4609                 /* make sure we use the same value as getenv(), otherwise code that
4610                    uses getenv() (like setlocale()) might see a different value to %ENV
4611                  */
4612                 sv = newSVpv(PerlEnv_getenv(name), 0);
4613
4614                 /* keep a count of the dups of this name so we can de-dup environ later */
4615                 if (hv_exists(dups, name, nlen))
4616                     ++SvIVX(*hv_fetch(dups, name, nlen, 0));
4617                 else
4618                     (void)hv_store(dups, name, nlen, newSViv(1), 0);
4619
4620                 Safefree(name);
4621             }
4622             else {
4623                 sv = newSVpv(s+1, 0);
4624             }
4625             (void)hv_store(hv, old_var, nlen, sv, 0);
4626             if (env_is_not_environ)
4627                 mg_set(sv);
4628           }
4629           if (HvKEYS(dups)) {
4630               /* environ has some duplicate definitions, remove them */
4631               HE *entry;
4632               hv_iterinit(dups);
4633               while ((entry = hv_iternext_flags(dups, 0))) {
4634                   STRLEN nlen;
4635                   const char *name = HePV(entry, nlen);
4636                   IV count = SvIV(HeVAL(entry));
4637                   IV i;
4638                   SV **valp = hv_fetch(hv, name, nlen, 0);
4639
4640                   assert(valp);
4641
4642                   /* try to remove any duplicate names, depending on the
4643                    * implementation used in my_setenv() the iteration might
4644                    * not be necessary, but let's be safe.
4645                    */
4646                   for (i = 0; i < count; ++i)
4647                       my_setenv(name, 0);
4648
4649                   /* and set it back to the value we set $ENV{name} to */
4650                   my_setenv(name, SvPV_nolen(*valp));
4651               }
4652           }
4653           SvREFCNT_dec_NN(dups);
4654       }
4655 #endif /* USE_ENVIRON_ARRAY */
4656 #endif /* !PERL_MICRO */
4657     }
4658     TAINT_NOT;
4659
4660     /* touch @F array to prevent spurious warnings 20020415 MJD */
4661     if (PL_minus_a) {
4662       (void) get_av("main::F", GV_ADD | GV_ADDMULTI);
4663     }
4664 }
4665
4666 STATIC void
4667 S_init_perllib(pTHX)
4668 {
4669 #ifndef VMS
4670     const char *perl5lib = NULL;
4671 #endif
4672     const char *s;
4673 #if defined(WIN32) && !defined(PERL_IS_MINIPERL)
4674     STRLEN len;
4675 #endif
4676
4677     if (!TAINTING_get) {
4678 #ifndef VMS
4679         perl5lib = PerlEnv_getenv("PERL5LIB");
4680 /*
4681  * It isn't possible to delete an environment variable with
4682  * PERL_USE_SAFE_PUTENV set unless unsetenv() is also available, so in that
4683  * case we treat PERL5LIB as undefined if it has a zero-length value.
4684  */
4685 #if defined(PERL_USE_SAFE_PUTENV) && ! defined(HAS_UNSETENV)
4686         if (perl5lib && *perl5lib != '\0')
4687 #else
4688         if (perl5lib)
4689 #endif
4690             incpush_use_sep(perl5lib, 0, INCPUSH_ADD_SUB_DIRS);
4691         else {
4692             s = PerlEnv_getenv("PERLLIB");
4693             if (s)
4694                 incpush_use_sep(s, 0, 0);
4695         }
4696 #else /* VMS */
4697         /* Treat PERL5?LIB as a possible search list logical name -- the
4698          * "natural" VMS idiom for a Unix path string.  We allow each
4699          * element to be a set of |-separated directories for compatibility.
4700          */
4701         char buf[256];
4702         int idx = 0;
4703         if (vmstrnenv("PERL5LIB",buf,0,NULL,0))
4704             do {
4705                 incpush_use_sep(buf, 0, INCPUSH_ADD_SUB_DIRS);
4706             } while (vmstrnenv("PERL5LIB",buf,++idx,NULL,0));
4707         else {
4708             while (vmstrnenv("PERLLIB",buf,idx++,NULL,0))
4709                 incpush_use_sep(buf, 0, 0);
4710         }
4711 #endif /* VMS */
4712     }
4713
4714 #ifndef PERL_IS_MINIPERL
4715     /* miniperl gets just -I..., the split of $ENV{PERL5LIB}, and "." in @INC
4716        (and not the architecture specific directories from $ENV{PERL5LIB}) */
4717
4718 #include "perl_inc_macro.h"
4719 /* Use the ~-expanded versions of APPLLIB (undocumented),
4720     SITEARCH, SITELIB, VENDORARCH, VENDORLIB, ARCHLIB and PRIVLIB
4721 */
4722     INCPUSH_APPLLIB_EXP
4723     INCPUSH_SITEARCH_EXP
4724     INCPUSH_SITELIB_EXP
4725     INCPUSH_PERL_VENDORARCH_EXP
4726     INCPUSH_PERL_VENDORLIB_EXP
4727     INCPUSH_ARCHLIB_EXP
4728     INCPUSH_PRIVLIB_EXP
4729     INCPUSH_PERL_OTHERLIBDIRS
4730     INCPUSH_PERL5LIB
4731     INCPUSH_APPLLIB_OLD_EXP
4732     INCPUSH_SITELIB_STEM
4733     INCPUSH_PERL_VENDORLIB_STEM
4734     INCPUSH_PERL_OTHERLIBDIRS_ARCHONLY
4735
4736 #endif /* !PERL_IS_MINIPERL */
4737
4738     if (!TAINTING_get) {
4739 #if !defined(PERL_IS_MINIPERL) && defined(DEFAULT_INC_EXCLUDES_DOT)
4740         const char * const unsafe = PerlEnv_getenv("PERL_USE_UNSAFE_INC");
4741         if (unsafe && strEQ(unsafe, "1"))
4742 #endif
4743           S_incpush(aTHX_ STR_WITH_LEN("."), 0);
4744     }
4745 }
4746
4747 #if defined(DOSISH)
4748 #    define PERLLIB_SEP ';'
4749 #elif defined(__VMS)
4750 #    define PERLLIB_SEP PL_perllib_sep
4751 #else
4752 #    define PERLLIB_SEP ':'
4753 #endif
4754 #ifndef PERLLIB_MANGLE
4755 #  define PERLLIB_MANGLE(s,n) (s)
4756 #endif
4757
4758 #ifndef PERL_IS_MINIPERL
4759 /* Push a directory onto @INC if it exists.
4760    Generate a new SV if we do this, to save needing to copy the SV we push
4761    onto @INC  */
4762 STATIC SV *
4763 S_incpush_if_exists(pTHX_ AV *const av, SV *dir, SV *const stem)
4764 {
4765     Stat_t tmpstatbuf;
4766
4767     PERL_ARGS_ASSERT_INCPUSH_IF_EXISTS;
4768
4769     if (PerlLIO_stat(SvPVX_const(dir), &tmpstatbuf) >= 0 &&
4770         S_ISDIR(tmpstatbuf.st_mode)) {
4771         av_push(av, dir);
4772         dir = newSVsv(stem);
4773     } else {
4774         /* Truncate dir back to stem.  */
4775         SvCUR_set(dir, SvCUR(stem));
4776     }
4777     return dir;
4778 }
4779 #endif
4780
4781 STATIC SV *
4782 S_mayberelocate(pTHX_ const char *const dir, STRLEN len, U32 flags)
4783 {
4784     const U8 canrelocate = (U8)flags & INCPUSH_CAN_RELOCATE;
4785     SV *libdir;
4786
4787     PERL_ARGS_ASSERT_MAYBERELOCATE;
4788     assert(len > 0);
4789
4790     /* I am not convinced that this is valid when PERLLIB_MANGLE is
4791        defined to so something (in os2/os2.c), but the code has been
4792        this way, ignoring any possible changed of length, since
4793        760ac839baf413929cd31cc32ffd6dba6b781a81 (5.003_02) so I'll leave
4794        it be.  */
4795     libdir = newSVpvn(PERLLIB_MANGLE(dir, len), len);
4796
4797 #ifdef VMS
4798     {
4799         char *unix;
4800
4801         if ((unix = tounixspec_ts(SvPV(libdir,len),NULL)) != NULL) {
4802             len = strlen(unix);
4803             while (len > 1 && unix[len-1] == '/') len--;  /* Cosmetic */
4804             sv_usepvn(libdir,unix,len);
4805         }
4806         else
4807             PerlIO_printf(Perl_error_log,
4808                           "Failed to unixify @INC element \"%s\"\n",
4809                           SvPV_nolen_const(libdir));
4810     }
4811 #endif
4812
4813         /* Do the if() outside the #ifdef to avoid warnings about an unused
4814            parameter.  */
4815         if (canrelocate) {
4816 #ifdef PERL_RELOCATABLE_INC
4817         /*
4818          * Relocatable include entries are marked with a leading .../
4819          *
4820          * The algorithm is
4821          * 0: Remove that leading ".../"
4822          * 1: Remove trailing executable name (anything after the last '/')
4823          *    from the perl path to give a perl prefix
4824          * Then
4825          * While the @INC element starts "../" and the prefix ends with a real
4826          * directory (ie not . or ..) chop that real directory off the prefix
4827          * and the leading "../" from the @INC element. ie a logical "../"
4828          * cleanup
4829          * Finally concatenate the prefix and the remainder of the @INC element
4830          * The intent is that /usr/local/bin/perl and .../../lib/perl5
4831          * generates /usr/local/lib/perl5
4832          */
4833             const char *libpath = SvPVX(libdir);
4834             STRLEN libpath_len = SvCUR(libdir);
4835             if (memBEGINs(libpath, libpath_len, ".../")) {
4836                 /* Game on!  */
4837                 SV * const caret_X = get_sv("\030", 0);
4838                 /* Going to use the SV just as a scratch buffer holding a C
4839                    string:  */
4840                 SV *prefix_sv;
4841                 char *prefix;
4842                 char *lastslash;
4843
4844                 /* $^X is *the* source of taint if tainting is on, hence
4845       &nbs