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