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