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