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