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