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