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