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