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