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