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