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