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