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