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