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