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