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