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