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