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