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