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