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