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