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