Simplify VMS symlink override.
[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
1807     PERL_SET_PHASE(PERL_PHASE_START);
1808
1809     SvGROW(linestr_sv, 80);
1810     sv_setpvs(linestr_sv,"");
1811
1812     init_main_stash();
1813
1814     {
1815         const char *s;
1816     for (argc--,argv++; argc > 0; argc--,argv++) {
1817         if (argv[0][0] != '-' || !argv[0][1])
1818             break;
1819         s = argv[0]+1;
1820       reswitch:
1821         switch ((c = *s)) {
1822         case 'C':
1823 #ifndef PERL_STRICT_CR
1824         case '\r':
1825 #endif
1826         case ' ':
1827         case '0':
1828         case 'F':
1829         case 'a':
1830         case 'c':
1831         case 'd':
1832         case 'D':
1833         case 'h':
1834         case 'i':
1835         case 'l':
1836         case 'M':
1837         case 'm':
1838         case 'n':
1839         case 'p':
1840         case 's':
1841         case 'u':
1842         case 'U':
1843         case 'v':
1844         case 'W':
1845         case 'X':
1846         case 'w':
1847             if ((s = moreswitches(s)))
1848                 goto reswitch;
1849             break;
1850
1851         case 't':
1852             CHECK_MALLOC_TOO_LATE_FOR('t');
1853             if( !PL_tainting ) {
1854                  PL_taint_warn = TRUE;
1855                  PL_tainting = TRUE;
1856             }
1857             s++;
1858             goto reswitch;
1859         case 'T':
1860             CHECK_MALLOC_TOO_LATE_FOR('T');
1861             PL_tainting = TRUE;
1862             PL_taint_warn = FALSE;
1863             s++;
1864             goto reswitch;
1865
1866         case 'E':
1867             PL_minus_E = TRUE;
1868             /* FALL THROUGH */
1869         case 'e':
1870             forbid_setid('e', FALSE);
1871             if (!PL_e_script) {
1872                 PL_e_script = newSVpvs("");
1873                 add_read_e_script = TRUE;
1874             }
1875             if (*++s)
1876                 sv_catpv(PL_e_script, s);
1877             else if (argv[1]) {
1878                 sv_catpv(PL_e_script, argv[1]);
1879                 argc--,argv++;
1880             }
1881             else
1882                 Perl_croak(aTHX_ "No code specified for -%c", c);
1883             sv_catpvs(PL_e_script, "\n");
1884             break;
1885
1886         case 'f':
1887 #ifdef USE_SITECUSTOMIZE
1888             minus_f = TRUE;
1889 #endif
1890             s++;
1891             goto reswitch;
1892
1893         case 'I':       /* -I handled both here and in moreswitches() */
1894             forbid_setid('I', FALSE);
1895             if (!*++s && (s=argv[1]) != NULL) {
1896                 argc--,argv++;
1897             }
1898             if (s && *s) {
1899                 STRLEN len = strlen(s);
1900                 incpush(s, len, INCPUSH_ADD_SUB_DIRS|INCPUSH_ADD_OLD_VERS);
1901             }
1902             else
1903                 Perl_croak(aTHX_ "No directory specified for -I");
1904             break;
1905         case 'S':
1906             forbid_setid('S', FALSE);
1907             dosearch = TRUE;
1908             s++;
1909             goto reswitch;
1910         case 'V':
1911             {
1912                 SV *opts_prog;
1913
1914                 if (*++s != ':')  {
1915                     opts_prog = newSVpvs("use Config; Config::_V()");
1916                 }
1917                 else {
1918                     ++s;
1919                     opts_prog = Perl_newSVpvf(aTHX_
1920                                               "use Config; Config::config_vars(qw%c%s%c)",
1921                                               0, s, 0);
1922                     s += strlen(s);
1923                 }
1924                 Perl_av_create_and_push(aTHX_ &PL_preambleav, opts_prog);
1925                 /* don't look for script or read stdin */
1926                 scriptname = BIT_BUCKET;
1927                 goto reswitch;
1928             }
1929         case 'x':
1930             doextract = TRUE;
1931             s++;
1932             if (*s)
1933                 cddir = s;
1934             break;
1935         case 0:
1936             break;
1937         case '-':
1938             if (!*++s || isSPACE(*s)) {
1939                 argc--,argv++;
1940                 goto switch_end;
1941             }
1942             /* catch use of gnu style long options.
1943                Both of these exit immediately.  */
1944             if (strEQ(s, "version"))
1945                 minus_v();
1946             if (strEQ(s, "help"))
1947                 usage();
1948             s--;
1949             /* FALL THROUGH */
1950         default:
1951             Perl_croak(aTHX_ "Unrecognized switch: -%s  (-h will show valid options)",s);
1952         }
1953     }
1954     }
1955
1956   switch_end:
1957
1958     {
1959         char *s;
1960
1961     if (
1962 #ifndef SECURE_INTERNAL_GETENV
1963         !PL_tainting &&
1964 #endif
1965         (s = PerlEnv_getenv("PERL5OPT")))
1966     {
1967         while (isSPACE(*s))
1968             s++;
1969         if (*s == '-' && *(s+1) == 'T') {
1970             CHECK_MALLOC_TOO_LATE_FOR('T');
1971             PL_tainting = TRUE;
1972             PL_taint_warn = FALSE;
1973         }
1974         else {
1975             char *popt_copy = NULL;
1976             while (s && *s) {
1977                 const char *d;
1978                 while (isSPACE(*s))
1979                     s++;
1980                 if (*s == '-') {
1981                     s++;
1982                     if (isSPACE(*s))
1983                         continue;
1984                 }
1985                 d = s;
1986                 if (!*s)
1987                     break;
1988                 if (!strchr("CDIMUdmtwW", *s))
1989                     Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s);
1990                 while (++s && *s) {
1991                     if (isSPACE(*s)) {
1992                         if (!popt_copy) {
1993                             popt_copy = SvPVX(sv_2mortal(newSVpv(d,0)));
1994                             s = popt_copy + (s - d);
1995                             d = popt_copy;
1996                         }
1997                         *s++ = '\0';
1998                         break;
1999                     }
2000                 }
2001                 if (*d == 't') {
2002                     if( !PL_tainting ) {
2003                         PL_taint_warn = TRUE;
2004                         PL_tainting = TRUE;
2005                     }
2006                 } else {
2007                     moreswitches(d);
2008                 }
2009             }
2010         }
2011     }
2012     }
2013
2014     /* Set $^X early so that it can be used for relocatable paths in @INC  */
2015     /* and for SITELIB_EXP in USE_SITECUSTOMIZE                            */
2016     assert (!PL_tainted);
2017     TAINT;
2018     S_set_caret_X(aTHX);
2019     TAINT_NOT;
2020
2021 #if defined(USE_SITECUSTOMIZE)
2022     if (!minus_f) {
2023         /* The games with local $! are to avoid setting errno if there is no
2024            sitecustomize script.  "q%c...%c", 0, ..., 0 becomes "q\0...\0",
2025            ie a q() operator with a NUL byte as a the delimiter. This avoids
2026            problems with pathnames containing (say) '  */
2027 #  ifdef PERL_IS_MINIPERL
2028         AV *const inc = GvAV(PL_incgv);
2029         SV **const inc0 = inc ? av_fetch(inc, 0, FALSE) : NULL;
2030
2031         if (inc0) {
2032             (void)Perl_av_create_and_unshift_one(aTHX_ &PL_preambleav,
2033                                                  Perl_newSVpvf(aTHX_
2034                                                                "BEGIN { do {local $!; -f q%c%"SVf"/buildcustomize.pl%c} && do q%c%"SVf"/buildcustomize.pl%c }",
2035                                                                0, *inc0, 0,
2036                                                                0, *inc0, 0));
2037         }
2038 #  else
2039         /* SITELIB_EXP is a function call on Win32.  */
2040         const char *const raw_sitelib = SITELIB_EXP;
2041         /* process .../.. if PERL_RELOCATABLE_INC is defined */
2042         SV *sitelib_sv = mayberelocate(raw_sitelib, strlen(raw_sitelib),
2043                                        INCPUSH_CAN_RELOCATE);
2044         const char *const sitelib = SvPVX(sitelib_sv);
2045         (void)Perl_av_create_and_unshift_one(aTHX_ &PL_preambleav,
2046                                              Perl_newSVpvf(aTHX_
2047                                                            "BEGIN { do {local $!; -f q%c%s/sitecustomize.pl%c} && do q%c%s/sitecustomize.pl%c }",
2048                                                            0, sitelib, 0,
2049                                                            0, sitelib, 0));
2050         assert (SvREFCNT(sitelib_sv) == 1);
2051         SvREFCNT_dec(sitelib_sv);
2052 #  endif
2053     }
2054 #endif
2055
2056     if (!scriptname)
2057         scriptname = argv[0];
2058     if (PL_e_script) {
2059         argc++,argv--;
2060         scriptname = BIT_BUCKET;        /* don't look for script or read stdin */
2061     }
2062     else if (scriptname == NULL) {
2063 #ifdef MSDOS
2064         if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) )
2065             moreswitches("h");
2066 #endif
2067         scriptname = "-";
2068     }
2069
2070     assert (!PL_tainted);
2071     init_perllib();
2072
2073     {
2074         bool suidscript = FALSE;
2075
2076         open_script(scriptname, dosearch, &suidscript, &rsfp);
2077
2078         validate_suid(validarg, scriptname, fdscript, suidscript,
2079                       linestr_sv, rsfp);
2080
2081 #ifndef PERL_MICRO
2082 #  if defined(SIGCHLD) || defined(SIGCLD)
2083         {
2084 #  ifndef SIGCHLD
2085 #    define SIGCHLD SIGCLD
2086 #  endif
2087             Sighandler_t sigstate = rsignal_state(SIGCHLD);
2088             if (sigstate == (Sighandler_t) SIG_IGN) {
2089                 Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL),
2090                                "Can't ignore signal CHLD, forcing to default");
2091                 (void)rsignal(SIGCHLD, (Sighandler_t)SIG_DFL);
2092             }
2093         }
2094 #  endif
2095 #endif
2096
2097         if (doextract) {
2098
2099             /* This will croak if suidscript is true, as -x cannot be used with
2100                setuid scripts.  */
2101             forbid_setid('x', suidscript);
2102             /* Hence you can't get here if suidscript is true */
2103
2104             find_beginning(linestr_sv, rsfp);
2105             if (cddir && PerlDir_chdir( (char *)cddir ) < 0)
2106                 Perl_croak(aTHX_ "Can't chdir to %s",cddir);
2107         }
2108     }
2109
2110     PL_main_cv = PL_compcv = MUTABLE_CV(newSV_type(SVt_PVCV));
2111     CvUNIQUE_on(PL_compcv);
2112
2113     CvPADLIST(PL_compcv) = pad_new(0);
2114
2115     PL_isarev = newHV();
2116
2117     boot_core_PerlIO();
2118     boot_core_UNIVERSAL();
2119     boot_core_mro();
2120     newXS("Internals::V", S_Internals_V, __FILE__);
2121
2122     if (xsinit)
2123         (*xsinit)(aTHX);        /* in case linked C routines want magical variables */
2124 #ifndef PERL_MICRO
2125 #if defined(VMS) || defined(WIN32) || defined(DJGPP) || defined(__CYGWIN__) || defined(EPOC) || defined(SYMBIAN)
2126     init_os_extras();
2127 #endif
2128 #endif
2129
2130 #ifdef USE_SOCKS
2131 #   ifdef HAS_SOCKS5_INIT
2132     socks5_init(argv[0]);
2133 #   else
2134     SOCKSinit(argv[0]);
2135 #   endif
2136 #endif
2137
2138     init_predump_symbols();
2139     /* init_postdump_symbols not currently designed to be called */
2140     /* more than once (ENV isn't cleared first, for example)     */
2141     /* But running with -u leaves %ENV & @ARGV undefined!    XXX */
2142     if (!PL_do_undump)
2143         init_postdump_symbols(argc,argv,env);
2144
2145     /* PL_unicode is turned on by -C, or by $ENV{PERL_UNICODE},
2146      * or explicitly in some platforms.
2147      * locale.c:Perl_init_i18nl10n() if the environment
2148      * look like the user wants to use UTF-8. */
2149 #if defined(__SYMBIAN32__)
2150     PL_unicode = PERL_UNICODE_STD_FLAG; /* See PERL_SYMBIAN_CONSOLE_UTF8. */
2151 #endif
2152 #  ifndef PERL_IS_MINIPERL
2153     if (PL_unicode) {
2154          /* Requires init_predump_symbols(). */
2155          if (!(PL_unicode & PERL_UNICODE_LOCALE_FLAG) || PL_utf8locale) {
2156               IO* io;
2157               PerlIO* fp;
2158               SV* sv;
2159
2160               /* Turn on UTF-8-ness on STDIN, STDOUT, STDERR
2161                * and the default open disciplines. */
2162               if ((PL_unicode & PERL_UNICODE_STDIN_FLAG) &&
2163                   PL_stdingv  && (io = GvIO(PL_stdingv)) &&
2164                   (fp = IoIFP(io)))
2165                    PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
2166               if ((PL_unicode & PERL_UNICODE_STDOUT_FLAG) &&
2167                   PL_defoutgv && (io = GvIO(PL_defoutgv)) &&
2168                   (fp = IoOFP(io)))
2169                    PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
2170               if ((PL_unicode & PERL_UNICODE_STDERR_FLAG) &&
2171                   PL_stderrgv && (io = GvIO(PL_stderrgv)) &&
2172                   (fp = IoOFP(io)))
2173                    PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
2174               if ((PL_unicode & PERL_UNICODE_INOUT_FLAG) &&
2175                   (sv = GvSV(gv_fetchpvs("\017PEN", GV_ADD|GV_NOTQUAL,
2176                                          SVt_PV)))) {
2177                    U32 in  = PL_unicode & PERL_UNICODE_IN_FLAG;
2178                    U32 out = PL_unicode & PERL_UNICODE_OUT_FLAG;
2179                    if (in) {
2180                         if (out)
2181                              sv_setpvs(sv, ":utf8\0:utf8");
2182                         else
2183                              sv_setpvs(sv, ":utf8\0");
2184                    }
2185                    else if (out)
2186                         sv_setpvs(sv, "\0:utf8");
2187                    SvSETMAGIC(sv);
2188               }
2189          }
2190     }
2191 #endif
2192
2193     {
2194         const char *s;
2195     if ((s = PerlEnv_getenv("PERL_SIGNALS"))) {
2196          if (strEQ(s, "unsafe"))
2197               PL_signals |=  PERL_SIGNALS_UNSAFE_FLAG;
2198          else if (strEQ(s, "safe"))
2199               PL_signals &= ~PERL_SIGNALS_UNSAFE_FLAG;
2200          else
2201               Perl_croak(aTHX_ "PERL_SIGNALS illegal: \"%s\"", s);
2202     }
2203     }
2204
2205 #ifdef PERL_MAD
2206     {
2207         const char *s;
2208     if ((s = PerlEnv_getenv("PERL_XMLDUMP"))) {
2209         PL_madskills = 1;
2210         PL_minus_c = 1;
2211         if (!s || !s[0])
2212             PL_xmlfp = PerlIO_stdout();
2213         else {
2214             PL_xmlfp = PerlIO_open(s, "w");
2215             if (!PL_xmlfp)
2216                 Perl_croak(aTHX_ "Can't open %s", s);
2217         }
2218         my_setenv("PERL_XMLDUMP", NULL);        /* hide from subprocs */
2219     }
2220     }
2221
2222     {
2223         const char *s;
2224     if ((s = PerlEnv_getenv("PERL_MADSKILLS"))) {
2225         PL_madskills = atoi(s);
2226         my_setenv("PERL_MADSKILLS", NULL);      /* hide from subprocs */
2227     }
2228     }
2229 #endif
2230
2231     lex_start(linestr_sv, rsfp, 0);
2232     PL_subname = newSVpvs("main");
2233
2234     if (add_read_e_script)
2235         filter_add(read_e_script, NULL);
2236
2237     /* now parse the script */
2238
2239     SETERRNO(0,SS_NORMAL);
2240     if (yyparse(GRAMPROG) || PL_parser->error_count) {
2241         if (PL_minus_c)
2242             Perl_croak(aTHX_ "%s had compilation errors.\n", PL_origfilename);
2243         else {
2244             Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
2245                        PL_origfilename);
2246         }
2247     }
2248     CopLINE_set(PL_curcop, 0);
2249     SET_CURSTASH(PL_defstash);
2250     if (PL_e_script) {
2251         SvREFCNT_dec(PL_e_script);
2252         PL_e_script = NULL;
2253     }
2254
2255     if (PL_do_undump)
2256         my_unexec();
2257
2258     if (isWARN_ONCE) {
2259         SAVECOPFILE(PL_curcop);
2260         SAVECOPLINE(PL_curcop);
2261         gv_check(PL_defstash);
2262     }
2263
2264     LEAVE;
2265     FREETMPS;
2266
2267 #ifdef MYMALLOC
2268     {
2269         const char *s;
2270     if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
2271         dump_mstats("after compilation:");
2272     }
2273 #endif
2274
2275     ENTER;
2276     PL_restartjmpenv = NULL;
2277     PL_restartop = 0;
2278     return NULL;
2279 }
2280
2281 /*
2282 =for apidoc perl_run
2283
2284 Tells a Perl interpreter to run.  See L<perlembed>.
2285
2286 =cut
2287 */
2288
2289 int
2290 perl_run(pTHXx)
2291 {
2292     dVAR;
2293     I32 oldscope;
2294     int ret = 0;
2295     dJMPENV;
2296
2297     PERL_ARGS_ASSERT_PERL_RUN;
2298 #ifndef MULTIPLICITY
2299     PERL_UNUSED_ARG(my_perl);
2300 #endif
2301
2302     oldscope = PL_scopestack_ix;
2303 #ifdef VMS
2304     VMSISH_HUSHED = 0;
2305 #endif
2306
2307     JMPENV_PUSH(ret);
2308     switch (ret) {
2309     case 1:
2310         cxstack_ix = -1;                /* start context stack again */
2311         goto redo_body;
2312     case 0:                             /* normal completion */
2313  redo_body:
2314         run_body(oldscope);
2315         /* FALL THROUGH */
2316     case 2:                             /* my_exit() */
2317         while (PL_scopestack_ix > oldscope)
2318             LEAVE;
2319         FREETMPS;
2320         SET_CURSTASH(PL_defstash);
2321         if (!(PL_exit_flags & PERL_EXIT_DESTRUCT_END) &&
2322             PL_endav && !PL_minus_c) {
2323             PERL_SET_PHASE(PERL_PHASE_END);
2324             call_list(oldscope, PL_endav);
2325         }
2326 #ifdef MYMALLOC
2327         if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
2328             dump_mstats("after execution:  ");
2329 #endif
2330         ret = STATUS_EXIT;
2331         break;
2332     case 3:
2333         if (PL_restartop) {
2334             POPSTACK_TO(PL_mainstack);
2335             goto redo_body;
2336         }
2337         PerlIO_printf(Perl_error_log, "panic: restartop in perl_run\n");
2338         FREETMPS;
2339         ret = 1;
2340         break;
2341     }
2342
2343     JMPENV_POP;
2344     return ret;
2345 }
2346
2347 STATIC void
2348 S_run_body(pTHX_ I32 oldscope)
2349 {
2350     dVAR;
2351     DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
2352                     PL_sawampersand ? "Enabling" : "Omitting"));
2353
2354     if (!PL_restartop) {
2355 #ifdef PERL_MAD
2356         if (PL_xmlfp) {
2357             xmldump_all();
2358             exit(0);    /* less likely to core dump than my_exit(0) */
2359         }
2360 #endif
2361 #ifdef DEBUGGING
2362         if (DEBUG_x_TEST || DEBUG_B_TEST)
2363             dump_all_perl(!DEBUG_B_TEST);
2364         if (!DEBUG_q_TEST)
2365           PERL_DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
2366 #endif
2367
2368         if (PL_minus_c) {
2369             PerlIO_printf(Perl_error_log, "%s syntax OK\n", PL_origfilename);
2370             my_exit(0);
2371         }
2372         if (PERLDB_SINGLE && PL_DBsingle)
2373             sv_setiv(PL_DBsingle, 1);
2374         if (PL_initav) {
2375             PERL_SET_PHASE(PERL_PHASE_INIT);
2376             call_list(oldscope, PL_initav);
2377         }
2378 #ifdef PERL_DEBUG_READONLY_OPS
2379         Perl_pending_Slabs_to_ro(aTHX);
2380 #endif
2381     }
2382
2383     /* do it */
2384
2385     PERL_SET_PHASE(PERL_PHASE_RUN);
2386
2387     if (PL_restartop) {
2388         PL_restartjmpenv = NULL;
2389         PL_op = PL_restartop;
2390         PL_restartop = 0;
2391         CALLRUNOPS(aTHX);
2392     }
2393     else if (PL_main_start) {
2394         CvDEPTH(PL_main_cv) = 1;
2395         PL_op = PL_main_start;
2396         CALLRUNOPS(aTHX);
2397     }
2398     my_exit(0);
2399     /* NOTREACHED */
2400 }
2401
2402 /*
2403 =head1 SV Manipulation Functions
2404
2405 =for apidoc p||get_sv
2406
2407 Returns the SV of the specified Perl scalar.  C<flags> are passed to
2408 C<gv_fetchpv>. If C<GV_ADD> is set and the
2409 Perl variable does not exist then it will be created.  If C<flags> is zero
2410 and the variable does not exist then NULL is returned.
2411
2412 =cut
2413 */
2414
2415 SV*
2416 Perl_get_sv(pTHX_ const char *name, I32 flags)
2417 {
2418     GV *gv;
2419
2420     PERL_ARGS_ASSERT_GET_SV;
2421
2422     gv = gv_fetchpv(name, flags, SVt_PV);
2423     if (gv)
2424         return GvSV(gv);
2425     return NULL;
2426 }
2427
2428 /*
2429 =head1 Array Manipulation Functions
2430
2431 =for apidoc p||get_av
2432
2433 Returns the AV of the specified Perl global or package array with the given
2434 name (so it won't work on lexical variables).  C<flags> are passed 
2435 to C<gv_fetchpv>. If C<GV_ADD> is set and the
2436 Perl variable does not exist then it will be created.  If C<flags> is zero
2437 and the variable does not exist then NULL is returned.
2438
2439 Perl equivalent: C<@{"$name"}>.
2440
2441 =cut
2442 */
2443
2444 AV*
2445 Perl_get_av(pTHX_ const char *name, I32 flags)
2446 {
2447     GV* const gv = gv_fetchpv(name, flags, SVt_PVAV);
2448
2449     PERL_ARGS_ASSERT_GET_AV;
2450
2451     if (flags)
2452         return GvAVn(gv);
2453     if (gv)
2454         return GvAV(gv);
2455     return NULL;
2456 }
2457
2458 /*
2459 =head1 Hash Manipulation Functions
2460
2461 =for apidoc p||get_hv
2462
2463 Returns the HV of the specified Perl hash.  C<flags> are passed to
2464 C<gv_fetchpv>. If C<GV_ADD> is set and the
2465 Perl variable does not exist then it will be created.  If C<flags> is zero
2466 and the variable does not exist then NULL is returned.
2467
2468 =cut
2469 */
2470
2471 HV*
2472 Perl_get_hv(pTHX_ const char *name, I32 flags)
2473 {
2474     GV* const gv = gv_fetchpv(name, flags, SVt_PVHV);
2475
2476     PERL_ARGS_ASSERT_GET_HV;
2477
2478     if (flags)
2479         return GvHVn(gv);
2480     if (gv)
2481         return GvHV(gv);
2482     return NULL;
2483 }
2484
2485 /*
2486 =head1 CV Manipulation Functions
2487
2488 =for apidoc p||get_cvn_flags
2489
2490 Returns the CV of the specified Perl subroutine.  C<flags> are passed to
2491 C<gv_fetchpvn_flags>. If C<GV_ADD> is set and the Perl subroutine does not
2492 exist then it will be declared (which has the same effect as saying
2493 C<sub name;>).  If C<GV_ADD> is not set and the subroutine does not exist
2494 then NULL is returned.
2495
2496 =for apidoc p||get_cv
2497
2498 Uses C<strlen> to get the length of C<name>, then calls C<get_cvn_flags>.
2499
2500 =cut
2501 */
2502
2503 CV*
2504 Perl_get_cvn_flags(pTHX_ const char *name, STRLEN len, I32 flags)
2505 {
2506     GV* const gv = gv_fetchpvn_flags(name, len, flags, SVt_PVCV);
2507     /* XXX this is probably not what they think they're getting.
2508      * It has the same effect as "sub name;", i.e. just a forward
2509      * declaration! */
2510
2511     PERL_ARGS_ASSERT_GET_CVN_FLAGS;
2512
2513     if ((flags & ~GV_NOADD_MASK) && !GvCVu(gv)) {
2514         SV *const sv = newSVpvn_flags(name, len, flags & SVf_UTF8);
2515         return newSUB(start_subparse(FALSE, 0),
2516                       newSVOP(OP_CONST, 0, sv),
2517                       NULL, NULL);
2518     }
2519     if (gv)
2520         return GvCVu(gv);
2521     return NULL;
2522 }
2523
2524 /* Nothing in core calls this now, but we can't replace it with a macro and
2525    move it to mathoms.c as a macro would evaluate name twice.  */
2526 CV*
2527 Perl_get_cv(pTHX_ const char *name, I32 flags)
2528 {
2529     PERL_ARGS_ASSERT_GET_CV;
2530
2531     return get_cvn_flags(name, strlen(name), flags);
2532 }
2533
2534 /* Be sure to refetch the stack pointer after calling these routines. */
2535
2536 /*
2537
2538 =head1 Callback Functions
2539
2540 =for apidoc p||call_argv
2541
2542 Performs a callback to the specified named and package-scoped Perl subroutine 
2543 with C<argv> (a NULL-terminated array of strings) as arguments. See L<perlcall>.
2544
2545 Approximate Perl equivalent: C<&{"$sub_name"}(@$argv)>.
2546
2547 =cut
2548 */
2549
2550 I32
2551 Perl_call_argv(pTHX_ const char *sub_name, I32 flags, register char **argv)
2552
2553                         /* See G_* flags in cop.h */
2554                         /* null terminated arg list */
2555 {
2556     dVAR;
2557     dSP;
2558
2559     PERL_ARGS_ASSERT_CALL_ARGV;
2560
2561     PUSHMARK(SP);
2562     if (argv) {
2563         while (*argv) {
2564             mXPUSHs(newSVpv(*argv,0));
2565             argv++;
2566         }
2567         PUTBACK;
2568     }
2569     return call_pv(sub_name, flags);
2570 }
2571
2572 /*
2573 =for apidoc p||call_pv
2574
2575 Performs a callback to the specified Perl sub.  See L<perlcall>.
2576
2577 =cut
2578 */
2579
2580 I32
2581 Perl_call_pv(pTHX_ const char *sub_name, I32 flags)
2582                         /* name of the subroutine */
2583                         /* See G_* flags in cop.h */
2584 {
2585     PERL_ARGS_ASSERT_CALL_PV;
2586
2587     return call_sv(MUTABLE_SV(get_cv(sub_name, GV_ADD)), flags);
2588 }
2589
2590 /*
2591 =for apidoc p||call_method
2592
2593 Performs a callback to the specified Perl method.  The blessed object must
2594 be on the stack.  See L<perlcall>.
2595
2596 =cut
2597 */
2598
2599 I32
2600 Perl_call_method(pTHX_ const char *methname, I32 flags)
2601                         /* name of the subroutine */
2602                         /* See G_* flags in cop.h */
2603 {
2604     STRLEN len;
2605     PERL_ARGS_ASSERT_CALL_METHOD;
2606
2607     len = strlen(methname);
2608
2609     /* XXX: sv_2mortal(newSVpvn_share(methname, len)) can be faster */
2610     return call_sv(newSVpvn_flags(methname, len, SVs_TEMP), flags | G_METHOD);
2611 }
2612
2613 /* May be called with any of a CV, a GV, or an SV containing the name. */
2614 /*
2615 =for apidoc p||call_sv
2616
2617 Performs a callback to the Perl sub whose name is in the SV.  See
2618 L<perlcall>.
2619
2620 =cut
2621 */
2622
2623 I32
2624 Perl_call_sv(pTHX_ SV *sv, VOL I32 flags)
2625                         /* See G_* flags in cop.h */
2626 {
2627     dVAR; dSP;
2628     LOGOP myop;         /* fake syntax tree node */
2629     UNOP method_op;
2630     I32 oldmark;
2631     VOL I32 retval = 0;
2632     I32 oldscope;
2633     bool oldcatch = CATCH_GET;
2634     int ret;
2635     OP* const oldop = PL_op;
2636     dJMPENV;
2637
2638     PERL_ARGS_ASSERT_CALL_SV;
2639
2640     if (flags & G_DISCARD) {
2641         ENTER;
2642         SAVETMPS;
2643     }
2644     if (!(flags & G_WANT)) {
2645         /* Backwards compatibility - as G_SCALAR was 0, it could be omitted.
2646          */
2647         flags |= G_SCALAR;
2648     }
2649
2650     Zero(&myop, 1, LOGOP);
2651     myop.op_next = NULL;
2652     if (!(flags & G_NOARGS))
2653         myop.op_flags |= OPf_STACKED;
2654     myop.op_flags |= OP_GIMME_REVERSE(flags);
2655     SAVEOP();
2656     PL_op = (OP*)&myop;
2657
2658     EXTEND(PL_stack_sp, 1);
2659     *++PL_stack_sp = sv;
2660     oldmark = TOPMARK;
2661     oldscope = PL_scopestack_ix;
2662
2663     if (PERLDB_SUB && PL_curstash != PL_debstash
2664            /* Handle first BEGIN of -d. */
2665           && (PL_DBcv || (PL_DBcv = GvCV(PL_DBsub)))
2666            /* Try harder, since this may have been a sighandler, thus
2667             * curstash may be meaningless. */
2668           && (SvTYPE(sv) != SVt_PVCV || CvSTASH((const CV *)sv) != PL_debstash)
2669           && !(flags & G_NODEBUG))
2670         PL_op->op_private |= OPpENTERSUB_DB;
2671
2672     if (flags & G_METHOD) {
2673         Zero(&method_op, 1, UNOP);
2674         method_op.op_next = PL_op;
2675         method_op.op_ppaddr = PL_ppaddr[OP_METHOD];
2676         method_op.op_type = OP_METHOD;
2677         myop.op_ppaddr = PL_ppaddr[OP_ENTERSUB];
2678         myop.op_type = OP_ENTERSUB;
2679         PL_op = (OP*)&method_op;
2680     }
2681
2682     if (!(flags & G_EVAL)) {
2683         CATCH_SET(TRUE);
2684         CALL_BODY_SUB((OP*)&myop);
2685         retval = PL_stack_sp - (PL_stack_base + oldmark);
2686         CATCH_SET(oldcatch);
2687     }
2688     else {
2689         myop.op_other = (OP*)&myop;
2690         PL_markstack_ptr--;
2691         create_eval_scope(flags|G_FAKINGEVAL);
2692         PL_markstack_ptr++;
2693
2694         JMPENV_PUSH(ret);
2695
2696         switch (ret) {
2697         case 0:
2698  redo_body:
2699             CALL_BODY_SUB((OP*)&myop);
2700             retval = PL_stack_sp - (PL_stack_base + oldmark);
2701             if (!(flags & G_KEEPERR)) {
2702                 CLEAR_ERRSV();
2703             }
2704             break;
2705         case 1:
2706             STATUS_ALL_FAILURE;
2707             /* FALL THROUGH */
2708         case 2:
2709             /* my_exit() was called */
2710             SET_CURSTASH(PL_defstash);
2711             FREETMPS;
2712             JMPENV_POP;
2713             my_exit_jump();
2714             /* NOTREACHED */
2715         case 3:
2716             if (PL_restartop) {
2717                 PL_restartjmpenv = NULL;
2718                 PL_op = PL_restartop;
2719                 PL_restartop = 0;
2720                 goto redo_body;
2721             }
2722             PL_stack_sp = PL_stack_base + oldmark;
2723             if ((flags & G_WANT) == G_ARRAY)
2724                 retval = 0;
2725             else {
2726                 retval = 1;
2727                 *++PL_stack_sp = &PL_sv_undef;
2728             }
2729             break;
2730         }
2731
2732         if (PL_scopestack_ix > oldscope)
2733             delete_eval_scope();
2734         JMPENV_POP;
2735     }
2736
2737     if (flags & G_DISCARD) {
2738         PL_stack_sp = PL_stack_base + oldmark;
2739         retval = 0;
2740         FREETMPS;
2741         LEAVE;
2742     }
2743     PL_op = oldop;
2744     return retval;
2745 }
2746
2747 /* Eval a string. The G_EVAL flag is always assumed. */
2748
2749 /*
2750 =for apidoc p||eval_sv
2751
2752 Tells Perl to C<eval> the string in the SV. It supports the same flags
2753 as C<call_sv>, with the obvious exception of G_EVAL. See L<perlcall>.
2754
2755 =cut
2756 */
2757
2758 I32
2759 Perl_eval_sv(pTHX_ SV *sv, I32 flags)
2760
2761                         /* See G_* flags in cop.h */
2762 {
2763     dVAR;
2764     dSP;
2765     UNOP myop;          /* fake syntax tree node */
2766     VOL I32 oldmark = SP - PL_stack_base;
2767     VOL I32 retval = 0;
2768     int ret;
2769     OP* const oldop = PL_op;
2770     dJMPENV;
2771
2772     PERL_ARGS_ASSERT_EVAL_SV;
2773
2774     if (flags & G_DISCARD) {
2775         ENTER;
2776         SAVETMPS;
2777     }
2778
2779     SAVEOP();
2780     PL_op = (OP*)&myop;
2781     Zero(PL_op, 1, UNOP);
2782     EXTEND(PL_stack_sp, 1);
2783     *++PL_stack_sp = sv;
2784
2785     if (!(flags & G_NOARGS))
2786         myop.op_flags = OPf_STACKED;
2787     myop.op_next = NULL;
2788     myop.op_type = OP_ENTEREVAL;
2789     myop.op_flags |= OP_GIMME_REVERSE(flags);
2790     if (flags & G_KEEPERR)
2791         myop.op_flags |= OPf_SPECIAL;
2792
2793     /* fail now; otherwise we could fail after the JMPENV_PUSH but
2794      * before a PUSHEVAL, which corrupts the stack after a croak */
2795     TAINT_PROPER("eval_sv()");
2796
2797     JMPENV_PUSH(ret);
2798     switch (ret) {
2799     case 0:
2800  redo_body:
2801         if (PL_op == (OP*)(&myop)) {
2802             PL_op = PL_ppaddr[OP_ENTEREVAL](aTHX);
2803             if (!PL_op)
2804                 goto fail; /* failed in compilation */
2805         }
2806         CALLRUNOPS(aTHX);
2807         retval = PL_stack_sp - (PL_stack_base + oldmark);
2808         if (!(flags & G_KEEPERR)) {
2809             CLEAR_ERRSV();
2810         }
2811         break;
2812     case 1:
2813         STATUS_ALL_FAILURE;
2814         /* FALL THROUGH */
2815     case 2:
2816         /* my_exit() was called */
2817         SET_CURSTASH(PL_defstash);
2818         FREETMPS;
2819         JMPENV_POP;
2820         my_exit_jump();
2821         /* NOTREACHED */
2822     case 3:
2823         if (PL_restartop) {
2824             PL_restartjmpenv = NULL;
2825             PL_op = PL_restartop;
2826             PL_restartop = 0;
2827             goto redo_body;
2828         }
2829       fail:
2830         PL_stack_sp = PL_stack_base + oldmark;
2831         if ((flags & G_WANT) == G_ARRAY)
2832             retval = 0;
2833         else {
2834             retval = 1;
2835             *++PL_stack_sp = &PL_sv_undef;
2836         }
2837         break;
2838     }
2839
2840     JMPENV_POP;
2841     if (flags & G_DISCARD) {
2842         PL_stack_sp = PL_stack_base + oldmark;
2843         retval = 0;
2844         FREETMPS;
2845         LEAVE;
2846     }
2847     PL_op = oldop;
2848     return retval;
2849 }
2850
2851 /*
2852 =for apidoc p||eval_pv
2853
2854 Tells Perl to C<eval> the given string and return an SV* result.
2855
2856 =cut
2857 */
2858
2859 SV*
2860 Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error)
2861 {
2862     dVAR;
2863     dSP;
2864     SV* sv = newSVpv(p, 0);
2865
2866     PERL_ARGS_ASSERT_EVAL_PV;
2867
2868     eval_sv(sv, G_SCALAR);
2869     SvREFCNT_dec(sv);
2870
2871     SPAGAIN;
2872     sv = POPs;
2873     PUTBACK;
2874
2875     if (croak_on_error && SvTRUE(ERRSV)) {
2876         Perl_croak(aTHX_ "%s", SvPVx_nolen_const(ERRSV));
2877     }
2878
2879     return sv;
2880 }
2881
2882 /* Require a module. */
2883
2884 /*
2885 =head1 Embedding Functions
2886
2887 =for apidoc p||require_pv
2888
2889 Tells Perl to C<require> the file named by the string argument.  It is
2890 analogous to the Perl code C<eval "require '$file'">.  It's even
2891 implemented that way; consider using load_module instead.
2892
2893 =cut */
2894
2895 void
2896 Perl_require_pv(pTHX_ const char *pv)
2897 {
2898     dVAR;
2899     dSP;
2900     SV* sv;
2901
2902     PERL_ARGS_ASSERT_REQUIRE_PV;
2903
2904     PUSHSTACKi(PERLSI_REQUIRE);
2905     PUTBACK;
2906     sv = Perl_newSVpvf(aTHX_ "require q%c%s%c", 0, pv, 0);
2907     eval_sv(sv_2mortal(sv), G_DISCARD);
2908     SPAGAIN;
2909     POPSTACK;
2910 }
2911
2912 STATIC void
2913 S_usage(pTHX)           /* XXX move this out into a module ? */
2914 {
2915     /* This message really ought to be max 23 lines.
2916      * Removed -h because the user already knows that option. Others? */
2917
2918     /* Grouped as 6 lines per C string literal, to keep under the ANSI C 89
2919        minimum of 509 character string literals.  */
2920     static const char * const usage_msg[] = {
2921 "  -0[octal]         specify record separator (\\0, if no argument)\n"
2922 "  -a                autosplit mode with -n or -p (splits $_ into @F)\n"
2923 "  -C[number/list]   enables the listed Unicode features\n"
2924 "  -c                check syntax only (runs BEGIN and CHECK blocks)\n"
2925 "  -d[:debugger]     run program under debugger\n"
2926 "  -D[number/list]   set debugging flags (argument is a bit mask or alphabets)\n",
2927 "  -e program        one line of program (several -e's allowed, omit programfile)\n"
2928 "  -E program        like -e, but enables all optional features\n"
2929 "  -f                don't do $sitelib/sitecustomize.pl at startup\n"
2930 "  -F/pattern/       split() pattern for -a switch (//'s are optional)\n"
2931 "  -i[extension]     edit <> files in place (makes backup if extension supplied)\n"
2932 "  -Idirectory       specify @INC/#include directory (several -I's allowed)\n",
2933 "  -l[octal]         enable line ending processing, specifies line terminator\n"
2934 "  -[mM][-]module    execute \"use/no module...\" before executing program\n"
2935 "  -n                assume \"while (<>) { ... }\" loop around program\n"
2936 "  -p                assume loop like -n but print line also, like sed\n"
2937 "  -s                enable rudimentary parsing for switches after programfile\n"
2938 "  -S                look for programfile using PATH environment variable\n",
2939 "  -t                enable tainting warnings\n"
2940 "  -T                enable tainting checks\n"
2941 "  -u                dump core after parsing program\n"
2942 "  -U                allow unsafe operations\n"
2943 "  -v                print version, patchlevel and license\n"
2944 "  -V[:variable]     print configuration summary (or a single Config.pm variable)\n",
2945 "  -w                enable many useful warnings\n"
2946 "  -W                enable all warnings\n"
2947 "  -x[directory]     ignore text before #!perl line (optionally cd to directory)\n"
2948 "  -X                disable all warnings\n"
2949 "  \n"
2950 "Run 'perldoc perl' for more help with Perl.\n\n",
2951 NULL
2952 };
2953     const char * const *p = usage_msg;
2954     PerlIO *out = PerlIO_stdout();
2955
2956     PerlIO_printf(out,
2957                   "\nUsage: %s [switches] [--] [programfile] [arguments]\n",
2958                   PL_origargv[0]);
2959     while (*p)
2960         PerlIO_puts(out, *p++);
2961     my_exit(0);
2962 }
2963
2964 /* convert a string of -D options (or digits) into an int.
2965  * sets *s to point to the char after the options */
2966
2967 #ifdef DEBUGGING
2968 int
2969 Perl_get_debug_opts(pTHX_ const char **s, bool givehelp)
2970 {
2971     static const char * const usage_msgd[] = {
2972       " Debugging flag values: (see also -d)\n"
2973       "  p  Tokenizing and parsing (with v, displays parse stack)\n"
2974       "  s  Stack snapshots (with v, displays all stacks)\n"
2975       "  l  Context (loop) stack processing\n"
2976       "  t  Trace execution\n"
2977       "  o  Method and overloading resolution\n",
2978       "  c  String/numeric conversions\n"
2979       "  P  Print profiling info, source file input state\n"
2980       "  m  Memory and SV allocation\n"
2981       "  f  Format processing\n"
2982       "  r  Regular expression parsing and execution\n"
2983       "  x  Syntax tree dump\n",
2984       "  u  Tainting checks\n"
2985       "  H  Hash dump -- usurps values()\n"
2986       "  X  Scratchpad allocation\n"
2987       "  D  Cleaning up\n"
2988       "  T  Tokenising\n"
2989       "  R  Include reference counts of dumped variables (eg when using -Ds)\n",
2990       "  J  Do not s,t,P-debug (Jump over) opcodes within package DB\n"
2991       "  v  Verbose: use in conjunction with other flags\n"
2992       "  C  Copy On Write\n"
2993       "  A  Consistency checks on internal structures\n"
2994       "  q  quiet - currently only suppresses the 'EXECUTING' message\n"
2995       "  M  trace smart match resolution\n"
2996       "  B  dump suBroutine definitions, including special Blocks like BEGIN\n",
2997       NULL
2998     };
2999     int i = 0;
3000
3001     PERL_ARGS_ASSERT_GET_DEBUG_OPTS;
3002
3003     if (isALPHA(**s)) {
3004         /* if adding extra options, remember to update DEBUG_MASK */
3005         static const char debopts[] = "psltocPmfrxuUHXDSTRJvCAqMB";
3006
3007         for (; isALNUM(**s); (*s)++) {
3008             const char * const d = strchr(debopts,**s);
3009             if (d)
3010                 i |= 1 << (d - debopts);
3011             else if (ckWARN_d(WARN_DEBUGGING))
3012                 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
3013                     "invalid option -D%c, use -D'' to see choices\n", **s);
3014         }
3015     }
3016     else if (isDIGIT(**s)) {
3017         i = atoi(*s);
3018         for (; isALNUM(**s); (*s)++) ;
3019     }
3020     else if (givehelp) {
3021       const char *const *p = usage_msgd;
3022       while (*p) PerlIO_puts(PerlIO_stdout(), *p++);
3023     }
3024 #  ifdef EBCDIC
3025     if ((i & DEBUG_p_FLAG) && ckWARN_d(WARN_DEBUGGING))
3026         Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
3027                 "-Dp not implemented on this platform\n");
3028 #  endif
3029     return i;
3030 }
3031 #endif
3032
3033 /* This routine handles any switches that can be given during run */
3034
3035 const char *
3036 Perl_moreswitches(pTHX_ const char *s)
3037 {
3038     dVAR;
3039     UV rschar;
3040     const char option = *s; /* used to remember option in -m/-M code */
3041
3042     PERL_ARGS_ASSERT_MORESWITCHES;
3043
3044     switch (*s) {
3045     case '0':
3046     {
3047          I32 flags = 0;
3048          STRLEN numlen;
3049
3050          SvREFCNT_dec(PL_rs);
3051          if (s[1] == 'x' && s[2]) {
3052               const char *e = s+=2;
3053               U8 *tmps;
3054
3055               while (*e)
3056                 e++;
3057               numlen = e - s;
3058               flags = PERL_SCAN_SILENT_ILLDIGIT;
3059               rschar = (U32)grok_hex(s, &numlen, &flags, NULL);
3060               if (s + numlen < e) {
3061                    rschar = 0; /* Grandfather -0xFOO as -0 -xFOO. */
3062                    numlen = 0;
3063                    s--;
3064               }
3065               PL_rs = newSVpvs("");
3066               SvGROW(PL_rs, (STRLEN)(UNISKIP(rschar) + 1));
3067               tmps = (U8*)SvPVX(PL_rs);
3068               uvchr_to_utf8(tmps, rschar);
3069               SvCUR_set(PL_rs, UNISKIP(rschar));
3070               SvUTF8_on(PL_rs);
3071          }
3072          else {
3073               numlen = 4;
3074               rschar = (U32)grok_oct(s, &numlen, &flags, NULL);
3075               if (rschar & ~((U8)~0))
3076                    PL_rs = &PL_sv_undef;
3077               else if (!rschar && numlen >= 2)
3078                    PL_rs = newSVpvs("");
3079               else {
3080                    char ch = (char)rschar;
3081                    PL_rs = newSVpvn(&ch, 1);
3082               }
3083          }
3084          sv_setsv(get_sv("/", GV_ADD), PL_rs);
3085          return s + numlen;
3086     }
3087     case 'C':
3088         s++;
3089         PL_unicode = parse_unicode_opts( (const char **)&s );
3090         if (PL_unicode & PERL_UNICODE_UTF8CACHEASSERT_FLAG)
3091             PL_utf8cache = -1;
3092         return s;
3093     case 'F':
3094         PL_minus_F = TRUE;
3095         PL_splitstr = ++s;
3096         while (*s && !isSPACE(*s)) ++s;
3097         PL_splitstr = savepvn(PL_splitstr, s - PL_splitstr);
3098         return s;
3099     case 'a':
3100         PL_minus_a = TRUE;
3101         s++;
3102         return s;
3103     case 'c':
3104         PL_minus_c = TRUE;
3105         s++;
3106         return s;
3107     case 'd':
3108         forbid_setid('d', FALSE);
3109         s++;
3110
3111         /* -dt indicates to the debugger that threads will be used */
3112         if (*s == 't' && !isALNUM(s[1])) {
3113             ++s;
3114             my_setenv("PERL5DB_THREADED", "1");
3115         }
3116
3117         /* The following permits -d:Mod to accepts arguments following an =
3118            in the fashion that -MSome::Mod does. */
3119         if (*s == ':' || *s == '=') {
3120             const char *start;
3121             const char *end;
3122             SV *sv;
3123
3124             if (*++s == '-') {
3125                 ++s;
3126                 sv = newSVpvs("no Devel::");
3127             } else {
3128                 sv = newSVpvs("use Devel::");
3129             }
3130
3131             start = s;
3132             end = s + strlen(s);
3133
3134             /* We now allow -d:Module=Foo,Bar and -d:-Module */
3135             while(isALNUM(*s) || *s==':') ++s;
3136             if (*s != '=')
3137                 sv_catpvn(sv, start, end - start);
3138             else {
3139                 sv_catpvn(sv, start, s-start);
3140                 /* Don't use NUL as q// delimiter here, this string goes in the
3141                  * environment. */
3142                 Perl_sv_catpvf(aTHX_ sv, " split(/,/,q{%s});", ++s);
3143             }
3144             s = end;
3145             my_setenv("PERL5DB", SvPV_nolen_const(sv));
3146             SvREFCNT_dec(sv);
3147         }
3148         if (!PL_perldb) {
3149             PL_perldb = PERLDB_ALL;
3150             init_debugger();
3151         }
3152         return s;
3153     case 'D':
3154     {   
3155 #ifdef DEBUGGING
3156         forbid_setid('D', FALSE);
3157         s++;
3158         PL_debug = get_debug_opts( (const char **)&s, 1) | DEBUG_TOP_FLAG;
3159 #else /* !DEBUGGING */
3160         if (ckWARN_d(WARN_DEBUGGING))
3161             Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
3162                    "Recompile perl with -DDEBUGGING to use -D switch (did you mean -d ?)\n");
3163         for (s++; isALNUM(*s); s++) ;
3164 #endif
3165         return s;
3166     }   
3167     case 'h':
3168         usage();
3169     case 'i':
3170         Safefree(PL_inplace);
3171 #if defined(__CYGWIN__) /* do backup extension automagically */
3172         if (*(s+1) == '\0') {
3173         PL_inplace = savepvs(".bak");
3174         return s+1;
3175         }
3176 #endif /* __CYGWIN__ */
3177         {
3178             const char * const start = ++s;
3179             while (*s && !isSPACE(*s))
3180                 ++s;
3181
3182             PL_inplace = savepvn(start, s - start);
3183         }
3184         if (*s) {
3185             ++s;
3186             if (*s == '-')      /* Additional switches on #! line. */
3187                 s++;
3188         }
3189         return s;
3190     case 'I':   /* -I handled both here and in parse_body() */
3191         forbid_setid('I', FALSE);
3192         ++s;
3193         while (*s && isSPACE(*s))
3194             ++s;
3195         if (*s) {
3196             const char *e, *p;
3197             p = s;
3198             /* ignore trailing spaces (possibly followed by other switches) */
3199             do {
3200                 for (e = p; *e && !isSPACE(*e); e++) ;
3201                 p = e;
3202                 while (isSPACE(*p))
3203                     p++;
3204             } while (*p && *p != '-');
3205             incpush(s, e-s,
3206                     INCPUSH_ADD_SUB_DIRS|INCPUSH_ADD_OLD_VERS|INCPUSH_UNSHIFT);
3207             s = p;
3208             if (*s == '-')
3209                 s++;
3210         }
3211         else
3212             Perl_croak(aTHX_ "No directory specified for -I");
3213         return s;
3214     case 'l':
3215         PL_minus_l = TRUE;
3216         s++;
3217         if (PL_ors_sv) {
3218             SvREFCNT_dec(PL_ors_sv);
3219             PL_ors_sv = NULL;
3220         }
3221         if (isDIGIT(*s)) {
3222             I32 flags = 0;
3223             STRLEN numlen;
3224             PL_ors_sv = newSVpvs("\n");
3225             numlen = 3 + (*s == '0');
3226             *SvPVX(PL_ors_sv) = (char)grok_oct(s, &numlen, &flags, NULL);
3227             s += numlen;
3228         }
3229         else {
3230             if (RsPARA(PL_rs)) {
3231                 PL_ors_sv = newSVpvs("\n\n");
3232             }
3233             else {
3234                 PL_ors_sv = newSVsv(PL_rs);
3235             }
3236         }
3237         return s;
3238     case 'M':
3239         forbid_setid('M', FALSE);       /* XXX ? */
3240         /* FALL THROUGH */
3241     case 'm':
3242         forbid_setid('m', FALSE);       /* XXX ? */
3243         if (*++s) {
3244             const char *start;
3245             const char *end;
3246             SV *sv;
3247             const char *use = "use ";
3248             bool colon = FALSE;
3249             /* -M-foo == 'no foo'       */
3250             /* Leading space on " no " is deliberate, to make both
3251                possibilities the same length.  */
3252             if (*s == '-') { use = " no "; ++s; }
3253             sv = newSVpvn(use,4);
3254             start = s;
3255             /* We allow -M'Module qw(Foo Bar)'  */
3256             while(isALNUM(*s) || *s==':') {
3257                 if( *s++ == ':' ) {
3258                     if( *s == ':' ) 
3259                         s++;
3260                     else
3261                         colon = TRUE;
3262                 }
3263             }
3264             if (s == start)
3265                 Perl_croak(aTHX_ "Module name required with -%c option",
3266                                     option);
3267             if (colon) 
3268                 Perl_croak(aTHX_ "Invalid module name %.*s with -%c option: "
3269                                     "contains single ':'",
3270                                     (int)(s - start), start, option);
3271             end = s + strlen(s);
3272             if (*s != '=') {
3273                 sv_catpvn(sv, start, end - start);
3274                 if (option == 'm') {
3275                     if (*s != '\0')
3276                         Perl_croak(aTHX_ "Can't use '%c' after -mname", *s);
3277                     sv_catpvs( sv, " ()");
3278                 }
3279             } else {
3280                 sv_catpvn(sv, start, s-start);
3281                 /* Use NUL as q''-delimiter.  */
3282                 sv_catpvs(sv, " split(/,/,q\0");
3283                 ++s;
3284                 sv_catpvn(sv, s, end - s);
3285                 sv_catpvs(sv,  "\0)");
3286             }
3287             s = end;
3288             Perl_av_create_and_push(aTHX_ &PL_preambleav, sv);
3289         }
3290         else
3291             Perl_croak(aTHX_ "Missing argument to -%c", option);
3292         return s;
3293     case 'n':
3294         PL_minus_n = TRUE;
3295         s++;
3296         return s;
3297     case 'p':
3298         PL_minus_p = TRUE;
3299         s++;
3300         return s;
3301     case 's':
3302         forbid_setid('s', FALSE);
3303         PL_doswitches = TRUE;
3304         s++;
3305         return s;
3306     case 't':
3307     case 'T':
3308         if (!PL_tainting)
3309             TOO_LATE_FOR(*s);
3310         s++;
3311         return s;
3312     case 'u':
3313         PL_do_undump = TRUE;
3314         s++;
3315         return s;
3316     case 'U':
3317         PL_unsafe = TRUE;
3318         s++;
3319         return s;
3320     case 'v':
3321         minus_v();
3322     case 'w':
3323         if (! (PL_dowarn & G_WARN_ALL_MASK)) {
3324             PL_dowarn |= G_WARN_ON;
3325         }
3326         s++;
3327         return s;
3328     case 'W':
3329         PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
3330         if (!specialWARN(PL_compiling.cop_warnings))
3331             PerlMemShared_free(PL_compiling.cop_warnings);
3332         PL_compiling.cop_warnings = pWARN_ALL ;
3333         s++;
3334         return s;
3335     case 'X':
3336         PL_dowarn = G_WARN_ALL_OFF;
3337         if (!specialWARN(PL_compiling.cop_warnings))
3338             PerlMemShared_free(PL_compiling.cop_warnings);
3339         PL_compiling.cop_warnings = pWARN_NONE ;
3340         s++;
3341         return s;
3342     case '*':
3343     case ' ':
3344         while( *s == ' ' )
3345           ++s;
3346         if (s[0] == '-')        /* Additional switches on #! line. */
3347             return s+1;
3348         break;
3349     case '-':
3350     case 0:
3351 #if defined(WIN32) || !defined(PERL_STRICT_CR)
3352     case '\r':
3353 #endif
3354     case '\n':
3355     case '\t':
3356         break;
3357 #ifdef ALTERNATE_SHEBANG
3358     case 'S':                   /* OS/2 needs -S on "extproc" line. */
3359         break;
3360 #endif
3361     case 'e': case 'f': case 'x': case 'E':
3362 #ifndef ALTERNATE_SHEBANG
3363     case 'S':
3364 #endif
3365     case 'V':
3366         Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s);
3367     default:
3368         Perl_croak(aTHX_
3369             "Unrecognized switch: -%.1s  (-h will show valid options)",s
3370         );
3371     }
3372     return NULL;
3373 }
3374
3375
3376 STATIC void
3377 S_minus_v(pTHX)
3378 {
3379         if (!sv_derived_from(PL_patchlevel, "version"))
3380             upg_version(PL_patchlevel, TRUE);
3381 #if !defined(DGUX)
3382         {
3383             SV* level= vstringify(PL_patchlevel);
3384 #ifdef PERL_PATCHNUM
3385 #  ifdef PERL_GIT_UNCOMMITTED_CHANGES
3386             SV *num = newSVpvs(PERL_PATCHNUM "*");
3387 #  else
3388             SV *num = newSVpvs(PERL_PATCHNUM);
3389 #  endif
3390
3391             if (sv_len(num)>=sv_len(level) && strnEQ(SvPV_nolen(num),SvPV_nolen(level),sv_len(level))) {
3392                 SvREFCNT_dec(level);
3393                 level= num;
3394             } else {
3395                 Perl_sv_catpvf(aTHX_ level, " (%"SVf")", num);
3396                 SvREFCNT_dec(num);
3397             }
3398  #endif
3399             PerlIO_printf(PerlIO_stdout(),
3400                 "\nThis is perl "       STRINGIFY(PERL_REVISION)
3401                 ", version "            STRINGIFY(PERL_VERSION)
3402                 ", subversion "         STRINGIFY(PERL_SUBVERSION)
3403                 " (%"SVf") built for "  ARCHNAME, level
3404                 );
3405             SvREFCNT_dec(level);
3406         }
3407 #else /* DGUX */
3408 /* Adjust verbose output as in the perl that ships with the DG/UX OS from EMC */
3409         PerlIO_printf(PerlIO_stdout(),
3410                 Perl_form(aTHX_ "\nThis is perl, %"SVf"\n",
3411                     SVfARG(vstringify(PL_patchlevel))));
3412         PerlIO_printf(PerlIO_stdout(),
3413                         Perl_form(aTHX_ "        built under %s at %s %s\n",
3414                                         OSNAME, __DATE__, __TIME__));
3415         PerlIO_printf(PerlIO_stdout(),
3416                         Perl_form(aTHX_ "        OS Specific Release: %s\n",
3417                                         OSVERS));
3418 #endif /* !DGUX */
3419 #if defined(LOCAL_PATCH_COUNT)
3420         if (LOCAL_PATCH_COUNT > 0)
3421             PerlIO_printf(PerlIO_stdout(),
3422                           "\n(with %d registered patch%s, "
3423                           "see perl -V for more detail)",
3424                           LOCAL_PATCH_COUNT,
3425                           (LOCAL_PATCH_COUNT!=1) ? "es" : "");
3426 #endif
3427
3428         PerlIO_printf(PerlIO_stdout(),
3429                       "\n\nCopyright 1987-2012, Larry Wall\n");
3430 #ifdef MSDOS
3431         PerlIO_printf(PerlIO_stdout(),
3432                       "\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
3433 #endif
3434 #ifdef DJGPP
3435         PerlIO_printf(PerlIO_stdout(),
3436                       "djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n"
3437                       "djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n");
3438 #endif
3439 #ifdef OS2
3440         PerlIO_printf(PerlIO_stdout(),
3441                       "\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
3442                       "Version 5 port Copyright (c) 1994-2002, Andreas Kaiser, Ilya Zakharevich\n");
3443 #endif
3444 #ifdef atarist
3445         PerlIO_printf(PerlIO_stdout(),
3446                       "atariST series port, ++jrb  bammi@cadence.com\n");
3447 #endif
3448 #ifdef __BEOS__
3449         PerlIO_printf(PerlIO_stdout(),
3450                       "BeOS port Copyright Tom Spindler, 1997-1999\n");
3451 #endif
3452 #ifdef MPE
3453         PerlIO_printf(PerlIO_stdout(),
3454                       "MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-2003\n");
3455 #endif
3456 #ifdef OEMVS
3457         PerlIO_printf(PerlIO_stdout(),
3458                       "MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
3459 #endif
3460 #ifdef __VOS__
3461         PerlIO_printf(PerlIO_stdout(),
3462                       "Stratus VOS port by Paul.Green@stratus.com, 1997-2002\n");
3463 #endif
3464 #ifdef __OPEN_VM
3465         PerlIO_printf(PerlIO_stdout(),
3466                       "VM/ESA port by Neale Ferguson, 1998-1999\n");
3467 #endif
3468 #ifdef POSIX_BC
3469         PerlIO_printf(PerlIO_stdout(),
3470                       "BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
3471 #endif
3472 #ifdef EPOC
3473         PerlIO_printf(PerlIO_stdout(),
3474                       "EPOC port by Olaf Flebbe, 1999-2002\n");
3475 #endif
3476 #ifdef UNDER_CE
3477         PerlIO_printf(PerlIO_stdout(),"WINCE port by Rainer Keuchel, 2001-2002\n");
3478         PerlIO_printf(PerlIO_stdout(),"Built on " __DATE__ " " __TIME__ "\n\n");
3479         wce_hitreturn();
3480 #endif
3481 #ifdef __SYMBIAN32__
3482         PerlIO_printf(PerlIO_stdout(),
3483                       "Symbian port by Nokia, 2004-2005\n");
3484 #endif
3485 #ifdef BINARY_BUILD_NOTICE
3486         BINARY_BUILD_NOTICE;
3487 #endif
3488         PerlIO_printf(PerlIO_stdout(),
3489                       "\n\
3490 Perl may be copied only under the terms of either the Artistic License or the\n\
3491 GNU General Public License, which may be found in the Perl 5 source kit.\n\n\
3492 Complete documentation for Perl, including FAQ lists, should be found on\n\
3493 this system using \"man perl\" or \"perldoc perl\".  If you have access to the\n\
3494 Internet, point your browser at http://www.perl.org/, the Perl Home Page.\n\n");
3495         my_exit(0);
3496 }
3497
3498 /* compliments of Tom Christiansen */
3499
3500 /* unexec() can be found in the Gnu emacs distribution */
3501 /* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
3502
3503 void
3504 Perl_my_unexec(pTHX)
3505 {
3506     PERL_UNUSED_CONTEXT;
3507 #ifdef UNEXEC
3508     SV *    prog = newSVpv(BIN_EXP, 0);
3509     SV *    file = newSVpv(PL_origfilename, 0);
3510     int    status = 1;
3511     extern int etext;
3512
3513     sv_catpvs(prog, "/perl");
3514     sv_catpvs(file, ".perldump");
3515
3516     unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
3517     /* unexec prints msg to stderr in case of failure */
3518     PerlProc_exit(status);
3519 #else
3520 #  ifdef VMS
3521 #    include <lib$routines.h>
3522      lib$signal(SS$_DEBUG);  /* ssdef.h #included from vmsish.h */
3523 #  elif defined(WIN32) || defined(__CYGWIN__)
3524     Perl_croak(aTHX_ "dump is not supported");
3525 #  else
3526     ABORT();            /* for use with undump */
3527 #  endif
3528 #endif
3529 }
3530
3531 /* initialize curinterp */
3532 STATIC void
3533 S_init_interp(pTHX)
3534 {
3535     dVAR;
3536 #ifdef MULTIPLICITY
3537 #  define PERLVAR(prefix,var,type)
3538 #  define PERLVARA(prefix,var,n,type)
3539 #  if defined(PERL_IMPLICIT_CONTEXT)
3540 #    define PERLVARI(prefix,var,type,init)      aTHX->prefix##var = init;
3541 #    define PERLVARIC(prefix,var,type,init)     aTHX->prefix##var = init;
3542 #  else
3543 #    define PERLVARI(prefix,var,type,init)      PERL_GET_INTERP->var = init;
3544 #    define PERLVARIC(prefix,var,type,init)     PERL_GET_INTERP->var = init;
3545 #  endif
3546 #  include "intrpvar.h"
3547 #  undef PERLVAR
3548 #  undef PERLVARA
3549 #  undef PERLVARI
3550 #  undef PERLVARIC
3551 #else
3552 #  define PERLVAR(prefix,var,type)
3553 #  define PERLVARA(prefix,var,n,type)
3554 #  define PERLVARI(prefix,var,type,init)        PL_##var = init;
3555 #  define PERLVARIC(prefix,var,type,init)       PL_##var = init;
3556 #  include "intrpvar.h"
3557 #  undef PERLVAR
3558 #  undef PERLVARA
3559 #  undef PERLVARI
3560 #  undef PERLVARIC
3561 #endif
3562
3563     /* As these are inside a structure, PERLVARI isn't capable of initialising
3564        them  */
3565     PL_reg_oldcurpm = PL_reg_curpm = NULL;
3566     PL_reg_poscache = PL_reg_starttry = NULL;
3567 }
3568
3569 STATIC void
3570 S_init_main_stash(pTHX)
3571 {
3572     dVAR;
3573     GV *gv;
3574
3575     PL_curstash = PL_defstash = (HV *)SvREFCNT_inc_simple_NN(newHV());
3576     /* We know that the string "main" will be in the global shared string
3577        table, so it's a small saving to use it rather than allocate another
3578        8 bytes.  */
3579     PL_curstname = newSVpvs_share("main");
3580     gv = gv_fetchpvs("main::", GV_ADD|GV_NOTQUAL, SVt_PVHV);
3581     /* If we hadn't caused another reference to "main" to be in the shared
3582        string table above, then it would be worth reordering these two,
3583        because otherwise all we do is delete "main" from it as a consequence
3584        of the SvREFCNT_dec, only to add it again with hv_name_set */
3585     SvREFCNT_dec(GvHV(gv));
3586     hv_name_set(PL_defstash, "main", 4, 0);
3587     GvHV(gv) = MUTABLE_HV(SvREFCNT_inc_simple(PL_defstash));
3588     SvREADONLY_on(gv);
3589     PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpvs("INC", GV_ADD|GV_NOTQUAL,
3590                                              SVt_PVAV)));
3591     SvREFCNT_inc_simple_void(PL_incgv); /* Don't allow it to be freed */
3592     GvMULTI_on(PL_incgv);
3593     PL_hintgv = gv_fetchpvs("\010", GV_ADD|GV_NOTQUAL, SVt_PV); /* ^H */
3594     GvMULTI_on(PL_hintgv);
3595     PL_defgv = gv_fetchpvs("_", GV_ADD|GV_NOTQUAL, SVt_PVAV);
3596     SvREFCNT_inc_simple_void(PL_defgv);
3597     PL_errgv = gv_HVadd(gv_fetchpvs("@", GV_ADD|GV_NOTQUAL, SVt_PV));
3598     SvREFCNT_inc_simple_void(PL_errgv);
3599     GvMULTI_on(PL_errgv);
3600     PL_replgv = gv_fetchpvs("\022", GV_ADD|GV_NOTQUAL, SVt_PV); /* ^R */
3601     GvMULTI_on(PL_replgv);
3602     (void)Perl_form(aTHX_ "%240s","");  /* Preallocate temp - for immediate signals. */
3603 #ifdef PERL_DONT_CREATE_GVSV
3604     gv_SVadd(PL_errgv);
3605 #endif
3606     sv_grow(ERRSV, 240);        /* Preallocate - for immediate signals. */
3607     CLEAR_ERRSV();
3608     SET_CURSTASH(PL_defstash);
3609     CopSTASH_set(&PL_compiling, PL_defstash);
3610     PL_debstash = GvHV(gv_fetchpvs("DB::", GV_ADDMULTI, SVt_PVHV));
3611     PL_globalstash = GvHV(gv_fetchpvs("CORE::GLOBAL::", GV_ADDMULTI,
3612                                       SVt_PVHV));
3613     /* We must init $/ before switches are processed. */
3614     sv_setpvs(get_sv("/", GV_ADD), "\n");
3615 }
3616
3617 STATIC int
3618 S_open_script(pTHX_ const char *scriptname, bool dosearch,
3619               bool *suidscript, PerlIO **rsfpp)
3620 {
3621     int fdscript = -1;
3622     dVAR;
3623
3624     PERL_ARGS_ASSERT_OPEN_SCRIPT;
3625
3626     if (PL_e_script) {
3627         PL_origfilename = savepvs("-e");
3628     }
3629     else {
3630         /* if find_script() returns, it returns a malloc()-ed value */
3631         scriptname = PL_origfilename = find_script(scriptname, dosearch, NULL, 1);
3632
3633         if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
3634             const char *s = scriptname + 8;
3635             fdscript = atoi(s);
3636             while (isDIGIT(*s))
3637                 s++;
3638             if (*s) {
3639                 /* PSz 18 Feb 04
3640                  * Tell apart "normal" usage of fdscript, e.g.
3641                  * with bash on FreeBSD:
3642                  *   perl <( echo '#!perl -DA'; echo 'print "$0\n"')
3643                  * from usage in suidperl.
3644                  * Does any "normal" usage leave garbage after the number???
3645                  * Is it a mistake to use a similar /dev/fd/ construct for
3646                  * suidperl?
3647                  */
3648                 *suidscript = TRUE;
3649                 /* PSz 20 Feb 04  
3650                  * Be supersafe and do some sanity-checks.
3651                  * Still, can we be sure we got the right thing?
3652                  */
3653                 if (*s != '/') {
3654                     Perl_croak(aTHX_ "Wrong syntax (suid) fd script name \"%s\"\n", s);
3655                 }
3656                 if (! *(s+1)) {
3657                     Perl_croak(aTHX_ "Missing (suid) fd script name\n");
3658                 }
3659                 scriptname = savepv(s + 1);
3660                 Safefree(PL_origfilename);
3661                 PL_origfilename = (char *)scriptname;
3662             }
3663         }
3664     }
3665
3666     CopFILE_free(PL_curcop);
3667     CopFILE_set(PL_curcop, PL_origfilename);
3668     if (*PL_origfilename == '-' && PL_origfilename[1] == '\0')
3669         scriptname = (char *)"";
3670     if (fdscript >= 0) {
3671         *rsfpp = PerlIO_fdopen(fdscript,PERL_SCRIPT_MODE);
3672 #       if defined(HAS_FCNTL) && defined(F_SETFD)
3673             if (*rsfpp)
3674                 /* ensure close-on-exec */
3675                 fcntl(PerlIO_fileno(*rsfpp),F_SETFD,1);
3676 #       endif
3677     }
3678     else if (!*scriptname) {
3679         forbid_setid(0, *suidscript);
3680         *rsfpp = PerlIO_stdin();
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         *rsfpp = 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 #       if defined(HAS_FCNTL) && defined(F_SETFD)
3725             if (*rsfpp)
3726                 /* ensure close-on-exec */
3727                 fcntl(PerlIO_fileno(*rsfpp),F_SETFD,1);
3728 #       endif
3729     }
3730     if (!*rsfpp) {
3731         /* PSz 16 Sep 03  Keep neat error message */
3732         if (PL_e_script)
3733             Perl_croak(aTHX_ "Can't open "BIT_BUCKET": %s\n", Strerror(errno));
3734         else
3735             Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
3736                     CopFILE(PL_curcop), Strerror(errno));
3737     }
3738     return fdscript;
3739 }
3740
3741 /* Mention
3742  * I_SYSSTATVFS HAS_FSTATVFS
3743  * I_SYSMOUNT
3744  * I_STATFS     HAS_FSTATFS     HAS_GETFSSTAT
3745  * I_MNTENT     HAS_GETMNTENT   HAS_HASMNTOPT
3746  * here so that metaconfig picks them up. */
3747
3748
3749 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
3750 /* Don't even need this function.  */
3751 #else
3752 STATIC void
3753 S_validate_suid(pTHX_ PerlIO *rsfp)
3754 {
3755     PERL_ARGS_ASSERT_VALIDATE_SUID;
3756
3757     if (PL_euid != PL_uid || PL_egid != PL_gid) {       /* (suidperl doesn't exist, in fact) */
3758         dVAR;
3759
3760         PerlLIO_fstat(PerlIO_fileno(rsfp),&PL_statbuf); /* may be either wrapped or real suid */
3761         if ((PL_euid != PL_uid && PL_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
3762             ||
3763             (PL_egid != PL_gid && PL_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
3764            )
3765             if (!PL_do_undump)
3766                 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
3767 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
3768         /* not set-id, must be wrapped */
3769     }
3770 }
3771 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
3772
3773 STATIC void
3774 S_find_beginning(pTHX_ SV* linestr_sv, PerlIO *rsfp)
3775 {
3776     dVAR;
3777     const char *s;
3778     register const char *s2;
3779
3780     PERL_ARGS_ASSERT_FIND_BEGINNING;
3781
3782     /* skip forward in input to the real script? */
3783
3784     do {
3785         if ((s = sv_gets(linestr_sv, rsfp, 0)) == NULL)
3786             Perl_croak(aTHX_ "No Perl script found in input\n");
3787         s2 = s;
3788     } while (!(*s == '#' && s[1] == '!' && ((s = instr(s,"perl")) || (s = instr(s2,"PERL")))));
3789     PerlIO_ungetc(rsfp, '\n');          /* to keep line count right */
3790     while (*s && !(isSPACE (*s) || *s == '#')) s++;
3791     s2 = s;
3792     while (*s == ' ' || *s == '\t') s++;
3793     if (*s++ == '-') {
3794         while (isDIGIT(s2[-1]) || s2[-1] == '-' || s2[-1] == '.'
3795                || s2[-1] == '_') s2--;
3796         if (strnEQ(s2-4,"perl",4))
3797             while ((s = moreswitches(s)))
3798                 ;
3799     }
3800 }
3801
3802
3803 STATIC void
3804 S_init_ids(pTHX)
3805 {
3806     dVAR;
3807     PL_uid = PerlProc_getuid();
3808     PL_euid = PerlProc_geteuid();
3809     PL_gid = PerlProc_getgid();
3810     PL_egid = PerlProc_getegid();
3811 #ifdef VMS
3812     PL_uid |= PL_gid << 16;
3813     PL_euid |= PL_egid << 16;
3814 #endif
3815     /* Should not happen: */
3816     CHECK_MALLOC_TAINT(PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
3817     PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
3818     /* BUG */
3819     /* PSz 27 Feb 04
3820      * Should go by suidscript, not uid!=euid: why disallow
3821      * system("ls") in scripts run from setuid things?
3822      * Or, is this run before we check arguments and set suidscript?
3823      * What about SETUID_SCRIPTS_ARE_SECURE_NOW: could we use fdscript then?
3824      * (We never have suidscript, can we be sure to have fdscript?)
3825      * Or must then go by UID checks? See comments in forbid_setid also.
3826      */
3827 }
3828
3829 /* This is used very early in the lifetime of the program,
3830  * before even the options are parsed, so PL_tainting has
3831  * not been initialized properly.  */
3832 bool
3833 Perl_doing_taint(int argc, char *argv[], char *envp[])
3834 {
3835 #ifndef PERL_IMPLICIT_SYS
3836     /* If we have PERL_IMPLICIT_SYS we can't call getuid() et alia
3837      * before we have an interpreter-- and the whole point of this
3838      * function is to be called at such an early stage.  If you are on
3839      * a system with PERL_IMPLICIT_SYS but you do have a concept of
3840      * "tainted because running with altered effective ids', you'll
3841      * have to add your own checks somewhere in here.  The two most
3842      * known samples of 'implicitness' are Win32 and NetWare, neither
3843      * of which has much of concept of 'uids'. */
3844     int uid  = PerlProc_getuid();
3845     int euid = PerlProc_geteuid();
3846     int gid  = PerlProc_getgid();
3847     int egid = PerlProc_getegid();
3848     (void)envp;
3849
3850 #ifdef VMS
3851     uid  |=  gid << 16;
3852     euid |= egid << 16;
3853 #endif
3854     if (uid && (euid != uid || egid != gid))
3855         return 1;
3856 #endif /* !PERL_IMPLICIT_SYS */
3857     /* This is a really primitive check; environment gets ignored only
3858      * if -T are the first chars together; otherwise one gets
3859      *  "Too late" message. */
3860     if ( argc > 1 && argv[1][0] == '-'
3861          && (argv[1][1] == 't' || argv[1][1] == 'T') )
3862         return 1;
3863     return 0;
3864 }
3865
3866 /* Passing the flag as a single char rather than a string is a slight space
3867    optimisation.  The only message that isn't /^-.$/ is
3868    "program input from stdin", which is substituted in place of '\0', which
3869    could never be a command line flag.  */
3870 STATIC void
3871 S_forbid_setid(pTHX_ const char flag, const bool suidscript) /* g */
3872 {
3873     dVAR;
3874     char string[3] = "-x";
3875     const char *message = "program input from stdin";
3876
3877     if (flag) {
3878         string[1] = flag;
3879         message = string;
3880     }
3881
3882 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
3883     if (PL_euid != PL_uid)
3884         Perl_croak(aTHX_ "No %s allowed while running setuid", message);
3885     if (PL_egid != PL_gid)
3886         Perl_croak(aTHX_ "No %s allowed while running setgid", message);
3887 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
3888     if (suidscript)
3889         Perl_croak(aTHX_ "No %s allowed with (suid) fdscript", message);
3890 }
3891
3892 void
3893 Perl_init_dbargs(pTHX)
3894 {
3895     AV *const args = PL_dbargs = GvAV(gv_AVadd((gv_fetchpvs("DB::args",
3896                                                             GV_ADDMULTI,
3897                                                             SVt_PVAV))));
3898
3899     if (AvREAL(args)) {
3900         /* Someone has already created it.
3901            It might have entries, and if we just turn off AvREAL(), they will
3902            "leak" until global destruction.  */
3903         av_clear(args);
3904         if (SvTIED_mg((const SV *)args, PERL_MAGIC_tied))
3905             Perl_croak(aTHX_ "Cannot set tied @DB::args");
3906     }
3907     AvREIFY_only(PL_dbargs);
3908 }
3909
3910 void
3911 Perl_init_debugger(pTHX)
3912 {
3913     dVAR;
3914     HV * const ostash = PL_curstash;
3915
3916     PL_curstash = (HV *)SvREFCNT_inc_simple(PL_debstash);
3917
3918     Perl_init_dbargs(aTHX);
3919     PL_DBgv = gv_fetchpvs("DB::DB", GV_ADDMULTI, SVt_PVGV);
3920     PL_DBline = gv_fetchpvs("DB::dbline", GV_ADDMULTI, SVt_PVAV);
3921     PL_DBsub = gv_HVadd(gv_fetchpvs("DB::sub", GV_ADDMULTI, SVt_PVHV));
3922     PL_DBsingle = GvSV((gv_fetchpvs("DB::single", GV_ADDMULTI, SVt_PV)));
3923     if (!SvIOK(PL_DBsingle))
3924         sv_setiv(PL_DBsingle, 0);
3925     PL_DBtrace = GvSV((gv_fetchpvs("DB::trace", GV_ADDMULTI, SVt_PV)));
3926     if (!SvIOK(PL_DBtrace))
3927         sv_setiv(PL_DBtrace, 0);
3928     PL_DBsignal = GvSV((gv_fetchpvs("DB::signal", GV_ADDMULTI, SVt_PV)));
3929     if (!SvIOK(PL_DBsignal))
3930         sv_setiv(PL_DBsignal, 0);
3931     SvREFCNT_dec(PL_curstash);
3932     PL_curstash = ostash;
3933 }
3934
3935 #ifndef STRESS_REALLOC
3936 #define REASONABLE(size) (size)
3937 #else
3938 #define REASONABLE(size) (1) /* unreasonable */
3939 #endif
3940
3941 void
3942 Perl_init_stacks(pTHX)
3943 {
3944     dVAR;
3945     /* start with 128-item stack and 8K cxstack */
3946     PL_curstackinfo = new_stackinfo(REASONABLE(128),
3947                                  REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
3948     PL_curstackinfo->si_type = PERLSI_MAIN;
3949     PL_curstack = PL_curstackinfo->si_stack;
3950     PL_mainstack = PL_curstack;         /* remember in case we switch stacks */
3951
3952     PL_stack_base = AvARRAY(PL_curstack);
3953     PL_stack_sp = PL_stack_base;
3954     PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
3955
3956     Newx(PL_tmps_stack,REASONABLE(128),SV*);
3957     PL_tmps_floor = -1;
3958     PL_tmps_ix = -1;
3959     PL_tmps_max = REASONABLE(128);
3960
3961     Newx(PL_markstack,REASONABLE(32),I32);
3962     PL_markstack_ptr = PL_markstack;
3963     PL_markstack_max = PL_markstack + REASONABLE(32);
3964
3965     SET_MARK_OFFSET;
3966
3967     Newx(PL_scopestack,REASONABLE(32),I32);
3968 #ifdef DEBUGGING
3969     Newx(PL_scopestack_name,REASONABLE(32),const char*);
3970 #endif
3971     PL_scopestack_ix = 0;
3972     PL_scopestack_max = REASONABLE(32);
3973
3974     Newx(PL_savestack,REASONABLE(128),ANY);
3975     PL_savestack_ix = 0;
3976     PL_savestack_max = REASONABLE(128);
3977 }
3978
3979 #undef REASONABLE
3980
3981 STATIC void
3982 S_nuke_stacks(pTHX)
3983 {
3984     dVAR;
3985     while (PL_curstackinfo->si_next)
3986         PL_curstackinfo = PL_curstackinfo->si_next;
3987     while (PL_curstackinfo) {
3988         PERL_SI *p = PL_curstackinfo->si_prev;
3989         /* curstackinfo->si_stack got nuked by sv_free_arenas() */
3990         Safefree(PL_curstackinfo->si_cxstack);
3991         Safefree(PL_curstackinfo);
3992         PL_curstackinfo = p;
3993     }
3994     Safefree(PL_tmps_stack);
3995     Safefree(PL_markstack);
3996     Safefree(PL_scopestack);
3997 #ifdef DEBUGGING
3998     Safefree(PL_scopestack_name);
3999 #endif
4000     Safefree(PL_savestack);
4001 }
4002
4003 void
4004 Perl_populate_isa(pTHX_ const char *name, STRLEN len, ...)
4005 {
4006     GV *const gv = gv_fetchpvn(name, len, GV_ADD | GV_ADDMULTI, SVt_PVAV);
4007     AV *const isa = GvAVn(gv);
4008     va_list args;
4009
4010     PERL_ARGS_ASSERT_POPULATE_ISA;
4011
4012     if(AvFILLp(isa) != -1)
4013         return;
4014
4015     /* NOTE: No support for tied ISA */
4016
4017     va_start(args, len);
4018     do {
4019         const char *const parent = va_arg(args, const char*);
4020         size_t parent_len;
4021
4022         if (!parent)
4023             break;
4024         parent_len = va_arg(args, size_t);
4025
4026         /* Arguments are supplied with a trailing ::  */
4027         assert(parent_len > 2);
4028         assert(parent[parent_len - 1] == ':');
4029         assert(parent[parent_len - 2] == ':');
4030         av_push(isa, newSVpvn(parent, parent_len - 2));
4031         (void) gv_fetchpvn(parent, parent_len, GV_ADD, SVt_PVGV);
4032     } while (1);
4033     va_end(args);
4034 }
4035
4036
4037 STATIC void
4038 S_init_predump_symbols(pTHX)
4039 {
4040     dVAR;
4041     GV *tmpgv;
4042     IO *io;
4043
4044     sv_setpvs(get_sv("\"", GV_ADD), " ");
4045     PL_ofsgv = (GV*)SvREFCNT_inc(gv_fetchpvs(",", GV_ADD|GV_NOTQUAL, SVt_PV));
4046
4047
4048     /* Historically, PVIOs were blessed into IO::Handle, unless
4049        FileHandle was loaded, in which case they were blessed into
4050        that. Action at a distance.
4051        However, if we simply bless into IO::Handle, we break code
4052        that assumes that PVIOs will have (among others) a seek
4053        method. IO::File inherits from IO::Handle and IO::Seekable,
4054        and provides the needed methods. But if we simply bless into
4055        it, then we break code that assumed that by loading
4056        IO::Handle, *it* would work.
4057        So a compromise is to set up the correct @IO::File::ISA,
4058        so that code that does C<use IO::Handle>; will still work.
4059     */
4060                    
4061     Perl_populate_isa(aTHX_ STR_WITH_LEN("IO::File::ISA"),
4062                       STR_WITH_LEN("IO::Handle::"),
4063                       STR_WITH_LEN("IO::Seekable::"),
4064                       STR_WITH_LEN("Exporter::"),
4065                       NULL);
4066
4067     PL_stdingv = gv_fetchpvs("STDIN", GV_ADD|GV_NOTQUAL, SVt_PVIO);
4068     GvMULTI_on(PL_stdingv);
4069     io = GvIOp(PL_stdingv);
4070     IoTYPE(io) = IoTYPE_RDONLY;
4071     IoIFP(io) = PerlIO_stdin();
4072     tmpgv = gv_fetchpvs("stdin", GV_ADD|GV_NOTQUAL, SVt_PV);
4073     GvMULTI_on(tmpgv);
4074     GvIOp(tmpgv) = MUTABLE_IO(SvREFCNT_inc_simple(io));
4075
4076     tmpgv = gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVIO);
4077     GvMULTI_on(tmpgv);
4078     io = GvIOp(tmpgv);
4079     IoTYPE(io) = IoTYPE_WRONLY;
4080     IoOFP(io) = IoIFP(io) = PerlIO_stdout();
4081     setdefout(tmpgv);
4082     tmpgv = gv_fetchpvs("stdout", GV_ADD|GV_NOTQUAL, SVt_PV);
4083     GvMULTI_on(tmpgv);
4084     GvIOp(tmpgv) = MUTABLE_IO(SvREFCNT_inc_simple(io));
4085
4086     PL_stderrgv = gv_fetchpvs("STDERR", GV_ADD|GV_NOTQUAL, SVt_PVIO);
4087     GvMULTI_on(PL_stderrgv);
4088     io = GvIOp(PL_stderrgv);
4089     IoTYPE(io) = IoTYPE_WRONLY;
4090     IoOFP(io) = IoIFP(io) = PerlIO_stderr();
4091     tmpgv = gv_fetchpvs("stderr", GV_ADD|GV_NOTQUAL, SVt_PV);
4092     GvMULTI_on(tmpgv);
4093     GvIOp(tmpgv) = MUTABLE_IO(SvREFCNT_inc_simple(io));
4094
4095     PL_statname = newSVpvs("");         /* last filename we did stat on */
4096 }
4097
4098 void
4099 Perl_init_argv_symbols(pTHX_ register int argc, register char **argv)
4100 {
4101     dVAR;
4102
4103     PERL_ARGS_ASSERT_INIT_ARGV_SYMBOLS;
4104
4105     argc--,argv++;      /* skip name of script */
4106     if (PL_doswitches) {
4107         for (; argc > 0 && **argv == '-'; argc--,argv++) {
4108             char *s;
4109             if (!argv[0][1])
4110                 break;
4111             if (argv[0][1] == '-' && !argv[0][2]) {
4112                 argc--,argv++;
4113                 break;
4114             }
4115             if ((s = strchr(argv[0], '='))) {
4116                 const char *const start_name = argv[0] + 1;
4117                 sv_setpv(GvSV(gv_fetchpvn_flags(start_name, s - start_name,
4118                                                 TRUE, SVt_PV)), s + 1);
4119             }
4120             else
4121                 sv_setiv(GvSV(gv_fetchpv(argv[0]+1, GV_ADD, SVt_PV)),1);
4122         }
4123     }
4124     if ((PL_argvgv = gv_fetchpvs("ARGV", GV_ADD|GV_NOTQUAL, SVt_PVAV))) {
4125         GvMULTI_on(PL_argvgv);
4126         (void)gv_AVadd(PL_argvgv);
4127         av_clear(GvAVn(PL_argvgv));
4128         for (; argc > 0; argc--,argv++) {
4129             SV * const sv = newSVpv(argv[0],0);
4130             av_push(GvAVn(PL_argvgv),sv);
4131             if (!(PL_unicode & PERL_UNICODE_LOCALE_FLAG) || PL_utf8locale) {
4132                  if (PL_unicode & PERL_UNICODE_ARGV_FLAG)
4133                       SvUTF8_on(sv);
4134             }
4135             if (PL_unicode & PERL_UNICODE_WIDESYSCALLS_FLAG) /* Sarathy? */
4136                  (void)sv_utf8_decode(sv);
4137         }
4138     }
4139 }
4140
4141 STATIC void
4142 S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env)
4143 {
4144     dVAR;
4145     GV* tmpgv;
4146
4147     PERL_ARGS_ASSERT_INIT_POSTDUMP_SYMBOLS;
4148
4149     PL_toptarget = newSV_type(SVt_PVFM);
4150     sv_setpvs(PL_toptarget, "");
4151     PL_bodytarget = newSV_type(SVt_PVFM);
4152     sv_setpvs(PL_bodytarget, "");
4153     PL_formtarget = PL_bodytarget;
4154
4155     TAINT;
4156
4157     init_argv_symbols(argc,argv);
4158
4159     if ((tmpgv = gv_fetchpvs("0", GV_ADD|GV_NOTQUAL, SVt_PV))) {
4160         sv_setpv(GvSV(tmpgv),PL_origfilename);
4161     }
4162     if ((PL_envgv = gv_fetchpvs("ENV", GV_ADD|GV_NOTQUAL, SVt_PVHV))) {
4163         HV *hv;
4164         bool env_is_not_environ;
4165         GvMULTI_on(PL_envgv);
4166         hv = GvHVn(PL_envgv);
4167         hv_magic(hv, NULL, PERL_MAGIC_env);
4168 #ifndef PERL_MICRO
4169 #ifdef USE_ENVIRON_ARRAY
4170         /* Note that if the supplied env parameter is actually a copy
4171            of the global environ then it may now point to free'd memory
4172            if the environment has been modified since. To avoid this
4173            problem we treat env==NULL as meaning 'use the default'
4174         */
4175         if (!env)
4176             env = environ;
4177         env_is_not_environ = env != environ;
4178         if (env_is_not_environ
4179 #  ifdef USE_ITHREADS
4180             && PL_curinterp == aTHX
4181 #  endif
4182            )
4183         {
4184             environ[0] = NULL;
4185         }
4186         if (env) {
4187           char *s, *old_var;
4188           SV *sv;
4189           for (; *env; env++) {
4190             old_var = *env;
4191
4192             if (!(s = strchr(old_var,'=')) || s == old_var)
4193                 continue;
4194
4195 #if defined(MSDOS) && !defined(DJGPP)
4196             *s = '\0';
4197             (void)strupr(old_var);
4198             *s = '=';
4199 #endif
4200             sv = newSVpv(s+1, 0);
4201             (void)hv_store(hv, old_var, s - old_var, sv, 0);
4202             if (env_is_not_environ)
4203                 mg_set(sv);
4204           }
4205       }
4206 #endif /* USE_ENVIRON_ARRAY */
4207 #endif /* !PERL_MICRO */
4208     }
4209     TAINT_NOT;
4210
4211     /* touch @F array to prevent spurious warnings 20020415 MJD */
4212     if (PL_minus_a) {
4213       (void) get_av("main::F", GV_ADD | GV_ADDMULTI);
4214     }
4215 }
4216
4217 STATIC void
4218 S_init_perllib(pTHX)
4219 {
4220     dVAR;
4221 #ifndef VMS
4222     const char *perl5lib = NULL;
4223 #endif
4224     const char *s;
4225 #if defined(WIN32) && !defined(PERL_IS_MINIPERL)
4226     STRLEN len;
4227 #endif
4228
4229     if (!PL_tainting) {
4230 #ifndef VMS
4231         perl5lib = PerlEnv_getenv("PERL5LIB");
4232 /*
4233  * It isn't possible to delete an environment variable with
4234  * PERL_USE_SAFE_PUTENV set unless unsetenv() is also available, so in that
4235  * case we treat PERL5LIB as undefined if it has a zero-length value.
4236  */
4237 #if defined(PERL_USE_SAFE_PUTENV) && ! defined(HAS_UNSETENV)
4238         if (perl5lib && *perl5lib != '\0')
4239 #else
4240         if (perl5lib)
4241 #endif
4242             incpush_use_sep(perl5lib, 0, INCPUSH_ADD_SUB_DIRS);
4243         else {
4244             s = PerlEnv_getenv("PERLLIB");
4245             if (s)
4246                 incpush_use_sep(s, 0, 0);
4247         }
4248 #else /* VMS */
4249         /* Treat PERL5?LIB as a possible search list logical name -- the
4250          * "natural" VMS idiom for a Unix path string.  We allow each
4251          * element to be a set of |-separated directories for compatibility.
4252          */
4253         char buf[256];
4254         int idx = 0;
4255         if (my_trnlnm("PERL5LIB",buf,0))
4256             do {
4257                 incpush_use_sep(buf, 0, INCPUSH_ADD_SUB_DIRS);
4258             } while (my_trnlnm("PERL5LIB",buf,++idx));
4259         else {
4260             while (my_trnlnm("PERLLIB",buf,idx++))
4261                 incpush_use_sep(buf, 0, 0);
4262         }
4263 #endif /* VMS */
4264     }
4265
4266 #ifndef PERL_IS_MINIPERL
4267     /* miniperl gets just -I..., the split of $ENV{PERL5LIB}, and "." in @INC
4268        (and not the architecture specific directories from $ENV{PERL5LIB}) */
4269
4270 /* Use the ~-expanded versions of APPLLIB (undocumented),
4271     SITEARCH, SITELIB, VENDORARCH, VENDORLIB, ARCHLIB and PRIVLIB
4272 */
4273 #ifdef APPLLIB_EXP
4274     S_incpush_use_sep(aTHX_ STR_WITH_LEN(APPLLIB_EXP),
4275                       INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE);
4276 #endif
4277
4278 #ifdef SITEARCH_EXP
4279     /* sitearch is always relative to sitelib on Windows for
4280      * DLL-based path intuition to work correctly */
4281 #  if !defined(WIN32)
4282         S_incpush_use_sep(aTHX_ STR_WITH_LEN(SITEARCH_EXP),
4283                           INCPUSH_CAN_RELOCATE);
4284 #  endif
4285 #endif
4286
4287 #ifdef SITELIB_EXP
4288 #  if defined(WIN32)
4289     /* this picks up sitearch as well */
4290         s = win32_get_sitelib(PERL_FS_VERSION, &len);
4291         if (s)
4292             incpush_use_sep(s, len, INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE);
4293 #  else
4294         S_incpush_use_sep(aTHX_ STR_WITH_LEN(SITELIB_EXP), INCPUSH_CAN_RELOCATE);
4295 #  endif
4296 #endif
4297
4298 #ifdef PERL_VENDORARCH_EXP
4299     /* vendorarch is always relative to vendorlib on Windows for
4300      * DLL-based path intuition to work correctly */
4301 #  if !defined(WIN32)
4302     S_incpush_use_sep(aTHX_ STR_WITH_LEN(PERL_VENDORARCH_EXP),
4303                       INCPUSH_CAN_RELOCATE);
4304 #  endif
4305 #endif
4306
4307 #ifdef PERL_VENDORLIB_EXP
4308 #  if defined(WIN32)
4309     /* this picks up vendorarch as well */
4310         s = win32_get_vendorlib(PERL_FS_VERSION, &len);
4311         if (s)
4312             incpush_use_sep(s, len, INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE);
4313 #  else
4314         S_incpush_use_sep(aTHX_ STR_WITH_LEN(PERL_VENDORLIB_EXP),
4315                           INCPUSH_CAN_RELOCATE);
4316 #  endif
4317 #endif
4318
4319 #ifdef ARCHLIB_EXP
4320     S_incpush_use_sep(aTHX_ STR_WITH_LEN(ARCHLIB_EXP), INCPUSH_CAN_RELOCATE);
4321 #endif
4322
4323 #ifndef PRIVLIB_EXP
4324 #  define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
4325 #endif
4326
4327 #if defined(WIN32)
4328     s = win32_get_privlib(PERL_FS_VERSION, &len);
4329     if (s)
4330         incpush_use_sep(s, len, INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE);
4331 #else
4332 #  ifdef NETWARE
4333     S_incpush_use_sep(aTHX_ PRIVLIB_EXP, 0, INCPUSH_CAN_RELOCATE);
4334 #  else
4335     S_incpush_use_sep(aTHX_ STR_WITH_LEN(PRIVLIB_EXP), INCPUSH_CAN_RELOCATE);
4336 #  endif
4337 #endif
4338
4339 #ifdef PERL_OTHERLIBDIRS
4340     S_incpush_use_sep(aTHX_ STR_WITH_LEN(PERL_OTHERLIBDIRS),
4341                       INCPUSH_ADD_VERSIONED_SUB_DIRS|INCPUSH_NOT_BASEDIR
4342                       |INCPUSH_CAN_RELOCATE);
4343 #endif
4344
4345     if (!PL_tainting) {
4346 #ifndef VMS
4347 /*
4348  * It isn't possible to delete an environment variable with
4349  * PERL_USE_SAFE_PUTENV set unless unsetenv() is also available, so in that
4350  * case we treat PERL5LIB as undefined if it has a zero-length value.
4351  */
4352 #if defined(PERL_USE_SAFE_PUTENV) && ! defined(HAS_UNSETENV)
4353         if (perl5lib && *perl5lib != '\0')
4354 #else
4355         if (perl5lib)
4356 #endif
4357             incpush_use_sep(perl5lib, 0,
4358                             INCPUSH_ADD_OLD_VERS|INCPUSH_NOT_BASEDIR);
4359 #else /* VMS */
4360         /* Treat PERL5?LIB as a possible search list logical name -- the
4361          * "natural" VMS idiom for a Unix path string.  We allow each
4362          * element to be a set of |-separated directories for compatibility.
4363          */
4364         char buf[256];
4365         int idx = 0;
4366         if (my_trnlnm("PERL5LIB",buf,0))
4367             do {
4368                 incpush_use_sep(buf, 0,
4369                                 INCPUSH_ADD_OLD_VERS|INCPUSH_NOT_BASEDIR);
4370             } while (my_trnlnm("PERL5LIB",buf,++idx));
4371 #endif /* VMS */
4372     }
4373
4374 /* Use the ~-expanded versions of APPLLIB (undocumented),
4375     SITELIB and VENDORLIB for older versions
4376 */
4377 #ifdef APPLLIB_EXP
4378     S_incpush_use_sep(aTHX_ STR_WITH_LEN(APPLLIB_EXP), INCPUSH_ADD_OLD_VERS
4379                       |INCPUSH_NOT_BASEDIR|INCPUSH_CAN_RELOCATE);
4380 #endif
4381
4382 #if defined(SITELIB_STEM) && defined(PERL_INC_VERSION_LIST)
4383     /* Search for version-specific dirs below here */
4384     S_incpush_use_sep(aTHX_ STR_WITH_LEN(SITELIB_STEM),
4385                       INCPUSH_ADD_OLD_VERS|INCPUSH_CAN_RELOCATE);
4386 #endif
4387
4388
4389 #if defined(PERL_VENDORLIB_STEM) && defined(PERL_INC_VERSION_LIST)
4390     /* Search for version-specific dirs below here */
4391     S_incpush_use_sep(aTHX_ STR_WITH_LEN(PERL_VENDORLIB_STEM),
4392                       INCPUSH_ADD_OLD_VERS|INCPUSH_CAN_RELOCATE);
4393 #endif
4394
4395 #ifdef PERL_OTHERLIBDIRS
4396     S_incpush_use_sep(aTHX_ STR_WITH_LEN(PERL_OTHERLIBDIRS),
4397                       INCPUSH_ADD_OLD_VERS|INCPUSH_ADD_ARCHONLY_SUB_DIRS
4398                       |INCPUSH_CAN_RELOCATE);
4399 #endif
4400 #endif /* !PERL_IS_MINIPERL */
4401
4402     if (!PL_tainting)
4403         S_incpush(aTHX_ STR_WITH_LEN("."), 0);
4404 }
4405
4406 #if defined(DOSISH) || defined(EPOC) || defined(__SYMBIAN32__)
4407 #    define PERLLIB_SEP ';'
4408 #else
4409 #  if defined(VMS)
4410 #    define PERLLIB_SEP '|'
4411 #  else
4412 #    define PERLLIB_SEP ':'
4413 #  endif
4414 #endif
4415 #ifndef PERLLIB_MANGLE
4416 #  define PERLLIB_MANGLE(s,n) (s)
4417 #endif
4418
4419 #ifndef PERL_IS_MINIPERL
4420 /* Push a directory onto @INC if it exists.
4421    Generate a new SV if we do this, to save needing to copy the SV we push
4422    onto @INC  */
4423 STATIC SV *
4424 S_incpush_if_exists(pTHX_ AV *const av, SV *dir, SV *const stem)
4425 {
4426     dVAR;
4427     Stat_t tmpstatbuf;
4428
4429     PERL_ARGS_ASSERT_INCPUSH_IF_EXISTS;
4430
4431     if (PerlLIO_stat(SvPVX_const(dir), &tmpstatbuf) >= 0 &&
4432         S_ISDIR(tmpstatbuf.st_mode)) {
4433         av_push(av, dir);
4434         dir = newSVsv(stem);
4435     } else {
4436         /* Truncate dir back to stem.  */
4437         SvCUR_set(dir, SvCUR(stem));
4438     }
4439     return dir;
4440 }
4441 #endif
4442
4443 STATIC SV *
4444 S_mayberelocate(pTHX_ const char *const dir, STRLEN len, U32 flags)
4445 {
4446     const U8 canrelocate = (U8)flags & INCPUSH_CAN_RELOCATE;
4447     SV *libdir;
4448
4449     PERL_ARGS_ASSERT_MAYBERELOCATE;
4450     assert(len > 0);
4451
4452         if (len) {
4453             /* I am not convinced that this is valid when PERLLIB_MANGLE is
4454                defined to so something (in os2/os2.c), but the code has been
4455                this way, ignoring any possible changed of length, since
4456                760ac839baf413929cd31cc32ffd6dba6b781a81 (5.003_02) so I'll leave
4457                it be.  */
4458             libdir = newSVpvn(PERLLIB_MANGLE(dir, len), len);
4459         } else {
4460             libdir = newSVpv(PERLLIB_MANGLE(dir, 0), 0);
4461         }
4462
4463 #ifdef VMS
4464     {
4465         char *unix;
4466
4467         if ((unix = tounixspec_ts(SvPV(libdir,len),NULL)) != NULL) {
4468             len = strlen(unix);
4469             while (unix[len-1] == '/') len--;  /* Cosmetic */
4470             sv_usepvn(libdir,unix,len);
4471         }
4472         else
4473             PerlIO_printf(Perl_error_log,
4474                           "Failed to unixify @INC element \"%s\"\n",
4475                           SvPV_nolen_const(libdir));
4476     }
4477 #endif
4478
4479         /* Do the if() outside the #ifdef to avoid warnings about an unused
4480            parameter.  */
4481         if (canrelocate) {
4482 #ifdef PERL_RELOCATABLE_INC
4483         /*
4484          * Relocatable include entries are marked with a leading .../
4485          *
4486          * The algorithm is
4487          * 0: Remove that leading ".../"
4488          * 1: Remove trailing executable name (anything after the last '/')
4489          *    from the perl path to give a perl prefix
4490          * Then
4491          * While the @INC element starts "../" and the prefix ends with a real
4492          * directory (ie not . or ..) chop that real directory off the prefix
4493          * and the leading "../" from the @INC element. ie a logical "../"
4494          * cleanup
4495          * Finally concatenate the prefix and the remainder of the @INC element
4496          * The intent is that /usr/local/bin/perl and .../../lib/perl5
4497          * generates /usr/local/lib/perl5
4498          */
4499             const char *libpath = SvPVX(libdir);
4500             STRLEN libpath_len = SvCUR(libdir);
4501             if (libpath_len >= 4 && memEQ (libpath, ".../", 4)) {
4502                 /* Game on!  */
4503                 SV * const caret_X = get_sv("\030", 0);
4504                 /* Going to use the SV just as a scratch buffer holding a C
4505                    string:  */
4506                 SV *prefix_sv;
4507                 char *prefix;
4508                 char *lastslash;
4509
4510                 /* $^X is *the* source of taint if tainting is on, hence
4511                    SvPOK() won't be true.  */
4512                 assert(caret_X);
4513                 assert(SvPOKp(caret_X));
4514                 prefix_sv = newSVpvn_flags(SvPVX(caret_X), SvCUR(caret_X),
4515                                            SvUTF8(caret_X));
4516                 /* Firstly take off the leading .../
4517                    If all else fail we'll do the paths relative to the current
4518                    directory.  */
4519                 sv_chop(libdir, libpath + 4);
4520                 /* Don't use SvPV as we're intentionally bypassing taining,
4521                    mortal copies that the mg_get of tainting creates, and
4522                    corruption that seems to come via the save stack.
4523                    I guess that the save stack isn't correctly set up yet.  */
4524                 libpath = SvPVX(libdir);
4525                 libpath_len = SvCUR(libdir);
4526
4527                 /* This would work more efficiently with memrchr, but as it's
4528                    only a GNU extension we'd need to probe for it and
4529                    implement our own. Not hard, but maybe not worth it?  */
4530
4531                 prefix = SvPVX(prefix_sv);
4532                 lastslash = strrchr(prefix, '/');
4533
4534                 /* First time in with the *lastslash = '\0' we just wipe off
4535                    the trailing /perl from (say) /usr/foo/bin/perl
4536                 */
4537                 if (lastslash) {
4538                     SV *tempsv;
4539                     while ((*lastslash = '\0'), /* Do that, come what may.  */
4540                            (libpath_len >= 3 && memEQ(libpath, "../", 3)
4541                             && (lastslash = strrchr(prefix, '/')))) {
4542                         if (lastslash[1] == '\0'
4543                             || (lastslash[1] == '.'
4544                                 && (lastslash[2] == '/' /* ends "/."  */
4545                                     || (lastslash[2] == '/'
4546                                         && lastslash[3] == '/' /* or "/.."  */
4547                                         )))) {
4548                             /* Prefix ends "/" or "/." or "/..", any of which
4549                                are fishy, so don't do any more logical cleanup.
4550                             */
4551                             break;
4552                         }
4553                         /* Remove leading "../" from path  */
4554                         libpath += 3;
4555                         libpath_len -= 3;
4556                         /* Next iteration round the loop removes the last
4557                            directory name from prefix by writing a '\0' in
4558                            the while clause.  */
4559                     }
4560                     /* prefix has been terminated with a '\0' to the correct
4561                        length. libpath points somewhere into the libdir SV.
4562                        We need to join the 2 with '/' and drop the result into
4563                        libdir.  */
4564                     tempsv = Perl_newSVpvf(aTHX_ "%s/%s", prefix, libpath);
4565                     SvREFCNT_dec(libdir);
4566                     /* And this is the new libdir.  */
4567                     libdir = tempsv;
4568                     if (PL_tainting &&
4569                         (PL_uid != PL_euid || PL_gid != PL_egid)) {
4570                         /* Need to taint relocated paths if running set ID  */
4571                         SvTAINTED_on(libdir);
4572                     }
4573                 }
4574                 SvREFCNT_dec(prefix_sv);
4575             }
4576 #endif
4577         }
4578     return libdir;
4579 }
4580
4581 STATIC void
4582 S_incpush(pTHX_ const char *const dir, STRLEN len, U32 flags)
4583 {
4584     dVAR;
4585 #ifndef PERL_IS_MINIPERL
4586     const U8 using_sub_dirs
4587         = (U8)flags & (INCPUSH_ADD_VERSIONED_SUB_DIRS
4588                        |INCPUSH_ADD_ARCHONLY_SUB_DIRS|INCPUSH_ADD_OLD_VERS);
4589     const U8 add_versioned_sub_dirs
4590         = (U8)flags & INCPUSH_ADD_VERSIONED_SUB_DIRS;
4591     const U8 add_archonly_sub_dirs
4592         = (U8)flags & INCPUSH_ADD_ARCHONLY_SUB_DIRS;
4593 #ifdef PERL_INC_VERSION_LIST
4594     const U8 addoldvers  = (U8)flags & INCPUSH_ADD_OLD_VERS;
4595 #endif
4596 #endif
4597     const U8 unshift     = (U8)flags & INCPUSH_UNSHIFT;
4598     const U8 push_basedir = (flags & INCPUSH_NOT_BASEDIR) ? 0 : 1;
4599     AV *const inc = GvAVn(PL_incgv);
4600
4601     PERL_ARGS_ASSERT_INCPUSH;
4602     assert(len > 0);
4603
4604     /* Could remove this vestigial extra block, if we don't mind a lot of
4605        re-indenting diff noise.  */
4606     {
4607         SV *const libdir = mayberelocate(dir, len, flags);
4608         /* Change 20189146be79a0596543441fa369c6bf7f85103f, to fix RT#6665,
4609            arranged to unshift #! line -I onto the front of @INC. However,
4610            -I can add version and architecture specific libraries, and they
4611            need to go first. The old code assumed that it was always
4612            pushing. Hence to make it work, need to push the architecture
4613            (etc) libraries onto a temporary array, then "unshift" that onto
4614            the front of @INC.  */
4615 #ifndef PERL_IS_MINIPERL
4616         AV *const av = (using_sub_dirs) ? (unshift ? newAV() : inc) : NULL;
4617
4618         /*
4619          * BEFORE pushing libdir onto @INC we may first push version- and
4620          * archname-specific sub-directories.
4621          */
4622         if (using_sub_dirs) {
4623             SV *subdir = newSVsv(libdir);
4624 #ifdef PERL_INC_VERSION_LIST
4625             /* Configure terminates PERL_INC_VERSION_LIST with a NULL */
4626             const char * const incverlist[] = { PERL_INC_VERSION_LIST };
4627             const char * const *incver;
4628 #endif
4629
4630             if (add_versioned_sub_dirs) {
4631                 /* .../version/archname if -d .../version/archname */
4632                 sv_catpvs(subdir, "/" PERL_FS_VERSION "/" ARCHNAME);
4633                 subdir = S_incpush_if_exists(aTHX_ av, subdir, libdir);
4634
4635                 /* .../version if -d .../version */
4636                 sv_catpvs(subdir, "/" PERL_FS_VERSION);
4637                 subdir = S_incpush_if_exists(aTHX_ av, subdir, libdir);
4638             }
4639
4640 #ifdef PERL_INC_VERSION_LIST
4641             if (addoldvers) {
4642                 for (incver = incverlist; *incver; incver++) {
4643                     /* .../xxx if -d .../xxx */
4644                     Perl_sv_catpvf(aTHX_ subdir, "/%s", *incver);
4645                     subdir = S_incpush_if_exists(aTHX_ av, subdir, libdir);
4646                 }
4647             }
4648 #endif
4649
4650             if (add_archonly_sub_dirs) {
4651                 /* .../archname if -d .../archname */
4652                 sv_catpvs(subdir, "/" ARCHNAME);
4653                 subdir = S_incpush_if_exists(aTHX_ av, subdir, libdir);
4654
4655             }
4656
4657             assert (SvREFCNT(subdir) == 1);
4658             SvREFCNT_dec(subdir);
4659         }
4660 #endif /* !PERL_IS_MINIPERL */
4661         /* finally add this lib directory at the end of @INC */
4662         if (unshift) {
4663 #ifdef PERL_IS_MINIPERL
4664             const U32 extra = 0;
4665 #else
4666             U32 extra = av_len(av) + 1;
4667 #endif
4668             av_unshift(inc, extra + push_basedir);
4669             if (push_basedir)
4670                 av_store(inc, extra, libdir);
4671 #ifndef PERL_IS_MINIPERL
4672             while (extra--) {
4673                 /* av owns a reference, av_store() expects to be donated a
4674                    reference, and av expects to be sane when it's cleared.
4675                    If I wanted to be naughty and wrong, I could peek inside the
4676                    implementation of av_clear(), realise that it uses
4677                    SvREFCNT_dec() too, so av's array could be a run of NULLs,
4678                    and so directly steal from it (with a memcpy() to inc, and
4679                    then memset() to NULL them out. But people copy code from the
4680                    core expecting it to be best practise, so let's use the API.
4681                    Although studious readers will note that I'm not checking any
4682                    return codes.  */
4683                 av_store(inc, extra, SvREFCNT_inc(*av_fetch(av, extra, FALSE)));
4684             }
4685             SvREFCNT_dec(av);
4686 #endif
4687         }
4688         else if (push_basedir) {
4689             av_push(inc, libdir);
4690         }
4691
4692         if (!push_basedir) {
4693             assert (SvREFCNT(libdir) == 1);
4694             SvREFCNT_dec(libdir);
4695         }
4696     }
4697 }
4698
4699 STATIC void
4700 S_incpush_use_sep(pTHX_ const char *p, STRLEN len, U32 flags)
4701 {
4702     const char *s;
4703     const char *end;
4704     /* This logic has been broken out from S_incpush(). It may be possible to
4705        simplify it.  */
4706
4707     PERL_ARGS_ASSERT_INCPUSH_USE_SEP;
4708
4709     /* perl compiled with -DPERL_RELOCATABLE_INCPUSH will ignore the len
4710      * argument to incpush_use_sep.  This allows creation of relocatable
4711      * Perl distributions that patch the binary at install time.  Those
4712      * distributions will have to provide their own relocation tools; this
4713      * is not a feature otherwise supported by core Perl.
4714      */
4715 #ifndef PERL_RELOCATABLE_INCPUSH
4716     if (!len)
4717 #endif
4718         len = strlen(p);
4719
4720     end = p + len;
4721
4722     /* Break at all separators */
4723     while ((s = (const char*)memchr(p, PERLLIB_SEP, end - p))) {
4724         if (s == p) {
4725             /* skip any consecutive separators */
4726
4727             /* Uncomment the next line for PATH semantics */
4728             /* But you'll need to write tests */
4729             /* av_push(GvAVn(PL_incgv), newSVpvs(".")); */
4730         } else {
4731             incpush(p, (STRLEN)(s - p), flags);
4732         }
4733         p = s + 1;
4734     }
4735     if (p != end)
4736         incpush(p, (STRLEN)(end - p), flags);
4737
4738 }
4739
4740 void
4741 Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
4742 {
4743     dVAR;
4744     SV *atsv;
4745     volatile const line_t oldline = PL_curcop ? CopLINE(PL_curcop) : 0;
4746     CV *cv;
4747     STRLEN len;
4748     int ret;
4749     dJMPENV;
4750
4751     PERL_ARGS_ASSERT_CALL_LIST;
4752
4753     while (av_len(paramList) >= 0) {
4754         cv = MUTABLE_CV(av_shift(paramList));
4755         if (PL_savebegin) {
4756             if (paramList == PL_beginav) {
4757                 /* save PL_beginav for compiler */
4758                 Perl_av_create_and_push(aTHX_ &PL_beginav_save, MUTABLE_SV(cv));
4759             }
4760             else if (paramList == PL_checkav) {
4761                 /* save PL_checkav for compiler */
4762                 Perl_av_create_and_push(aTHX_ &PL_checkav_save, MUTABLE_SV(cv));
4763             }
4764             else if (paramList == PL_unitcheckav) {
4765                 /* save PL_unitcheckav for compiler */
4766                 Perl_av_create_and_push(aTHX_ &PL_unitcheckav_save, MUTABLE_SV(cv));
4767             }
4768         } else {
4769             if (!PL_madskills)
4770                 SAVEFREESV(cv);
4771         }
4772         JMPENV_PUSH(ret);
4773         switch (ret) {
4774         case 0:
4775 #ifdef PERL_MAD
4776             if (PL_madskills)
4777                 PL_madskills |= 16384;
4778 #endif
4779             CALL_LIST_BODY(cv);
4780 #ifdef PERL_MAD
4781             if (PL_madskills)
4782                 PL_madskills &= ~16384;
4783 #endif
4784             atsv = ERRSV;
4785             (void)SvPV_const(atsv, len);
4786             if (len) {
4787                 PL_curcop = &PL_compiling;
4788                 CopLINE_set(PL_curcop, oldline);
4789                 if (paramList == PL_beginav)
4790                     sv_catpvs(atsv, "BEGIN failed--compilation aborted");
4791                 else
4792                     Perl_sv_catpvf(aTHX_ atsv,
4793                                    "%s failed--call queue aborted",
4794                                    paramList == PL_checkav ? "CHECK"
4795                                    : paramList == PL_initav ? "INIT"
4796                                    : paramList == PL_unitcheckav ? "UNITCHECK"
4797                                    : "END");
4798                 while (PL_scopestack_ix > oldscope)
4799                     LEAVE;
4800                 JMPENV_POP;
4801                 Perl_croak(aTHX_ "%"SVf"", SVfARG(atsv));
4802             }
4803             break;
4804         case 1:
4805             STATUS_ALL_FAILURE;
4806             /* FALL THROUGH */
4807         case 2:
4808             /* my_exit() was called */
4809             while (PL_scopestack_ix > oldscope)
4810                 LEAVE;
4811             FREETMPS;
4812             SET_CURSTASH(PL_defstash);
4813             PL_curcop = &PL_compiling;
4814             CopLINE_set(PL_curcop, oldline);
4815             JMPENV_POP;
4816             my_exit_jump();
4817             /* NOTREACHED */
4818         case 3:
4819             if (PL_restartop) {
4820                 PL_curcop = &PL_compiling;
4821                 CopLINE_set(PL_curcop, oldline);
4822                 JMPENV_JUMP(3);
4823             }
4824             PerlIO_printf(Perl_error_log, "panic: restartop in call_list\n");
4825             FREETMPS;
4826             break;
4827         }
4828         JMPENV_POP;
4829     }
4830 }
4831
4832 void
4833 Perl_my_exit(pTHX_ U32 status)
4834 {
4835     dVAR;
4836     switch (status) {
4837     case 0:
4838         STATUS_ALL_SUCCESS;
4839         break;
4840     case 1:
4841         STATUS_ALL_FAILURE;
4842         break;
4843     default:
4844         STATUS_EXIT_SET(status);
4845         break;
4846     }
4847     my_exit_jump();
4848 }
4849
4850 void
4851 Perl_my_failure_exit(pTHX)
4852 {
4853     dVAR;
4854 #ifdef VMS
4855      /* We have been called to fall on our sword.  The desired exit code
4856       * should be already set in STATUS_UNIX, but could be shifted over
4857       * by 8 bits.  STATUS_UNIX_EXIT_SET will handle the cases where a
4858       * that code is set.
4859       *
4860       * If an error code has not been set, then force the issue.
4861       */
4862     if (MY_