86fb8d9c4be9d64dd4a0c91e258c477b589db744
[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 tmpfd = mkstemp(tmpname);
3766             if (tmpfd > -1) {
3767                 scriptname = tmpname;
3768                 close(tmpfd);
3769             } else
3770                 Perl_croak(aTHX_ err);
3771 #else
3772 #  ifdef HAS_MKTEMP
3773             scriptname = mktemp(tmpname);
3774             if (!scriptname)
3775                 Perl_croak(aTHX_ err);
3776 #  endif
3777 #endif
3778         }
3779 #endif
3780         rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
3781 #ifdef FAKE_BIT_BUCKET
3782         if (memEQ(scriptname, FAKE_BIT_BUCKET_PREFIX,
3783                   sizeof(FAKE_BIT_BUCKET_PREFIX) - 1)
3784             && strlen(scriptname) == sizeof(tmpname) - 1) {
3785             unlink(scriptname);
3786         }
3787         scriptname = BIT_BUCKET;
3788 #endif
3789     }
3790     if (!rsfp) {
3791         /* PSz 16 Sep 03  Keep neat error message */
3792         if (PL_e_script)
3793             Perl_croak(aTHX_ "Can't open "BIT_BUCKET": %s\n", Strerror(errno));
3794         else
3795             Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
3796                     CopFILE(PL_curcop), Strerror(errno));
3797     }
3798 #if defined(HAS_FCNTL) && defined(F_SETFD)
3799     /* ensure close-on-exec */
3800     fcntl(PerlIO_fileno(rsfp), F_SETFD, 1);
3801 #endif
3802
3803     if (PerlLIO_fstat(PerlIO_fileno(rsfp), &tmpstatbuf) >= 0
3804         && S_ISDIR(tmpstatbuf.st_mode))
3805         Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
3806             CopFILE(PL_curcop),
3807             Strerror(EISDIR));
3808
3809     return rsfp;
3810 }
3811
3812 /* Mention
3813  * I_SYSSTATVFS HAS_FSTATVFS
3814  * I_SYSMOUNT
3815  * I_STATFS     HAS_FSTATFS     HAS_GETFSSTAT
3816  * I_MNTENT     HAS_GETMNTENT   HAS_HASMNTOPT
3817  * here so that metaconfig picks them up. */
3818
3819
3820 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
3821 /* Don't even need this function.  */
3822 #else
3823 STATIC void
3824 S_validate_suid(pTHX_ PerlIO *rsfp)
3825 {
3826     const Uid_t  my_uid = PerlProc_getuid();
3827     const Uid_t my_euid = PerlProc_geteuid();
3828     const Gid_t  my_gid = PerlProc_getgid();
3829     const Gid_t my_egid = PerlProc_getegid();
3830
3831     PERL_ARGS_ASSERT_VALIDATE_SUID;
3832
3833     if (my_euid != my_uid || my_egid != my_gid) {       /* (suidperl doesn't exist, in fact) */
3834         dVAR;
3835
3836         PerlLIO_fstat(PerlIO_fileno(rsfp),&PL_statbuf); /* may be either wrapped or real suid */
3837         if ((my_euid != my_uid && my_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
3838             ||
3839             (my_egid != my_gid && my_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
3840            )
3841             if (!PL_do_undump)
3842                 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
3843 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
3844         /* not set-id, must be wrapped */
3845     }
3846 }
3847 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
3848
3849 STATIC void
3850 S_find_beginning(pTHX_ SV* linestr_sv, PerlIO *rsfp)
3851 {
3852     dVAR;
3853     const char *s;
3854     const char *s2;
3855
3856     PERL_ARGS_ASSERT_FIND_BEGINNING;
3857
3858     /* skip forward in input to the real script? */
3859
3860     do {
3861         if ((s = sv_gets(linestr_sv, rsfp, 0)) == NULL)
3862             Perl_croak(aTHX_ "No Perl script found in input\n");
3863         s2 = s;
3864     } while (!(*s == '#' && s[1] == '!' && ((s = instr(s,"perl")) || (s = instr(s2,"PERL")))));
3865     PerlIO_ungetc(rsfp, '\n');          /* to keep line count right */
3866     while (*s && !(isSPACE (*s) || *s == '#')) s++;
3867     s2 = s;
3868     while (*s == ' ' || *s == '\t') s++;
3869     if (*s++ == '-') {
3870         while (isDIGIT(s2[-1]) || s2[-1] == '-' || s2[-1] == '.'
3871                || s2[-1] == '_') s2--;
3872         if (strnEQ(s2-4,"perl",4))
3873             while ((s = moreswitches(s)))
3874                 ;
3875     }
3876 }
3877
3878
3879 STATIC void
3880 S_init_ids(pTHX)
3881 {
3882     /* no need to do anything here any more if we don't
3883      * do tainting. */
3884 #ifndef NO_TAINT_SUPPORT
3885     dVAR;
3886     const Uid_t my_uid = PerlProc_getuid();
3887     const Uid_t my_euid = PerlProc_geteuid();
3888     const Gid_t my_gid = PerlProc_getgid();
3889     const Gid_t my_egid = PerlProc_getegid();
3890
3891     /* Should not happen: */
3892     CHECK_MALLOC_TAINT(my_uid && (my_euid != my_uid || my_egid != my_gid));
3893     TAINTING_set( TAINTING_get | (my_uid && (my_euid != my_uid || my_egid != my_gid)) );
3894 #endif
3895     /* BUG */
3896     /* PSz 27 Feb 04
3897      * Should go by suidscript, not uid!=euid: why disallow
3898      * system("ls") in scripts run from setuid things?
3899      * Or, is this run before we check arguments and set suidscript?
3900      * What about SETUID_SCRIPTS_ARE_SECURE_NOW: could we use fdscript then?
3901      * (We never have suidscript, can we be sure to have fdscript?)
3902      * Or must then go by UID checks? See comments in forbid_setid also.
3903      */
3904 }
3905
3906 /* This is used very early in the lifetime of the program,
3907  * before even the options are parsed, so PL_tainting has
3908  * not been initialized properly.  */
3909 bool
3910 Perl_doing_taint(int argc, char *argv[], char *envp[])
3911 {
3912 #ifndef PERL_IMPLICIT_SYS
3913     /* If we have PERL_IMPLICIT_SYS we can't call getuid() et alia
3914      * before we have an interpreter-- and the whole point of this
3915      * function is to be called at such an early stage.  If you are on
3916      * a system with PERL_IMPLICIT_SYS but you do have a concept of
3917      * "tainted because running with altered effective ids', you'll
3918      * have to add your own checks somewhere in here.  The two most
3919      * known samples of 'implicitness' are Win32 and NetWare, neither
3920      * of which has much of concept of 'uids'. */
3921     Uid_t uid  = PerlProc_getuid();
3922     Uid_t euid = PerlProc_geteuid();
3923     Gid_t gid  = PerlProc_getgid();
3924     Gid_t egid = PerlProc_getegid();
3925     (void)envp;
3926
3927 #ifdef VMS
3928     uid  |=  gid << 16;
3929     euid |= egid << 16;
3930 #endif
3931     if (uid && (euid != uid || egid != gid))
3932         return 1;
3933 #endif /* !PERL_IMPLICIT_SYS */
3934     /* This is a really primitive check; environment gets ignored only
3935      * if -T are the first chars together; otherwise one gets
3936      *  "Too late" message. */
3937     if ( argc > 1 && argv[1][0] == '-'
3938          && (argv[1][1] == 't' || argv[1][1] == 'T') )
3939         return 1;
3940     return 0;
3941 }
3942
3943 /* Passing the flag as a single char rather than a string is a slight space
3944    optimisation.  The only message that isn't /^-.$/ is
3945    "program input from stdin", which is substituted in place of '\0', which
3946    could never be a command line flag.  */
3947 STATIC void
3948 S_forbid_setid(pTHX_ const char flag, const bool suidscript) /* g */
3949 {
3950     dVAR;
3951     char string[3] = "-x";
3952     const char *message = "program input from stdin";
3953
3954     if (flag) {
3955         string[1] = flag;
3956         message = string;
3957     }
3958
3959 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
3960     if (PerlProc_getuid() != PerlProc_geteuid())
3961         Perl_croak(aTHX_ "No %s allowed while running setuid", message);
3962     if (PerlProc_getgid() != PerlProc_getegid())
3963         Perl_croak(aTHX_ "No %s allowed while running setgid", message);
3964 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
3965     if (suidscript)
3966         Perl_croak(aTHX_ "No %s allowed with (suid) fdscript", message);
3967 }
3968
3969 void
3970 Perl_init_dbargs(pTHX)
3971 {
3972     AV *const args = PL_dbargs = GvAV(gv_AVadd((gv_fetchpvs("DB::args",
3973                                                             GV_ADDMULTI,
3974                                                             SVt_PVAV))));
3975
3976     if (AvREAL(args)) {
3977         /* Someone has already created it.
3978            It might have entries, and if we just turn off AvREAL(), they will
3979            "leak" until global destruction.  */
3980         av_clear(args);
3981         if (SvTIED_mg((const SV *)args, PERL_MAGIC_tied))
3982             Perl_croak(aTHX_ "Cannot set tied @DB::args");
3983     }
3984     AvREIFY_only(PL_dbargs);
3985 }
3986
3987 void
3988 Perl_init_debugger(pTHX)
3989 {
3990     dVAR;
3991     HV * const ostash = PL_curstash;
3992
3993     PL_curstash = (HV *)SvREFCNT_inc_simple(PL_debstash);
3994
3995     Perl_init_dbargs(aTHX);
3996     PL_DBgv = MUTABLE_GV(
3997         SvREFCNT_inc(gv_fetchpvs("DB::DB", GV_ADDMULTI, SVt_PVGV))
3998     );
3999     PL_DBline = MUTABLE_GV(
4000         SvREFCNT_inc(gv_fetchpvs("DB::dbline", GV_ADDMULTI, SVt_PVAV))
4001     );
4002     PL_DBsub = MUTABLE_GV(SvREFCNT_inc(
4003         gv_HVadd(gv_fetchpvs("DB::sub", GV_ADDMULTI, SVt_PVHV))
4004     ));
4005     PL_DBsingle = GvSV((gv_fetchpvs("DB::single", GV_ADDMULTI, SVt_PV)));
4006     if (!SvIOK(PL_DBsingle))
4007         sv_setiv(PL_DBsingle, 0);
4008     PL_DBtrace = GvSV((gv_fetchpvs("DB::trace", GV_ADDMULTI, SVt_PV)));
4009     if (!SvIOK(PL_DBtrace))
4010         sv_setiv(PL_DBtrace, 0);
4011     PL_DBsignal = GvSV((gv_fetchpvs("DB::signal", GV_ADDMULTI, SVt_PV)));
4012     if (!SvIOK(PL_DBsignal))
4013         sv_setiv(PL_DBsignal, 0);
4014     SvREFCNT_dec(PL_curstash);
4015     PL_curstash = ostash;
4016 }
4017
4018 #ifndef STRESS_REALLOC
4019 #define REASONABLE(size) (size)
4020 #define REASONABLE_but_at_least(size,min) (size)
4021 #else
4022 #define REASONABLE(size) (1) /* unreasonable */
4023 #define REASONABLE_but_at_least(size,min) (min)
4024 #endif
4025
4026 void
4027 Perl_init_stacks(pTHX)
4028 {
4029     dVAR;
4030     /* start with 128-item stack and 8K cxstack */
4031     PL_curstackinfo = new_stackinfo(REASONABLE(128),
4032                                  REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
4033     PL_curstackinfo->si_type = PERLSI_MAIN;
4034     PL_curstack = PL_curstackinfo->si_stack;
4035     PL_mainstack = PL_curstack;         /* remember in case we switch stacks */
4036
4037     PL_stack_base = AvARRAY(PL_curstack);
4038     PL_stack_sp = PL_stack_base;
4039     PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
4040
4041     Newx(PL_tmps_stack,REASONABLE(128),SV*);
4042     PL_tmps_floor = -1;
4043     PL_tmps_ix = -1;
4044     PL_tmps_max = REASONABLE(128);
4045
4046     Newx(PL_markstack,REASONABLE(32),I32);
4047     PL_markstack_ptr = PL_markstack;
4048     PL_markstack_max = PL_markstack + REASONABLE(32);
4049
4050     SET_MARK_OFFSET;
4051
4052     Newx(PL_scopestack,REASONABLE(32),I32);
4053 #ifdef DEBUGGING
4054     Newx(PL_scopestack_name,REASONABLE(32),const char*);
4055 #endif
4056     PL_scopestack_ix = 0;
4057     PL_scopestack_max = REASONABLE(32);
4058
4059     Newx(PL_savestack,REASONABLE_but_at_least(128,SS_MAXPUSH),ANY);
4060     PL_savestack_ix = 0;
4061     PL_savestack_max = REASONABLE_but_at_least(128,SS_MAXPUSH);
4062 }
4063
4064 #undef REASONABLE
4065
4066 STATIC void
4067 S_nuke_stacks(pTHX)
4068 {
4069     dVAR;
4070     while (PL_curstackinfo->si_next)
4071         PL_curstackinfo = PL_curstackinfo->si_next;
4072     while (PL_curstackinfo) {
4073         PERL_SI *p = PL_curstackinfo->si_prev;
4074         /* curstackinfo->si_stack got nuked by sv_free_arenas() */
4075         Safefree(PL_curstackinfo->si_cxstack);
4076         Safefree(PL_curstackinfo);
4077         PL_curstackinfo = p;
4078     }
4079     Safefree(PL_tmps_stack);
4080     Safefree(PL_markstack);
4081     Safefree(PL_scopestack);
4082 #ifdef DEBUGGING
4083     Safefree(PL_scopestack_name);
4084 #endif
4085     Safefree(PL_savestack);
4086 }
4087
4088 void
4089 Perl_populate_isa(pTHX_ const char *name, STRLEN len, ...)
4090 {
4091     GV *const gv = gv_fetchpvn(name, len, GV_ADD | GV_ADDMULTI, SVt_PVAV);
4092     AV *const isa = GvAVn(gv);
4093     va_list args;
4094
4095     PERL_ARGS_ASSERT_POPULATE_ISA;
4096
4097     if(AvFILLp(isa) != -1)
4098         return;
4099
4100     /* NOTE: No support for tied ISA */
4101
4102     va_start(args, len);
4103     do {
4104         const char *const parent = va_arg(args, const char*);
4105         size_t parent_len;
4106
4107         if (!parent)
4108             break;
4109         parent_len = va_arg(args, size_t);
4110
4111         /* Arguments are supplied with a trailing ::  */
4112         assert(parent_len > 2);
4113         assert(parent[parent_len - 1] == ':');
4114         assert(parent[parent_len - 2] == ':');
4115         av_push(isa, newSVpvn(parent, parent_len - 2));
4116         (void) gv_fetchpvn(parent, parent_len, GV_ADD, SVt_PVGV);
4117     } while (1);
4118     va_end(args);
4119 }
4120
4121
4122 STATIC void
4123 S_init_predump_symbols(pTHX)
4124 {
4125     dVAR;
4126     GV *tmpgv;
4127     IO *io;
4128
4129     sv_setpvs(get_sv("\"", GV_ADD), " ");
4130     PL_ofsgv = (GV*)SvREFCNT_inc(gv_fetchpvs(",", GV_ADD|GV_NOTQUAL, SVt_PV));
4131
4132
4133     /* Historically, PVIOs were blessed into IO::Handle, unless
4134        FileHandle was loaded, in which case they were blessed into
4135        that. Action at a distance.
4136        However, if we simply bless into IO::Handle, we break code
4137        that assumes that PVIOs will have (among others) a seek
4138        method. IO::File inherits from IO::Handle and IO::Seekable,
4139        and provides the needed methods. But if we simply bless into
4140        it, then we break code that assumed that by loading
4141        IO::Handle, *it* would work.
4142        So a compromise is to set up the correct @IO::File::ISA,
4143        so that code that does C<use IO::Handle>; will still work.
4144     */
4145                    
4146     Perl_populate_isa(aTHX_ STR_WITH_LEN("IO::File::ISA"),
4147                       STR_WITH_LEN("IO::Handle::"),
4148                       STR_WITH_LEN("IO::Seekable::"),
4149                       STR_WITH_LEN("Exporter::"),
4150                       NULL);
4151
4152     PL_stdingv = gv_fetchpvs("STDIN", GV_ADD|GV_NOTQUAL, SVt_PVIO);
4153     GvMULTI_on(PL_stdingv);
4154     io = GvIOp(PL_stdingv);
4155     IoTYPE(io) = IoTYPE_RDONLY;
4156     IoIFP(io) = PerlIO_stdin();
4157     tmpgv = gv_fetchpvs("stdin", GV_ADD|GV_NOTQUAL, SVt_PV);
4158     GvMULTI_on(tmpgv);
4159     GvIOp(tmpgv) = MUTABLE_IO(SvREFCNT_inc_simple(io));
4160
4161     tmpgv = gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVIO);
4162     GvMULTI_on(tmpgv);
4163     io = GvIOp(tmpgv);
4164     IoTYPE(io) = IoTYPE_WRONLY;
4165     IoOFP(io) = IoIFP(io) = PerlIO_stdout();
4166     setdefout(tmpgv);
4167     tmpgv = gv_fetchpvs("stdout", GV_ADD|GV_NOTQUAL, SVt_PV);
4168     GvMULTI_on(tmpgv);
4169     GvIOp(tmpgv) = MUTABLE_IO(SvREFCNT_inc_simple(io));
4170
4171     PL_stderrgv = gv_fetchpvs("STDERR", GV_ADD|GV_NOTQUAL, SVt_PVIO);
4172     GvMULTI_on(PL_stderrgv);
4173     io = GvIOp(PL_stderrgv);
4174     IoTYPE(io) = IoTYPE_WRONLY;
4175     IoOFP(io) = IoIFP(io) = PerlIO_stderr();
4176     tmpgv = gv_fetchpvs("stderr", GV_ADD|GV_NOTQUAL, SVt_PV);
4177     GvMULTI_on(tmpgv);
4178     GvIOp(tmpgv) = MUTABLE_IO(SvREFCNT_inc_simple(io));
4179
4180     PL_statname = newSVpvs("");         /* last filename we did stat on */
4181 }
4182
4183 void
4184 Perl_init_argv_symbols(pTHX_ int argc, char **argv)
4185 {
4186     dVAR;
4187
4188     PERL_ARGS_ASSERT_INIT_ARGV_SYMBOLS;
4189
4190     argc--,argv++;      /* skip name of script */
4191     if (PL_doswitches) {
4192         for (; argc > 0 && **argv == '-'; argc--,argv++) {
4193             char *s;
4194             if (!argv[0][1])
4195                 break;
4196             if (argv[0][1] == '-' && !argv[0][2]) {
4197                 argc--,argv++;
4198                 break;
4199             }
4200             if ((s = strchr(argv[0], '='))) {
4201                 const char *const start_name = argv[0] + 1;
4202                 sv_setpv(GvSV(gv_fetchpvn_flags(start_name, s - start_name,
4203                                                 TRUE, SVt_PV)), s + 1);
4204             }
4205             else
4206                 sv_setiv(GvSV(gv_fetchpv(argv[0]+1, GV_ADD, SVt_PV)),1);
4207         }
4208     }
4209     if ((PL_argvgv = gv_fetchpvs("ARGV", GV_ADD|GV_NOTQUAL, SVt_PVAV))) {
4210         SvREFCNT_inc_simple_void_NN(PL_argvgv);
4211         GvMULTI_on(PL_argvgv);
4212         av_clear(GvAVn(PL_argvgv));
4213         for (; argc > 0; argc--,argv++) {
4214             SV * const sv = newSVpv(argv[0],0);
4215             av_push(GvAV(PL_argvgv),sv);
4216             if (!(PL_unicode & PERL_UNICODE_LOCALE_FLAG) || PL_utf8locale) {
4217                  if (PL_unicode & PERL_UNICODE_ARGV_FLAG)
4218                       SvUTF8_on(sv);
4219             }
4220             if (PL_unicode & PERL_UNICODE_WIDESYSCALLS_FLAG) /* Sarathy? */
4221                  (void)sv_utf8_decode(sv);
4222         }
4223     }
4224
4225     if (PL_inplace && (!PL_argvgv || AvFILL(GvAV(PL_argvgv)) == -1))
4226         Perl_ck_warner_d(aTHX_ packWARN(WARN_INPLACE),
4227                          "-i used with no filenames on the command line, "
4228                          "reading from STDIN");
4229 }
4230
4231 STATIC void
4232 S_init_postdump_symbols(pTHX_ int argc, char **argv, char **env)
4233 {
4234     dVAR;
4235     GV* tmpgv;
4236
4237     PERL_ARGS_ASSERT_INIT_POSTDUMP_SYMBOLS;
4238
4239     PL_toptarget = newSV_type(SVt_PVIV);
4240     sv_setpvs(PL_toptarget, "");
4241     PL_bodytarget = newSV_type(SVt_PVIV);
4242     sv_setpvs(PL_bodytarget, "");
4243     PL_formtarget = PL_bodytarget;
4244
4245     TAINT;
4246
4247     init_argv_symbols(argc,argv);
4248
4249     if ((tmpgv = gv_fetchpvs("0", GV_ADD|GV_NOTQUAL, SVt_PV))) {
4250         sv_setpv(GvSV(tmpgv),PL_origfilename);
4251     }
4252     if ((PL_envgv = gv_fetchpvs("ENV", GV_ADD|GV_NOTQUAL, SVt_PVHV))) {
4253         HV *hv;
4254         bool env_is_not_environ;
4255         SvREFCNT_inc_simple_void_NN(PL_envgv);
4256         GvMULTI_on(PL_envgv);
4257         hv = GvHVn(PL_envgv);
4258         hv_magic(hv, NULL, PERL_MAGIC_env);
4259 #ifndef PERL_MICRO
4260 #ifdef USE_ENVIRON_ARRAY
4261         /* Note that if the supplied env parameter is actually a copy
4262            of the global environ then it may now point to free'd memory
4263            if the environment has been modified since. To avoid this
4264            problem we treat env==NULL as meaning 'use the default'
4265         */
4266         if (!env)
4267             env = environ;
4268         env_is_not_environ = env != environ;
4269         if (env_is_not_environ
4270 #  ifdef USE_ITHREADS
4271             && PL_curinterp == aTHX
4272 #  endif
4273            )
4274         {
4275             environ[0] = NULL;
4276         }
4277         if (env) {
4278           char *s, *old_var;
4279           SV *sv;
4280           for (; *env; env++) {
4281             old_var = *env;
4282
4283             if (!(s = strchr(old_var,'=')) || s == old_var)
4284                 continue;
4285
4286 #if defined(MSDOS) && !defined(DJGPP)
4287             *s = '\0';
4288             (void)strupr(old_var);
4289             *s = '=';
4290 #endif
4291             sv = newSVpv(s+1, 0);
4292             (void)hv_store(hv, old_var, s - old_var, sv, 0);
4293             if (env_is_not_environ)
4294                 mg_set(sv);
4295           }
4296       }
4297 #endif /* USE_ENVIRON_ARRAY */
4298 #endif /* !PERL_MICRO */
4299     }
4300     TAINT_NOT;
4301
4302     /* touch @F array to prevent spurious warnings 20020415 MJD */
4303     if (PL_minus_a) {
4304       (void) get_av("main::F", GV_ADD | GV_ADDMULTI);
4305     }
4306 }
4307
4308 STATIC void
4309 S_init_perllib(pTHX)
4310 {
4311     dVAR;
4312 #ifndef VMS
4313     const char *perl5lib = NULL;
4314 #endif
4315     const char *s;
4316 #if defined(WIN32) && !defined(PERL_IS_MINIPERL)
4317     STRLEN len;
4318 #endif
4319
4320     if (!TAINTING_get) {
4321 #ifndef VMS
4322         perl5lib = PerlEnv_getenv("PERL5LIB");
4323 /*
4324  * It isn't possible to delete an environment variable with
4325  * PERL_USE_SAFE_PUTENV set unless unsetenv() is also available, so in that
4326  * case we treat PERL5LIB as undefined if it has a zero-length value.
4327  */
4328 #if defined(PERL_USE_SAFE_PUTENV) && ! defined(HAS_UNSETENV)
4329         if (perl5lib && *perl5lib != '\0')
4330 #else
4331         if (perl5lib)
4332 #endif
4333             incpush_use_sep(perl5lib, 0, INCPUSH_ADD_SUB_DIRS);
4334         else {
4335             s = PerlEnv_getenv("PERLLIB");
4336             if (s)
4337                 incpush_use_sep(s, 0, 0);
4338         }
4339 #else /* VMS */
4340         /* Treat PERL5?LIB as a possible search list logical name -- the
4341          * "natural" VMS idiom for a Unix path string.  We allow each
4342          * element to be a set of |-separated directories for compatibility.
4343          */
4344         char buf[256];
4345         int idx = 0;
4346         if (my_trnlnm("PERL5LIB",buf,0))
4347             do {
4348                 incpush_use_sep(buf, 0, INCPUSH_ADD_SUB_DIRS);
4349             } while (my_trnlnm("PERL5LIB",buf,++idx));
4350         else {
4351             while (my_trnlnm("PERLLIB",buf,idx++))
4352                 incpush_use_sep(buf, 0, 0);
4353         }
4354 #endif /* VMS */
4355     }
4356
4357 #ifndef PERL_IS_MINIPERL
4358     /* miniperl gets just -I..., the split of $ENV{PERL5LIB}, and "." in @INC
4359        (and not the architecture specific directories from $ENV{PERL5LIB}) */
4360
4361 /* Use the ~-expanded versions of APPLLIB (undocumented),
4362     SITEARCH, SITELIB, VENDORARCH, VENDORLIB, ARCHLIB and PRIVLIB
4363 */
4364 #ifdef APPLLIB_EXP
4365     S_incpush_use_sep(aTHX_ STR_WITH_LEN(APPLLIB_EXP),
4366                       INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE);
4367 #endif
4368
4369 #ifdef SITEARCH_EXP
4370     /* sitearch is always relative to sitelib on Windows for
4371      * DLL-based path intuition to work correctly */
4372 #  if !defined(WIN32)
4373         S_incpush_use_sep(aTHX_ STR_WITH_LEN(SITEARCH_EXP),
4374                           INCPUSH_CAN_RELOCATE);
4375 #  endif
4376 #endif
4377
4378 #ifdef SITELIB_EXP
4379 #  if defined(WIN32)
4380     /* this picks up sitearch as well */
4381         s = win32_get_sitelib(PERL_FS_VERSION, &len);
4382         if (s)
4383             incpush_use_sep(s, len, INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE);
4384 #  else
4385         S_incpush_use_sep(aTHX_ STR_WITH_LEN(SITELIB_EXP), INCPUSH_CAN_RELOCATE);
4386 #  endif
4387 #endif
4388
4389 #ifdef PERL_VENDORARCH_EXP
4390     /* vendorarch is always relative to vendorlib on Windows for
4391      * DLL-based path intuition to work correctly */
4392 #  if !defined(WIN32)
4393     S_incpush_use_sep(aTHX_ STR_WITH_LEN(PERL_VENDORARCH_EXP),
4394                       INCPUSH_CAN_RELOCATE);
4395 #  endif
4396 #endif
4397
4398 #ifdef PERL_VENDORLIB_EXP
4399 #  if defined(WIN32)
4400     /* this picks up vendorarch as well */
4401         s = win32_get_vendorlib(PERL_FS_VERSION, &len);
4402         if (s)
4403             incpush_use_sep(s, len, INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE);
4404 #  else
4405         S_incpush_use_sep(aTHX_ STR_WITH_LEN(PERL_VENDORLIB_EXP),
4406                           INCPUSH_CAN_RELOCATE);
4407 #  endif
4408 #endif
4409
4410 #ifdef ARCHLIB_EXP
4411     S_incpush_use_sep(aTHX_ STR_WITH_LEN(ARCHLIB_EXP), INCPUSH_CAN_RELOCATE);
4412 #endif
4413
4414 #ifndef PRIVLIB_EXP
4415 #  define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
4416 #endif
4417
4418 #if defined(WIN32)
4419     s = win32_get_privlib(PERL_FS_VERSION, &len);
4420     if (s)
4421         incpush_use_sep(s, len, INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE);
4422 #else
4423 #  ifdef NETWARE
4424     S_incpush_use_sep(aTHX_ PRIVLIB_EXP, 0, INCPUSH_CAN_RELOCATE);
4425 #  else
4426     S_incpush_use_sep(aTHX_ STR_WITH_LEN(PRIVLIB_EXP), INCPUSH_CAN_RELOCATE);
4427 #  endif
4428 #endif
4429
4430 #ifdef PERL_OTHERLIBDIRS
4431     S_incpush_use_sep(aTHX_ STR_WITH_LEN(PERL_OTHERLIBDIRS),
4432                       INCPUSH_ADD_VERSIONED_SUB_DIRS|INCPUSH_NOT_BASEDIR
4433                       |INCPUSH_CAN_RELOCATE);
4434 #endif
4435
4436     if (!TAINTING_get) {
4437 #ifndef VMS
4438 /*
4439  * It isn't possible to delete an environment variable with
4440  * PERL_USE_SAFE_PUTENV set unless unsetenv() is also available, so in that
4441  * case we treat PERL5LIB as undefined if it has a zero-length value.
4442  */
4443 #if defined(PERL_USE_SAFE_PUTENV) && ! defined(HAS_UNSETENV)
4444         if (perl5lib && *perl5lib != '\0')
4445 #else
4446         if (perl5lib)
4447 #endif
4448             incpush_use_sep(perl5lib, 0,
4449                             INCPUSH_ADD_OLD_VERS|INCPUSH_NOT_BASEDIR);
4450 #else /* VMS */
4451         /* Treat PERL5?LIB as a possible search list logical name -- the
4452          * "natural" VMS idiom for a Unix path string.  We allow each
4453          * element to be a set of |-separated directories for compatibility.
4454          */
4455         char buf[256];
4456         int idx = 0;
4457         if (my_trnlnm("PERL5LIB",buf,0))
4458             do {
4459                 incpush_use_sep(buf, 0,
4460                                 INCPUSH_ADD_OLD_VERS|INCPUSH_NOT_BASEDIR);
4461             } while (my_trnlnm("PERL5LIB",buf,++idx));
4462 #endif /* VMS */
4463     }
4464
4465 /* Use the ~-expanded versions of APPLLIB (undocumented),
4466     SITELIB and VENDORLIB for older versions
4467 */
4468 #ifdef APPLLIB_EXP
4469     S_incpush_use_sep(aTHX_ STR_WITH_LEN(APPLLIB_EXP), INCPUSH_ADD_OLD_VERS
4470                       |INCPUSH_NOT_BASEDIR|INCPUSH_CAN_RELOCATE);
4471 #endif
4472
4473 #if defined(SITELIB_STEM) && defined(PERL_INC_VERSION_LIST)
4474     /* Search for version-specific dirs below here */
4475     S_incpush_use_sep(aTHX_ STR_WITH_LEN(SITELIB_STEM),
4476                       INCPUSH_ADD_OLD_VERS|INCPUSH_CAN_RELOCATE);
4477 #endif
4478
4479
4480 #if defined(PERL_VENDORLIB_STEM) && defined(PERL_INC_VERSION_LIST)
4481     /* Search for version-specific dirs below here */
4482     S_incpush_use_sep(aTHX_ STR_WITH_LEN(PERL_VENDORLIB_STEM),
4483                       INCPUSH_ADD_OLD_VERS|INCPUSH_CAN_RELOCATE);
4484 #endif
4485
4486 #ifdef PERL_OTHERLIBDIRS
4487     S_incpush_use_sep(aTHX_ STR_WITH_LEN(PERL_OTHERLIBDIRS),
4488                       INCPUSH_ADD_OLD_VERS|INCPUSH_ADD_ARCHONLY_SUB_DIRS
4489                       |INCPUSH_CAN_RELOCATE);
4490 #endif
4491 #endif /* !PERL_IS_MINIPERL */
4492
4493     if (!TAINTING_get)
4494         S_incpush(aTHX_ STR_WITH_LEN("."), 0);
4495 }
4496
4497 #if defined(DOSISH) || defined(__SYMBIAN32__)
4498 #    define PERLLIB_SEP ';'
4499 #else
4500 #  if defined(VMS)
4501 #    define PERLLIB_SEP '|'
4502 #  else
4503 #    define PERLLIB_SEP ':'
4504 #  endif
4505 #endif
4506 #ifndef PERLLIB_MANGLE
4507 #  define PERLLIB_MANGLE(s,n) (s)
4508 #endif
4509
4510 #ifndef PERL_IS_MINIPERL
4511 /* Push a directory onto @INC if it exists.
4512    Generate a new SV if we do this, to save needing to copy the SV we push
4513    onto @INC  */
4514 STATIC SV *
4515 S_incpush_if_exists(pTHX_ AV *const av, SV *dir, SV *const stem)
4516 {
4517     dVAR;
4518     Stat_t tmpstatbuf;
4519
4520     PERL_ARGS_ASSERT_INCPUSH_IF_EXISTS;
4521
4522     if (PerlLIO_stat(SvPVX_const(dir), &tmpstatbuf) >= 0 &&
4523         S_ISDIR(tmpstatbuf.st_mode)) {
4524         av_push(av, dir);
4525         dir = newSVsv(stem);
4526     } else {
4527         /* Truncate dir back to stem.  */
4528         SvCUR_set(dir, SvCUR(stem));
4529     }
4530     return dir;
4531 }
4532 #endif
4533
4534 STATIC SV *
4535 S_mayberelocate(pTHX_ const char *const dir, STRLEN len, U32 flags)
4536 {
4537     const U8 canrelocate = (U8)flags & INCPUSH_CAN_RELOCATE;
4538     SV *libdir;
4539
4540     PERL_ARGS_ASSERT_MAYBERELOCATE;
4541     assert(len > 0);
4542
4543     /* I am not convinced that this is valid when PERLLIB_MANGLE is
4544        defined to so something (in os2/os2.c), but the code has been
4545        this way, ignoring any possible changed of length, since
4546        760ac839baf413929cd31cc32ffd6dba6b781a81 (5.003_02) so I'll leave
4547        it be.  */
4548     libdir = newSVpvn(PERLLIB_MANGLE(dir, len), len);
4549
4550 #ifdef VMS
4551     {
4552         char *unix;
4553
4554         if ((unix = tounixspec_ts(SvPV(libdir,len),NULL)) != NULL) {
4555             len = strlen(unix);
4556             while (len > 1 && unix[len-1] == '/') len--;  /* Cosmetic */
4557             sv_usepvn(libdir,unix,len);
4558         }
4559         else
4560             PerlIO_printf(Perl_error_log,
4561                           "Failed to unixify @INC element \"%s\"\n",
4562                           SvPV_nolen_const(libdir));
4563     }
4564 #endif
4565
4566         /* Do the if() outside the #ifdef to avoid warnings about an unused
4567            parameter.  */
4568         if (canrelocate) {
4569 #ifdef PERL_RELOCATABLE_INC
4570         /*
4571          * Relocatable include entries are marked with a leading .../
4572          *
4573          * The algorithm is
4574          * 0: Remove that leading ".../"
4575          * 1: Remove trailing executable name (anything after the last '/')
4576          *    from the perl path to give a perl prefix
4577          * Then
4578          * While the @INC element starts "../" and the prefix ends with a real
4579          * directory (ie not . or ..) chop that real directory off the prefix
4580          * and the leading "../" from the @INC element. ie a logical "../"
4581          * cleanup
4582          * Finally concatenate the prefix and the remainder of the @INC element
4583          * The intent is that /usr/local/bin/perl and .../../lib/perl5
4584          * generates /usr/local/lib/perl5
4585          */
4586             const char *libpath = SvPVX(libdir);
4587             STRLEN libpath_len = SvCUR(libdir);
4588             if (libpath_len >= 4 && memEQ (libpath, ".../", 4)) {
4589                 /* Game on!  */
4590                 SV * const caret_X = get_sv("\030", 0);
4591                 /* Going to use the SV just as a scratch buffer holding a C
4592                    string:  */
4593                 SV *prefix_sv;
4594                 char *prefix;
4595                 char *lastslash;
4596
4597                 /* $^X is *the* source of taint if tainting is on, hence
4598                    SvPOK() won't be true.  */
4599                 assert(caret_X);
4600                 assert(SvPOKp(caret_X));
4601                 prefix_sv = newSVpvn_flags(SvPVX(caret_X), SvCUR(caret_X),
4602                                            SvUTF8(caret_X));
4603                 /* Firstly take off the leading .../
4604                    If all else fail we'll do the paths relative to the current
4605                    directory.  */
4606                 sv_chop(libdir, libpath + 4);
4607                 /* Don't use SvPV as we're intentionally bypassing taining,
4608                    mortal copies that the mg_get of tainting creates, and
4609                    corruption that seems to come via the save stack.
4610                    I guess that the save stack isn't correctly set up yet.  */
4611                 libpath = SvPVX(libdir);
4612                 libpath_len = SvCUR(libdir);
4613
4614                 /* This would work more efficiently with memrchr, but as it's
4615                    only a GNU extension we'd need to probe for it and
4616                    implement our own. Not hard, but maybe not worth it?  */
4617
4618                 prefix = SvPVX(prefix_sv);
4619                 lastslash = strrchr(prefix, '/');
4620
4621                 /* First time in with the *lastslash = '\0' we just wipe off
4622                    the trailing /perl from (say) /usr/foo/bin/perl
4623                 */
4624                 if (lastslash) {
4625                     SV *tempsv;
4626                     while ((*lastslash = '\0'), /* Do that, come what may.  */
4627                            (libpath_len >= 3 && memEQ(libpath, "../", 3)
4628                             && (lastslash = strrchr(prefix, '/')))) {
4629                         if (lastslash[1] == '\0'
4630                             || (lastslash[1] == '.'
4631                                 && (lastslash[2] == '/' /* ends "/."  */
4632                                     || (lastslash[2] == '/'
4633                                         && lastslash[3] == '/' /* or "/.."  */
4634                                         )))) {
4635                             /* Prefix ends "/" or "/." or "/..", any of which
4636                                are fishy, so don't do any more logical cleanup.
4637                             */
4638                             break;
4639                         }
4640                         /* Remove leading "../" from path  */
4641                         libpath += 3;
4642                         libpath_len -= 3;
4643                         /* Next iteration round the loop removes the last
4644                            directory name from prefix by writing a '\0' in
4645                            the while clause.  */
4646                     }
4647                     /* prefix has been terminated with a '\0' to the correct
4648                        length. libpath points somewhere into the libdir SV.
4649                        We need to join the 2 with '/' and drop the result into
4650                        libdir.  */
4651                     tempsv = Perl_newSVpvf(aTHX_ "%s/%s", prefix, libpath);
4652                     SvREFCNT_dec(libdir);
4653                     /* And this is the new libdir.  */
4654                     libdir = tempsv;
4655                     if (TAINTING_get &&
4656                         (PerlProc_getuid() != PerlProc_geteuid() ||
4657                          PerlProc_getgid() != PerlProc_getegid())) {
4658                         /* Need to taint relocated paths if running set ID  */
4659                         SvTAINTED_on(libdir);
4660                     }
4661                 }
4662                 SvREFCNT_dec(prefix_sv);
4663             }
4664 #endif
4665         }
4666     return libdir;
4667 }
4668
4669 STATIC void
4670 S_incpush(pTHX_ const char *const dir, STRLEN len, U32 flags)
4671 {
4672     dVAR;
4673 #ifndef PERL_IS_MINIPERL
4674     const U8 using_sub_dirs
4675         = (U8)flags & (INCPUSH_ADD_VERSIONED_SUB_DIRS
4676                        |INCPUSH_ADD_ARCHONLY_SUB_DIRS|INCPUSH_ADD_OLD_VERS);
4677     const U8 add_versioned_sub_dirs
4678         = (U8)flags & INCPUSH_ADD_VERSIONED_SUB_DIRS;
4679     const U8 add_archonly_sub_dirs
4680         = (U8)flags & INCPUSH_ADD_ARCHONLY_SUB_DIRS;
4681 #ifdef PERL_INC_VERSION_LIST
4682     const U8 addoldvers  = (U8)flags & INCPUSH_ADD_OLD_VERS;
4683 #endif
4684 #endif
4685     const U8 unshift     = (U8)flags & INCPUSH_UNSHIFT;
4686     const U8 push_basedir = (flags & INCPUSH_NOT_BASEDIR) ? 0 : 1;
4687     AV *const inc = GvAVn(PL_incgv);
4688
4689     PERL_ARGS_ASSERT_INCPUSH;
4690     assert(len > 0);
4691
4692     /* Could remove this vestigial extra block, if we don't mind a lot of
4693        re-indenting diff noise.  */
4694     {
4695         SV *const libdir = mayberelocate(dir, len, flags);
4696         /* Change 20189146be79a0596543441fa369c6bf7f85103f, to fix RT#6665,
4697            arranged to unshift #! line -I onto the front of @INC. However,
4698            -I can add version and architecture specific libraries, and they
4699            need to go first. The old code assumed that it was always
4700            pushing. Hence to make it work, need to push the architecture
4701            (etc) libraries onto a temporary array, then "unshift" that onto
4702            the front of @INC.  */
4703 #ifndef PERL_IS_MINIPERL
4704         AV *const av = (using_sub_dirs) ? (unshift ? newAV() : inc) : NULL;
4705
4706         /*
4707          * BEFORE pushing libdir onto @INC we may first push version- and
4708          * archname-specific sub-directories.
4709          */
4710         if (using_sub_dirs) {
4711             SV *subdir = newSVsv(libdir);
4712 #ifdef PERL_INC_VERSION_LIST
4713             /* Configure terminates PERL_INC_VERSION_LIST with a NULL */
4714             const char * const incverlist[] = { PERL_INC_VERSION_LIST };
4715             const char * const *incver;
4716 #endif
4717
4718             if (add_versioned_sub_dirs) {
4719                 /* .../version/archname if -d .../version/archname */
4720                 sv_catpvs(subdir, "/" PERL_FS_VERSION "/" ARCHNAME);
4721                 subdir = S_incpush_if_exists(aTHX_ av, subdir, libdir);
4722
4723                 /* .../version if -d .../version */
4724                 sv_catpvs(subdir, "/" PERL_FS_VERSION);
4725                 subdir = S_incpush_if_exists(aTHX_ av, subdir, libdir);
4726             }
4727
4728 #ifdef PERL_INC_VERSION_LIST
4729             if (addoldvers) {
4730                 for (incver = incverlist; *incver; incver++) {
4731                     /* .../xxx if -d .../xxx */
4732                     Perl_sv_catpvf(aTHX_ subdir, "/%s", *incver);
4733                     subdir = S_incpush_if_exists(aTHX_ av, subdir, libdir);
4734                 }
4735             }
4736 #endif
4737
4738             if (add_archonly_sub_dirs) {
4739                 /* .../archname if -d .../archname */
4740                 sv_catpvs(subdir, "/" ARCHNAME);
4741                 subdir = S_incpush_if_exists(aTHX_ av, subdir, libdir);
4742
4743             }
4744
4745             assert (SvREFCNT(subdir) == 1);
4746             SvREFCNT_dec(subdir);
4747         }
4748 #endif /* !PERL_IS_MINIPERL */
4749         /* finally add this lib directory at the end of @INC */
4750         if (unshift) {
4751 #ifdef PERL_IS_MINIPERL
4752             const Size_t extra = 0;
4753 #else
4754             Size_t extra = av_tindex(av) + 1;
4755 #endif
4756             av_unshift(inc, extra + push_basedir);
4757             if (push_basedir)
4758                 av_store(inc, extra, libdir);
4759 #ifndef PERL_IS_MINIPERL
4760             while (extra--) {
4761                 /* av owns a reference, av_store() expects to be donated a
4762                    reference, and av expects to be sane when it's cleared.
4763                    If I wanted to be naughty and wrong, I could peek inside the
4764                    implementation of av_clear(), realise that it uses
4765                    SvREFCNT_dec() too, so av's array could be a run of NULLs,
4766                    and so directly steal from it (with a memcpy() to inc, and
4767                    then memset() to NULL them out. But people copy code from the
4768                    core expecting it to be best practise, so let's use the API.
4769                    Although studious readers will note that I'm not checking any
4770                    return codes.  */
4771                 av_store(inc, extra, SvREFCNT_inc(*av_fetch(av, extra, FALSE)));
4772             }
4773             SvREFCNT_dec(av);
4774 #endif
4775         }
4776         else if (push_basedir) {
4777             av_push(inc, libdir);
4778         }
4779
4780         if (!push_basedir) {
4781             assert (SvREFCNT(libdir) == 1);
4782             SvREFCNT_dec(libdir);
4783         }
4784     }
4785 }
4786
4787 STATIC void
4788 S_incpush_use_sep(pTHX_ const char *p, STRLEN len, U32 flags)
4789 {
4790     const char *s;
4791     const char *end;
4792     /* This logic has been broken out from S_incpush(). It may be possible to
4793        simplify it.  */
4794
4795     PERL_ARGS_ASSERT_INCPUSH_USE_SEP;
4796
4797     /* perl compiled with -DPERL_RELOCATABLE_INCPUSH will ignore the len
4798      * argument to incpush_use_sep.  This allows creation of relocatable
4799      * Perl distributions that patch the binary at install time.  Those
4800      * distributions will have to provide their own relocation tools; this
4801      * is not a feature otherwise supported by core Perl.
4802      */
4803 #ifndef PERL_RELOCATABLE_INCPUSH
4804     if (!len)
4805 #endif
4806         len = strlen(p);
4807
4808     end = p + len;
4809
4810     /* Break at all separators */
4811     while ((s = (const char*)memchr(p, PERLLIB_SEP, end - p))) {
4812         if (s == p) {
4813             /* skip any consecutive separators */
4814
4815             /* Uncomment the next line for PATH semantics */
4816             /* But you'll need to write tests */
4817             /* av_push(GvAVn(PL_incgv), newSVpvs(".")); */
4818         } else {
4819             incpush(p, (STRLEN)(s - p), flags);
4820         }
4821         p = s + 1;
4822     }
4823     if (p != end)
4824         incpush(p, (STRLEN)(end - p), flags);
4825
4826 }
4827
4828 void
4829 Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
4830 {
4831     dVAR;
4832     SV *atsv;
4833     volatile const line_t oldline = PL_curcop ? CopLINE(PL_curcop) : 0;
4834     CV *cv;
4835     STRLEN len;
4836     int ret;
4837     dJMPENV;
4838
4839     PERL_ARGS_ASSERT_CALL_LIST;
4840
4841     while (av_tindex(paramList) >= 0) {
4842         cv = MUTABLE_CV(av_shift(paramList));
4843         if (PL_savebegin) {
4844             if (paramList == PL_beginav) {
4845                 /* save PL_beginav for compiler */
4846                 Perl_av_create_and_push(aTHX_ &PL_begi