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