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