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