This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
9817220e4c9e0efa7111ee01f0126d3169ab24b0
[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_langinfo_buf) {
1167         Safefree(PL_langinfo_buf);
1168         PL_langinfo_buf = NULL;
1169     }
1170
1171     /* clear character classes  */
1172     for (i = 0; i < POSIX_SWASH_COUNT; i++) {
1173         SvREFCNT_dec(PL_utf8_swash_ptrs[i]);
1174         PL_utf8_swash_ptrs[i] = NULL;
1175     }
1176     SvREFCNT_dec(PL_utf8_mark);
1177     SvREFCNT_dec(PL_utf8_toupper);
1178     SvREFCNT_dec(PL_utf8_totitle);
1179     SvREFCNT_dec(PL_utf8_tolower);
1180     SvREFCNT_dec(PL_utf8_tofold);
1181     SvREFCNT_dec(PL_utf8_idstart);
1182     SvREFCNT_dec(PL_utf8_idcont);
1183     SvREFCNT_dec(PL_utf8_foldable);
1184     SvREFCNT_dec(PL_utf8_foldclosures);
1185     SvREFCNT_dec(PL_AboveLatin1);
1186     SvREFCNT_dec(PL_InBitmap);
1187     SvREFCNT_dec(PL_UpperLatin1);
1188     SvREFCNT_dec(PL_Latin1);
1189     SvREFCNT_dec(PL_NonL1NonFinalFold);
1190     SvREFCNT_dec(PL_HasMultiCharFold);
1191 #ifdef USE_LOCALE_CTYPE
1192     SvREFCNT_dec(PL_warn_locale);
1193 #endif
1194     PL_utf8_mark        = NULL;
1195     PL_utf8_toupper     = NULL;
1196     PL_utf8_totitle     = NULL;
1197     PL_utf8_tolower     = NULL;
1198     PL_utf8_tofold      = NULL;
1199     PL_utf8_idstart     = NULL;
1200     PL_utf8_idcont      = NULL;
1201     PL_utf8_foldclosures = NULL;
1202     PL_AboveLatin1       = NULL;
1203     PL_InBitmap          = NULL;
1204     PL_HasMultiCharFold  = NULL;
1205 #ifdef USE_LOCALE_CTYPE
1206     PL_warn_locale       = NULL;
1207 #endif
1208     PL_Latin1            = NULL;
1209     PL_NonL1NonFinalFold = NULL;
1210     PL_UpperLatin1       = NULL;
1211     for (i = 0; i < POSIX_CC_COUNT; i++) {
1212         SvREFCNT_dec(PL_XPosix_ptrs[i]);
1213         PL_XPosix_ptrs[i] = NULL;
1214     }
1215     PL_GCB_invlist = NULL;
1216     PL_LB_invlist = NULL;
1217     PL_SB_invlist = NULL;
1218     PL_SCX_invlist = NULL;
1219     PL_WB_invlist = NULL;
1220     PL_Assigned_invlist = NULL;
1221
1222     if (!specialWARN(PL_compiling.cop_warnings))
1223         PerlMemShared_free(PL_compiling.cop_warnings);
1224     PL_compiling.cop_warnings = NULL;
1225     cophh_free(CopHINTHASH_get(&PL_compiling));
1226     CopHINTHASH_set(&PL_compiling, cophh_new_empty());
1227     CopFILE_free(&PL_compiling);
1228
1229     /* Prepare to destruct main symbol table.  */
1230
1231     hv = PL_defstash;
1232     /* break ref loop  *:: <=> %:: */
1233     (void)hv_deletes(hv, "main::", G_DISCARD);
1234     PL_defstash = 0;
1235     SvREFCNT_dec(hv);
1236     SvREFCNT_dec(PL_curstname);
1237     PL_curstname = NULL;
1238
1239     /* clear queued errors */
1240     SvREFCNT_dec(PL_errors);
1241     PL_errors = NULL;
1242
1243     SvREFCNT_dec(PL_isarev);
1244
1245     FREETMPS;
1246     if (destruct_level >= 2) {
1247         if (PL_scopestack_ix != 0)
1248             Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
1249                              "Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
1250                              (long)PL_scopestack_ix);
1251         if (PL_savestack_ix != 0)
1252             Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
1253                              "Unbalanced saves: %ld more saves than restores\n",
1254                              (long)PL_savestack_ix);
1255         if (PL_tmps_floor != -1)
1256             Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),"Unbalanced tmps: %ld more allocs than frees\n",
1257                              (long)PL_tmps_floor + 1);
1258         if (cxstack_ix != -1)
1259             Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),"Unbalanced context: %ld more PUSHes than POPs\n",
1260                              (long)cxstack_ix + 1);
1261     }
1262
1263 #ifdef USE_ITHREADS
1264     SvREFCNT_dec(PL_regex_padav);
1265     PL_regex_padav = NULL;
1266     PL_regex_pad = NULL;
1267 #endif
1268
1269 #ifdef PERL_IMPLICIT_CONTEXT
1270     /* the entries in this list are allocated via SV PVX's, so get freed
1271      * in sv_clean_all */
1272     Safefree(PL_my_cxt_list);
1273 #endif
1274
1275     /* Now absolutely destruct everything, somehow or other, loops or no. */
1276
1277     /* the 2 is for PL_fdpid and PL_strtab */
1278     while (sv_clean_all() > 2)
1279         ;
1280
1281 #ifdef USE_ITHREADS
1282     Safefree(PL_stashpad); /* must come after sv_clean_all */
1283 #endif
1284
1285     AvREAL_off(PL_fdpid);               /* no surviving entries */
1286     SvREFCNT_dec(PL_fdpid);             /* needed in io_close() */
1287     PL_fdpid = NULL;
1288
1289 #ifdef HAVE_INTERP_INTERN
1290     sys_intern_clear();
1291 #endif
1292
1293     /* constant strings */
1294     for (i = 0; i < SV_CONSTS_COUNT; i++) {
1295         SvREFCNT_dec(PL_sv_consts[i]);
1296         PL_sv_consts[i] = NULL;
1297     }
1298
1299     /* Destruct the global string table. */
1300     {
1301         /* Yell and reset the HeVAL() slots that are still holding refcounts,
1302          * so that sv_free() won't fail on them.
1303          * Now that the global string table is using a single hunk of memory
1304          * for both HE and HEK, we either need to explicitly unshare it the
1305          * correct way, or actually free things here.
1306          */
1307         I32 riter = 0;
1308         const I32 max = HvMAX(PL_strtab);
1309         HE * const * const array = HvARRAY(PL_strtab);
1310         HE *hent = array[0];
1311
1312         for (;;) {
1313             if (hent && ckWARN_d(WARN_INTERNAL)) {
1314                 HE * const next = HeNEXT(hent);
1315                 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
1316                      "Unbalanced string table refcount: (%ld) for \"%s\"",
1317                      (long)hent->he_valu.hent_refcount, HeKEY(hent));
1318                 Safefree(hent);
1319                 hent = next;
1320             }
1321             if (!hent) {
1322                 if (++riter > max)
1323                     break;
1324                 hent = array[riter];
1325             }
1326         }
1327
1328         Safefree(array);
1329         HvARRAY(PL_strtab) = 0;
1330         HvTOTALKEYS(PL_strtab) = 0;
1331     }
1332     SvREFCNT_dec(PL_strtab);
1333
1334 #ifdef USE_ITHREADS
1335     /* free the pointer tables used for cloning */
1336     ptr_table_free(PL_ptr_table);
1337     PL_ptr_table = (PTR_TBL_t*)NULL;
1338 #endif
1339
1340     /* free special SVs */
1341
1342     SvREFCNT(&PL_sv_yes) = 0;
1343     sv_clear(&PL_sv_yes);
1344     SvANY(&PL_sv_yes) = NULL;
1345     SvFLAGS(&PL_sv_yes) = 0;
1346
1347     SvREFCNT(&PL_sv_no) = 0;
1348     sv_clear(&PL_sv_no);
1349     SvANY(&PL_sv_no) = NULL;
1350     SvFLAGS(&PL_sv_no) = 0;
1351
1352     SvREFCNT(&PL_sv_zero) = 0;
1353     sv_clear(&PL_sv_zero);
1354     SvANY(&PL_sv_zero) = NULL;
1355     SvFLAGS(&PL_sv_zero) = 0;
1356
1357     {
1358         int i;
1359         for (i=0; i<=2; i++) {
1360             SvREFCNT(PERL_DEBUG_PAD(i)) = 0;
1361             sv_clear(PERL_DEBUG_PAD(i));
1362             SvANY(PERL_DEBUG_PAD(i)) = NULL;
1363             SvFLAGS(PERL_DEBUG_PAD(i)) = 0;
1364         }
1365     }
1366
1367     if (PL_sv_count != 0 && ckWARN_d(WARN_INTERNAL))
1368         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Scalars leaked: %ld\n", (long)PL_sv_count);
1369
1370 #ifdef DEBUG_LEAKING_SCALARS
1371     if (PL_sv_count != 0) {
1372         SV* sva;
1373         SV* sv;
1374         SV* svend;
1375
1376         for (sva = PL_sv_arenaroot; sva; sva = MUTABLE_SV(SvANY(sva))) {
1377             svend = &sva[SvREFCNT(sva)];
1378             for (sv = sva + 1; sv < svend; ++sv) {
1379                 if (SvTYPE(sv) != (svtype)SVTYPEMASK) {
1380                     PerlIO_printf(Perl_debug_log, "leaked: sv=0x%p"
1381                         " flags=0x%"UVxf
1382                         " refcnt=%"UVuf pTHX__FORMAT "\n"
1383                         "\tallocated at %s:%d %s %s (parent 0x%" UVxf ");"
1384                         "serial %" UVuf "\n",
1385                         (void*)sv, (UV)sv->sv_flags, (UV)sv->sv_refcnt
1386                         pTHX__VALUE,
1387                         sv->sv_debug_file ? sv->sv_debug_file : "(unknown)",
1388                         sv->sv_debug_line,
1389                         sv->sv_debug_inpad ? "for" : "by",
1390                         sv->sv_debug_optype ?
1391                             PL_op_name[sv->sv_debug_optype]: "(none)",
1392                         PTR2UV(sv->sv_debug_parent),
1393                         sv->sv_debug_serial
1394                     );
1395 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
1396                     Perl_dump_sv_child(aTHX_ sv);
1397 #endif
1398                 }
1399             }
1400         }
1401     }
1402 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
1403     {
1404         int status;
1405         fd_set rset;
1406         /* Wait for up to 4 seconds for child to terminate.
1407            This seems to be the least effort way of timing out on reaping
1408            its exit status.  */
1409         struct timeval waitfor = {4, 0};
1410         int sock = PL_dumper_fd;
1411
1412         shutdown(sock, 1);
1413         FD_ZERO(&rset);
1414         FD_SET(sock, &rset);
1415         select(sock + 1, &rset, NULL, NULL, &waitfor);
1416         waitpid(child, &status, WNOHANG);
1417         close(sock);
1418     }
1419 #endif
1420 #endif
1421 #ifdef DEBUG_LEAKING_SCALARS_ABORT
1422     if (PL_sv_count)
1423         abort();
1424 #endif
1425     PL_sv_count = 0;
1426
1427 #if defined(PERLIO_LAYERS)
1428     /* No more IO - including error messages ! */
1429     PerlIO_cleanup(aTHX);
1430 #endif
1431
1432     /* sv_undef needs to stay immortal until after PerlIO_cleanup
1433        as currently layers use it rather than NULL as a marker
1434        for no arg - and will try and SvREFCNT_dec it.
1435      */
1436     SvREFCNT(&PL_sv_undef) = 0;
1437     SvREADONLY_off(&PL_sv_undef);
1438
1439     Safefree(PL_origfilename);
1440     PL_origfilename = NULL;
1441     Safefree(PL_reg_curpm);
1442     free_tied_hv_pool();
1443     Safefree(PL_op_mask);
1444     Safefree(PL_psig_name);
1445     PL_psig_name = (SV**)NULL;
1446     PL_psig_ptr = (SV**)NULL;
1447     {
1448         /* We need to NULL PL_psig_pend first, so that
1449            signal handlers know not to use it */
1450         int *psig_save = PL_psig_pend;
1451         PL_psig_pend = (int*)NULL;
1452         Safefree(psig_save);
1453     }
1454     nuke_stacks();
1455     TAINTING_set(FALSE);
1456     TAINT_WARN_set(FALSE);
1457     PL_hints = 0;               /* Reset hints. Should hints be per-interpreter ? */
1458
1459     DEBUG_P(debprofdump());
1460
1461     PL_debug = 0;
1462
1463 #ifdef USE_REENTRANT_API
1464     Perl_reentrant_free(aTHX);
1465 #endif
1466
1467     /* These all point to HVs that are about to be blown away.
1468        Code in core and on CPAN assumes that if the interpreter is re-started
1469        that they will be cleanly NULL or pointing to a valid HV.  */
1470     PL_custom_op_names = NULL;
1471     PL_custom_op_descs = NULL;
1472     PL_custom_ops = NULL;
1473
1474     sv_free_arenas();
1475
1476     while (PL_regmatch_slab) {
1477         regmatch_slab  *s = PL_regmatch_slab;
1478         PL_regmatch_slab = PL_regmatch_slab->next;
1479         Safefree(s);
1480     }
1481
1482     /* As the absolutely last thing, free the non-arena SV for mess() */
1483
1484     if (PL_mess_sv) {
1485         /* we know that type == SVt_PVMG */
1486
1487         /* it could have accumulated taint magic */
1488         MAGIC* mg;
1489         MAGIC* moremagic;
1490         for (mg = SvMAGIC(PL_mess_sv); mg; mg = moremagic) {
1491             moremagic = mg->mg_moremagic;
1492             if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global
1493                 && mg->mg_len >= 0)
1494                 Safefree(mg->mg_ptr);
1495             Safefree(mg);
1496         }
1497
1498         /* we know that type >= SVt_PV */
1499         SvPV_free(PL_mess_sv);
1500         Safefree(SvANY(PL_mess_sv));
1501         Safefree(PL_mess_sv);
1502         PL_mess_sv = NULL;
1503     }
1504     return STATUS_EXIT;
1505 }
1506
1507 /*
1508 =for apidoc perl_free
1509
1510 Releases a Perl interpreter.  See L<perlembed>.
1511
1512 =cut
1513 */
1514
1515 void
1516 perl_free(pTHXx)
1517 {
1518     dVAR;
1519
1520     PERL_ARGS_ASSERT_PERL_FREE;
1521
1522     if (PL_veto_cleanup)
1523         return;
1524
1525 #ifdef PERL_TRACK_MEMPOOL
1526     {
1527         /*
1528          * Don't free thread memory if PERL_DESTRUCT_LEVEL is set to a non-zero
1529          * value as we're probably hunting memory leaks then
1530          */
1531         if (PL_perl_destruct_level == 0) {
1532             const U32 old_debug = PL_debug;
1533             /* Emulate the PerlHost behaviour of free()ing all memory allocated in this
1534                thread at thread exit.  */
1535             if (DEBUG_m_TEST) {
1536                 PerlIO_puts(Perl_debug_log, "Disabling memory debugging as we "
1537                             "free this thread's memory\n");
1538                 PL_debug &= ~ DEBUG_m_FLAG;
1539             }
1540             while(aTHXx->Imemory_debug_header.next != &(aTHXx->Imemory_debug_header)){
1541                 char * next = (char *)(aTHXx->Imemory_debug_header.next);
1542                 Malloc_t ptr = PERL_MEMORY_DEBUG_HEADER_SIZE + next;
1543                 safesysfree(ptr);
1544             }
1545             PL_debug = old_debug;
1546         }
1547     }
1548 #endif
1549
1550 #if defined(WIN32) || defined(NETWARE)
1551 #  if defined(PERL_IMPLICIT_SYS)
1552     {
1553 #    ifdef NETWARE
1554         void *host = nw_internal_host;
1555         PerlMem_free(aTHXx);
1556         nw_delete_internal_host(host);
1557 #    else
1558         void *host = w32_internal_host;
1559         PerlMem_free(aTHXx);
1560         win32_delete_internal_host(host);
1561 #    endif
1562     }
1563 #  else
1564     PerlMem_free(aTHXx);
1565 #  endif
1566 #else
1567     PerlMem_free(aTHXx);
1568 #endif
1569 }
1570
1571 #if defined(USE_ITHREADS)
1572 /* provide destructors to clean up the thread key when libperl is unloaded */
1573 #ifndef WIN32 /* handled during DLL_PROCESS_DETACH in win32/perllib.c */
1574
1575 #if defined(__hpux) && !(defined(__ux_version) && __ux_version <= 1020) && !defined(__GNUC__)
1576 #pragma fini "perl_fini"
1577 #elif defined(__sun) && !defined(__GNUC__)
1578 #pragma fini (perl_fini)
1579 #endif
1580
1581 static void
1582 #if defined(__GNUC__)
1583 __attribute__((destructor))
1584 #endif
1585 perl_fini(void)
1586 {
1587     dVAR;
1588     if (
1589 #ifdef PERL_GLOBAL_STRUCT_PRIVATE
1590         my_vars &&
1591 #endif
1592         PL_curinterp && !PL_veto_cleanup)
1593         FREE_THREAD_KEY;
1594 }
1595
1596 #endif /* WIN32 */
1597 #endif /* THREADS */
1598
1599 void
1600 Perl_call_atexit(pTHX_ ATEXIT_t fn, void *ptr)
1601 {
1602     Renew(PL_exitlist, PL_exitlistlen+1, PerlExitListEntry);
1603     PL_exitlist[PL_exitlistlen].fn = fn;
1604     PL_exitlist[PL_exitlistlen].ptr = ptr;
1605     ++PL_exitlistlen;
1606 }
1607
1608 /*
1609 =for apidoc Am|int|perl_parse|PerlInterpreter *my_perl|XSINIT_t xsinit|int argc|char **argv|char **env
1610
1611 Tells a Perl interpreter to parse a Perl script.  This performs most
1612 of the initialisation of a Perl interpreter.  See L<perlembed> for
1613 a tutorial.
1614
1615 C<my_perl> points to the Perl interpreter that is to parse the script.
1616 It must have been previously created through the use of L</perl_alloc>
1617 and L</perl_construct>.  C<xsinit> points to a callback function that
1618 will be called to set up the ability for this Perl interpreter to load
1619 XS extensions, or may be null to perform no such setup.
1620
1621 C<argc> and C<argv> supply a set of command-line arguments to the Perl
1622 interpreter, as would normally be passed to the C<main> function of
1623 a C program.  C<argv[argc]> must be null.  These arguments are where
1624 the script to parse is specified, either by naming a script file or by
1625 providing a script in a C<-e> option.
1626 If L<C<$0>|perlvar/$0> will be written to in the Perl interpreter, then
1627 the argument strings must be in writable memory, and so mustn't just be
1628 string constants.
1629
1630 C<env> specifies a set of environment variables that will be used by
1631 this Perl interpreter.  If non-null, it must point to a null-terminated
1632 array of environment strings.  If null, the Perl interpreter will use
1633 the environment supplied by the C<environ> global variable.
1634
1635 This function initialises the interpreter, and parses and compiles the
1636 script specified by the command-line arguments.  This includes executing
1637 code in C<BEGIN>, C<UNITCHECK>, and C<CHECK> blocks.  It does not execute
1638 C<INIT> blocks or the main program.
1639
1640 Returns an integer of slightly tricky interpretation.  The correct
1641 use of the return value is as a truth value indicating whether there
1642 was a failure in initialisation.  If zero is returned, this indicates
1643 that initialisation was successful, and it is safe to proceed to call
1644 L</perl_run> and make other use of it.  If a non-zero value is returned,
1645 this indicates some problem that means the interpreter wants to terminate.
1646 The interpreter should not be just abandoned upon such failure; the caller
1647 should proceed to shut the interpreter down cleanly with L</perl_destruct>
1648 and free it with L</perl_free>.
1649
1650 For historical reasons, the non-zero return value also attempts to
1651 be a suitable value to pass to the C library function C<exit> (or to
1652 return from C<main>), to serve as an exit code indicating the nature
1653 of the way initialisation terminated.  However, this isn't portable,
1654 due to differing exit code conventions.  A historical bug is preserved
1655 for the time being: if the Perl built-in C<exit> is called during this
1656 function's execution, with a type of exit entailing a zero exit code
1657 under the host operating system's conventions, then this function
1658 returns zero rather than a non-zero value.  This bug, [perl #2754],
1659 leads to C<perl_run> being called (and therefore C<INIT> blocks and the
1660 main program running) despite a call to C<exit>.  It has been preserved
1661 because a popular module-installing module has come to rely on it and
1662 needs time to be fixed.  This issue is [perl #132577], and the original
1663 bug is due to be fixed in Perl 5.30.
1664
1665 =cut
1666 */
1667
1668 #define SET_CURSTASH(newstash)                       \
1669         if (PL_curstash != newstash) {                \
1670             SvREFCNT_dec(PL_curstash);                 \
1671             PL_curstash = (HV *)SvREFCNT_inc(newstash); \
1672         }
1673
1674 int
1675 perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env)
1676 {
1677     dVAR;
1678     I32 oldscope;
1679     int ret;
1680     dJMPENV;
1681
1682     PERL_ARGS_ASSERT_PERL_PARSE;
1683 #ifndef MULTIPLICITY
1684     PERL_UNUSED_ARG(my_perl);
1685 #endif
1686 #if (defined(USE_HASH_SEED) || defined(USE_HASH_SEED_DEBUG)) && !defined(NO_PERL_HASH_SEED_DEBUG)
1687     {
1688         const char * const s = PerlEnv_getenv("PERL_HASH_SEED_DEBUG");
1689
1690         if (s && strEQ(s, "1")) {
1691             const unsigned char *seed= PERL_HASH_SEED;
1692             const unsigned char *seed_end= PERL_HASH_SEED + PERL_HASH_SEED_BYTES;
1693             PerlIO_printf(Perl_debug_log, "HASH_FUNCTION = %s HASH_SEED = 0x", PERL_HASH_FUNC);
1694             while (seed < seed_end) {
1695                 PerlIO_printf(Perl_debug_log, "%02x", *seed++);
1696             }
1697 #ifdef PERL_HASH_RANDOMIZE_KEYS
1698             PerlIO_printf(Perl_debug_log, " PERTURB_KEYS = %d (%s)",
1699                     PL_HASH_RAND_BITS_ENABLED,
1700                     PL_HASH_RAND_BITS_ENABLED == 0 ? "NO" : PL_HASH_RAND_BITS_ENABLED == 1 ? "RANDOM" : "DETERMINISTIC");
1701 #endif
1702             PerlIO_printf(Perl_debug_log, "\n");
1703         }
1704     }
1705 #endif /* #if (defined(USE_HASH_SEED) ... */
1706
1707 #ifdef __amigaos4__
1708     {
1709         struct NameTranslationInfo nti;
1710         __translate_amiga_to_unix_path_name(&argv[0],&nti); 
1711     }
1712 #endif
1713
1714     {
1715         int i;
1716         assert(argc >= 0);
1717         for(i = 0; i != argc; i++)
1718             assert(argv[i]);
1719         assert(!argv[argc]);
1720     }
1721     PL_origargc = argc;
1722     PL_origargv = argv;
1723
1724     if (PL_origalen != 0) {
1725         PL_origalen = 1; /* don't use old PL_origalen if perl_parse() is called again */
1726     }
1727     else {
1728         /* Set PL_origalen be the sum of the contiguous argv[]
1729          * elements plus the size of the env in case that it is
1730          * contiguous with the argv[].  This is used in mg.c:Perl_magic_set()
1731          * as the maximum modifiable length of $0.  In the worst case
1732          * the area we are able to modify is limited to the size of
1733          * the original argv[0].  (See below for 'contiguous', though.)
1734          * --jhi */
1735          const char *s = NULL;
1736          const UV mask = ~(UV)(PTRSIZE-1);
1737          /* Do the mask check only if the args seem like aligned. */
1738          const UV aligned =
1739            (mask < ~(UV)0) && ((PTR2UV(argv[0]) & mask) == PTR2UV(argv[0]));
1740
1741          /* See if all the arguments are contiguous in memory.  Note
1742           * that 'contiguous' is a loose term because some platforms
1743           * align the argv[] and the envp[].  If the arguments look
1744           * like non-aligned, assume that they are 'strictly' or
1745           * 'traditionally' contiguous.  If the arguments look like
1746           * aligned, we just check that they are within aligned
1747           * PTRSIZE bytes.  As long as no system has something bizarre
1748           * like the argv[] interleaved with some other data, we are
1749           * fine.  (Did I just evoke Murphy's Law?)  --jhi */
1750          if (PL_origargv && PL_origargc >= 1 && (s = PL_origargv[0])) {
1751               int i;
1752               while (*s) s++;
1753               for (i = 1; i < PL_origargc; i++) {
1754                    if ((PL_origargv[i] == s + 1
1755 #ifdef OS2
1756                         || PL_origargv[i] == s + 2
1757 #endif 
1758                             )
1759                        ||
1760                        (aligned &&
1761                         (PL_origargv[i] >  s &&
1762                          PL_origargv[i] <=
1763                          INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask)))
1764                         )
1765                    {
1766                         s = PL_origargv[i];
1767                         while (*s) s++;
1768                    }
1769                    else
1770                         break;
1771               }
1772          }
1773
1774 #ifndef PERL_USE_SAFE_PUTENV
1775          /* Can we grab env area too to be used as the area for $0? */
1776          if (s && PL_origenviron && !PL_use_safe_putenv) {
1777               if ((PL_origenviron[0] == s + 1)
1778                   ||
1779                   (aligned &&
1780                    (PL_origenviron[0] >  s &&
1781                     PL_origenviron[0] <=
1782                     INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask)))
1783                  )
1784               {
1785                    int i;
1786 #ifndef OS2             /* ENVIRON is read by the kernel too. */
1787                    s = PL_origenviron[0];
1788                    while (*s) s++;
1789 #endif
1790                    my_setenv("NoNe  SuCh", NULL);
1791                    /* Force copy of environment. */
1792                    for (i = 1; PL_origenviron[i]; i++) {
1793                         if (PL_origenviron[i] == s + 1
1794                             ||
1795                             (aligned &&
1796                              (PL_origenviron[i] >  s &&
1797                               PL_origenviron[i] <=
1798                               INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask)))
1799                            )
1800                         {
1801                              s = PL_origenviron[i];
1802                              while (*s) s++;
1803                         }
1804                         else
1805                              break;
1806                    }
1807               }
1808          }
1809 #endif /* !defined(PERL_USE_SAFE_PUTENV) */
1810
1811          PL_origalen = s ? s - PL_origargv[0] + 1 : 0;
1812     }
1813
1814     if (PL_do_undump) {
1815
1816         /* Come here if running an undumped a.out. */
1817
1818         PL_origfilename = savepv(argv[0]);
1819         PL_do_undump = FALSE;
1820         cxstack_ix = -1;                /* start label stack again */
1821         init_ids();
1822         assert (!TAINT_get);
1823         TAINT;
1824         set_caret_X();
1825         TAINT_NOT;
1826         init_postdump_symbols(argc,argv,env);
1827         return 0;
1828     }
1829
1830     if (PL_main_root) {
1831         op_free(PL_main_root);
1832         PL_main_root = NULL;
1833     }
1834     PL_main_start = NULL;
1835     SvREFCNT_dec(PL_main_cv);
1836     PL_main_cv = NULL;
1837
1838     time(&PL_basetime);
1839     oldscope = PL_scopestack_ix;
1840     PL_dowarn = G_WARN_OFF;
1841
1842     JMPENV_PUSH(ret);
1843     switch (ret) {
1844     case 0:
1845         parse_body(env,xsinit);
1846         if (PL_unitcheckav) {
1847             call_list(oldscope, PL_unitcheckav);
1848         }
1849         if (PL_checkav) {
1850             PERL_SET_PHASE(PERL_PHASE_CHECK);
1851             call_list(oldscope, PL_checkav);
1852         }
1853         ret = 0;
1854         break;
1855     case 1:
1856         STATUS_ALL_FAILURE;
1857         /* FALLTHROUGH */
1858     case 2:
1859         /* my_exit() was called */
1860         while (PL_scopestack_ix > oldscope)
1861             LEAVE;
1862         FREETMPS;
1863         SET_CURSTASH(PL_defstash);
1864         if (PL_unitcheckav) {
1865             call_list(oldscope, PL_unitcheckav);
1866         }
1867         if (PL_checkav) {
1868             PERL_SET_PHASE(PERL_PHASE_CHECK);
1869             call_list(oldscope, PL_checkav);
1870         }
1871         ret = STATUS_EXIT;
1872         if (ret == 0) {
1873             /*
1874              * At this point we should do
1875              *     ret = 0x100;
1876              * to avoid [perl #2754], but that bugfix has been postponed
1877              * because of the Module::Install breakage it causes
1878              * [perl #132577].
1879              */
1880         }
1881         break;
1882     case 3:
1883         PerlIO_printf(Perl_error_log, "panic: top_env\n");
1884         ret = 1;
1885         break;
1886     }
1887     JMPENV_POP;
1888     return ret;
1889 }
1890
1891 /* This needs to stay in perl.c, as perl.c is compiled with different flags for
1892    miniperl, and we need to see those flags reflected in the values here.  */
1893
1894 /* What this returns is subject to change.  Use the public interface in Config.
1895  */
1896 static void
1897 S_Internals_V(pTHX_ CV *cv)
1898 {
1899     dXSARGS;
1900 #ifdef LOCAL_PATCH_COUNT
1901     const int local_patch_count = LOCAL_PATCH_COUNT;
1902 #else
1903     const int local_patch_count = 0;
1904 #endif
1905     const int entries = 3 + local_patch_count;
1906     int i;
1907     static const char non_bincompat_options[] = 
1908 #  ifdef DEBUGGING
1909                              " DEBUGGING"
1910 #  endif
1911 #  ifdef NO_MATHOMS
1912                              " NO_MATHOMS"
1913 #  endif
1914 #  ifdef NO_HASH_SEED
1915                              " NO_HASH_SEED"
1916 #  endif
1917 #  ifdef NO_TAINT_SUPPORT
1918                              " NO_TAINT_SUPPORT"
1919 #  endif
1920 #  ifdef PERL_BOOL_AS_CHAR
1921                              " PERL_BOOL_AS_CHAR"
1922 #  endif
1923 #  ifdef PERL_COPY_ON_WRITE
1924                              " PERL_COPY_ON_WRITE"
1925 #  endif
1926 #  ifdef PERL_DISABLE_PMC
1927                              " PERL_DISABLE_PMC"
1928 #  endif
1929 #  ifdef PERL_DONT_CREATE_GVSV
1930                              " PERL_DONT_CREATE_GVSV"
1931 #  endif
1932 #  ifdef PERL_EXTERNAL_GLOB
1933                              " PERL_EXTERNAL_GLOB"
1934 #  endif
1935 #  ifdef PERL_HASH_FUNC_SIPHASH
1936                              " PERL_HASH_FUNC_SIPHASH"
1937 #  endif
1938 #  ifdef PERL_HASH_FUNC_SDBM
1939                              " PERL_HASH_FUNC_SDBM"
1940 #  endif
1941 #  ifdef PERL_HASH_FUNC_DJB2
1942                              " PERL_HASH_FUNC_DJB2"
1943 #  endif
1944 #  ifdef PERL_HASH_FUNC_SUPERFAST
1945                              " PERL_HASH_FUNC_SUPERFAST"
1946 #  endif
1947 #  ifdef PERL_HASH_FUNC_MURMUR3
1948                              " PERL_HASH_FUNC_MURMUR3"
1949 #  endif
1950 #  ifdef PERL_HASH_FUNC_ONE_AT_A_TIME
1951                              " PERL_HASH_FUNC_ONE_AT_A_TIME"
1952 #  endif
1953 #  ifdef PERL_HASH_FUNC_ONE_AT_A_TIME_HARD
1954                              " PERL_HASH_FUNC_ONE_AT_A_TIME_HARD"
1955 #  endif
1956 #  ifdef PERL_HASH_FUNC_ONE_AT_A_TIME_OLD
1957                              " PERL_HASH_FUNC_ONE_AT_A_TIME_OLD"
1958 #  endif
1959 #  ifdef PERL_IS_MINIPERL
1960                              " PERL_IS_MINIPERL"
1961 #  endif
1962 #  ifdef PERL_MALLOC_WRAP
1963                              " PERL_MALLOC_WRAP"
1964 #  endif
1965 #  ifdef PERL_MEM_LOG
1966                              " PERL_MEM_LOG"
1967 #  endif
1968 #  ifdef PERL_MEM_LOG_NOIMPL
1969                              " PERL_MEM_LOG_NOIMPL"
1970 #  endif
1971 #  ifdef PERL_OP_PARENT
1972                              " PERL_OP_PARENT"
1973 #  endif
1974 #  ifdef PERL_PERTURB_KEYS_DETERMINISTIC
1975                              " PERL_PERTURB_KEYS_DETERMINISTIC"
1976 #  endif
1977 #  ifdef PERL_PERTURB_KEYS_DISABLED
1978                              " PERL_PERTURB_KEYS_DISABLED"
1979 #  endif
1980 #  ifdef PERL_PERTURB_KEYS_RANDOM
1981                              " PERL_PERTURB_KEYS_RANDOM"
1982 #  endif
1983 #  ifdef PERL_PRESERVE_IVUV
1984                              " PERL_PRESERVE_IVUV"
1985 #  endif
1986 #  ifdef PERL_RELOCATABLE_INCPUSH
1987                              " PERL_RELOCATABLE_INCPUSH"
1988 #  endif
1989 #  ifdef PERL_USE_DEVEL
1990                              " PERL_USE_DEVEL"
1991 #  endif
1992 #  ifdef PERL_USE_SAFE_PUTENV
1993                              " PERL_USE_SAFE_PUTENV"
1994 #  endif
1995 #  ifdef SILENT_NO_TAINT_SUPPORT
1996                              " SILENT_NO_TAINT_SUPPORT"
1997 #  endif
1998 #  ifdef UNLINK_ALL_VERSIONS
1999                              " UNLINK_ALL_VERSIONS"
2000 #  endif
2001 #  ifdef USE_ATTRIBUTES_FOR_PERLIO
2002                              " USE_ATTRIBUTES_FOR_PERLIO"
2003 #  endif
2004 #  ifdef USE_FAST_STDIO
2005                              " USE_FAST_STDIO"
2006 #  endif               
2007 #  ifdef USE_LOCALE
2008                              " USE_LOCALE"
2009 #  endif
2010 #  ifdef USE_LOCALE_CTYPE
2011                              " USE_LOCALE_CTYPE"
2012 #  endif
2013 #  ifdef WIN32_NO_REGISTRY
2014                              " USE_NO_REGISTRY"
2015 #  endif
2016 #  ifdef USE_PERL_ATOF
2017                              " USE_PERL_ATOF"
2018 #  endif               
2019 #  ifdef USE_SITECUSTOMIZE
2020                              " USE_SITECUSTOMIZE"
2021 #  endif               
2022         ;
2023     PERL_UNUSED_ARG(cv);
2024     PERL_UNUSED_VAR(items);
2025
2026     EXTEND(SP, entries);
2027
2028     PUSHs(sv_2mortal(newSVpv(PL_bincompat_options, 0)));
2029     PUSHs(Perl_newSVpvn_flags(aTHX_ non_bincompat_options,
2030                               sizeof(non_bincompat_options) - 1, SVs_TEMP));
2031
2032 #ifndef PERL_BUILD_DATE
2033 #  ifdef __DATE__
2034 #    ifdef __TIME__
2035 #      define PERL_BUILD_DATE __DATE__ " " __TIME__
2036 #    else
2037 #      define PERL_BUILD_DATE __DATE__
2038 #    endif
2039 #  endif
2040 #endif
2041
2042 #ifdef PERL_BUILD_DATE
2043     PUSHs(Perl_newSVpvn_flags(aTHX_
2044                               STR_WITH_LEN("Compiled at " PERL_BUILD_DATE),
2045                               SVs_TEMP));
2046 #else
2047     PUSHs(&PL_sv_undef);
2048 #endif
2049
2050     for (i = 1; i <= local_patch_count; i++) {
2051         /* This will be an undef, if PL_localpatches[i] is NULL.  */
2052         PUSHs(sv_2mortal(newSVpv(PL_localpatches[i], 0)));
2053     }
2054
2055     XSRETURN(entries);
2056 }
2057
2058 #define INCPUSH_UNSHIFT                 0x01
2059 #define INCPUSH_ADD_OLD_VERS            0x02
2060 #define INCPUSH_ADD_VERSIONED_SUB_DIRS  0x04
2061 #define INCPUSH_ADD_ARCHONLY_SUB_DIRS   0x08
2062 #define INCPUSH_NOT_BASEDIR             0x10
2063 #define INCPUSH_CAN_RELOCATE            0x20
2064 #define INCPUSH_ADD_SUB_DIRS    \
2065     (INCPUSH_ADD_VERSIONED_SUB_DIRS|INCPUSH_ADD_ARCHONLY_SUB_DIRS)
2066
2067 STATIC void *
2068 S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
2069 {
2070     dVAR;
2071     PerlIO *rsfp;
2072     int argc = PL_origargc;
2073     char **argv = PL_origargv;
2074     const char *scriptname = NULL;
2075     bool dosearch = FALSE;
2076     char c;
2077     bool doextract = FALSE;
2078     const char *cddir = NULL;
2079 #ifdef USE_SITECUSTOMIZE
2080     bool minus_f = FALSE;
2081 #endif
2082     SV *linestr_sv = NULL;
2083     bool add_read_e_script = FALSE;
2084     U32 lex_start_flags = 0;
2085
2086     PERL_SET_PHASE(PERL_PHASE_START);
2087
2088     init_main_stash();
2089
2090     {
2091         const char *s;
2092     for (argc--,argv++; argc > 0; argc--,argv++) {
2093         if (argv[0][0] != '-' || !argv[0][1])
2094             break;
2095         s = argv[0]+1;
2096       reswitch:
2097         switch ((c = *s)) {
2098         case 'C':
2099 #ifndef PERL_STRICT_CR
2100         case '\r':
2101 #endif
2102         case ' ':
2103         case '0':
2104         case 'F':
2105         case 'a':
2106         case 'c':
2107         case 'd':
2108         case 'D':
2109         case 'h':
2110         case 'i':
2111         case 'l':
2112         case 'M':
2113         case 'm':
2114         case 'n':
2115         case 'p':
2116         case 's':
2117         case 'u':
2118         case 'U':
2119         case 'v':
2120         case 'W':
2121         case 'X':
2122         case 'w':
2123             if ((s = moreswitches(s)))
2124                 goto reswitch;
2125             break;
2126
2127         case 't':
2128 #if defined(SILENT_NO_TAINT_SUPPORT)
2129             /* silently ignore */
2130 #elif defined(NO_TAINT_SUPPORT)
2131             Perl_croak_nocontext("This perl was compiled without taint support. "
2132                        "Cowardly refusing to run with -t or -T flags");
2133 #else
2134             CHECK_MALLOC_TOO_LATE_FOR('t');
2135             if( !TAINTING_get ) {
2136                  TAINT_WARN_set(TRUE);
2137                  TAINTING_set(TRUE);
2138             }
2139 #endif
2140             s++;
2141             goto reswitch;
2142         case 'T':
2143 #if defined(SILENT_NO_TAINT_SUPPORT)
2144             /* silently ignore */
2145 #elif defined(NO_TAINT_SUPPORT)
2146             Perl_croak_nocontext("This perl was compiled without taint support. "
2147                        "Cowardly refusing to run with -t or -T flags");
2148 #else
2149             CHECK_MALLOC_TOO_LATE_FOR('T');
2150             TAINTING_set(TRUE);
2151             TAINT_WARN_set(FALSE);
2152 #endif
2153             s++;
2154             goto reswitch;
2155
2156         case 'E':
2157             PL_minus_E = TRUE;
2158             /* FALLTHROUGH */
2159         case 'e':
2160             forbid_setid('e', FALSE);
2161             if (!PL_e_script) {
2162                 PL_e_script = newSVpvs("");
2163                 add_read_e_script = TRUE;
2164             }
2165             if (*++s)
2166                 sv_catpv(PL_e_script, s);
2167             else if (argv[1]) {
2168                 sv_catpv(PL_e_script, argv[1]);
2169                 argc--,argv++;
2170             }
2171             else
2172                 Perl_croak(aTHX_ "No code specified for -%c", c);
2173             sv_catpvs(PL_e_script, "\n");
2174             break;
2175
2176         case 'f':
2177 #ifdef USE_SITECUSTOMIZE
2178             minus_f = TRUE;
2179 #endif
2180             s++;
2181             goto reswitch;
2182
2183         case 'I':       /* -I handled both here and in moreswitches() */
2184             forbid_setid('I', FALSE);
2185             if (!*++s && (s=argv[1]) != NULL) {
2186                 argc--,argv++;
2187             }
2188             if (s && *s) {
2189                 STRLEN len = strlen(s);
2190                 incpush(s, len, INCPUSH_ADD_SUB_DIRS|INCPUSH_ADD_OLD_VERS);
2191             }
2192             else
2193                 Perl_croak(aTHX_ "No directory specified for -I");
2194             break;
2195         case 'S':
2196             forbid_setid('S', FALSE);
2197             dosearch = TRUE;
2198             s++;
2199             goto reswitch;
2200         case 'V':
2201             {
2202                 SV *opts_prog;
2203
2204                 if (*++s != ':')  {
2205                     opts_prog = newSVpvs("use Config; Config::_V()");
2206                 }
2207                 else {
2208                     ++s;
2209                     opts_prog = Perl_newSVpvf(aTHX_
2210                                               "use Config; Config::config_vars(qw%c%s%c)",
2211                                               0, s, 0);
2212                     s += strlen(s);
2213                 }
2214                 Perl_av_create_and_push(aTHX_ &PL_preambleav, opts_prog);
2215                 /* don't look for script or read stdin */
2216                 scriptname = BIT_BUCKET;
2217                 goto reswitch;
2218             }
2219         case 'x':
2220             doextract = TRUE;
2221             s++;
2222             if (*s)
2223                 cddir = s;
2224             break;
2225         case 0:
2226             break;
2227         case '-':
2228             if (!*++s || isSPACE(*s)) {
2229                 argc--,argv++;
2230                 goto switch_end;
2231             }
2232             /* catch use of gnu style long options.
2233                Both of these exit immediately.  */
2234             if (strEQ(s, "version"))
2235                 minus_v();
2236             if (strEQ(s, "help"))
2237                 usage();
2238             s--;
2239             /* FALLTHROUGH */
2240         default:
2241             Perl_croak(aTHX_ "Unrecognized switch: -%s  (-h will show valid options)",s);
2242         }
2243     }
2244     }
2245
2246   switch_end:
2247
2248     {
2249         char *s;
2250
2251     if (
2252 #ifndef SECURE_INTERNAL_GETENV
2253         !TAINTING_get &&
2254 #endif
2255         (s = PerlEnv_getenv("PERL5OPT")))
2256     {
2257         /* s points to static memory in getenv(), which may be overwritten at
2258          * any time; use a mortal copy instead */
2259         s = SvPVX(sv_2mortal(newSVpv(s, 0)));
2260
2261         while (isSPACE(*s))
2262             s++;
2263         if (*s == '-' && *(s+1) == 'T') {
2264 #if defined(SILENT_NO_TAINT_SUPPORT)
2265             /* silently ignore */
2266 #elif defined(NO_TAINT_SUPPORT)
2267             Perl_croak_nocontext("This perl was compiled without taint support. "
2268                        "Cowardly refusing to run with -t or -T flags");
2269 #else
2270             CHECK_MALLOC_TOO_LATE_FOR('T');
2271             TAINTING_set(TRUE);
2272             TAINT_WARN_set(FALSE);
2273 #endif
2274         }
2275         else {
2276             char *popt_copy = NULL;
2277             while (s && *s) {
2278                 const char *d;
2279                 while (isSPACE(*s))
2280                     s++;
2281                 if (*s == '-') {
2282                     s++;
2283                     if (isSPACE(*s))
2284                         continue;
2285                 }
2286                 d = s;
2287                 if (!*s)
2288                     break;
2289                 if (!strchr("CDIMUdmtwW", *s))
2290                     Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s);
2291                 while (++s && *s) {
2292                     if (isSPACE(*s)) {
2293                         if (!popt_copy) {
2294                             popt_copy = SvPVX(sv_2mortal(newSVpv(d,0)));
2295                             s = popt_copy + (s - d);
2296                             d = popt_copy;
2297                         }
2298                         *s++ = '\0';
2299                         break;
2300                     }
2301                 }
2302                 if (*d == 't') {
2303 #if defined(SILENT_NO_TAINT_SUPPORT)
2304             /* silently ignore */
2305 #elif defined(NO_TAINT_SUPPORT)
2306                     Perl_croak_nocontext("This perl was compiled without taint support. "
2307                                "Cowardly refusing to run with -t or -T flags");
2308 #else
2309                     if( !TAINTING_get) {
2310                         TAINT_WARN_set(TRUE);
2311                         TAINTING_set(TRUE);
2312                     }
2313 #endif
2314                 } else {
2315                     moreswitches(d);
2316                 }
2317             }
2318         }
2319     }
2320     }
2321
2322 #ifndef NO_PERL_INTERNAL_RAND_SEED
2323     /* If we're not set[ug]id, we might have honored
2324        PERL_INTERNAL_RAND_SEED in perl_construct().
2325        At this point command-line options have been parsed, so if
2326        we're now tainting and not set[ug]id re-seed.
2327        This could possibly be wasteful if PERL_INTERNAL_RAND_SEED is invalid,
2328        but avoids duplicating the logic from perl_construct().
2329     */
2330     if (PL_tainting &&
2331         PerlProc_getuid() == PerlProc_geteuid() &&
2332         PerlProc_getgid() == PerlProc_getegid()) {
2333         Perl_drand48_init_r(&PL_internal_random_state, seed());
2334     }
2335 #endif
2336
2337     /* Set $^X early so that it can be used for relocatable paths in @INC  */
2338     /* and for SITELIB_EXP in USE_SITECUSTOMIZE                            */
2339     assert (!TAINT_get);
2340     TAINT;
2341     set_caret_X();
2342     TAINT_NOT;
2343
2344 #if defined(USE_SITECUSTOMIZE)
2345     if (!minus_f) {
2346         /* The games with local $! are to avoid setting errno if there is no
2347            sitecustomize script.  "q%c...%c", 0, ..., 0 becomes "q\0...\0",
2348            ie a q() operator with a NUL byte as a the delimiter. This avoids
2349            problems with pathnames containing (say) '  */
2350 #  ifdef PERL_IS_MINIPERL
2351         AV *const inc = GvAV(PL_incgv);
2352         SV **const inc0 = inc ? av_fetch(inc, 0, FALSE) : NULL;
2353
2354         if (inc0) {
2355             /* if lib/buildcustomize.pl exists, it should not fail. If it does,
2356                it should be reported immediately as a build failure.  */
2357             (void)Perl_av_create_and_unshift_one(aTHX_ &PL_preambleav,
2358                                                  Perl_newSVpvf(aTHX_
2359                 "BEGIN { my $f = q%c%s%" SVf "/buildcustomize.pl%c; "
2360                         "do {local $!; -f $f }"
2361                         " and do $f || die $@ || qq '$f: $!' }",
2362                                 0, (TAINTING_get ? "./" : ""), SVfARG(*inc0), 0));
2363         }
2364 #  else
2365         /* SITELIB_EXP is a function call on Win32.  */
2366         const char *const raw_sitelib = SITELIB_EXP;
2367         if (raw_sitelib) {
2368             /* process .../.. if PERL_RELOCATABLE_INC is defined */
2369             SV *sitelib_sv = mayberelocate(raw_sitelib, strlen(raw_sitelib),
2370                                            INCPUSH_CAN_RELOCATE);
2371             const char *const sitelib = SvPVX(sitelib_sv);
2372             (void)Perl_av_create_and_unshift_one(aTHX_ &PL_preambleav,
2373                                                  Perl_newSVpvf(aTHX_
2374                                                                "BEGIN { do {local $!; -f q%c%s/sitecustomize.pl%c} && do q%c%s/sitecustomize.pl%c }",
2375                                                                0, SVfARG(sitelib), 0,
2376                                                                0, SVfARG(sitelib), 0));
2377             assert (SvREFCNT(sitelib_sv) == 1);
2378             SvREFCNT_dec(sitelib_sv);
2379         }
2380 #  endif
2381     }
2382 #endif
2383
2384     if (!scriptname)
2385         scriptname = argv[0];
2386     if (PL_e_script) {
2387         argc++,argv--;
2388         scriptname = BIT_BUCKET;        /* don't look for script or read stdin */
2389     }
2390     else if (scriptname == NULL) {
2391 #ifdef MSDOS
2392         if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) )
2393             moreswitches("h");
2394 #endif
2395         scriptname = "-";
2396     }
2397
2398     assert (!TAINT_get);
2399     init_perllib();
2400
2401     {
2402         bool suidscript = FALSE;
2403
2404         rsfp = open_script(scriptname, dosearch, &suidscript);
2405         if (!rsfp) {
2406             rsfp = PerlIO_stdin();
2407             lex_start_flags = LEX_DONT_CLOSE_RSFP;
2408         }
2409
2410         validate_suid(rsfp);
2411
2412 #ifndef PERL_MICRO
2413 #  if defined(SIGCHLD) || defined(SIGCLD)
2414         {
2415 #  ifndef SIGCHLD
2416 #    define SIGCHLD SIGCLD
2417 #  endif
2418             Sighandler_t sigstate = rsignal_state(SIGCHLD);
2419             if (sigstate == (Sighandler_t) SIG_IGN) {
2420                 Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL),
2421                                "Can't ignore signal CHLD, forcing to default");
2422                 (void)rsignal(SIGCHLD, (Sighandler_t)SIG_DFL);
2423             }
2424         }
2425 #  endif
2426 #endif
2427
2428         if (doextract) {
2429
2430             /* This will croak if suidscript is true, as -x cannot be used with
2431                setuid scripts.  */
2432             forbid_setid('x', suidscript);
2433             /* Hence you can't get here if suidscript is true */
2434
2435             linestr_sv = newSV_type(SVt_PV);
2436             lex_start_flags |= LEX_START_COPIED;
2437             find_beginning(linestr_sv, rsfp);
2438             if (cddir && PerlDir_chdir( (char *)cddir ) < 0)
2439                 Perl_croak(aTHX_ "Can't chdir to %s",cddir);
2440         }
2441     }
2442
2443     PL_main_cv = PL_compcv = MUTABLE_CV(newSV_type(SVt_PVCV));
2444     CvUNIQUE_on(PL_compcv);
2445
2446     CvPADLIST_set(PL_compcv, pad_new(0));
2447
2448     PL_isarev = newHV();
2449
2450     boot_core_PerlIO();
2451     boot_core_UNIVERSAL();
2452     boot_core_mro();
2453     newXS("Internals::V", S_Internals_V, __FILE__);
2454
2455     if (xsinit)
2456         (*xsinit)(aTHX);        /* in case linked C routines want magical variables */
2457 #ifndef PERL_MICRO
2458 #if defined(VMS) || defined(WIN32) || defined(DJGPP) || defined(__CYGWIN__) || defined(SYMBIAN)
2459     init_os_extras();
2460 #endif
2461 #endif
2462
2463 #ifdef USE_SOCKS
2464 #   ifdef HAS_SOCKS5_INIT
2465     socks5_init(argv[0]);
2466 #   else
2467     SOCKSinit(argv[0]);
2468 #   endif
2469 #endif
2470
2471     init_predump_symbols();
2472     /* init_postdump_symbols not currently designed to be called */
2473     /* more than once (ENV isn't cleared first, for example)     */
2474     /* But running with -u leaves %ENV & @ARGV undefined!    XXX */
2475     if (!PL_do_undump)
2476         init_postdump_symbols(argc,argv,env);
2477
2478     /* PL_unicode is turned on by -C, or by $ENV{PERL_UNICODE},
2479      * or explicitly in some platforms.
2480      * PL_utf8locale is conditionally turned on by
2481      * locale.c:Perl_init_i18nl10n() if the environment
2482      * look like the user wants to use UTF-8. */
2483 #if defined(__SYMBIAN32__)
2484     PL_unicode = PERL_UNICODE_STD_FLAG; /* See PERL_SYMBIAN_CONSOLE_UTF8. */
2485 #endif
2486 #  ifndef PERL_IS_MINIPERL
2487     if (PL_unicode) {
2488          /* Requires init_predump_symbols(). */
2489          if (!(PL_unicode & PERL_UNICODE_LOCALE_FLAG) || PL_utf8locale) {
2490               IO* io;
2491               PerlIO* fp;
2492               SV* sv;
2493
2494               /* Turn on UTF-8-ness on STDIN, STDOUT, STDERR
2495                * and the default open disciplines. */
2496               if ((PL_unicode & PERL_UNICODE_STDIN_FLAG) &&
2497                   PL_stdingv  && (io = GvIO(PL_stdingv)) &&
2498                   (fp = IoIFP(io)))
2499                    PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
2500               if ((PL_unicode & PERL_UNICODE_STDOUT_FLAG) &&
2501                   PL_defoutgv && (io = GvIO(PL_defoutgv)) &&
2502                   (fp = IoOFP(io)))
2503                    PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
2504               if ((PL_unicode & PERL_UNICODE_STDERR_FLAG) &&
2505                   PL_stderrgv && (io = GvIO(PL_stderrgv)) &&
2506                   (fp = IoOFP(io)))
2507                    PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
2508               if ((PL_unicode & PERL_UNICODE_INOUT_FLAG) &&
2509                   (sv = GvSV(gv_fetchpvs("\017PEN", GV_ADD|GV_NOTQUAL,
2510                                          SVt_PV)))) {
2511                    U32 in  = PL_unicode & PERL_UNICODE_IN_FLAG;
2512                    U32 out = PL_unicode & PERL_UNICODE_OUT_FLAG;
2513                    if (in) {
2514                         if (out)
2515                              sv_setpvs(sv, ":utf8\0:utf8");
2516                         else
2517                              sv_setpvs(sv, ":utf8\0");
2518                    }
2519                    else if (out)
2520                         sv_setpvs(sv, "\0:utf8");
2521                    SvSETMAGIC(sv);
2522               }
2523          }
2524     }
2525 #endif
2526
2527     {
2528         const char *s;
2529     if ((s = PerlEnv_getenv("PERL_SIGNALS"))) {
2530          if (strEQ(s, "unsafe"))
2531               PL_signals |=  PERL_SIGNALS_UNSAFE_FLAG;
2532          else if (strEQ(s, "safe"))
2533               PL_signals &= ~PERL_SIGNALS_UNSAFE_FLAG;
2534          else
2535               Perl_croak(aTHX_ "PERL_SIGNALS illegal: \"%s\"", s);
2536     }
2537     }
2538
2539
2540     lex_start(linestr_sv, rsfp, lex_start_flags);
2541     SvREFCNT_dec(linestr_sv);
2542
2543     PL_subname = newSVpvs("main");
2544
2545     if (add_read_e_script)
2546         filter_add(read_e_script, NULL);
2547
2548     /* now parse the script */
2549
2550     SETERRNO(0,SS_NORMAL);
2551     if (yyparse(GRAMPROG) || PL_parser->error_count) {
2552         abort_execution("", PL_origfilename);
2553     }
2554     CopLINE_set(PL_curcop, 0);
2555     SET_CURSTASH(PL_defstash);
2556     if (PL_e_script) {
2557         SvREFCNT_dec(PL_e_script);
2558         PL_e_script = NULL;
2559     }
2560
2561     if (PL_do_undump)
2562         my_unexec();
2563
2564     if (isWARN_ONCE) {
2565         SAVECOPFILE(PL_curcop);
2566         SAVECOPLINE(PL_curcop);
2567         gv_check(PL_defstash);
2568     }
2569
2570     LEAVE;
2571     FREETMPS;
2572
2573 #ifdef MYMALLOC
2574     {
2575         const char *s;
2576         UV uv;
2577         s = PerlEnv_getenv("PERL_DEBUG_MSTATS");
2578         if (s && grok_atoUV(s, &uv, NULL) && uv >= 2)
2579             dump_mstats("after compilation:");
2580     }
2581 #endif
2582
2583     ENTER;
2584     PL_restartjmpenv = NULL;
2585     PL_restartop = 0;
2586     return NULL;
2587 }
2588
2589 /*
2590 =for apidoc Am|int|perl_run|PerlInterpreter *my_perl
2591
2592 Tells a Perl interpreter to run its main program.  See L<perlembed>
2593 for a tutorial.
2594
2595 C<my_perl> points to the Perl interpreter.  It must have been previously
2596 created through the use of L</perl_alloc> and L</perl_construct>, and
2597 initialised through L</perl_parse>.  This function should not be called
2598 if L</perl_parse> returned a non-zero value, indicating a failure in
2599 initialisation or compilation.
2600
2601 This function executes code in C<INIT> blocks, and then executes the
2602 main program.  The code to be executed is that established by the prior
2603 call to L</perl_parse>.  If the interpreter's C<PL_exit_flags> word
2604 does not have the C<PERL_EXIT_DESTRUCT_END> flag set, then this function
2605 will also execute code in C<END> blocks.  If it is desired to make any
2606 further use of the interpreter after calling this function, then C<END>
2607 blocks should be postponed to L</perl_destruct> time by setting that flag.
2608
2609 Returns an integer of slightly tricky interpretation.  The correct use
2610 of the return value is as a truth value indicating whether the program
2611 terminated non-locally.  If zero is returned, this indicates that
2612 the program ran to completion, and it is safe to make other use of the
2613 interpreter (provided that the C<PERL_EXIT_DESTRUCT_END> flag was set as
2614 described above).  If a non-zero value is returned, this indicates that
2615 the interpreter wants to terminate early.  The interpreter should not be
2616 just abandoned because of this desire to terminate; the caller should
2617 proceed to shut the interpreter down cleanly with L</perl_destruct>
2618 and free it with L</perl_free>.
2619
2620 For historical reasons, the non-zero return value also attempts to
2621 be a suitable value to pass to the C library function C<exit> (or to
2622 return from C<main>), to serve as an exit code indicating the nature of
2623 the way the program terminated.  However, this isn't portable, due to
2624 differing exit code conventions.  An attempt is made to return an exit
2625 code of the type required by the host operating system, but because
2626 it is constrained to be non-zero, it is not necessarily possible to
2627 indicate every type of exit.  It is only reliable on Unix, where a zero
2628 exit code can be augmented with a set bit that will be ignored.  In any
2629 case, this function is not the correct place to acquire an exit code:
2630 one should get that from L</perl_destruct>.
2631
2632 =cut
2633 */
2634
2635 int
2636 perl_run(pTHXx)
2637 {
2638     I32 oldscope;
2639     int ret = 0, exit_called = 0;
2640     dJMPENV;
2641
2642     PERL_ARGS_ASSERT_PERL_RUN;
2643 #ifndef MULTIPLICITY
2644     PERL_UNUSED_ARG(my_perl);
2645 #endif
2646
2647     oldscope = PL_scopestack_ix;
2648 #ifdef VMS
2649     VMSISH_HUSHED = 0;
2650 #endif
2651
2652     JMPENV_PUSH(ret);
2653     switch (ret) {
2654     case 1:
2655         cxstack_ix = -1;                /* start context stack again */
2656         goto redo_body;
2657     case 0:                             /* normal completion */
2658  redo_body:
2659         run_body(oldscope);
2660         goto handle_exit;
2661     case 2:                             /* my_exit() */
2662         exit_called = 1;
2663     handle_exit:
2664         while (PL_scopestack_ix > oldscope)
2665             LEAVE;
2666         FREETMPS;
2667         SET_CURSTASH(PL_defstash);
2668         if (!(PL_exit_flags & PERL_EXIT_DESTRUCT_END) &&
2669             PL_endav && !PL_minus_c) {
2670             PERL_SET_PHASE(PERL_PHASE_END);
2671             call_list(oldscope, PL_endav);
2672         }
2673 #ifdef MYMALLOC
2674         if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
2675             dump_mstats("after execution:  ");
2676 #endif
2677         if (exit_called) {
2678             ret = STATUS_EXIT;
2679             if (ret == 0) ret = 0x100;
2680         } else {
2681             ret = 0;
2682         }
2683         break;
2684     case 3:
2685         if (PL_restartop) {
2686             POPSTACK_TO(PL_mainstack);
2687             goto redo_body;
2688         }
2689         PerlIO_printf(Perl_error_log, "panic: restartop in perl_run\n");
2690         FREETMPS;
2691         ret = 1;
2692         break;
2693     }
2694
2695     JMPENV_POP;
2696     return ret;
2697 }
2698
2699 STATIC void
2700 S_run_body(pTHX_ I32 oldscope)
2701 {
2702     DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support (0x%x).\n",
2703                     PL_sawampersand ? "Enabling" : "Omitting",
2704                     (unsigned int)(PL_sawampersand)));
2705
2706     if (!PL_restartop) {
2707 #ifdef DEBUGGING
2708         if (DEBUG_x_TEST || DEBUG_B_TEST)
2709             dump_all_perl(!DEBUG_B_TEST);
2710         if (!DEBUG_q_TEST)
2711           PERL_DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
2712 #endif
2713
2714         if (PL_minus_c) {
2715             PerlIO_printf(Perl_error_log, "%s syntax OK\n", PL_origfilename);
2716             my_exit(0);
2717         }
2718         if (PERLDB_SINGLE && PL_DBsingle)
2719             PL_DBsingle_iv = 1;
2720         if (PL_initav) {
2721             PERL_SET_PHASE(PERL_PHASE_INIT);
2722             call_list(oldscope, PL_initav);
2723         }
2724 #ifdef PERL_DEBUG_READONLY_OPS
2725         if (PL_main_root && PL_main_root->op_slabbed)
2726             Slab_to_ro(OpSLAB(PL_main_root));
2727 #endif
2728     }
2729
2730     /* do it */
2731
2732     PERL_SET_PHASE(PERL_PHASE_RUN);
2733
2734     if (PL_restartop) {
2735         PL_restartjmpenv = NULL;
2736         PL_op = PL_restartop;
2737         PL_restartop = 0;
2738         CALLRUNOPS(aTHX);
2739     }
2740     else if (PL_main_start) {
2741         CvDEPTH(PL_main_cv) = 1;
2742         PL_op = PL_main_start;
2743         CALLRUNOPS(aTHX);
2744     }
2745     my_exit(0);
2746     NOT_REACHED; /* NOTREACHED */
2747 }
2748
2749 /*
2750 =head1 SV Manipulation Functions
2751
2752 =for apidoc p||get_sv
2753
2754 Returns the SV of the specified Perl scalar.  C<flags> are passed to
2755 C<gv_fetchpv>.  If C<GV_ADD> is set and the
2756 Perl variable does not exist then it will be created.  If C<flags> is zero
2757 and the variable does not exist then NULL is returned.
2758
2759 =cut
2760 */
2761
2762 SV*
2763 Perl_get_sv(pTHX_ const char *name, I32 flags)
2764 {
2765     GV *gv;
2766
2767     PERL_ARGS_ASSERT_GET_SV;
2768
2769     gv = gv_fetchpv(name, flags, SVt_PV);
2770     if (gv)
2771         return GvSV(gv);
2772     return NULL;
2773 }
2774
2775 /*
2776 =head1 Array Manipulation Functions
2777
2778 =for apidoc p||get_av
2779
2780 Returns the AV of the specified Perl global or package array with the given
2781 name (so it won't work on lexical variables).  C<flags> are passed 
2782 to C<gv_fetchpv>.  If C<GV_ADD> is set and the
2783 Perl variable does not exist then it will be created.  If C<flags> is zero
2784 and the variable does not exist then NULL is returned.
2785
2786 Perl equivalent: C<@{"$name"}>.
2787
2788 =cut
2789 */
2790
2791 AV*
2792 Perl_get_av(pTHX_ const char *name, I32 flags)
2793 {
2794     GV* const gv = gv_fetchpv(name, flags, SVt_PVAV);
2795
2796     PERL_ARGS_ASSERT_GET_AV;
2797
2798     if (flags)
2799         return GvAVn(gv);
2800     if (gv)
2801         return GvAV(gv);
2802     return NULL;
2803 }
2804
2805 /*
2806 =head1 Hash Manipulation Functions
2807
2808 =for apidoc p||get_hv
2809
2810 Returns the HV of the specified Perl hash.  C<flags> are passed to
2811 C<gv_fetchpv>.  If C<GV_ADD> is set and the
2812 Perl variable does not exist then it will be created.  If C<flags> is zero
2813 and the variable does not exist then C<NULL> is returned.
2814
2815 =cut
2816 */
2817
2818 HV*
2819 Perl_get_hv(pTHX_ const char *name, I32 flags)
2820 {
2821     GV* const gv = gv_fetchpv(name, flags, SVt_PVHV);
2822
2823     PERL_ARGS_ASSERT_GET_HV;
2824
2825     if (flags)
2826         return GvHVn(gv);
2827     if (gv)
2828         return GvHV(gv);
2829     return NULL;
2830 }
2831
2832 /*
2833 =head1 CV Manipulation Functions
2834
2835 =for apidoc p||get_cvn_flags
2836
2837 Returns the CV of the specified Perl subroutine.  C<flags> are passed to
2838 C<gv_fetchpvn_flags>.  If C<GV_ADD> is set and the Perl subroutine does not
2839 exist then it will be declared (which has the same effect as saying
2840 C<sub name;>).  If C<GV_ADD> is not set and the subroutine does not exist
2841 then NULL is returned.
2842
2843 =for apidoc p||get_cv
2844
2845 Uses C<strlen> to get the length of C<name>, then calls C<get_cvn_flags>.
2846
2847 =cut
2848 */
2849
2850 CV*
2851 Perl_get_cvn_flags(pTHX_ const char *name, STRLEN len, I32 flags)
2852 {
2853     GV* const gv = gv_fetchpvn_flags(name, len, flags, SVt_PVCV);
2854
2855     PERL_ARGS_ASSERT_GET_CVN_FLAGS;
2856
2857     if (gv && UNLIKELY(SvROK(gv)) && SvTYPE(SvRV((SV *)gv)) == SVt_PVCV)
2858         return (CV*)SvRV((SV *)gv);
2859
2860     /* XXX this is probably not what they think they're getting.
2861      * It has the same effect as "sub name;", i.e. just a forward
2862      * declaration! */
2863     if ((flags & ~GV_NOADD_MASK) && !GvCVu(gv)) {
2864         return newSTUB(gv,0);
2865     }
2866     if (gv)
2867         return GvCVu(gv);
2868     return NULL;
2869 }
2870
2871 /* Nothing in core calls this now, but we can't replace it with a macro and
2872    move it to mathoms.c as a macro would evaluate name twice.  */
2873 CV*
2874 Perl_get_cv(pTHX_ const char *name, I32 flags)
2875 {
2876     PERL_ARGS_ASSERT_GET_CV;
2877
2878     return get_cvn_flags(name, strlen(name), flags);
2879 }
2880
2881 /* Be sure to refetch the stack pointer after calling these routines. */
2882
2883 /*
2884
2885 =head1 Callback Functions
2886
2887 =for apidoc p||call_argv
2888
2889 Performs a callback to the specified named and package-scoped Perl subroutine 
2890 with C<argv> (a C<NULL>-terminated array of strings) as arguments.  See
2891 L<perlcall>.
2892
2893 Approximate Perl equivalent: C<&{"$sub_name"}(@$argv)>.
2894
2895 =cut
2896 */
2897
2898 I32
2899 Perl_call_argv(pTHX_ const char *sub_name, I32 flags, char **argv)
2900
2901                         /* See G_* flags in cop.h */
2902                         /* null terminated arg list */
2903 {
2904     dSP;
2905
2906     PERL_ARGS_ASSERT_CALL_ARGV;
2907
2908     PUSHMARK(SP);
2909     while (*argv) {
2910         mXPUSHs(newSVpv(*argv,0));
2911         argv++;
2912     }
2913     PUTBACK;
2914     return call_pv(sub_name, flags);
2915 }
2916
2917 /*
2918 =for apidoc p||call_pv
2919
2920 Performs a callback to the specified Perl sub.  See L<perlcall>.
2921
2922 =cut
2923 */
2924
2925 I32
2926 Perl_call_pv(pTHX_ const char *sub_name, I32 flags)
2927                         /* name of the subroutine */
2928                         /* See G_* flags in cop.h */
2929 {
2930     PERL_ARGS_ASSERT_CALL_PV;
2931
2932     return call_sv(MUTABLE_SV(get_cv(sub_name, GV_ADD)), flags);
2933 }
2934
2935 /*
2936 =for apidoc p||call_method
2937
2938 Performs a callback to the specified Perl method.  The blessed object must
2939 be on the stack.  See L<perlcall>.
2940
2941 =cut
2942 */
2943
2944 I32
2945 Perl_call_method(pTHX_ const char *methname, I32 flags)
2946                         /* name of the subroutine */
2947                         /* See G_* flags in cop.h */
2948 {
2949     STRLEN len;
2950     SV* sv;
2951     PERL_ARGS_ASSERT_CALL_METHOD;
2952
2953     len = strlen(methname);
2954     sv = flags & G_METHOD_NAMED
2955         ? sv_2mortal(newSVpvn_share(methname, len,0))
2956         : newSVpvn_flags(methname, len, SVs_TEMP);
2957
2958     return call_sv(sv, flags | G_METHOD);
2959 }
2960
2961 /* May be called with any of a CV, a GV, or an SV containing the name. */
2962 /*
2963 =for apidoc p||call_sv
2964
2965 Performs a callback to the Perl sub specified by the SV.
2966
2967 If neither the C<G_METHOD> nor C<G_METHOD_NAMED> flag is supplied, the
2968 SV may be any of a CV, a GV, a reference to a CV, a reference to a GV
2969 or C<SvPV(sv)> will be used as the name of the sub to call.
2970
2971 If the C<G_METHOD> flag is supplied, the SV may be a reference to a CV or
2972 C<SvPV(sv)> will be used as the name of the method to call.
2973
2974 If the C<G_METHOD_NAMED> flag is supplied, C<SvPV(sv)> will be used as
2975 the name of the method to call.
2976
2977 Some other values are treated specially for internal use and should
2978 not be depended on.
2979
2980 See L<perlcall>.
2981
2982 =cut
2983 */
2984
2985 I32
2986 Perl_call_sv(pTHX_ SV *sv, volatile I32 flags)
2987                         /* See G_* flags in cop.h */
2988 {
2989     dVAR;
2990     LOGOP myop;         /* fake syntax tree node */
2991     METHOP method_op;
2992     I32 oldmark;
2993     volatile I32 retval = 0;
2994     bool oldcatch = CATCH_GET;
2995     int ret;
2996     OP* const oldop = PL_op;
2997     dJMPENV;
2998
2999     PERL_ARGS_ASSERT_CALL_SV;
3000
3001     if (flags & G_DISCARD) {
3002         ENTER;
3003         SAVETMPS;
3004     }
3005     if (!(flags & G_WANT)) {
3006         /* Backwards compatibility - as G_SCALAR was 0, it could be omitted.
3007          */
3008         flags |= G_SCALAR;
3009     }
3010
3011     Zero(&myop, 1, LOGOP);
3012     if (!(flags & G_NOARGS))
3013         myop.op_flags |= OPf_STACKED;
3014     myop.op_flags |= OP_GIMME_REVERSE(flags);
3015     SAVEOP();
3016     PL_op = (OP*)&myop;
3017
3018     if (!(flags & G_METHOD_NAMED)) {
3019         dSP;
3020         EXTEND(SP, 1);
3021         PUSHs(sv);
3022         PUTBACK;
3023     }
3024     oldmark = TOPMARK;
3025
3026     if (PERLDB_SUB && PL_curstash != PL_debstash
3027            /* Handle first BEGIN of -d. */
3028           && (PL_DBcv || (PL_DBcv = GvCV(PL_DBsub)))
3029            /* Try harder, since this may have been a sighandler, thus
3030             * curstash may be meaningless. */
3031           && (SvTYPE(sv) != SVt_PVCV || CvSTASH((const CV *)sv) != PL_debstash)
3032           && !(flags & G_NODEBUG))
3033         myop.op_private |= OPpENTERSUB_DB;
3034
3035     if (flags & (G_METHOD|G_METHOD_NAMED)) {
3036         Zero(&method_op, 1, METHOP);
3037         method_op.op_next = (OP*)&myop;
3038         PL_op = (OP*)&method_op;
3039         if ( flags & G_METHOD_NAMED ) {
3040             method_op.op_ppaddr = PL_ppaddr[OP_METHOD_NAMED];
3041             method_op.op_type = OP_METHOD_NAMED;
3042             method_op.op_u.op_meth_sv = sv;
3043         } else {
3044             method_op.op_ppaddr = PL_ppaddr[OP_METHOD];
3045             method_op.op_type = OP_METHOD;
3046         }
3047         myop.op_ppaddr = PL_ppaddr[OP_ENTERSUB];
3048         myop.op_type = OP_ENTERSUB;
3049     }
3050
3051     if (!(flags & G_EVAL)) {
3052         CATCH_SET(TRUE);
3053         CALL_BODY_SUB((OP*)&myop);
3054         retval = PL_stack_sp - (PL_stack_base + oldmark);
3055         CATCH_SET(oldcatch);
3056     }
3057     else {
3058         I32 old_cxix;
3059         myop.op_other = (OP*)&myop;
3060         (void)POPMARK;
3061         old_cxix = cxstack_ix;
3062         create_eval_scope(NULL, flags|G_FAKINGEVAL);
3063         INCMARK;
3064
3065         JMPENV_PUSH(ret);
3066
3067         switch (ret) {
3068         case 0:
3069  redo_body:
3070             CALL_BODY_SUB((OP*)&myop);
3071             retval = PL_stack_sp - (PL_stack_base + oldmark);
3072             if (!(flags & G_KEEPERR)) {
3073                 CLEAR_ERRSV();
3074             }
3075             break;
3076         case 1:
3077             STATUS_ALL_FAILURE;
3078             /* FALLTHROUGH */
3079         case 2:
3080             /* my_exit() was called */
3081             SET_CURSTASH(PL_defstash);
3082             FREETMPS;
3083             JMPENV_POP;
3084             my_exit_jump();
3085             NOT_REACHED; /* NOTREACHED */
3086         case 3:
3087             if (PL_restartop) {
3088                 PL_restartjmpenv = NULL;
3089                 PL_op = PL_restartop;
3090                 PL_restartop = 0;
3091                 goto redo_body;
3092             }
3093             PL_stack_sp = PL_stack_base + oldmark;
3094             if ((flags & G_WANT) == G_ARRAY)
3095                 retval = 0;
3096             else {
3097                 retval = 1;
3098                 *++PL_stack_sp = &PL_sv_undef;
3099             }
3100             break;
3101         }
3102
3103         /* if we croaked, depending on how we croaked the eval scope
3104          * may or may not have already been popped */
3105         if (cxstack_ix > old_cxix) {
3106             assert(cxstack_ix == old_cxix + 1);
3107             assert(CxTYPE(CX_CUR()) == CXt_EVAL);
3108             delete_eval_scope();
3109         }
3110         JMPENV_POP;
3111     }
3112
3113     if (flags & G_DISCARD) {
3114         PL_stack_sp = PL_stack_base + oldmark;
3115         retval = 0;
3116         FREETMPS;
3117         LEAVE;
3118     }
3119     PL_op = oldop;
3120     return retval;
3121 }
3122
3123 /* Eval a string. The G_EVAL flag is always assumed. */
3124
3125 /*
3126 =for apidoc p||eval_sv
3127
3128 Tells Perl to C<eval> the string in the SV.  It supports the same flags
3129 as C<call_sv>, with the obvious exception of C<G_EVAL>.  See L<perlcall>.
3130
3131 =cut
3132 */
3133
3134 I32
3135 Perl_eval_sv(pTHX_ SV *sv, I32 flags)
3136
3137                         /* See G_* flags in cop.h */
3138 {
3139     dVAR;
3140     UNOP myop;          /* fake syntax tree node */
3141     volatile I32 oldmark;
3142     volatile I32 retval = 0;
3143     int ret;
3144     OP* const oldop = PL_op;
3145     dJMPENV;
3146
3147     PERL_ARGS_ASSERT_EVAL_SV;
3148
3149     if (flags & G_DISCARD) {
3150         ENTER;
3151         SAVETMPS;
3152     }
3153
3154     SAVEOP();
3155     PL_op = (OP*)&myop;
3156     Zero(&myop, 1, UNOP);
3157     {
3158         dSP;
3159         oldmark = SP - PL_stack_base;
3160         EXTEND(SP, 1);
3161         PUSHs(sv);
3162         PUTBACK;
3163     }
3164
3165     if (!(flags & G_NOARGS))
3166         myop.op_flags = OPf_STACKED;
3167     myop.op_type = OP_ENTEREVAL;
3168     myop.op_flags |= OP_GIMME_REVERSE(flags);
3169     if (flags & G_KEEPERR)
3170         myop.op_flags |= OPf_SPECIAL;
3171
3172     if (flags & G_RE_REPARSING)
3173         myop.op_private = (OPpEVAL_COPHH | OPpEVAL_RE_REPARSING);
3174
3175     /* fail now; otherwise we could fail after the JMPENV_PUSH but
3176      * before a cx_pusheval(), which corrupts the stack after a croak */
3177     TAINT_PROPER("eval_sv()");
3178
3179     JMPENV_PUSH(ret);
3180     switch (ret) {
3181     case 0:
3182  redo_body:
3183         if (PL_op == (OP*)(&myop)) {
3184             PL_op = PL_ppaddr[OP_ENTEREVAL](aTHX);
3185             if (!PL_op)
3186                 goto fail; /* failed in compilation */
3187         }
3188         CALLRUNOPS(aTHX);
3189         retval = PL_stack_sp - (PL_stack_base + oldmark);
3190         if (!(flags & G_KEEPERR)) {
3191             CLEAR_ERRSV();
3192         }
3193         break;
3194     case 1:
3195         STATUS_ALL_FAILURE;
3196         /* FALLTHROUGH */
3197     case 2:
3198         /* my_exit() was called */
3199         SET_CURSTASH(PL_defstash);
3200         FREETMPS;
3201         JMPENV_POP;
3202         my_exit_jump();
3203         NOT_REACHED; /* NOTREACHED */
3204     case 3:
3205         if (PL_restartop) {
3206             PL_restartjmpenv = NULL;
3207             PL_op = PL_restartop;
3208             PL_restartop = 0;
3209             goto redo_body;
3210         }
3211       fail:
3212         PL_stack_sp = PL_stack_base + oldmark;
3213         if ((flags & G_WANT) == G_ARRAY)
3214             retval = 0;
3215         else {
3216             retval = 1;
3217             *++PL_stack_sp = &PL_sv_undef;
3218         }
3219         break;
3220     }
3221
3222     JMPENV_POP;
3223     if (flags & G_DISCARD) {
3224         PL_stack_sp = PL_stack_base + oldmark;
3225         retval = 0;
3226         FREETMPS;
3227         LEAVE;
3228     }
3229     PL_op = oldop;
3230     return retval;
3231 }
3232
3233 /*
3234 =for apidoc p||eval_pv
3235
3236 Tells Perl to C<eval> the given string in scalar context and return an SV* result.
3237
3238 =cut
3239 */
3240
3241 SV*
3242 Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error)
3243 {
3244     SV* sv = newSVpv(p, 0);
3245
3246     PERL_ARGS_ASSERT_EVAL_PV;
3247
3248     eval_sv(sv, G_SCALAR);
3249     SvREFCNT_dec(sv);
3250
3251     {
3252         dSP;
3253         sv = POPs;
3254         PUTBACK;
3255     }
3256
3257     /* just check empty string or undef? */
3258     if (croak_on_error) {
3259         SV * const errsv = ERRSV;
3260         if(SvTRUE_NN(errsv))
3261             /* replace with croak_sv? */
3262             Perl_croak_nocontext("%s", SvPV_nolen_const(errsv));
3263     }
3264
3265     return sv;
3266 }
3267
3268 /* Require a module. */
3269
3270 /*
3271 =head1 Embedding Functions
3272
3273 =for apidoc p||require_pv
3274
3275 Tells Perl to C<require> the file named by the string argument.  It is
3276 analogous to the Perl code C<eval "require '$file'">.  It's even
3277 implemented that way; consider using load_module instead.
3278
3279 =cut */
3280
3281 void
3282 Perl_require_pv(pTHX_ const char *pv)
3283 {
3284     dSP;
3285     SV* sv;
3286
3287     PERL_ARGS_ASSERT_REQUIRE_PV;
3288
3289     PUSHSTACKi(PERLSI_REQUIRE);
3290     sv = Perl_newSVpvf(aTHX_ "require q%c%s%c", 0, pv, 0);
3291     eval_sv(sv_2mortal(sv), G_DISCARD);
3292     POPSTACK;
3293 }
3294
3295 STATIC void
3296 S_usage(pTHX)           /* XXX move this out into a module ? */
3297 {
3298     /* This message really ought to be max 23 lines.
3299      * Removed -h because the user already knows that option. Others? */
3300
3301     /* Grouped as 6 lines per C string literal, to keep under the ANSI C 89
3302        minimum of 509 character string literals.  */
3303     static const char * const usage_msg[] = {
3304 "  -0[octal]         specify record separator (\\0, if no argument)\n"
3305 "  -a                autosplit mode with -n or -p (splits $_ into @F)\n"
3306 "  -C[number/list]   enables the listed Unicode features\n"
3307 "  -c                check syntax only (runs BEGIN and CHECK blocks)\n"
3308 "  -d[:debugger]     run program under debugger\n"
3309 "  -D[number/list]   set debugging flags (argument is a bit mask or alphabets)\n",
3310 "  -e program        one line of program (several -e's allowed, omit programfile)\n"
3311 "  -E program        like -e, but enables all optional features\n"
3312 "  -f                don't do $sitelib/sitecustomize.pl at startup\n"
3313 "  -F/pattern/       split() pattern for -a switch (//'s are optional)\n"
3314 "  -i[extension]     edit <> files in place (makes backup if extension supplied)\n"
3315 "  -Idirectory       specify @INC/#include directory (several -I's allowed)\n",
3316 "  -l[octal]         enable line ending processing, specifies line terminator\n"
3317 "  -[mM][-]module    execute \"use/no module...\" before executing program\n"
3318 "  -n                assume \"while (<>) { ... }\" loop around program\n"
3319 "  -p                assume loop like -n but print line also, like sed\n"
3320 "  -s                enable rudimentary parsing for switches after programfile\n"
3321 "  -S                look for programfile using PATH environment variable\n",
3322 "  -t                enable tainting warnings\n"
3323 "  -T                enable tainting checks\n"
3324 "  -u                dump core after parsing program\n"
3325 "  -U                allow unsafe operations\n"
3326 "  -v                print version, patchlevel and license\n"
3327 "  -V[:variable]     print configuration summary (or a single Config.pm variable)\n",
3328 "  -w                enable many useful warnings\n"
3329 "  -W                enable all warnings\n"
3330 "  -x[directory]     ignore text before #!perl line (optionally cd to directory)\n"
3331 "  -X                disable all warnings\n"
3332 "  \n"
3333 "Run 'perldoc perl' for more help with Perl.\n\n",
3334 NULL
3335 };
3336     const char * const *p = usage_msg;
3337     PerlIO *out = PerlIO_stdout();
3338
3339     PerlIO_printf(out,
3340                   "\nUsage: %s [switches] [--] [programfile] [arguments]\n",
3341                   PL_origargv[0]);
3342     while (*p)
3343         PerlIO_puts(out, *p++);
3344     my_exit(0);
3345 }
3346
3347 /* convert a string of -D options (or digits) into an int.
3348  * sets *s to point to the char after the options */
3349
3350 #ifdef DEBUGGING
3351 int
3352 Perl_get_debug_opts(pTHX_ const char **s, bool givehelp)
3353 {
3354     static const char * const usage_msgd[] = {
3355       " Debugging flag values: (see also -d)\n"
3356       "  p  Tokenizing and parsing (with v, displays parse stack)\n"
3357       "  s  Stack snapshots (with v, displays all stacks)\n"
3358       "  l  Context (loop) stack processing\n"
3359       "  t  Trace execution\n"
3360       "  o  Method and overloading resolution\n",
3361       "  c  String/numeric conversions\n"
3362       "  P  Print profiling info, source file input state\n"
3363       "  m  Memory and SV allocation\n"
3364       "  f  Format processing\n"
3365       "  r  Regular expression parsing and execution\n"
3366       "  x  Syntax tree dump\n",
3367       "  u  Tainting checks\n"
3368       "  H  Hash dump -- usurps values()\n"
3369       "  X  Scratchpad allocation\n"
3370       "  D  Cleaning up\n"
3371       "  S  Op slab allocation\n"
3372       "  T  Tokenising\n"
3373       "  R  Include reference counts of dumped variables (eg when using -Ds)\n",
3374       "  J  Do not s,t,P-debug (Jump over) opcodes within package DB\n"
3375       "  v  Verbose: use in conjunction with other flags\n"
3376       "  C  Copy On Write\n"
3377       "  A  Consistency checks on internal structures\n"
3378       "  q  quiet - currently only suppresses the 'EXECUTING' message\n"
3379       "  M  trace smart match resolution\n"
3380       "  B  dump suBroutine definitions, including special Blocks like BEGIN\n",
3381       "  L  trace some locale setting information--for Perl core development\n",
3382       "  i  trace PerlIO layer processing\n",
3383       NULL
3384     };
3385     UV uv = 0;
3386
3387     PERL_ARGS_ASSERT_GET_DEBUG_OPTS;
3388
3389     if (isALPHA(**s)) {
3390         /* if adding extra options, remember to update DEBUG_MASK */
3391         static const char debopts[] = "psltocPmfrxuUHXDSTRJvCAqMBLi";
3392
3393         for (; isWORDCHAR(**s); (*s)++) {
3394             const char * const d = strchr(debopts,**s);
3395             if (d)
3396                 uv |= 1 << (d - debopts);
3397             else if (ckWARN_d(WARN_DEBUGGING))
3398                 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
3399                     "invalid option -D%c, use -D'' to see choices\n", **s);
3400         }
3401     }
3402     else if (isDIGIT(**s)) {
3403         const char* e;
3404         if (grok_atoUV(*s, &uv, &e))
3405             *s = e;
3406         for (; isWORDCHAR(**s); (*s)++) ;
3407     }
3408     else if (givehelp) {
3409       const char *const *p = usage_msgd;
3410       while (*p) PerlIO_puts(PerlIO_stdout(), *p++);
3411     }
3412     return (int)uv; /* ignore any UV->int conversion loss */
3413 }
3414 #endif
3415
3416 /* This routine handles any switches that can be given during run */
3417
3418 const char *
3419 Perl_moreswitches(pTHX_ const char *s)
3420 {
3421     dVAR;
3422     UV rschar;
3423     const char option = *s; /* used to remember option in -m/-M code */
3424
3425     PERL_ARGS_ASSERT_MORESWITCHES;
3426
3427     switch (*s) {
3428     case '0':
3429     {
3430          I32 flags = 0;
3431          STRLEN numlen;
3432
3433          SvREFCNT_dec(PL_rs);
3434          if (s[1] == 'x' && s[2]) {
3435               const char *e = s+=2;
3436               U8 *tmps;
3437
3438               while (*e)
3439                 e++;
3440               numlen = e - s;
3441               flags = PERL_SCAN_SILENT_ILLDIGIT;
3442               rschar = (U32)grok_hex(s, &numlen, &flags, NULL);
3443               if (s + numlen < e) {
3444                    rschar = 0; /* Grandfather -0xFOO as -0 -xFOO. */
3445                    numlen = 0;
3446                    s--;
3447               }
3448               PL_rs = newSVpvs("");
3449               tmps = (U8*) SvGROW(PL_rs, (STRLEN)(UVCHR_SKIP(rschar) + 1));
3450               uvchr_to_utf8(tmps, rschar);
3451               SvCUR_set(PL_rs, UVCHR_SKIP(rschar));
3452               SvUTF8_on(PL_rs);
3453          }
3454          else {
3455               numlen = 4;
3456               rschar = (U32)grok_oct(s, &numlen, &flags, NULL);
3457               if (rschar & ~((U8)~0))
3458                    PL_rs = &PL_sv_undef;
3459               else if (!rschar && numlen >= 2)
3460                    PL_rs = newSVpvs("");
3461               else {
3462                    char ch = (char)rschar;
3463                    PL_rs = newSVpvn(&ch, 1);
3464               }
3465          }
3466          sv_setsv(get_sv("/", GV_ADD), PL_rs);
3467          return s + numlen;
3468     }
3469     case 'C':
3470         s++;
3471         PL_unicode = parse_unicode_opts( (const char **)&s );
3472         if (PL_unicode & PERL_UNICODE_UTF8CACHEASSERT_FLAG)
3473             PL_utf8cache = -1;
3474         return s;
3475     case 'F':
3476         PL_minus_a = TRUE;
3477         PL_minus_F = TRUE;
3478         PL_minus_n = TRUE;
3479         PL_splitstr = ++s;
3480         while (*s && !isSPACE(*s)) ++s;
3481         PL_splitstr = savepvn(PL_splitstr, s - PL_splitstr);
3482         return s;
3483     case 'a':
3484         PL_minus_a = TRUE;
3485         PL_minus_n = TRUE;
3486         s++;
3487         return s;
3488     case 'c':
3489         PL_minus_c = TRUE;
3490         s++;
3491         return s;
3492     case 'd':
3493         forbid_setid('d', FALSE);
3494         s++;
3495
3496         /* -dt indicates to the debugger that threads will be used */
3497         if (*s == 't' && !isWORDCHAR(s[1])) {
3498             ++s;
3499             my_setenv("PERL5DB_THREADED", "1");
3500         }
3501
3502         /* The following permits -d:Mod to accepts arguments following an =
3503            in the fashion that -MSome::Mod does. */
3504         if (*s == ':' || *s == '=') {
3505             const char *start;
3506             const char *end;
3507             SV *sv;
3508
3509             if (*++s == '-') {
3510                 ++s;
3511                 sv = newSVpvs("no Devel::");
3512             } else {
3513                 sv = newSVpvs("use Devel::");
3514             }
3515
3516             start = s;
3517             end = s + strlen(s);
3518
3519             /* We now allow -d:Module=Foo,Bar and -d:-Module */
3520             while(isWORDCHAR(*s) || *s==':') ++s;
3521             if (*s != '=')
3522                 sv_catpvn(sv, start, end - start);
3523             else {
3524                 sv_catpvn(sv, start, s-start);
3525                 /* Don't use NUL as q// delimiter here, this string goes in the
3526                  * environment. */
3527                 Perl_sv_catpvf(aTHX_ sv, " split(/,/,q{%s});", ++s);
3528             }
3529             s = end;
3530             my_setenv("PERL5DB", SvPV_nolen_const(sv));
3531             SvREFCNT_dec(sv);
3532         }
3533         if (!PL_perldb) {
3534             PL_perldb = PERLDB_ALL;
3535             init_debugger();
3536         }
3537         return s;
3538     case 'D':
3539     {   
3540 #ifdef DEBUGGING
3541         forbid_setid('D', FALSE);
3542         s++;
3543         PL_debug = get_debug_opts( (const char **)&s, 1) | DEBUG_TOP_FLAG;
3544 #else /* !DEBUGGING */
3545         if (ckWARN_d(WARN_DEBUGGING))
3546             Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
3547                    "Recompile perl with -DDEBUGGING to use -D switch (did you mean -d ?)\n");
3548         for (s++; isWORDCHAR(*s); s++) ;
3549 #endif
3550         return s;
3551         NOT_REACHED; /* NOTREACHED */
3552     }   
3553     case 'h':
3554         usage();
3555         NOT_REACHED; /* NOTREACHED */
3556
3557     case 'i':
3558         Safefree(PL_inplace);
3559         {
3560             const char * const start = ++s;
3561             while (*s && !isSPACE(*s))
3562                 ++s;
3563
3564             PL_inplace = savepvn(start, s - start);
3565         }
3566         return s;
3567     case 'I':   /* -I handled both here and in parse_body() */
3568         forbid_setid('I', FALSE);
3569         ++s;
3570         while (*s && isSPACE(*s))
3571             ++s;
3572         if (*s) {
3573             const char *e, *p;
3574             p = s;
3575             /* ignore trailing spaces (possibly followed by other switches) */
3576             do {
3577                 for (e = p; *e && !isSPACE(*e); e++) ;
3578                 p = e;
3579                 while (isSPACE(*p))
3580                     p++;
3581             } while (*p && *p != '-');
3582             incpush(s, e-s,
3583                     INCPUSH_ADD_SUB_DIRS|INCPUSH_ADD_OLD_VERS|INCPUSH_UNSHIFT);
3584             s = p;
3585             if (*s == '-')
3586                 s++;
3587         }
3588         else
3589             Perl_croak(aTHX_ "No directory specified for -I");
3590         return s;
3591     case 'l':
3592         PL_minus_l = TRUE;
3593         s++;
3594         if (PL_ors_sv) {
3595             SvREFCNT_dec(PL_ors_sv);
3596             PL_ors_sv = NULL;
3597         }
3598         if (isDIGIT(*s)) {
3599             I32 flags = 0;
3600             STRLEN numlen;
3601             PL_ors_sv = newSVpvs("\n");
3602             numlen = 3 + (*s == '0');
3603             *SvPVX(PL_ors_sv) = (char)grok_oct(s, &numlen, &flags, NULL);
3604             s += numlen;
3605         }
3606         else {
3607             if (RsPARA(PL_rs)) {
3608                 PL_ors_sv = newSVpvs("\n\n");
3609             }
3610             else {
3611                 PL_ors_sv = newSVsv(PL_rs);
3612             }
3613         }
3614         return s;
3615     case 'M':
3616         forbid_setid('M', FALSE);       /* XXX ? */
3617         /* FALLTHROUGH */
3618     case 'm':
3619         forbid_setid('m', FALSE);       /* XXX ? */
3620         if (*++s) {
3621             const char *start;
3622             const char *end;
3623             SV *sv;
3624             const char *use = "use ";
3625             bool colon = FALSE;
3626             /* -M-foo == 'no foo'       */
3627             /* Leading space on " no " is deliberate, to make both
3628                possibilities the same length.  */
3629             if (*s == '-') { use = " no "; ++s; }
3630             sv = newSVpvn(use,4);
3631             start = s;
3632             /* We allow -M'Module qw(Foo Bar)'  */
3633             while(isWORDCHAR(*s) || *s==':') {
3634                 if( *s++ == ':' ) {
3635                     if( *s == ':' ) 
3636                         s++;
3637                     else
3638                         colon = TRUE;
3639                 }
3640             }
3641             if (s == start)
3642                 Perl_croak(aTHX_ "Module name required with -%c option",
3643                                     option);
3644             if (colon) 
3645                 Perl_croak(aTHX_ "Invalid module name %.*s with -%c option: "
3646                                     "contains single ':'",
3647                                     (int)(s - start), start, option);
3648             end = s + strlen(s);
3649             if (*s != '=') {
3650                 sv_catpvn(sv, start, end - start);
3651                 if (option == 'm') {
3652                     if (*s != '\0')
3653                         Perl_croak(aTHX_ "Can't use '%c' after -mname", *s);
3654                     sv_catpvs( sv, " ()");
3655                 }
3656             } else {
3657                 sv_catpvn(sv, start, s-start);
3658                 /* Use NUL as q''-delimiter.  */
3659                 sv_catpvs(sv, " split(/,/,q\0");
3660                 ++s;
3661                 sv_catpvn(sv, s, end - s);
3662                 sv_catpvs(sv,  "\0)");
3663             }
3664             s = end;
3665             Perl_av_create_and_push(aTHX_ &PL_preambleav, sv);
3666         }
3667         else
3668             Perl_croak(aTHX_ "Missing argument to -%c", option);
3669         return s;
3670     case 'n':
3671         PL_minus_n = TRUE;
3672         s++;
3673         return s;
3674     case 'p':
3675         PL_minus_p = TRUE;
3676         s++;
3677         return s;
3678     case 's':
3679         forbid_setid('s', FALSE);
3680         PL_doswitches = TRUE;
3681         s++;
3682         return s;
3683     case 't':
3684     case 'T':
3685 #if defined(SILENT_NO_TAINT_SUPPORT)
3686             /* silently ignore */
3687 #elif defined(NO_TAINT_SUPPORT)
3688         Perl_croak_nocontext("This perl was compiled without taint support. "
3689                    "Cowardly refusing to run with -t or -T flags");
3690 #else
3691         if (!TAINTING_get)
3692             TOO_LATE_FOR(*s);
3693 #endif
3694         s++;
3695         return s;
3696     case 'u':
3697         PL_do_undump = TRUE;
3698         s++;
3699         return s;
3700     case 'U':
3701         PL_unsafe = TRUE;
3702         s++;
3703         return s;
3704     case 'v':
3705         minus_v();
3706     case 'w':
3707         if (! (PL_dowarn & G_WARN_ALL_MASK)) {
3708             PL_dowarn |= G_WARN_ON;
3709         }
3710         s++;
3711         return s;
3712     case 'W':
3713         PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
3714         if (!specialWARN(PL_compiling.cop_warnings))
3715             PerlMemShared_free(PL_compiling.cop_warnings);
3716         PL_compiling.cop_warnings = pWARN_ALL ;
3717         s++;
3718         return s;
3719     case 'X':
3720         PL_dowarn = G_WARN_ALL_OFF;
3721         if (!specialWARN(PL_compiling.cop_warnings))
3722             PerlMemShared_free(PL_compiling.cop_warnings);
3723         PL_compiling.cop_warnings = pWARN_NONE ;
3724         s++;
3725         return s;
3726     case '*':
3727     case ' ':
3728         while( *s == ' ' )
3729           ++s;
3730         if (s[0] == '-')        /* Additional switches on #! line. */
3731             return s+1;
3732         break;
3733     case '-':
3734     case 0:
3735 #if defined(WIN32) || !defined(PERL_STRICT_CR)
3736     case '\r':
3737 #endif
3738     case '\n':
3739     case '\t':
3740         break;
3741 #ifdef ALTERNATE_SHEBANG
3742     case 'S':                   /* OS/2 needs -S on "extproc" line. */
3743         break;
3744 #endif
3745     case 'e': case 'f': case 'x': case 'E':
3746 #ifndef ALTERNATE_SHEBANG
3747     case 'S':
3748 #endif
3749     case 'V':
3750         Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s);
3751     default:
3752         Perl_croak(aTHX_
3753             "Unrecognized switch: -%.1s  (-h will show valid options)",s
3754         );
3755     }
3756     return NULL;
3757 }
3758
3759
3760 STATIC void
3761 S_minus_v(pTHX)
3762 {
3763         PerlIO * PIO_stdout;
3764         {
3765             const char * const level_str = "v" PERL_VERSION_STRING;
3766             const STRLEN level_len = sizeof("v" PERL_VERSION_STRING)-1;
3767 #ifdef PERL_PATCHNUM
3768             SV* level;
3769 #  ifdef PERL_GIT_UNCOMMITTED_CHANGES
3770             static const char num [] = PERL_PATCHNUM "*";
3771 #  else
3772             static const char num [] = PERL_PATCHNUM;
3773 #  endif
3774             {
3775                 const STRLEN num_len = sizeof(num)-1;
3776                 /* A very advanced compiler would fold away the strnEQ
3777                    and this whole conditional, but most (all?) won't do it.
3778                    SV level could also be replaced by with preprocessor
3779                    catenation.
3780                 */
3781                 if (num_len >= level_len && strnEQ(num,level_str,level_len)) {
3782                     /* per 46807d8e80, PERL_PATCHNUM is outside of the control
3783                        of the interp so it might contain format characters
3784                     */
3785                     level = newSVpvn(num, num_len);
3786                 } else {
3787                     level = Perl_newSVpvf_nocontext("%s (%s)", level_str, num);
3788                 }
3789             }
3790 #else
3791         SV* level = newSVpvn(level_str, level_len);
3792 #endif /* #ifdef PERL_PATCHNUM */
3793         PIO_stdout =  PerlIO_stdout();
3794             PerlIO_printf(PIO_stdout,
3795                 "\nThis is perl "       STRINGIFY(PERL_REVISION)
3796                 ", version "            STRINGIFY(PERL_VERSION)
3797                 ", subversion "         STRINGIFY(PERL_SUBVERSION)
3798                 " (%" SVf ") built for "        ARCHNAME, SVfARG(level)
3799                 );
3800             SvREFCNT_dec_NN(level);
3801         }
3802 #if defined(LOCAL_PATCH_COUNT)
3803         if (LOCAL_PATCH_COUNT > 0)
3804             PerlIO_printf(PIO_stdout,
3805                           "\n(with %d registered patch%s, "
3806                           "see perl -V for more detail)",
3807                           LOCAL_PATCH_COUNT,
3808                           (LOCAL_PATCH_COUNT!=1) ? "es" : "");
3809 #endif
3810
3811         PerlIO_printf(PIO_stdout,
3812                       "\n\nCopyright 1987-2018, Larry Wall\n");
3813 #ifdef MSDOS
3814         PerlIO_printf(PIO_stdout,
3815                       "\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
3816 #endif
3817 #ifdef DJGPP
3818         PerlIO_printf(PIO_stdout,
3819                       "djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n"
3820                       "djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n");
3821 #endif
3822 #ifdef OS2
3823         PerlIO_printf(PIO_stdout,
3824                       "\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
3825                       "Version 5 port Copyright (c) 1994-2002, Andreas Kaiser, Ilya Zakharevich\n");
3826 #endif
3827 #ifdef OEMVS
3828         PerlIO_printf(PIO_stdout,
3829                       "MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
3830 #endif
3831 #ifdef __VOS__
3832         PerlIO_printf(PIO_stdout,
3833                       "Stratus OpenVOS port by Paul.Green@stratus.com, 1997-2013\n");
3834 #endif
3835 #ifdef POSIX_BC
3836         PerlIO_printf(PIO_stdout,
3837                       "BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
3838 #endif
3839 #ifdef UNDER_CE
3840         PerlIO_printf(PIO_stdout,
3841                         "WINCE port by Rainer Keuchel, 2001-2002\n"
3842                         "Built on " __DATE__ " " __TIME__ "\n\n");
3843         wce_hitreturn();
3844 #endif
3845 #ifdef __SYMBIAN32__
3846         PerlIO_printf(PIO_stdout,
3847                       "Symbian port by Nokia, 2004-2005\n");
3848 #endif
3849 #ifdef BINARY_BUILD_NOTICE
3850         BINARY_BUILD_NOTICE;
3851 #endif
3852         PerlIO_printf(PIO_stdout,
3853                       "\n\
3854 Perl may be copied only under the terms of either the Artistic License or the\n\
3855 GNU General Public License, which may be found in the Perl 5 source kit.\n\n\
3856 Complete documentation for Perl, including FAQ lists, should be found on\n\
3857 this system using \"man perl\" or \"perldoc perl\".  If you have access to the\n\
3858 Internet, point your browser at http://www.perl.org/, the Perl Home Page.\n\n");
3859         my_exit(0);
3860 }
3861
3862 /* compliments of Tom Christiansen */
3863
3864 /* unexec() can be found in the Gnu emacs distribution */
3865 /* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
3866
3867 #ifdef VMS
3868 #include <lib$routines.h>
3869 #endif
3870
3871 void
3872 Perl_my_unexec(pTHX)
3873 {
3874 #ifdef UNEXEC
3875     SV *    prog = newSVpv(BIN_EXP, 0);
3876     SV *    file = newSVpv(PL_origfilename, 0);
3877     int    status = 1;
3878     extern int etext;
3879
3880     sv_catpvs(prog, "/perl");
3881     sv_catpvs(file, ".perldump");
3882
3883     unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
3884     /* unexec prints msg to stderr in case of failure */
3885     PerlProc_exit(status);
3886 #else
3887     PERL_UNUSED_CONTEXT;
3888 #  ifdef VMS
3889      lib$signal(SS$_DEBUG);  /* ssdef.h #included from vmsish.h */
3890 #  elif defined(WIN32) || defined(__CYGWIN__)
3891     Perl_croak_nocontext("dump is not supported");
3892 #  else
3893     ABORT();            /* for use with undump */
3894 #  endif
3895 #endif
3896 }
3897
3898 /* initialize curinterp */
3899 STATIC void
3900 S_init_interp(pTHX)
3901 {
3902 #ifdef MULTIPLICITY
3903 #  define PERLVAR(prefix,var,type)
3904 #  define PERLVARA(prefix,var,n,type)
3905 #  if defined(PERL_IMPLICIT_CONTEXT)
3906 #    define PERLVARI(prefix,var,type,init)      aTHX->prefix##var = init;
3907 #    define PERLVARIC(prefix,var,type,init)     aTHX->prefix##var = init;
3908 #  else
3909 #    define PERLVARI(prefix,var,type,init)      PERL_GET_INTERP->var = init;
3910 #    define PERLVARIC(prefix,var,type,init)     PERL_GET_INTERP->var = init;
3911 #  endif
3912 #  include "intrpvar.h"
3913 #  undef PERLVAR
3914 #  undef PERLVARA
3915 #  undef PERLVARI
3916 #  undef PERLVARIC
3917 #else
3918 #  define PERLVAR(prefix,var,type)
3919 #  define PERLVARA(prefix,var,n,type)
3920 #  define PERLVARI(prefix,var,type,init)        PL_##var = init;
3921 #  define PERLVARIC(prefix,var,type,init)       PL_##var = init;
3922 #  include "intrpvar.h"
3923 #  undef PERLVAR
3924 #  undef PERLVARA
3925 #  undef PERLVARI
3926 #  undef PERLVARIC
3927 #endif
3928
3929 }
3930
3931 STATIC void
3932 S_init_main_stash(pTHX)
3933 {
3934     GV *gv;
3935     HV *hv = newHV();
3936
3937     PL_curstash = PL_defstash = (HV *)SvREFCNT_inc_simple_NN(hv);
3938     /* We know that the string "main" will be in the global shared string
3939        table, so it's a small saving to use it rather than allocate another
3940        8 bytes.  */
3941     PL_curstname = newSVpvs_share("main");
3942     gv = gv_fetchpvs("main::", GV_ADD|GV_NOTQUAL, SVt_PVHV);
3943     /* If we hadn't caused another reference to "main" to be in the shared
3944        string table above, then it would be worth reordering these two,
3945        because otherwise all we do is delete "main" from it as a consequence
3946        of the SvREFCNT_dec, only to add it again with hv_name_set */
3947     SvREFCNT_dec(GvHV(gv));
3948     hv_name_sets(PL_defstash, "main", 0);
3949     GvHV(gv) = MUTABLE_HV(SvREFCNT_inc_simple(PL_defstash));
3950     SvREADONLY_on(gv);
3951     PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpvs("INC", GV_ADD|GV_NOTQUAL,
3952                                              SVt_PVAV)));
3953     SvREFCNT_inc_simple_void(PL_incgv); /* Don't allow it to be freed */
3954     GvMULTI_on(PL_incgv);
3955     PL_hintgv = gv_fetchpvs("\010", GV_ADD|GV_NOTQUAL, SVt_PV); /* ^H */
3956     SvREFCNT_inc_simple_void(PL_hintgv);
3957     GvMULTI_on(PL_hintgv);
3958     PL_defgv = gv_fetchpvs("_", GV_ADD|GV_NOTQUAL, SVt_PVAV);
3959     SvREFCNT_inc_simple_void(PL_defgv);
3960     PL_errgv = gv_fetchpvs("@", GV_ADD|GV_NOTQUAL, SVt_PV);
3961     SvREFCNT_inc_simple_void(PL_errgv);
3962     GvMULTI_on(PL_errgv);
3963     PL_replgv = gv_fetchpvs("\022", GV_ADD|GV_NOTQUAL, SVt_PV); /* ^R */
3964     SvREFCNT_inc_simple_void(PL_replgv);
3965     GvMULTI_on(PL_replgv);
3966     (void)Perl_form(aTHX_ "%240s","");  /* Preallocate temp - for immediate signals. */
3967 #ifdef PERL_DONT_CREATE_GVSV
3968     (void)gv_SVadd(PL_errgv);
3969 #endif
3970     sv_grow(ERRSV, 240);        /* Preallocate - for immediate signals. */
3971     CLEAR_ERRSV();
3972     CopSTASH_set(&PL_compiling, PL_defstash);
3973     PL_debstash = GvHV(gv_fetchpvs("DB::", GV_ADDMULTI, SVt_PVHV));
3974     PL_globalstash = GvHV(gv_fetchpvs("CORE::GLOBAL::", GV_ADDMULTI,
3975                                       SVt_PVHV));
3976     /* We must init $/ before switches are processed. */
3977     sv_setpvs(get_sv("/", GV_ADD), "\n");
3978 }
3979
3980 STATIC PerlIO *
3981 S_open_script(pTHX_ const char *scriptname, bool dosearch, bool *suidscript)
3982 {
3983     int fdscript = -1;
3984     PerlIO *rsfp = NULL;
3985     Stat_t tmpstatbuf;
3986     int fd;
3987
3988     PERL_ARGS_ASSERT_OPEN_SCRIPT;
3989
3990     if (PL_e_script) {
3991         PL_origfilename = savepvs("-e");
3992     }
3993     else {
3994         const char *s;
3995         UV uv;
3996         /* if find_script() returns, it returns a malloc()-ed value */
3997         scriptname = PL_origfilename = find_script(scriptname, dosearch, NULL, 1);
3998
3999         if (strBEGINs(scriptname, "/dev/fd/")
4000             && isDIGIT(scriptname[8])
4001             && grok_atoUV(scriptname + 8, &uv, &s)
4002             && uv <= PERL_INT_MAX
4003         ) {
4004             fdscript = (int)uv;
4005             if (*s) {
4006                 /* PSz 18 Feb 04
4007                  * Tell apart "normal" usage of fdscript, e.g.
4008                  * with bash on FreeBSD:
4009                  *   perl <( echo '#!perl -DA'; echo 'print "$0\n"')
4010                  * from usage in suidperl.
4011                  * Does any "normal" usage leave garbage after the number???
4012                  * Is it a mistake to use a similar /dev/fd/ construct for
4013                  * suidperl?
4014                  */
4015                 *suidscript = TRUE;
4016                 /* PSz 20 Feb 04  
4017                  * Be supersafe and do some sanity-checks.
4018                  * Still, can we be sure we got the right thing?
4019                  */
4020                 if (*s != '/') {
4021                     Perl_croak(aTHX_ "Wrong syntax (suid) fd script name \"%s\"\n", s);
4022                 }
4023                 if (! *(s+1)) {
4024                     Perl_croak(aTHX_ "Missing (suid) fd script name\n");
4025                 }
4026                 scriptname = savepv(s + 1);
4027                 Safefree(PL_origfilename);
4028                 PL_origfilename = (char *)scriptname;
4029             }
4030         }
4031     }
4032
4033     CopFILE_free(PL_curcop);
4034     CopFILE_set(PL_curcop, PL_origfilename);
4035     if (*PL_origfilename == '-' && PL_origfilename[1] == '\0')
4036         scriptname = (char *)"";
4037     if (fdscript >= 0) {
4038         rsfp = PerlIO_fdopen(fdscript,PERL_SCRIPT_MODE);
4039     }
4040     else if (!*scriptname) {
4041         forbid_setid(0, *suidscript);
4042         return NULL;
4043     }
4044     else {
4045 #ifdef FAKE_BIT_BUCKET
4046         /* This hack allows one not to have /dev/null (or BIT_BUCKET as it
4047          * is called) and still have the "-e" work.  (Believe it or not,
4048          * a /dev/null is required for the "-e" to work because source
4049          * filter magic is used to implement it. ) This is *not* a general
4050          * replacement for a /dev/null.  What we do here is create a temp
4051          * file (an empty file), open up that as the script, and then
4052          * immediately close and unlink it.  Close enough for jazz. */ 
4053 #define FAKE_BIT_BUCKET_PREFIX "/tmp/perlnull-"
4054 #define FAKE_BIT_BUCKET_SUFFIX "XXXXXXXX"
4055 #define FAKE_BIT_BUCKET_TEMPLATE FAKE_BIT_BUCKET_PREFIX FAKE_BIT_BUCKET_SUFFIX
4056         char tmpname[sizeof(FAKE_BIT_BUCKET_TEMPLATE)] = {
4057             FAKE_BIT_BUCKET_TEMPLATE
4058         };
4059         const char * const err = "Failed to create a fake bit bucket";
4060         if (strEQ(scriptname, BIT_BUCKET)) {
4061             int tmpfd = Perl_my_mkstemp_cloexec(tmpname);
4062             if (tmpfd > -1) {
4063                 scriptname = tmpname;
4064                 close(tmpfd);
4065             } else
4066                 Perl_croak(aTHX_ err);
4067         }
4068 #endif
4069         rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
4070 #ifdef FAKE_BIT_BUCKET
4071         if (   strBEGINs(scriptname, FAKE_BIT_BUCKET_PREFIX)
4072             && strlen(scriptname) == sizeof(tmpname) - 1)
4073         {
4074             unlink(scriptname);
4075         }
4076         scriptname = BIT_BUCKET;
4077 #endif
4078     }
4079     if (!rsfp) {
4080         /* PSz 16 Sep 03  Keep neat error message */
4081         if (PL_e_script)
4082             Perl_croak(aTHX_ "Can't open " BIT_BUCKET ": %s\n", Strerror(errno));
4083         else
4084             Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
4085                     CopFILE(PL_curcop), Strerror(errno));
4086     }
4087     fd = PerlIO_fileno(rsfp);
4088
4089     if (fd < 0 ||
4090         (PerlLIO_fstat(fd, &tmpstatbuf) >= 0
4091          && S_ISDIR(tmpstatbuf.st_mode)))
4092         Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
4093             CopFILE(PL_curcop),
4094             Strerror(EISDIR));
4095
4096     return rsfp;
4097 }
4098
4099 /* In the days of suidperl, we refused to execute a setuid script stored on
4100  * a filesystem mounted nosuid and/or noexec. This meant that we probed for the
4101  * existence of the appropriate filesystem-statting function, and behaved
4102  * accordingly. But even though suidperl is long gone, we must still include
4103  * those probes for the benefit of modules like Filesys::Df, which expect the
4104  * results of those probes to be stored in %Config; see RT#126368. So mention
4105  * the relevant cpp symbols here, to ensure that metaconfig will include their
4106  * probes in the generated Configure:
4107  *
4108  * I_SYSSTATVFS HAS_FSTATVFS
4109  * I_SYSMOUNT
4110  * I_STATFS     HAS_FSTATFS     HAS_GETFSSTAT
4111  * I_MNTENT     HAS_GETMNTENT   HAS_HASMNTOPT
4112  */
4113
4114
4115 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
4116 /* Don't even need this function.  */
4117 #else
4118 STATIC void
4119 S_validate_suid(pTHX_ PerlIO *rsfp)
4120 {
4121     const Uid_t  my_uid = PerlProc_getuid();
4122     const Uid_t my_euid = PerlProc_geteuid();
4123     const Gid_t  my_gid = PerlProc_getgid();
4124     const Gid_t my_egid = PerlProc_getegid();
4125
4126     PERL_ARGS_ASSERT_VALIDATE_SUID;
4127
4128     if (my_euid != my_uid || my_egid != my_gid) {       /* (suidperl doesn't exist, in fact) */
4129         dVAR;
4130         int fd = PerlIO_fileno(rsfp);
4131         Stat_t statbuf;
4132         if (fd < 0 || PerlLIO_fstat(fd, &statbuf) < 0) { /* may be either wrapped or real suid */
4133             Perl_croak_nocontext( "Illegal suidscript");
4134         }
4135         if ((my_euid != my_uid && my_euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
4136             ||
4137             (my_egid != my_gid && my_egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
4138             )
4139             if (!PL_do_undump)
4140                 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
4141 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
4142         /* not set-id, must be wrapped */
4143     }
4144 }
4145 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
4146
4147 STATIC void
4148 S_find_beginning(pTHX_ SV* linestr_sv, PerlIO *rsfp)
4149 {
4150     const char *s;
4151     const char *s2;
4152
4153     PERL_ARGS_ASSERT_FIND_BEGINNING;
4154
4155     /* skip forward in input to the real script? */
4156
4157     do {
4158         if ((s = sv_gets(linestr_sv, rsfp, 0)) == NULL)
4159             Perl_croak(aTHX_ "No Perl script found in input\n");
4160         s2 = s;
4161     } while (!(*s == '#' && s[1] == '!' && ((s = instr(s,"perl")) || (s = instr(s2,"PERL")))));
4162     PerlIO_ungetc(rsfp, '\n');          /* to keep line count right */
4163     while (*s && !(isSPACE (*s) || *s == '#')) s++;
4164     s2 = s;
4165     while (*s == ' ' || *s == '\t') s++;
4166     if (*s++ == '-') {
4167         while (isDIGIT(s2[-1]) || s2[-1] == '-' || s2[-1] == '.'
4168                || s2[-1] == '_') s2--;
4169         if (strBEGINs(s2-4,"perl"))
4170             while ((s = moreswitches(s)))
4171                 ;
4172     }
4173 }
4174
4175
4176 STATIC void
4177 S_init_ids(pTHX)
4178 {
4179     /* no need to do anything here any more if we don't
4180      * do tainting. */
4181 #ifndef NO_TAINT_SUPPORT
4182     const Uid_t my_uid = PerlProc_getuid();
4183     const Uid_t my_euid = PerlProc_geteuid();
4184     const Gid_t my_gid = PerlProc_getgid();
4185     const Gid_t my_egid = PerlProc_getegid();
4186
4187     PERL_UNUSED_CONTEXT;
4188
4189     /* Should not happen: */
4190     CHECK_MALLOC_TAINT(my_uid && (my_euid != my_uid || my_egid != my_gid));
4191     TAINTING_set( TAINTING_get | (my_uid && (my_euid != my_uid || my_egid != my_gid)) );
4192 #endif
4193     /* BUG */
4194     /* PSz 27 Feb 04
4195      * Should go by suidscript, not uid!=euid: why disallow
4196      * system("ls") in scripts run from setuid things?
4197      * Or, is this run before we check arguments and set suidscript?
4198      * What about SETUID_SCRIPTS_ARE_SECURE_NOW: could we use fdscript then?
4199      * (We never have suidscript, can we be sure to have fdscript?)
4200      * Or must then go by UID checks? See comments in forbid_setid also.
4201      */
4202 }
4203
4204 /* This is used very early in the lifetime of the program,
4205  * before even the options are parsed, so PL_tainting has
4206  * not been initialized properly.  */
4207 bool
4208 Perl_doing_taint(int argc, char *argv[], char *envp[])
4209 {
4210 #ifndef PERL_IMPLICIT_SYS
4211     /* If we have PERL_IMPLICIT_SYS we can't call getuid() et alia
4212      * before we have an interpreter-- and the whole point of this
4213      * function is to be called at such an early stage.  If you are on
4214      * a system with PERL_IMPLICIT_SYS but you do have a concept of
4215      * "tainted because running with altered effective ids', you'll
4216      * have to add your own checks somewhere in here.  The two most
4217      * known samples of 'implicitness' are Win32 and NetWare, neither
4218      * of which has much of concept of 'uids'. */
4219     Uid_t uid  = PerlProc_getuid();
4220     Uid_t euid = PerlProc_geteuid();
4221     Gid_t gid  = PerlProc_getgid();
4222     Gid_t egid = PerlProc_getegid();
4223     (void)envp;
4224
4225 #ifdef VMS
4226     uid  |=  gid << 16;
4227     euid |= egid << 16;
4228 #endif
4229     if (uid && (euid != uid || egid != gid))
4230         return 1;
4231 #endif /* !PERL_IMPLICIT_SYS */
4232     /* This is a really primitive check; environment gets ignored only
4233      * if -T are the first chars together; otherwise one gets
4234      *  "Too late" message. */
4235     if ( argc > 1 && argv[1][0] == '-'
4236          && isALPHA_FOLD_EQ(argv[1][1], 't'))
4237         return 1;
4238     return 0;
4239 }
4240
4241 /* Passing the flag as a single char rather than a string is a slight space
4242    optimisation.  The only message that isn't /^-.$/ is
4243    "program input from stdin", which is substituted in place of '\0', which
4244    could never be a command line flag.  */
4245 STATIC void
4246 S_forbid_setid(pTHX_ const char flag, const bool suidscript) /* g */
4247 {
4248     char string[3] = "-x";
4249     const char *message = "program input from stdin";
4250
4251     PERL_UNUSED_CONTEXT;
4252     if (flag) {
4253         string[1] = flag;
4254         message = string;
4255     }
4256
4257 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
4258     if (PerlProc_getuid() != PerlProc_geteuid())
4259         Perl_croak(aTHX_ "No %s allowed while running setuid", message);
4260     if (PerlProc_getgid() != PerlProc_getegid())
4261         Perl_croak(aTHX_ "No %s allowed while running setgid", message);
4262 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
4263     if (suidscript)
4264         Perl_croak(aTHX_ "No %s allowed with (suid) fdscript", message);
4265 }
4266
4267 void
4268 Perl_init_dbargs(pTHX)
4269 {
4270     AV *const args = PL_dbargs = GvAV(gv_AVadd((gv_fetchpvs("DB::args",
4271                                                             GV_ADDMULTI,
4272                                                             SVt_PVAV))));
4273
4274     if (AvREAL(args)) {
4275         /* Someone has already created it.
4276            It might have entries, and if we just turn off AvREAL(), they will
4277            "leak" until global destruction.  */
4278         av_clear(args);
4279         if (SvTIED_mg((const SV *)args, PERL_MAGIC_tied))
4280             Perl_croak(aTHX_ "Cannot set tied @DB::args");
4281     }
4282     AvREIFY_only(PL_dbargs);
4283 }
4284
4285 void
4286 Perl_init_debugger(pTHX)
4287 {
4288     HV * const ostash = PL_curstash;
4289     MAGIC *mg;
4290
4291     PL_curstash = (HV *)SvREFCNT_inc_simple(PL_debstash);
4292
4293     Perl_init_dbargs(aTHX);
4294     PL_DBgv = MUTABLE_GV(
4295         SvREFCNT_inc(gv_fetchpvs("DB::DB", GV_ADDMULTI, SVt_PVGV))
4296     );
4297     PL_DBline = MUTABLE_GV(
4298         SvREFCNT_inc(gv_fetchpvs("DB::dbline", GV_ADDMULTI, SVt_PVAV))
4299     );
4300     PL_DBsub = MUTABLE_GV(SvREFCNT_inc(
4301         gv_HVadd(gv_fetchpvs("DB::sub", GV_ADDMULTI, SVt_PVHV))
4302     ));
4303     PL_DBsingle = GvSV((gv_fetchpvs("DB::single", GV_ADDMULTI, SVt_PV)));
4304     if (!SvIOK(PL_DBsingle))
4305         sv_setiv(PL_DBsingle, 0);
4306     mg = sv_magicext(PL_DBsingle, NULL, PERL_MAGIC_debugvar, &PL_vtbl_debugvar, 0, 0);
4307     mg->mg_private = DBVARMG_SINGLE;
4308     SvSETMAGIC(PL_DBsingle);
4309
4310     PL_DBtrace = GvSV((gv_fetchpvs("DB::trace", GV_ADDMULTI, SVt_PV)));
4311     if (!SvIOK(PL_DBtrace))
4312         sv_setiv(PL_DBtrace, 0);
4313     mg = sv_magicext(PL_DBtrace, NULL, PERL_MAGIC_debugvar, &PL_vtbl_debugvar, 0, 0);
4314     mg->mg_private = DBVARMG_TRACE;
4315     SvSETMAGIC(PL_DBtrace);
4316
4317     PL_DBsignal = GvSV((gv_fetchpvs("DB::signal", GV_ADDMULTI, SVt_PV)));
4318     if (!SvIOK(PL_DBsignal))
4319         sv_setiv(PL_DBsignal, 0);
4320     mg = sv_magicext(PL_DBsignal, NULL, PERL_MAGIC_debugvar, &PL_vtbl_debugvar, 0, 0);
4321     mg->mg_private = DBVARMG_SIGNAL;
4322     SvSETMAGIC(PL_DBsignal);
4323
4324     SvREFCNT_dec(PL_curstash);
4325     PL_curstash = ostash;
4326 }
4327
4328 #ifndef STRESS_REALLOC
4329 #define REASONABLE(size) (size)
4330 #define REASONABLE_but_at_least(size,min) (size)
4331 #else
4332 #define REASONABLE(size) (1) /* unreasonable */
4333 #define REASONABLE_but_at_least(size,min) (min)
4334 #endif
4335
4336 void
4337 Perl_init_stacks(pTHX)
4338 {
4339     SSize_t size;
4340
4341     /* start with 128-item stack and 8K cxstack */
4342     PL_curstackinfo = new_stackinfo(REASONABLE(128),
4343                                  REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
4344     PL_curstackinfo->si_type = PERLSI_MAIN;
4345 #if defined DEBUGGING && !defined DEBUGGING_RE_ONLY
4346     PL_curstackinfo->si_stack_hwm = 0;
4347 #endif
4348     PL_curstack = PL_curstackinfo->si_stack;
4349     PL_mainstack = PL_curstack;         /* remember in case we switch stacks */
4350
4351     PL_stack_base = AvARRAY(PL_curstack);
4352     PL_stack_sp = PL_stack_base;
4353     PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
4354
4355     Newx(PL_tmps_stack,REASONABLE(128),SV*);
4356     PL_tmps_floor = -1;
4357     PL_tmps_ix = -1;
4358     PL_tmps_max = REASONABLE(128);
4359
4360     Newx(PL_markstack,REASONABLE(32),I32);
4361     PL_markstack_ptr = PL_markstack;
4362     PL_markstack_max = PL_markstack + REASONABLE(32);
4363
4364     SET_MARK_OFFSET;
4365
4366     Newx(PL_scopestack,REASONABLE(32),I32);
4367 #ifdef DEBUGGING
4368     Newx(PL_scopestack_name,REASONABLE(32),const char*);
4369 #endif
4370     PL_scopestack_ix = 0;
4371     PL_scopestack_max = REASONABLE(32);
4372
4373     size = REASONABLE_but_at_least(128,SS_MAXPUSH);
4374     Newx(PL_savestack, size, ANY);
4375     PL_savestack_ix = 0;
4376     /*PL_savestack_max lies: it always has SS_MAXPUSH more than it claims */
4377     PL_savestack_max = size - SS_MAXPUSH;
4378 }
4379
4380 #undef REASONABLE
4381
4382 STATIC void
4383 S_nuke_stacks(pTHX)
4384 {
4385     while (PL_curstackinfo->si_next)
4386         PL_curstackinfo = PL_curstackinfo->si_next;
4387     while (PL_curstackinfo) {
4388         PERL_SI *p = PL_curstackinfo->si_prev;
4389         /* curstackinfo->si_stack got nuked by sv_free_arenas() */
4390         Safefree(PL_curstackinfo->si_cxstack);
4391         Safefree(PL_curstackinfo);
4392         PL_curstackinfo = p;
4393     }
4394     Safefree(PL_tmps_stack);
4395     Safefree(PL_markstack);
4396     Safefree(PL_scopestack);
4397 #ifdef DEBUGGING
4398     Safefree(PL_scopestack_name);
4399 #endif
4400     Safefree(PL_savestack);
4401 }
4402
4403 void
4404 Perl_populate_isa(pTHX_ const char *name, STRLEN len, ...)
4405 {
4406     GV *const gv = gv_fetchpvn(name, len, GV_ADD | GV_ADDMULTI, SVt_PVAV);
4407     AV *const isa = GvAVn(gv);
4408     va_list args;
4409
4410     PERL_ARGS_ASSERT_POPULATE_ISA;
4411
4412     if(AvFILLp(isa) != -1)
4413         return;
4414
4415     /* NOTE: No support for tied ISA */
4416
4417     va_start(args, len);
4418     do {
4419         const char *const parent = va_arg(args, const char*);
4420         size_t parent_len;
4421
4422         if (!parent)
4423             break;
4424         parent_len = va_arg(args, size_t);
4425
4426         /* Arguments are supplied with a trailing ::  */
4427         assert(parent_len > 2);
4428         assert(parent[parent_len - 1] == ':');
4429         assert(parent[parent_len - 2] == ':');
4430         av_push(isa, newSVpvn(parent, parent_len - 2));
4431         (void) gv_fetchpvn(parent, parent_len, GV_ADD, SVt_PVGV);
4432     } while (1);
4433     va_end(args);
4434 }
4435
4436
4437 STATIC void
4438 S_init_predump_symbols(pTHX)
4439 {
4440     GV *tmpgv;
4441     IO *io;
4442
4443     sv_setpvs(get_sv("\"", GV_ADD), " ");
4444     PL_ofsgv = (GV*)SvREFCNT_inc(gv_fetchpvs(",", GV_ADD|GV_NOTQUAL, SVt_PV));
4445
4446
4447     /* Historically, PVIOs were blessed into IO::Handle, unless
4448        FileHandle was loaded, in which case they were blessed into
4449        that. Action at a distance.
4450        However, if we simply bless into IO::Handle, we break code
4451        that assumes that PVIOs will have (among others) a seek
4452        method. IO::File inherits from IO::Handle and IO::Seekable,
4453        and provides the needed methods. But if we simply bless into
4454        it, then we break code that assumed that by loading
4455        IO::Handle, *it* would work.
4456        So a compromise is to set up the correct @IO::File::ISA,
4457        so that code that does C<use IO::Handle>; will still work.
4458     */
4459                    
4460     Perl_populate_isa(aTHX_ STR_WITH_LEN("IO::File::ISA"),
4461                       STR_WITH_LEN("IO::Handle::"),
4462                       STR_WITH_LEN("IO::Seekable::"),
4463                       STR_WITH_LEN("Exporter::"),
4464                       NULL);
4465
4466     PL_stdingv = gv_fetchpvs("STDIN", GV_ADD|GV_NOTQUAL, SVt_PVIO);
4467     GvMULTI_on(PL_stdingv);
4468     io = GvIOp(PL_stdingv);
4469     IoTYPE(io) = IoTYPE_RDONLY;
4470     IoIFP(io) = PerlIO_stdin();
4471     tmpgv = gv_fetchpvs("stdin", GV_ADD|GV_NOTQUAL, SVt_PV);
4472     GvMULTI_on(tmpgv);
4473     GvIOp(tmpgv) = MUTABLE_IO(SvREFCNT_inc_simple(io));
4474
4475     tmpgv = gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVIO);
4476     GvMULTI_on(tmpgv);
4477     io = GvIOp(tmpgv);
4478     IoTYPE(io) = IoTYPE_WRONLY;
4479     IoOFP(io) = IoIFP(io) = PerlIO_stdout();
4480     setdefout(tmpgv);
4481     tmpgv = gv_fetchpvs("stdout", GV_ADD|GV_NOTQUAL, SVt_PV);
4482     GvMULTI_on(tmpgv);
4483     GvIOp(tmpgv) = MUTABLE_IO(SvREFCNT_inc_simple(io));
4484
4485     PL_stderrgv = gv_fetchpvs("STDERR", GV_ADD|GV_NOTQUAL, SVt_PVIO);
4486     GvMULTI_on(PL_stderrgv);
4487     io = GvIOp(PL_stderrgv);
4488     IoTYPE(io) = IoTYPE_WRONLY;
4489     IoOFP(io) = IoIFP(io) = PerlIO_stderr();
4490     tmpgv = gv_fetchpvs("stderr", GV_ADD|GV_NOTQUAL, SVt_PV);
4491     GvMULTI_on(tmpgv);
4492     GvIOp(tmpgv) = MUTABLE_IO(SvREFCNT_inc_simple(io));
4493
4494     PL_statname = newSVpvs("");         /* last filename we did stat on */
4495 }
4496
4497 void
4498 Perl_init_argv_symbols(pTHX_ int argc, char **argv)
4499 {
4500     PERL_ARGS_ASSERT_INIT_ARGV_SYMBOLS;
4501
4502     argc--,argv++;      /* skip name of script */
4503     if (PL_doswitches) {
4504         for (; argc > 0 && **argv == '-'; argc--,argv++) {
4505             char *s;
4506             if (!argv[0][1])
4507                 break;
4508             if (argv[0][1] == '-' && !argv[0][2]) {
4509                 argc--,argv++;
4510                 break;
4511             }
4512             if ((s = strchr(argv[0], '='))) {
4513                 const char *const start_name = argv[0] + 1;
4514                 sv_setpv(GvSV(gv_fetchpvn_flags(start_name, s - start_name,
4515                                                 TRUE, SVt_PV)), s + 1);
4516             }
4517             else
4518                 sv_setiv(GvSV(gv_fetchpv(argv[0]+1, GV_ADD, SVt_PV)),1);
4519         }
4520     }
4521     if ((PL_argvgv = gv_fetchpvs("ARGV", GV_ADD|GV_NOTQUAL, SVt_PVAV))) {
4522         SvREFCNT_inc_simple_void_NN(PL_argvgv);
4523         GvMULTI_on(PL_argvgv);
4524         av_clear(GvAVn(PL_argvgv));
4525         for (; argc > 0; argc--,argv++) {
4526             SV * const sv = newSVpv(argv[0],0);
4527             av_push(GvAV(PL_argvgv),sv);
4528             if (!(PL_unicode & PERL_UNICODE_LOCALE_FLAG) || PL_utf8locale) {
4529                  if (PL_unicode & PERL_UNICODE_ARGV_FLAG)
4530                       SvUTF8_on(sv);
4531             }
4532             if (PL_unicode & PERL_UNICODE_WIDESYSCALLS_FLAG) /* Sarathy? */
4533                  (void)sv_utf8_decode(sv);
4534         }
4535     }
4536
4537     if (PL_inplace && (!PL_argvgv || AvFILL(GvAV(PL_argvgv)) == -1))
4538         Perl_ck_warner_d(aTHX_ packWARN(WARN_INPLACE),
4539                          "-i used with no filenames on the command line, "
4540                          "reading from STDIN");
4541 }
4542
4543 STATIC void
4544 S_init_postdump_symbols(pTHX_ int argc, char **argv, char **env)
4545 {
4546 #ifdef USE_ITHREADS
4547     dVAR;
4548 #endif
4549     GV* tmpgv;
4550
4551     PERL_ARGS_ASSERT_INIT_POSTDUMP_SYMBOLS;
4552
4553     PL_toptarget = newSV_type(SVt_PVIV);
4554     SvPVCLEAR(PL_toptarget);
4555     PL_bodytarget = newSV_type(SVt_PVIV);
4556     SvPVCLEAR(PL_bodytarget);
4557     PL_formtarget = PL_bodytarget;
4558
4559     TAINT;
4560
4561     init_argv_symbols(argc,argv);
4562
4563     if ((tmpgv = gv_fetchpvs("0", GV_ADD|GV_NOTQUAL, SVt_PV))) {
4564         sv_setpv(GvSV(tmpgv),PL_origfilename);
4565     }
4566     if ((PL_envgv = gv_fetchpvs("ENV", GV_ADD|GV_NOTQUAL, SVt_PVHV))) {
4567         HV *hv;
4568         bool env_is_not_environ;
4569         SvREFCNT_inc_simple_void_NN(PL_envgv);
4570         GvMULTI_on(PL_envgv);
4571         hv = GvHVn(PL_envgv);
4572         hv_magic(hv, NULL, PERL_MAGIC_env);
4573 #ifndef PERL_MICRO
4574 #ifdef USE_ENVIRON_ARRAY
4575         /* Note that if the supplied env parameter is actually a copy
4576            of the global environ then it may now point to free'd memory
4577            if the environment has been modified since. To avoid this
4578            problem we treat env==NULL as meaning 'use the default'
4579         */
4580         if (!env)
4581             env = environ;
4582         env_is_not_environ = env != environ;
4583         if (env_is_not_environ
4584 #  ifdef USE_ITHREADS
4585             && PL_curinterp == aTHX
4586 #  endif
4587            )
4588         {
4589             environ[0] = NULL;
4590         }
4591         if (env) {
4592           char *s, *old_var;
4593           STRLEN nlen;
4594           SV *sv;
4595           HV *dups = newHV();
4596
4597           for (; *env; env++) {
4598             old_var = *env;
4599
4600             if (!(s = strchr(old_var,'=')) || s == old_var)
4601                 continue;
4602             nlen = s - old_var;
4603
4604 #if defined(MSDOS) && !defined(DJGPP)
4605             *s = '\0';
4606             (void)strupr(old_var);
4607             *s = '=';
4608 #endif
4609             if (hv_exists(hv, old_var, nlen)) {
4610                 const char *name = savepvn(old_var, nlen);
4611
4612                 /* make sure we use the same value as getenv(), otherwise code that
4613                    uses getenv() (like setlocale()) might see a different value to %ENV
4614                  */
4615                 sv = newSVpv(PerlEnv_getenv(name), 0);
4616
4617                 /* keep a count of the dups of this name so we can de-dup environ later */
4618                 if (hv_exists(dups, name, nlen))
4619                     ++SvIVX(*hv_fetch(dups, name, nlen, 0));
4620                 else
4621                     (void)hv_store(dups, name, nlen, newSViv(1), 0);
4622
4623                 Safefree(name);
4624             }
4625             else {
4626                 sv = newSVpv(s+1, 0);
4627             }
4628             (void)hv_store(hv, old_var, nlen, sv, 0);
4629             if (env_is_not_environ)
4630                 mg_set(sv);
4631           }
4632           if (HvKEYS(dups)) {
4633               /* environ has some duplicate definitions, remove them */
4634               HE *entry;
4635               hv_iterinit(dups);
4636               while ((entry = hv_iternext_flags(dups, 0))) {
4637                   STRLEN nlen;
4638                   const char *name = HePV(entry, nlen);
4639                   IV count = SvIV(HeVAL(entry));
4640                   IV i;
4641                   SV **valp = hv_fetch(hv, name, nlen, 0);
4642
4643                   assert(valp);
4644
4645                   /* try to remove any duplicate names, depending on the
4646                    * implementation used in my_setenv() the iteration might
4647                    * not be necessary, but let's be safe.
4648                    */
4649                   for (i = 0; i < count; ++i)
4650                       my_setenv(name, 0);
4651
4652                   /* and set it back to the value we set $ENV{name} to */
4653                   my_setenv(name, SvPV_nolen(*valp));
4654               }
4655           }
4656           SvREFCNT_dec_NN(dups);
4657       }
4658 #endif /* USE_ENVIRON_ARRAY */
4659 #endif /* !PERL_MICRO */
4660     }
4661     TAINT_NOT;
4662
4663     /* touch @F array to prevent spurious warnings 20020415 MJD */
4664     if (PL_minus_a) {
4665       (void) get_av("main::F", GV_ADD | GV_ADDMULTI);
4666     }
4667 }
4668
4669 STATIC void
4670 S_init_perllib(pTHX)
4671 {
4672 #ifndef VMS
4673     const char *perl5lib = NULL;
4674 #endif
4675     const char *s;
4676 #if defined(WIN32) && !defined(PERL_IS_MINIPERL)
4677     STRLEN len;
4678 #endif
4679
4680     if (!TAINTING_get) {
4681 #ifndef VMS
4682         perl5lib = PerlEnv_getenv("PERL5LIB");
4683 /*
4684  * It isn't possible to delete an environment variable with
4685  * PERL_USE_SAFE_PUTENV set unless unsetenv() is also available, so in that
4686  * case we treat PERL5LIB as undefined if it has a zero-length value.
4687  */
4688 #if defined(PERL_USE_SAFE_PUTENV) && ! defined(HAS_UNSETENV)
4689         if (perl5lib && *perl5lib != '\0')
4690 #else
4691         if (perl5lib)
4692 #endif
4693             incpush_use_sep(perl5lib, 0, INCPUSH_ADD_SUB_DIRS);
4694         else {
4695             s = PerlEnv_getenv("PERLLIB");
4696             if (s)
4697                 incpush_use_sep(s, 0, 0);
4698         }
4699 #else /* VMS */
4700         /* Treat PERL5?LIB as a possible search list logical name -- the
4701          * "natural" VMS idiom for a Unix path string.  We allow each
4702          * element to be a set of |-separated directories for compatibility.
4703          */
4704         char buf[256];
4705         int idx = 0;
4706         if (vmstrnenv("PERL5LIB",buf,0,NULL,0))
4707             do {
4708                 incpush_use_sep(buf, 0, INCPUSH_ADD_SUB_DIRS);
4709             } while (vmstrnenv("PERL5LIB",buf,++idx,NULL,0));
4710         else {
4711             while (vmstrnenv("PERLLIB",buf,idx++,NULL,0))
4712                 incpush_use_sep(buf, 0, 0);
4713         }
4714 #endif /* VMS */
4715     }
4716
4717 #ifndef PERL_IS_MINIPERL
4718     /* miniperl gets just -I..., the split of $ENV{PERL5LIB}, and "." in @INC
4719        (and not the architecture specific directories from $ENV{PERL5LIB}) */
4720
4721 #include "perl_inc_macro.h"
4722 /* Use the ~-expanded versions of APPLLIB (undocumented),
4723     SITEARCH, SITELIB, VENDORARCH, VENDORLIB, ARCHLIB and PRIVLIB
4724 */
4725     INCPUSH_APPLLIB_EXP
4726     INCPUSH_SITEARCH_EXP
4727     INCPUSH_SITELIB_EXP
4728     INCPUSH_PERL_VENDORARCH_EXP
4729     INCPUSH_PERL_VENDORLIB_EXP
4730     INCPUSH_ARCHLIB_EXP
4731     INCPUSH_PRIVLIB_EXP
4732     INCPUSH_PERL_OTHERLIBDIRS
4733     INCPUSH_PERL5LIB
4734     INCPUSH_APPLLIB_OLD_EXP
4735     INCPUSH_SITELIB_STEM
4736     INCPUSH_PERL_VENDORLIB_STEM
4737     INCPUSH_PERL_OTHERLIBDIRS_ARCHONLY
4738
4739 #endif /* !PERL_IS_MINIPERL */
4740
4741     if (!TAINTING_get) {
4742 #if !defined(PERL_IS_MINIPERL) && defined(DEFAULT_INC_EXCLUDES_DOT)
4743         const char * const unsafe = PerlEnv_getenv("PERL_USE_UNSAFE_INC");
4744         if (unsafe && strEQ(unsafe, "1"))
4745 #endif
4746           S_incpush(aTHX_ STR_WITH_LEN("."), 0);
4747     }
4748 }
4749
4750 #if defined(DOSISH) || defined(__SYMBIAN32__)
4751 #    define PERLLIB_SEP ';'
4752 #elif defined(__VMS)
4753 #    define PERLLIB_SEP PL_perllib_sep
4754 #else
4755 #    define PERLLIB_SEP ':'
4756 #endif
4757 #ifndef PERLLIB_MANGLE
4758 #  define PERLLIB_MANGLE(s,n) (s)
4759 #endif
4760
4761 #ifndef PERL_IS_MINIPERL
4762 /* Push a directory onto @INC if it exists.
4763    Generate a new SV if we do this, to save needing to copy the SV we push
4764    onto @INC  */
4765 STATIC SV *
4766 S_incpush_if_exists(pTHX_ AV *const av, SV *dir, SV *const stem)
4767 {
4768     Stat_t tmpstatbuf;
4769
4770     PERL_ARGS_ASSERT_INCPUSH_IF_EXISTS;
4771
4772     if (PerlLIO_stat(SvPVX_const(dir), &tmpstatbuf) >= 0 &&
4773         S_ISDIR(tmpstatbuf.st_mode)) {
4774         av_push(av, dir);
4775         dir = newSVsv(stem);
4776     } else {
4777         /* Truncate dir back to stem.  */
4778         SvCUR_set(dir, SvCUR(stem));
4779     }
4780     return dir;
4781 }
4782 #endif
4783
4784 STATIC SV *
4785 S_mayberelocate(pTHX_ const char *const dir, STRLEN len, U32 flags)
4786 {
4787     const U8 canrelocate = (U8)flags & INCPUSH_CAN_RELOCATE;
4788     SV *libdir;
4789
4790     PERL_ARGS_ASSERT_MAYBERELOCATE;
4791     assert(len > 0);
4792
4793     /* I am not convinced that this is valid when PERLLIB_MANGLE is
4794        defined to so something (in os2/os2.c), but the code has been
4795        this way, ignoring any possible changed of length, since
4796        760ac839baf413929cd31cc32ffd6dba6b781a81 (5.003_02) so I'll leave
4797        it be.  */
4798     libdir = newSVpvn(PERLLIB_MANGLE(dir, len), len);
4799
4800 #ifdef VMS
4801     {
4802         char *unix;
4803
4804         if ((unix = tounixspec_ts(SvPV(libdir,len),NULL)) != NULL) {
4805             len = strlen(unix);
4806             while (len > 1 && unix[len-1] == '/') len--;  /* Cosmetic */
4807             sv_usepvn(libdir,unix,len);
4808         }
4809         else
4810             PerlIO_printf(Perl_error_log,
4811                           "Failed to unixify @INC element \"%s\"\n",
4812                           SvPV_nolen_const(libdir));
4813     }
4814 #endif
4815
4816         /* Do the if() outside the #ifdef to avoid warnings about an unused
4817            parameter.  */
4818         if (canrelocate) {
4819 #ifdef PERL_RELOCATABLE_INC
4820         /*
4821          * Relocatable include entries are marked with a leading .../
4822          *
4823          * The algorithm is
4824          * 0: Remove that leading ".../"
4825          * 1: Remove trailing executable name (anything after the last '/')
4826          *    from the perl path to give a perl prefix
4827          * Then
4828          * While the @INC element starts "../" and the prefix ends with a real
4829          * directory (ie not . or ..) chop that real directory off the prefix
4830          * and the leading "../" from the @INC element. ie a logical "../"
4831          * cleanup
4832          * Finally concatenate the prefix and the remainder of the @INC element
4833          * The intent is that /usr/local/bin/perl and .../../lib/perl5