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