Pod formatting fix
[perl.git] / perl.c
1 /*    perl.c
2  *
3  *    Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001
4  *    2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 by Larry Wall and others
5  *
6  *    You may distribute under the terms of either the GNU General Public
7  *    License or the Artistic License, as specified in the README file.
8  *
9  */
10
11 /*
12  *      A ship then new they built for him
13  *      of mithril and of elven-glass
14  *              --from Bilbo's song of Eďż˝rendil
15  *
16  *     [p.236 of _The Lord of the Rings_, II/i: "Many Meetings"]
17  */
18
19 /* This file contains the top-level functions that are used to create, use
20  * and destroy a perl interpreter, plus the functions used by XS code to
21  * call back into perl. Note that it does not contain the actual main()
22  * function of the interpreter; that can be found in perlmain.c
23  */
24
25 #include "EXTERN.h"
26 #define PERL_IN_PERL_C
27 #include "perl.h"
28 #include "patchlevel.h"                 /* for local_patches */
29 #include "XSUB.h"
30
31 #ifdef NETWARE
32 #include "nwutil.h"     
33 #endif
34
35 /* XXX If this causes problems, set i_unistd=undef in the hint file.  */
36 #ifdef I_UNISTD
37 #include <unistd.h>
38 #endif
39
40 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
41 #  ifdef I_SYS_WAIT
42 #   include <sys/wait.h>
43 #  endif
44 #  ifdef I_SYSUIO
45 #    include <sys/uio.h>
46 #  endif
47
48 union control_un {
49   struct cmsghdr cm;
50   char control[CMSG_SPACE(sizeof(int))];
51 };
52
53 #endif
54
55 #ifdef __BEOS__
56 #  define HZ 1000000
57 #endif
58
59 #ifndef HZ
60 #  ifdef CLK_TCK
61 #    define HZ CLK_TCK
62 #  else
63 #    define HZ 60
64 #  endif
65 #endif
66
67 #if !defined(STANDARD_C) && !defined(HAS_GETENV_PROTOTYPE) && !defined(PERL_MICRO)
68 char *getenv (char *); /* Usually in <stdlib.h> */
69 #endif
70
71 static I32 read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen);
72
73 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
74 /* Drop everything. Heck, don't even try to call it */
75 #  define validate_suid(validarg, scriptname, fdscript, suidscript, linestr_sv, rsfp) NOOP
76 #else
77 /* Drop almost everything */
78 #  define validate_suid(validarg, scriptname, fdscript, suidscript, linestr_sv, rsfp) S_validate_suid(aTHX_ rsfp)
79 #endif
80
81 #define CALL_BODY_EVAL(myop) \
82     if (PL_op == (myop)) \
83         PL_op = PL_ppaddr[OP_ENTEREVAL](aTHX); \
84     if (PL_op) \
85         CALLRUNOPS(aTHX);
86
87 #define CALL_BODY_SUB(myop) \
88     if (PL_op == (myop)) \
89         PL_op = PL_ppaddr[OP_ENTERSUB](aTHX); \
90     if (PL_op) \
91         CALLRUNOPS(aTHX);
92
93 #define CALL_LIST_BODY(cv) \
94     PUSHMARK(PL_stack_sp); \
95     call_sv(MUTABLE_SV((cv)), G_EVAL|G_DISCARD);
96
97 static void
98 S_init_tls_and_interp(PerlInterpreter *my_perl)
99 {
100     dVAR;
101     if (!PL_curinterp) {                        
102         PERL_SET_INTERP(my_perl);
103 #if defined(USE_ITHREADS)
104         INIT_THREADS;
105         ALLOC_THREAD_KEY;
106         PERL_SET_THX(my_perl);
107         OP_REFCNT_INIT;
108         HINTS_REFCNT_INIT;
109         MUTEX_INIT(&PL_dollarzero_mutex);
110 #  endif
111 #ifdef PERL_IMPLICIT_CONTEXT
112         MUTEX_INIT(&PL_my_ctx_mutex);
113 #  endif
114     }
115 #if defined(USE_ITHREADS)
116     else
117 #else
118     /* This always happens for non-ithreads  */
119 #endif
120     {
121         PERL_SET_THX(my_perl);
122     }
123 }
124
125
126 /* these implement the PERL_SYS_INIT, PERL_SYS_INIT3, PERL_SYS_TERM macros */
127
128 void
129 Perl_sys_init(int* argc, char*** argv)
130 {
131     dVAR;
132
133     PERL_ARGS_ASSERT_SYS_INIT;
134
135     PERL_UNUSED_ARG(argc); /* may not be used depending on _BODY macro */
136     PERL_UNUSED_ARG(argv);
137     PERL_SYS_INIT_BODY(argc, argv);
138 }
139
140 void
141 Perl_sys_init3(int* argc, char*** argv, char*** env)
142 {
143     dVAR;
144
145     PERL_ARGS_ASSERT_SYS_INIT3;
146
147     PERL_UNUSED_ARG(argc); /* may not be used depending on _BODY macro */
148     PERL_UNUSED_ARG(argv);
149     PERL_UNUSED_ARG(env);
150     PERL_SYS_INIT3_BODY(argc, argv, env);
151 }
152
153 void
154 Perl_sys_term()
155 {
156     dVAR;
157     if (!PL_veto_cleanup) {
158         PERL_SYS_TERM_BODY();
159     }
160 }
161
162
163 #ifdef PERL_IMPLICIT_SYS
164 PerlInterpreter *
165 perl_alloc_using(struct IPerlMem* ipM, struct IPerlMem* ipMS,
166                  struct IPerlMem* ipMP, struct IPerlEnv* ipE,
167                  struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
168                  struct IPerlDir* ipD, struct IPerlSock* ipS,
169                  struct IPerlProc* ipP)
170 {
171     PerlInterpreter *my_perl;
172
173     PERL_ARGS_ASSERT_PERL_ALLOC_USING;
174
175     /* Newx() needs interpreter, so call malloc() instead */
176     my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
177     S_init_tls_and_interp(my_perl);
178     Zero(my_perl, 1, PerlInterpreter);
179     PL_Mem = ipM;
180     PL_MemShared = ipMS;
181     PL_MemParse = ipMP;
182     PL_Env = ipE;
183     PL_StdIO = ipStd;
184     PL_LIO = ipLIO;
185     PL_Dir = ipD;
186     PL_Sock = ipS;
187     PL_Proc = ipP;
188     INIT_TRACK_MEMPOOL(PL_memory_debug_header, my_perl);
189
190     return my_perl;
191 }
192 #else
193
194 /*
195 =head1 Embedding Functions
196
197 =for apidoc perl_alloc
198
199 Allocates a new Perl interpreter.  See L<perlembed>.
200
201 =cut
202 */
203
204 PerlInterpreter *
205 perl_alloc(void)
206 {
207     PerlInterpreter *my_perl;
208
209     /* Newx() needs interpreter, so call malloc() instead */
210     my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
211
212     S_init_tls_and_interp(my_perl);
213 #ifndef PERL_TRACK_MEMPOOL
214     return (PerlInterpreter *) ZeroD(my_perl, 1, PerlInterpreter);
215 #else
216     Zero(my_perl, 1, PerlInterpreter);
217     INIT_TRACK_MEMPOOL(PL_memory_debug_header, my_perl);
218     return my_perl;
219 #endif
220 }
221 #endif /* PERL_IMPLICIT_SYS */
222
223 /*
224 =for apidoc perl_construct
225
226 Initializes a new Perl interpreter.  See L<perlembed>.
227
228 =cut
229 */
230
231 void
232 perl_construct(pTHXx)
233 {
234     dVAR;
235
236     PERL_ARGS_ASSERT_PERL_CONSTRUCT;
237
238 #ifdef MULTIPLICITY
239     init_interp();
240     PL_perl_destruct_level = 1;
241 #else
242     PERL_UNUSED_ARG(my_perl);
243    if (PL_perl_destruct_level > 0)
244        init_interp();
245 #endif
246     PL_curcop = &PL_compiling;  /* needed by ckWARN, right away */
247
248     /* set read-only and try to insure than we wont see REFCNT==0
249        very often */
250
251     SvREADONLY_on(&PL_sv_undef);
252     SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
253
254     sv_setpv(&PL_sv_no,PL_No);
255     /* value lookup in void context - happens to have the side effect
256        of caching the numeric forms. However, as &PL_sv_no doesn't contain
257        a string that is a valid numer, we have to turn the public flags by
258        hand:  */
259     SvNV(&PL_sv_no);
260     SvIV(&PL_sv_no);
261     SvIOK_on(&PL_sv_no);
262     SvNOK_on(&PL_sv_no);
263     SvREADONLY_on(&PL_sv_no);
264     SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
265
266     sv_setpv(&PL_sv_yes,PL_Yes);
267     SvNV(&PL_sv_yes);
268     SvIV(&PL_sv_yes);
269     SvREADONLY_on(&PL_sv_yes);
270     SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
271
272     SvREADONLY_on(&PL_sv_placeholder);
273     SvREFCNT(&PL_sv_placeholder) = (~(U32)0)/2;
274
275     PL_sighandlerp = (Sighandler_t) Perl_sighandler;
276 #ifdef PERL_USES_PL_PIDSTATUS
277     PL_pidstatus = newHV();
278 #endif
279
280     PL_rs = newSVpvs("\n");
281
282     init_stacks();
283
284     init_ids();
285
286     JMPENV_BOOTSTRAP;
287     STATUS_ALL_SUCCESS;
288
289     init_i18nl10n(1);
290     SET_NUMERIC_STANDARD();
291
292 #if defined(LOCAL_PATCH_COUNT)
293     PL_localpatches = local_patches;    /* For possible -v */
294 #endif
295
296 #ifdef HAVE_INTERP_INTERN
297     sys_intern_init();
298 #endif
299
300     PerlIO_init(aTHX);                  /* Hook to IO system */
301
302     PL_fdpid = newAV();                 /* for remembering popen pids by fd */
303     PL_modglobal = newHV();             /* pointers to per-interpreter module globals */
304     PL_errors = newSVpvs("");
305     sv_setpvs(PERL_DEBUG_PAD(0), "");   /* For regex debugging. */
306     sv_setpvs(PERL_DEBUG_PAD(1), "");   /* ext/re needs these */
307     sv_setpvs(PERL_DEBUG_PAD(2), "");   /* even without DEBUGGING. */
308 #ifdef USE_ITHREADS
309     /* First entry is a list of empty elements. It needs to be initialised
310        else all hell breaks loose in S_find_uninit_var().  */
311     Perl_av_create_and_push(aTHX_ &PL_regex_padav, newSVpvs(""));
312     PL_regex_pad = AvARRAY(PL_regex_padav);
313 #endif
314 #ifdef USE_REENTRANT_API
315     Perl_reentrant_init(aTHX);
316 #endif
317
318     /* Note that strtab is a rather special HV.  Assumptions are made
319        about not iterating on it, and not adding tie magic to it.
320        It is properly deallocated in perl_destruct() */
321     PL_strtab = newHV();
322
323     HvSHAREKEYS_off(PL_strtab);                 /* mandatory */
324     hv_ksplit(PL_strtab, 512);
325
326 #if defined(__DYNAMIC__) && (defined(NeXT) || defined(__NeXT__))
327     _dyld_lookup_and_bind
328         ("__environ", (unsigned long *) &environ_pointer, NULL);
329 #endif /* environ */
330
331 #ifndef PERL_MICRO
332 #   ifdef  USE_ENVIRON_ARRAY
333     PL_origenviron = environ;
334 #   endif
335 #endif
336
337     /* Use sysconf(_SC_CLK_TCK) if available, if not
338      * available or if the sysconf() fails, use the HZ.
339      * BeOS has those, but returns the wrong value.
340      * The HZ if not originally defined has been by now
341      * been defined as CLK_TCK, if available. */
342 #if defined(HAS_SYSCONF) && defined(_SC_CLK_TCK) && !defined(__BEOS__)
343     PL_clocktick = sysconf(_SC_CLK_TCK);
344     if (PL_clocktick <= 0)
345 #endif
346          PL_clocktick = HZ;
347
348     PL_stashcache = newHV();
349
350     PL_patchlevel = newSVpvs("v" PERL_VERSION_STRING);
351
352 #ifdef HAS_MMAP
353     if (!PL_mmap_page_size) {
354 #if defined(HAS_SYSCONF) && (defined(_SC_PAGESIZE) || defined(_SC_MMAP_PAGE_SIZE))
355       {
356         SETERRNO(0, SS_NORMAL);
357 #   ifdef _SC_PAGESIZE
358         PL_mmap_page_size = sysconf(_SC_PAGESIZE);
359 #   else
360         PL_mmap_page_size = sysconf(_SC_MMAP_PAGE_SIZE);
361 #   endif
362         if ((long) PL_mmap_page_size < 0) {
363           if (errno) {
364             SV * const error = ERRSV;
365             SvUPGRADE(error, SVt_PV);
366             Perl_croak(aTHX_ "panic: sysconf: %s", SvPV_nolen_const(error));
367           }
368           else
369             Perl_croak(aTHX_ "panic: sysconf: pagesize unknown");
370         }
371       }
372 #else
373 #   ifdef HAS_GETPAGESIZE
374       PL_mmap_page_size = getpagesize();
375 #   else
376 #       if defined(I_SYS_PARAM) && defined(PAGESIZE)
377       PL_mmap_page_size = PAGESIZE;       /* compiletime, bad */
378 #       endif
379 #   endif
380 #endif
381       if (PL_mmap_page_size <= 0)
382         Perl_croak(aTHX_ "panic: bad pagesize %" IVdf,
383                    (IV) PL_mmap_page_size);
384     }
385 #endif /* HAS_MMAP */
386
387 #if defined(HAS_TIMES) && defined(PERL_NEED_TIMESBASE)
388     PL_timesbase.tms_utime  = 0;
389     PL_timesbase.tms_stime  = 0;
390     PL_timesbase.tms_cutime = 0;
391     PL_timesbase.tms_cstime = 0;
392 #endif
393
394     PL_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                 Perl_av_create_and_push(aTHX_ &PL_preambleav, newSVpvs("use Config;"));
1848                 if (*++s != ':')  {
1849                     opts_prog = newSVpvs("Config::_V()");
1850                 }
1851                 else {
1852                     ++s;
1853                     opts_prog = Perl_newSVpvf(aTHX_
1854                                               "Config::config_vars(qw%c%s%c)",
1855                                               0, s, 0);
1856                     s += strlen(s);
1857                 }
1858                 av_push(PL_preambleav, opts_prog);
1859                 /* don't look for script or read stdin */
1860                 scriptname = BIT_BUCKET;
1861                 goto reswitch;
1862             }
1863         case 'x':
1864             PL_doextract = TRUE;
1865             s++;
1866             if (*s)
1867                 cddir = s;
1868             break;
1869         case 0:
1870             break;
1871         case '-':
1872             if (!*++s || isSPACE(*s)) {
1873                 argc--,argv++;
1874                 goto switch_end;
1875             }
1876             /* catch use of gnu style long options */
1877             if (strEQ(s, "version")) {
1878                 s = (char *)"v";
1879                 goto reswitch;
1880             }
1881             if (strEQ(s, "help")) {
1882                 s = (char *)"h";
1883                 goto reswitch;
1884             }
1885             s--;
1886             /* FALL THROUGH */
1887         default:
1888             Perl_croak(aTHX_ "Unrecognized switch: -%s  (-h will show valid options)",s);
1889         }
1890     }
1891     }
1892
1893   switch_end:
1894
1895     {
1896         char *s;
1897
1898     if (
1899 #ifndef SECURE_INTERNAL_GETENV
1900         !PL_tainting &&
1901 #endif
1902         (s = PerlEnv_getenv("PERL5OPT")))
1903     {
1904         while (isSPACE(*s))
1905             s++;
1906         if (*s == '-' && *(s+1) == 'T') {
1907             CHECK_MALLOC_TOO_LATE_FOR('T');
1908             PL_tainting = TRUE;
1909             PL_taint_warn = FALSE;
1910         }
1911         else {
1912             char *popt_copy = NULL;
1913             while (s && *s) {
1914                 const char *d;
1915                 while (isSPACE(*s))
1916                     s++;
1917                 if (*s == '-') {
1918                     s++;
1919                     if (isSPACE(*s))
1920                         continue;
1921                 }
1922                 d = s;
1923                 if (!*s)
1924                     break;
1925                 if (!strchr("CDIMUdmtwW", *s))
1926                     Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s);
1927                 while (++s && *s) {
1928                     if (isSPACE(*s)) {
1929                         if (!popt_copy) {
1930                             popt_copy = SvPVX(sv_2mortal(newSVpv(d,0)));
1931                             s = popt_copy + (s - d);
1932                             d = popt_copy;
1933                         }
1934                         *s++ = '\0';
1935                         break;
1936                     }
1937                 }
1938                 if (*d == 't') {
1939                     if( !PL_tainting ) {
1940                         PL_taint_warn = TRUE;
1941                         PL_tainting = TRUE;
1942                     }
1943                 } else {
1944                     moreswitches(d);
1945                 }
1946             }
1947         }
1948     }
1949     }
1950
1951 #if defined(USE_SITECUSTOMIZE) && !defined(PERL_IS_MINIPERL)
1952     if (!minus_f) {
1953         /* SITELIB_EXP is a function call on Win32.
1954            The games with local $! are to avoid setting errno if there is no
1955            sitecustomize script.  */
1956         const char *const sitelib = SITELIB_EXP;
1957         (void)Perl_av_create_and_unshift_one(aTHX_ &PL_preambleav,
1958                                              Perl_newSVpvf(aTHX_
1959                                                            "BEGIN { do {local $!; -f '%s/sitecustomize.pl'} && do '%s/sitecustomize.pl' }", sitelib, sitelib));
1960     }
1961 #endif
1962
1963     if (!scriptname)
1964         scriptname = argv[0];
1965     if (PL_e_script) {
1966         argc++,argv--;
1967         scriptname = BIT_BUCKET;        /* don't look for script or read stdin */
1968     }
1969     else if (scriptname == NULL) {
1970 #ifdef MSDOS
1971         if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) )
1972             moreswitches("h");
1973 #endif
1974         scriptname = "-";
1975     }
1976
1977     /* Set $^X early so that it can be used for relocatable paths in @INC  */
1978     assert (!PL_tainted);
1979     TAINT;
1980     S_set_caret_X(aTHX);
1981     TAINT_NOT;
1982     init_perllib();
1983
1984     {
1985         bool suidscript = FALSE;
1986
1987         open_script(scriptname, dosearch, &suidscript, &rsfp);
1988
1989         validate_suid(validarg, scriptname, fdscript, suidscript,
1990                       linestr_sv, rsfp);
1991
1992 #ifndef PERL_MICRO
1993 #  if defined(SIGCHLD) || defined(SIGCLD)
1994         {
1995 #  ifndef SIGCHLD
1996 #    define SIGCHLD SIGCLD
1997 #  endif
1998             Sighandler_t sigstate = rsignal_state(SIGCHLD);
1999             if (sigstate == (Sighandler_t) SIG_IGN) {
2000                 if (ckWARN(WARN_SIGNAL))
2001                     Perl_warner(aTHX_ packWARN(WARN_SIGNAL),
2002                                 "Can't ignore signal CHLD, forcing to default");
2003                 (void)rsignal(SIGCHLD, (Sighandler_t)SIG_DFL);
2004             }
2005         }
2006 #  endif
2007 #endif
2008
2009         if (PL_doextract) {
2010
2011             /* This will croak if suidscript is true, as -x cannot be used with
2012                setuid scripts.  */
2013             forbid_setid('x', suidscript);
2014             /* Hence you can't get here if suidscript is true */
2015
2016             find_beginning(linestr_sv, rsfp);
2017             if (cddir && PerlDir_chdir( (char *)cddir ) < 0)
2018                 Perl_croak(aTHX_ "Can't chdir to %s",cddir);
2019         }
2020     }
2021
2022     PL_main_cv = PL_compcv = MUTABLE_CV(newSV_type(SVt_PVCV));
2023     CvUNIQUE_on(PL_compcv);
2024
2025     CvPADLIST(PL_compcv) = pad_new(0);
2026
2027     PL_isarev = newHV();
2028
2029     boot_core_PerlIO();
2030     boot_core_UNIVERSAL();
2031     boot_core_mro();
2032     newXS("Internals::V", S_Internals_V, __FILE__);
2033
2034     if (xsinit)
2035         (*xsinit)(aTHX);        /* in case linked C routines want magical variables */
2036 #ifndef PERL_MICRO
2037 #if defined(VMS) || defined(WIN32) || defined(DJGPP) || defined(__CYGWIN__) || defined(EPOC) || defined(SYMBIAN)
2038     init_os_extras();
2039 #endif
2040 #endif
2041
2042 #ifdef USE_SOCKS
2043 #   ifdef HAS_SOCKS5_INIT
2044     socks5_init(argv[0]);
2045 #   else
2046     SOCKSinit(argv[0]);
2047 #   endif
2048 #endif
2049
2050     init_predump_symbols();
2051     /* init_postdump_symbols not currently designed to be called */
2052     /* more than once (ENV isn't cleared first, for example)     */
2053     /* But running with -u leaves %ENV & @ARGV undefined!    XXX */
2054     if (!PL_do_undump)
2055         init_postdump_symbols(argc,argv,env);
2056
2057     /* PL_unicode is turned on by -C, or by $ENV{PERL_UNICODE},
2058      * or explicitly in some platforms.
2059      * locale.c:Perl_init_i18nl10n() if the environment
2060      * look like the user wants to use UTF-8. */
2061 #if defined(__SYMBIAN32__)
2062     PL_unicode = PERL_UNICODE_STD_FLAG; /* See PERL_SYMBIAN_CONSOLE_UTF8. */
2063 #endif
2064 #  ifndef PERL_IS_MINIPERL
2065     if (PL_unicode) {
2066          /* Requires init_predump_symbols(). */
2067          if (!(PL_unicode & PERL_UNICODE_LOCALE_FLAG) || PL_utf8locale) {
2068               IO* io;
2069               PerlIO* fp;
2070               SV* sv;
2071
2072               /* Turn on UTF-8-ness on STDIN, STDOUT, STDERR
2073                * and the default open disciplines. */
2074               if ((PL_unicode & PERL_UNICODE_STDIN_FLAG) &&
2075                   PL_stdingv  && (io = GvIO(PL_stdingv)) &&
2076                   (fp = IoIFP(io)))
2077                    PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
2078               if ((PL_unicode & PERL_UNICODE_STDOUT_FLAG) &&
2079                   PL_defoutgv && (io = GvIO(PL_defoutgv)) &&
2080                   (fp = IoOFP(io)))
2081                    PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
2082               if ((PL_unicode & PERL_UNICODE_STDERR_FLAG) &&
2083                   PL_stderrgv && (io = GvIO(PL_stderrgv)) &&
2084                   (fp = IoOFP(io)))
2085                    PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
2086               if ((PL_unicode & PERL_UNICODE_INOUT_FLAG) &&
2087                   (sv = GvSV(gv_fetchpvs("\017PEN", GV_ADD|GV_NOTQUAL,
2088                                          SVt_PV)))) {
2089                    U32 in  = PL_unicode & PERL_UNICODE_IN_FLAG;
2090                    U32 out = PL_unicode & PERL_UNICODE_OUT_FLAG;
2091                    if (in) {
2092                         if (out)
2093                              sv_setpvs(sv, ":utf8\0:utf8");
2094                         else
2095                              sv_setpvs(sv, ":utf8\0");
2096                    }
2097                    else if (out)
2098                         sv_setpvs(sv, "\0:utf8");
2099                    SvSETMAGIC(sv);
2100               }
2101          }
2102     }
2103 #endif
2104
2105     {
2106         const char *s;
2107     if ((s = PerlEnv_getenv("PERL_SIGNALS"))) {
2108          if (strEQ(s, "unsafe"))
2109               PL_signals |=  PERL_SIGNALS_UNSAFE_FLAG;
2110          else if (strEQ(s, "safe"))
2111               PL_signals &= ~PERL_SIGNALS_UNSAFE_FLAG;
2112          else
2113               Perl_croak(aTHX_ "PERL_SIGNALS illegal: \"%s\"", s);
2114     }
2115     }
2116
2117 #ifdef PERL_MAD
2118     {
2119         const char *s;
2120     if ((s = PerlEnv_getenv("PERL_XMLDUMP"))) {
2121         PL_madskills = 1;
2122         PL_minus_c = 1;
2123         if (!s || !s[0])
2124             PL_xmlfp = PerlIO_stdout();
2125         else {
2126             PL_xmlfp = PerlIO_open(s, "w");
2127             if (!PL_xmlfp)
2128                 Perl_croak(aTHX_ "Can't open %s", s);
2129         }
2130         my_setenv("PERL_XMLDUMP", NULL);        /* hide from subprocs */
2131     }
2132     }
2133
2134     {
2135         const char *s;
2136     if ((s = PerlEnv_getenv("PERL_MADSKILLS"))) {
2137         PL_madskills = atoi(s);
2138         my_setenv("PERL_MADSKILLS", NULL);      /* hide from subprocs */
2139     }
2140     }
2141 #endif
2142
2143     lex_start(linestr_sv, rsfp, TRUE);
2144     PL_subname = newSVpvs("main");
2145
2146     if (add_read_e_script)
2147         filter_add(read_e_script, NULL);
2148
2149     /* now parse the script */
2150
2151     SETERRNO(0,SS_NORMAL);
2152     if (yyparse() || PL_parser->error_count) {
2153         if (PL_minus_c)
2154             Perl_croak(aTHX_ "%s had compilation errors.\n", PL_origfilename);
2155         else {
2156             Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
2157                        PL_origfilename);
2158         }
2159     }
2160     CopLINE_set(PL_curcop, 0);
2161     PL_curstash = PL_defstash;
2162     if (PL_e_script) {
2163         SvREFCNT_dec(PL_e_script);
2164         PL_e_script = NULL;
2165     }
2166
2167     if (PL_do_undump)
2168         my_unexec();
2169
2170     if (isWARN_ONCE) {
2171         SAVECOPFILE(PL_curcop);
2172         SAVECOPLINE(PL_curcop);
2173         gv_check(PL_defstash);
2174     }
2175
2176     LEAVE;
2177     FREETMPS;
2178
2179 #ifdef MYMALLOC
2180     {
2181         const char *s;
2182     if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
2183         dump_mstats("after compilation:");
2184     }
2185 #endif
2186
2187     ENTER;
2188     PL_restartop = 0;
2189     return NULL;
2190 }
2191
2192 /*
2193 =for apidoc perl_run
2194
2195 Tells a Perl interpreter to run.  See L<perlembed>.
2196
2197 =cut
2198 */
2199
2200 int
2201 perl_run(pTHXx)
2202 {
2203     dVAR;
2204     I32 oldscope;
2205     int ret = 0;
2206     dJMPENV;
2207
2208     PERL_ARGS_ASSERT_PERL_RUN;
2209 #ifndef MULTIPLICITY
2210     PERL_UNUSED_ARG(my_perl);
2211 #endif
2212
2213     oldscope = PL_scopestack_ix;
2214 #ifdef VMS
2215     VMSISH_HUSHED = 0;
2216 #endif
2217
2218     JMPENV_PUSH(ret);
2219     switch (ret) {
2220     case 1:
2221         cxstack_ix = -1;                /* start context stack again */
2222         goto redo_body;
2223     case 0:                             /* normal completion */
2224  redo_body:
2225         run_body(oldscope);
2226         /* FALL THROUGH */
2227     case 2:                             /* my_exit() */
2228         while (PL_scopestack_ix > oldscope)
2229             LEAVE;
2230         FREETMPS;
2231         PL_curstash = PL_defstash;
2232         if (!(PL_exit_flags & PERL_EXIT_DESTRUCT_END) &&
2233             PL_endav && !PL_minus_c)
2234             call_list(oldscope, PL_endav);
2235 #ifdef MYMALLOC
2236         if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
2237             dump_mstats("after execution:  ");
2238 #endif
2239         ret = STATUS_EXIT;
2240         break;
2241     case 3:
2242         if (PL_restartop) {
2243             POPSTACK_TO(PL_mainstack);
2244             goto redo_body;
2245         }
2246         PerlIO_printf(Perl_error_log, "panic: restartop\n");
2247         FREETMPS;
2248         ret = 1;
2249         break;
2250     }
2251
2252     JMPENV_POP;
2253     return ret;
2254 }
2255
2256 STATIC void
2257 S_run_body(pTHX_ I32 oldscope)
2258 {
2259     dVAR;
2260     DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
2261                     PL_sawampersand ? "Enabling" : "Omitting"));
2262
2263     if (!PL_restartop) {
2264 #ifdef PERL_MAD
2265         if (PL_xmlfp) {
2266             xmldump_all();
2267             exit(0);    /* less likely to core dump than my_exit(0) */
2268         }
2269 #endif
2270 #ifdef DEBUGGING
2271         if (DEBUG_x_TEST || DEBUG_B_TEST)
2272             dump_all_perl(!DEBUG_B_TEST);
2273         if (!DEBUG_q_TEST)
2274           PERL_DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
2275 #endif
2276
2277         if (PL_minus_c) {
2278             PerlIO_printf(Perl_error_log, "%s syntax OK\n", PL_origfilename);
2279             my_exit(0);
2280         }
2281         if (PERLDB_SINGLE && PL_DBsingle)
2282             sv_setiv(PL_DBsingle, 1);
2283         if (PL_initav)
2284             call_list(oldscope, PL_initav);
2285 #ifdef PERL_DEBUG_READONLY_OPS
2286         Perl_pending_Slabs_to_ro(aTHX);
2287 #endif
2288     }
2289
2290     /* do it */
2291
2292     if (PL_restartop) {
2293         PL_op = PL_restartop;
2294         PL_restartop = 0;
2295         CALLRUNOPS(aTHX);
2296     }
2297     else if (PL_main_start) {
2298         CvDEPTH(PL_main_cv) = 1;
2299         PL_op = PL_main_start;
2300         CALLRUNOPS(aTHX);
2301     }
2302     my_exit(0);
2303     /* NOTREACHED */
2304 }
2305
2306 /*
2307 =head1 SV Manipulation Functions
2308
2309 =for apidoc p||get_sv
2310
2311 Returns the SV of the specified Perl scalar.  C<flags> are passed to
2312 C<gv_fetchpv>. If C<GV_ADD> is set and the
2313 Perl variable does not exist then it will be created.  If C<flags> is zero
2314 and the variable does not exist then NULL is returned.
2315
2316 =cut
2317 */
2318
2319 SV*
2320 Perl_get_sv(pTHX_ const char *name, I32 flags)
2321 {
2322     GV *gv;
2323
2324     PERL_ARGS_ASSERT_GET_SV;
2325
2326     gv = gv_fetchpv(name, flags, SVt_PV);
2327     if (gv)
2328         return GvSV(gv);
2329     return NULL;
2330 }
2331
2332 /*
2333 =head1 Array Manipulation Functions
2334
2335 =for apidoc p||get_av
2336
2337 Returns the AV of the specified Perl array.  C<flags> are passed to
2338 C<gv_fetchpv>. If C<GV_ADD> is set and the
2339 Perl variable does not exist then it will be created.  If C<flags> is zero
2340 and the variable does not exist then NULL is returned.
2341
2342 =cut
2343 */
2344
2345 AV*
2346 Perl_get_av(pTHX_ const char *name, I32 flags)
2347 {
2348     GV* const gv = gv_fetchpv(name, flags, SVt_PVAV);
2349
2350     PERL_ARGS_ASSERT_GET_AV;
2351
2352     if (flags)
2353         return GvAVn(gv);
2354     if (gv)
2355         return GvAV(gv);
2356     return NULL;
2357 }
2358
2359 /*
2360 =head1 Hash Manipulation Functions
2361
2362 =for apidoc p||get_hv
2363
2364 Returns the HV of the specified Perl hash.  C<flags> are passed to
2365 C<gv_fetchpv>. If C<GV_ADD> is set and the
2366 Perl variable does not exist then it will be created.  If C<flags> is zero
2367 and the variable does not exist then NULL is returned.
2368
2369 =cut
2370 */
2371
2372 HV*
2373 Perl_get_hv(pTHX_ const char *name, I32 flags)
2374 {
2375     GV* const gv = gv_fetchpv(name, flags, SVt_PVHV);
2376
2377     PERL_ARGS_ASSERT_GET_HV;
2378
2379     if (flags)
2380         return GvHVn(gv);
2381     if (gv)
2382         return GvHV(gv);
2383     return NULL;
2384 }
2385
2386 /*
2387 =head1 CV Manipulation Functions
2388
2389 =for apidoc p||get_cvn_flags
2390
2391 Returns the CV of the specified Perl subroutine.  C<flags> are passed to
2392 C<gv_fetchpvn_flags>. If C<GV_ADD> is set and the Perl subroutine does not
2393 exist then it will be declared (which has the same effect as saying
2394 C<sub name;>).  If C<GV_ADD> is not set and the subroutine does not exist
2395 then NULL is returned.
2396
2397 =for apidoc p||get_cv
2398
2399 Uses C<strlen> to get the length of C<name>, then calls C<get_cvn_flags>.
2400
2401 =cut
2402 */
2403
2404 CV*
2405 Perl_get_cvn_flags(pTHX_ const char *name, STRLEN len, I32 flags)
2406 {
2407     GV* const gv = gv_fetchpvn_flags(name, len, flags, SVt_PVCV);
2408     /* XXX this is probably not what they think they're getting.
2409      * It has the same effect as "sub name;", i.e. just a forward
2410      * declaration! */
2411
2412     PERL_ARGS_ASSERT_GET_CVN_FLAGS;
2413
2414     if ((flags & ~GV_NOADD_MASK) && !GvCVu(gv)) {
2415         SV *const sv = newSVpvn_flags(name, len, flags & SVf_UTF8);
2416         return newSUB(start_subparse(FALSE, 0),
2417                       newSVOP(OP_CONST, 0, sv),
2418                       NULL, NULL);
2419     }
2420     if (gv)
2421         return GvCVu(gv);
2422     return NULL;
2423 }
2424
2425 /* Nothing in core calls this now, but we can't replace it with a macro and
2426    move it to mathoms.c as a macro would evaluate name twice.  */
2427 CV*
2428 Perl_get_cv(pTHX_ const char *name, I32 flags)
2429 {
2430     PERL_ARGS_ASSERT_GET_CV;
2431
2432     return get_cvn_flags(name, strlen(name), flags);
2433 }
2434
2435 /* Be sure to refetch the stack pointer after calling these routines. */
2436
2437 /*
2438
2439 =head1 Callback Functions
2440
2441 =for apidoc p||call_argv
2442
2443 Performs a callback to the specified Perl sub.  See L<perlcall>.
2444
2445 =cut
2446 */
2447
2448 I32
2449 Perl_call_argv(pTHX_ const char *sub_name, I32 flags, register char **argv)
2450
2451                         /* See G_* flags in cop.h */
2452                         /* null terminated arg list */
2453 {
2454     dVAR;
2455     dSP;
2456
2457     PERL_ARGS_ASSERT_CALL_ARGV;
2458
2459     PUSHMARK(SP);
2460     if (argv) {
2461         while (*argv) {
2462             mXPUSHs(newSVpv(*argv,0));
2463             argv++;
2464         }
2465         PUTBACK;
2466     }
2467     return call_pv(sub_name, flags);
2468 }
2469
2470 /*
2471 =for apidoc p||call_pv
2472
2473 Performs a callback to the specified Perl sub.  See L<perlcall>.
2474
2475 =cut
2476 */
2477
2478 I32
2479 Perl_call_pv(pTHX_ const char *sub_name, I32 flags)
2480                         /* name of the subroutine */
2481                         /* See G_* flags in cop.h */
2482 {
2483     PERL_ARGS_ASSERT_CALL_PV;
2484
2485     return call_sv(MUTABLE_SV(get_cv(sub_name, GV_ADD)), flags);
2486 }
2487
2488 /*
2489 =for apidoc p||call_method
2490
2491 Performs a callback to the specified Perl method.  The blessed object must
2492 be on the stack.  See L<perlcall>.
2493
2494 =cut
2495 */
2496
2497 I32
2498 Perl_call_method(pTHX_ const char *methname, I32 flags)
2499                         /* name of the subroutine */
2500                         /* See G_* flags in cop.h */
2501 {
2502     STRLEN len;
2503     PERL_ARGS_ASSERT_CALL_METHOD;
2504
2505     len = strlen(methname);
2506
2507     /* XXX: sv_2mortal(newSVpvn_share(methname, len)) can be faster */
2508     return call_sv(newSVpvn_flags(methname, len, SVs_TEMP), flags | G_METHOD);
2509 }
2510
2511 /* May be called with any of a CV, a GV, or an SV containing the name. */
2512 /*
2513 =for apidoc p||call_sv
2514
2515 Performs a callback to the Perl sub whose name is in the SV.  See
2516 L<perlcall>.
2517
2518 =cut
2519 */
2520
2521 I32
2522 Perl_call_sv(pTHX_ SV *sv, VOL I32 flags)
2523                         /* See G_* flags in cop.h */
2524 {
2525     dVAR; dSP;
2526     LOGOP myop;         /* fake syntax tree node */
2527     UNOP method_op;
2528     I32 oldmark;
2529     VOL I32 retval = 0;
2530     I32 oldscope;
2531     bool oldcatch = CATCH_GET;
2532     int ret;
2533     OP* const oldop = PL_op;
2534     dJMPENV;
2535
2536     PERL_ARGS_ASSERT_CALL_SV;
2537
2538     if (flags & G_DISCARD) {
2539         ENTER;
2540         SAVETMPS;
2541     }
2542     if (!(flags & G_WANT)) {
2543         /* Backwards compatibility - as G_SCALAR was 0, it could be omitted.
2544          */
2545         flags |= G_SCALAR;
2546     }
2547
2548     Zero(&myop, 1, LOGOP);
2549     myop.op_next = NULL;
2550     if (!(flags & G_NOARGS))
2551         myop.op_flags |= OPf_STACKED;
2552     myop.op_flags |= OP_GIMME_REVERSE(flags);
2553     SAVEOP();
2554     PL_op = (OP*)&myop;
2555
2556     EXTEND(PL_stack_sp, 1);
2557     *++PL_stack_sp = sv;
2558     oldmark = TOPMARK;
2559     oldscope = PL_scopestack_ix;
2560
2561     if (PERLDB_SUB && PL_curstash != PL_debstash
2562            /* Handle first BEGIN of -d. */
2563           && (PL_DBcv || (PL_DBcv = GvCV(PL_DBsub)))
2564            /* Try harder, since this may have been a sighandler, thus
2565             * curstash may be meaningless. */
2566           && (SvTYPE(sv) != SVt_PVCV || CvSTASH((const CV *)sv) != PL_debstash)
2567           && !(flags & G_NODEBUG))
2568         PL_op->op_private |= OPpENTERSUB_DB;
2569
2570     if (flags & G_METHOD) {
2571         Zero(&method_op, 1, UNOP);
2572         method_op.op_next = PL_op;
2573         method_op.op_ppaddr = PL_ppaddr[OP_METHOD];
2574         method_op.op_type = OP_METHOD;
2575         myop.op_ppaddr = PL_ppaddr[OP_ENTERSUB];
2576         myop.op_type = OP_ENTERSUB;
2577         PL_op = (OP*)&method_op;
2578     }
2579
2580     if (!(flags & G_EVAL)) {
2581         CATCH_SET(TRUE);
2582         CALL_BODY_SUB((OP*)&myop);
2583         retval = PL_stack_sp - (PL_stack_base + oldmark);
2584         CATCH_SET(oldcatch);
2585     }
2586     else {
2587         myop.op_other = (OP*)&myop;
2588         PL_markstack_ptr--;
2589         create_eval_scope(flags|G_FAKINGEVAL);
2590         PL_markstack_ptr++;
2591
2592         JMPENV_PUSH(ret);
2593
2594         switch (ret) {
2595         case 0:
2596  redo_body:
2597             CALL_BODY_SUB((OP*)&myop);
2598             retval = PL_stack_sp - (PL_stack_base + oldmark);
2599             if (!(flags & G_KEEPERR)) {
2600                 CLEAR_ERRSV();
2601             }
2602             break;
2603         case 1:
2604             STATUS_ALL_FAILURE;
2605             /* FALL THROUGH */
2606         case 2:
2607             /* my_exit() was called */
2608             PL_curstash = PL_defstash;
2609             FREETMPS;
2610             JMPENV_POP;
2611             if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
2612                 Perl_croak(aTHX_ "Callback called exit");
2613             my_exit_jump();
2614             /* NOTREACHED */
2615         case 3:
2616             if (PL_restartop) {
2617                 PL_op = PL_restartop;
2618                 PL_restartop = 0;
2619                 goto redo_body;
2620             }
2621             PL_stack_sp = PL_stack_base + oldmark;
2622             if ((flags & G_WANT) == G_ARRAY)
2623                 retval = 0;
2624             else {
2625                 retval = 1;
2626                 *++PL_stack_sp = &PL_sv_undef;
2627             }
2628             break;
2629         }
2630
2631         if (PL_scopestack_ix > oldscope)
2632             delete_eval_scope();
2633         JMPENV_POP;
2634     }
2635
2636     if (flags & G_DISCARD) {
2637         PL_stack_sp = PL_stack_base + oldmark;
2638         retval = 0;
2639         FREETMPS;
2640         LEAVE;
2641     }
2642     PL_op = oldop;
2643     return retval;
2644 }
2645
2646 /* Eval a string. The G_EVAL flag is always assumed. */
2647
2648 /*
2649 =for apidoc p||eval_sv
2650
2651 Tells Perl to C<eval> the string in the SV.
2652
2653 =cut
2654 */
2655
2656 I32
2657 Perl_eval_sv(pTHX_ SV *sv, I32 flags)
2658
2659                         /* See G_* flags in cop.h */
2660 {
2661     dVAR;
2662     dSP;
2663     UNOP myop;          /* fake syntax tree node */
2664     VOL I32 oldmark = SP - PL_stack_base;
2665     VOL I32 retval = 0;
2666     int ret;
2667     OP* const oldop = PL_op;
2668     dJMPENV;
2669
2670     PERL_ARGS_ASSERT_EVAL_SV;
2671
2672     if (flags & G_DISCARD) {
2673         ENTER;
2674         SAVETMPS;
2675     }
2676
2677     SAVEOP();
2678     PL_op = (OP*)&myop;
2679     Zero(PL_op, 1, UNOP);
2680     EXTEND(PL_stack_sp, 1);
2681     *++PL_stack_sp = sv;
2682
2683     if (!(flags & G_NOARGS))
2684         myop.op_flags = OPf_STACKED;
2685     myop.op_next = NULL;
2686     myop.op_type = OP_ENTEREVAL;
2687     myop.op_flags |= OP_GIMME_REVERSE(flags);
2688     if (flags & G_KEEPERR)
2689         myop.op_flags |= OPf_SPECIAL;
2690
2691     /* fail now; otherwise we could fail after the JMPENV_PUSH but
2692      * before a PUSHEVAL, which corrupts the stack after a croak */
2693     TAINT_PROPER("eval_sv()");
2694
2695     JMPENV_PUSH(ret);
2696     switch (ret) {
2697     case 0:
2698  redo_body:
2699         CALL_BODY_EVAL((OP*)&myop);
2700         retval = PL_stack_sp - (PL_stack_base + oldmark);
2701         if (!(flags & G_KEEPERR)) {
2702             CLEAR_ERRSV();
2703         }
2704         break;
2705     case 1:
2706         STATUS_ALL_FAILURE;
2707         /* FALL THROUGH */
2708     case 2:
2709         /* my_exit() was called */
2710         PL_curstash = PL_defstash;
2711         FREETMPS;
2712         JMPENV_POP;
2713         if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
2714             Perl_croak(aTHX_ "Callback called exit");
2715         my_exit_jump();
2716         /* NOTREACHED */
2717     case 3:
2718         if (PL_restartop) {
2719             PL_op = PL_restartop;
2720             PL_restartop = 0;
2721             goto redo_body;
2722         }
2723         PL_stack_sp = PL_stack_base + oldmark;
2724         if ((flags & G_WANT) == G_ARRAY)
2725             retval = 0;
2726         else {
2727             retval = 1;
2728             *++PL_stack_sp = &PL_sv_undef;
2729         }
2730         break;
2731     }
2732
2733     JMPENV_POP;
2734     if (flags & G_DISCARD) {
2735         PL_stack_sp = PL_stack_base + oldmark;
2736         retval = 0;
2737         FREETMPS;
2738         LEAVE;
2739     }
2740     PL_op = oldop;
2741     return retval;
2742 }
2743
2744 /*
2745 =for apidoc p||eval_pv
2746
2747 Tells Perl to C<eval> the given string and return an SV* result.
2748
2749 =cut
2750 */
2751
2752 SV*
2753 Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error)
2754 {
2755     dVAR;
2756     dSP;
2757     SV* sv = newSVpv(p, 0);
2758
2759     PERL_ARGS_ASSERT_EVAL_PV;
2760
2761     eval_sv(sv, G_SCALAR);
2762     SvREFCNT_dec(sv);
2763
2764     SPAGAIN;
2765     sv = POPs;
2766     PUTBACK;
2767
2768     if (croak_on_error && SvTRUE(ERRSV)) {
2769         Perl_croak(aTHX_ "%s", SvPVx_nolen_const(ERRSV));
2770     }
2771
2772     return sv;
2773 }
2774
2775 /* Require a module. */
2776
2777 /*
2778 =head1 Embedding Functions
2779
2780 =for apidoc p||require_pv
2781
2782 Tells Perl to C<require> the file named by the string argument.  It is
2783 analogous to the Perl code C<eval "require '$file'">.  It's even
2784 implemented that way; consider using load_module instead.
2785
2786 =cut */
2787
2788 void
2789 Perl_require_pv(pTHX_ const char *pv)
2790 {
2791     dVAR;
2792     dSP;
2793     SV* sv;
2794
2795     PERL_ARGS_ASSERT_REQUIRE_PV;
2796
2797     PUSHSTACKi(PERLSI_REQUIRE);
2798     PUTBACK;
2799     sv = Perl_newSVpvf(aTHX_ "require q%c%s%c", 0, pv, 0);
2800     eval_sv(sv_2mortal(sv), G_DISCARD);
2801     SPAGAIN;
2802     POPSTACK;
2803 }
2804
2805 STATIC void
2806 S_usage(pTHX_ const char *name)         /* XXX move this out into a module ? */
2807 {
2808     /* This message really ought to be max 23 lines.
2809      * Removed -h because the user already knows that option. Others? */
2810
2811     static const char * const usage_msg[] = {
2812 "-0[octal]         specify record separator (\\0, if no argument)",
2813 "-a                autosplit mode with -n or -p (splits $_ into @F)",
2814 "-C[number/list]   enables the listed Unicode features",
2815 "-c                check syntax only (runs BEGIN and CHECK blocks)",
2816 "-d[:debugger]     run program under debugger",
2817 "-D[number/list]   set debugging flags (argument is a bit mask or alphabets)",
2818 "-e program        one line of program (several -e's allowed, omit programfile)",
2819 "-E program        like -e, but enables all optional features",
2820 "-f                don't do $sitelib/sitecustomize.pl at startup",
2821 "-F/pattern/       split() pattern for -a switch (//'s are optional)",
2822 "-i[extension]     edit <> files in place (makes backup if extension supplied)",
2823 "-Idirectory       specify @INC/#include directory (several -I's allowed)",
2824 "-l[octal]         enable line ending processing, specifies line terminator",
2825 "-[mM][-]module    execute \"use/no module...\" before executing program",
2826 "-n                assume \"while (<>) { ... }\" loop around program",
2827 "-p                assume loop like -n but print line also, like sed",
2828 "-s                enable rudimentary parsing for switches after programfile",
2829 "-S                look for programfile using PATH environment variable",
2830 "-t                enable tainting warnings",
2831 "-T                enable tainting checks",
2832 "-u                dump core after parsing program",
2833 "-U                allow unsafe operations",
2834 "-v                print version, subversion (includes VERY IMPORTANT perl info)",
2835 "-V[:variable]     print configuration summary (or a single Config.pm variable)",
2836 "-w                enable many useful warnings (RECOMMENDED)",
2837 "-W                enable all warnings",
2838 "-x[directory]     strip off text before #!perl line and perhaps cd to directory",
2839 "-X                disable all warnings",
2840 "\n",
2841 NULL
2842 };
2843     const char * const *p = usage_msg;
2844
2845     PERL_ARGS_ASSERT_USAGE;
2846
2847     PerlIO_printf(PerlIO_stdout(),
2848                   "\nUsage: %s [switches] [--] [programfile] [arguments]",
2849                   name);
2850     while (*p)
2851         PerlIO_printf(PerlIO_stdout(), "\n  %s", *p++);
2852 }
2853
2854 /* convert a string of -D options (or digits) into an int.
2855  * sets *s to point to the char after the options */
2856
2857 #ifdef DEBUGGING
2858 int
2859 Perl_get_debug_opts(pTHX_ const char **s, bool givehelp)
2860 {
2861     static const char * const usage_msgd[] = {
2862       " Debugging flag values: (see also -d)",
2863       "  p  Tokenizing and parsing (with v, displays parse stack)",
2864       "  s  Stack snapshots (with v, displays all stacks)",
2865       "  l  Context (loop) stack processing",
2866       "  t  Trace execution",
2867       "  o  Method and overloading resolution",
2868       "  c  String/numeric conversions",
2869       "  P  Print profiling info, source file input state",
2870       "  m  Memory and SV allocation",
2871       "  f  Format processing",
2872       "  r  Regular expression parsing and execution",
2873       "  x  Syntax tree dump",
2874       "  u  Tainting checks",
2875       "  H  Hash dump -- usurps values()",
2876       "  X  Scratchpad allocation",
2877       "  D  Cleaning up",
2878       "  T  Tokenising",
2879       "  R  Include reference counts of dumped variables (eg when using -Ds)",
2880       "  J  Do not s,t,P-debug (Jump over) opcodes within package DB",
2881       "  v  Verbose: use in conjunction with other flags",
2882       "  C  Copy On Write",
2883       "  A  Consistency checks on internal structures",
2884       "  q  quiet - currently only suppresses the 'EXECUTING' message",
2885       "  M  trace smart match resolution",
2886       "  B  dump suBroutine definitions, including special Blocks like BEGIN",
2887       NULL
2888     };
2889     int i = 0;
2890
2891     PERL_ARGS_ASSERT_GET_DEBUG_OPTS;
2892
2893     if (isALPHA(**s)) {
2894         /* if adding extra options, remember to update DEBUG_MASK */
2895         static const char debopts[] = "psltocPmfrxuUHXDSTRJvCAqMB";
2896
2897         for (; isALNUM(**s); (*s)++) {
2898             const char * const d = strchr(debopts,**s);
2899             if (d)
2900                 i |= 1 << (d - debopts);
2901             else if (ckWARN_d(WARN_DEBUGGING))
2902                 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
2903                     "invalid option -D%c, use -D'' to see choices\n", **s);
2904         }
2905     }
2906     else if (isDIGIT(**s)) {
2907         i = atoi(*s);
2908         for (; isALNUM(**s); (*s)++) ;
2909     }
2910     else if (givehelp) {
2911       const char *const *p = usage_msgd;
2912       while (*p) PerlIO_printf(PerlIO_stdout(), "%s\n", *p++);
2913     }
2914 #  ifdef EBCDIC
2915     if ((i & DEBUG_p_FLAG) && ckWARN_d(WARN_DEBUGGING))
2916         Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
2917                 "-Dp not implemented on this platform\n");
2918 #  endif
2919     return i;
2920 }
2921 #endif
2922
2923 /* This routine handles any switches that can be given during run */
2924
2925 const char *
2926 Perl_moreswitches(pTHX_ const char *s)
2927 {
2928     dVAR;
2929     UV rschar;
2930     const char option = *s; /* used to remember option in -m/-M code */
2931
2932     PERL_ARGS_ASSERT_MORESWITCHES;
2933
2934     switch (*s) {
2935     case '0':
2936     {
2937          I32 flags = 0;
2938          STRLEN numlen;
2939
2940          SvREFCNT_dec(PL_rs);
2941          if (s[1] == 'x' && s[2]) {
2942               const char *e = s+=2;
2943               U8 *tmps;
2944
2945               while (*e)
2946                 e++;
2947               numlen = e - s;
2948               flags = PERL_SCAN_SILENT_ILLDIGIT;
2949               rschar = (U32)grok_hex(s, &numlen, &flags, NULL);
2950               if (s + numlen < e) {
2951                    rschar = 0; /* Grandfather -0xFOO as -0 -xFOO. */
2952                    numlen = 0;
2953                    s--;
2954               }
2955               PL_rs = newSVpvs("");
2956               SvGROW(PL_rs, (STRLEN)(UNISKIP(rschar) + 1));
2957               tmps = (U8*)SvPVX(PL_rs);
2958               uvchr_to_utf8(tmps, rschar);
2959               SvCUR_set(PL_rs, UNISKIP(rschar));
2960               SvUTF8_on(PL_rs);
2961          }
2962          else {
2963               numlen = 4;
2964               rschar = (U32)grok_oct(s, &numlen, &flags, NULL);
2965               if (rschar & ~((U8)~0))
2966                    PL_rs = &PL_sv_undef;
2967               else if (!rschar && numlen >= 2)
2968                    PL_rs = newSVpvs("");
2969               else {
2970                    char ch = (char)rschar;
2971                    PL_rs = newSVpvn(&ch, 1);
2972               }
2973          }
2974          sv_setsv(get_sv("/", GV_ADD), PL_rs);
2975          return s + numlen;
2976     }
2977     case 'C':
2978         s++;
2979         PL_unicode = parse_unicode_opts( (const char **)&s );
2980         if (PL_unicode & PERL_UNICODE_UTF8CACHEASSERT_FLAG)
2981             PL_utf8cache = -1;
2982         return s;
2983     case 'F':
2984         PL_minus_F = TRUE;
2985         PL_splitstr = ++s;
2986         while (*s && !isSPACE(*s)) ++s;
2987         PL_splitstr = savepvn(PL_splitstr, s - PL_splitstr);
2988         return s;
2989     case 'a':
2990         PL_minus_a = TRUE;
2991         s++;
2992         return s;
2993     case 'c':
2994         PL_minus_c = TRUE;
2995         s++;
2996         return s;
2997     case 'd':
2998         forbid_setid('d', FALSE);
2999         s++;
3000
3001         /* -dt indicates to the debugger that threads will be used */
3002         if (*s == 't' && !isALNUM(s[1])) {
3003             ++s;
3004             my_setenv("PERL5DB_THREADED", "1");
3005         }
3006
3007         /* The following permits -d:Mod to accepts arguments following an =
3008            in the fashion that -MSome::Mod does. */
3009         if (*s == ':' || *s == '=') {
3010             const char *start = ++s;
3011             const char *const end = s + strlen(s);
3012             SV * const sv = newSVpvs("use Devel::");
3013
3014             /* We now allow -d:Module=Foo,Bar */
3015             while(isALNUM(*s) || *s==':') ++s;
3016             if (*s != '=')
3017                 sv_catpvn(sv, start, end - start);
3018             else {
3019                 sv_catpvn(sv, start, s-start);
3020                 /* Don't use NUL as q// delimiter here, this string goes in the
3021                  * environment. */
3022                 Perl_sv_catpvf(aTHX_ sv, " split(/,/,q{%s});", ++s);
3023             }
3024             s = end;
3025             my_setenv("PERL5DB", SvPV_nolen_const(sv));
3026             SvREFCNT_dec(sv);
3027         }
3028         if (!PL_perldb) {
3029             PL_perldb = PERLDB_ALL;
3030             init_debugger();
3031         }
3032         return s;
3033     case 'D':
3034     {   
3035 #ifdef DEBUGGING
3036         forbid_setid('D', FALSE);
3037         s++;
3038         PL_debug = get_debug_opts( (const char **)&s, 1) | DEBUG_TOP_FLAG;
3039 #else /* !DEBUGGING */
3040         if (ckWARN_d(WARN_DEBUGGING))
3041             Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
3042                    "Recompile perl with -DDEBUGGING to use -D switch (did you mean -d ?)\n");
3043         for (s++; isALNUM(*s); s++) ;
3044 #endif
3045         return s;
3046     }   
3047     case 'h':
3048         usage(PL_origargv[0]);
3049         my_exit(0);
3050     case 'i':
3051         Safefree(PL_inplace);
3052 #if defined(__CYGWIN__) /* do backup extension automagically */
3053         if (*(s+1) == '\0') {
3054         PL_inplace = savepvs(".bak");
3055         return s+1;
3056         }
3057 #endif /* __CYGWIN__ */
3058         {
3059             const char * const start = ++s;
3060             while (*s && !isSPACE(*s))
3061                 ++s;
3062
3063             PL_inplace = savepvn(start, s - start);
3064         }
3065         if (*s) {
3066             ++s;
3067             if (*s == '-')      /* Additional switches on #! line. */
3068                 s++;
3069         }
3070         return s;
3071     case 'I':   /* -I handled both here and in parse_body() */
3072         forbid_setid('I', FALSE);
3073         ++s;
3074         while (*s && isSPACE(*s))
3075             ++s;
3076         if (*s) {
3077             const char *e, *p;
3078             p = s;
3079             /* ignore trailing spaces (possibly followed by other switches) */
3080             do {
3081                 for (e = p; *e && !isSPACE(*e); e++) ;
3082                 p = e;
3083                 while (isSPACE(*p))
3084                     p++;
3085             } while (*p && *p != '-');
3086             incpush(s, e-s,
3087                     INCPUSH_ADD_SUB_DIRS|INCPUSH_ADD_OLD_VERS|INCPUSH_UNSHIFT);
3088             s = p;
3089             if (*s == '-')
3090                 s++;
3091         }
3092         else
3093             Perl_croak(aTHX_ "No directory specified for -I");
3094         return s;
3095     case 'l':
3096         PL_minus_l = TRUE;
3097         s++;
3098         if (PL_ors_sv) {
3099             SvREFCNT_dec(PL_ors_sv);
3100             PL_ors_sv = NULL;
3101         }
3102         if (isDIGIT(*s)) {
3103             I32 flags = 0;
3104             STRLEN numlen;
3105             PL_ors_sv = newSVpvs("\n");
3106             numlen = 3 + (*s == '0');
3107             *SvPVX(PL_ors_sv) = (char)grok_oct(s, &numlen, &flags, NULL);
3108             s += numlen;
3109         }
3110         else {
3111             if (RsPARA(PL_rs)) {
3112                 PL_ors_sv = newSVpvs("\n\n");
3113             }
3114             else {
3115                 PL_ors_sv = newSVsv(PL_rs);
3116             }
3117         }
3118         return s;
3119     case 'M':
3120         forbid_setid('M', FALSE);       /* XXX ? */
3121         /* FALL THROUGH */
3122     case 'm':
3123         forbid_setid('m', FALSE);       /* XXX ? */
3124         if (*++s) {
3125             const char *start;
3126             const char *end;
3127             SV *sv;
3128             const char *use = "use ";
3129             bool colon = FALSE;
3130             /* -M-foo == 'no foo'       */
3131             /* Leading space on " no " is deliberate, to make both
3132                possibilities the same length.  */
3133             if (*s == '-') { use = " no "; ++s; }
3134             sv = newSVpvn(use,4);
3135             start = s;
3136             /* We allow -M'Module qw(Foo Bar)'  */
3137             while(isALNUM(*s) || *s==':') {
3138                 if( *s++ == ':' ) {
3139                     if( *s == ':' ) 
3140                         s++;
3141                     else
3142                         colon = TRUE;
3143                 }
3144             }
3145             if (s == start)
3146                 Perl_croak(aTHX_ "Module name required with -%c option",
3147                                     option);
3148             if (colon) 
3149                 Perl_croak(aTHX_ "Invalid module name %.*s with -%c option: "
3150                                     "contains single ':'",
3151                                     (int)(s - start), start, option);
3152             end = s + strlen(s);
3153             if (*s != '=') {
3154                 sv_catpvn(sv, start, end - start);
3155                 if (option == 'm') {
3156                     if (*s != '\0')
3157                         Perl_croak(aTHX_ "Can't use '%c' after -mname", *s);
3158                     sv_catpvs( sv, " ()");
3159                 }
3160             } else {
3161                 sv_catpvn(sv, start, s-start);
3162                 /* Use NUL as q''-delimiter.  */
3163                 sv_catpvs(sv, " split(/,/,q\0");
3164                 ++s;
3165                 sv_catpvn(sv, s, end - s);
3166                 sv_catpvs(sv,  "\0)");
3167             }
3168             s = end;
3169             Perl_av_create_and_push(aTHX_ &PL_preambleav, sv);
3170         }
3171         else
3172             Perl_croak(aTHX_ "Missing argument to -%c", option);
3173         return s;
3174     case 'n':
3175         PL_minus_n = TRUE;
3176         s++;
3177         return s;
3178     case 'p':
3179         PL_minus_p = TRUE;
3180         s++;
3181         return s;
3182     case 's':
3183         forbid_setid('s', FALSE);
3184         PL_doswitches = TRUE;
3185         s++;
3186         return s;
3187     case 't':
3188         if (!PL_tainting)
3189             TOO_LATE_FOR('t');
3190         s++;
3191         return s;
3192     case 'T':
3193         if (!PL_tainting)
3194             TOO_LATE_FOR('T');
3195         s++;
3196         return s;
3197     case 'u':
3198         PL_do_undump = TRUE;
3199         s++;
3200         return s;
3201     case 'U':
3202         PL_unsafe = TRUE;
3203         s++;
3204         return s;
3205     case 'v':
3206         if (!sv_derived_from(PL_patchlevel, "version"))
3207             upg_version(PL_patchlevel, TRUE);
3208 #if !defined(DGUX)
3209         {
3210             SV* level= vstringify(PL_patchlevel);
3211 #ifdef PERL_PATCHNUM
3212 #  ifdef PERL_GIT_UNCOMMITTED_CHANGES
3213             SV *num = newSVpvs(PERL_PATCHNUM "*");
3214 #  else
3215             SV *num = newSVpvs(PERL_PATCHNUM);
3216 #  endif
3217
3218             if (sv_len(num)>=sv_len(level) && strnEQ(SvPV_nolen(num),SvPV_nolen(level),sv_len(level))) {
3219                 SvREFCNT_dec(level);
3220                 level= num;
3221             } else {
3222                 Perl_sv_catpvf(aTHX_ level, " (%"SVf")", num);
3223                 SvREFCNT_dec(num);
3224             }
3225  #endif
3226             PerlIO_printf(PerlIO_stdout(),
3227                 "\nThis is perl, %"SVf
3228                 " built for %s",
3229                 level,
3230                 ARCHNAME);
3231             SvREFCNT_dec(level);
3232         }
3233 #else /* DGUX */
3234 /* Adjust verbose output as in the perl that ships with the DG/UX OS from EMC */
3235         PerlIO_printf(PerlIO_stdout(),
3236                 Perl_form(aTHX_ "\nThis is perl, %"SVf"\n",
3237                     SVfARG(vstringify(PL_patchlevel))));
3238         PerlIO_printf(PerlIO_stdout(),
3239                         Perl_form(aTHX_ "        built under %s at %s %s\n",
3240                                         OSNAME, __DATE__, __TIME__));
3241         PerlIO_printf(PerlIO_stdout(),
3242                         Perl_form(aTHX_ "        OS Specific Release: %s\n",
3243                                         OSVERS));
3244 #endif /* !DGUX */
3245 #if defined(LOCAL_PATCH_COUNT)
3246         if (LOCAL_PATCH_COUNT > 0)
3247             PerlIO_printf(PerlIO_stdout(),
3248                           "\n(with %d registered patch%s, "
3249                           "see perl -V for more detail)",
3250                           LOCAL_PATCH_COUNT,
3251                           (LOCAL_PATCH_COUNT!=1) ? "es" : "");
3252 #endif
3253
3254         PerlIO_printf(PerlIO_stdout(),
3255                       "\n\nCopyright 1987-2009, Larry Wall\n");
3256 #ifdef MSDOS
3257         PerlIO_printf(PerlIO_stdout(),
3258                       "\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
3259 #endif
3260 #ifdef DJGPP
3261         PerlIO_printf(PerlIO_stdout(),
3262                       "djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n"
3263                       "djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n");
3264 #endif
3265 #ifdef OS2
3266         PerlIO_printf(PerlIO_stdout(),
3267                       "\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
3268                       "Version 5 port Copyright (c) 1994-2002, Andreas Kaiser, Ilya Zakharevich\n");
3269 #endif
3270 #ifdef atarist
3271         PerlIO_printf(PerlIO_stdout(),
3272                       "atariST series port, ++jrb  bammi@cadence.com\n");
3273 #endif
3274 #ifdef __BEOS__
3275         PerlIO_printf(PerlIO_stdout(),
3276                       "BeOS port Copyright Tom Spindler, 1997-1999\n");
3277 #endif
3278 #ifdef MPE
3279         PerlIO_printf(PerlIO_stdout(),
3280                       "MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-2003\n");
3281 #endif
3282 #ifdef OEMVS
3283         PerlIO_printf(PerlIO_stdout(),
3284                       "MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
3285 #endif
3286 #ifdef __VOS__
3287         PerlIO_printf(PerlIO_stdout(),
3288                       "Stratus VOS port by Paul.Green@stratus.com, 1997-2002\n");
3289 #endif
3290 #ifdef __OPEN_VM
3291         PerlIO_printf(PerlIO_stdout(),
3292                       "VM/ESA port by Neale Ferguson, 1998-1999\n");
3293 #endif
3294 #ifdef POSIX_BC
3295         PerlIO_printf(PerlIO_stdout(),
3296                       "BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
3297 #endif
3298 #ifdef EPOC
3299         PerlIO_printf(PerlIO_stdout(),
3300                       "EPOC port by Olaf Flebbe, 1999-2002\n");
3301 #endif
3302 #ifdef UNDER_CE
3303         PerlIO_printf(PerlIO_stdout(),"WINCE port by Rainer Keuchel, 2001-2002\n");
3304         PerlIO_printf(PerlIO_stdout(),"Built on " __DATE__ " " __TIME__ "\n\n");
3305         wce_hitreturn();
3306 #endif
3307 #ifdef __SYMBIAN32__
3308         PerlIO_printf(PerlIO_stdout(),
3309                       "Symbian port by Nokia, 2004-2005\n");
3310 #endif
3311 #ifdef BINARY_BUILD_NOTICE
3312         BINARY_BUILD_NOTICE;
3313 #endif
3314         PerlIO_printf(PerlIO_stdout(),
3315                       "\n\
3316 Perl may be copied only under the terms of either the Artistic License or the\n\
3317 GNU General Public License, which may be found in the Perl 5 source kit.\n\n\
3318 Complete documentation for Perl, including FAQ lists, should be found on\n\
3319 this system using \"man perl\" or \"perldoc perl\".  If you have access to the\n\
3320 Internet, point your browser at http://www.perl.org/, the Perl Home Page.\n\n");
3321         my_exit(0);
3322     case 'w':
3323         if (! (PL_dowarn & G_WARN_ALL_MASK)) {
3324             PL_dowarn |= G_WARN_ON;
3325         }
3326         s++;
3327         return s;
3328     case 'W':
3329         PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
3330         if (!specialWARN(PL_compiling.cop_warnings))
3331             PerlMemShared_free(PL_compiling.cop_warnings);
3332         PL_compiling.cop_warnings = pWARN_ALL ;
3333         s++;
3334         return s;
3335     case 'X':
3336         PL_dowarn = G_WARN_ALL_OFF;
3337         if (!specialWARN(PL_compiling.cop_warnings))
3338             PerlMemShared_free(PL_compiling.cop_warnings);
3339         PL_compiling.cop_warnings = pWARN_NONE ;
3340         s++;
3341         return s;
3342     case '*':
3343     case ' ':
3344         while( *s == ' ' )
3345           ++s;
3346         if (s[0] == '-')        /* Additional switches on #! line. */
3347             return s+1;
3348         break;
3349     case '-':
3350     case 0:
3351 #if defined(WIN32) || !defined(PERL_STRICT_CR)
3352     case '\r':
3353 #endif
3354     case '\n':
3355     case '\t':
3356         break;
3357 #ifdef ALTERNATE_SHEBANG
3358     case 'S':                   /* OS/2 needs -S on "extproc" line. */
3359         break;
3360 #endif
3361     default:
3362         Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s);
3363     }
3364     return NULL;
3365 }
3366
3367 /* compliments of Tom Christiansen */
3368
3369 /* unexec() can be found in the Gnu emacs distribution */
3370 /* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
3371
3372 void
3373 Perl_my_unexec(pTHX)
3374 {
3375     PERL_UNUSED_CONTEXT;
3376 #ifdef UNEXEC
3377     SV *    prog = newSVpv(BIN_EXP, 0);
3378     SV *    file = newSVpv(PL_origfilename, 0);
3379     int    status = 1;
3380     extern int etext;
3381
3382     sv_catpvs(prog, "/perl");
3383     sv_catpvs(file, ".perldump");
3384
3385     unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
3386     /* unexec prints msg to stderr in case of failure */
3387     PerlProc_exit(status);
3388 #else
3389 #  ifdef VMS
3390 #    include <lib$routines.h>
3391      lib$signal(SS$_DEBUG);  /* ssdef.h #included from vmsish.h */
3392 #  elif defined(WIN32) || defined(__CYGWIN__)
3393     Perl_croak(aTHX_ "dump is not supported");
3394 #  else
3395     ABORT();            /* for use with undump */
3396 #  endif
3397 #endif
3398 }
3399
3400 /* initialize curinterp */
3401 STATIC void
3402 S_init_interp(pTHX)
3403 {
3404     dVAR;
3405 #ifdef MULTIPLICITY
3406 #  define PERLVAR(var,type)
3407 #  define PERLVARA(var,n,type)
3408 #  if defined(PERL_IMPLICIT_CONTEXT)
3409 #    define PERLVARI(var,type,init)             aTHX->var = init;
3410 #    define PERLVARIC(var,type,init)    aTHX->var = init;
3411 #  else
3412 #    define PERLVARI(var,type,init)     PERL_GET_INTERP->var = init;
3413 #    define PERLVARIC(var,type,init)    PERL_GET_INTERP->var = init;
3414 #  endif
3415 #  include "intrpvar.h"
3416 #  undef PERLVAR
3417 #  undef PERLVARA
3418 #  undef PERLVARI
3419 #  undef PERLVARIC
3420 #else
3421 #  define PERLVAR(var,type)
3422 #  define PERLVARA(var,n,type)
3423 #  define PERLVARI(var,type,init)       PL_##var = init;
3424 #  define PERLVARIC(var,type,init)      PL_##var = init;
3425 #  include "intrpvar.h"
3426 #  undef PERLVAR
3427 #  undef PERLVARA
3428 #  undef PERLVARI
3429 #  undef PERLVARIC
3430 #endif
3431
3432     /* As these are inside a structure, PERLVARI isn't capable of initialising
3433        them  */
3434     PL_reg_oldcurpm = PL_reg_curpm = NULL;
3435     PL_reg_poscache = PL_reg_starttry = NULL;
3436 }
3437
3438 STATIC void
3439 S_init_main_stash(pTHX)
3440 {
3441     dVAR;
3442     GV *gv;
3443
3444     PL_curstash = PL_defstash = newHV();
3445     /* We know that the string "main" will be in the global shared string
3446        table, so it's a small saving to use it rather than allocate another
3447        8 bytes.  */
3448     PL_curstname = newSVpvs_share("main");
3449     gv = gv_fetchpvs("main::", GV_ADD|GV_NOTQUAL, SVt_PVHV);
3450     /* If we hadn't caused another reference to "main" to be in the shared
3451        string table above, then it would be worth reordering these two,
3452        because otherwise all we do is delete "main" from it as a consequence
3453        of the SvREFCNT_dec, only to add it again with hv_name_set */
3454     SvREFCNT_dec(GvHV(gv));
3455     hv_name_set(PL_defstash, "main", 4, 0);
3456     GvHV(gv) = MUTABLE_HV(SvREFCNT_inc_simple(PL_defstash));
3457     SvREADONLY_on(gv);
3458     PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpvs("INC", GV_ADD|GV_NOTQUAL,
3459                                              SVt_PVAV)));
3460     SvREFCNT_inc_simple_void(PL_incgv); /* Don't allow it to be freed */
3461     GvMULTI_on(PL_incgv);
3462     PL_hintgv = gv_fetchpvs("\010", GV_ADD|GV_NOTQUAL, SVt_PV); /* ^H */
3463     GvMULTI_on(PL_hintgv);
3464     PL_defgv = gv_fetchpvs("_", GV_ADD|GV_NOTQUAL, SVt_PVAV);
3465     SvREFCNT_inc_simple_void(PL_defgv);
3466     PL_errgv = gv_HVadd(gv_fetchpvs("@", GV_ADD|GV_NOTQUAL, SVt_PV));
3467     SvREFCNT_inc_simple_void(PL_errgv);
3468     GvMULTI_on(PL_errgv);
3469     PL_replgv = gv_fetchpvs("\022", GV_ADD|GV_NOTQUAL, SVt_PV); /* ^R */
3470     GvMULTI_on(PL_replgv);
3471     (void)Perl_form(aTHX_ "%240s","");  /* Preallocate temp - for immediate signals. */
3472 #ifdef PERL_DONT_CREATE_GVSV
3473     gv_SVadd(PL_errgv);
3474 #endif
3475     sv_grow(ERRSV, 240);        /* Preallocate - for immediate signals. */
3476     CLEAR_ERRSV();
3477     PL_curstash = PL_defstash;
3478     CopSTASH_set(&PL_compiling, PL_defstash);
3479     PL_debstash = GvHV(gv_fetchpvs("DB::", GV_ADDMULTI, SVt_PVHV));
3480     PL_globalstash = GvHV(gv_fetchpvs("CORE::GLOBAL::", GV_ADDMULTI,
3481                                       SVt_PVHV));
3482     /* We must init $/ before switches are processed. */
3483     sv_setpvs(get_sv("/", GV_ADD), "\n");
3484 }
3485
3486 STATIC int
3487 S_open_script(pTHX_ const char *scriptname, bool dosearch,
3488               bool *suidscript, PerlIO **rsfpp)
3489 {
3490     int fdscript = -1;
3491     dVAR;
3492
3493     PERL_ARGS_ASSERT_OPEN_SCRIPT;
3494
3495     if (PL_e_script) {
3496         PL_origfilename = savepvs("-e");
3497     }
3498     else {
3499         /* if find_script() returns, it returns a malloc()-ed value */
3500         scriptname = PL_origfilename = find_script(scriptname, dosearch, NULL, 1);
3501
3502         if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
3503             const char *s = scriptname + 8;
3504             fdscript = atoi(s);
3505             while (isDIGIT(*s))
3506                 s++;
3507             if (*s) {
3508                 /* PSz 18 Feb 04
3509                  * Tell apart "normal" usage of fdscript, e.g.
3510                  * with bash on FreeBSD:
3511                  *   perl <( echo '#!perl -DA'; echo 'print "$0\n"')
3512                  * from usage in suidperl.
3513                  * Does any "normal" usage leave garbage after the number???
3514                  * Is it a mistake to use a similar /dev/fd/ construct for
3515                  * suidperl?
3516                  */
3517                 *suidscript = TRUE;
3518                 /* PSz 20 Feb 04  
3519                  * Be supersafe and do some sanity-checks.
3520                  * Still, can we be sure we got the right thing?
3521                  */
3522                 if (*s != '/') {
3523                     Perl_croak(aTHX_ "Wrong syntax (suid) fd script name \"%s\"\n", s);
3524                 }
3525                 if (! *(s+1)) {
3526                     Perl_croak(aTHX_ "Missing (suid) fd script name\n");
3527                 }
3528                 scriptname = savepv(s + 1);
3529                 Safefree(PL_origfilename);
3530                 PL_origfilename = (char *)scriptname;
3531             }
3532         }
3533     }
3534
3535     CopFILE_free(PL_curcop);
3536     CopFILE_set(PL_curcop, PL_origfilename);
3537     if (*PL_origfilename == '-' && PL_origfilename[1] == '\0')
3538         scriptname = (char *)"";
3539     if (fdscript >= 0) {
3540         *rsfpp = PerlIO_fdopen(fdscript,PERL_SCRIPT_MODE);
3541 #       if defined(HAS_FCNTL) && defined(F_SETFD)
3542             if (*rsfpp)
3543                 /* ensure close-on-exec */
3544                 fcntl(PerlIO_fileno(*rsfpp),F_SETFD,1);
3545 #       endif
3546     }
3547     else if (!*scriptname) {
3548         forbid_setid(0, *suidscript);
3549         *rsfpp = PerlIO_stdin();
3550     }
3551     else {
3552 #ifdef FAKE_BIT_BUCKET
3553         /* This hack allows one not to have /dev/null (or BIT_BUCKET as it
3554          * is called) and still have the "-e" work.  (Believe it or not,
3555          * a /dev/null is required for the "-e" to work because source
3556          * filter magic is used to implement it. ) This is *not* a general
3557          * replacement for a /dev/null.  What we do here is create a temp
3558          * file (an empty file), open up that as the script, and then
3559          * immediately close and unlink it.  Close enough for jazz. */ 
3560 #define FAKE_BIT_BUCKET_PREFIX "/tmp/perlnull-"
3561 #define FAKE_BIT_BUCKET_SUFFIX "XXXXXXXX"
3562 #define FAKE_BIT_BUCKET_TEMPLATE FAKE_BIT_BUCKET_PREFIX FAKE_BIT_BUCKET_SUFFIX
3563         char tmpname[sizeof(FAKE_BIT_BUCKET_TEMPLATE)] = {
3564             FAKE_BIT_BUCKET_TEMPLATE
3565         };
3566         const char * const err = "Failed to create a fake bit bucket";
3567         if (strEQ(scriptname, BIT_BUCKET)) {
3568 #ifdef HAS_MKSTEMP /* Hopefully mkstemp() is safe here. */
3569             int tmpfd = mkstemp(tmpname);
3570             if (tmpfd > -1) {
3571                 scriptname = tmpname;
3572                 close(tmpfd);
3573             } else
3574                 Perl_croak(aTHX_ err);
3575 #else
3576 #  ifdef HAS_MKTEMP
3577             scriptname = mktemp(tmpname);
3578             if (!scriptname)
3579                 Perl_croak(aTHX_ err);
3580 #  endif
3581 #endif
3582         }
3583 #endif
3584         *rsfpp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
3585 #ifdef FAKE_BIT_BUCKET
3586         if (memEQ(scriptname, FAKE_BIT_BUCKET_PREFIX,
3587                   sizeof(FAKE_BIT_BUCKET_PREFIX) - 1)
3588             && strlen(scriptname) == sizeof(tmpname) - 1) {
3589             unlink(scriptname);
3590         }
3591         scriptname = BIT_BUCKET;
3592 #endif
3593 #       if defined(HAS_FCNTL) && defined(F_SETFD)
3594             if (*rsfpp)
3595                 /* ensure close-on-exec */
3596                 fcntl(PerlIO_fileno(*rsfpp),F_SETFD,1);
3597 #       endif
3598     }
3599     if (!*rsfpp) {
3600         /* PSz 16 Sep 03  Keep neat error message */
3601         if (PL_e_script)
3602             Perl_croak(aTHX_ "Can't open "BIT_BUCKET": %s\n", Strerror(errno));
3603         else
3604             Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
3605                     CopFILE(PL_curcop), Strerror(errno));
3606     }
3607     return fdscript;
3608 }
3609
3610 /* Mention
3611  * I_SYSSTATVFS HAS_FSTATVFS
3612  * I_SYSMOUNT
3613  * I_STATFS     HAS_FSTATFS     HAS_GETFSSTAT
3614  * I_MNTENT     HAS_GETMNTENT   HAS_HASMNTOPT
3615  * here so that metaconfig picks them up. */
3616
3617
3618 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
3619 /* Don't even need this function.  */
3620 #else
3621 STATIC void
3622 S_validate_suid(pTHX_ PerlIO *rsfp)
3623 {
3624     PERL_ARGS_ASSERT_VALIDATE_SUID;
3625
3626     if (PL_euid != PL_uid || PL_egid != PL_gid) {       /* (suidperl doesn't exist, in fact) */
3627         dVAR;
3628
3629         PerlLIO_fstat(PerlIO_fileno(rsfp),&PL_statbuf); /* may be either wrapped or real suid */
3630         if ((PL_euid != PL_uid && PL_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
3631             ||
3632             (PL_egid != PL_gid && PL_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
3633            )
3634             if (!PL_do_undump)
3635                 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
3636 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
3637         /* not set-id, must be wrapped */
3638     }
3639 }
3640 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
3641
3642 STATIC void
3643 S_find_beginning(pTHX_ SV* linestr_sv, PerlIO *rsfp)
3644 {
3645     dVAR;
3646     const char *s;
3647     register const char *s2;
3648
3649     PERL_ARGS_ASSERT_FIND_BEGINNING;
3650
3651     /* skip forward in input to the real script? */
3652
3653     while (PL_doextract) {
3654         if ((s = sv_gets(linestr_sv, rsfp, 0)) == NULL)
3655             Perl_croak(aTHX_ "No Perl script found in input\n");
3656         s2 = s;
3657         if (*s == '#' && s[1] == '!' && ((s = instr(s,"perl")) || (s = instr(s2,"PERL")))) {
3658             PerlIO_ungetc(rsfp, '\n');          /* to keep line count right */
3659             PL_doextract = FALSE;
3660             while (*s && !(isSPACE (*s) || *s == '#')) s++;
3661             s2 = s;
3662             while (*s == ' ' || *s == '\t') s++;
3663             if (*s++ == '-') {
3664                 while (isDIGIT(s2[-1]) || s2[-1] == '-' || s2[-1] == '.'
3665                        || s2[-1] == '_') s2--;
3666                 if (strnEQ(s2-4,"perl",4))
3667                     while ((s = moreswitches(s)))
3668                         ;
3669             }
3670         }
3671     }
3672 }
3673
3674
3675 STATIC void
3676 S_init_ids(pTHX)
3677 {
3678     dVAR;
3679     PL_uid = PerlProc_getuid();
3680     PL_euid = PerlProc_geteuid();
3681     PL_gid = PerlProc_getgid();
3682     PL_egid = PerlProc_getegid();
3683 #ifdef VMS
3684     PL_uid |= PL_gid << 16;
3685     PL_euid |= PL_egid << 16;
3686 #endif
3687     /* Should not happen: */
3688     CHECK_MALLOC_TAINT(PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
3689     PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
3690     /* BUG */
3691     /* PSz 27 Feb 04
3692      * Should go by suidscript, not uid!=euid: why disallow
3693      * system("ls") in scripts run from setuid things?
3694      * Or, is this run before we check arguments and set suidscript?
3695      * What about SETUID_SCRIPTS_ARE_SECURE_NOW: could we use fdscript then?
3696      * (We never have suidscript, can we be sure to have fdscript?)
3697      * Or must then go by UID checks? See comments in forbid_setid also.
3698      */
3699 }
3700
3701 /* This is used very early in the lifetime of the program,
3702  * before even the options are parsed, so PL_tainting has
3703  * not been initialized properly.  */
3704 bool
3705 Perl_doing_taint(int argc, char *argv[], char *envp[])
3706 {
3707 #ifndef PERL_IMPLICIT_SYS
3708     /* If we have PERL_IMPLICIT_SYS we can't call getuid() et alia
3709      * before we have an interpreter-- and the whole point of this
3710      * function is to be called at such an early stage.  If you are on
3711      * a system with PERL_IMPLICIT_SYS but you do have a concept of
3712      * "tainted because running with altered effective ids', you'll
3713      * have to add your own checks somewhere in here.  The two most
3714      * known samples of 'implicitness' are Win32 and NetWare, neither
3715      * of which has much of concept of 'uids'. */
3716     int uid  = PerlProc_getuid();
3717     int euid = PerlProc_geteuid();
3718     int gid  = PerlProc_getgid();
3719     int egid = PerlProc_getegid();
3720     (void)envp;
3721
3722 #ifdef VMS
3723     uid  |=  gid << 16;
3724     euid |= egid << 16;
3725 #endif
3726     if (uid && (euid != uid || egid != gid))
3727         return 1;
3728 #endif /* !PERL_IMPLICIT_SYS */
3729     /* This is a really primitive check; environment gets ignored only
3730      * if -T are the first chars together; otherwise one gets
3731      *  "Too late" message. */
3732     if ( argc > 1 && argv[1][0] == '-'
3733          && (argv[1][1] == 't' || argv[1][1] == 'T') )
3734         return 1;
3735     return 0;
3736 }
3737
3738 /* Passing the flag as a single char rather than a string is a slight space
3739    optimisation.  The only message that isn't /^-.$/ is
3740    "program input from stdin", which is substituted in place of '\0', which
3741    could never be a command line flag.  */
3742 STATIC void
3743 S_forbid_setid(pTHX_ const char flag, const bool suidscript) /* g */
3744 {
3745     dVAR;
3746     char string[3] = "-x";
3747     const char *message = "program input from stdin";
3748
3749     if (flag) {
3750         string[1] = flag;
3751         message = string;
3752     }
3753
3754 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
3755     if (PL_euid != PL_uid)
3756         Perl_croak(aTHX_ "No %s allowed while running setuid", message);
3757     if (PL_egid != PL_gid)
3758         Perl_croak(aTHX_ "No %s allowed while running setgid", message);
3759 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
3760     if (suidscript)
3761         Perl_croak(aTHX_ "No %s allowed with (suid) fdscript", message);
3762 }
3763
3764 void
3765 Perl_init_debugger(pTHX)
3766 {
3767     dVAR;
3768     HV * const ostash = PL_curstash;
3769
3770     PL_curstash = PL_debstash;
3771     PL_dbargs = GvAV(gv_AVadd((gv_fetchpvs("DB::args", GV_ADDMULTI,
3772                                            SVt_PVAV))));
3773     AvREAL_off(PL_dbargs);
3774     PL_DBgv = gv_fetchpvs("DB::DB", GV_ADDMULTI, SVt_PVGV);
3775     PL_DBline = gv_fetchpvs("DB::dbline", GV_ADDMULTI, SVt_PVAV);
3776     PL_DBsub = gv_HVadd(gv_fetchpvs("DB::sub", GV_ADDMULTI, SVt_PVHV));
3777     PL_DBsingle = GvSV((gv_fetchpvs("DB::single", GV_ADDMULTI, SVt_PV)));
3778     sv_setiv(PL_DBsingle, 0);
3779     PL_DBtrace = GvSV((gv_fetchpvs("DB::trace", GV_ADDMULTI, SVt_PV)));
3780     sv_setiv(PL_DBtrace, 0);
3781     PL_DBsignal = GvSV((gv_fetchpvs("DB::signal", GV_ADDMULTI, SVt_PV)));
3782     sv_setiv(PL_DBsignal, 0);
3783     PL_curstash = ostash;
3784 }
3785
3786 #ifndef STRESS_REALLOC
3787 #define REASONABLE(size) (size)
3788 #else
3789 #define REASONABLE(size) (1) /* unreasonable */
3790 #endif
3791
3792 void
3793 Perl_init_stacks(pTHX)
3794 {
3795     dVAR;
3796     /* start with 128-item stack and 8K cxstack */
3797     PL_curstackinfo = new_stackinfo(REASONABLE(128),
3798                                  REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
3799     PL_curstackinfo->si_type = PERLSI_MAIN;
3800     PL_curstack = PL_curstackinfo->si_stack;
3801     PL_mainstack = PL_curstack;         /* remember in case we switch stacks */
3802
3803     PL_stack_base = AvARRAY(PL_curstack);
3804     PL_stack_sp = PL_stack_base;
3805     PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
3806
3807     Newx(PL_tmps_stack,REASONABLE(128),SV*);
3808     PL_tmps_floor = -1;
3809     PL_tmps_ix = -1;
3810     PL_tmps_max = REASONABLE(128);
3811
3812     Newx(PL_markstack,REASONABLE(32),I32);
3813     PL_markstack_ptr = PL_markstack;
3814     PL_markstack_max = PL_markstack + REASONABLE(32);
3815
3816     SET_MARK_OFFSET;
3817
3818     Newx(PL_scopestack,REASONABLE(32),I32);
3819     PL_scopestack_ix = 0;
3820     PL_scopestack_max = REASONABLE(32);
3821
3822     Newx(PL_savestack,REASONABLE(128),ANY);
3823     PL_savestack_ix = 0;
3824     PL_savestack_max = REASONABLE(128);
3825 }
3826
3827 #undef REASONABLE
3828
3829 STATIC void
3830 S_nuke_stacks(pTHX)
3831 {
3832     dVAR;
3833     while (PL_curstackinfo->si_next)
3834         PL_curstackinfo = PL_curstackinfo->si_next;
3835     while (PL_curstackinfo) {
3836         PERL_SI *p = PL_curstackinfo->si_prev;
3837         /* curstackinfo->si_stack got nuked by sv_free_arenas() */
3838         Safefree(PL_curstackinfo->si_cxstack);
3839         Safefree(PL_curstackinfo);
3840         PL_curstackinfo = p;
3841     }
3842     Safefree(PL_tmps_stack);
3843     Safefree(PL_markstack);
3844     Safefree(PL_scopestack);
3845     Safefree(PL_savestack);
3846 }
3847
3848
3849 STATIC void
3850 S_init_predump_symbols(pTHX)
3851 {
3852     dVAR;
3853     GV *tmpgv;
3854     IO *io;
3855
3856     sv_setpvs(get_sv("\"", GV_ADD), " ");
3857     PL_ofsgv = (GV*)SvREFCNT_inc(gv_fetchpvs(",", GV_ADD|GV_NOTQUAL, SVt_PV));
3858
3859     PL_stdingv = gv_fetchpvs("STDIN", GV_ADD|GV_NOTQUAL, SVt_PVIO);
3860     GvMULTI_on(PL_stdingv);
3861     io = GvIOp(PL_stdingv);
3862     IoTYPE(io) = IoTYPE_RDONLY;
3863     IoIFP(io) = PerlIO_stdin();
3864     tmpgv = gv_fetchpvs("stdin", GV_ADD|GV_NOTQUAL, SVt_PV);
3865     GvMULTI_on(tmpgv);
3866     GvIOp(tmpgv) = MUTABLE_IO(SvREFCNT_inc_simple(io));
3867
3868     tmpgv = gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVIO);
3869     GvMULTI_on(tmpgv);
3870     io = GvIOp(tmpgv);
3871     IoTYPE(io) = IoTYPE_WRONLY;
3872     IoOFP(io) = IoIFP(io) = PerlIO_stdout();
3873     setdefout(tmpgv);
3874     tmpgv = gv_fetchpvs("stdout", GV_ADD|GV_NOTQUAL, SVt_PV);
3875     GvMULTI_on(tmpgv);
3876     GvIOp(tmpgv) = MUTABLE_IO(SvREFCNT_inc_simple(io));
3877
3878     PL_stderrgv = gv_fetchpvs("STDERR", GV_ADD|GV_NOTQUAL, SVt_PVIO);
3879     GvMULTI_on(PL_stderrgv);
3880     io = GvIOp(PL_stderrgv);
3881     IoTYPE(io) = IoTYPE_WRONLY;
3882     IoOFP(io) = IoIFP(io) = PerlIO_stderr();
3883     tmpgv = gv_fetchpvs("stderr", GV_ADD|GV_NOTQUAL, SVt_PV);
3884     GvMULTI_on(tmpgv);
3885     GvIOp(tmpgv) = MUTABLE_IO(SvREFCNT_inc_simple(io));
3886
3887     PL_statname = newSV(0);             /* last filename we did stat on */
3888
3889     Safefree(PL_osname);
3890     PL_osname = savepv(OSNAME);
3891 }
3892
3893 void
3894 Perl_init_argv_symbols(pTHX_ register int argc, register char **argv)
3895 {
3896     dVAR;
3897
3898     PERL_ARGS_ASSERT_INIT_ARGV_SYMBOLS;
3899
3900     argc--,argv++;      /* skip name of script */
3901     if (PL_doswitches) {
3902         for (; argc > 0 && **argv == '-'; argc--,argv++) {
3903             char *s;
3904             if (!argv[0][1])
3905                 break;
3906             if (argv[0][1] == '-' && !argv[0][2]) {
3907                 argc--,argv++;
3908                 break;
3909             }
3910             if ((s = strchr(argv[0], '='))) {
3911                 const char *const start_name = argv[0] + 1;
3912                 sv_setpv(GvSV(gv_fetchpvn_flags(start_name, s - start_name,
3913                                                 TRUE, SVt_PV)), s + 1);
3914             }
3915             else
3916                 sv_setiv(GvSV(gv_fetchpv(argv[0]+1, GV_ADD, SVt_PV)),1);
3917         }
3918     }
3919     if ((PL_argvgv = gv_fetchpvs("ARGV", GV_ADD|GV_NOTQUAL, SVt_PVAV))) {
3920         GvMULTI_on(PL_argvgv);
3921         (void)gv_AVadd(PL_argvgv);
3922         av_clear(GvAVn(PL_argvgv));
3923         for (; argc > 0; argc--,argv++) {
3924             SV * const sv = newSVpv(argv[0],0);
3925             av_push(GvAVn(PL_argvgv),sv);
3926             if (!(PL_unicode & PERL_UNICODE_LOCALE_FLAG) || PL_utf8locale) {
3927                  if (PL_unicode & PERL_UNICODE_ARGV_FLAG)
3928                       SvUTF8_on(sv);
3929             }
3930             if (PL_unicode & PERL_UNICODE_WIDESYSCALLS_FLAG) /* Sarathy? */
3931                  (void)sv_utf8_decode(sv);
3932         }
3933     }
3934 }
3935
3936 STATIC void
3937 S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env)
3938 {
3939     dVAR;
3940     GV* tmpgv;
3941
3942     PERL_ARGS_ASSERT_INIT_POSTDUMP_SYMBOLS;
3943
3944     PL_toptarget = newSV_type(SVt_PVFM);
3945     sv_setpvs(PL_toptarget, "");
3946     PL_bodytarget = newSV_type(SVt_PVFM);
3947     sv_setpvs(PL_bodytarget, "");
3948     PL_formtarget = PL_bodytarget;
3949
3950     TAINT;
3951
3952     init_argv_symbols(argc,argv);
3953
3954     if ((tmpgv = gv_fetchpvs("0", GV_ADD|GV_NOTQUAL, SVt_PV))) {
3955         sv_setpv(GvSV(tmpgv),PL_origfilename);
3956     }
3957     if ((PL_envgv = gv_fetchpvs("ENV", GV_ADD|GV_NOTQUAL, SVt_PVHV))) {
3958         HV *hv;
3959         bool env_is_not_environ;
3960         GvMULTI_on(PL_envgv);
3961         hv = GvHVn(PL_envgv);
3962         hv_magic(hv, NULL, PERL_MAGIC_env);
3963 #ifndef PERL_MICRO
3964 #ifdef USE_ENVIRON_ARRAY
3965         /* Note that if the supplied env parameter is actually a copy
3966            of the global environ then it may now point to free'd memory
3967            if the environment has been modified since. To avoid this
3968            problem we treat env==NULL as meaning 'use the default'
3969         */
3970         if (!env)
3971             env = environ;
3972         env_is_not_environ = env != environ;
3973         if (env_is_not_environ
3974 #  ifdef USE_ITHREADS
3975             && PL_curinterp == aTHX
3976 #  endif
3977            )
3978         {
3979             environ[0] = NULL;
3980         }
3981         if (env) {
3982           char *s, *old_var;
3983           SV *sv;
3984           for (; *env; env++) {
3985             old_var = *env;
3986
3987             if (!(s = strchr(old_var,'=')) || s == old_var)
3988                 continue;
3989
3990 #if defined(MSDOS) && !defined(DJGPP)
3991             *s = '\0';
3992             (void)strupr(old_var);
3993             *s = '=';
3994 #endif
3995             sv = newSVpv(s+1, 0);
3996             (void)hv_store(hv, old_var, s - old_var, sv, 0);
3997             if (env_is_not_environ)
3998                 mg_set(sv);
3999           }
4000       }
4001 #endif /* USE_ENVIRON_ARRAY */
4002 #endif /* !PERL_MICRO */
4003     }
4004     TAINT_NOT;
4005     if ((tmpgv = gv_fetchpvs("$", GV_ADD|GV_NOTQUAL, SVt_PV))) {
4006         SvREADONLY_off(GvSV(tmpgv));
4007         sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
4008         SvREADONLY_on(GvSV(tmpgv));
4009     }
4010 #ifdef THREADS_HAVE_PIDS
4011     PL_ppid = (IV)getppid();
4012 #endif
4013
4014     /* touch @F array to prevent spurious warnings 20020415 MJD */
4015     if (PL_minus_a) {
4016       (void) get_av("main::F", GV_ADD | GV_ADDMULTI);
4017     }
4018 }
4019
4020 STATIC void
4021 S_init_perllib(pTHX)
4022 {
4023     dVAR;
4024 #ifndef VMS
4025     const char *perl5lib = NULL;
4026 #endif
4027     const char *s;
4028 #ifdef WIN32
4029     STRLEN len;
4030 #endif
4031
4032     if (!PL_tainting) {
4033 #ifndef VMS
4034         perl5lib = PerlEnv_getenv("PERL5LIB");
4035 /*
4036  * It isn't possible to delete an environment variable with
4037  * PERL_USE_SAFE_PUTENV set unless unsetenv() is also available, so in that
4038  * case we treat PERL5LIB as undefined if it has a zero-length value.
4039  */
4040 #if defined(PERL_USE_SAFE_PUTENV) && ! defined(HAS_UNSETENV)
4041         if (perl5lib && *perl5lib != '\0')
4042 #else
4043         if (perl5lib)
4044 #endif
4045             incpush_use_sep(perl5lib, 0, INCPUSH_ADD_SUB_DIRS);
4046         else {
4047             s = PerlEnv_getenv("PERLLIB");
4048             if (s)
4049                 incpush_use_sep(s, 0, 0);
4050         }
4051 #else /* VMS */
4052         /* Treat PERL5?LIB as a possible search list logical name -- the
4053          * "natural" VMS idiom for a Unix path string.  We allow each
4054          * element to be a set of |-separated directories for compatibility.
4055          */
4056         char buf[256];
4057         int idx = 0;
4058         if (my_trnlnm("PERL5LIB",buf,0))
4059             do {
4060                 incpush_use_sep(buf, 0, INCPUSH_ADD_SUB_DIRS);
4061             } while (my_trnlnm("PERL5LIB",buf,++idx));
4062         else {
4063             while (my_trnlnm("PERLLIB",buf,idx++))
4064                 incpush_use_sep(buf, 0, 0);
4065         }
4066 #endif /* VMS */
4067     }
4068
4069 #ifndef PERL_IS_MINIPERL
4070     /* miniperl gets just -I..., the split of $ENV{PERL5LIB}, and "." in @INC
4071        (and not the architecture specific directories from $ENV{PERL5LIB}) */
4072
4073 /* Use the ~-expanded versions of APPLLIB (undocumented),
4074     ARCHLIB PRIVLIB SITEARCH SITELIB VENDORARCH and VENDORLIB
4075 */
4076 #ifdef APPLLIB_EXP
4077     S_incpush_use_sep(aTHX_ STR_WITH_LEN(APPLLIB_EXP),
4078                       INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE);
4079 #endif
4080
4081 #ifdef SITEARCH_EXP
4082     /* sitearch is always relative to sitelib on Windows for
4083      * DLL-based path intuition to work correctly */
4084 #  if !defined(WIN32)
4085         S_incpush_use_sep(aTHX_ STR_WITH_LEN(SITEARCH_EXP),
4086                           INCPUSH_CAN_RELOCATE);
4087 #  endif
4088 #endif
4089
4090 #ifdef SITELIB_EXP
4091 #  if defined(WIN32)
4092     /* this picks up sitearch as well */
4093         s = win32_get_sitelib(PERL_FS_VERSION, &len);
4094         if (s)
4095             incpush_use_sep(s, len, INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE);
4096 #  else
4097         S_incpush_use_sep(aTHX_ STR_WITH_LEN(SITELIB_EXP), INCPUSH_CAN_RELOCATE);
4098 #  endif
4099 #endif
4100
4101 #ifdef PERL_VENDORARCH_EXP
4102     /* vendorarch is always relative to vendorlib on Windows for
4103      * DLL-based path intuition to work correctly */
4104 #  if !defined(WIN32)
4105     S_incpush_use_sep(aTHX_ STR_WITH_LEN(PERL_VENDORARCH_EXP),
4106                       INCPUSH_CAN_RELOCATE);
4107 #  endif
4108 #endif
4109
4110 #ifdef PERL_VENDORLIB_EXP
4111 #  if defined(WIN32)
4112     /* this picks up vendorarch as well */
4113         s = win32_get_vendorlib(PERL_FS_VERSION, &len);
4114         if (s)
4115             incpush_use_sep(s, len, INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE);
4116 #  else
4117         S_incpush_use_sep(aTHX_ STR_WITH_LEN(PERL_VENDORLIB_EXP),
4118                           INCPUSH_CAN_RELOCATE);
4119 #  endif
4120 #endif
4121
4122 #ifdef ARCHLIB_EXP
4123     S_incpush_use_sep(aTHX_ STR_WITH_LEN(ARCHLIB_EXP), INCPUSH_CAN_RELOCATE);
4124 #endif
4125
4126 #ifndef PRIVLIB_EXP
4127 #  define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
4128 #endif
4129
4130 #if defined(WIN32)
4131     s = win32_get_privlib(PERL_FS_VERSION, &len);
4132     if (s)
4133         incpush_use_sep(s, len, INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE);
4134 #else
4135 #  ifdef NETWARE
4136     S_incpush_use_sep(aTHX_ PRIVLIB_EXP, 0, INCPUSH_CAN_RELOCATE);
4137 #  else
4138     S_incpush_use_sep(aTHX_ STR_WITH_LEN(PRIVLIB_EXP), INCPUSH_CAN_RELOCATE);
4139 #  endif
4140 #endif
4141
4142 #ifdef PERL_OTHERLIBDIRS
4143     S_incpush_use_sep(aTHX_ STR_WITH_LEN(PERL_OTHERLIBDIRS),
4144                       INCPUSH_ADD_VERSIONED_SUB_DIRS|INCPUSH_NOT_BASEDIR
4145                       |INCPUSH_CAN_RELOCATE);
4146 #endif
4147
4148     if (!PL_tainting) {
4149 #ifndef VMS
4150 /*
4151  * It isn't possible to delete an environment variable with
4152  * PERL_USE_SAFE_PUTENV set unless unsetenv() is also available, so in that
4153  * case we treat PERL5LIB as undefined if it has a zero-length value.
4154  */
4155 #if defined(PERL_USE_SAFE_PUTENV) && ! defined(HAS_UNSETENV)
4156         if (perl5lib && *perl5lib != '\0')
4157 #else
4158         if (perl5lib)
4159 #endif
4160             incpush_use_sep(perl5lib, 0,
4161                             INCPUSH_ADD_OLD_VERS|INCPUSH_NOT_BASEDIR);
4162 #else /* VMS */
4163         /* Treat PERL5?LIB as a possible search list logical name -- the
4164          * "natural" VMS idiom for a Unix path string.  We allow each
4165          * element to be a set of |-separated directories for compatibility.
4166          */
4167         char buf[256];
4168         int idx = 0;
4169         if (my_trnlnm("PERL5LIB",buf,0))
4170             do {
4171                 incpush_use_sep(buf, 0,
4172                                 INCPUSH_ADD_OLD_VERS|INCPUSH_NOT_BASEDIR);
4173             } while (my_trnlnm("PERL5LIB",buf,++idx));
4174 #endif /* VMS */
4175     }
4176
4177 /* Use the ~-expanded versions of APPLLIB (undocumented),
4178     ARCHLIB PRIVLIB SITEARCH SITELIB VENDORARCH and VENDORLIB
4179 */
4180 #ifdef APPLLIB_EXP
4181     S_incpush_use_sep(aTHX_ STR_WITH_LEN(APPLLIB_EXP), INCPUSH_ADD_OLD_VERS
4182                       |INCPUSH_NOT_BASEDIR|INCPUSH_CAN_RELOCATE);
4183 #endif
4184
4185 #if defined(SITELIB_STEM) && defined(PERL_INC_VERSION_LIST)
4186     /* Search for version-specific dirs below here */
4187     S_incpush_use_sep(aTHX_ STR_WITH_LEN(SITELIB_STEM),
4188                       INCPUSH_ADD_OLD_VERS|INCPUSH_CAN_RELOCATE);
4189 #endif
4190
4191
4192 #if defined(PERL_VENDORLIB_STEM) && defined(PERL_INC_VERSION_LIST)
4193     /* Search for version-specific dirs below here */
4194     S_incpush_use_sep(aTHX_ STR_WITH_LEN(PERL_VENDORLIB_STEM),
4195                       INCPUSH_ADD_OLD_VERS|INCPUSH_CAN_RELOCATE);
4196 #endif
4197
4198 #ifdef PERL_OTHERLIBDIRS
4199     S_incpush_use_sep(aTHX_ STR_WITH_LEN(PERL_OTHERLIBDIRS),
4200                       INCPUSH_ADD_OLD_VERS|INCPUSH_ADD_ARCHONLY_SUB_DIRS
4201                       |INCPUSH_CAN_RELOCATE);
4202 #endif
4203 #endif /* !PERL_IS_MINIPERL */
4204
4205     if (!PL_tainting)
4206         S_incpush(aTHX_ STR_WITH_LEN("."), 0);
4207 }
4208
4209 #if defined(DOSISH) || defined(EPOC) || defined(__SYMBIAN32__)
4210 #    define PERLLIB_SEP ';'
4211 #else
4212 #  if defined(VMS)
4213 #    define PERLLIB_SEP '|'
4214 #  else
4215 #    define PERLLIB_SEP ':'
4216 #  endif
4217 #endif
4218 #ifndef PERLLIB_MANGLE
4219 #  define PERLLIB_MANGLE(s,n) (s)
4220 #endif
4221
4222 /* Push a directory onto @INC if it exists.
4223    Generate a new SV if we do this, to save needing to copy the SV we push
4224    onto @INC  */
4225 STATIC SV *
4226 S_incpush_if_exists(pTHX_ AV *const av, SV *dir, SV *const stem)
4227 {
4228     dVAR;
4229     Stat_t tmpstatbuf;
4230
4231     PERL_ARGS_ASSERT_INCPUSH_IF_EXISTS;
4232
4233     if (PerlLIO_stat(SvPVX_const(dir), &tmpstatbuf) >= 0 &&
4234         S_ISDIR(tmpstatbuf.st_mode)) {
4235         av_push(av, dir);
4236         dir = newSVsv(stem);
4237     } else {
4238         /* Truncate dir back to stem.  */
4239         SvCUR_set(dir, SvCUR(stem));
4240     }
4241     return dir;
4242 }
4243
4244 STATIC void
4245 S_incpush(pTHX_ const char *const dir, STRLEN len, U32 flags)
4246 {
4247     dVAR;
4248     const U8 using_sub_dirs
4249         = (U8)flags & (INCPUSH_ADD_VERSIONED_SUB_DIRS
4250                        |INCPUSH_ADD_ARCHONLY_SUB_DIRS|INCPUSH_ADD_OLD_VERS);
4251     const U8 add_versioned_sub_dirs
4252         = (U8)flags & INCPUSH_ADD_VERSIONED_SUB_DIRS;
4253     const U8 add_archonly_sub_dirs
4254         = (U8)flags & INCPUSH_ADD_ARCHONLY_SUB_DIRS;
4255 #ifdef PERL_INC_VERSION_LIST
4256     const U8 addoldvers  = (U8)flags & INCPUSH_ADD_OLD_VERS;
4257 #endif
4258     const U8 canrelocate = (U8)flags & INCPUSH_CAN_RELOCATE;
4259     const U8 unshift     = (U8)flags & INCPUSH_UNSHIFT;
4260     const U8 push_basedir = (flags & INCPUSH_NOT_BASEDIR) ? 0 : 1;
4261     AV *const inc = GvAVn(PL_incgv);
4262
4263     PERL_ARGS_ASSERT_INCPUSH;
4264     assert(len > 0);
4265
4266     /* Could remove this vestigial extra block, if we don't mind a lot of
4267        re-indenting diff noise.  */
4268     {
4269         SV *libdir;
4270         /* Change 20189146be79a0596543441fa369c6bf7f85103f, to fix RT#6665,
4271            arranged to unshift #! line -I onto the front of @INC. However,
4272            -I can add version and architecture specific libraries, and they
4273            need to go first. The old code assumed that it was always
4274            pushing. Hence to make it work, need to push the architecture
4275            (etc) libraries onto a temporary array, then "unshift" that onto
4276            the front of @INC.  */
4277         AV *const av = (using_sub_dirs) ? (unshift ? newAV() : inc) : NULL;
4278
4279         if (len) {
4280             /* I am not convinced that this is valid when PERLLIB_MANGLE is
4281                defined to so something (in os2/os2.c), but the code has been
4282                this way, ignoring any possible changed of length, since
4283                760ac839baf413929cd31cc32ffd6dba6b781a81 (5.003_02) so I'll leave
4284                it be.  */
4285             libdir = newSVpvn(PERLLIB_MANGLE(dir, len), len);
4286         } else {
4287             libdir = newSVpv(PERLLIB_MANGLE(dir, 0), 0);
4288         }
4289
4290         /* Do the if() outside the #ifdef to avoid warnings about an unused
4291            parameter.  */
4292         if (canrelocate) {
4293 #ifdef PERL_RELOCATABLE_INC
4294         /*
4295          * Relocatable include entries are marked with a leading .../
4296          *
4297          * The algorithm is
4298          * 0: Remove that leading ".../"
4299          * 1: Remove trailing executable name (anything after the last '/')
4300          *    from the perl path to give a perl prefix
4301          * Then
4302          * While the @INC element starts "../" and the prefix ends with a real
4303          * directory (ie not . or ..) chop that real directory off the prefix
4304          * and the leading "../" from the @INC element. ie a logical "../"
4305          * cleanup
4306          * Finally concatenate the prefix and the remainder of the @INC element
4307          * The intent is that /usr/local/bin/perl and .../../lib/perl5
4308          * generates /usr/local/lib/perl5
4309          */
4310             const char *libpath = SvPVX(libdir);
4311             STRLEN libpath_len = SvCUR(libdir);
4312             if (libpath_len >= 4 && memEQ (libpath, ".../", 4)) {
4313                 /* Game on!  */
4314                 SV * const caret_X = get_sv("\030", 0);
4315                 /* Going to use the SV just as a scratch buffer holding a C
4316                    string:  */
4317                 SV *prefix_sv;
4318                 char *prefix;
4319                 char *lastslash;
4320
4321                 /* $^X is *the* source of taint if tainting is on, hence
4322                    SvPOK() won't be true.  */
4323                 assert(caret_X);
4324                 assert(SvPOKp(caret_X));
4325                 prefix_sv = newSVpvn_flags(SvPVX(caret_X), SvCUR(caret_X),
4326                                            SvUTF8(caret_X));
4327                 /* Firstly take off the leading .../
4328                    If all else fail we'll do the paths relative to the current
4329                    directory.  */
4330                 sv_chop(libdir, libpath + 4);
4331                 /* Don't use SvPV as we're intentionally bypassing taining,
4332                    mortal copies that the mg_get of tainting creates, and
4333                    corruption that seems to come via the save stack.
4334                    I guess that the save stack isn't correctly set up yet.  */
4335                 libpath = SvPVX(libdir);
4336                 libpath_len = SvCUR(libdir);
4337
4338                 /* This would work more efficiently with memrchr, but as it's
4339                    only a GNU extension we'd need to probe for it and
4340                    implement our own. Not hard, but maybe not worth it?  */
4341
4342                 prefix = SvPVX(prefix_sv);
4343                 lastslash = strrchr(prefix, '/');
4344
4345                 /* First time in with the *lastslash = '\0' we just wipe off
4346                    the trailing /perl from (say) /usr/foo/bin/perl
4347                 */
4348                 if (lastslash) {
4349                     SV *tempsv;
4350                     while ((*lastslash = '\0'), /* Do that, come what may.  */
4351                            (libpath_len >= 3 && memEQ(libpath, "../", 3)
4352                             && (lastslash = strrchr(prefix, '/')))) {
4353                         if (lastslash[1] == '\0'
4354                             || (lastslash[1] == '.'
4355                                 && (lastslash[2] == '/' /* ends "/."  */
4356                                     || (lastslash[2] == '/'
4357                                         && lastslash[3] == '/' /* or "/.."  */
4358                                         )))) {
4359                             /* Prefix ends "/" or "/." or "/..", any of which
4360                                are fishy, so don't do any more logical cleanup.
4361                             */
4362                             break;
4363                         }
4364                         /* Remove leading "../" from path  */
4365                         libpath += 3;
4366                         libpath_len -= 3;
4367                         /* Next iteration round the loop removes the last
4368                            directory name from prefix by writing a '\0' in
4369                            the while clause.  */
4370                     }
4371                     /* prefix has been terminated with a '\0' to the correct
4372                        length. libpath points somewhere into the libdir SV.
4373                        We need to join the 2 with '/' and drop the result into
4374                        libdir.  */
4375                     tempsv = Perl_newSVpvf(aTHX_ "%s/%s", prefix, libpath);
4376                     SvREFCNT_dec(libdir);
4377                     /* And this is the new libdir.  */
4378                     libdir = tempsv;
4379                     if (PL_tainting &&
4380                         (PL_uid != PL_euid || PL_gid != PL_egid)) {
4381                         /* Need to taint reloccated paths if running set ID  */
4382                         SvTAINTED_on(libdir);
4383                     }
4384                 }
4385                 SvREFCNT_dec(prefix_sv);
4386             }
4387 #endif
4388         }
4389         /*
4390          * BEFORE pushing libdir onto @INC we may first push version- and
4391          * archname-specific sub-directories.
4392          */
4393         if (using_sub_dirs) {
4394             SV *subdir;
4395 #ifdef PERL_INC_VERSION_LIST
4396             /* Configure terminates PERL_INC_VERSION_LIST with a NULL */
4397             const char * const incverlist[] = { PERL_INC_VERSION_LIST };
4398             const char * const *incver;
4399 #endif
4400 #ifdef VMS
4401             char *unix;
4402             STRLEN len;
4403
4404
4405             if ((unix = tounixspec_ts(SvPV(libdir,len),NULL)) != NULL) {
4406                 len = strlen(unix);
4407                 while (unix[len-1] == '/') len--;  /* Cosmetic */
4408                 sv_usepvn(libdir,unix,len);
4409             }
4410             else
4411                 PerlIO_printf(Perl_error_log,
4412                               "Failed to unixify @INC element \"%s\"\n",
4413                               SvPV(libdir,len));
4414 #endif
4415
4416             subdir = newSVsv(libdir);
4417
4418             if (add_versioned_sub_dirs) {
4419                 /* .../version/archname if -d .../version/archname */
4420                 sv_catpvs(subdir, "/" PERL_FS_VERSION "/" ARCHNAME);
4421                 subdir = S_incpush_if_exists(aTHX_ av, subdir, libdir);
4422
4423                 /* .../version if -d .../version */
4424                 sv_catpvs(subdir, "/" PERL_FS_VERSION);
4425                 subdir = S_incpush_if_exists(aTHX_ av, subdir, libdir);
4426             }
4427
4428 #ifdef PERL_INC_VERSION_LIST
4429             if (addoldvers) {
4430                 for (incver = incverlist; *incver; incver++) {
4431                     /* .../xxx if -d .../xxx */
4432                     Perl_sv_catpvf(aTHX_ subdir, "/%s", *incver);
4433                     subdir = S_incpush_if_exists(aTHX_ av, subdir, libdir);
4434                 }
4435             }
4436 #endif
4437
4438             if (add_archonly_sub_dirs) {
4439                 /* .../archname if -d .../archname */
4440                 sv_catpvs(subdir, "/" ARCHNAME);
4441                 subdir = S_incpush_if_exists(aTHX_ av, subdir, libdir);
4442
4443             }
4444
4445             assert (SvREFCNT(subdir) == 1);
4446             SvREFCNT_dec(subdir);
4447         }
4448
4449         /* finally add this lib directory at the end of @INC */
4450         if (unshift) {
4451             U32 extra = av_len(av) + 1;
4452             av_unshift(inc, extra + push_basedir);
4453             if (push_basedir)
4454                 av_store(inc, extra, libdir);
4455             while (extra--) {
4456                 /* av owns a reference, av_store() expects to be donated a
4457                    reference, and av expects to be sane when it's cleared.
4458                    If I wanted to be naughty and wrong, I could peek inside the
4459                    implementation of av_clear(), realise that it uses
4460                    SvREFCNT_dec() too, so av's array could be a run of NULLs,
4461                    and so directly steal from it (with a memcpy() to inc, and
4462                    then memset() to NULL them out. But people copy code from the
4463                    core expecting it to be best practise, so let's use the API.
4464                    Although studious readers will note that I'm not checking any
4465                    return codes.  */
4466                 av_store(inc, extra, SvREFCNT_inc(*av_fetch(av, extra, FALSE)));
4467             }
4468             SvREFCNT_dec(av);
4469         }
4470         else if (push_basedir) {
4471             av_push(inc, libdir);
4472         }
4473
4474         if (!push_basedir) {
4475             assert (SvREFCNT(libdir) == 1);
4476             SvREFCNT_dec(libdir);
4477         }
4478     }
4479 }
4480
4481 STATIC void
4482 S_incpush_use_sep(pTHX_ const char *p, STRLEN len, U32 flags)
4483 {
4484     const char *s;
4485     const char *end;
4486     /* This logic has been broken out from S_incpush(). It may be possible to
4487        simplify it.  */
4488
4489     PERL_ARGS_ASSERT_INCPUSH_USE_SEP;
4490
4491     if (!len)
4492         len = strlen(p);
4493
4494     end = p + len;
4495
4496     /* Break at all separators */
4497     while ((s = (const char*)memchr(p, PERLLIB_SEP, end - p))) {
4498         if (s == p) {
4499             /* skip any consecutive separators */
4500
4501             /* Uncomment the next line for PATH semantics */
4502             /* But you'll need to write tests */
4503             /* av_push(GvAVn(PL_incgv), newSVpvs(".")); */
4504         } else {
4505             incpush(p, (STRLEN)(s - p), flags);
4506         }
4507         p = s + 1;
4508     }
4509     if (p != end)
4510         incpush(p, (STRLEN)(end - p), flags);
4511
4512 }
4513
4514 void
4515 Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
4516 {
4517     dVAR;
4518     SV *atsv;
4519     volatile const line_t oldline = PL_curcop ? CopLINE(PL_curcop) : 0;
4520     CV *cv;
4521     STRLEN len;
4522     int ret;
4523     dJMPENV;
4524
4525     PERL_ARGS_ASSERT_CALL_LIST;
4526
4527     while (av_len(paramList) >= 0) {
4528         cv = MUTABLE_CV(av_shift(paramList));
4529         if (PL_savebegin) {
4530             if (paramList == PL_beginav) {
4531                 /* save PL_beginav for compiler */
4532                 Perl_av_create_and_push(aTHX_ &PL_beginav_save, MUTABLE_SV(cv));
4533             }
4534             else if (paramList == PL_checkav) {
4535                 /* save PL_checkav for compiler */
4536                 Perl_av_create_and_push(aTHX_ &PL_checkav_save, MUTABLE_SV(cv));
4537             }
4538             else if (paramList == PL_unitcheckav) {
4539                 /* save PL_unitcheckav for compiler */
4540                 Perl_av_create_and_push(aTHX_ &PL_unitcheckav_save, MUTABLE_SV(cv));
4541             }
4542         } else {
4543             if (!PL_madskills)
4544                 SAVEFREESV(cv);
4545         }
4546         JMPENV_PUSH(ret);
4547         switch (ret) {
4548         case 0:
4549 #ifdef PERL_MAD
4550             if (PL_madskills)
4551                 PL_madskills |= 16384;
4552 #endif
4553             CALL_LIST_BODY(cv);
4554 #ifdef PERL_MAD
4555             if (PL_madskills)
4556                 PL_madskills &= ~16384;
4557 #endif
4558             atsv = ERRSV;
4559             (void)SvPV_const(atsv, len);
4560             if (len) {
4561                 PL_curcop = &PL_compiling;
4562                 CopLINE_set(PL_curcop, oldline);
4563                 if (paramList == PL_beginav)
4564                     sv_catpvs(atsv, "BEGIN failed--compilation aborted");
4565                 else
4566                     Perl_sv_catpvf(aTHX_ atsv,
4567                                    "%s failed--call queue aborted",
4568                                    paramList == PL_checkav ? "CHECK"
4569                                    : paramList == PL_initav ? "INIT"
4570                                    : paramList == PL_unitcheckav ? "UNITCHECK"
4571                                    : "END");
4572                 while (PL_scopestack_ix > oldscope)
4573                     LEAVE;
4574                 JMPENV_POP;
4575                 Perl_croak(aTHX_ "%"SVf"", SVfARG(atsv));
4576             }
4577             break;
4578         case 1:
4579             STATUS_ALL_FAILURE;
4580             /* FALL THROUGH */
4581         case 2:
4582             /* my_exit() was called */
4583             while (PL_scopestack_ix > oldscope)
4584                 LEAVE;
4585             FREETMPS;
4586             PL_curstash = PL_defstash;
4587             PL_curcop = &PL_compiling;
4588             CopLINE_set(PL_curcop, oldline);
4589             JMPENV_POP;
4590             if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED)) {
4591                 if (paramList == PL_beginav)
4592                     Perl_croak(aTHX_ "BEGIN failed--compilation aborted");
4593                 else
4594                     Perl_croak(aTHX_ "%s failed--call queue aborted",
4595                                paramList == PL_checkav ? "CHECK"
4596                                : paramList == PL_initav ? "INIT"
4597                                : paramList == PL_unitcheckav ? "UNITCHECK"
4598                                : "END");
4599             }
4600             my_exit_jump();
4601             /* NOTREACHED */
4602         case 3:
4603             if (PL_restartop) {
4604                 PL_curcop = &PL_compiling;
4605                 CopLINE_set(PL_curcop, oldline);
4606                 JMPENV_JUMP(3);
4607             }
4608             PerlIO_printf(Perl_error_log, "panic: restartop\n");
4609             FREETMPS;
4610             break;
4611         }
4612         JMPENV_POP;
4613     }
4614 }
4615
4616 void
4617 Perl_my_exit(pTHX_ U32 status)
4618 {
4619     dVAR;
4620     switch (status) {
4621     case 0:
4622         STATUS_ALL_SUCCESS;
4623         break;
4624     case 1:
4625         STATUS_ALL_FAILURE;
4626         break;
4627     default:
4628         STATUS_EXIT_SET(status);
4629         break;
4630     }
4631     my_exit_jump();
4632 }
4633
4634 void
4635 Perl_my_failure_exit(pTHX)
4636 {
4637     dVAR;
4638 #ifdef VMS
4639      /* We have been called to fall on our sword.  The desired exit code
4640       * should be already set in STATUS_UNIX, but could be shifted over
4641       * by 8 bits.  STATUS_UNIX_EXIT_SET will handle the cases where a
4642       * that code is set.
4643       *
4644       * If an error code has not been set, then force the issue.
4645       */
4646     if (MY_POSIX_EXIT) {
4647
4648         /* According to the die_exit.t tests, if errno is non-zero */
4649         /* It should be used for the error status. */
4650
4651         if (errno == EVMSERR) {
4652             STATUS_NATIVE = vaxc$errno;
4653         } else {
4654
4655             /* According to die_exit.t tests, if the child_exit code is */
4656             /* also zero, then we need to exit with a code of 255 */
4657             if ((errno != 0) && (errno < 256))
4658                 STATUS_UNIX_EXIT_SET(errno);
4659             else if (STATUS_UNIX < 255) {
4660                 STATUS_UNIX_EXIT_SET(255);
4661             }
4662
4663         }
4664
4665         /* The exit code could have been set by $? or vmsish which
4666          * means that it may not have fatal set.  So convert
4667          * success/warning codes to fatal with out changing
4668          * the POSIX status code.  The severity makes VMS native
4669          * status handling work, while UNIX mode programs use the
4670          * the POSIX exit codes.
4671          */
4672          if ((STATUS_NATIVE & (STS$K_SEVERE|STS$K_ERROR)) == 0) {
4673             STATUS_NATIVE &= STS$M_COND_ID;
4674             STATUS_NATIVE |= STS$K_ERROR | STS$M_INHIB_MSG;
4675          }
4676     }
4677     else {
4678         /* Traditionally Perl on VMS always expects a Fatal Error. */
4679         if (vaxc$errno & 1) {
4680
4681             /* So force success status to failure */
4682             if (STATUS_NATIVE & 1)
4683                 STATUS_ALL_FAILURE;
4684         }
4685         else {
4686             if (!vaxc$errno) {
4687                 STATUS_UNIX = EINTR; /* In case something cares */
4688                 STATUS_ALL_FAILURE;
4689             }
4690             else {
4691                 int severity;
4692                 STATUS_NATIVE = vaxc$errno; /* Should already be this */
4693
4694                 /* Encode the severity code */
4695                 severity = STATUS_NATIVE & STS$M_SEVERITY;
4696                 STATUS_UNIX = (severity ? severity : 1) << 8;
4697
4698                 /* Perl expects this to be a fatal error */
4699                 if (severity != STS$K_SEVERE)
4700                     STATUS_ALL_FAILURE;
4701             }
4702         }
4703     }
4704
4705 #else
4706     int exitstatus;
4707     if (errno & 255)
4708         STATUS_UNIX_SET(errno);
4709     else {
4710         exitstatus = STATUS_UNIX >> 8;
4711         if (exitstatus & 255)
4712             STATUS_UNIX_SET(exitstatus);
4713         else
4714             STATUS_UNIX_SET(255);
4715     }
4716 #endif
4717     my_exit_jump();
4718 }
4719
4720 STATIC void
4721 S_my_exit_jump(pTHX)
4722 {
4723     dVAR;
4724
4725     if (PL_e_script) {
4726         SvREFCNT_dec(PL_e_script);
4727         PL_e_script = NULL;
4728     }
4729
4730     POPSTACK_TO(PL_mainstack);
4731     dounwind(-1);
4732     LEAVE_SCOPE(0);
4733
4734     JMPENV_JUMP(2);
4735 }
4736
4737 static I32
4738 read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen)
4739 {
4740     dVAR;
4741     const char * const p  = SvPVX_const(PL_e_script);
4742     const char *nl = strchr(p, '\n');
4743
4744     PERL_UNUSED_ARG(idx);
4745     PERL_UNUSED_ARG(maxlen);
4746
4747     nl = (nl) ? nl+1 : SvEND(PL_e_script);
4748     if (nl-p == 0) {
4749         filter_del(read_e_script);
4750         return 0;
4751     }
4752     sv_catpvn(buf_sv, p, nl-p);
4753     sv_chop(PL_e_script, nl);
4754     return 1;
4755 }
4756
4757 /*
4758  * Local variables:
4759  * c-indentation-style: bsd
4760  * c-basic-offset: 4
4761  * indent-tabs-mode: t
4762  * End:
4763  *
4764  * ex: set ts=8 sts=4 sw=4 noet:
4765  */