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