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