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