This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Add mutex for accessing ENV
[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_idcont);
1202     PL_utf8_idcont = NULL;
1203     SvREFCNT_dec(PL_utf8_idstart);
1204     PL_utf8_idstart = NULL;
1205     SvREFCNT_dec(PL_utf8_perl_idcont);
1206     PL_utf8_perl_idcont = NULL;
1207     SvREFCNT_dec(PL_utf8_perl_idstart);
1208     PL_utf8_perl_idstart = NULL;
1209     SvREFCNT_dec(PL_utf8_xidcont);
1210     PL_utf8_xidcont = NULL;
1211     SvREFCNT_dec(PL_utf8_xidstart);
1212     PL_utf8_xidstart = NULL;
1213     SvREFCNT_dec(PL_WB_invlist);
1214     PL_WB_invlist = NULL;
1215     SvREFCNT_dec(PL_utf8_toupper);
1216     PL_utf8_toupper = NULL;
1217     SvREFCNT_dec(PL_utf8_totitle);
1218     PL_utf8_totitle = NULL;
1219     SvREFCNT_dec(PL_utf8_tolower);
1220     PL_utf8_tolower = NULL;
1221     SvREFCNT_dec(PL_utf8_tofold);
1222     PL_utf8_tofold = NULL;
1223     SvREFCNT_dec(PL_utf8_tosimplefold);
1224     PL_utf8_tosimplefold = NULL;
1225     SvREFCNT_dec(PL_utf8_charname_begin);
1226     PL_utf8_charname_begin = NULL;
1227     SvREFCNT_dec(PL_utf8_charname_continue);
1228     PL_utf8_charname_continue = NULL;
1229     SvREFCNT_dec(PL_utf8_mark);
1230     PL_utf8_mark = NULL;
1231     SvREFCNT_dec(PL_InBitmap);
1232     PL_InBitmap = NULL;
1233     SvREFCNT_dec(PL_CCC_non0_non230);
1234     PL_CCC_non0_non230 = NULL;
1235     SvREFCNT_dec(PL_Private_Use);
1236     PL_Private_Use = NULL;
1237
1238     for (i = 0; i < POSIX_CC_COUNT; i++) {
1239         SvREFCNT_dec(PL_XPosix_ptrs[i]);
1240         PL_XPosix_ptrs[i] = NULL;
1241
1242         if (i != _CC_CASED) {   /* A copy of Alpha */
1243             SvREFCNT_dec(PL_Posix_ptrs[i]);
1244             PL_Posix_ptrs[i] = NULL;
1245         }
1246     }
1247
1248     if (!specialWARN(PL_compiling.cop_warnings))
1249         PerlMemShared_free(PL_compiling.cop_warnings);
1250     PL_compiling.cop_warnings = 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         /* s points to static memory in getenv(), which may be overwritten at
2287          * any time; use a mortal copy instead */
2288         s = SvPVX(sv_2mortal(newSVpv(s, 0)));
2289
2290         while (isSPACE(*s))
2291             s++;
2292         if (*s == '-' && *(s+1) == 'T') {
2293 #if defined(SILENT_NO_TAINT_SUPPORT)
2294             /* silently ignore */
2295 #elif defined(NO_TAINT_SUPPORT)
2296             Perl_croak_nocontext("This perl was compiled without taint support. "
2297                        "Cowardly refusing to run with -t or -T flags");
2298 #else
2299             CHECK_MALLOC_TOO_LATE_FOR('T');
2300             TAINTING_set(TRUE);
2301             TAINT_WARN_set(FALSE);
2302 #endif
2303         }
2304         else {
2305             char *popt_copy = NULL;
2306             while (s && *s) {
2307                 const char *d;
2308                 while (isSPACE(*s))
2309                     s++;
2310                 if (*s == '-') {
2311                     s++;
2312                     if (isSPACE(*s))
2313                         continue;
2314                 }
2315                 d = s;
2316                 if (!*s)
2317                     break;
2318                 if (!memCHRs("CDIMUdmtwW", *s))
2319                     Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s);
2320                 while (++s && *s) {
2321                     if (isSPACE(*s)) {
2322                         if (!popt_copy) {
2323                             popt_copy = SvPVX(sv_2mortal(newSVpv(d,0)));
2324                             s = popt_copy + (s - d);
2325                             d = popt_copy;
2326                         }
2327                         *s++ = '\0';
2328                         break;
2329                     }
2330                 }
2331                 if (*d == 't') {
2332 #if defined(SILENT_NO_TAINT_SUPPORT)
2333             /* silently ignore */
2334 #elif defined(NO_TAINT_SUPPORT)
2335                     Perl_croak_nocontext("This perl was compiled without taint support. "
2336                                "Cowardly refusing to run with -t or -T flags");
2337 #else
2338                     if( !TAINTING_get) {
2339                         TAINT_WARN_set(TRUE);
2340                         TAINTING_set(TRUE);
2341                     }
2342 #endif
2343                 } else {
2344                     moreswitches(d);
2345                 }
2346             }
2347         }
2348     }
2349     }
2350
2351 #ifndef NO_PERL_INTERNAL_RAND_SEED
2352     /* If we're not set[ug]id, we might have honored
2353        PERL_INTERNAL_RAND_SEED in perl_construct().
2354        At this point command-line options have been parsed, so if
2355        we're now tainting and not set[ug]id re-seed.
2356        This could possibly be wasteful if PERL_INTERNAL_RAND_SEED is invalid,
2357        but avoids duplicating the logic from perl_construct().
2358     */
2359     if (TAINT_get &&
2360         PerlProc_getuid() == PerlProc_geteuid() &&
2361         PerlProc_getgid() == PerlProc_getegid()) {
2362         Perl_drand48_init_r(&PL_internal_random_state, seed());
2363     }
2364 #endif
2365
2366     /* Set $^X early so that it can be used for relocatable paths in @INC  */
2367     /* and for SITELIB_EXP in USE_SITECUSTOMIZE                            */
2368     assert (!TAINT_get);
2369     TAINT;
2370     set_caret_X();
2371     TAINT_NOT;
2372
2373 #if defined(USE_SITECUSTOMIZE)
2374     if (!minus_f) {
2375         /* The games with local $! are to avoid setting errno if there is no
2376            sitecustomize script.  "q%c...%c", 0, ..., 0 becomes "q\0...\0",
2377            ie a q() operator with a NUL byte as a the delimiter. This avoids
2378            problems with pathnames containing (say) '  */
2379 #  ifdef PERL_IS_MINIPERL
2380         AV *const inc = GvAV(PL_incgv);
2381         SV **const inc0 = inc ? av_fetch(inc, 0, FALSE) : NULL;
2382
2383         if (inc0) {
2384             /* if lib/buildcustomize.pl exists, it should not fail. If it does,
2385                it should be reported immediately as a build failure.  */
2386             (void)Perl_av_create_and_unshift_one(aTHX_ &PL_preambleav,
2387                                                  Perl_newSVpvf(aTHX_
2388                 "BEGIN { my $f = q%c%s%" SVf "/buildcustomize.pl%c; "
2389                         "do {local $!; -f $f }"
2390                         " and do $f || die $@ || qq '$f: $!' }",
2391                                 0, (TAINTING_get ? "./" : ""), SVfARG(*inc0), 0));
2392         }
2393 #  else
2394         /* SITELIB_EXP is a function call on Win32.  */
2395         const char *const raw_sitelib = SITELIB_EXP;
2396         if (raw_sitelib) {
2397             /* process .../.. if PERL_RELOCATABLE_INC is defined */
2398             SV *sitelib_sv = mayberelocate(raw_sitelib, strlen(raw_sitelib),
2399                                            INCPUSH_CAN_RELOCATE);
2400             const char *const sitelib = SvPVX(sitelib_sv);
2401             (void)Perl_av_create_and_unshift_one(aTHX_ &PL_preambleav,
2402                                                  Perl_newSVpvf(aTHX_
2403                                                                "BEGIN { do {local $!; -f q%c%s/sitecustomize.pl%c} && do q%c%s/sitecustomize.pl%c }",
2404                                                                0, SVfARG(sitelib), 0,
2405                                                                0, SVfARG(sitelib), 0));
2406             assert (SvREFCNT(sitelib_sv) == 1);
2407             SvREFCNT_dec(sitelib_sv);
2408         }
2409 #  endif
2410     }
2411 #endif
2412
2413     if (!scriptname)
2414         scriptname = argv[0];
2415     if (PL_e_script) {
2416         argc++,argv--;
2417         scriptname = BIT_BUCKET;        /* don't look for script or read stdin */
2418     }
2419     else if (scriptname == NULL) {
2420 #ifdef MSDOS
2421         if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) )
2422             moreswitches("h");
2423 #endif
2424         scriptname = "-";
2425     }
2426
2427     assert (!TAINT_get);
2428     init_perllib();
2429
2430     {
2431         bool suidscript = FALSE;
2432
2433         rsfp = open_script(scriptname, dosearch, &suidscript);
2434         if (!rsfp) {
2435             rsfp = PerlIO_stdin();
2436             lex_start_flags = LEX_DONT_CLOSE_RSFP;
2437         }
2438
2439         validate_suid(rsfp);
2440
2441 #ifndef PERL_MICRO
2442 #  if defined(SIGCHLD) || defined(SIGCLD)
2443         {
2444 #  ifndef SIGCHLD
2445 #    define SIGCHLD SIGCLD
2446 #  endif
2447             Sighandler_t sigstate = rsignal_state(SIGCHLD);
2448             if (sigstate == (Sighandler_t) SIG_IGN) {
2449                 Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL),
2450                                "Can't ignore signal CHLD, forcing to default");
2451                 (void)rsignal(SIGCHLD, (Sighandler_t)SIG_DFL);
2452             }
2453         }
2454 #  endif
2455 #endif
2456
2457         if (doextract) {
2458
2459             /* This will croak if suidscript is true, as -x cannot be used with
2460                setuid scripts.  */
2461             forbid_setid('x', suidscript);
2462             /* Hence you can't get here if suidscript is true */
2463
2464             linestr_sv = newSV_type(SVt_PV);
2465             lex_start_flags |= LEX_START_COPIED;
2466             find_beginning(linestr_sv, rsfp);
2467             if (cddir && PerlDir_chdir( (char *)cddir ) < 0)
2468                 Perl_croak(aTHX_ "Can't chdir to %s",cddir);
2469         }
2470     }
2471
2472     PL_main_cv = PL_compcv = MUTABLE_CV(newSV_type(SVt_PVCV));
2473     CvUNIQUE_on(PL_compcv);
2474
2475     CvPADLIST_set(PL_compcv, pad_new(0));
2476
2477     PL_isarev = newHV();
2478
2479     boot_core_PerlIO();
2480     boot_core_UNIVERSAL();
2481     boot_core_mro();
2482     newXS("Internals::V", S_Internals_V, __FILE__);
2483
2484     if (xsinit)
2485         (*xsinit)(aTHX);        /* in case linked C routines want magical variables */
2486 #ifndef PERL_MICRO
2487 #if defined(VMS) || defined(WIN32) || defined(DJGPP) || defined(__CYGWIN__) || defined(SYMBIAN)
2488     init_os_extras();
2489 #endif
2490 #endif
2491
2492 #ifdef USE_SOCKS
2493 #   ifdef HAS_SOCKS5_INIT
2494     socks5_init(argv[0]);
2495 #   else
2496     SOCKSinit(argv[0]);
2497 #   endif
2498 #endif
2499
2500     init_predump_symbols();
2501     /* init_postdump_symbols not currently designed to be called */
2502     /* more than once (ENV isn't cleared first, for example)     */
2503     /* But running with -u leaves %ENV & @ARGV undefined!    XXX */
2504     if (!PL_do_undump)
2505         init_postdump_symbols(argc,argv,env);
2506
2507     /* PL_unicode is turned on by -C, or by $ENV{PERL_UNICODE},
2508      * or explicitly in some platforms.
2509      * PL_utf8locale is conditionally turned on by
2510      * locale.c:Perl_init_i18nl10n() if the environment
2511      * look like the user wants to use UTF-8. */
2512 #if defined(__SYMBIAN32__)
2513     PL_unicode = PERL_UNICODE_STD_FLAG; /* See PERL_SYMBIAN_CONSOLE_UTF8. */
2514 #endif
2515 #  ifndef PERL_IS_MINIPERL
2516     if (PL_unicode) {
2517          /* Requires init_predump_symbols(). */
2518          if (!(PL_unicode & PERL_UNICODE_LOCALE_FLAG) || PL_utf8locale) {
2519               IO* io;
2520               PerlIO* fp;
2521               SV* sv;
2522
2523               /* Turn on UTF-8-ness on STDIN, STDOUT, STDERR
2524                * and the default open disciplines. */
2525               if ((PL_unicode & PERL_UNICODE_STDIN_FLAG) &&
2526                   PL_stdingv  && (io = GvIO(PL_stdingv)) &&
2527                   (fp = IoIFP(io)))
2528                    PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
2529               if ((PL_unicode & PERL_UNICODE_STDOUT_FLAG) &&
2530                   PL_defoutgv && (io = GvIO(PL_defoutgv)) &&
2531                   (fp = IoOFP(io)))
2532                    PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
2533               if ((PL_unicode & PERL_UNICODE_STDERR_FLAG) &&
2534                   PL_stderrgv && (io = GvIO(PL_stderrgv)) &&
2535                   (fp = IoOFP(io)))
2536                    PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
2537               if ((PL_unicode & PERL_UNICODE_INOUT_FLAG) &&
2538                   (sv = GvSV(gv_fetchpvs("\017PEN", GV_ADD|GV_NOTQUAL,
2539                                          SVt_PV)))) {
2540                    U32 in  = PL_unicode & PERL_UNICODE_IN_FLAG;
2541                    U32 out = PL_unicode & PERL_UNICODE_OUT_FLAG;
2542                    if (in) {
2543                         if (out)
2544                              sv_setpvs(sv, ":utf8\0:utf8");
2545                         else
2546                              sv_setpvs(sv, ":utf8\0");
2547                    }
2548                    else if (out)
2549                         sv_setpvs(sv, "\0:utf8");
2550                    SvSETMAGIC(sv);
2551               }
2552          }
2553     }
2554 #endif
2555
2556     {
2557         const char *s;
2558     if ((s = PerlEnv_getenv("PERL_SIGNALS"))) {
2559          if (strEQ(s, "unsafe"))
2560               PL_signals |=  PERL_SIGNALS_UNSAFE_FLAG;
2561          else if (strEQ(s, "safe"))
2562               PL_signals &= ~PERL_SIGNALS_UNSAFE_FLAG;
2563          else
2564               Perl_croak(aTHX_ "PERL_SIGNALS illegal: \"%s\"", s);
2565     }
2566     }
2567
2568
2569     lex_start(linestr_sv, rsfp, lex_start_flags);
2570     SvREFCNT_dec(linestr_sv);
2571
2572     PL_subname = newSVpvs("main");
2573
2574     if (add_read_e_script)
2575         filter_add(read_e_script, NULL);
2576
2577     /* now parse the script */
2578
2579     SETERRNO(0,SS_NORMAL);
2580     if (yyparse(GRAMPROG) || PL_parser->error_count) {
2581         abort_execution("", PL_origfilename);
2582     }
2583     CopLINE_set(PL_curcop, 0);
2584     SET_CURSTASH(PL_defstash);
2585     if (PL_e_script) {
2586         SvREFCNT_dec(PL_e_script);
2587         PL_e_script = NULL;
2588     }
2589
2590     if (PL_do_undump)
2591         my_unexec();
2592
2593     if (isWARN_ONCE) {
2594         SAVECOPFILE(PL_curcop);
2595         SAVECOPLINE(PL_curcop);
2596         gv_check(PL_defstash);
2597     }
2598
2599     LEAVE;
2600     FREETMPS;
2601
2602 #ifdef MYMALLOC
2603     {
2604         const char *s;
2605         UV uv;
2606         s = PerlEnv_getenv("PERL_DEBUG_MSTATS");
2607         if (s && grok_atoUV(s, &uv, NULL) && uv >= 2)
2608             dump_mstats("after compilation:");
2609     }
2610 #endif
2611
2612     ENTER;
2613     PL_restartjmpenv = NULL;
2614     PL_restartop = 0;
2615     return NULL;
2616 }
2617
2618 /*
2619 =for apidoc perl_run
2620
2621 Tells a Perl interpreter to run its main program.  See L<perlembed>
2622 for a tutorial.
2623
2624 C<my_perl> points to the Perl interpreter.  It must have been previously
2625 created through the use of L</perl_alloc> and L</perl_construct>, and
2626 initialised through L</perl_parse>.  This function should not be called
2627 if L</perl_parse> returned a non-zero value, indicating a failure in
2628 initialisation or compilation.
2629
2630 This function executes code in C<INIT> blocks, and then executes the
2631 main program.  The code to be executed is that established by the prior
2632 call to L</perl_parse>.  If the interpreter's C<PL_exit_flags> word
2633 does not have the C<PERL_EXIT_DESTRUCT_END> flag set, then this function
2634 will also execute code in C<END> blocks.  If it is desired to make any
2635 further use of the interpreter after calling this function, then C<END>
2636 blocks should be postponed to L</perl_destruct> time by setting that flag.
2637
2638 Returns an integer of slightly tricky interpretation.  The correct use
2639 of the return value is as a truth value indicating whether the program
2640 terminated non-locally.  If zero is returned, this indicates that
2641 the program ran to completion, and it is safe to make other use of the
2642 interpreter (provided that the C<PERL_EXIT_DESTRUCT_END> flag was set as
2643 described above).  If a non-zero value is returned, this indicates that
2644 the interpreter wants to terminate early.  The interpreter should not be
2645 just abandoned because of this desire to terminate; the caller should
2646 proceed to shut the interpreter down cleanly with L</perl_destruct>
2647 and free it with L</perl_free>.
2648
2649 For historical reasons, the non-zero return value also attempts to
2650 be a suitable value to pass to the C library function C<exit> (or to
2651 return from C<main>), to serve as an exit code indicating the nature of
2652 the way the program terminated.  However, this isn't portable, due to
2653 differing exit code conventions.  An attempt is made to return an exit
2654 code of the type required by the host operating system, but because
2655 it is constrained to be non-zero, it is not necessarily possible to
2656 indicate every type of exit.  It is only reliable on Unix, where a zero
2657 exit code can be augmented with a set bit that will be ignored.  In any
2658 case, this function is not the correct place to acquire an exit code:
2659 one should get that from L</perl_destruct>.
2660
2661 =cut
2662 */
2663
2664 int
2665 perl_run(pTHXx)
2666 {
2667     I32 oldscope;
2668     int ret = 0;
2669     dJMPENV;
2670
2671     PERL_ARGS_ASSERT_PERL_RUN;
2672 #ifndef MULTIPLICITY
2673     PERL_UNUSED_ARG(my_perl);
2674 #endif
2675
2676     oldscope = PL_scopestack_ix;
2677 #ifdef VMS
2678     VMSISH_HUSHED = 0;
2679 #endif
2680
2681     JMPENV_PUSH(ret);
2682     switch (ret) {
2683     case 1:
2684         cxstack_ix = -1;                /* start context stack again */
2685         goto redo_body;
2686     case 0:                             /* normal completion */
2687  redo_body:
2688         run_body(oldscope);
2689         /* FALLTHROUGH */
2690     case 2:                             /* my_exit() */
2691         while (PL_scopestack_ix > oldscope)
2692             LEAVE;
2693         FREETMPS;
2694         SET_CURSTASH(PL_defstash);
2695         if (!(PL_exit_flags & PERL_EXIT_DESTRUCT_END) &&
2696             PL_endav && !PL_minus_c) {
2697             PERL_SET_PHASE(PERL_PHASE_END);
2698             call_list(oldscope, PL_endav);
2699         }
2700 #ifdef MYMALLOC
2701         if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
2702             dump_mstats("after execution:  ");
2703 #endif
2704         ret = STATUS_EXIT;
2705         break;
2706     case 3:
2707         if (PL_restartop) {
2708             POPSTACK_TO(PL_mainstack);
2709             goto redo_body;
2710         }
2711         PerlIO_printf(Perl_error_log, "panic: restartop in perl_run\n");
2712         FREETMPS;
2713         ret = 1;
2714         break;
2715     }
2716
2717     JMPENV_POP;
2718     return ret;
2719 }
2720
2721 STATIC void
2722 S_run_body(pTHX_ I32 oldscope)
2723 {
2724     DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support (0x%x).\n",
2725                     PL_sawampersand ? "Enabling" : "Omitting",
2726                     (unsigned int)(PL_sawampersand)));
2727
2728     if (!PL_restartop) {
2729 #ifdef DEBUGGING
2730         if (DEBUG_x_TEST || DEBUG_B_TEST)
2731             dump_all_perl(!DEBUG_B_TEST);
2732         if (!DEBUG_q_TEST)
2733           PERL_DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
2734 #endif
2735
2736         if (PL_minus_c) {
2737             PerlIO_printf(Perl_error_log, "%s syntax OK\n", PL_origfilename);
2738             my_exit(0);
2739         }
2740         if (PERLDB_SINGLE && PL_DBsingle)
2741             PL_DBsingle_iv = 1;
2742         if (PL_initav) {
2743             PERL_SET_PHASE(PERL_PHASE_INIT);
2744             call_list(oldscope, PL_initav);
2745         }
2746 #ifdef PERL_DEBUG_READONLY_OPS
2747         if (PL_main_root && PL_main_root->op_slabbed)
2748             Slab_to_ro(OpSLAB(PL_main_root));
2749 #endif
2750     }
2751
2752     /* do it */
2753
2754     PERL_SET_PHASE(PERL_PHASE_RUN);
2755
2756     if (PL_restartop) {
2757         PL_restartjmpenv = NULL;
2758         PL_op = PL_restartop;
2759         PL_restartop = 0;
2760         CALLRUNOPS(aTHX);
2761     }
2762     else if (PL_main_start) {
2763         CvDEPTH(PL_main_cv) = 1;
2764         PL_op = PL_main_start;
2765         CALLRUNOPS(aTHX);
2766     }
2767     my_exit(0);
2768     NOT_REACHED; /* NOTREACHED */
2769 }
2770
2771 /*
2772 =head1 SV Manipulation Functions
2773
2774 =for apidoc get_sv
2775
2776 Returns the SV of the specified Perl scalar.  C<flags> are passed to
2777 C<gv_fetchpv>.  If C<GV_ADD> is set and the
2778 Perl variable does not exist then it will be created.  If C<flags> is zero
2779 and the variable does not exist then NULL is returned.
2780
2781 =cut
2782 */
2783
2784 SV*
2785 Perl_get_sv(pTHX_ const char *name, I32 flags)
2786 {
2787     GV *gv;
2788
2789     PERL_ARGS_ASSERT_GET_SV;
2790
2791     gv = gv_fetchpv(name, flags, SVt_PV);
2792     if (gv)
2793         return GvSV(gv);
2794     return NULL;
2795 }
2796
2797 /*
2798 =head1 Array Manipulation Functions
2799
2800 =for apidoc get_av
2801
2802 Returns the AV of the specified Perl global or package array with the given
2803 name (so it won't work on lexical variables).  C<flags> are passed 
2804 to C<gv_fetchpv>.  If C<GV_ADD> is set and the
2805 Perl variable does not exist then it will be created.  If C<flags> is zero
2806 and the variable does not exist then NULL is returned.
2807
2808 Perl equivalent: C<@{"$name"}>.
2809
2810 =cut
2811 */
2812
2813 AV*
2814 Perl_get_av(pTHX_ const char *name, I32 flags)
2815 {
2816     GV* const gv = gv_fetchpv(name, flags, SVt_PVAV);
2817
2818     PERL_ARGS_ASSERT_GET_AV;
2819
2820     if (flags)
2821         return GvAVn(gv);
2822     if (gv)
2823         return GvAV(gv);
2824     return NULL;
2825 }
2826
2827 /*
2828 =head1 Hash Manipulation Functions
2829
2830 =for apidoc get_hv
2831
2832 Returns the HV of the specified Perl hash.  C<flags> are passed to
2833 C<gv_fetchpv>.  If C<GV_ADD> is set and the
2834 Perl variable does not exist then it will be created.  If C<flags> is zero
2835 and the variable does not exist then C<NULL> is returned.
2836
2837 =cut
2838 */
2839
2840 HV*
2841 Perl_get_hv(pTHX_ const char *name, I32 flags)
2842 {
2843     GV* const gv = gv_fetchpv(name, flags, SVt_PVHV);
2844
2845     PERL_ARGS_ASSERT_GET_HV;
2846
2847     if (flags)
2848         return GvHVn(gv);
2849     if (gv)
2850         return GvHV(gv);
2851     return NULL;
2852 }
2853
2854 /*
2855 =head1 CV Manipulation Functions
2856
2857 =for apidoc get_cvn_flags
2858
2859 Returns the CV of the specified Perl subroutine.  C<flags> are passed to
2860 C<gv_fetchpvn_flags>.  If C<GV_ADD> is set and the Perl subroutine does not
2861 exist then it will be declared (which has the same effect as saying
2862 C<sub name;>).  If C<GV_ADD> is not set and the subroutine does not exist
2863 then NULL is returned.
2864
2865 =for apidoc get_cv
2866
2867 Uses C<strlen> to get the length of C<name>, then calls C<get_cvn_flags>.
2868
2869 =cut
2870 */
2871
2872 CV*
2873 Perl_get_cvn_flags(pTHX_ const char *name, STRLEN len, I32 flags)
2874 {
2875     GV* const gv = gv_fetchpvn_flags(name, len, flags, SVt_PVCV);
2876
2877     PERL_ARGS_ASSERT_GET_CVN_FLAGS;
2878
2879     if (gv && UNLIKELY(SvROK(gv)) && SvTYPE(SvRV((SV *)gv)) == SVt_PVCV)
2880         return (CV*)SvRV((SV *)gv);
2881
2882     /* XXX this is probably not what they think they're getting.
2883      * It has the same effect as "sub name;", i.e. just a forward
2884      * declaration! */
2885     if ((flags & ~GV_NOADD_MASK) && !GvCVu(gv)) {
2886         return newSTUB(gv,0);
2887     }
2888     if (gv)
2889         return GvCVu(gv);
2890     return NULL;
2891 }
2892
2893 /* Nothing in core calls this now, but we can't replace it with a macro and
2894    move it to mathoms.c as a macro would evaluate name twice.  */
2895 CV*
2896 Perl_get_cv(pTHX_ const char *name, I32 flags)
2897 {
2898     PERL_ARGS_ASSERT_GET_CV;
2899
2900     return get_cvn_flags(name, strlen(name), flags);
2901 }
2902
2903 /* Be sure to refetch the stack pointer after calling these routines. */
2904
2905 /*
2906
2907 =head1 Callback Functions
2908
2909 =for apidoc call_argv
2910
2911 Performs a callback to the specified named and package-scoped Perl subroutine 
2912 with C<argv> (a C<NULL>-terminated array of strings) as arguments.  See
2913 L<perlcall>.
2914
2915 Approximate Perl equivalent: C<&{"$sub_name"}(@$argv)>.
2916
2917 =cut
2918 */
2919
2920 I32
2921 Perl_call_argv(pTHX_ const char *sub_name, I32 flags, char **argv)
2922
2923                         /* See G_* flags in cop.h */
2924                         /* null terminated arg list */
2925 {
2926     dSP;
2927
2928     PERL_ARGS_ASSERT_CALL_ARGV;
2929
2930     PUSHMARK(SP);
2931     while (*argv) {
2932         mXPUSHs(newSVpv(*argv,0));
2933         argv++;
2934     }
2935     PUTBACK;
2936     return call_pv(sub_name, flags);
2937 }
2938
2939 /*
2940 =for apidoc call_pv
2941
2942 Performs a callback to the specified Perl sub.  See L<perlcall>.
2943
2944 =cut
2945 */
2946
2947 I32
2948 Perl_call_pv(pTHX_ const char *sub_name, I32 flags)
2949                         /* name of the subroutine */
2950                         /* See G_* flags in cop.h */
2951 {
2952     PERL_ARGS_ASSERT_CALL_PV;
2953
2954     return call_sv(MUTABLE_SV(get_cv(sub_name, GV_ADD)), flags);
2955 }
2956
2957 /*
2958 =for apidoc call_method
2959
2960 Performs a callback to the specified Perl method.  The blessed object must
2961 be on the stack.  See L<perlcall>.
2962
2963 =cut
2964 */
2965
2966 I32
2967 Perl_call_method(pTHX_ const char *methname, I32 flags)
2968                         /* name of the subroutine */
2969                         /* See G_* flags in cop.h */
2970 {
2971     STRLEN len;
2972     SV* sv;
2973     PERL_ARGS_ASSERT_CALL_METHOD;
2974
2975     len = strlen(methname);
2976     sv = flags & G_METHOD_NAMED
2977         ? sv_2mortal(newSVpvn_share(methname, len,0))
2978         : newSVpvn_flags(methname, len, SVs_TEMP);
2979
2980     return call_sv(sv, flags | G_METHOD);
2981 }
2982
2983 /* May be called with any of a CV, a GV, or an SV containing the name. */
2984 /*
2985 =for apidoc call_sv
2986
2987 Performs a callback to the Perl sub specified by the SV.
2988
2989 If neither the C<G_METHOD> nor C<G_METHOD_NAMED> flag is supplied, the
2990 SV may be any of a CV, a GV, a reference to a CV, a reference to a GV
2991 or C<SvPV(sv)> will be used as the name of the sub to call.
2992
2993 If the C<G_METHOD> flag is supplied, the SV may be a reference to a CV or
2994 C<SvPV(sv)> will be used as the name of the method to call.
2995
2996 If the C<G_METHOD_NAMED> flag is supplied, C<SvPV(sv)> will be used as
2997 the name of the method to call.
2998
2999 Some other values are treated specially for internal use and should
3000 not be depended on.
3001
3002 See L<perlcall>.
3003
3004 =for apidoc Amnh||G_METHOD
3005 =for apidoc Amnh||G_METHOD_NAMED
3006
3007 =cut
3008 */
3009
3010 I32
3011 Perl_call_sv(pTHX_ SV *sv, volatile I32 flags)
3012                         /* See G_* flags in cop.h */
3013 {
3014     dVAR;
3015     LOGOP myop;         /* fake syntax tree node */
3016     METHOP method_op;
3017     I32 oldmark;
3018     volatile I32 retval = 0;
3019     bool oldcatch = CATCH_GET;
3020     int ret;
3021     OP* const oldop = PL_op;
3022     dJMPENV;
3023
3024     PERL_ARGS_ASSERT_CALL_SV;
3025
3026     if (flags & G_DISCARD) {
3027         ENTER;
3028         SAVETMPS;
3029     }
3030     if (!(flags & G_WANT)) {
3031         /* Backwards compatibility - as G_SCALAR was 0, it could be omitted.
3032          */
3033         flags |= G_SCALAR;
3034     }
3035
3036     Zero(&myop, 1, LOGOP);
3037     if (!(flags & G_NOARGS))
3038         myop.op_flags |= OPf_STACKED;
3039     myop.op_flags |= OP_GIMME_REVERSE(flags);
3040     SAVEOP();
3041     PL_op = (OP*)&myop;
3042
3043     if (!(flags & G_METHOD_NAMED)) {
3044         dSP;
3045         EXTEND(SP, 1);
3046         PUSHs(sv);
3047         PUTBACK;
3048     }
3049     oldmark = TOPMARK;
3050
3051     if (PERLDB_SUB && PL_curstash != PL_debstash
3052            /* Handle first BEGIN of -d. */
3053           && (PL_DBcv || (PL_DBcv = GvCV(PL_DBsub)))
3054            /* Try harder, since this may have been a sighandler, thus
3055             * curstash may be meaningless. */
3056           && (SvTYPE(sv) != SVt_PVCV || CvSTASH((const CV *)sv) != PL_debstash)
3057           && !(flags & G_NODEBUG))
3058         myop.op_private |= OPpENTERSUB_DB;
3059
3060     if (flags & (G_METHOD|G_METHOD_NAMED)) {
3061         Zero(&method_op, 1, METHOP);
3062         method_op.op_next = (OP*)&myop;
3063         PL_op = (OP*)&method_op;
3064         if ( flags & G_METHOD_NAMED ) {
3065             method_op.op_ppaddr = PL_ppaddr[OP_METHOD_NAMED];
3066             method_op.op_type = OP_METHOD_NAMED;
3067             method_op.op_u.op_meth_sv = sv;
3068         } else {
3069             method_op.op_ppaddr = PL_ppaddr[OP_METHOD];
3070             method_op.op_type = OP_METHOD;
3071         }
3072         myop.op_ppaddr = PL_ppaddr[OP_ENTERSUB];
3073         myop.op_type = OP_ENTERSUB;
3074     }
3075
3076     if (!(flags & G_EVAL)) {
3077         CATCH_SET(TRUE);
3078         CALL_BODY_SUB((OP*)&myop);
3079         retval = PL_stack_sp - (PL_stack_base + oldmark);
3080         CATCH_SET(oldcatch);
3081     }
3082     else {
3083         I32 old_cxix;
3084         myop.op_other = (OP*)&myop;
3085         (void)POPMARK;
3086         old_cxix = cxstack_ix;
3087         create_eval_scope(NULL, flags|G_FAKINGEVAL);
3088         INCMARK;
3089
3090         JMPENV_PUSH(ret);
3091
3092         switch (ret) {
3093         case 0:
3094  redo_body:
3095             CALL_BODY_SUB((OP*)&myop);
3096             retval = PL_stack_sp - (PL_stack_base + oldmark);
3097             if (!(flags & G_KEEPERR)) {
3098                 CLEAR_ERRSV();
3099             }
3100             break;
3101         case 1:
3102             STATUS_ALL_FAILURE;
3103             /* FALLTHROUGH */
3104         case 2:
3105             /* my_exit() was called */
3106             SET_CURSTASH(PL_defstash);
3107             FREETMPS;
3108             JMPENV_POP;
3109             my_exit_jump();
3110             NOT_REACHED; /* NOTREACHED */
3111         case 3:
3112             if (PL_restartop) {
3113                 PL_restartjmpenv = NULL;
3114                 PL_op = PL_restartop;
3115                 PL_restartop = 0;
3116                 goto redo_body;
3117             }
3118             PL_stack_sp = PL_stack_base + oldmark;
3119             if ((flags & G_WANT) == G_ARRAY)
3120                 retval = 0;
3121             else {
3122                 retval = 1;
3123                 *++PL_stack_sp = &PL_sv_undef;
3124             }
3125             break;
3126         }
3127
3128         /* if we croaked, depending on how we croaked the eval scope
3129          * may or may not have already been popped */
3130         if (cxstack_ix > old_cxix) {
3131             assert(cxstack_ix == old_cxix + 1);
3132             assert(CxTYPE(CX_CUR()) == CXt_EVAL);
3133             delete_eval_scope();
3134         }
3135         JMPENV_POP;
3136     }
3137
3138     if (flags & G_DISCARD) {
3139         PL_stack_sp = PL_stack_base + oldmark;
3140         retval = 0;
3141         FREETMPS;
3142         LEAVE;
3143     }
3144     PL_op = oldop;
3145     return retval;
3146 }
3147
3148 /* Eval a string. The G_EVAL flag is always assumed. */
3149
3150 /*
3151 =for apidoc eval_sv
3152
3153 Tells Perl to C<eval> the string in the SV.  It supports the same flags
3154 as C<call_sv>, with the obvious exception of C<G_EVAL>.  See L<perlcall>.
3155
3156 The C<G_RETHROW> flag can be used if you only need eval_sv() to
3157 execute code specified by a string, but not catch any errors.
3158
3159 =for apidoc Amnh||G_RETHROW
3160 =cut
3161 */
3162
3163 I32
3164 Perl_eval_sv(pTHX_ SV *sv, I32 flags)
3165
3166                         /* See G_* flags in cop.h */
3167 {
3168     dVAR;
3169     UNOP myop;          /* fake syntax tree node */
3170     volatile I32 oldmark;
3171     volatile I32 retval = 0;
3172     int ret;
3173     OP* const oldop = PL_op;
3174     dJMPENV;
3175
3176     PERL_ARGS_ASSERT_EVAL_SV;
3177
3178     if (flags & G_DISCARD) {
3179         ENTER;
3180         SAVETMPS;
3181     }
3182
3183     SAVEOP();
3184     PL_op = (OP*)&myop;
3185     Zero(&myop, 1, UNOP);
3186     {
3187         dSP;
3188         oldmark = SP - PL_stack_base;
3189         EXTEND(SP, 1);
3190         PUSHs(sv);
3191         PUTBACK;
3192     }
3193
3194     if (!(flags & G_NOARGS))
3195         myop.op_flags = OPf_STACKED;
3196     myop.op_type = OP_ENTEREVAL;
3197     myop.op_flags |= OP_GIMME_REVERSE(flags);
3198     if (flags & G_KEEPERR)
3199         myop.op_flags |= OPf_SPECIAL;
3200
3201     if (flags & G_RE_REPARSING)
3202         myop.op_private = (OPpEVAL_COPHH | OPpEVAL_RE_REPARSING);
3203
3204     /* fail now; otherwise we could fail after the JMPENV_PUSH but
3205      * before a cx_pusheval(), which corrupts the stack after a croak */
3206     TAINT_PROPER("eval_sv()");
3207
3208     JMPENV_PUSH(ret);
3209     switch (ret) {
3210     case 0:
3211  redo_body:
3212         if (PL_op == (OP*)(&myop)) {
3213             PL_op = PL_ppaddr[OP_ENTEREVAL](aTHX);
3214             if (!PL_op)
3215                 goto fail; /* failed in compilation */
3216         }
3217         CALLRUNOPS(aTHX);
3218         retval = PL_stack_sp - (PL_stack_base + oldmark);
3219         if (!(flags & G_KEEPERR)) {
3220             CLEAR_ERRSV();
3221         }
3222         break;
3223     case 1:
3224         STATUS_ALL_FAILURE;
3225         /* FALLTHROUGH */
3226     case 2:
3227         /* my_exit() was called */
3228         SET_CURSTASH(PL_defstash);
3229         FREETMPS;
3230         JMPENV_POP;
3231         my_exit_jump();
3232         NOT_REACHED; /* NOTREACHED */
3233     case 3:
3234         if (PL_restartop) {
3235             PL_restartjmpenv = NULL;
3236             PL_op = PL_restartop;
3237             PL_restartop = 0;
3238             goto redo_body;
3239         }
3240       fail:
3241         if (flags & G_RETHROW) {
3242             JMPENV_POP;
3243             croak_sv(ERRSV);
3244         }
3245
3246         PL_stack_sp = PL_stack_base + oldmark;
3247         if ((flags & G_WANT) == G_ARRAY)
3248             retval = 0;
3249         else {
3250             retval = 1;
3251             *++PL_stack_sp = &PL_sv_undef;
3252         }
3253         break;
3254     }
3255
3256     JMPENV_POP;
3257     if (flags & G_DISCARD) {
3258         PL_stack_sp = PL_stack_base + oldmark;
3259         retval = 0;
3260         FREETMPS;
3261         LEAVE;
3262     }
3263     PL_op = oldop;
3264     return retval;
3265 }
3266
3267 /*
3268 =for apidoc eval_pv
3269
3270 Tells Perl to C<eval> the given string in scalar context and return an SV* result.
3271
3272 =cut
3273 */
3274
3275 SV*
3276 Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error)
3277 {
3278     SV* sv = newSVpv(p, 0);
3279
3280     PERL_ARGS_ASSERT_EVAL_PV;
3281
3282     if (croak_on_error) {
3283         sv_2mortal(sv);
3284         eval_sv(sv, G_SCALAR | G_RETHROW);
3285     }
3286     else {
3287         eval_sv(sv, G_SCALAR);
3288         SvREFCNT_dec(sv);
3289     }
3290
3291     {
3292         dSP;
3293         sv = POPs;
3294         PUTBACK;
3295     }
3296
3297     return sv;
3298 }
3299
3300 /* Require a module. */
3301
3302 /*
3303 =head1 Embedding Functions
3304
3305 =for apidoc require_pv
3306
3307 Tells Perl to C<require> the file named by the string argument.  It is
3308 analogous to the Perl code C<eval "require '$file'">.  It's even
3309 implemented that way; consider using load_module instead.
3310
3311 =cut */
3312
3313 void
3314 Perl_require_pv(pTHX_ const char *pv)
3315 {
3316     dSP;
3317     SV* sv;
3318
3319     PERL_ARGS_ASSERT_REQUIRE_PV;
3320
3321     PUSHSTACKi(PERLSI_REQUIRE);
3322     sv = Perl_newSVpvf(aTHX_ "require q%c%s%c", 0, pv, 0);
3323     eval_sv(sv_2mortal(sv), G_DISCARD);
3324     POPSTACK;
3325 }
3326
3327 STATIC void
3328 S_usage(pTHX)           /* XXX move this out into a module ? */
3329 {
3330     /* This message really ought to be max 23 lines.
3331      * Removed -h because the user already knows that option. Others? */
3332
3333     /* Grouped as 6 lines per C string literal, to keep under the ANSI C 89
3334        minimum of 509 character string literals.  */
3335     static const char * const usage_msg[] = {
3336 "  -0[octal]         specify record separator (\\0, if no argument)\n"
3337 "  -a                autosplit mode with -n or -p (splits $_ into @F)\n"
3338 "  -C[number/list]   enables the listed Unicode features\n"
3339 "  -c                check syntax only (runs BEGIN and CHECK blocks)\n"
3340 "  -d[:debugger]     run program under debugger\n"
3341 "  -D[number/list]   set debugging flags (argument is a bit mask or alphabets)\n",
3342 "  -e program        one line of program (several -e's allowed, omit programfile)\n"
3343 "  -E program        like -e, but enables all optional features\n"
3344 "  -f                don't do $sitelib/sitecustomize.pl at startup\n"
3345 "  -F/pattern/       split() pattern for -a switch (//'s are optional)\n"
3346 "  -i[extension]     edit <> files in place (makes backup if extension supplied)\n"
3347 "  -Idirectory       specify @INC/#include directory (several -I's allowed)\n",
3348 "  -l[octal]         enable line ending processing, specifies line terminator\n"
3349 "  -[mM][-]module    execute \"use/no module...\" before executing program\n"
3350 "  -n                assume \"while (<>) { ... }\" loop around program\n"
3351 "  -p                assume loop like -n but print line also, like sed\n"
3352 "  -s                enable rudimentary parsing for switches after programfile\n"
3353 "  -S                look for programfile using PATH environment variable\n",
3354 "  -t                enable tainting warnings\n"
3355 "  -T                enable tainting checks\n"
3356 "  -u                dump core after parsing program\n"
3357 "  -U                allow unsafe operations\n"
3358 "  -v                print version, patchlevel and license\n"
3359 "  -V[:variable]     print configuration summary (or a single Config.pm variable)\n",
3360 "  -w                enable many useful warnings\n"
3361 "  -W                enable all warnings\n"
3362 "  -x[directory]     ignore text before #!perl line (optionally cd to directory)\n"
3363 "  -X                disable all warnings\n"
3364 "  \n"
3365 "Run 'perldoc perl' for more help with Perl.\n\n",
3366 NULL
3367 };
3368     const char * const *p = usage_msg;
3369     PerlIO *out = PerlIO_stdout();
3370
3371     PerlIO_printf(out,
3372                   "\nUsage: %s [switches] [--] [programfile] [arguments]\n",
3373                   PL_origargv[0]);
3374     while (*p)
3375         PerlIO_puts(out, *p++);
3376     my_exit(0);
3377 }
3378
3379 /* convert a string of -D options (or digits) into an int.
3380  * sets *s to point to the char after the options */
3381
3382 #ifdef DEBUGGING
3383 int
3384 Perl_get_debug_opts(pTHX_ const char **s, bool givehelp)
3385 {
3386     static const char * const usage_msgd[] = {
3387       " Debugging flag values: (see also -d)\n"
3388       "  p  Tokenizing and parsing (with v, displays parse stack)\n"
3389       "  s  Stack snapshots (with v, displays all stacks)\n"
3390       "  l  Context (loop) stack processing\n"
3391       "  t  Trace execution\n"
3392       "  o  Method and overloading resolution\n",
3393       "  c  String/numeric conversions\n"
3394       "  P  Print profiling info, source file input state\n"
3395       "  m  Memory and SV allocation\n"
3396       "  f  Format processing\n"
3397       "  r  Regular expression parsing and execution\n"
3398       "  x  Syntax tree dump\n",
3399       "  u  Tainting checks\n"
3400       "  H  Hash dump -- usurps values()\n"
3401       "  X  Scratchpad allocation\n"
3402       "  D  Cleaning up\n"
3403       "  S  Op slab allocation\n"
3404       "  T  Tokenising\n"
3405       "  R  Include reference counts of dumped variables (eg when using -Ds)\n",
3406       "  J  Do not s,t,P-debug (Jump over) opcodes within package DB\n"
3407       "  v  Verbose: use in conjunction with other flags\n"
3408       "  C  Copy On Write\n"
3409       "  A  Consistency checks on internal structures\n"
3410       "  q  quiet - currently only suppresses the 'EXECUTING' message\n"
3411       "  M  trace smart match resolution\n"
3412       "  B  dump suBroutine definitions, including special Blocks like BEGIN\n",
3413       "  L  trace some locale setting information--for Perl core development\n",
3414       "  i  trace PerlIO layer processing\n",
3415       "  y  trace y///, tr/// compilation and execution\n",
3416       NULL
3417     };
3418     UV uv = 0;
3419
3420     PERL_ARGS_ASSERT_GET_DEBUG_OPTS;
3421
3422     if (isALPHA(**s)) {
3423         /* if adding extra options, remember to update DEBUG_MASK */
3424         static const char debopts[] = "psltocPmfrxuUHXDSTRJvCAqMBLiy";
3425
3426         for (; isWORDCHAR(**s); (*s)++) {
3427             const char * const d = strchr(debopts,**s);
3428             if (d)
3429                 uv |= 1 << (d - debopts);
3430             else if (ckWARN_d(WARN_DEBUGGING))
3431                 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
3432                     "invalid option -D%c, use -D'' to see choices\n", **s);
3433         }
3434     }
3435     else if (isDIGIT(**s)) {
3436         const char* e = *s + strlen(*s);
3437         if (grok_atoUV(*s, &uv, &e))
3438             *s = e;
3439         for (; isWORDCHAR(**s); (*s)++) ;
3440     }
3441     else if (givehelp) {
3442       const char *const *p = usage_msgd;
3443       while (*p) PerlIO_puts(PerlIO_stdout(), *p++);
3444     }
3445     return (int)uv; /* ignore any UV->int conversion loss */
3446 }
3447 #endif
3448
3449 /* This routine handles any switches that can be given during run */
3450
3451 const char *
3452 Perl_moreswitches(pTHX_ const char *s)
3453 {
3454     dVAR;
3455     UV rschar;
3456     const char option = *s; /* used to remember option in -m/-M code */
3457
3458     PERL_ARGS_ASSERT_MORESWITCHES;
3459
3460     switch (*s) {
3461     case '0':
3462     {
3463          I32 flags = 0;
3464          STRLEN numlen;
3465
3466          SvREFCNT_dec(PL_rs);
3467          if (s[1] == 'x' && s[2]) {
3468               const char *e = s+=2;
3469               U8 *tmps;
3470
3471               while (*e)
3472                 e++;
3473               numlen = e - s;
3474               flags = PERL_SCAN_SILENT_ILLDIGIT;
3475               rschar = (U32)grok_hex(s, &numlen, &flags, NULL);
3476               if (s + numlen < e) {
3477                    rschar = 0; /* Grandfather -0xFOO as -0 -xFOO. */
3478                    numlen = 0;
3479                    s--;
3480               }
3481               PL_rs = newSVpvs("");
3482               tmps = (U8*) SvGROW(PL_rs, (STRLEN)(UVCHR_SKIP(rschar) + 1));
3483               uvchr_to_utf8(tmps, rschar);
3484               SvCUR_set(PL_rs, UVCHR_SKIP(rschar));
3485               SvUTF8_on(PL_rs);
3486          }
3487          else {
3488               numlen = 4;
3489               rschar = (U32)grok_oct(s, &numlen, &flags, NULL);
3490               if (rschar & ~((U8)~0))
3491                    PL_rs = &PL_sv_undef;
3492               else if (!rschar && numlen >= 2)
3493                    PL_rs = newSVpvs("");
3494               else {
3495                    char ch = (char)rschar;
3496                    PL_rs = newSVpvn(&ch, 1);
3497               }
3498          }
3499          sv_setsv(get_sv("/", GV_ADD), PL_rs);
3500          return s + numlen;
3501     }
3502     case 'C':
3503         s++;
3504         PL_unicode = parse_unicode_opts( (const char **)&s );
3505         if (PL_unicode & PERL_UNICODE_UTF8CACHEASSERT_FLAG)
3506             PL_utf8cache = -1;
3507         return s;
3508     case 'F':
3509         PL_minus_a = TRUE;
3510         PL_minus_F = TRUE;
3511         PL_minus_n = TRUE;
3512         PL_splitstr = ++s;
3513         while (*s && !isSPACE(*s)) ++s;
3514         PL_splitstr = savepvn(PL_splitstr, s - PL_splitstr);
3515         return s;
3516     case 'a':
3517         PL_minus_a = TRUE;
3518         PL_minus_n = TRUE;
3519         s++;
3520         return s;
3521     case 'c':
3522         PL_minus_c = TRUE;
3523         s++;
3524         return s;
3525     case 'd':
3526         forbid_setid('d', FALSE);
3527         s++;
3528
3529         /* -dt indicates to the debugger that threads will be used */
3530         if (*s == 't' && !isWORDCHAR(s[1])) {
3531             ++s;
3532             my_setenv("PERL5DB_THREADED", "1");
3533         }
3534
3535         /* The following permits -d:Mod to accepts arguments following an =
3536            in the fashion that -MSome::Mod does. */
3537         if (*s == ':' || *s == '=') {
3538             const char *start;
3539             const char *end;
3540             SV *sv;
3541
3542             if (*++s == '-') {
3543                 ++s;
3544                 sv = newSVpvs("no Devel::");
3545             } else {
3546                 sv = newSVpvs("use Devel::");
3547             }
3548
3549             start = s;
3550             end = s + strlen(s);
3551
3552             /* We now allow -d:Module=Foo,Bar and -d:-Module */
3553             while(isWORDCHAR(*s) || *s==':') ++s;
3554             if (*s != '=')
3555                 sv_catpvn(sv, start, end - start);
3556             else {
3557                 sv_catpvn(sv, start, s-start);
3558                 /* Don't use NUL as q// delimiter here, this string goes in the
3559                  * environment. */
3560                 Perl_sv_catpvf(aTHX_ sv, " split(/,/,q{%s});", ++s);
3561             }
3562             s = end;
3563             my_setenv("PERL5DB", SvPV_nolen_const(sv));
3564             SvREFCNT_dec(sv);
3565         }
3566         if (!PL_perldb) {
3567             PL_perldb = PERLDB_ALL;
3568             init_debugger();
3569         }
3570         return s;
3571     case 'D':
3572     {   
3573 #ifdef DEBUGGING
3574         forbid_setid('D', FALSE);
3575         s++;
3576         PL_debug = get_debug_opts( (const char **)&s, 1) | DEBUG_TOP_FLAG;
3577 #else /* !DEBUGGING */
3578         if (ckWARN_d(WARN_DEBUGGING))
3579             Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
3580                    "Recompile perl with -DDEBUGGING to use -D switch (did you mean -d ?)\n");
3581         for (s++; isWORDCHAR(*s); s++) ;
3582 #endif
3583         return s;
3584         NOT_REACHED; /* NOTREACHED */
3585     }   
3586     case 'h':
3587         usage();
3588         NOT_REACHED; /* NOTREACHED */
3589
3590     case 'i':
3591         Safefree(PL_inplace);
3592         {
3593             const char * const start = ++s;
3594             while (*s && !isSPACE(*s))
3595                 ++s;
3596
3597             PL_inplace = savepvn(start, s - start);
3598         }
3599         return s;
3600     case 'I':   /* -I handled both here and in parse_body() */
3601         forbid_setid('I', FALSE);
3602         ++s;
3603         while (*s && isSPACE(*s))
3604             ++s;
3605         if (*s) {
3606             const char *e, *p;
3607             p = s;
3608             /* ignore trailing spaces (possibly followed by other switches) */
3609             do {
3610                 for (e = p; *e && !isSPACE(*e); e++) ;
3611                 p = e;
3612                 while (isSPACE(*p))
3613                     p++;
3614             } while (*p && *p != '-');
3615             incpush(s, e-s,
3616                     INCPUSH_ADD_SUB_DIRS|INCPUSH_ADD_OLD_VERS|INCPUSH_UNSHIFT);
3617             s = p;
3618             if (*s == '-')
3619                 s++;
3620         }
3621         else
3622             Perl_croak(aTHX_ "No directory specified for -I");
3623         return s;
3624     case 'l':
3625         PL_minus_l = TRUE;
3626         s++;
3627         if (PL_ors_sv) {
3628             SvREFCNT_dec(PL_ors_sv);
3629             PL_ors_sv = NULL;
3630         }
3631         if (isDIGIT(*s)) {
3632             I32 flags = 0;
3633             STRLEN numlen;
3634             PL_ors_sv = newSVpvs("\n");
3635             numlen = 3 + (*s == '0');
3636             *SvPVX(PL_ors_sv) = (char)grok_oct(s, &numlen, &flags, NULL);
3637             s += numlen;
3638         }
3639         else {
3640             if (RsPARA(PL_rs)) {
3641                 PL_ors_sv = newSVpvs("\n\n");
3642             }
3643             else {
3644                 PL_ors_sv = newSVsv(PL_rs);
3645             }
3646         }
3647         return s;
3648     case 'M':
3649         forbid_setid('M', FALSE);       /* XXX ? */
3650         /* FALLTHROUGH */
3651     case 'm':
3652         forbid_setid('m', FALSE);       /* XXX ? */
3653         if (*++s) {
3654             const char *start;
3655             const char *end;
3656             SV *sv;
3657             const char *use = "use ";
3658             bool colon = FALSE;
3659             /* -M-foo == 'no foo'       */
3660             /* Leading space on " no " is deliberate, to make both
3661                possibilities the same length.  */
3662             if (*s == '-') { use = " no "; ++s; }
3663             sv = newSVpvn(use,4);
3664             start = s;
3665             /* We allow -M'Module qw(Foo Bar)'  */
3666             while(isWORDCHAR(*s) || *s==':') {
3667                 if( *s++ == ':' ) {
3668                     if( *s == ':' ) 
3669                         s++;
3670                     else
3671                         colon = TRUE;
3672                 }
3673             }
3674             if (s == start)
3675                 Perl_croak(aTHX_ "Module name required with -%c option",
3676                                     option);
3677             if (colon) 
3678                 Perl_croak(aTHX_ "Invalid module name %.*s with -%c option: "
3679                                     "contains single ':'",
3680                                     (int)(s - start), start, option);
3681             end = s + strlen(s);
3682             if (*s != '=') {
3683                 sv_catpvn(sv, start, end - start);
3684                 if (option == 'm') {
3685                     if (*s != '\0')
3686                         Perl_croak(aTHX_ "Can't use '%c' after -mname", *s);
3687                     sv_catpvs( sv, " ()");
3688                 }
3689             } else {
3690                 sv_catpvn(sv, start, s-start);
3691                 /* Use NUL as q''-delimiter.  */
3692                 sv_catpvs(sv, " split(/,/,q\0");
3693                 ++s;
3694                 sv_catpvn(sv, s, end - s);
3695                 sv_catpvs(sv,  "\0)");
3696             }
3697             s = end;
3698             Perl_av_create_and_push(aTHX_ &PL_preambleav, sv);
3699         }
3700         else
3701             Perl_croak(aTHX_ "Missing argument to -%c", option);
3702         return s;
3703     case 'n':
3704         PL_minus_n = TRUE;
3705         s++;
3706         return s;
3707     case 'p':
3708         PL_minus_p = TRUE;
3709         s++;
3710         return s;
3711     case 's':
3712         forbid_setid('s', FALSE);
3713         PL_doswitches = TRUE;
3714         s++;
3715         return s;
3716     case 't':
3717     case 'T':
3718 #if defined(SILENT_NO_TAINT_SUPPORT)
3719             /* silently ignore */
3720 #elif defined(NO_TAINT_SUPPORT)
3721         Perl_croak_nocontext("This perl was compiled without taint support. "
3722                    "Cowardly refusing to run with -t or -T flags");
3723 #else
3724         if (!TAINTING_get)
3725             TOO_LATE_FOR(*s);
3726 #endif
3727         s++;
3728         return s;
3729     case 'u':
3730         PL_do_undump = TRUE;
3731         s++;
3732         return s;
3733     case 'U':
3734         PL_unsafe = TRUE;
3735         s++;
3736         return s;
3737     case 'v':
3738         minus_v();
3739     case 'w':
3740         if (! (PL_dowarn & G_WARN_ALL_MASK)) {
3741             PL_dowarn |= G_WARN_ON;
3742         }
3743         s++;
3744         return s;
3745     case 'W':
3746         PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
3747         if (!specialWARN(PL_compiling.cop_warnings))
3748             PerlMemShared_free(PL_compiling.cop_warnings);
3749         PL_compiling.cop_warnings = pWARN_ALL ;
3750         s++;
3751         return s;
3752     case 'X':
3753         PL_dowarn = G_WARN_ALL_OFF;
3754         if (!specialWARN(PL_compiling.cop_warnings))
3755             PerlMemShared_free(PL_compiling.cop_warnings);
3756         PL_compiling.cop_warnings = pWARN_NONE ;
3757         s++;
3758         return s;
3759     case '*':
3760     case ' ':
3761         while( *s == ' ' )
3762           ++s;
3763         if (s[0] == '-')        /* Additional switches on #! line. */
3764             return s+1;
3765         break;
3766     case '-':
3767     case 0:
3768 #if defined(WIN32) || !defined(PERL_STRICT_CR)
3769     case '\r':
3770 #endif
3771     case '\n':
3772     case '\t':
3773         break;
3774 #ifdef ALTERNATE_SHEBANG
3775     case 'S':                   /* OS/2 needs -S on "extproc" line. */
3776         break;
3777 #endif
3778     case 'e': case 'f': case 'x': case 'E':
3779 #ifndef ALTERNATE_SHEBANG
3780     case 'S':
3781 #endif
3782     case 'V':
3783         Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s);
3784     default:
3785         Perl_croak(aTHX_
3786             "Unrecognized switch: -%.1s  (-h will show valid options)",s
3787         );
3788     }
3789     return NULL;
3790 }
3791
3792
3793 STATIC void
3794 S_minus_v(pTHX)
3795 {
3796         PerlIO * PIO_stdout;
3797         {
3798             const char * const level_str = "v" PERL_VERSION_STRING;
3799             const STRLEN level_len = sizeof("v" PERL_VERSION_STRING)-1;
3800 #ifdef PERL_PATCHNUM
3801             SV* level;
3802 #  ifdef PERL_GIT_UNCOMMITTED_CHANGES
3803             static const char num [] = PERL_PATCHNUM "*";
3804 #  else
3805             static const char num [] = PERL_PATCHNUM;
3806 #  endif
3807             {
3808                 const STRLEN num_len = sizeof(num)-1;
3809                 /* A very advanced compiler would fold away the strnEQ
3810                    and this whole conditional, but most (all?) won't do it.
3811                    SV level could also be replaced by with preprocessor
3812                    catenation.
3813                 */
3814                 if (num_len >= level_len && strnEQ(num,level_str,level_len)) {
3815                     /* per 46807d8e80, PERL_PATCHNUM is outside of the control
3816                        of the interp so it might contain format characters
3817                     */
3818                     level = newSVpvn(num, num_len);
3819                 } else {
3820                     level = Perl_newSVpvf_nocontext("%s (%s)", level_str, num);
3821                 }
3822             }
3823 #else
3824         SV* level = newSVpvn(level_str, level_len);
3825 #endif /* #ifdef PERL_PATCHNUM */
3826         PIO_stdout =  PerlIO_stdout();
3827             PerlIO_printf(PIO_stdout,
3828                 "\nThis is perl "       STRINGIFY(PERL_REVISION)
3829                 ", version "            STRINGIFY(PERL_VERSION)
3830                 ", subversion "         STRINGIFY(PERL_SUBVERSION)
3831                 " (%" SVf ") built for "        ARCHNAME, SVfARG(level)
3832                 );
3833             SvREFCNT_dec_NN(level);
3834         }
3835 #if defined(LOCAL_PATCH_COUNT)
3836         if (LOCAL_PATCH_COUNT > 0)
3837             PerlIO_printf(PIO_stdout,
3838                           "\n(with %d registered patch%s, "
3839                           "see perl -V for more detail)",
3840                           LOCAL_PATCH_COUNT,
3841                           (LOCAL_PATCH_COUNT!=1) ? "es" : "");
3842 #endif
3843
3844         PerlIO_printf(PIO_stdout,
3845                       "\n\nCopyright 1987-2020, Larry Wall\n");
3846 #ifdef MSDOS
3847         PerlIO_printf(PIO_stdout,
3848                       "\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
3849 #endif
3850 #ifdef DJGPP
3851         PerlIO_printf(PIO_stdout,
3852                       "djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n"
3853                       "djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n");
3854 #endif
3855 #ifdef OS2
3856         PerlIO_printf(PIO_stdout,
3857                       "\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
3858                       "Version 5 port Copyright (c) 1994-2002, Andreas Kaiser, Ilya Zakharevich\n");
3859 #endif
3860 #ifdef OEMVS
3861         PerlIO_printf(PIO_stdout,
3862                       "MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
3863 #endif
3864 #ifdef __VOS__
3865         PerlIO_printf(PIO_stdout,
3866                       "Stratus OpenVOS port by Paul.Green@stratus.com, 1997-2013\n");
3867 #endif
3868 #ifdef POSIX_BC
3869         PerlIO_printf(PIO_stdout,
3870                       "BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
3871 #endif
3872 #ifdef __SYMBIAN32__
3873         PerlIO_printf(PIO_stdout,
3874                       "Symbian port by Nokia, 2004-2005\n");
3875 #endif
3876 #ifdef BINARY_BUILD_NOTICE
3877         BINARY_BUILD_NOTICE;
3878 #endif
3879         PerlIO_printf(PIO_stdout,
3880                       "\n\
3881 Perl may be copied only under the terms of either the Artistic License or the\n\
3882 GNU General Public License, which may be found in the Perl 5 source kit.\n\n\
3883 Complete documentation for Perl, including FAQ lists, should be found on\n\
3884 this system using \"man perl\" or \"perldoc perl\".  If you have access to the\n\
3885 Internet, point your browser at http://www.perl.org/, the Perl Home Page.\n\n");
3886         my_exit(0);
3887 }
3888
3889 /* compliments of Tom Christiansen */
3890
3891 /* unexec() can be found in the Gnu emacs distribution */
3892 /* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
3893
3894 #ifdef VMS
3895 #include <lib$routines.h>
3896 #endif
3897
3898 void
3899 Perl_my_unexec(pTHX)
3900 {
3901 #ifdef UNEXEC
3902     SV *    prog = newSVpv(BIN_EXP, 0);
3903     SV *    file = newSVpv(PL_origfilename, 0);
3904     int    status = 1;
3905     extern int etext;
3906
3907     sv_catpvs(prog, "/perl");
3908     sv_catpvs(file, ".perldump");
3909
3910     unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
3911     /* unexec prints msg to stderr in case of failure */
3912     PerlProc_exit(status);
3913 #else
3914     PERL_UNUSED_CONTEXT;
3915 #  ifdef VMS
3916      lib$signal(SS$_DEBUG);  /* ssdef.h #included from vmsish.h */
3917 #  elif defined(WIN32) || defined(__CYGWIN__)
3918     Perl_croak_nocontext("dump is not supported");
3919 #  else
3920     ABORT();            /* for use with undump */
3921 #  endif
3922 #endif
3923 }
3924
3925 /* initialize curinterp */
3926 STATIC void
3927 S_init_interp(pTHX)
3928 {
3929 #ifdef MULTIPLICITY
3930 #  define PERLVAR(prefix,var,type)
3931 #  define PERLVARA(prefix,var,n,type)
3932 #  if defined(PERL_IMPLICIT_CONTEXT)
3933 #    define PERLVARI(prefix,var,type,init)      aTHX->prefix##var = init;
3934 #    define PERLVARIC(prefix,var,type,init)     aTHX->prefix##var = init;
3935 #  else
3936 #    define PERLVARI(prefix,var,type,init)      PERL_GET_INTERP->var = init;
3937 #    define PERLVARIC(prefix,var,type,init)     PERL_GET_INTERP->var = init;
3938 #  endif
3939 #  include "intrpvar.h"
3940 #  undef PERLVAR
3941 #  undef PERLVARA
3942 #  undef PERLVARI
3943 #  undef PERLVARIC
3944 #else
3945 #  define PERLVAR(prefix,var,type)
3946 #  define PERLVARA(prefix,var,n,type)
3947 #  define PERLVARI(prefix,var,type,init)        PL_##var = init;
3948 #  define PERLVARIC(prefix,var,type,init)       PL_##var = init;
3949 #  include "intrpvar.h"
3950 #  undef PERLVAR
3951 #  undef PERLVARA
3952 #  undef PERLVARI
3953 #  undef PERLVARIC
3954 #endif
3955
3956 }
3957
3958 STATIC void
3959 S_init_main_stash(pTHX)
3960 {
3961     GV *gv;
3962     HV *hv = newHV();
3963
3964     PL_curstash = PL_defstash = (HV *)SvREFCNT_inc_simple_NN(hv);
3965     /* We know that the string "main" will be in the global shared string
3966        table, so it's a small saving to use it rather than allocate another
3967        8 bytes.  */
3968     PL_curstname = newSVpvs_share("main");
3969     gv = gv_fetchpvs("main::", GV_ADD|GV_NOTQUAL, SVt_PVHV);
3970     /* If we hadn't caused another reference to "main" to be in the shared
3971        string table above, then it would be worth reordering these two,
3972        because otherwise all we do is delete "main" from it as a consequence
3973        of the SvREFCNT_dec, only to add it again with hv_name_set */
3974     SvREFCNT_dec(GvHV(gv));
3975     hv_name_sets(PL_defstash, "main", 0);
3976     GvHV(gv) = MUTABLE_HV(SvREFCNT_inc_simple(PL_defstash));
3977     SvREADONLY_on(gv);
3978     PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpvs("INC", GV_ADD|GV_NOTQUAL,
3979                                              SVt_PVAV)));
3980     SvREFCNT_inc_simple_void(PL_incgv); /* Don't allow it to be freed */
3981     GvMULTI_on(PL_incgv);
3982     PL_hintgv = gv_fetchpvs("\010", GV_ADD|GV_NOTQUAL, SVt_PV); /* ^H */
3983     SvREFCNT_inc_simple_void(PL_hintgv);
3984     GvMULTI_on(PL_hintgv);
3985     PL_defgv = gv_fetchpvs("_", GV_ADD|GV_NOTQUAL, SVt_PVAV);
3986     SvREFCNT_inc_simple_void(PL_defgv);
3987     PL_errgv = gv_fetchpvs("@", GV_ADD|GV_NOTQUAL, SVt_PV);
3988     SvREFCNT_inc_simple_void(PL_errgv);
3989     GvMULTI_on(PL_errgv);
3990     PL_replgv = gv_fetchpvs("\022", GV_ADD|GV_NOTQUAL, SVt_PV); /* ^R */
3991     SvREFCNT_inc_simple_void(PL_replgv);
3992     GvMULTI_on(PL_replgv);
3993     (void)Perl_form(aTHX_ "%240s","");  /* Preallocate temp - for immediate signals. */
3994 #ifdef PERL_DONT_CREATE_GVSV
3995     (void)gv_SVadd(PL_errgv);
3996 #endif
3997     sv_grow(ERRSV, 240);        /* Preallocate - for immediate signals. */
3998     CLEAR_ERRSV();
3999     CopSTASH_set(&PL_compiling, PL_defstash);
4000     PL_debstash = GvHV(gv_fetchpvs("DB::", GV_ADDMULTI, SVt_PVHV));
4001     PL_globalstash = GvHV(gv_fetchpvs("CORE::GLOBAL::", GV_ADDMULTI,
4002                                       SVt_PVHV));
4003     /* We must init $/ before switches are processed. */
4004     sv_setpvs(get_sv("/", GV_ADD), "\n");
4005 }
4006
4007 STATIC PerlIO *
4008 S_open_script(pTHX_ const char *scriptname, bool dosearch, bool *suidscript)
4009 {
4010     int fdscript = -1;
4011     PerlIO *rsfp = NULL;
4012     Stat_t tmpstatbuf;
4013     int fd;
4014
4015     PERL_ARGS_ASSERT_OPEN_SCRIPT;
4016
4017     if (PL_e_script) {
4018         PL_origfilename = savepvs("-e");
4019     }
4020     else {
4021         const char *s;
4022         UV uv;
4023         /* if find_script() returns, it returns a malloc()-ed value */
4024         scriptname = PL_origfilename = find_script(scriptname, dosearch, NULL, 1);
4025         s = scriptname + strlen(scriptname);
4026
4027         if (strBEGINs(scriptname, "/dev/fd/")
4028             && isDIGIT(scriptname[8])
4029             && grok_atoUV(scriptname + 8, &uv, &s)
4030             && uv <= PERL_INT_MAX
4031         ) {
4032             fdscript = (int)uv;
4033             if (*s) {
4034                 /* PSz 18 Feb 04
4035                  * Tell apart "normal" usage of fdscript, e.g.
4036                  * with bash on FreeBSD:
4037                  *   perl <( echo '#!perl -DA'; echo 'print "$0\n"')
4038                  * from usage in suidperl.
4039                  * Does any "normal" usage leave garbage after the number???
4040                  * Is it a mistake to use a similar /dev/fd/ construct for
4041                  * suidperl?
4042                  */
4043                 *suidscript = TRUE;
4044                 /* PSz 20 Feb 04  
4045                  * Be supersafe and do some sanity-checks.
4046                  * Still, can we be sure we got the right thing?
4047                  */
4048                 if (*s != '/') {
4049                     Perl_croak(aTHX_ "Wrong syntax (suid) fd script name \"%s\"\n", s);
4050                 }
4051                 if (! *(s+1)) {
4052                     Perl_croak(aTHX_ "Missing (suid) fd script name\n");
4053                 }
4054                 scriptname = savepv(s + 1);
4055                 Safefree(PL_origfilename);
4056                 PL_origfilename = (char *)scriptname;
4057             }
4058         }
4059     }
4060
4061     CopFILE_free(PL_curcop);
4062     CopFILE_set(PL_curcop, PL_origfilename);
4063     if (*PL_origfilename == '-' && PL_origfilename[1] == '\0')
4064         scriptname = (char *)"";
4065     if (fdscript >= 0) {
4066         rsfp = PerlIO_fdopen(fdscript,PERL_SCRIPT_MODE);
4067     }
4068     else if (!*scriptname) {
4069         forbid_setid(0, *suidscript);
4070         return NULL;
4071     }
4072     else {
4073 #ifdef FAKE_BIT_BUCKET
4074         /* This hack allows one not to have /dev/null (or BIT_BUCKET as it
4075          * is called) and still have the "-e" work.  (Believe it or not,
4076          * a /dev/null is required for the "-e" to work because source
4077          * filter magic is used to implement it. ) This is *not* a general
4078          * replacement for a /dev/null.  What we do here is create a temp
4079          * file (an empty file), open up that as the script, and then
4080          * immediately close and unlink it.  Close enough for jazz. */ 
4081 #define FAKE_BIT_BUCKET_PREFIX "/tmp/perlnull-"
4082 #define FAKE_BIT_BUCKET_SUFFIX "XXXXXXXX"
4083 #define FAKE_BIT_BUCKET_TEMPLATE FAKE_BIT_BUCKET_PREFIX FAKE_BIT_BUCKET_SUFFIX
4084         char tmpname[sizeof(FAKE_BIT_BUCKET_TEMPLATE)] = {
4085             FAKE_BIT_BUCKET_TEMPLATE
4086         };
4087         const char * const err = "Failed to create a fake bit bucket";
4088         if (strEQ(scriptname, BIT_BUCKET)) {
4089             int tmpfd = Perl_my_mkstemp_cloexec(tmpname);
4090             if (tmpfd > -1) {
4091                 scriptname = tmpname;
4092                 close(tmpfd);
4093             } else
4094                 Perl_croak(aTHX_ err);
4095         }
4096 #endif
4097         rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
4098 #ifdef FAKE_BIT_BUCKET
4099         if (   strBEGINs(scriptname, FAKE_BIT_BUCKET_PREFIX)
4100             && strlen(scriptname) == sizeof(tmpname) - 1)
4101         {
4102             unlink(scriptname);
4103         }
4104         scriptname = BIT_BUCKET;
4105 #endif
4106     }
4107     if (!rsfp) {
4108         /* PSz 16 Sep 03  Keep neat error message */
4109         if (PL_e_script)
4110             Perl_croak(aTHX_ "Can't open " BIT_BUCKET ": %s\n", Strerror(errno));
4111         else
4112             Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
4113                     CopFILE(PL_curcop), Strerror(errno));
4114     }
4115     fd = PerlIO_fileno(rsfp);
4116
4117     if (fd < 0 ||
4118         (PerlLIO_fstat(fd, &tmpstatbuf) >= 0
4119          && S_ISDIR(tmpstatbuf.st_mode)))
4120         Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
4121             CopFILE(PL_curcop),
4122             Strerror(EISDIR));
4123
4124     return rsfp;
4125 }
4126
4127 /* In the days of suidperl, we refused to execute a setuid script stored on
4128  * a filesystem mounted nosuid and/or noexec. This meant that we probed for the
4129  * existence of the appropriate filesystem-statting function, and behaved
4130  * accordingly. But even though suidperl is long gone, we must still include
4131  * those probes for the benefit of modules like Filesys::Df, which expect the
4132  * results of those probes to be stored in %Config; see RT#126368. So mention
4133  * the relevant cpp symbols here, to ensure that metaconfig will include their
4134  * probes in the generated Configure:
4135  *
4136  * I_SYSSTATVFS HAS_FSTATVFS
4137  * I_SYSMOUNT
4138  * I_STATFS     HAS_FSTATFS     HAS_GETFSSTAT
4139  * I_MNTENT     HAS_GETMNTENT   HAS_HASMNTOPT
4140  */
4141
4142
4143 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
4144 /* Don't even need this function.  */
4145 #else
4146 STATIC void
4147 S_validate_suid(pTHX_ PerlIO *rsfp)
4148 {
4149     const Uid_t  my_uid = PerlProc_getuid();
4150     const Uid_t my_euid = PerlProc_geteuid();
4151     const Gid_t  my_gid = PerlProc_getgid();
4152     const Gid_t my_egid = PerlProc_getegid();
4153
4154     PERL_ARGS_ASSERT_VALIDATE_SUID;
4155
4156     if (my_euid != my_uid || my_egid != my_gid) {       /* (suidperl doesn't exist, in fact) */
4157         dVAR;
4158         int fd = PerlIO_fileno(rsfp);
4159         Stat_t statbuf;
4160         if (fd < 0 || PerlLIO_fstat(fd, &statbuf) < 0) { /* may be either wrapped or real suid */
4161             Perl_croak_nocontext( "Illegal suidscript");
4162         }
4163         if ((my_euid != my_uid && my_euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
4164             ||
4165             (my_egid != my_gid && my_egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
4166             )
4167             if (!PL_do_undump)
4168                 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
4169 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
4170         /* not set-id, must be wrapped */
4171     }
4172 }
4173 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
4174
4175 STATIC void
4176 S_find_beginning(pTHX_ SV* linestr_sv, PerlIO *rsfp)
4177 {
4178     const char *s;
4179     const char *s2;
4180
4181     PERL_ARGS_ASSERT_FIND_BEGINNING;
4182
4183     /* skip forward in input to the real script? */
4184
4185     do {
4186         if ((s = sv_gets(linestr_sv, rsfp, 0)) == NULL)
4187             Perl_croak(aTHX_ "No Perl script found in input\n");
4188         s2 = s;
4189     } while (!(*s == '#' && s[1] == '!' && ((s = instr(s,"perl")) || (s = instr(s2,"PERL")))));
4190     PerlIO_ungetc(rsfp, '\n');          /* to keep line count right */
4191     while (*s && !(isSPACE (*s) || *s == '#')) s++;
4192     s2 = s;
4193     while (*s == ' ' || *s == '\t') s++;
4194     if (*s++ == '-') {
4195         while (isDIGIT(s2[-1]) || s2[-1] == '-' || s2[-1] == '.'
4196                || s2[-1] == '_') s2--;
4197         if (strBEGINs(s2-4,"perl"))
4198             while ((s = moreswitches(s)))
4199                 ;
4200     }
4201 }
4202
4203
4204 STATIC void
4205 S_init_ids(pTHX)
4206 {
4207     /* no need to do anything here any more if we don't
4208      * do tainting. */
4209 #ifndef NO_TAINT_SUPPORT
4210     const Uid_t my_uid = PerlProc_getuid();
4211     const Uid_t my_euid = PerlProc_geteuid();
4212     const Gid_t my_gid = PerlProc_getgid();
4213     const Gid_t my_egid = PerlProc_getegid();
4214
4215     PERL_UNUSED_CONTEXT;
4216
4217     /* Should not happen: */
4218     CHECK_MALLOC_TAINT(my_uid && (my_euid != my_uid || my_egid != my_gid));
4219     TAINTING_set( TAINTING_get | (my_uid && (my_euid != my_uid || my_egid != my_gid)) );
4220 #endif
4221     /* BUG */
4222     /* PSz 27 Feb 04
4223      * Should go by suidscript, not uid!=euid: why disallow
4224      * system("ls") in scripts run from setuid things?
4225      * Or, is this run before we check arguments and set suidscript?
4226      * What about SETUID_SCRIPTS_ARE_SECURE_NOW: could we use fdscript then?
4227      * (We never have suidscript, can we be sure to have fdscript?)
4228      * Or must then go by UID checks? See comments in forbid_setid also.
4229      */
4230 }
4231
4232 /* This is used very early in the lifetime of the program,
4233  * before even the options are parsed, so PL_tainting has
4234  * not been initialized properly.  */
4235 bool
4236 Perl_doing_taint(int argc, char *argv[], char *envp[])
4237 {
4238 #ifndef PERL_IMPLICIT_SYS
4239     /* If we have PERL_IMPLICIT_SYS we can't call getuid() et alia
4240      * before we have an interpreter-- and the whole point of this
4241      * function is to be called at such an early stage.  If you are on
4242      * a system with PERL_IMPLICIT_SYS but you do have a concept of
4243      * "tainted because running with altered effective ids', you'll
4244      * have to add your own checks somewhere in here.  The two most
4245      * known samples of 'implicitness' are Win32 and NetWare, neither
4246      * of which has much of concept of 'uids'. */
4247     Uid_t uid  = PerlProc_getuid();
4248     Uid_t euid = PerlProc_geteuid();
4249     Gid_t gid  = PerlProc_getgid();
4250     Gid_t egid = PerlProc_getegid();
4251     (void)envp;
4252
4253 #ifdef VMS
4254     uid  |=  gid << 16;
4255     euid |= egid << 16;
4256 #endif
4257     if (uid && (euid != uid || egid != gid))
4258         return 1;
4259 #endif /* !PERL_IMPLICIT_SYS */
4260     /* This is a really primitive check; environment gets ignored only
4261      * if -T are the first chars together; otherwise one gets
4262      *  "Too late" message. */
4263     if ( argc > 1 && argv[1][0] == '-'
4264          && isALPHA_FOLD_EQ(argv[1][1], 't'))
4265         return 1;
4266     return 0;
4267 }
4268
4269 /* Passing the flag as a single char rather than a string is a slight space
4270    optimisation.  The only message that isn't /^-.$/ is
4271    "program input from stdin", which is substituted in place of '\0', which
4272    could never be a command line flag.  */
4273 STATIC void
4274 S_forbid_setid(pTHX_ const char flag, const bool suidscript) /* g */
4275 {
4276     char string[3] = "-x";
4277     const char *message = "program input from stdin";
4278
4279     PERL_UNUSED_CONTEXT;
4280     if (flag) {
4281         string[1] = flag;
4282         message = string;
4283     }
4284
4285 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
4286     if (PerlProc_getuid() != PerlProc_geteuid())
4287         Perl_croak(aTHX_ "No %s allowed while running setuid", message);
4288     if (PerlProc_getgid() != PerlProc_getegid())
4289         Perl_croak(aTHX_ "No %s allowed while running setgid", message);
4290 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
4291     if (suidscript)
4292         Perl_croak(aTHX_ "No %s allowed with (suid) fdscript", message);
4293 }
4294
4295 void
4296 Perl_init_dbargs(pTHX)
4297 {
4298     AV *const args = PL_dbargs = GvAV(gv_AVadd((gv_fetchpvs("DB::args",
4299                                                             GV_ADDMULTI,
4300                                                             SVt_PVAV))));
4301
4302     if (AvREAL(args)) {
4303         /* Someone has already created it.
4304            It might have entries, and if we just turn off AvREAL(), they will
4305            "leak" until global destruction.  */
4306         av_clear(args);
4307         if (SvTIED_mg((const SV *)args, PERL_MAGIC_tied))
4308             Perl_croak(aTHX_ "Cannot set tied @DB::args");
4309     }
4310     AvREIFY_only(PL_dbargs);
4311 }
4312
4313 void
4314 Perl_init_debugger(pTHX)
4315 {
4316     HV * const ostash = PL_curstash;
4317     MAGIC *mg;
4318
4319     PL_curstash = (HV *)SvREFCNT_inc_simple(PL_debstash);
4320
4321     Perl_init_dbargs(aTHX);
4322     PL_DBgv = MUTABLE_GV(
4323         SvREFCNT_inc(gv_fetchpvs("DB::DB", GV_ADDMULTI, SVt_PVGV))
4324     );
4325     PL_DBline = MUTABLE_GV(
4326         SvREFCNT_inc(gv_fetchpvs("DB::dbline", GV_ADDMULTI, SVt_PVAV))
4327     );
4328     PL_DBsub = MUTABLE_GV(SvREFCNT_inc(
4329         gv_HVadd(gv_fetchpvs("DB::sub", GV_ADDMULTI, SVt_PVHV))
4330     ));
4331     PL_DBsingle = GvSV((gv_fetchpvs("DB::single", GV_ADDMULTI, SVt_PV)));
4332     if (!SvIOK(PL_DBsingle))
4333         sv_setiv(PL_DBsingle, 0);
4334     mg = sv_magicext(PL_DBsingle, NULL, PERL_MAGIC_debugvar, &PL_vtbl_debugvar, 0, 0);
4335     mg->mg_private = DBVARMG_SINGLE;
4336     SvSETMAGIC(PL_DBsingle);
4337
4338     PL_DBtrace = GvSV((gv_fetchpvs("DB::trace", GV_ADDMULTI, SVt_PV)));
4339     if (!SvIOK(PL_DBtrace))
4340         sv_setiv(PL_DBtrace, 0);
4341     mg = sv_magicext(PL_DBtrace, NULL, PERL_MAGIC_debugvar, &PL_vtbl_debugvar, 0, 0);
4342     mg->mg_private = DBVARMG_TRACE;
4343     SvSETMAGIC(PL_DBtrace);
4344
4345     PL_DBsignal = GvSV((gv_fetchpvs("DB::signal", GV_ADDMULTI, SVt_PV)));
4346     if (!SvIOK(PL_DBsignal))
4347         sv_setiv(PL_DBsignal, 0);
4348     mg = sv_magicext(PL_DBsignal, NULL, PERL_MAGIC_debugvar, &PL_vtbl_debugvar, 0, 0);
4349     mg->mg_private = DBVARMG_SIGNAL;
4350     SvSETMAGIC(PL_DBsignal);
4351
4352     SvREFCNT_dec(PL_curstash);
4353     PL_curstash = ostash;
4354 }
4355
4356 #ifndef STRESS_REALLOC
4357 #define REASONABLE(size) (size)
4358 #define REASONABLE_but_at_least(size,min) (size)
4359 #else
4360 #define REASONABLE(size) (1) /* unreasonable */
4361 #define REASONABLE_but_at_least(size,min) (min)
4362 #endif
4363
4364 void
4365 Perl_init_stacks(pTHX)
4366 {
4367     SSize_t size;
4368
4369     /* start with 128-item stack and 8K cxstack */
4370     PL_curstackinfo = new_stackinfo(REASONABLE(128),
4371                                  REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
4372     PL_curstackinfo->si_type = PERLSI_MAIN;
4373 #if defined DEBUGGING && !defined DEBUGGING_RE_ONLY
4374     PL_curstackinfo->si_stack_hwm = 0;
4375 #endif
4376     PL_curstack = PL_curstackinfo->si_stack;
4377     PL_mainstack = PL_curstack;         /* remember in case we switch stacks */
4378
4379     PL_stack_base = AvARRAY(PL_curstack);
4380     PL_stack_sp = PL_stack_base;
4381     PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
4382
4383     Newx(PL_tmps_stack,REASONABLE(128),SV*);
4384     PL_tmps_floor = -1;
4385     PL_tmps_ix = -1;
4386     PL_tmps_max = REASONABLE(128);
4387
4388     Newx(PL_markstack,REASONABLE(32),I32);
4389     PL_markstack_ptr = PL_markstack;
4390     PL_markstack_max = PL_markstack + REASONABLE(32);
4391
4392     SET_MARK_OFFSET;
4393
4394     Newx(PL_scopestack,REASONABLE(32),I32);
4395 #ifdef DEBUGGING
4396     Newx(PL_scopestack_name,REASONABLE(32),const char*);
4397 #endif
4398     PL_scopestack_ix = 0;
4399     PL_scopestack_max = REASONABLE(32);
4400
4401     size = REASONABLE_but_at_least(128,SS_MAXPUSH);
4402     Newx(PL_savestack, size, ANY);
4403     PL_savestack_ix = 0;
4404     /*PL_savestack_max lies: it always has SS_MAXPUSH more than it claims */
4405     PL_savestack_max = size - SS_MAXPUSH;
4406 }
4407
4408 #undef REASONABLE
4409
4410 STATIC void
4411 S_nuke_stacks(pTHX)
4412 {
4413     while (PL_curstackinfo->si_next)
4414         PL_curstackinfo = PL_curstackinfo->si_next;
4415     while (PL_curstackinfo) {
4416         PERL_SI *p = PL_curstackinfo->si_prev;
4417         /* curstackinfo->si_stack got nuked by sv_free_arenas() */
4418         Safefree(PL_curstackinfo->si_cxstack);
4419         Safefree(PL_curstackinfo);
4420         PL_curstackinfo = p;
4421     }
4422     Safefree(PL_tmps_stack);
4423     Safefree(PL_markstack);
4424     Safefree(PL_scopestack);
4425 #ifdef DEBUGGING
4426     Safefree(PL_scopestack_name);
4427 #endif
4428     Safefree(PL_savestack);
4429 }
4430
4431 void
4432 Perl_populate_isa(pTHX_ const char *name, STRLEN len, ...)
4433 {
4434     GV *const gv = gv_fetchpvn(name, len, GV_ADD | GV_ADDMULTI, SVt_PVAV);
4435     AV *const isa = GvAVn(gv);
4436     va_list args;
4437
4438     PERL_ARGS_ASSERT_POPULATE_ISA;
4439
4440     if(AvFILLp(isa) != -1)
4441         return;
4442
4443     /* NOTE: No support for tied ISA */
4444
4445     va_start(args, len);
4446     do {
4447         const char *const parent = va_arg(args, const char*);
4448         size_t parent_len;
4449
4450         if (!parent)
4451             break;
4452         parent_len = va_arg(args, size_t);
4453
4454         /* Arguments are supplied with a trailing ::  */
4455         assert(parent_len > 2);
4456         assert(parent[parent_len - 1] == ':');
4457         assert(parent[parent_len - 2] == ':');
4458         av_push(isa, newSVpvn(parent, parent_len - 2));
4459         (void) gv_fetchpvn(parent, parent_len, GV_ADD, SVt_PVGV);
4460     } while (1);
4461     va_end(args);
4462 }
4463
4464
4465 STATIC void
4466 S_init_predump_symbols(pTHX)
4467 {
4468     GV *tmpgv;
4469     IO *io;
4470
4471     sv_setpvs(get_sv("\"", GV_ADD), " ");
4472     PL_ofsgv = (GV*)SvREFCNT_inc(gv_fetchpvs(",", GV_ADD|GV_NOTQUAL, SVt_PV));
4473
4474
4475     /* Historically, PVIOs were blessed into IO::Handle, unless
4476        FileHandle was loaded, in which case they were blessed into
4477        that. Action at a distance.
4478        However, if we simply bless into IO::Handle, we break code
4479        that assumes that PVIOs will have (among others) a seek
4480        method. IO::File inherits from IO::Handle and IO::Seekable,
4481        and provides the needed methods. But if we simply bless into
4482        it, then we break code that assumed that by loading
4483        IO::Handle, *it* would work.
4484        So a compromise is to set up the correct @IO::File::ISA,
4485        so that code that does C<use IO::Handle>; will still work.
4486     */
4487                    
4488     Perl_populate_isa(aTHX_ STR_WITH_LEN("IO::File::ISA"),
4489                       STR_WITH_LEN("IO::Handle::"),
4490                       STR_WITH_LEN("IO::Seekable::"),
4491                       STR_WITH_LEN("Exporter::"),
4492                       NULL);
4493
4494     PL_stdingv = gv_fetchpvs("STDIN", GV_ADD|GV_NOTQUAL, SVt_PVIO);
4495     GvMULTI_on(PL_stdingv);
4496     io = GvIOp(PL_stdingv);
4497     IoTYPE(io) = IoTYPE_RDONLY;
4498     IoIFP(io) = PerlIO_stdin();
4499     tmpgv = gv_fetchpvs("stdin", GV_ADD|GV_NOTQUAL, SVt_PV);
4500     GvMULTI_on(tmpgv);
4501     GvIOp(tmpgv) = MUTABLE_IO(SvREFCNT_inc_simple(io));
4502
4503     tmpgv = gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVIO);
4504     GvMULTI_on(tmpgv);
4505     io = GvIOp(tmpgv);
4506     IoTYPE(io) = IoTYPE_WRONLY;
4507     IoOFP(io) = IoIFP(io) = PerlIO_stdout();
4508     setdefout(tmpgv);
4509     tmpgv = gv_fetchpvs("stdout", GV_ADD|GV_NOTQUAL, SVt_PV);
4510     GvMULTI_on(tmpgv);
4511     GvIOp(tmpgv) = MUTABLE_IO(SvREFCNT_inc_simple(io));
4512
4513     PL_stderrgv = gv_fetchpvs("STDERR", GV_ADD|GV_NOTQUAL, SVt_PVIO);
4514     GvMULTI_on(PL_stderrgv);
4515     io = GvIOp(PL_stderrgv);
4516     IoTYPE(io) = IoTYPE_WRONLY;
4517     IoOFP(io) = IoIFP(io) = PerlIO_stderr();
4518     tmpgv = gv_fetchpvs("stderr", GV_ADD|GV_NOTQUAL, SVt_PV);
4519     GvMULTI_on(tmpgv);
4520     GvIOp(tmpgv) = MUTABLE_IO(SvREFCNT_inc_simple(io));
4521
4522     PL_statname = newSVpvs("");         /* last filename we did stat on */
4523 }
4524
4525 void
4526 Perl_init_argv_symbols(pTHX_ int argc, char **argv)
4527 {
4528     PERL_ARGS_ASSERT_INIT_ARGV_SYMBOLS;
4529
4530     argc--,argv++;      /* skip name of script */
4531     if (PL_doswitches) {
4532         for (; argc > 0 && **argv == '-'; argc--,argv++) {
4533             char *s;
4534             if (!argv[0][1])
4535                 break;
4536             if (argv[0][1] == '-' && !argv[0][2]) {
4537                 argc--,argv++;
4538                 break;
4539             }
4540             if ((s = strchr(argv[0], '='))) {
4541                 const char *const start_name = argv[0] + 1;
4542                 sv_setpv(GvSV(gv_fetchpvn_flags(start_name, s - start_name,
4543                                                 TRUE, SVt_PV)), s + 1);
4544             }
4545             else
4546                 sv_setiv(GvSV(gv_fetchpv(argv[0]+1, GV_ADD, SVt_PV)),1);
4547         }
4548     }
4549     if ((PL_argvgv = gv_fetchpvs("ARGV", GV_ADD|GV_NOTQUAL, SVt_PVAV))) {
4550         SvREFCNT_inc_simple_void_NN(PL_argvgv);
4551         GvMULTI_on(PL_argvgv);
4552         av_clear(GvAVn(PL_argvgv));
4553         for (; argc > 0; argc--,argv++) {
4554             SV * const sv = newSVpv(argv[0],0);
4555             av_push(GvAV(PL_argvgv),sv);
4556             if (!(PL_unicode & PERL_UNICODE_LOCALE_FLAG) || PL_utf8locale) {
4557                  if (PL_unicode & PERL_UNICODE_ARGV_FLAG)
4558                       SvUTF8_on(sv);
4559             }
4560             if (PL_unicode & PERL_UNICODE_WIDESYSCALLS_FLAG) /* Sarathy? */
4561                  (void)sv_utf8_decode(sv);
4562         }
4563     }
4564
4565     if (PL_inplace && (!PL_argvgv || AvFILL(GvAV(PL_argvgv)) == -1))
4566         Perl_ck_warner_d(aTHX_ packWARN(WARN_INPLACE),
4567                          "-i used with no filenames on the command line, "
4568                          "reading from STDIN");
4569 }
4570
4571 STATIC void
4572 S_init_postdump_symbols(pTHX_ int argc, char **argv, char **env)
4573 {
4574 #ifdef USE_ITHREADS
4575     dVAR;
4576 #endif
4577     GV* tmpgv;
4578
4579     PERL_ARGS_ASSERT_INIT_POSTDUMP_SYMBOLS;
4580
4581     PL_toptarget = newSV_type(SVt_PVIV);
4582     SvPVCLEAR(PL_toptarget);
4583     PL_bodytarget = newSV_type(SVt_PVIV);
4584     SvPVCLEAR(PL_bodytarget);
4585     PL_formtarget = PL_bodytarget;
4586
4587     TAINT;
4588
4589     init_argv_symbols(argc,argv);
4590
4591     if ((tmpgv = gv_fetchpvs("0", GV_ADD|GV_NOTQUAL, SVt_PV))) {
4592         sv_setpv(GvSV(tmpgv),PL_origfilename);
4593     }
4594     if ((PL_envgv = gv_fetchpvs("ENV", GV_ADD|GV_NOTQUAL, SVt_PVHV))) {
4595         HV *hv;
4596         bool env_is_not_environ;
4597         SvREFCNT_inc_simple_void_NN(PL_envgv);
4598         GvMULTI_on(PL_envgv);
4599         hv = GvHVn(PL_envgv);
4600         hv_magic(hv, NULL, PERL_MAGIC_env);
4601 #ifndef PERL_MICRO
4602 #ifdef USE_ENVIRON_ARRAY
4603         /* Note that if the supplied env parameter is actually a copy
4604            of the global environ then it may now point to free'd memory
4605            if the environment has been modified since. To avoid this
4606            problem we treat env==NULL as meaning 'use the default'
4607         */
4608         if (!env)
4609             env = environ;
4610         env_is_not_environ = env != environ;
4611         if (env_is_not_environ
4612 #  ifdef USE_ITHREADS
4613             && PL_curinterp == aTHX
4614 #  endif
4615            )
4616         {
4617             environ[0] = NULL;
4618         }
4619         if (env) {
4620           char *s, *old_var;
4621           STRLEN nlen;
4622           SV *sv;
4623           HV *dups = newHV();
4624
4625           for (; *env; env++) {
4626             old_var = *env;
4627
4628             if (!(s = strchr(old_var,'=')) || s == old_var)
4629                 continue;
4630             nlen = s - old_var;
4631
4632 #if defined(MSDOS) && !defined(DJGPP)
4633             *s = '\0';
4634             (void)strupr(old_var);
4635             *s = '=';
4636 #endif
4637             if (hv_exists(hv, old_var, nlen)) {
4638                 const char *name = savepvn(old_var, nlen);
4639
4640                 /* make sure we use the same value as getenv(), otherwise code that
4641                    uses getenv() (like setlocale()) might see a different value to %ENV
4642                  */
4643                 sv = newSVpv(PerlEnv_getenv(name), 0);
4644
4645                 /* keep a count of the dups of this name so we can de-dup environ later */
4646                 if (hv_exists(dups, name, nlen))
4647                     ++SvIVX(*hv_fetch(dups, name, nlen, 0));
4648                 else
4649                     (void)hv_store(dups, name, nlen, newSViv(1), 0);
4650
4651                 Safefree(name);
4652             }
4653             else {
4654                 sv = newSVpv(s+1, 0);
4655             }
4656             (void)hv_store(hv, old_var, nlen, sv, 0);
4657             if (env_is_not_environ)
4658                 mg_set(sv);
4659           }
4660           if (HvKEYS(dups)) {
4661               /* environ has some duplicate definitions, remove them */
4662               HE *entry;
4663               hv_iterinit(dups);
4664               while ((entry = hv_iternext_flags(dups, 0))) {
4665                   STRLEN nlen;
4666                   const char *name = HePV(entry, nlen);
4667                   IV count = SvIV(HeVAL(entry));
4668                   IV i;
4669                   SV **valp = hv_fetch(hv, name, nlen, 0);
4670
4671                   assert(valp);
4672
4673                   /* try to remove any duplicate names, depending on the
4674                    * implementation used in my_setenv() the iteration might
4675                    * not be necessary, but let's be safe.
4676                    */
4677                   for (i = 0; i < count; ++i)
4678                       my_setenv(name, 0);
4679
4680                   /* and set it back to the value we set $ENV{name} to */
4681                   my_setenv(name, SvPV_nolen(*valp));
4682               }
4683           }
4684           SvREFCNT_dec_NN(dups);
4685       }
4686 #endif /* USE_ENVIRON_ARRAY */
4687 #endif /* !PERL_MICRO */
4688     }
4689     TAINT_NOT;
4690
4691     /* touch @F array to prevent spurious warnings 20020415 MJD */
4692     if (PL_minus_a) {
4693       (void) get_av("main::F", GV_ADD | GV_ADDMULTI);
4694     }
4695 }
4696
4697 STATIC void
4698 S_init_perllib(pTHX)
4699 {
4700 #ifndef VMS
4701     const char *perl5lib = NULL;
4702 #endif
4703     const char *s;
4704 #if defined(WIN32) && !defined(PERL_IS_MINIPERL)
4705     STRLEN len;
4706 #endif
4707
4708     if (!TAINTING_get) {
4709 #ifndef VMS
4710         perl5lib = PerlEnv_getenv("PERL5LIB");
4711 /*
4712  * It isn't possible to delete an environment variable with
4713  * PERL_USE_SAFE_PUTENV set unless unsetenv() is also available, so in that
4714  * case we treat PERL5LIB as undefined if it has a zero-length value.
4715  */
4716 #if defined(PERL_USE_SAFE_PUTENV) && ! defined(HAS_UNSETENV)
4717         if (perl5lib && *perl5lib != '\0')
4718 #else
4719         if (perl5lib)
4720 #endif
4721             incpush_use_sep(perl5lib, 0, INCPUSH_ADD_SUB_DIRS);
4722         else {
4723             s = PerlEnv_getenv("PERLLIB");
4724             if (s)
4725                 incpush_use_sep(s, 0, 0);
4726         }
4727 #else /* VMS */
4728         /* Treat PERL5?LIB as a possible search list logical name -- the
4729          * "natural" VMS idiom for a Unix path string.  We allow each
4730          * element to be a set of |-separated directories for compatibility.
4731          */
4732         char buf[256];
4733         int idx = 0;
4734         if (vmstrnenv("PERL5LIB",buf,0,NULL,0))
4735             do {
4736                 incpush_use_sep(buf, 0, INCPUSH_ADD_SUB_DIRS);
4737             } while (vmstrnenv("PERL5LIB",buf,++idx,NULL,0));
4738         else {
4739             while (vmstrnenv("PERLLIB",buf,idx++,NULL,0))
4740                 incpush_use_sep(buf, 0, 0);
4741         }
4742 #endif /* VMS */
4743     }
4744
4745 #ifndef PERL_IS_MINIPERL
4746     /* miniperl gets just -I..., the split of $ENV{PERL5LIB}, and "." in @INC
4747        (and not the architecture specific directories from $ENV{PERL5LIB}) */
4748
4749 #include "perl_inc_macro.h"
4750 /* Use the ~-expanded versions of APPLLIB (undocumented),
4751     SITEARCH, SITELIB, VENDORARCH, VENDORLIB, ARCHLIB and PRIVLIB
4752 */
4753     INCPUSH_APPLLIB_EXP
4754     INCPUSH_SITEARCH_EXP
4755     INCPUSH_SITELIB_EXP
4756     INCPUSH_PERL_VENDORARCH_EXP
4757     INCPUSH_PERL_VENDORLIB_EXP
4758     INCPUSH_ARCHLIB_EXP
4759     INCPUSH_PRIVLIB_EXP
4760     INCPUSH_PERL_OTHERLIBDIRS
4761     INCPUSH_PERL5LIB
4762     INCPUSH_APPLLIB_OLD_EXP
4763     INCPUSH_SITELIB_STEM
4764     INCPUSH_PERL_VENDORLIB_STEM
4765     INCPUSH_PERL_OTHERLIBDIRS_ARCHONLY
4766
4767 #endif /* !PERL_IS_MINIPERL */
4768
4769     if (!TAINTING_get) {
4770 #if !defined(PERL_IS_MINIPERL) && defined(DEFAULT_INC_EXCLUDES_DOT)
4771         const char * const unsafe = PerlEnv_getenv("PERL_USE_UNSAFE_INC");
4772         if (unsafe && strEQ(unsafe, "1"))
4773 #endif
4774           S_incpush(aTHX_ STR_WITH_LEN("."), 0);
4775     }
4776 }
4777
4778 #if defined(DOSISH) || defined(__SYMBIAN32__)
4779 #    define PERLLIB_SEP ';'
4780 #elif defined(__VMS)
4781 #    define PERLLIB_SEP PL_perllib_sep
4782 #else
4783 #    define PERLLIB_SEP ':'
4784 #endif
4785 #ifndef PERLLIB_MANGLE
4786 #  define PERLLIB_MANGLE(s,n) (s)
4787 #endif
4788
4789 #ifndef PERL_IS_MINIPERL
4790 /* Push a directory onto @INC if it exists.
4791    Generate a new SV if we do this, to save needing to copy the SV we push
4792    onto @INC  */
4793 STATIC SV *
4794 S_incpush_if_exists(pTHX_ AV *const av, SV *dir, SV *const stem)
4795 {
4796     Stat_t tmpstatbuf;
4797
4798     PERL_ARGS_ASSERT_INCPUSH_IF_EXISTS;
4799
4800     if (PerlLIO_stat(SvPVX_const(dir), &tmpstatbuf) >= 0 &&
4801         S_ISDIR(tmpstatbuf.st_mode)) {
4802         av_push(av, dir);
4803         dir = newSVsv(stem);
4804     } else {
4805         /* Truncate dir back to stem.  */
4806         SvCUR_set(dir, SvCUR(stem));
4807     }
4808     return dir;
4809 }
4810 #endif
4811
4812 STATIC SV *
4813 S_mayberelocate(pTHX_ const char *const dir, STRLEN len, U32 flags)
4814 {
4815     const U8 canrelocate = (U8)flags & INCPUSH_CAN_RELOCATE;
4816     SV *libdir;
4817
4818     PERL_ARGS_ASSERT_MAYBERELOCATE;
4819     assert(len > 0);
4820
4821     /* I am not convinced that this is valid when PERLLIB_MANGLE is
4822        defined to so something (in os2/os2.c), but the code has been
4823        this way, ignoring any possible changed of length, since
4824        760ac839baf413929cd31cc32ffd6dba6b781a81 (5.003_02) so I'll leave
4825        it be.  */
4826     libdir = newSVpvn(PERLLIB_MANGLE(dir, len), len);
4827
4828 #ifdef VMS
4829     {
4830         char *unix;
4831
4832         if ((unix = tounixspec_ts(SvPV(libdir,len),NULL)) != NULL) {
4833             len = strlen(unix);
4834             while (len > 1 && unix[len-1] == '/') len--;  /* Cosmetic */
4835             sv_usepvn(libdir,unix,len);
4836         }
4837         else
4838             PerlIO_printf(Perl_error_log,
4839                           "Failed to unixify @INC element \"%s\"\n",
4840                           SvPV_nolen_const(libdir));
4841     }
4842 #endif
4843
4844         /* Do the if() outside the #ifdef to avoid warnings about an unused
4845            parameter.  */
4846         if (canrelocate) {
4847 #ifdef PERL_RELOCATABLE_INC
4848         /*
4849          * Relocatable include entries are marked with a leading .../
4850          *
4851          * The algorithm is
4852          * 0: Remove that leading ".../"
4853          * 1: Remove trailing executable name (anything after the last '/')
4854          *    from the perl path to give a perl prefix
4855          * Then
4856          * While the @INC element starts "../" and the prefix ends with a real
4857          * directory (ie not . or ..) chop that real directory off the prefix
4858   &