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