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