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