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