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