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