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