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