This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Fix umask for mkstemp(3) calls
[perl5.git] / perl.c
1 #line 2 "perl.c"
2 /*    perl.c
3  *
4  *    Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001
5  *    2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012
6  *    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     I32 oldscope;
2715     bool oldcatch = CATCH_GET;
2716     int ret;
2717     OP* const oldop = PL_op;
2718     dJMPENV;
2719
2720     PERL_ARGS_ASSERT_CALL_SV;
2721
2722     if (flags & G_DISCARD) {
2723         ENTER;
2724         SAVETMPS;
2725     }
2726     if (!(flags & G_WANT)) {
2727         /* Backwards compatibility - as G_SCALAR was 0, it could be omitted.
2728          */
2729         flags |= G_SCALAR;
2730     }
2731
2732     Zero(&myop, 1, LOGOP);
2733     if (!(flags & G_NOARGS))
2734         myop.op_flags |= OPf_STACKED;
2735     myop.op_flags |= OP_GIMME_REVERSE(flags);
2736     SAVEOP();
2737     PL_op = (OP*)&myop;
2738
2739     if (!(flags & G_METHOD_NAMED)) {
2740         dSP;
2741         EXTEND(SP, 1);
2742         PUSHs(sv);
2743         PUTBACK;
2744     }
2745     oldmark = TOPMARK;
2746     oldscope = PL_scopestack_ix;
2747
2748     if (PERLDB_SUB && PL_curstash != PL_debstash
2749            /* Handle first BEGIN of -d. */
2750           && (PL_DBcv || (PL_DBcv = GvCV(PL_DBsub)))
2751            /* Try harder, since this may have been a sighandler, thus
2752             * curstash may be meaningless. */
2753           && (SvTYPE(sv) != SVt_PVCV || CvSTASH((const CV *)sv) != PL_debstash)
2754           && !(flags & G_NODEBUG))
2755         myop.op_private |= OPpENTERSUB_DB;
2756
2757     if (flags & (G_METHOD|G_METHOD_NAMED)) {
2758         Zero(&method_op, 1, METHOP);
2759         method_op.op_next = (OP*)&myop;
2760         PL_op = (OP*)&method_op;
2761         if ( flags & G_METHOD_NAMED ) {
2762             method_op.op_ppaddr = PL_ppaddr[OP_METHOD_NAMED];
2763             method_op.op_type = OP_METHOD_NAMED;
2764             method_op.op_u.op_meth_sv = sv;
2765         } else {
2766             method_op.op_ppaddr = PL_ppaddr[OP_METHOD];
2767             method_op.op_type = OP_METHOD;
2768         }
2769         myop.op_ppaddr = PL_ppaddr[OP_ENTERSUB];
2770         myop.op_type = OP_ENTERSUB;
2771     }
2772
2773     if (!(flags & G_EVAL)) {
2774         CATCH_SET(TRUE);
2775         CALL_BODY_SUB((OP*)&myop);
2776         retval = PL_stack_sp - (PL_stack_base + oldmark);
2777         CATCH_SET(oldcatch);
2778     }
2779     else {
2780         myop.op_other = (OP*)&myop;
2781         (void)POPMARK;
2782         create_eval_scope(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 (PL_scopestack_ix > oldscope)
2824             delete_eval_scope();
2825         JMPENV_POP;
2826     }
2827
2828     if (flags & G_DISCARD) {
2829         PL_stack_sp = PL_stack_base + oldmark;
2830         retval = 0;
2831         FREETMPS;
2832         LEAVE;
2833     }
2834     PL_op = oldop;
2835     return retval;
2836 }
2837
2838 /* Eval a string. The G_EVAL flag is always assumed. */
2839
2840 /*
2841 =for apidoc p||eval_sv
2842
2843 Tells Perl to C<eval> the string in the SV.  It supports the same flags
2844 as C<call_sv>, with the obvious exception of C<G_EVAL>.  See L<perlcall>.
2845
2846 =cut
2847 */
2848
2849 I32
2850 Perl_eval_sv(pTHX_ SV *sv, I32 flags)
2851
2852                         /* See G_* flags in cop.h */
2853 {
2854     dVAR;
2855     UNOP myop;          /* fake syntax tree node */
2856     VOL I32 oldmark;
2857     VOL I32 retval = 0;
2858     int ret;
2859     OP* const oldop = PL_op;
2860     dJMPENV;
2861
2862     PERL_ARGS_ASSERT_EVAL_SV;
2863
2864     if (flags & G_DISCARD) {
2865         ENTER;
2866         SAVETMPS;
2867     }
2868
2869     SAVEOP();
2870     PL_op = (OP*)&myop;
2871     Zero(&myop, 1, UNOP);
2872     {
2873         dSP;
2874         oldmark = SP - PL_stack_base;
2875         EXTEND(SP, 1);
2876         PUSHs(sv);
2877         PUTBACK;
2878     }
2879
2880     if (!(flags & G_NOARGS))
2881         myop.op_flags = OPf_STACKED;
2882     myop.op_type = OP_ENTEREVAL;
2883     myop.op_flags |= OP_GIMME_REVERSE(flags);
2884     if (flags & G_KEEPERR)
2885         myop.op_flags |= OPf_SPECIAL;
2886
2887     if (flags & G_RE_REPARSING)
2888         myop.op_private = (OPpEVAL_COPHH | OPpEVAL_RE_REPARSING);
2889
2890     /* fail now; otherwise we could fail after the JMPENV_PUSH but
2891      * before a PUSHEVAL, which corrupts the stack after a croak */
2892     TAINT_PROPER("eval_sv()");
2893
2894     JMPENV_PUSH(ret);
2895     switch (ret) {
2896     case 0:
2897  redo_body:
2898         if (PL_op == (OP*)(&myop)) {
2899             PL_op = PL_ppaddr[OP_ENTEREVAL](aTHX);
2900             if (!PL_op)
2901                 goto fail; /* failed in compilation */
2902         }
2903         CALLRUNOPS(aTHX);
2904         retval = PL_stack_sp - (PL_stack_base + oldmark);
2905         if (!(flags & G_KEEPERR)) {
2906             CLEAR_ERRSV();
2907         }
2908         break;
2909     case 1:
2910         STATUS_ALL_FAILURE;
2911         /* FALLTHROUGH */
2912     case 2:
2913         /* my_exit() was called */
2914         SET_CURSTASH(PL_defstash);
2915         FREETMPS;
2916         JMPENV_POP;
2917         my_exit_jump();
2918         NOT_REACHED; /* NOTREACHED */
2919     case 3:
2920         if (PL_restartop) {
2921             PL_restartjmpenv = NULL;
2922             PL_op = PL_restartop;
2923             PL_restartop = 0;
2924             goto redo_body;
2925         }
2926       fail:
2927         PL_stack_sp = PL_stack_base + oldmark;
2928         if ((flags & G_WANT) == G_ARRAY)
2929             retval = 0;
2930         else {
2931             retval = 1;
2932             *++PL_stack_sp = &PL_sv_undef;
2933         }
2934         break;
2935     }
2936
2937     JMPENV_POP;
2938     if (flags & G_DISCARD) {
2939         PL_stack_sp = PL_stack_base + oldmark;
2940         retval = 0;
2941         FREETMPS;
2942         LEAVE;
2943     }
2944     PL_op = oldop;
2945     return retval;
2946 }
2947
2948 /*
2949 =for apidoc p||eval_pv
2950
2951 Tells Perl to C<eval> the given string in scalar context and return an SV* result.
2952
2953 =cut
2954 */
2955
2956 SV*
2957 Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error)
2958 {
2959     SV* sv = newSVpv(p, 0);
2960
2961     PERL_ARGS_ASSERT_EVAL_PV;
2962
2963     eval_sv(sv, G_SCALAR);
2964     SvREFCNT_dec(sv);
2965
2966     {
2967         dSP;
2968         sv = POPs;
2969         PUTBACK;
2970     }
2971
2972     /* just check empty string or undef? */
2973     if (croak_on_error) {
2974         SV * const errsv = ERRSV;
2975         if(SvTRUE_NN(errsv))
2976             /* replace with croak_sv? */
2977             Perl_croak_nocontext("%s", SvPV_nolen_const(errsv));
2978     }
2979
2980     return sv;
2981 }
2982
2983 /* Require a module. */
2984
2985 /*
2986 =head1 Embedding Functions
2987
2988 =for apidoc p||require_pv
2989
2990 Tells Perl to C<require> the file named by the string argument.  It is
2991 analogous to the Perl code C<eval "require '$file'">.  It's even
2992 implemented that way; consider using load_module instead.
2993
2994 =cut */
2995
2996 void
2997 Perl_require_pv(pTHX_ const char *pv)
2998 {
2999     dSP;
3000     SV* sv;
3001
3002     PERL_ARGS_ASSERT_REQUIRE_PV;
3003
3004     PUSHSTACKi(PERLSI_REQUIRE);
3005     sv = Perl_newSVpvf(aTHX_ "require q%c%s%c", 0, pv, 0);
3006     eval_sv(sv_2mortal(sv), G_DISCARD);
3007     POPSTACK;
3008 }
3009
3010 STATIC void
3011 S_usage(pTHX)           /* XXX move this out into a module ? */
3012 {
3013     /* This message really ought to be max 23 lines.
3014      * Removed -h because the user already knows that option. Others? */
3015
3016     /* Grouped as 6 lines per C string literal, to keep under the ANSI C 89
3017        minimum of 509 character string literals.  */
3018     static const char * const usage_msg[] = {
3019 "  -0[octal]         specify record separator (\\0, if no argument)\n"
3020 "  -a                autosplit mode with -n or -p (splits $_ into @F)\n"
3021 "  -C[number/list]   enables the listed Unicode features\n"
3022 "  -c                check syntax only (runs BEGIN and CHECK blocks)\n"
3023 "  -d[:debugger]     run program under debugger\n"
3024 "  -D[number/list]   set debugging flags (argument is a bit mask or alphabets)\n",
3025 "  -e program        one line of program (several -e's allowed, omit programfile)\n"
3026 "  -E program        like -e, but enables all optional features\n"
3027 "  -f                don't do $sitelib/sitecustomize.pl at startup\n"
3028 "  -F/pattern/       split() pattern for -a switch (//'s are optional)\n"
3029 "  -i[extension]     edit <> files in place (makes backup if extension supplied)\n"
3030 "  -Idirectory       specify @INC/#include directory (several -I's allowed)\n",
3031 "  -l[octal]         enable line ending processing, specifies line terminator\n"
3032 "  -[mM][-]module    execute \"use/no module...\" before executing program\n"
3033 "  -n                assume \"while (<>) { ... }\" loop around program\n"
3034 "  -p                assume loop like -n but print line also, like sed\n"
3035 "  -s                enable rudimentary parsing for switches after programfile\n"
3036 "  -S                look for programfile using PATH environment variable\n",
3037 "  -t                enable tainting warnings\n"
3038 "  -T                enable tainting checks\n"
3039 "  -u                dump core after parsing program\n"
3040 "  -U                allow unsafe operations\n"
3041 "  -v                print version, patchlevel and license\n"
3042 "  -V[:variable]     print configuration summary (or a single Config.pm variable)\n",
3043 "  -w                enable many useful warnings\n"
3044 "  -W                enable all warnings\n"
3045 "  -x[directory]     ignore text before #!perl line (optionally cd to directory)\n"
3046 "  -X                disable all warnings\n"
3047 "  \n"
3048 "Run 'perldoc perl' for more help with Perl.\n\n",
3049 NULL
3050 };
3051     const char * const *p = usage_msg;
3052     PerlIO *out = PerlIO_stdout();
3053
3054     PerlIO_printf(out,
3055                   "\nUsage: %s [switches] [--] [programfile] [arguments]\n",
3056                   PL_origargv[0]);
3057     while (*p)
3058         PerlIO_puts(out, *p++);
3059     my_exit(0);
3060 }
3061
3062 /* convert a string of -D options (or digits) into an int.
3063  * sets *s to point to the char after the options */
3064
3065 #ifdef DEBUGGING
3066 int
3067 Perl_get_debug_opts(pTHX_ const char **s, bool givehelp)
3068 {
3069     static const char * const usage_msgd[] = {
3070       " Debugging flag values: (see also -d)\n"
3071       "  p  Tokenizing and parsing (with v, displays parse stack)\n"
3072       "  s  Stack snapshots (with v, displays all stacks)\n"
3073       "  l  Context (loop) stack processing\n"
3074       "  t  Trace execution\n"
3075       "  o  Method and overloading resolution\n",
3076       "  c  String/numeric conversions\n"
3077       "  P  Print profiling info, source file input state\n"
3078       "  m  Memory and SV allocation\n"
3079       "  f  Format processing\n"
3080       "  r  Regular expression parsing and execution\n"
3081       "  x  Syntax tree dump\n",
3082       "  u  Tainting checks\n"
3083       "  H  Hash dump -- usurps values()\n"
3084       "  X  Scratchpad allocation\n"
3085       "  D  Cleaning up\n"
3086       "  S  Op slab allocation\n"
3087       "  T  Tokenising\n"
3088       "  R  Include reference counts of dumped variables (eg when using -Ds)\n",
3089       "  J  Do not s,t,P-debug (Jump over) opcodes within package DB\n"
3090       "  v  Verbose: use in conjunction with other flags\n"
3091       "  C  Copy On Write\n"
3092       "  A  Consistency checks on internal structures\n"
3093       "  q  quiet - currently only suppresses the 'EXECUTING' message\n"
3094       "  M  trace smart match resolution\n"
3095       "  B  dump suBroutine definitions, including special Blocks like BEGIN\n",
3096       "  L  trace some locale setting information--for Perl core development\n",
3097       NULL
3098     };
3099     UV uv = 0;
3100
3101     PERL_ARGS_ASSERT_GET_DEBUG_OPTS;
3102
3103     if (isALPHA(**s)) {
3104         /* if adding extra options, remember to update DEBUG_MASK */
3105         static const char debopts[] = "psltocPmfrxuUHXDSTRJvCAqMBL";
3106
3107         for (; isWORDCHAR(**s); (*s)++) {
3108             const char * const d = strchr(debopts,**s);
3109             if (d)
3110                 uv |= 1 << (d - debopts);
3111             else if (ckWARN_d(WARN_DEBUGGING))
3112                 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
3113                     "invalid option -D%c, use -D'' to see choices\n", **s);
3114         }
3115     }
3116     else if (isDIGIT(**s)) {
3117         const char* e;
3118         if (grok_atoUV(*s, &uv, &e))
3119             *s = e;
3120         for (; isWORDCHAR(**s); (*s)++) ;
3121     }
3122     else if (givehelp) {
3123       const char *const *p = usage_msgd;
3124       while (*p) PerlIO_puts(PerlIO_stdout(), *p++);
3125     }
3126     return (int)uv; /* ignore any UV->int conversion loss */
3127 }
3128 #endif
3129
3130 /* This routine handles any switches that can be given during run */
3131
3132 const char *
3133 Perl_moreswitches(pTHX_ const char *s)
3134 {
3135     dVAR;
3136     UV rschar;
3137     const char option = *s; /* used to remember option in -m/-M code */
3138
3139     PERL_ARGS_ASSERT_MORESWITCHES;
3140
3141     switch (*s) {
3142     case '0':
3143     {
3144          I32 flags = 0;
3145          STRLEN numlen;
3146
3147          SvREFCNT_dec(PL_rs);
3148          if (s[1] == 'x' && s[2]) {
3149               const char *e = s+=2;
3150               U8 *tmps;
3151
3152               while (*e)
3153                 e++;
3154               numlen = e - s;
3155               flags = PERL_SCAN_SILENT_ILLDIGIT;
3156               rschar = (U32)grok_hex(s, &numlen, &flags, NULL);
3157               if (s + numlen < e) {
3158                    rschar = 0; /* Grandfather -0xFOO as -0 -xFOO. */
3159                    numlen = 0;
3160                    s--;
3161               }
3162               PL_rs = newSVpvs("");
3163               SvGROW(PL_rs, (STRLEN)(UVCHR_SKIP(rschar) + 1));
3164               tmps = (U8*)SvPVX(PL_rs);
3165               uvchr_to_utf8(tmps, rschar);
3166               SvCUR_set(PL_rs, UVCHR_SKIP(rschar));
3167               SvUTF8_on(PL_rs);
3168          }
3169          else {
3170               numlen = 4;
3171               rschar = (U32)grok_oct(s, &numlen, &flags, NULL);
3172               if (rschar & ~((U8)~0))
3173                    PL_rs = &PL_sv_undef;
3174               else if (!rschar && numlen >= 2)
3175                    PL_rs = newSVpvs("");
3176               else {
3177                    char ch = (char)rschar;
3178                    PL_rs = newSVpvn(&ch, 1);
3179               }
3180          }
3181          sv_setsv(get_sv("/", GV_ADD), PL_rs);
3182          return s + numlen;
3183     }
3184     case 'C':
3185         s++;
3186         PL_unicode = parse_unicode_opts( (const char **)&s );
3187         if (PL_unicode & PERL_UNICODE_UTF8CACHEASSERT_FLAG)
3188             PL_utf8cache = -1;
3189         return s;
3190     case 'F':
3191         PL_minus_a = TRUE;
3192         PL_minus_F = TRUE;
3193         PL_minus_n = TRUE;
3194         PL_splitstr = ++s;
3195         while (*s && !isSPACE(*s)) ++s;
3196         PL_splitstr = savepvn(PL_splitstr, s - PL_splitstr);
3197         return s;
3198     case 'a':
3199         PL_minus_a = TRUE;
3200         PL_minus_n = TRUE;
3201         s++;
3202         return s;
3203     case 'c':
3204         PL_minus_c = TRUE;
3205         s++;
3206         return s;
3207     case 'd':
3208         forbid_setid('d', FALSE);
3209         s++;
3210
3211         /* -dt indicates to the debugger that threads will be used */
3212         if (*s == 't' && !isWORDCHAR(s[1])) {
3213             ++s;
3214             my_setenv("PERL5DB_THREADED", "1");
3215         }
3216
3217         /* The following permits -d:Mod to accepts arguments following an =
3218            in the fashion that -MSome::Mod does. */
3219         if (*s == ':' || *s == '=') {
3220             const char *start;
3221             const char *end;
3222             SV *sv;
3223
3224             if (*++s == '-') {
3225                 ++s;
3226                 sv = newSVpvs("no Devel::");
3227             } else {
3228                 sv = newSVpvs("use Devel::");
3229             }
3230
3231             start = s;
3232             end = s + strlen(s);
3233
3234             /* We now allow -d:Module=Foo,Bar and -d:-Module */
3235             while(isWORDCHAR(*s) || *s==':') ++s;
3236             if (*s != '=')
3237                 sv_catpvn(sv, start, end - start);
3238             else {
3239                 sv_catpvn(sv, start, s-start);
3240                 /* Don't use NUL as q// delimiter here, this string goes in the
3241                  * environment. */
3242                 Perl_sv_catpvf(aTHX_ sv, " split(/,/,q{%s});", ++s);
3243             }
3244             s = end;
3245             my_setenv("PERL5DB", SvPV_nolen_const(sv));
3246             SvREFCNT_dec(sv);
3247         }
3248         if (!PL_perldb) {
3249             PL_perldb = PERLDB_ALL;
3250             init_debugger();
3251         }
3252         return s;
3253     case 'D':
3254     {   
3255 #ifdef DEBUGGING
3256         forbid_setid('D', FALSE);
3257         s++;
3258         PL_debug = get_debug_opts( (const char **)&s, 1) | DEBUG_TOP_FLAG;
3259 #else /* !DEBUGGING */
3260         if (ckWARN_d(WARN_DEBUGGING))
3261             Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
3262                    "Recompile perl with -DDEBUGGING to use -D switch (did you mean -d ?)\n");
3263         for (s++; isWORDCHAR(*s); s++) ;
3264 #endif
3265         return s;
3266         NOT_REACHED; /* NOTREACHED */
3267     }   
3268     case 'h':
3269         usage();
3270         NOT_REACHED; /* NOTREACHED */
3271
3272     case 'i':
3273         Safefree(PL_inplace);
3274 #if defined(__CYGWIN__) /* do backup extension automagically */
3275         if (*(s+1) == '\0') {
3276         PL_inplace = savepvs(".bak");
3277         return s+1;
3278         }
3279 #endif /* __CYGWIN__ */
3280         {
3281             const char * const start = ++s;
3282             while (*s && !isSPACE(*s))
3283                 ++s;
3284
3285             PL_inplace = savepvn(start, s - start);
3286         }
3287         if (*s) {
3288             ++s;
3289             if (*s == '-')      /* Additional switches on #! line. */
3290                 s++;
3291         }
3292         return s;
3293     case 'I':   /* -I handled both here and in parse_body() */
3294         forbid_setid('I', FALSE);
3295         ++s;
3296         while (*s && isSPACE(*s))
3297             ++s;
3298         if (*s) {
3299             const char *e, *p;
3300             p = s;
3301             /* ignore trailing spaces (possibly followed by other switches) */
3302             do {
3303                 for (e = p; *e && !isSPACE(*e); e++) ;
3304                 p = e;
3305                 while (isSPACE(*p))
3306                     p++;
3307             } while (*p && *p != '-');
3308             incpush(s, e-s,
3309                     INCPUSH_ADD_SUB_DIRS|INCPUSH_ADD_OLD_VERS|INCPUSH_UNSHIFT);
3310             s = p;
3311             if (*s == '-')
3312                 s++;
3313         }
3314         else
3315             Perl_croak(aTHX_ "No directory specified for -I");
3316         return s;
3317     case 'l':
3318         PL_minus_l = TRUE;
3319         s++;
3320         if (PL_ors_sv) {
3321             SvREFCNT_dec(PL_ors_sv);
3322             PL_ors_sv = NULL;
3323         }
3324         if (isDIGIT(*s)) {
3325             I32 flags = 0;
3326             STRLEN numlen;
3327             PL_ors_sv = newSVpvs("\n");
3328             numlen = 3 + (*s == '0');
3329             *SvPVX(PL_ors_sv) = (char)grok_oct(s, &numlen, &flags, NULL);
3330             s += numlen;
3331         }
3332         else {
3333             if (RsPARA(PL_rs)) {
3334                 PL_ors_sv = newSVpvs("\n\n");
3335             }
3336             else {
3337                 PL_ors_sv = newSVsv(PL_rs);
3338             }
3339         }
3340         return s;
3341     case 'M':
3342         forbid_setid('M', FALSE);       /* XXX ? */
3343         /* FALLTHROUGH */
3344     case 'm':
3345         forbid_setid('m', FALSE);       /* XXX ? */
3346         if (*++s) {
3347             const char *start;
3348             const char *end;
3349             SV *sv;
3350             const char *use = "use ";
3351             bool colon = FALSE;
3352             /* -M-foo == 'no foo'       */
3353             /* Leading space on " no " is deliberate, to make both
3354                possibilities the same length.  */
3355             if (*s == '-') { use = " no "; ++s; }
3356             sv = newSVpvn(use,4);
3357             start = s;
3358             /* We allow -M'Module qw(Foo Bar)'  */
3359             while(isWORDCHAR(*s) || *s==':') {
3360                 if( *s++ == ':' ) {
3361                     if( *s == ':' ) 
3362                         s++;
3363                     else
3364                         colon = TRUE;
3365                 }
3366             }
3367             if (s == start)
3368                 Perl_croak(aTHX_ "Module name required with -%c option",
3369                                     option);
3370             if (colon) 
3371                 Perl_croak(aTHX_ "Invalid module name %.*s with -%c option: "
3372                                     "contains single ':'",
3373                                     (int)(s - start), start, option);
3374             end = s + strlen(s);
3375             if (*s != '=') {
3376                 sv_catpvn(sv, start, end - start);
3377                 if (option == 'm') {
3378                     if (*s != '\0')
3379                         Perl_croak(aTHX_ "Can't use '%c' after -mname", *s);
3380                     sv_catpvs( sv, " ()");
3381                 }
3382             } else {
3383                 sv_catpvn(sv, start, s-start);
3384                 /* Use NUL as q''-delimiter.  */
3385                 sv_catpvs(sv, " split(/,/,q\0");
3386                 ++s;
3387                 sv_catpvn(sv, s, end - s);
3388                 sv_catpvs(sv,  "\0)");
3389             }
3390             s = end;
3391             Perl_av_create_and_push(aTHX_ &PL_preambleav, sv);
3392         }
3393         else
3394             Perl_croak(aTHX_ "Missing argument to -%c", option);
3395         return s;
3396     case 'n':
3397         PL_minus_n = TRUE;
3398         s++;
3399         return s;
3400     case 'p':
3401         PL_minus_p = TRUE;
3402         s++;
3403         return s;
3404     case 's':
3405         forbid_setid('s', FALSE);
3406         PL_doswitches = TRUE;
3407         s++;
3408         return s;
3409     case 't':
3410     case 'T':
3411 #if defined(SILENT_NO_TAINT_SUPPORT)
3412             /* silently ignore */
3413 #elif defined(NO_TAINT_SUPPORT)
3414         Perl_croak_nocontext("This perl was compiled without taint support. "
3415                    "Cowardly refusing to run with -t or -T flags");
3416 #else
3417         if (!TAINTING_get)
3418             TOO_LATE_FOR(*s);
3419 #endif
3420         s++;
3421         return s;
3422     case 'u':
3423         PL_do_undump = TRUE;
3424         s++;
3425         return s;
3426     case 'U':
3427         PL_unsafe = TRUE;
3428         s++;
3429         return s;
3430     case 'v':
3431         minus_v();
3432     case 'w':
3433         if (! (PL_dowarn & G_WARN_ALL_MASK)) {
3434             PL_dowarn |= G_WARN_ON;
3435         }
3436         s++;
3437         return s;
3438     case 'W':
3439         PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
3440         if (!specialWARN(PL_compiling.cop_warnings))
3441             PerlMemShared_free(PL_compiling.cop_warnings);
3442         PL_compiling.cop_warnings = pWARN_ALL ;
3443         s++;
3444         return s;
3445     case 'X':
3446         PL_dowarn = G_WARN_ALL_OFF;
3447         if (!specialWARN(PL_compiling.cop_warnings))
3448             PerlMemShared_free(PL_compiling.cop_warnings);
3449         PL_compiling.cop_warnings = pWARN_NONE ;
3450         s++;
3451         return s;
3452     case '*':
3453     case ' ':
3454         while( *s == ' ' )
3455           ++s;
3456         if (s[0] == '-')        /* Additional switches on #! line. */
3457             return s+1;
3458         break;
3459     case '-':
3460     case 0:
3461 #if defined(WIN32) || !defined(PERL_STRICT_CR)
3462     case '\r':
3463 #endif
3464     case '\n':
3465     case '\t':
3466         break;
3467 #ifdef ALTERNATE_SHEBANG
3468     case 'S':                   /* OS/2 needs -S on "extproc" line. */
3469         break;
3470 #endif
3471     case 'e': case 'f': case 'x': case 'E':
3472 #ifndef ALTERNATE_SHEBANG
3473     case 'S':
3474 #endif
3475     case 'V':
3476         Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s);
3477     default:
3478         Perl_croak(aTHX_
3479             "Unrecognized switch: -%.1s  (-h will show valid options)",s
3480         );
3481     }
3482     return NULL;
3483 }
3484
3485
3486 STATIC void
3487 S_minus_v(pTHX)
3488 {
3489         PerlIO * PIO_stdout;
3490         {
3491             const char * const level_str = "v" PERL_VERSION_STRING;
3492             const STRLEN level_len = sizeof("v" PERL_VERSION_STRING)-1;
3493 #ifdef PERL_PATCHNUM
3494             SV* level;
3495 #  ifdef PERL_GIT_UNCOMMITTED_CHANGES
3496             static const char num [] = PERL_PATCHNUM "*";
3497 #  else
3498             static const char num [] = PERL_PATCHNUM;
3499 #  endif
3500             {
3501                 const STRLEN num_len = sizeof(num)-1;
3502                 /* A very advanced compiler would fold away the strnEQ
3503                    and this whole conditional, but most (all?) won't do it.
3504                    SV level could also be replaced by with preprocessor
3505                    catenation.
3506                 */
3507                 if (num_len >= level_len && strnEQ(num,level_str,level_len)) {
3508                     /* per 46807d8e80, PERL_PATCHNUM is outside of the control
3509                        of the interp so it might contain format characters
3510                     */
3511                     level = newSVpvn(num, num_len);
3512                 } else {
3513                     level = Perl_newSVpvf_nocontext("%s (%s)", level_str, num);
3514                 }
3515             }
3516 #else
3517         SV* level = newSVpvn(level_str, level_len);
3518 #endif /* #ifdef PERL_PATCHNUM */
3519         PIO_stdout =  PerlIO_stdout();
3520             PerlIO_printf(PIO_stdout,
3521                 "\nThis is perl "       STRINGIFY(PERL_REVISION)
3522                 ", version "            STRINGIFY(PERL_VERSION)
3523                 ", subversion "         STRINGIFY(PERL_SUBVERSION)
3524                 " (%"SVf") built for "  ARCHNAME, SVfARG(level)
3525                 );
3526             SvREFCNT_dec_NN(level);
3527         }
3528 #if defined(LOCAL_PATCH_COUNT)
3529         if (LOCAL_PATCH_COUNT > 0)
3530             PerlIO_printf(PIO_stdout,
3531                           "\n(with %d registered patch%s, "
3532                           "see perl -V for more detail)",
3533                           LOCAL_PATCH_COUNT,
3534                           (LOCAL_PATCH_COUNT!=1) ? "es" : "");
3535 #endif
3536
3537         PerlIO_printf(PIO_stdout,
3538                       "\n\nCopyright 1987-2016, Larry Wall\n");
3539 #ifdef MSDOS
3540         PerlIO_printf(PIO_stdout,
3541                       "\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
3542 #endif
3543 #ifdef DJGPP
3544         PerlIO_printf(PIO_stdout,
3545                       "djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n"
3546                       "djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n");
3547 #endif
3548 #ifdef OS2
3549         PerlIO_printf(PIO_stdout,
3550                       "\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
3551                       "Version 5 port Copyright (c) 1994-2002, Andreas Kaiser, Ilya Zakharevich\n");
3552 #endif
3553 #ifdef OEMVS
3554         PerlIO_printf(PIO_stdout,
3555                       "MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
3556 #endif
3557 #ifdef __VOS__
3558         PerlIO_printf(PIO_stdout,
3559                       "Stratus OpenVOS port by Paul.Green@stratus.com, 1997-2013\n");
3560 #endif
3561 #ifdef POSIX_BC
3562         PerlIO_printf(PIO_stdout,
3563                       "BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
3564 #endif
3565 #ifdef UNDER_CE
3566         PerlIO_printf(PIO_stdout,
3567                         "WINCE port by Rainer Keuchel, 2001-2002\n"
3568                         "Built on " __DATE__ " " __TIME__ "\n\n");
3569         wce_hitreturn();
3570 #endif
3571 #ifdef __SYMBIAN32__
3572         PerlIO_printf(PIO_stdout,
3573                       "Symbian port by Nokia, 2004-2005\n");
3574 #endif
3575 #ifdef BINARY_BUILD_NOTICE
3576         BINARY_BUILD_NOTICE;
3577 #endif
3578         PerlIO_printf(PIO_stdout,
3579                       "\n\
3580 Perl may be copied only under the terms of either the Artistic License or the\n\
3581 GNU General Public License, which may be found in the Perl 5 source kit.\n\n\
3582 Complete documentation for Perl, including FAQ lists, should be found on\n\
3583 this system using \"man perl\" or \"perldoc perl\".  If you have access to the\n\
3584 Internet, point your browser at http://www.perl.org/, the Perl Home Page.\n\n");
3585         my_exit(0);
3586 }
3587
3588 /* compliments of Tom Christiansen */
3589
3590 /* unexec() can be found in the Gnu emacs distribution */
3591 /* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
3592
3593 #ifdef VMS
3594 #include <lib$routines.h>
3595 #endif
3596
3597 void
3598 Perl_my_unexec(pTHX)
3599 {
3600 #ifdef UNEXEC
3601     SV *    prog = newSVpv(BIN_EXP, 0);
3602     SV *    file = newSVpv(PL_origfilename, 0);
3603     int    status = 1;
3604     extern int etext;
3605
3606     sv_catpvs(prog, "/perl");
3607     sv_catpvs(file, ".perldump");
3608
3609     unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
3610     /* unexec prints msg to stderr in case of failure */
3611     PerlProc_exit(status);
3612 #else
3613     PERL_UNUSED_CONTEXT;
3614 #  ifdef VMS
3615      lib$signal(SS$_DEBUG);  /* ssdef.h #included from vmsish.h */
3616 #  elif defined(WIN32) || defined(__CYGWIN__)
3617     Perl_croak_nocontext("dump is not supported");
3618 #  else
3619     ABORT();            /* for use with undump */
3620 #  endif
3621 #endif
3622 }
3623
3624 /* initialize curinterp */
3625 STATIC void
3626 S_init_interp(pTHX)
3627 {
3628 #ifdef MULTIPLICITY
3629 #  define PERLVAR(prefix,var,type)
3630 #  define PERLVARA(prefix,var,n,type)
3631 #  if defined(PERL_IMPLICIT_CONTEXT)
3632 #    define PERLVARI(prefix,var,type,init)      aTHX->prefix##var = init;
3633 #    define PERLVARIC(prefix,var,type,init)     aTHX->prefix##var = init;
3634 #  else
3635 #    define PERLVARI(prefix,var,type,init)      PERL_GET_INTERP->var = init;
3636 #    define PERLVARIC(prefix,var,type,init)     PERL_GET_INTERP->var = init;
3637 #  endif
3638 #  include "intrpvar.h"
3639 #  undef PERLVAR
3640 #  undef PERLVARA
3641 #  undef PERLVARI
3642 #  undef PERLVARIC
3643 #else
3644 #  define PERLVAR(prefix,var,type)
3645 #  define PERLVARA(prefix,var,n,type)
3646 #  define PERLVARI(prefix,var,type,init)        PL_##var = init;
3647 #  define PERLVARIC(prefix,var,type,init)       PL_##var = init;
3648 #  include "intrpvar.h"
3649 #  undef PERLVAR
3650 #  undef PERLVARA
3651 #  undef PERLVARI
3652 #  undef PERLVARIC
3653 #endif
3654
3655 }
3656
3657 STATIC void
3658 S_init_main_stash(pTHX)
3659 {
3660     GV *gv;
3661
3662     PL_curstash = PL_defstash = (HV *)SvREFCNT_inc_simple_NN(newHV());
3663     /* We know that the string "main" will be in the global shared string
3664        table, so it's a small saving to use it rather than allocate another
3665        8 bytes.  */
3666     PL_curstname = newSVpvs_share("main");
3667     gv = gv_fetchpvs("main::", GV_ADD|GV_NOTQUAL, SVt_PVHV);
3668     /* If we hadn't caused another reference to "main" to be in the shared
3669        string table above, then it would be worth reordering these two,
3670        because otherwise all we do is delete "main" from it as a consequence
3671        of the SvREFCNT_dec, only to add it again with hv_name_set */
3672     SvREFCNT_dec(GvHV(gv));
3673     hv_name_set(PL_defstash, "main", 4, 0);
3674     GvHV(gv) = MUTABLE_HV(SvREFCNT_inc_simple(PL_defstash));
3675     SvREADONLY_on(gv);
3676     PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpvs("INC", GV_ADD|GV_NOTQUAL,
3677                                              SVt_PVAV)));
3678     SvREFCNT_inc_simple_void(PL_incgv); /* Don't allow it to be freed */
3679     GvMULTI_on(PL_incgv);
3680     PL_hintgv = gv_fetchpvs("\010", GV_ADD|GV_NOTQUAL, SVt_PV); /* ^H */
3681     SvREFCNT_inc_simple_void(PL_hintgv);
3682     GvMULTI_on(PL_hintgv);
3683     PL_defgv = gv_fetchpvs("_", GV_ADD|GV_NOTQUAL, SVt_PVAV);
3684     SvREFCNT_inc_simple_void(PL_defgv);
3685     PL_errgv = gv_fetchpvs("@", GV_ADD|GV_NOTQUAL, SVt_PV);
3686     SvREFCNT_inc_simple_void(PL_errgv);
3687     GvMULTI_on(PL_errgv);
3688     PL_replgv = gv_fetchpvs("\022", GV_ADD|GV_NOTQUAL, SVt_PV); /* ^R */
3689     SvREFCNT_inc_simple_void(PL_replgv);
3690     GvMULTI_on(PL_replgv);
3691     (void)Perl_form(aTHX_ "%240s","");  /* Preallocate temp - for immediate signals. */
3692 #ifdef PERL_DONT_CREATE_GVSV
3693     (void)gv_SVadd(PL_errgv);
3694 #endif
3695     sv_grow(ERRSV, 240);        /* Preallocate - for immediate signals. */
3696     CLEAR_ERRSV();
3697     SET_CURSTASH(PL_defstash);
3698     CopSTASH_set(&PL_compiling, PL_defstash);
3699     PL_debstash = GvHV(gv_fetchpvs("DB::", GV_ADDMULTI, SVt_PVHV));
3700     PL_globalstash = GvHV(gv_fetchpvs("CORE::GLOBAL::", GV_ADDMULTI,
3701                                       SVt_PVHV));
3702     /* We must init $/ before switches are processed. */
3703     sv_setpvs(get_sv("/", GV_ADD), "\n");
3704 }
3705
3706 STATIC PerlIO *
3707 S_open_script(pTHX_ const char *scriptname, bool dosearch, bool *suidscript)
3708 {
3709     int fdscript = -1;
3710     PerlIO *rsfp = NULL;
3711     Stat_t tmpstatbuf;
3712     int fd;
3713
3714     PERL_ARGS_ASSERT_OPEN_SCRIPT;
3715
3716     if (PL_e_script) {
3717         PL_origfilename = savepvs("-e");
3718     }
3719     else {
3720         const char *s;
3721         UV uv;
3722         /* if find_script() returns, it returns a malloc()-ed value */
3723         scriptname = PL_origfilename = find_script(scriptname, dosearch, NULL, 1);
3724
3725         if (strnEQ(scriptname, "/dev/fd/", 8)
3726             && isDIGIT(scriptname[8])
3727             && grok_atoUV(scriptname + 8, &uv, &s)
3728             && uv <= PERL_INT_MAX
3729         ) {
3730             fdscript = (int)uv;
3731             if (*s) {
3732                 /* PSz 18 Feb 04
3733                  * Tell apart "normal" usage of fdscript, e.g.
3734                  * with bash on FreeBSD:
3735                  *   perl <( echo '#!perl -DA'; echo 'print "$0\n"')
3736                  * from usage in suidperl.
3737                  * Does any "normal" usage leave garbage after the number???
3738                  * Is it a mistake to use a similar /dev/fd/ construct for
3739                  * suidperl?
3740                  */
3741                 *suidscript = TRUE;
3742                 /* PSz 20 Feb 04  
3743                  * Be supersafe and do some sanity-checks.
3744                  * Still, can we be sure we got the right thing?
3745                  */
3746                 if (*s != '/') {
3747                     Perl_croak(aTHX_ "Wrong syntax (suid) fd script name \"%s\"\n", s);
3748                 }
3749                 if (! *(s+1)) {
3750                     Perl_croak(aTHX_ "Missing (suid) fd script name\n");
3751                 }
3752                 scriptname = savepv(s + 1);
3753                 Safefree(PL_origfilename);
3754                 PL_origfilename = (char *)scriptname;
3755             }
3756         }
3757     }
3758
3759     CopFILE_free(PL_curcop);
3760     CopFILE_set(PL_curcop, PL_origfilename);
3761     if (*PL_origfilename == '-' && PL_origfilename[1] == '\0')
3762         scriptname = (char *)"";
3763     if (fdscript >= 0) {
3764         rsfp = PerlIO_fdopen(fdscript,PERL_SCRIPT_MODE);
3765     }
3766     else if (!*scriptname) {
3767         forbid_setid(0, *suidscript);
3768         return NULL;
3769     }
3770     else {
3771 #ifdef FAKE_BIT_BUCKET
3772         /* This hack allows one not to have /dev/null (or BIT_BUCKET as it
3773          * is called) and still have the "-e" work.  (Believe it or not,
3774          * a /dev/null is required for the "-e" to work because source
3775          * filter magic is used to implement it. ) This is *not* a general
3776          * replacement for a /dev/null.  What we do here is create a temp
3777          * file (an empty file), open up that as the script, and then
3778          * immediately close and unlink it.  Close enough for jazz. */ 
3779 #define FAKE_BIT_BUCKET_PREFIX "/tmp/perlnull-"
3780 #define FAKE_BIT_BUCKET_SUFFIX "XXXXXXXX"
3781 #define FAKE_BIT_BUCKET_TEMPLATE FAKE_BIT_BUCKET_PREFIX FAKE_BIT_BUCKET_SUFFIX
3782         char tmpname[sizeof(FAKE_BIT_BUCKET_TEMPLATE)] = {
3783             FAKE_BIT_BUCKET_TEMPLATE
3784         };
3785         const char * const err = "Failed to create a fake bit bucket";
3786         if (strEQ(scriptname, BIT_BUCKET)) {
3787 #ifdef HAS_MKSTEMP /* Hopefully mkstemp() is safe here. */
3788             int old_umask = umask(0177);
3789             int tmpfd = mkstemp(tmpname);
3790             umask(old_umask);
3791             if (tmpfd > -1) {
3792                 scriptname = tmpname;
3793                 close(tmpfd);
3794             } else
3795                 Perl_croak(aTHX_ err);
3796 #else
3797 #  ifdef HAS_MKTEMP
3798             scriptname = mktemp(tmpname);
3799             if (!scriptname)
3800                 Perl_croak(aTHX_ err);
3801 #  endif
3802 #endif
3803         }
3804 #endif
3805         rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
3806 #ifdef FAKE_BIT_BUCKET
3807         if (memEQ(scriptname, FAKE_BIT_BUCKET_PREFIX,
3808                   sizeof(FAKE_BIT_BUCKET_PREFIX) - 1)
3809             && strlen(scriptname) == sizeof(tmpname) - 1) {
3810             unlink(scriptname);
3811         }
3812         scriptname = BIT_BUCKET;
3813 #endif
3814     }
3815     if (!rsfp) {
3816         /* PSz 16 Sep 03  Keep neat error message */
3817         if (PL_e_script)
3818             Perl_croak(aTHX_ "Can't open "BIT_BUCKET": %s\n", Strerror(errno));
3819         else
3820             Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
3821                     CopFILE(PL_curcop), Strerror(errno));
3822     }
3823     fd = PerlIO_fileno(rsfp);
3824 #if defined(HAS_FCNTL) && defined(F_SETFD) && defined(FD_CLOEXEC)
3825     if (fd >= 0) {
3826         /* ensure close-on-exec */
3827         if (fcntl(fd, F_SETFD, FD_CLOEXEC) < 0) {
3828             Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
3829                        CopFILE(PL_curcop), Strerror(errno));
3830         }
3831     }
3832 #endif
3833
3834     if (fd < 0 ||
3835         (PerlLIO_fstat(fd, &tmpstatbuf) >= 0
3836          && S_ISDIR(tmpstatbuf.st_mode)))
3837         Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
3838             CopFILE(PL_curcop),
3839             Strerror(EISDIR));
3840
3841     return rsfp;
3842 }
3843
3844 /* Mention
3845  * I_SYSSTATVFS HAS_FSTATVFS
3846  * I_SYSMOUNT
3847  * I_STATFS     HAS_FSTATFS     HAS_GETFSSTAT
3848  * I_MNTENT     HAS_GETMNTENT   HAS_HASMNTOPT
3849  * here so that metaconfig picks them up. */
3850
3851
3852 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
3853 /* Don't even need this function.  */
3854 #else
3855 STATIC void
3856 S_validate_suid(pTHX_ PerlIO *rsfp)
3857 {
3858     const Uid_t  my_uid = PerlProc_getuid();
3859     const Uid_t my_euid = PerlProc_geteuid();
3860     const Gid_t  my_gid = PerlProc_getgid();
3861     const Gid_t my_egid = PerlProc_getegid();
3862
3863     PERL_ARGS_ASSERT_VALIDATE_SUID;
3864
3865     if (my_euid != my_uid || my_egid != my_gid) {       /* (suidperl doesn't exist, in fact) */
3866         dVAR;
3867         int fd = PerlIO_fileno(rsfp);
3868         Stat_t statbuf;
3869         if (fd < 0 || PerlLIO_fstat(fd, &statbuf) < 0) { /* may be either wrapped or real suid */
3870             Perl_croak_nocontext( "Illegal suidscript");
3871         }
3872         if ((my_euid != my_uid && my_euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
3873             ||
3874             (my_egid != my_gid && my_egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
3875             )
3876             if (!PL_do_undump)
3877                 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
3878 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
3879         /* not set-id, must be wrapped */
3880     }
3881 }
3882 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
3883
3884 STATIC void
3885 S_find_beginning(pTHX_ SV* linestr_sv, PerlIO *rsfp)
3886 {
3887     const char *s;
3888     const char *s2;
3889
3890     PERL_ARGS_ASSERT_FIND_BEGINNING;
3891
3892     /* skip forward in input to the real script? */
3893
3894     do {
3895         if ((s = sv_gets(linestr_sv, rsfp, 0)) == NULL)
3896             Perl_croak(aTHX_ "No Perl script found in input\n");
3897         s2 = s;
3898     } while (!(*s == '#' && s[1] == '!' && ((s = instr(s,"perl")) || (s = instr(s2,"PERL")))));
3899     PerlIO_ungetc(rsfp, '\n');          /* to keep line count right */
3900     while (*s && !(isSPACE (*s) || *s == '#')) s++;
3901     s2 = s;
3902     while (*s == ' ' || *s == '\t') s++;
3903     if (*s++ == '-') {
3904         while (isDIGIT(s2[-1]) || s2[-1] == '-' || s2[-1] == '.'
3905                || s2[-1] == '_') s2--;
3906         if (strnEQ(s2-4,"perl",4))
3907             while ((s = moreswitches(s)))
3908                 ;
3909     }
3910 }
3911
3912
3913 STATIC void
3914 S_init_ids(pTHX)
3915 {
3916     /* no need to do anything here any more if we don't
3917      * do tainting. */
3918 #ifndef NO_TAINT_SUPPORT
3919     const Uid_t my_uid = PerlProc_getuid();
3920     const Uid_t my_euid = PerlProc_geteuid();
3921     const Gid_t my_gid = PerlProc_getgid();
3922     const Gid_t my_egid = PerlProc_getegid();
3923
3924     PERL_UNUSED_CONTEXT;
3925
3926     /* Should not happen: */
3927     CHECK_MALLOC_TAINT(my_uid && (my_euid != my_uid || my_egid != my_gid));
3928     TAINTING_set( TAINTING_get | (my_uid && (my_euid != my_uid || my_egid != my_gid)) );
3929 #endif
3930     /* BUG */
3931     /* PSz 27 Feb 04
3932      * Should go by suidscript, not uid!=euid: why disallow
3933      * system("ls") in scripts run from setuid things?
3934      * Or, is this run before we check arguments and set suidscript?
3935      * What about SETUID_SCRIPTS_ARE_SECURE_NOW: could we use fdscript then?
3936      * (We never have suidscript, can we be sure to have fdscript?)
3937      * Or must then go by UID checks? See comments in forbid_setid also.
3938      */
3939 }
3940
3941 /* This is used very early in the lifetime of the program,
3942  * before even the options are parsed, so PL_tainting has
3943  * not been initialized properly.  */
3944 bool
3945 Perl_doing_taint(int argc, char *argv[], char *envp[])
3946 {
3947 #ifndef PERL_IMPLICIT_SYS
3948     /* If we have PERL_IMPLICIT_SYS we can't call getuid() et alia
3949      * before we have an interpreter-- and the whole point of this
3950      * function is to be called at such an early stage.  If you are on
3951      * a system with PERL_IMPLICIT_SYS but you do have a concept of
3952      * "tainted because running with altered effective ids', you'll
3953      * have to add your own checks somewhere in here.  The two most
3954      * known samples of 'implicitness' are Win32 and NetWare, neither
3955      * of which has much of concept of 'uids'. */
3956     Uid_t uid  = PerlProc_getuid();
3957     Uid_t euid = PerlProc_geteuid();
3958     Gid_t gid  = PerlProc_getgid();
3959     Gid_t egid = PerlProc_getegid();
3960     (void)envp;
3961
3962 #ifdef VMS
3963     uid  |=  gid << 16;
3964     euid |= egid << 16;
3965 #endif
3966     if (uid && (euid != uid || egid != gid))
3967         return 1;
3968 #endif /* !PERL_IMPLICIT_SYS */
3969     /* This is a really primitive check; environment gets ignored only
3970      * if -T are the first chars together; otherwise one gets
3971      *  "Too late" message. */
3972     if ( argc > 1 && argv[1][0] == '-'
3973          && isALPHA_FOLD_EQ(argv[1][1], 't'))
3974         return 1;
3975     return 0;
3976 }
3977
3978 /* Passing the flag as a single char rather than a string is a slight space
3979    optimisation.  The only message that isn't /^-.$/ is
3980    "program input from stdin", which is substituted in place of '\0', which
3981    could never be a command line flag.  */
3982 STATIC void
3983 S_forbid_setid(pTHX_ const char flag, const bool suidscript) /* g */
3984 {
3985     char string[3] = "-x";
3986     const char *message = "program input from stdin";
3987
3988     PERL_UNUSED_CONTEXT;
3989     if (flag) {
3990         string[1] = flag;
3991         message = string;
3992     }
3993
3994 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
3995     if (PerlProc_getuid() != PerlProc_geteuid())
3996         Perl_croak(aTHX_ "No %s allowed while running setuid", message);
3997     if (PerlProc_getgid() != PerlProc_getegid())
3998         Perl_croak(aTHX_ "No %s allowed while running setgid", message);
3999 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
4000     if (suidscript)
4001         Perl_croak(aTHX_ "No %s allowed with (suid) fdscript", message);
4002 }
4003
4004 void
4005 Perl_init_dbargs(pTHX)
4006 {
4007     AV *const args = PL_dbargs = GvAV(gv_AVadd((gv_fetchpvs("DB::args",
4008                                                             GV_ADDMULTI,
4009                                                             SVt_PVAV))));
4010
4011     if (AvREAL(args)) {
4012         /* Someone has already created it.
4013            It might have entries, and if we just turn off AvREAL(), they will
4014            "leak" until global destruction.  */
4015         av_clear(args);
4016         if (SvTIED_mg((const SV *)args, PERL_MAGIC_tied))
4017             Perl_croak(aTHX_ "Cannot set tied @DB::args");
4018     }
4019     AvREIFY_only(PL_dbargs);
4020 }
4021
4022 void
4023 Perl_init_debugger(pTHX)
4024 {
4025     HV * const ostash = PL_curstash;
4026     MAGIC *mg;
4027
4028     PL_curstash = (HV *)SvREFCNT_inc_simple(PL_debstash);
4029
4030     Perl_init_dbargs(aTHX);
4031     PL_DBgv = MUTABLE_GV(
4032         SvREFCNT_inc(gv_fetchpvs("DB::DB", GV_ADDMULTI, SVt_PVGV))
4033     );
4034     PL_DBline = MUTABLE_GV(
4035         SvREFCNT_inc(gv_fetchpvs("DB::dbline", GV_ADDMULTI, SVt_PVAV))
4036     );
4037     PL_DBsub = MUTABLE_GV(SvREFCNT_inc(
4038         gv_HVadd(gv_fetchpvs("DB::sub", GV_ADDMULTI, SVt_PVHV))
4039     ));
4040     PL_DBsingle = GvSV((gv_fetchpvs("DB::single", GV_ADDMULTI, SVt_PV)));
4041     if (!SvIOK(PL_DBsingle))
4042         sv_setiv(PL_DBsingle, 0);
4043     mg = sv_magicext(PL_DBsingle, NULL, PERL_MAGIC_debugvar, &PL_vtbl_debugvar, 0, 0);
4044     mg->mg_private = DBVARMG_SINGLE;
4045     SvSETMAGIC(PL_DBsingle);
4046
4047     PL_DBtrace = GvSV((gv_fetchpvs("DB::trace", GV_ADDMULTI, SVt_PV)));
4048     if (!SvIOK(PL_DBtrace))
4049         sv_setiv(PL_DBtrace, 0);
4050     mg = sv_magicext(PL_DBtrace, NULL, PERL_MAGIC_debugvar, &PL_vtbl_debugvar, 0, 0);
4051     mg->mg_private = DBVARMG_TRACE;
4052     SvSETMAGIC(PL_DBtrace);
4053
4054     PL_DBsignal = GvSV((gv_fetchpvs("DB::signal", GV_ADDMULTI, SVt_PV)));
4055     if (!SvIOK(PL_DBsignal))
4056         sv_setiv(PL_DBsignal, 0);
4057     mg = sv_magicext(PL_DBsignal, NULL, PERL_MAGIC_debugvar, &PL_vtbl_debugvar, 0, 0);
4058     mg->mg_private = DBVARMG_SIGNAL;
4059     SvSETMAGIC(PL_DBsignal);
4060
4061     SvREFCNT_dec(PL_curstash);
4062     PL_curstash = ostash;
4063 }
4064
4065 #ifndef STRESS_REALLOC
4066 #define REASONABLE(size) (size)
4067 #define REASONABLE_but_at_least(size,min) (size)
4068 #else
4069 #define REASONABLE(size) (1) /* unreasonable */
4070 #define REASONABLE_but_at_least(size,min) (min)
4071 #endif
4072
4073 void
4074 Perl_init_stacks(pTHX)
4075 {
4076     /* start with 128-item stack and 8K cxstack */
4077     PL_curstackinfo = new_stackinfo(REASONABLE(128),
4078                                  REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
4079     PL_curstackinfo->si_type = PERLSI_MAIN;
4080     PL_curstack = PL_curstackinfo->si_stack;
4081     PL_mainstack = PL_curstack;         /* remember in case we switch stacks */
4082
4083     PL_stack_base = AvARRAY(PL_curstack);
4084     PL_stack_sp = PL_stack_base;
4085     PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
4086
4087     Newx(PL_tmps_stack,REASONABLE(128),SV*);
4088     PL_tmps_floor = -1;
4089     PL_tmps_ix = -1;
4090     PL_tmps_max = REASONABLE(128);
4091
4092     Newx(PL_markstack,REASONABLE(32),I32);
4093     PL_markstack_ptr = PL_markstack;
4094     PL_markstack_max = PL_markstack + REASONABLE(32);
4095
4096     SET_MARK_OFFSET;
4097
4098     Newx(PL_scopestack,REASONABLE(32),I32);
4099 #ifdef DEBUGGING
4100     Newx(PL_scopestack_name,REASONABLE(32),const char*);
4101 #endif
4102     PL_scopestack_ix = 0;
4103     PL_scopestack_max = REASONABLE(32);
4104
4105     Newx(PL_savestack,REASONABLE_but_at_least(128,SS_MAXPUSH),ANY);
4106     PL_savestack_ix = 0;
4107     PL_savestack_max = REASONABLE_but_at_least(128,SS_MAXPUSH);
4108 }
4109
4110 #undef REASONABLE
4111
4112 STATIC void
4113 S_nuke_stacks(pTHX)
4114 {
4115     while (PL_curstackinfo->si_next)
4116         PL_curstackinfo = PL_curstackinfo->si_next;
4117     while (PL_curstackinfo) {
4118         PERL_SI *p = PL_curstackinfo->si_prev;
4119         /* curstackinfo->si_stack got nuked by sv_free_arenas() */
4120         Safefree(PL_curstackinfo->si_cxstack);
4121         Safefree(PL_curstackinfo);
4122         PL_curstackinfo = p;
4123     }
4124     Safefree(PL_tmps_stack);
4125     Safefree(PL_markstack);
4126     Safefree(PL_scopestack);
4127 #ifdef DEBUGGING
4128     Safefree(PL_scopestack_name);
4129 #endif
4130     Safefree(PL_savestack);
4131 }
4132
4133 void
4134 Perl_populate_isa(pTHX_ const char *name, STRLEN len, ...)
4135 {
4136     GV *const gv = gv_fetchpvn(name, len, GV_ADD | GV_ADDMULTI, SVt_PVAV);
4137     AV *const isa = GvAVn(gv);
4138     va_list args;
4139
4140     PERL_ARGS_ASSERT_POPULATE_ISA;
4141
4142     if(AvFILLp(isa) != -1)
4143         return;
4144
4145     /* NOTE: No support for tied ISA */
4146
4147     va_start(args, len);
4148     do {
4149         const char *const parent = va_arg(args, const char*);
4150         size_t parent_len;
4151
4152         if (!parent)
4153             break;
4154         parent_len = va_arg(args, size_t);
4155
4156         /* Arguments are supplied with a trailing ::  */
4157         assert(parent_len > 2);
4158         assert(parent[parent_len - 1] == ':');
4159         assert(parent[parent_len - 2] == ':');
4160         av_push(isa, newSVpvn(parent, parent_len - 2));
4161         (void) gv_fetchpvn(parent, parent_len, GV_ADD, SVt_PVGV);
4162     } while (1);
4163     va_end(args);
4164 }
4165
4166
4167 STATIC void
4168 S_init_predump_symbols(pTHX)
4169 {
4170     GV *tmpgv;
4171     IO *io;
4172
4173     sv_setpvs(get_sv("\"", GV_ADD), " ");
4174     PL_ofsgv = (GV*)SvREFCNT_inc(gv_fetchpvs(",", GV_ADD|GV_NOTQUAL, SVt_PV));
4175
4176
4177     /* Historically, PVIOs were blessed into IO::Handle, unless
4178        FileHandle was loaded, in which case they were blessed into
4179        that. Action at a distance.
4180        However, if we simply bless into IO::Handle, we break code
4181        that assumes that PVIOs will have (among others) a seek
4182        method. IO::File inherits from IO::Handle and IO::Seekable,
4183        and provides the needed methods. But if we simply bless into
4184        it, then we break code that assumed that by loading
4185        IO::Handle, *it* would work.
4186        So a compromise is to set up the correct @IO::File::ISA,
4187        so that code that does C<use IO::Handle>; will still work.
4188     */
4189                    
4190     Perl_populate_isa(aTHX_ STR_WITH_LEN("IO::File::ISA"),
4191                       STR_WITH_LEN("IO::Handle::"),
4192                       STR_WITH_LEN("IO::Seekable::"),
4193                       STR_WITH_LEN("Exporter::"),
4194                       NULL);
4195
4196     PL_stdingv = gv_fetchpvs("STDIN", GV_ADD|GV_NOTQUAL, SVt_PVIO);
4197     GvMULTI_on(PL_stdingv);
4198     io = GvIOp(PL_stdingv);
4199     IoTYPE(io) = IoTYPE_RDONLY;
4200     IoIFP(io) = PerlIO_stdin();
4201     tmpgv = gv_fetchpvs("stdin", GV_ADD|GV_NOTQUAL, SVt_PV);
4202     GvMULTI_on(tmpgv);
4203     GvIOp(tmpgv) = MUTABLE_IO(SvREFCNT_inc_simple(io));
4204
4205     tmpgv = gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVIO);
4206     GvMULTI_on(tmpgv);
4207     io = GvIOp(tmpgv);
4208     IoTYPE(io) = IoTYPE_WRONLY;
4209     IoOFP(io) = IoIFP(io) = PerlIO_stdout();
4210     setdefout(tmpgv);
4211     tmpgv = gv_fetchpvs("stdout", GV_ADD|GV_NOTQUAL, SVt_PV);
4212     GvMULTI_on(tmpgv);
4213     GvIOp(tmpgv) = MUTABLE_IO(SvREFCNT_inc_simple(io));
4214
4215     PL_stderrgv = gv_fetchpvs("STDERR", GV_ADD|GV_NOTQUAL, SVt_PVIO);
4216     GvMULTI_on(PL_stderrgv);
4217     io = GvIOp(PL_stderrgv);
4218     IoTYPE(io) = IoTYPE_WRONLY;
4219     IoOFP(io) = IoIFP(io) = PerlIO_stderr();
4220     tmpgv = gv_fetchpvs("stderr", GV_ADD|GV_NOTQUAL, SVt_PV);
4221     GvMULTI_on(tmpgv);
4222     GvIOp(tmpgv) = MUTABLE_IO(SvREFCNT_inc_simple(io));
4223
4224     PL_statname = newSVpvs("");         /* last filename we did stat on */
4225 }
4226
4227 void
4228 Perl_init_argv_symbols(pTHX_ int argc, char **argv)
4229 {
4230     PERL_ARGS_ASSERT_INIT_ARGV_SYMBOLS;
4231
4232     argc--,argv++;      /* skip name of script */
4233     if (PL_doswitches) {
4234         for (; argc > 0 && **argv == '-'; argc--,argv++) {
4235             char *s;
4236             if (!argv[0][1])
4237                 break;
4238             if (argv[0][1] == '-' && !argv[0][2]) {
4239                 argc--,argv++;
4240                 break;
4241             }
4242             if ((s = strchr(argv[0], '='))) {
4243                 const char *const start_name = argv[0] + 1;
4244                 sv_setpv(GvSV(gv_fetchpvn_flags(start_name, s - start_name,
4245                                                 TRUE, SVt_PV)), s + 1);
4246             }
4247             else
4248                 sv_setiv(GvSV(gv_fetchpv(argv[0]+1, GV_ADD, SVt_PV)),1);
4249         }
4250     }
4251     if ((PL_argvgv = gv_fetchpvs("ARGV", GV_ADD|GV_NOTQUAL, SVt_PVAV))) {
4252         SvREFCNT_inc_simple_void_NN(PL_argvgv);
4253         GvMULTI_on(PL_argvgv);
4254         av_clear(GvAVn(PL_argvgv));
4255         for (; argc > 0; argc--,argv++) {
4256             SV * const sv = newSVpv(argv[0],0);
4257             av_push(GvAV(PL_argvgv),sv);
4258             if (!(PL_unicode & PERL_UNICODE_LOCALE_FLAG) || PL_utf8locale) {
4259                  if (PL_unicode & PERL_UNICODE_ARGV_FLAG)
4260                       SvUTF8_on(sv);
4261             }
4262             if (PL_unicode & PERL_UNICODE_WIDESYSCALLS_FLAG) /* Sarathy? */
4263                  (void)sv_utf8_decode(sv);
4264         }
4265     }
4266
4267     if (PL_inplace && (!PL_argvgv || AvFILL(GvAV(PL_argvgv)) == -1))
4268         Perl_ck_warner_d(aTHX_ packWARN(WARN_INPLACE),
4269                          "-i used with no filenames on the command line, "
4270                          "reading from STDIN");
4271 }
4272
4273 STATIC void
4274 S_init_postdump_symbols(pTHX_ int argc, char **argv, char **env)
4275 {
4276 #ifdef USE_ITHREADS
4277     dVAR;
4278 #endif
4279     GV* tmpgv;
4280
4281     PERL_ARGS_ASSERT_INIT_POSTDUMP_SYMBOLS;
4282
4283     PL_toptarget = newSV_type(SVt_PVIV);
4284     sv_setpvs(PL_toptarget, "");
4285     PL_bodytarget = newSV_type(SVt_PVIV);
4286     sv_setpvs(PL_bodytarget, "");
4287     PL_formtarget = PL_bodytarget;
4288
4289     TAINT;
4290
4291     init_argv_symbols(argc,argv);
4292
4293     if ((tmpgv = gv_fetchpvs("0", GV_ADD|GV_NOTQUAL, SVt_PV))) {
4294         sv_setpv(GvSV(tmpgv),PL_origfilename);
4295     }
4296     if ((PL_envgv = gv_fetchpvs("ENV", GV_ADD|GV_NOTQUAL, SVt_PVHV))) {
4297         HV *hv;
4298         bool env_is_not_environ;
4299         SvREFCNT_inc_simple_void_NN(PL_envgv);
4300         GvMULTI_on(PL_envgv);
4301         hv = GvHVn(PL_envgv);
4302         hv_magic(hv, NULL, PERL_MAGIC_env);
4303 #ifndef PERL_MICRO
4304 #ifdef USE_ENVIRON_ARRAY
4305         /* Note that if the supplied env parameter is actually a copy
4306            of the global environ then it may now point to free'd memory
4307            if the environment has been modified since. To avoid this
4308            problem we treat env==NULL as meaning 'use the default'
4309         */
4310         if (!env)
4311             env = environ;
4312         env_is_not_environ = env != environ;
4313         if (env_is_not_environ
4314 #  ifdef USE_ITHREADS
4315             && PL_curinterp == aTHX
4316 #  endif
4317            )
4318         {
4319             environ[0] = NULL;
4320         }
4321         if (env) {
4322           char *s, *old_var;
4323           SV *sv;
4324           for (; *env; env++) {
4325             old_var = *env;
4326
4327             if (!(s = strchr(old_var,'=')) || s == old_var)
4328                 continue;
4329
4330 #if defined(MSDOS) && !defined(DJGPP)
4331             *s = '\0';
4332             (void)strupr(old_var);
4333             *s = '=';
4334 #endif
4335             sv = newSVpv(s+1, 0);
4336             (void)hv_store(hv, old_var, s - old_var, sv, 0);
4337             if (env_is_not_environ)
4338                 mg_set(sv);
4339           }
4340       }
4341 #endif /* USE_ENVIRON_ARRAY */
4342 #endif /* !PERL_MICRO */
4343     }
4344     TAINT_NOT;
4345
4346     /* touch @F array to prevent spurious warnings 20020415 MJD */
4347     if (PL_minus_a) {
4348       (void) get_av("main::F", GV_ADD | GV_ADDMULTI);
4349     }
4350 }
4351
4352 STATIC void
4353 S_init_perllib(pTHX)
4354 {
4355 #ifndef VMS
4356     const char *perl5lib = NULL;
4357 #endif
4358     const char *s;
4359 #if defined(WIN32) && !defined(PERL_IS_MINIPERL)
4360     STRLEN len;
4361 #endif
4362
4363     if (!TAINTING_get) {
4364 #ifndef VMS
4365         perl5lib = PerlEnv_getenv("PERL5LIB");
4366 /*
4367  * It isn't possible to delete an environment variable with
4368  * PERL_USE_SAFE_PUTENV set unless unsetenv() is also available, so in that
4369  * case we treat PERL5LIB as undefined if it has a zero-length value.
4370  */
4371 #if defined(PERL_USE_SAFE_PUTENV) && ! defined(HAS_UNSETENV)
4372         if (perl5lib && *perl5lib != '\0')
4373 #else
4374         if (perl5lib)
4375 #endif
4376             incpush_use_sep(perl5lib, 0, INCPUSH_ADD_SUB_DIRS);
4377         else {
4378             s = PerlEnv_getenv("PERLLIB");
4379             if (s)
4380                 incpush_use_sep(s, 0, 0);
4381         }
4382 #else /* VMS */
4383         /* Treat PERL5?LIB as a possible search list logical name -- the
4384          * "natural" VMS idiom for a Unix path string.  We allow each
4385          * element to be a set of |-separated directories for compatibility.
4386          */
4387         char buf[256];
4388         int idx = 0;
4389         if (vmstrnenv("PERL5LIB",buf,0,NULL,0))
4390             do {
4391                 incpush_use_sep(buf, 0, INCPUSH_ADD_SUB_DIRS);
4392             } while (vmstrnenv("PERL5LIB",buf,++idx,NULL,0));
4393         else {
4394             while (vmstrnenv("PERLLIB",buf,idx++,NULL,0))
4395                 incpush_use_sep(buf, 0, 0);
4396         }
4397 #endif /* VMS */
4398     }
4399
4400 #ifndef PERL_IS_MINIPERL
4401     /* miniperl gets just -I..., the split of $ENV{PERL5LIB}, and "." in @INC
4402        (and not the architecture specific directories from $ENV{PERL5LIB}) */
4403
4404 /* Use the ~-expanded versions of APPLLIB (undocumented),
4405     SITEARCH, SITELIB, VENDORARCH, VENDORLIB, ARCHLIB and PRIVLIB
4406 */
4407 #ifdef APPLLIB_EXP
4408     S_incpush_use_sep(aTHX_ STR_WITH_LEN(APPLLIB_EXP),
4409                       INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE);
4410 #endif
4411
4412 #ifdef SITEARCH_EXP
4413     /* sitearch is always relative to sitelib on Windows for
4414      * DLL-based path intuition to work correctly */
4415 #  if !defined(WIN32)
4416         S_incpush_use_sep(aTHX_ STR_WITH_LEN(SITEARCH_EXP),
4417                           INCPUSH_CAN_RELOCATE);
4418 #  endif
4419 #endif
4420
4421 #ifdef SITELIB_EXP
4422 #  if defined(WIN32)
4423     /* this picks up sitearch as well */
4424         s = PerlEnv_sitelib_path(PERL_FS_VERSION, &len);
4425         if (s)
4426             incpush_use_sep(s, len, INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE);
4427 #  else
4428         S_incpush_use_sep(aTHX_ STR_WITH_LEN(SITELIB_EXP), INCPUSH_CAN_RELOCATE);
4429 #  endif
4430 #endif
4431
4432 #ifdef PERL_VENDORARCH_EXP
4433     /* vendorarch is always relative to vendorlib on Windows for
4434      * DLL-based path intuition to work correctly */
4435 #  if !defined(WIN32)
4436     S_incpush_use_sep(aTHX_ STR_WITH_LEN(PERL_VENDORARCH_EXP),
4437                       INCPUSH_CAN_RELOCATE);
4438 #  endif
4439 #endif
4440
4441 #ifdef PERL_VENDORLIB_EXP
4442 #  if defined(WIN32)
4443     /* this picks up vendorarch as well */
4444         s = PerlEnv_vendorlib_path(PERL_FS_VERSION, &len);
4445         if (s)
4446             incpush_use_sep(s, len, INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE);
4447 #  else
4448         S_incpush_use_sep(aTHX_ STR_WITH_LEN(PERL_VENDORLIB_EXP),
4449                           INCPUSH_CAN_RELOCATE);
4450 #  endif
4451 #endif
4452
4453 #ifdef ARCHLIB_EXP
4454     S_incpush_use_sep(aTHX_ STR_WITH_LEN(ARCHLIB_EXP), INCPUSH_CAN_RELOCATE);
4455 #endif
4456
4457 #ifndef PRIVLIB_EXP
4458 #  define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
4459 #endif
4460
4461 #if defined(WIN32)
4462     s = PerlEnv_lib_path(PERL_FS_VERSION, &len);
4463     if (s)
4464         incpush_use_sep(s, len, INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE);
4465 #else
4466 #  ifdef NETWARE
4467     S_incpush_use_sep(aTHX_ PRIVLIB_EXP, 0, INCPUSH_CAN_RELOCATE);
4468 #  else
4469     S_incpush_use_sep(aTHX_ STR_WITH_LEN(PRIVLIB_EXP), INCPUSH_CAN_RELOCATE);
4470 #  endif
4471 #endif
4472
4473 #ifdef PERL_OTHERLIBDIRS
4474     S_incpush_use_sep(aTHX_ STR_WITH_LEN(PERL_OTHERLIBDIRS),
4475                       INCPUSH_ADD_VERSIONED_SUB_DIRS|INCPUSH_NOT_BASEDIR
4476                       |INCPUSH_CAN_RELOCATE);
4477 #endif
4478
4479     if (!TAINTING_get) {
4480 #ifndef VMS
4481 /*
4482  * It isn't possible to delete an environment variable with
4483  * PERL_USE_SAFE_PUTENV set unless unsetenv() is also available, so in that
4484  * case we treat PERL5LIB as undefined if it has a zero-length value.
4485  */
4486 #if defined(PERL_USE_SAFE_PUTENV) && ! defined(HAS_UNSETENV)
4487         if (perl5lib && *perl5lib != '\0')
4488 #else
4489         if (perl5lib)
4490 #endif
4491             incpush_use_sep(perl5lib, 0,
4492                             INCPUSH_ADD_OLD_VERS|INCPUSH_NOT_BASEDIR);
4493 #else /* VMS */
4494         /* Treat PERL5?LIB as a possible search list logical name -- the
4495          * "natural" VMS idiom for a Unix path string.  We allow each
4496          * element to be a set of |-separated directories for compatibility.
4497          */
4498         char buf[256];
4499         int idx = 0;
4500         if (vmstrnenv("PERL5LIB",buf,0,NULL,0))
4501             do {
4502                 incpush_use_sep(buf, 0,
4503                                 INCPUSH_ADD_OLD_VERS|INCPUSH_NOT_BASEDIR);
4504             } while (vmstrnenv("PERL5LIB",buf,++idx,NULL,0));
4505 #endif /* VMS */
4506     }
4507
4508 /* Use the ~-expanded versions of APPLLIB (undocumented),
4509     SITELIB and VENDORLIB for older versions
4510 */
4511 #ifdef APPLLIB_EXP
4512     S_incpush_use_sep(aTHX_ STR_WITH_LEN(APPLLIB_EXP), INCPUSH_ADD_OLD_VERS
4513                       |INCPUSH_NOT_BASEDIR|INCPUSH_CAN_RELOCATE);
4514 #endif
4515
4516 #if defined(SITELIB_STEM) && defined(PERL_INC_VERSION_LIST)
4517     /* Search for version-specific dirs below here */
4518     S_incpush_use_sep(aTHX_ STR_WITH_LEN(SITELIB_STEM),
4519                       INCPUSH_ADD_OLD_VERS|INCPUSH_CAN_RELOCATE);
4520 #endif
4521
4522
4523 #if defined(PERL_VENDORLIB_STEM) && defined(PERL_INC_VERSION_LIST)
4524     /* Search for version-specific dirs below here */
4525     S_incpush_use_sep(aTHX_ STR_WITH_LEN(PERL_VENDORLIB_STEM),
4526                       INCPUSH_ADD_OLD_VERS|INCPUSH_CAN_RELOCATE);
4527 #endif
4528
4529 #ifdef PERL_OTHERLIBDIRS
4530     S_incpush_use_sep(aTHX_ STR_WITH_LEN(PERL_OTHERLIBDIRS),
4531                       INCPUSH_ADD_OLD_VERS|INCPUSH_ADD_ARCHONLY_SUB_DIRS
4532                       |INCPUSH_CAN_RELOCATE);
4533 #endif
4534 #endif /* !PERL_IS_MINIPERL */
4535
4536     if (!TAINTING_get)
4537         S_incpush(aTHX_ STR_WITH_LEN("."), 0);
4538 }
4539
4540 #if defined(DOSISH) || defined(__SYMBIAN32__)
4541 #    define PERLLIB_SEP ';'
4542 #else
4543 #  if defined(VMS)
4544 #    define PERLLIB_SEP '|'
4545 #  else
4546 #    define PERLLIB_SEP ':'
4547 #  endif
4548 #endif
4549 #ifndef PERLLIB_MANGLE
4550 #  define PERLLIB_MANGLE(s,n) (s)
4551 #endif
4552
4553 #ifndef PERL_IS_MINIPERL
4554 /* Push a directory onto @INC if it exists.
4555    Generate a new SV if we do this, to save needing to copy the SV we push
4556    onto @INC  */
4557 STATIC SV *
4558 S_incpush_if_exists(pTHX_ AV *const av, SV *dir, SV *const stem)
4559 {
4560     Stat_t tmpstatbuf;
4561
4562     PERL_ARGS_ASSERT_INCPUSH_IF_EXISTS;
4563
4564     if (PerlLIO_stat(SvPVX_const(dir), &tmpstatbuf) >= 0 &&
4565         S_ISDIR(tmpstatbuf.st_mode)) {
4566         av_push(av, dir);
4567         dir = newSVsv(stem);
4568     } else {
4569         /* Truncate dir back to stem.  */
4570         SvCUR_set(dir, SvCUR(stem));
4571     }
4572     return dir;
4573 }
4574 #endif
4575
4576 STATIC SV *
4577 S_mayberelocate(pTHX_ const char *const dir, STRLEN len, U32 flags)
4578 {
4579     const U8 canrelocate = (U8)flags & INCPUSH_CAN_RELOCATE;
4580     SV *libdir;
4581
4582     PERL_ARGS_ASSERT_MAYBERELOCATE;
4583     assert(len > 0);
4584
4585     /* I am not convinced that this is valid when PERLLIB_MANGLE is
4586        defined to so something (in os2/os2.c), but the code has been
4587        this way, ignoring any possible changed of length, since
4588        760ac839baf413929cd31cc32ffd6dba6b781a81 (5.003_02) so I'll leave
4589        it be.  */
4590     libdir = newSVpvn(PERLLIB_MANGLE(dir, len), len);
4591
4592 #ifdef VMS
4593     {
4594         char *unix;
4595
4596         if ((unix = tounixspec_ts(SvPV(libdir,len),NULL)) != NULL) {
4597             len = strlen(unix);
4598             while (len > 1 && unix[len-1] == '/') len--;  /* Cosmetic */
4599             sv_usepvn(libdir,unix,len);
4600         }
4601         else
4602             PerlIO_printf(Perl_error_log,
4603                           "Failed to unixify @INC element \"%s\"\n",
4604                           SvPV_nolen_const(libdir));
4605     }
4606 #endif
4607
4608         /* Do the if() outside the #ifdef to avoid warnings about an unused
4609            parameter.  */
4610         if (canrelocate) {
4611 #ifdef PERL_RELOCATABLE_INC
4612         /*
4613          * Relocatable include entries are marked with a leading .../
4614          *
4615          * The algorithm is
4616          * 0: Remove that leading ".../"
4617          * 1: Remove trailing executable name (anything after the last '/')
4618          *    from the perl path to give a perl prefix
4619          * Then
4620          * While the @INC element starts "../" and the prefix ends with a real
4621          * directory (ie not . or ..) chop that real directory off the prefix
4622          * and the leading "../" from the @INC element. ie a logical "../"
4623          * cleanup
4624          * Finally concatenate the prefix and the remainder of the @INC element
4625          * The intent is that /usr/local/bin/perl and .../../lib/perl5
4626          * generates /usr/local/lib/perl5
4627          */
4628             const char *libpath = SvPVX(libdir);
4629             STRLEN libpath_len = SvCUR(libdir);
4630             if (libpath_len >= 4 && memEQ (libpath, ".../", 4)) {
4631                 /* Game on!  */
4632                 SV * const caret_X = get_sv("\030", 0);
4633                 /* Going to use the SV just as a scratch buffer holding a C
4634                    string:  */
4635                 SV *prefix_sv;
4636                 char *prefix;
4637                 char *lastslash;
4638
4639                 /* $^X is *the* source of taint if tainting is on, hence
4640                    SvPOK() won't be true.  */
4641                 assert(caret_X);
4642                 assert(SvPOKp(caret_X));
4643                 prefix_sv = newSVpvn_flags(SvPVX(caret_X), SvCUR(caret_X),
4644                                            SvUTF8(caret_X));
4645                 /* Firstly take off the leading .../
4646                    If all else fail we'll do the paths relative to the current
4647                    directory.  */
4648                 sv_chop(libdir, libpath + 4);
4649                 /* Don't use SvPV as we're intentionally bypassing taining,
4650                    mortal copies that the mg_get of tainting creates, and
4651                    corruption that seems to come via the save stack.
4652                    I guess that the save stack isn't correctly set up yet.  */
4653                 libpath = SvPVX(libdir);
4654                 libpath_len = SvCUR(libdir);
4655
4656                 /* This would work more efficiently with memrchr, but as it's
4657                    only a GNU extension we'd need to probe for it and
4658                    implement our own. Not hard, but maybe not worth it?  */
4659
4660                 prefix = SvPVX(prefix_sv);
4661                 lastslash = strrchr(prefix, '/');
4662
4663                 /* First time in with the *lastslash = '\0' we just wipe off
4664                    the trailing /perl from (say) /usr/foo/bin/perl
4665                 */
4666                 if (lastslash) {
4667                     SV *tempsv;
4668                     while ((*lastslash = '\0'), /* Do that, come what may.  */
4669                            (libpath_len >= 3 && memEQ(libpath, "../", 3)
4670                             && (lastslash = strrchr(prefix, '/')))) {
4671                         if (lastslash[1] == '\0'
4672                             || (lastslash[1] == '.'
4673                                 && (lastslash[2] == '/' /* ends "/."  */
4674                                     || (lastslash[2] == '/'
4675                                         && lastslash[3] == '/' /* or "/.."  */
4676                                         )))) {
4677                             /* Prefix ends "/" or "/." or "/..", any of which
4678                                are fishy, so don't do any more logical cleanup.
4679                             */
4680                             break;
4681                         }
4682                         /* Remove leading "../" from path  */
4683                         libpath += 3;
4684                         libpath_len -= 3;
4685                         /* Next iteration round the loop removes the last
4686                            directory name from prefix by writing a '\0' in
4687                            the while clause.  */
4688                     }
4689                     /* prefix has been terminated with a '\0' to the correct
4690                        length. libpath points somewhere into the libdir SV.
4691                        We need to join the 2 with '/' and drop the result into
4692                        libdir.  */
4693                     tempsv = Perl_newSVpvf(aTHX_ "%s/%s", prefix, libpath);
4694                     SvREFCNT_dec(libdir);
4695                     /* And this is the new libdir.  */
4696                     libdir = tempsv;
4697                     if (TAINTING_get &&
4698                         (PerlProc_getuid() != PerlProc_geteuid() ||
4699                          PerlProc_getgid() != PerlProc_getegid())) {
4700                         /* Need to taint relocated paths if running set ID  */
4701                         SvTAINTED_on(libdir);
4702                     }
4703                 }
4704                 SvREFCNT_dec(prefix_sv);
4705             }
4706 #endif
4707         }
4708     return libdir;
4709 }
4710
4711 STATIC void
4712 S_incpush(pTHX_ const char *const dir, STRLEN len, U32 flags)
4713 {
4714 #ifndef PERL_IS_MINIPERL
4715     const U8 using_sub_dirs
4716         = (U8)flags & (INCPUSH_ADD_VERSIONED_SUB_DIRS
4717                        |INCPUSH_ADD_ARCHONLY_SUB_DIRS|INCPUSH_ADD_OLD_VERS);
4718     const U8 add_versioned_sub_dirs
4719         = (U8)flags & INCPUSH_ADD_VERSIONED_SUB_DIRS;
4720     const U8 add_archonly_sub_dirs
4721         = (U8)flags & INCPUSH_ADD_ARCHONLY_SUB_DIRS;
4722 #ifdef PERL_INC_VERSION_LIST
4723     const U8 addoldvers  = (U8)flags & INCPUSH_ADD_OLD_VERS;
4724 #endif
4725 #endif
4726     const U8 unshift     = (U8)flags & INCPUSH_UNSHIFT;
4727     const U8 push_basedir = (flags & INCPUSH_NOT_BASEDIR) ? 0 : 1;
4728     AV *const inc = GvAVn(PL_incgv);
4729
4730     PERL_ARGS_ASSERT_INCPUSH;
4731     assert(len > 0);
4732
4733     /* Could remove this vestigial extra block, if we don't mind a lot of
4734        re-indenting diff noise.  */
4735     {
4736         SV *const libdir = mayberelocate(dir, len, flags);
4737         /* Change 20189146be79a0596543441fa369c6bf7f85103f, to fix RT#6665,
4738            arranged to unshift #! line -I onto the front of @INC. However,
4739            -I can add version and architecture specific libraries, and they
4740            need to go first. The old code assumed that it was always
4741            pushing. Hence to make it work, need to push the architecture
4742            (etc) libraries onto a temporary array, then "unshift" that onto
4743            the front of @INC.  */
4744 #ifndef PERL_IS_MINIPERL
4745         AV *const av = (using_sub_dirs) ? (unshift ? newAV() : inc) : NULL;
4746
4747         /*
4748          * BEFORE pushing libdir onto @INC we may first push version- and
4749          * archname-specific sub-directories.
4750          */
4751         if (using_sub_dirs) {
4752             SV *subdir = newSVsv(libdir);
4753 #ifdef PERL_INC_VERSION_LIST
4754             /* Configure terminates PERL_INC_VERSION_LIST with a NULL */
4755             const char * const incverlist[] = { PERL_INC_VERSION_LIST };
4756             const char * const *incver;
4757 #endif
4758
4759             if (add_versioned_sub_dirs) {
4760                 /* .../version/archname if -d .../version/archname */
4761                 sv_catpvs(subdir, "/" PERL_FS_VERSION "/" ARCHNAME);
4762                 subdir = S_incpush_if_exists(aTHX_ av, subdir, libdir);
4763
4764                 /* .../version if -d .../version */
4765                 sv_catpvs(subdir, "/" PERL_FS_VERSION);
4766                 subdir = S_incpush_if_exists(aTHX_ av, subdir, libdir);
4767             }
4768
4769 #ifdef PERL_INC_VERSION_LIST
4770             if (addoldvers) {
4771                 for (incver = incverlist; *incver; incver++) {
4772                     /* .../xxx if -d .../xxx */
4773                     Perl_sv_catpvf(aTHX_ subdir, "/%s", *incver);
4774                     subdir = S_incpush_if_exists(aTHX_ av, subdir, libdir);
4775                 }
4776             }
4777 #endif
4778
4779             if (add_archonly_sub_dirs) {
4780                 /* .../archname if -d .../archname */
4781                 sv_catpvs(subdir, "/" ARCHNAME);
4782                 subdir = S_incpush_if_exists(aTHX_ av, subdir, libdir);
4783
4784             }
4785
4786             assert (SvREFCNT(subdir) == 1);
4787             SvREFCNT_dec(subdir);
4788         }
4789 #endif /* !PERL_IS_MINIPERL */
4790         /* finally add this lib directory at the end of @INC */
4791         if (unshift) {
4792 #ifdef PERL_IS_MINIPERL
4793             const Size_t extra = 0;
4794 #else
4795             Size_t extra = av_tindex(av) + 1;
4796 #endif
4797             av_unshift(inc, extra + push_basedir);
4798             if (push_basedir)
4799                 av_store(inc, extra, libdir);
4800 #ifndef PERL_IS_MINIPERL
4801             while (extra--) {
4802                 /* av owns a reference, av_store() expects to be donated a
4803                    reference, and av expects to be sane when it's cleared.
4804                    If I wanted to be naughty and wrong, I could peek inside the
4805                    implementation of av_clear(), realise that it uses
4806                    SvREFCNT_dec() too, so av's array could be a run of NULLs,
4807                    and so directly steal from it (with a memcpy() to inc, and
4808                    then memset() to NULL them out. But people copy code from the
4809                    core expecting it to be best practise, so let's use the API.
4810                    Although studious readers will note that I'm not checking any
4811                    return codes.  */
4812                 av_store(inc, extra, SvREFCNT_inc(*av_fetch(av, extra, FALSE)));
4813             }
4814             SvREFCNT_dec(av);
4815 #endif
4816         }
4817         else if (push_basedir) {
4818             av_push(inc, libdir);
4819         }
4820
4821         if (!push_basedir) {
4822             assert (SvREFCNT(libdir) == 1);
4823             SvREFCNT_dec(libdir);
4824         }
4825     }
4826 }
4827
4828 STATIC void
4829 S_incpush_use_sep(pTHX_ const char *p, STRLEN len, U32 flags)
4830 {
4831     const char *s;
4832     const char *end;
4833     /* This logic has been broken out from S_incpush(). It may be possible to
4834        simplify it.  */
4835
4836     PERL_ARGS_ASSERT_INCPUSH_USE_SEP;
4837
4838     /* perl compiled with -DPERL_RELOCATABLE_INCPUSH will ignore the len
4839