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