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