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