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