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