This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Restore "Add new hashing and "hash with state" infrastructure"
[perl5.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) || defined(USE_HASH_SEED_EXPLICIT)
321         /* get the hash seed from the environment or from an RNG */
322         Perl_get_hash_seed(aTHX_ PL_hash_seed);
323 #else /*if !(defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT)) */
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 /* #if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT) */
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     {
1291         int i;
1292         for (i=0; i<=2; i++) {
1293             SvREFCNT(PERL_DEBUG_PAD(i)) = 0;
1294             sv_clear(PERL_DEBUG_PAD(i));
1295             SvANY(PERL_DEBUG_PAD(i)) = NULL;
1296             SvFLAGS(PERL_DEBUG_PAD(i)) = 0;
1297         }
1298     }
1299
1300     if (PL_sv_count != 0 && ckWARN_d(WARN_INTERNAL))
1301         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Scalars leaked: %ld\n", (long)PL_sv_count);
1302
1303 #ifdef DEBUG_LEAKING_SCALARS
1304     if (PL_sv_count != 0) {
1305         SV* sva;
1306         SV* sv;
1307         SV* svend;
1308
1309         for (sva = PL_sv_arenaroot; sva; sva = MUTABLE_SV(SvANY(sva))) {
1310             svend = &sva[SvREFCNT(sva)];
1311             for (sv = sva + 1; sv < svend; ++sv) {
1312                 if (SvTYPE(sv) != (svtype)SVTYPEMASK) {
1313                     PerlIO_printf(Perl_debug_log, "leaked: sv=0x%p"
1314                         " flags=0x%"UVxf
1315                         " refcnt=%"UVuf pTHX__FORMAT "\n"
1316                         "\tallocated at %s:%d %s %s (parent 0x%" UVxf ");"
1317                         "serial %" UVuf "\n",
1318                         (void*)sv, (UV)sv->sv_flags, (UV)sv->sv_refcnt
1319                         pTHX__VALUE,
1320                         sv->sv_debug_file ? sv->sv_debug_file : "(unknown)",
1321                         sv->sv_debug_line,
1322                         sv->sv_debug_inpad ? "for" : "by",
1323                         sv->sv_debug_optype ?
1324                             PL_op_name[sv->sv_debug_optype]: "(none)",
1325                         PTR2UV(sv->sv_debug_parent),
1326                         sv->sv_debug_serial
1327                     );
1328 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
1329                     Perl_dump_sv_child(aTHX_ sv);
1330 #endif
1331                 }
1332             }
1333         }
1334     }
1335 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
1336     {
1337         int status;
1338         fd_set rset;
1339         /* Wait for up to 4 seconds for child to terminate.
1340            This seems to be the least effort way of timing out on reaping
1341            its exit status.  */
1342         struct timeval waitfor = {4, 0};
1343         int sock = PL_dumper_fd;
1344
1345         shutdown(sock, 1);
1346         FD_ZERO(&rset);
1347         FD_SET(sock, &rset);
1348         select(sock + 1, &rset, NULL, NULL, &waitfor);
1349         waitpid(child, &status, WNOHANG);
1350         close(sock);
1351     }
1352 #endif
1353 #endif
1354 #ifdef DEBUG_LEAKING_SCALARS_ABORT
1355     if (PL_sv_count)
1356         abort();
1357 #endif
1358     PL_sv_count = 0;
1359
1360 #if defined(PERLIO_LAYERS)
1361     /* No more IO - including error messages ! */
1362     PerlIO_cleanup(aTHX);
1363 #endif
1364
1365     /* sv_undef needs to stay immortal until after PerlIO_cleanup
1366        as currently layers use it rather than NULL as a marker
1367        for no arg - and will try and SvREFCNT_dec it.
1368      */
1369     SvREFCNT(&PL_sv_undef) = 0;
1370     SvREADONLY_off(&PL_sv_undef);
1371
1372     Safefree(PL_origfilename);
1373     PL_origfilename = NULL;
1374     Safefree(PL_reg_curpm);
1375     free_tied_hv_pool();
1376     Safefree(PL_op_mask);
1377     Safefree(PL_psig_name);
1378     PL_psig_name = (SV**)NULL;
1379     PL_psig_ptr = (SV**)NULL;
1380     {
1381         /* We need to NULL PL_psig_pend first, so that
1382            signal handlers know not to use it */
1383         int *psig_save = PL_psig_pend;
1384         PL_psig_pend = (int*)NULL;
1385         Safefree(psig_save);
1386     }
1387     nuke_stacks();
1388     TAINTING_set(FALSE);
1389     TAINT_WARN_set(FALSE);
1390     PL_hints = 0;               /* Reset hints. Should hints be per-interpreter ? */
1391
1392     DEBUG_P(debprofdump());
1393
1394     PL_debug = 0;
1395
1396 #ifdef USE_REENTRANT_API
1397     Perl_reentrant_free(aTHX);
1398 #endif
1399
1400     /* These all point to HVs that are about to be blown away.
1401        Code in core and on CPAN assumes that if the interpreter is re-started
1402        that they will be cleanly NULL or pointing to a valid HV.  */
1403     PL_custom_op_names = NULL;
1404     PL_custom_op_descs = NULL;
1405     PL_custom_ops = NULL;
1406
1407     sv_free_arenas();
1408
1409     while (PL_regmatch_slab) {
1410         regmatch_slab  *s = PL_regmatch_slab;
1411         PL_regmatch_slab = PL_regmatch_slab->next;
1412         Safefree(s);
1413     }
1414
1415     /* As the absolutely last thing, free the non-arena SV for mess() */
1416
1417     if (PL_mess_sv) {
1418         /* we know that type == SVt_PVMG */
1419
1420         /* it could have accumulated taint magic */
1421         MAGIC* mg;
1422         MAGIC* moremagic;
1423         for (mg = SvMAGIC(PL_mess_sv); mg; mg = moremagic) {
1424             moremagic = mg->mg_moremagic;
1425             if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global
1426                 && mg->mg_len >= 0)
1427                 Safefree(mg->mg_ptr);
1428             Safefree(mg);
1429         }
1430
1431         /* we know that type >= SVt_PV */
1432         SvPV_free(PL_mess_sv);
1433         Safefree(SvANY(PL_mess_sv));
1434         Safefree(PL_mess_sv);
1435         PL_mess_sv = NULL;
1436     }
1437     return STATUS_EXIT;
1438 }
1439
1440 /*
1441 =for apidoc perl_free
1442
1443 Releases a Perl interpreter.  See L<perlembed>.
1444
1445 =cut
1446 */
1447
1448 void
1449 perl_free(pTHXx)
1450 {
1451     dVAR;
1452
1453     PERL_ARGS_ASSERT_PERL_FREE;
1454
1455     if (PL_veto_cleanup)
1456         return;
1457
1458 #ifdef PERL_TRACK_MEMPOOL
1459     {
1460         /*
1461          * Don't free thread memory if PERL_DESTRUCT_LEVEL is set to a non-zero
1462          * value as we're probably hunting memory leaks then
1463          */
1464         if (PL_perl_destruct_level == 0) {
1465             const U32 old_debug = PL_debug;
1466             /* Emulate the PerlHost behaviour of free()ing all memory allocated in this
1467                thread at thread exit.  */
1468             if (DEBUG_m_TEST) {
1469                 PerlIO_puts(Perl_debug_log, "Disabling memory debugging as we "
1470                             "free this thread's memory\n");
1471                 PL_debug &= ~ DEBUG_m_FLAG;
1472             }
1473             while(aTHXx->Imemory_debug_header.next != &(aTHXx->Imemory_debug_header)){
1474                 char * next = (char *)(aTHXx->Imemory_debug_header.next);
1475                 Malloc_t ptr = PERL_MEMORY_DEBUG_HEADER_SIZE + next;
1476                 safesysfree(ptr);
1477             }
1478             PL_debug = old_debug;
1479         }
1480     }
1481 #endif
1482
1483 #if defined(WIN32) || defined(NETWARE)
1484 #  if defined(PERL_IMPLICIT_SYS)
1485     {
1486 #    ifdef NETWARE
1487         void *host = nw_internal_host;
1488         PerlMem_free(aTHXx);
1489         nw_delete_internal_host(host);
1490 #    else
1491         void *host = w32_internal_host;
1492         PerlMem_free(aTHXx);
1493         win32_delete_internal_host(host);
1494 #    endif
1495     }
1496 #  else
1497     PerlMem_free(aTHXx);
1498 #  endif
1499 #else
1500     PerlMem_free(aTHXx);
1501 #endif
1502 }
1503
1504 #if defined(USE_ITHREADS)
1505 /* provide destructors to clean up the thread key when libperl is unloaded */
1506 #ifndef WIN32 /* handled during DLL_PROCESS_DETACH in win32/perllib.c */
1507
1508 #if defined(__hpux) && !(defined(__ux_version) && __ux_version <= 1020) && !defined(__GNUC__)
1509 #pragma fini "perl_fini"
1510 #elif defined(__sun) && !defined(__GNUC__)
1511 #pragma fini (perl_fini)
1512 #endif
1513
1514 static void
1515 #if defined(__GNUC__)
1516 __attribute__((destructor))
1517 #endif
1518 perl_fini(void)
1519 {
1520     dVAR;
1521     if (
1522 #ifdef PERL_GLOBAL_STRUCT_PRIVATE
1523         my_vars &&
1524 #endif
1525         PL_curinterp && !PL_veto_cleanup)
1526         FREE_THREAD_KEY;
1527 }
1528
1529 #endif /* WIN32 */
1530 #endif /* THREADS */
1531
1532 void
1533 Perl_call_atexit(pTHX_ ATEXIT_t fn, void *ptr)
1534 {
1535     Renew(PL_exitlist, PL_exitlistlen+1, PerlExitListEntry);
1536     PL_exitlist[PL_exitlistlen].fn = fn;
1537     PL_exitlist[PL_exitlistlen].ptr = ptr;
1538     ++PL_exitlistlen;
1539 }
1540
1541 /*
1542 =for apidoc perl_parse
1543
1544 Tells a Perl interpreter to parse a Perl script.  See L<perlembed>.
1545
1546 =cut
1547 */
1548
1549 #define SET_CURSTASH(newstash)                       \
1550         if (PL_curstash != newstash) {                \
1551             SvREFCNT_dec(PL_curstash);                 \
1552             PL_curstash = (HV *)SvREFCNT_inc(newstash); \
1553         }
1554
1555 int
1556 perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env)
1557 {
1558     dVAR;
1559     I32 oldscope;
1560     int ret;
1561     dJMPENV;
1562
1563     PERL_ARGS_ASSERT_PERL_PARSE;
1564 #ifndef MULTIPLICITY
1565     PERL_UNUSED_ARG(my_perl);
1566 #endif
1567 #if (defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT) || defined(USE_HASH_SEED_DEBUG)) && !defined(NO_PERL_HASH_SEED_DEBUG)
1568     {
1569         const char * const s = PerlEnv_getenv("PERL_HASH_SEED_DEBUG");
1570
1571         if (s && strEQ(s, "1")) {
1572             const unsigned char *seed= PERL_HASH_SEED;
1573             const unsigned char *seed_end= PERL_HASH_SEED + PERL_HASH_SEED_BYTES;
1574             PerlIO_printf(Perl_debug_log, "HASH_FUNCTION = %s HASH_SEED = 0x", PERL_HASH_FUNC);
1575             while (seed < seed_end) {
1576                 PerlIO_printf(Perl_debug_log, "%02x", *seed++);
1577             }
1578 #ifdef PERL_HASH_RANDOMIZE_KEYS
1579             PerlIO_printf(Perl_debug_log, " PERTURB_KEYS = %d (%s)",
1580                     PL_HASH_RAND_BITS_ENABLED,
1581                     PL_HASH_RAND_BITS_ENABLED == 0 ? "NO" : PL_HASH_RAND_BITS_ENABLED == 1 ? "RANDOM" : "DETERMINISTIC");
1582 #endif
1583             PerlIO_printf(Perl_debug_log, "\n");
1584         }
1585     }
1586 #endif /* #if (defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT) ... */
1587
1588 #ifdef __amigaos4__
1589     {
1590         struct NameTranslationInfo nti;
1591         __translate_amiga_to_unix_path_name(&argv[0],&nti); 
1592     }
1593 #endif
1594
1595     PL_origargc = argc;
1596     PL_origargv = argv;
1597
1598     if (PL_origalen != 0) {
1599         PL_origalen = 1; /* don't use old PL_origalen if perl_parse() is called again */
1600     }
1601     else {
1602         /* Set PL_origalen be the sum of the contiguous argv[]
1603          * elements plus the size of the env in case that it is
1604          * contiguous with the argv[].  This is used in mg.c:Perl_magic_set()
1605          * as the maximum modifiable length of $0.  In the worst case
1606          * the area we are able to modify is limited to the size of
1607          * the original argv[0].  (See below for 'contiguous', though.)
1608          * --jhi */
1609          const char *s = NULL;
1610          const UV mask = ~(UV)(PTRSIZE-1);
1611          /* Do the mask check only if the args seem like aligned. */
1612          const UV aligned =
1613            (mask < ~(UV)0) && ((PTR2UV(argv[0]) & mask) == PTR2UV(argv[0]));
1614
1615          /* See if all the arguments are contiguous in memory.  Note
1616           * that 'contiguous' is a loose term because some platforms
1617           * align the argv[] and the envp[].  If the arguments look
1618           * like non-aligned, assume that they are 'strictly' or
1619           * 'traditionally' contiguous.  If the arguments look like
1620           * aligned, we just check that they are within aligned
1621           * PTRSIZE bytes.  As long as no system has something bizarre
1622           * like the argv[] interleaved with some other data, we are
1623           * fine.  (Did I just evoke Murphy's Law?)  --jhi */
1624          if (PL_origargv && PL_origargc >= 1 && (s = PL_origargv[0])) {
1625               int i;
1626               while (*s) s++;
1627               for (i = 1; i < PL_origargc; i++) {
1628                    if ((PL_origargv[i] == s + 1
1629 #ifdef OS2
1630                         || PL_origargv[i] == s + 2
1631 #endif 
1632                             )
1633                        ||
1634                        (aligned &&
1635                         (PL_origargv[i] >  s &&
1636                          PL_origargv[i] <=
1637                          INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask)))
1638                         )
1639                    {
1640                         s = PL_origargv[i];
1641                         while (*s) s++;
1642                    }
1643                    else
1644                         break;
1645               }
1646          }
1647
1648 #ifndef PERL_USE_SAFE_PUTENV
1649          /* Can we grab env area too to be used as the area for $0? */
1650          if (s && PL_origenviron && !PL_use_safe_putenv) {
1651               if ((PL_origenviron[0] == s + 1)
1652                   ||
1653                   (aligned &&
1654                    (PL_origenviron[0] >  s &&
1655                     PL_origenviron[0] <=
1656                     INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask)))
1657                  )
1658               {
1659                    int i;
1660 #ifndef OS2             /* ENVIRON is read by the kernel too. */
1661                    s = PL_origenviron[0];
1662                    while (*s) s++;
1663 #endif
1664                    my_setenv("NoNe  SuCh", NULL);
1665                    /* Force copy of environment. */
1666                    for (i = 1; PL_origenviron[i]; i++) {
1667                         if (PL_origenviron[i] == s + 1
1668                             ||
1669                             (aligned &&
1670                              (PL_origenviron[i] >  s &&
1671                               PL_origenviron[i] <=
1672                               INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask)))
1673                            )
1674                         {
1675                              s = PL_origenviron[i];
1676                              while (*s) s++;
1677                         }
1678                         else
1679                              break;
1680                    }
1681               }
1682          }
1683 #endif /* !defined(PERL_USE_SAFE_PUTENV) */
1684
1685          PL_origalen = s ? s - PL_origargv[0] + 1 : 0;
1686     }
1687
1688     if (PL_do_undump) {
1689
1690         /* Come here if running an undumped a.out. */
1691
1692         PL_origfilename = savepv(argv[0]);
1693         PL_do_undump = FALSE;
1694         cxstack_ix = -1;                /* start label stack again */
1695         init_ids();
1696         assert (!TAINT_get);
1697         TAINT;
1698         set_caret_X();
1699         TAINT_NOT;
1700         init_postdump_symbols(argc,argv,env);
1701         return 0;
1702     }
1703
1704     if (PL_main_root) {
1705         op_free(PL_main_root);
1706         PL_main_root = NULL;
1707     }
1708     PL_main_start = NULL;
1709     SvREFCNT_dec(PL_main_cv);
1710     PL_main_cv = NULL;
1711
1712     time(&PL_basetime);
1713     oldscope = PL_scopestack_ix;
1714     PL_dowarn = G_WARN_OFF;
1715
1716     JMPENV_PUSH(ret);
1717     switch (ret) {
1718     case 0:
1719         parse_body(env,xsinit);
1720         if (PL_unitcheckav) {
1721             call_list(oldscope, PL_unitcheckav);
1722         }
1723         if (PL_checkav) {
1724             PERL_SET_PHASE(PERL_PHASE_CHECK);
1725             call_list(oldscope, PL_checkav);
1726         }
1727         ret = 0;
1728         break;
1729     case 1:
1730         STATUS_ALL_FAILURE;
1731         /* FALLTHROUGH */
1732     case 2:
1733         /* my_exit() was called */
1734         while (PL_scopestack_ix > oldscope)
1735             LEAVE;
1736         FREETMPS;
1737         SET_CURSTASH(PL_defstash);
1738         if (PL_unitcheckav) {
1739             call_list(oldscope, PL_unitcheckav);
1740         }
1741         if (PL_checkav) {
1742             PERL_SET_PHASE(PERL_PHASE_CHECK);
1743             call_list(oldscope, PL_checkav);
1744         }
1745         ret = STATUS_EXIT;
1746         break;
1747     case 3:
1748         PerlIO_printf(Perl_error_log, "panic: top_env\n");
1749         ret = 1;
1750         break;
1751     }
1752     JMPENV_POP;
1753     return ret;
1754 }
1755
1756 /* This needs to stay in perl.c, as perl.c is compiled with different flags for
1757    miniperl, and we need to see those flags reflected in the values here.  */
1758
1759 /* What this returns is subject to change.  Use the public interface in Config.
1760  */
1761 static void
1762 S_Internals_V(pTHX_ CV *cv)
1763 {
1764     dXSARGS;
1765 #ifdef LOCAL_PATCH_COUNT
1766     const int local_patch_count = LOCAL_PATCH_COUNT;
1767 #else
1768     const int local_patch_count = 0;
1769 #endif
1770     const int entries = 3 + local_patch_count;
1771     int i;
1772     static const char non_bincompat_options[] = 
1773 #  ifdef DEBUGGING
1774                              " DEBUGGING"
1775 #  endif
1776 #  ifdef NO_MATHOMS
1777                              " NO_MATHOMS"
1778 #  endif
1779 #  ifdef NO_HASH_SEED
1780                              " NO_HASH_SEED"
1781 #  endif
1782 #  ifdef NO_TAINT_SUPPORT
1783                              " NO_TAINT_SUPPORT"
1784 #  endif
1785 #  ifdef PERL_BOOL_AS_CHAR
1786                              " PERL_BOOL_AS_CHAR"
1787 #  endif
1788 #  ifdef PERL_COPY_ON_WRITE
1789                              " PERL_COPY_ON_WRITE"
1790 #  endif
1791 #  ifdef PERL_DISABLE_PMC
1792                              " PERL_DISABLE_PMC"
1793 #  endif
1794 #  ifdef PERL_DONT_CREATE_GVSV
1795                              " PERL_DONT_CREATE_GVSV"
1796 #  endif
1797 #  ifdef PERL_EXTERNAL_GLOB
1798                              " PERL_EXTERNAL_GLOB"
1799 #  endif
1800 #  ifdef PERL_HASH_FUNC_SIPHASH
1801                              " PERL_HASH_FUNC_SIPHASH"
1802 #  endif
1803 #  ifdef PERL_HASH_FUNC_SDBM
1804                              " PERL_HASH_FUNC_SDBM"
1805 #  endif
1806 #  ifdef PERL_HASH_FUNC_DJB2
1807                              " PERL_HASH_FUNC_DJB2"
1808 #  endif
1809 #  ifdef PERL_HASH_FUNC_SUPERFAST
1810                              " PERL_HASH_FUNC_SUPERFAST"
1811 #  endif
1812 #  ifdef PERL_HASH_FUNC_MURMUR3
1813                              " PERL_HASH_FUNC_MURMUR3"
1814 #  endif
1815 #  ifdef PERL_HASH_FUNC_ONE_AT_A_TIME
1816                              " PERL_HASH_FUNC_ONE_AT_A_TIME"
1817 #  endif
1818 #  ifdef PERL_HASH_FUNC_ONE_AT_A_TIME_HARD
1819                              " PERL_HASH_FUNC_ONE_AT_A_TIME_HARD"
1820 #  endif
1821 #  ifdef PERL_HASH_FUNC_ONE_AT_A_TIME_OLD
1822                              " PERL_HASH_FUNC_ONE_AT_A_TIME_OLD"
1823 #  endif
1824 #  ifdef PERL_IS_MINIPERL
1825                              " PERL_IS_MINIPERL"
1826 #  endif
1827 #  ifdef PERL_MALLOC_WRAP
1828                              " PERL_MALLOC_WRAP"
1829 #  endif
1830 #  ifdef PERL_MEM_LOG
1831                              " PERL_MEM_LOG"
1832 #  endif
1833 #  ifdef PERL_MEM_LOG_NOIMPL
1834                              " PERL_MEM_LOG_NOIMPL"
1835 #  endif
1836 #  ifdef PERL_OP_PARENT
1837                              " PERL_OP_PARENT"
1838 #  endif
1839 #  ifdef PERL_PERTURB_KEYS_DETERMINISTIC
1840                              " PERL_PERTURB_KEYS_DETERMINISTIC"
1841 #  endif
1842 #  ifdef PERL_PERTURB_KEYS_DISABLED
1843                              " PERL_PERTURB_KEYS_DISABLED"
1844 #  endif
1845 #  ifdef PERL_PERTURB_KEYS_RANDOM
1846                              " PERL_PERTURB_KEYS_RANDOM"
1847 #  endif
1848 #  ifdef PERL_PRESERVE_IVUV
1849                              " PERL_PRESERVE_IVUV"
1850 #  endif
1851 #  ifdef PERL_RELOCATABLE_INCPUSH
1852                              " PERL_RELOCATABLE_INCPUSH"
1853 #  endif
1854 #  ifdef PERL_USE_DEVEL
1855                              " PERL_USE_DEVEL"
1856 #  endif
1857 #  ifdef PERL_USE_SAFE_PUTENV
1858                              " PERL_USE_SAFE_PUTENV"
1859 #  endif
1860 #  ifdef SILENT_NO_TAINT_SUPPORT
1861                              " SILENT_NO_TAINT_SUPPORT"
1862 #  endif
1863 #  ifdef UNLINK_ALL_VERSIONS
1864                              " UNLINK_ALL_VERSIONS"
1865 #  endif
1866 #  ifdef USE_ATTRIBUTES_FOR_PERLIO
1867                              " USE_ATTRIBUTES_FOR_PERLIO"
1868 #  endif
1869 #  ifdef USE_FAST_STDIO
1870                              " USE_FAST_STDIO"
1871 #  endif               
1872 #  ifdef USE_HASH_SEED_EXPLICIT
1873                              " USE_HASH_SEED_EXPLICIT"
1874 #  endif
1875 #  ifdef USE_LOCALE
1876                              " USE_LOCALE"
1877 #  endif
1878 #  ifdef USE_LOCALE_CTYPE
1879                              " USE_LOCALE_CTYPE"
1880 #  endif
1881 #  ifdef WIN32_NO_REGISTRY
1882                              " USE_NO_REGISTRY"
1883 #  endif
1884 #  ifdef USE_PERL_ATOF
1885                              " USE_PERL_ATOF"
1886 #  endif               
1887 #  ifdef USE_SITECUSTOMIZE
1888                              " USE_SITECUSTOMIZE"
1889 #  endif               
1890         ;
1891     PERL_UNUSED_ARG(cv);
1892     PERL_UNUSED_VAR(items);
1893
1894     EXTEND(SP, entries);
1895
1896     PUSHs(sv_2mortal(newSVpv(PL_bincompat_options, 0)));
1897     PUSHs(Perl_newSVpvn_flags(aTHX_ non_bincompat_options,
1898                               sizeof(non_bincompat_options) - 1, SVs_TEMP));
1899
1900 #ifndef PERL_BUILD_DATE
1901 #  ifdef __DATE__
1902 #    ifdef __TIME__
1903 #      define PERL_BUILD_DATE __DATE__ " " __TIME__
1904 #    else
1905 #      define PERL_BUILD_DATE __DATE__
1906 #    endif
1907 #  endif
1908 #endif
1909
1910 #ifdef PERL_BUILD_DATE
1911     PUSHs(Perl_newSVpvn_flags(aTHX_
1912                               STR_WITH_LEN("Compiled at " PERL_BUILD_DATE),
1913                               SVs_TEMP));
1914 #else
1915     PUSHs(&PL_sv_undef);
1916 #endif
1917
1918     for (i = 1; i <= local_patch_count; i++) {
1919         /* This will be an undef, if PL_localpatches[i] is NULL.  */
1920         PUSHs(sv_2mortal(newSVpv(PL_localpatches[i], 0)));
1921     }
1922
1923     XSRETURN(entries);
1924 }
1925
1926 #define INCPUSH_UNSHIFT                 0x01
1927 #define INCPUSH_ADD_OLD_VERS            0x02
1928 #define INCPUSH_ADD_VERSIONED_SUB_DIRS  0x04
1929 #define INCPUSH_ADD_ARCHONLY_SUB_DIRS   0x08
1930 #define INCPUSH_NOT_BASEDIR             0x10
1931 #define INCPUSH_CAN_RELOCATE            0x20
1932 #define INCPUSH_ADD_SUB_DIRS    \
1933     (INCPUSH_ADD_VERSIONED_SUB_DIRS|INCPUSH_ADD_ARCHONLY_SUB_DIRS)
1934
1935 STATIC void *
1936 S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
1937 {
1938     dVAR;
1939     PerlIO *rsfp;
1940     int argc = PL_origargc;
1941     char **argv = PL_origargv;
1942     const char *scriptname = NULL;
1943     bool dosearch = FALSE;
1944     char c;
1945     bool doextract = FALSE;
1946     const char *cddir = NULL;
1947 #ifdef USE_SITECUSTOMIZE
1948     bool minus_f = FALSE;
1949 #endif
1950     SV *linestr_sv = NULL;
1951     bool add_read_e_script = FALSE;
1952     U32 lex_start_flags = 0;
1953
1954     PERL_SET_PHASE(PERL_PHASE_START);
1955
1956     init_main_stash();
1957
1958     {
1959         const char *s;
1960     for (argc--,argv++; argc > 0; argc--,argv++) {
1961         if (argv[0][0] != '-' || !argv[0][1])
1962             break;
1963         s = argv[0]+1;
1964       reswitch:
1965         switch ((c = *s)) {
1966         case 'C':
1967 #ifndef PERL_STRICT_CR
1968         case '\r':
1969 #endif
1970         case ' ':
1971         case '0':
1972         case 'F':
1973         case 'a':
1974         case 'c':
1975         case 'd':
1976         case 'D':
1977         case 'h':
1978         case 'i':
1979         case 'l':
1980         case 'M':
1981         case 'm':
1982         case 'n':
1983         case 'p':
1984         case 's':
1985         case 'u':
1986         case 'U':
1987         case 'v':
1988         case 'W':
1989         case 'X':
1990         case 'w':
1991             if ((s = moreswitches(s)))
1992                 goto reswitch;
1993             break;
1994
1995         case 't':
1996 #if defined(SILENT_NO_TAINT_SUPPORT)
1997             /* silently ignore */
1998 #elif defined(NO_TAINT_SUPPORT)
1999             Perl_croak_nocontext("This perl was compiled without taint support. "
2000                        "Cowardly refusing to run with -t or -T flags");
2001 #else
2002             CHECK_MALLOC_TOO_LATE_FOR('t');
2003             if( !TAINTING_get ) {
2004                  TAINT_WARN_set(TRUE);
2005                  TAINTING_set(TRUE);
2006             }
2007 #endif
2008             s++;
2009             goto reswitch;
2010         case 'T':
2011 #if defined(SILENT_NO_TAINT_SUPPORT)
2012             /* silently ignore */
2013 #elif defined(NO_TAINT_SUPPORT)
2014             Perl_croak_nocontext("This perl was compiled without taint support. "
2015                        "Cowardly refusing to run with -t or -T flags");
2016 #else
2017             CHECK_MALLOC_TOO_LATE_FOR('T');
2018             TAINTING_set(TRUE);
2019             TAINT_WARN_set(FALSE);
2020 #endif
2021             s++;
2022             goto reswitch;
2023
2024         case 'E':
2025             PL_minus_E = TRUE;
2026             /* FALLTHROUGH */
2027         case 'e':
2028             forbid_setid('e', FALSE);
2029             if (!PL_e_script) {
2030                 PL_e_script = newSVpvs("");
2031                 add_read_e_script = TRUE;
2032             }
2033             if (*++s)
2034                 sv_catpv(PL_e_script, s);
2035             else if (argv[1]) {
2036                 sv_catpv(PL_e_script, argv[1]);
2037                 argc--,argv++;
2038             }
2039             else
2040                 Perl_croak(aTHX_ "No code specified for -%c", c);
2041             sv_catpvs(PL_e_script, "\n");
2042             break;
2043
2044         case 'f':
2045 #ifdef USE_SITECUSTOMIZE
2046             minus_f = TRUE;
2047 #endif
2048             s++;
2049             goto reswitch;
2050
2051         case 'I':       /* -I handled both here and in moreswitches() */
2052             forbid_setid('I', FALSE);
2053             if (!*++s && (s=argv[1]) != NULL) {
2054                 argc--,argv++;
2055             }
2056             if (s && *s) {
2057                 STRLEN len = strlen(s);
2058                 incpush(s, len, INCPUSH_ADD_SUB_DIRS|INCPUSH_ADD_OLD_VERS);
2059             }
2060             else
2061                 Perl_croak(aTHX_ "No directory specified for -I");
2062             break;
2063         case 'S':
2064             forbid_setid('S', FALSE);
2065             dosearch = TRUE;
2066             s++;
2067             goto reswitch;
2068         case 'V':
2069             {
2070                 SV *opts_prog;
2071
2072                 if (*++s != ':')  {
2073                     opts_prog = newSVpvs("use Config; Config::_V()");
2074                 }
2075                 else {
2076                     ++s;
2077                     opts_prog = Perl_newSVpvf(aTHX_
2078                                               "use Config; Config::config_vars(qw%c%s%c)",
2079                                               0, s, 0);
2080                     s += strlen(s);
2081                 }
2082                 Perl_av_create_and_push(aTHX_ &PL_preambleav, opts_prog);
2083                 /* don't look for script or read stdin */
2084                 scriptname = BIT_BUCKET;
2085                 goto reswitch;
2086             }
2087         case 'x':
2088             doextract = TRUE;
2089             s++;
2090             if (*s)
2091                 cddir = s;
2092             break;
2093         case 0:
2094             break;
2095         case '-':
2096             if (!*++s || isSPACE(*s)) {
2097                 argc--,argv++;
2098                 goto switch_end;
2099             }
2100             /* catch use of gnu style long options.
2101                Both of these exit immediately.  */
2102             if (strEQ(s, "version"))
2103                 minus_v();
2104             if (strEQ(s, "help"))
2105                 usage();
2106             s--;
2107             /* FALLTHROUGH */
2108         default:
2109             Perl_croak(aTHX_ "Unrecognized switch: -%s  (-h will show valid options)",s);
2110         }
2111     }
2112     }
2113
2114   switch_end:
2115
2116     {
2117         char *s;
2118
2119     if (
2120 #ifndef SECURE_INTERNAL_GETENV
2121         !TAINTING_get &&
2122 #endif
2123         (s = PerlEnv_getenv("PERL5OPT")))
2124     {
2125         /* s points to static memory in getenv(), which may be overwritten at
2126          * any time; use a mortal copy instead */
2127         s = SvPVX(sv_2mortal(newSVpv(s, 0)));
2128
2129         while (isSPACE(*s))
2130             s++;
2131         if (*s == '-' && *(s+1) == 'T') {
2132 #if defined(SILENT_NO_TAINT_SUPPORT)
2133             /* silently ignore */
2134 #elif defined(NO_TAINT_SUPPORT)
2135             Perl_croak_nocontext("This perl was compiled without taint support. "
2136                        "Cowardly refusing to run with -t or -T flags");
2137 #else
2138             CHECK_MALLOC_TOO_LATE_FOR('T');
2139             TAINTING_set(TRUE);
2140             TAINT_WARN_set(FALSE);
2141 #endif
2142         }
2143         else {
2144             char *popt_copy = NULL;
2145             while (s && *s) {
2146                 const char *d;
2147                 while (isSPACE(*s))
2148                     s++;
2149                 if (*s == '-') {
2150                     s++;
2151                     if (isSPACE(*s))
2152                         continue;
2153                 }
2154                 d = s;
2155                 if (!*s)
2156                     break;
2157                 if (!strchr("CDIMUdmtwW", *s))
2158                     Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s);
2159                 while (++s && *s) {
2160                     if (isSPACE(*s)) {
2161                         if (!popt_copy) {
2162                             popt_copy = SvPVX(sv_2mortal(newSVpv(d,0)));
2163                             s = popt_copy + (s - d);
2164                             d = popt_copy;
2165                         }
2166                         *s++ = '\0';
2167                         break;
2168                     }
2169                 }
2170                 if (*d == 't') {
2171 #if defined(SILENT_NO_TAINT_SUPPORT)
2172             /* silently ignore */
2173 #elif defined(NO_TAINT_SUPPORT)
2174                     Perl_croak_nocontext("This perl was compiled without taint support. "
2175                                "Cowardly refusing to run with -t or -T flags");
2176 #else
2177                     if( !TAINTING_get) {
2178                         TAINT_WARN_set(TRUE);
2179                         TAINTING_set(TRUE);
2180                     }
2181 #endif
2182                 } else {
2183                     moreswitches(d);
2184                 }
2185             }
2186         }
2187     }
2188     }
2189
2190     /* Set $^X early so that it can be used for relocatable paths in @INC  */
2191     /* and for SITELIB_EXP in USE_SITECUSTOMIZE                            */
2192     assert (!TAINT_get);
2193     TAINT;
2194     set_caret_X();
2195     TAINT_NOT;
2196
2197 #if defined(USE_SITECUSTOMIZE)
2198     if (!minus_f) {
2199         /* The games with local $! are to avoid setting errno if there is no
2200            sitecustomize script.  "q%c...%c", 0, ..., 0 becomes "q\0...\0",
2201            ie a q() operator with a NUL byte as a the delimiter. This avoids
2202            problems with pathnames containing (say) '  */
2203 #  ifdef PERL_IS_MINIPERL
2204         AV *const inc = GvAV(PL_incgv);
2205         SV **const inc0 = inc ? av_fetch(inc, 0, FALSE) : NULL;
2206
2207         if (inc0) {
2208             /* if lib/buildcustomize.pl exists, it should not fail. If it does,
2209                it should be reported immediately as a build failure.  */
2210             (void)Perl_av_create_and_unshift_one(aTHX_ &PL_preambleav,
2211                                                  Perl_newSVpvf(aTHX_
2212                 "BEGIN { my $f = q%c%s%" SVf "/buildcustomize.pl%c; "
2213                         "do {local $!; -f $f }"
2214                         " and do $f || die $@ || qq '$f: $!' }",
2215                                 0, (TAINTING_get ? "./" : ""), SVfARG(*inc0), 0));
2216         }
2217 #  else
2218         /* SITELIB_EXP is a function call on Win32.  */
2219         const char *const raw_sitelib = SITELIB_EXP;
2220         if (raw_sitelib) {
2221             /* process .../.. if PERL_RELOCATABLE_INC is defined */
2222             SV *sitelib_sv = mayberelocate(raw_sitelib, strlen(raw_sitelib),
2223                                            INCPUSH_CAN_RELOCATE);
2224             const char *const sitelib = SvPVX(sitelib_sv);
2225             (void)Perl_av_create_and_unshift_one(aTHX_ &PL_preambleav,
2226                                                  Perl_newSVpvf(aTHX_
2227                                                                "BEGIN { do {local $!; -f q%c%s/sitecustomize.pl%c} && do q%c%s/sitecustomize.pl%c }",
2228                                                                0, SVfARG(sitelib), 0,
2229                                                                0, SVfARG(sitelib), 0));
2230             assert (SvREFCNT(sitelib_sv) == 1);
2231             SvREFCNT_dec(sitelib_sv);
2232         }
2233 #  endif
2234     }
2235 #endif
2236
2237     if (!scriptname)
2238         scriptname = argv[0];
2239     if (PL_e_script) {
2240         argc++,argv--;
2241         scriptname = BIT_BUCKET;        /* don't look for script or read stdin */
2242     }
2243     else if (scriptname == NULL) {
2244 #ifdef MSDOS
2245         if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) )
2246             moreswitches("h");
2247 #endif
2248         scriptname = "-";
2249     }
2250
2251     assert (!TAINT_get);
2252     init_perllib();
2253
2254     {
2255         bool suidscript = FALSE;
2256
2257         rsfp = open_script(scriptname, dosearch, &suidscript);
2258         if (!rsfp) {
2259             rsfp = PerlIO_stdin();
2260             lex_start_flags = LEX_DONT_CLOSE_RSFP;
2261         }
2262
2263         validate_suid(rsfp);
2264
2265 #ifndef PERL_MICRO
2266 #  if defined(SIGCHLD) || defined(SIGCLD)
2267         {
2268 #  ifndef SIGCHLD
2269 #    define SIGCHLD SIGCLD
2270 #  endif
2271             Sighandler_t sigstate = rsignal_state(SIGCHLD);
2272             if (sigstate == (Sighandler_t) SIG_IGN) {
2273                 Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL),
2274                                "Can't ignore signal CHLD, forcing to default");
2275                 (void)rsignal(SIGCHLD, (Sighandler_t)SIG_DFL);
2276             }
2277         }
2278 #  endif
2279 #endif
2280
2281         if (doextract) {
2282
2283             /* This will croak if suidscript is true, as -x cannot be used with
2284                setuid scripts.  */
2285             forbid_setid('x', suidscript);
2286             /* Hence you can't get here if suidscript is true */
2287
2288             linestr_sv = newSV_type(SVt_PV);
2289             lex_start_flags |= LEX_START_COPIED;
2290             find_beginning(linestr_sv, rsfp);
2291             if (cddir && PerlDir_chdir( (char *)cddir ) < 0)
2292                 Perl_croak(aTHX_ "Can't chdir to %s",cddir);
2293         }
2294     }
2295
2296     PL_main_cv = PL_compcv = MUTABLE_CV(newSV_type(SVt_PVCV));
2297     CvUNIQUE_on(PL_compcv);
2298
2299     CvPADLIST_set(PL_compcv, pad_new(0));
2300
2301     PL_isarev = newHV();
2302
2303     boot_core_PerlIO();
2304     boot_core_UNIVERSAL();
2305     boot_core_mro();
2306     newXS("Internals::V", S_Internals_V, __FILE__);
2307
2308     if (xsinit)
2309         (*xsinit)(aTHX);        /* in case linked C routines want magical variables */
2310 #ifndef PERL_MICRO
2311 #if defined(VMS) || defined(WIN32) || defined(DJGPP) || defined(__CYGWIN__) || defined(SYMBIAN)
2312     init_os_extras();
2313 #endif
2314 #endif
2315
2316 #ifdef USE_SOCKS
2317 #   ifdef HAS_SOCKS5_INIT
2318     socks5_init(argv[0]);
2319 #   else
2320     SOCKSinit(argv[0]);
2321 #   endif
2322 #endif
2323
2324     init_predump_symbols();
2325     /* init_postdump_symbols not currently designed to be called */
2326     /* more than once (ENV isn't cleared first, for example)     */
2327     /* But running with -u leaves %ENV & @ARGV undefined!    XXX */
2328     if (!PL_do_undump)
2329         init_postdump_symbols(argc,argv,env);
2330
2331     /* PL_unicode is turned on by -C, or by $ENV{PERL_UNICODE},
2332      * or explicitly in some platforms.
2333      * PL_utf8locale is conditionally turned on by
2334      * locale.c:Perl_init_i18nl10n() if the environment
2335      * look like the user wants to use UTF-8. */
2336 #if defined(__SYMBIAN32__)
2337     PL_unicode = PERL_UNICODE_STD_FLAG; /* See PERL_SYMBIAN_CONSOLE_UTF8. */
2338 #endif
2339 #  ifndef PERL_IS_MINIPERL
2340     if (PL_unicode) {
2341          /* Requires init_predump_symbols(). */
2342          if (!(PL_unicode & PERL_UNICODE_LOCALE_FLAG) || PL_utf8locale) {
2343               IO* io;
2344               PerlIO* fp;
2345               SV* sv;
2346
2347               /* Turn on UTF-8-ness on STDIN, STDOUT, STDERR
2348                * and the default open disciplines. */
2349               if ((PL_unicode & PERL_UNICODE_STDIN_FLAG) &&
2350                   PL_stdingv  && (io = GvIO(PL_stdingv)) &&
2351                   (fp = IoIFP(io)))
2352                    PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
2353               if ((PL_unicode & PERL_UNICODE_STDOUT_FLAG) &&
2354                   PL_defoutgv && (io = GvIO(PL_defoutgv)) &&
2355                   (fp = IoOFP(io)))
2356                    PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
2357               if ((PL_unicode & PERL_UNICODE_STDERR_FLAG) &&
2358                   PL_stderrgv && (io = GvIO(PL_stderrgv)) &&
2359                   (fp = IoOFP(io)))
2360                    PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
2361               if ((PL_unicode & PERL_UNICODE_INOUT_FLAG) &&
2362                   (sv = GvSV(gv_fetchpvs("\017PEN", GV_ADD|GV_NOTQUAL,
2363                                          SVt_PV)))) {
2364                    U32 in  = PL_unicode & PERL_UNICODE_IN_FLAG;
2365                    U32 out = PL_unicode & PERL_UNICODE_OUT_FLAG;
2366                    if (in) {
2367                         if (out)
2368                              sv_setpvs(sv, ":utf8\0:utf8");
2369                         else
2370                              sv_setpvs(sv, ":utf8\0");
2371                    }
2372                    else if (out)
2373                         sv_setpvs(sv, "\0:utf8");
2374                    SvSETMAGIC(sv);
2375               }
2376          }
2377     }
2378 #endif
2379
2380     {
2381         const char *s;
2382     if ((s = PerlEnv_getenv("PERL_SIGNALS"))) {
2383          if (strEQ(s, "unsafe"))
2384               PL_signals |=  PERL_SIGNALS_UNSAFE_FLAG;
2385          else if (strEQ(s, "safe"))
2386               PL_signals &= ~PERL_SIGNALS_UNSAFE_FLAG;
2387          else
2388               Perl_croak(aTHX_ "PERL_SIGNALS illegal: \"%s\"", s);
2389     }
2390     }
2391
2392
2393     lex_start(linestr_sv, rsfp, lex_start_flags);
2394     SvREFCNT_dec(linestr_sv);
2395
2396     PL_subname = newSVpvs("main");
2397
2398     if (add_read_e_script)
2399         filter_add(read_e_script, NULL);
2400
2401     /* now parse the script */
2402
2403     SETERRNO(0,SS_NORMAL);
2404     if (yyparse(GRAMPROG) || PL_parser->error_count) {
2405         abort_execution("", PL_origfilename);
2406     }
2407     CopLINE_set(PL_curcop, 0);
2408     SET_CURSTASH(PL_defstash);
2409     if (PL_e_script) {
2410         SvREFCNT_dec(PL_e_script);
2411         PL_e_script = NULL;
2412     }
2413
2414     if (PL_do_undump)
2415         my_unexec();
2416
2417     if (isWARN_ONCE) {
2418         SAVECOPFILE(PL_curcop);
2419         SAVECOPLINE(PL_curcop);
2420         gv_check(PL_defstash);
2421     }
2422
2423     LEAVE;
2424     FREETMPS;
2425
2426 #ifdef MYMALLOC
2427     {
2428         const char *s;
2429         UV uv;
2430         s = PerlEnv_getenv("PERL_DEBUG_MSTATS");
2431         if (s && grok_atoUV(s, &uv, NULL) && uv >= 2)
2432             dump_mstats("after compilation:");
2433     }
2434 #endif
2435
2436     ENTER;
2437     PL_restartjmpenv = NULL;
2438     PL_restartop = 0;
2439     return NULL;
2440 }
2441
2442 /*
2443 =for apidoc perl_run
2444
2445 Tells a Perl interpreter to run.  See L<perlembed>.
2446
2447 =cut
2448 */
2449
2450 int
2451 perl_run(pTHXx)
2452 {
2453     I32 oldscope;
2454     int ret = 0;
2455     dJMPENV;
2456
2457     PERL_ARGS_ASSERT_PERL_RUN;
2458 #ifndef MULTIPLICITY
2459     PERL_UNUSED_ARG(my_perl);
2460 #endif
2461
2462     oldscope = PL_scopestack_ix;
2463 #ifdef VMS
2464     VMSISH_HUSHED = 0;
2465 #endif
2466
2467     JMPENV_PUSH(ret);
2468     switch (ret) {
2469     case 1:
2470         cxstack_ix = -1;                /* start context stack again */
2471         goto redo_body;
2472     case 0:                             /* normal completion */
2473  redo_body:
2474         run_body(oldscope);
2475         /* FALLTHROUGH */
2476     case 2:                             /* my_exit() */
2477         while (PL_scopestack_ix > oldscope)
2478             LEAVE;
2479         FREETMPS;
2480         SET_CURSTASH(PL_defstash);
2481         if (!(PL_exit_flags & PERL_EXIT_DESTRUCT_END) &&
2482             PL_endav && !PL_minus_c) {
2483             PERL_SET_PHASE(PERL_PHASE_END);
2484             call_list(oldscope, PL_endav);
2485         }
2486 #ifdef MYMALLOC
2487         if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
2488             dump_mstats("after execution:  ");
2489 #endif
2490         ret = STATUS_EXIT;
2491         break;
2492     case 3:
2493         if (PL_restartop) {
2494             POPSTACK_TO(PL_mainstack);
2495             goto redo_body;
2496         }
2497         PerlIO_printf(Perl_error_log, "panic: restartop in perl_run\n");
2498         FREETMPS;
2499         ret = 1;
2500         break;
2501     }
2502
2503     JMPENV_POP;
2504     return ret;
2505 }
2506
2507 STATIC void
2508 S_run_body(pTHX_ I32 oldscope)
2509 {
2510     DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support (0x%x).\n",
2511                     PL_sawampersand ? "Enabling" : "Omitting",
2512                     (unsigned int)(PL_sawampersand)));
2513
2514     if (!PL_restartop) {
2515 #ifdef DEBUGGING
2516         if (DEBUG_x_TEST || DEBUG_B_TEST)
2517             dump_all_perl(!DEBUG_B_TEST);
2518         if (!DEBUG_q_TEST)
2519           PERL_DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
2520 #endif
2521
2522         if (PL_minus_c) {
2523             PerlIO_printf(Perl_error_log, "%s syntax OK\n", PL_origfilename);
2524             my_exit(0);
2525         }
2526         if (PERLDB_SINGLE && PL_DBsingle)
2527             PL_DBsingle_iv = 1;
2528         if (PL_initav) {
2529             PERL_SET_PHASE(PERL_PHASE_INIT);
2530             call_list(oldscope, PL_initav);
2531         }
2532 #ifdef PERL_DEBUG_READONLY_OPS
2533         if (PL_main_root && PL_main_root->op_slabbed)
2534             Slab_to_ro(OpSLAB(PL_main_root));
2535 #endif
2536     }
2537
2538     /* do it */
2539
2540     PERL_SET_PHASE(PERL_PHASE_RUN);
2541
2542     if (PL_restartop) {
2543         PL_restartjmpenv = NULL;
2544         PL_op = PL_restartop;
2545         PL_restartop = 0;
2546         CALLRUNOPS(aTHX);
2547     }
2548     else if (PL_main_start) {
2549         CvDEPTH(PL_main_cv) = 1;
2550         PL_op = PL_main_start;
2551         CALLRUNOPS(aTHX);
2552     }
2553     my_exit(0);
2554     NOT_REACHED; /* NOTREACHED */
2555 }
2556
2557 /*
2558 =head1 SV Manipulation Functions
2559
2560 =for apidoc p||get_sv
2561
2562 Returns the SV of the specified Perl scalar.  C<flags> are passed to
2563 C<gv_fetchpv>.  If C<GV_ADD> is set and the
2564 Perl variable does not exist then it will be created.  If C<flags> is zero
2565 and the variable does not exist then NULL is returned.
2566
2567 =cut
2568 */
2569
2570 SV*
2571 Perl_get_sv(pTHX_ const char *name, I32 flags)
2572 {
2573     GV *gv;
2574
2575     PERL_ARGS_ASSERT_GET_SV;
2576
2577     gv = gv_fetchpv(name, flags, SVt_PV);
2578     if (gv)
2579         return GvSV(gv);
2580     return NULL;
2581 }
2582
2583 /*
2584 =head1 Array Manipulation Functions
2585
2586 =for apidoc p||get_av
2587
2588 Returns the AV of the specified Perl global or package array with the given
2589 name (so it won't work on lexical variables).  C<flags> are passed 
2590 to C<gv_fetchpv>.  If C<GV_ADD> is set and the
2591 Perl variable does not exist then it will be created.  If C<flags> is zero
2592 and the variable does not exist then NULL is returned.
2593
2594 Perl equivalent: C<@{"$name"}>.
2595
2596 =cut
2597 */
2598
2599 AV*
2600 Perl_get_av(pTHX_ const char *name, I32 flags)
2601 {
2602     GV* const gv = gv_fetchpv(name, flags, SVt_PVAV);
2603
2604     PERL_ARGS_ASSERT_GET_AV;
2605
2606     if (flags)
2607         return GvAVn(gv);
2608     if (gv)
2609         return GvAV(gv);
2610     return NULL;
2611 }
2612
2613 /*
2614 =head1 Hash Manipulation Functions
2615
2616 =for apidoc p||get_hv
2617
2618 Returns the HV of the specified Perl hash.  C<flags> are passed to
2619 C<gv_fetchpv>.  If C<GV_ADD> is set and the
2620 Perl variable does not exist then it will be created.  If C<flags> is zero
2621 and the variable does not exist then C<NULL> is returned.
2622
2623 =cut
2624 */
2625
2626 HV*
2627 Perl_get_hv(pTHX_ const char *name, I32 flags)
2628 {
2629     GV* const gv = gv_fetchpv(name, flags, SVt_PVHV);
2630
2631     PERL_ARGS_ASSERT_GET_HV;
2632
2633     if (flags)
2634         return GvHVn(gv);
2635     if (gv)
2636         return GvHV(gv);
2637     return NULL;
2638 }
2639
2640 /*
2641 =head1 CV Manipulation Functions
2642
2643 =for apidoc p||get_cvn_flags
2644
2645 Returns the CV of the specified Perl subroutine.  C<flags> are passed to
2646 C<gv_fetchpvn_flags>.  If C<GV_ADD> is set and the Perl subroutine does not
2647 exist then it will be declared (which has the same effect as saying
2648 C<sub name;>).  If C<GV_ADD> is not set and the subroutine does not exist
2649 then NULL is returned.
2650
2651 =for apidoc p||get_cv
2652
2653 Uses C<strlen> to get the length of C<name>, then calls C<get_cvn_flags>.
2654
2655 =cut
2656 */
2657
2658 CV*
2659 Perl_get_cvn_flags(pTHX_ const char *name, STRLEN len, I32 flags)
2660 {
2661     GV* const gv = gv_fetchpvn_flags(name, len, flags, SVt_PVCV);
2662
2663     PERL_ARGS_ASSERT_GET_CVN_FLAGS;
2664
2665     /* XXX this is probably not what they think they're getting.
2666      * It has the same effect as "sub name;", i.e. just a forward
2667      * declaration! */
2668     if ((flags & ~GV_NOADD_MASK) && !GvCVu(gv)) {
2669         return newSTUB(gv,0);
2670     }
2671     if (gv)
2672         return GvCVu(gv);
2673     return NULL;
2674 }
2675
2676 /* Nothing in core calls this now, but we can't replace it with a macro and
2677    move it to mathoms.c as a macro would evaluate name twice.  */
2678 CV*
2679 Perl_get_cv(pTHX_ const char *name, I32 flags)
2680 {
2681     PERL_ARGS_ASSERT_GET_CV;
2682
2683     return get_cvn_flags(name, strlen(name), flags);
2684 }
2685
2686 /* Be sure to refetch the stack pointer after calling these routines. */
2687
2688 /*
2689
2690 =head1 Callback Functions
2691
2692 =for apidoc p||call_argv
2693
2694 Performs a callback to the specified named and package-scoped Perl subroutine 
2695 with C<argv> (a C<NULL>-terminated array of strings) as arguments.  See
2696 L<perlcall>.
2697
2698 Approximate Perl equivalent: C<&{"$sub_name"}(@$argv)>.
2699
2700 =cut
2701 */
2702
2703 I32
2704 Perl_call_argv(pTHX_ const char *sub_name, I32 flags, char **argv)
2705
2706                         /* See G_* flags in cop.h */
2707                         /* null terminated arg list */
2708 {
2709     dSP;
2710
2711     PERL_ARGS_ASSERT_CALL_ARGV;
2712
2713     PUSHMARK(SP);
2714     while (*argv) {
2715         mXPUSHs(newSVpv(*argv,0));
2716         argv++;
2717     }
2718     PUTBACK;
2719     return call_pv(sub_name, flags);
2720 }
2721
2722 /*
2723 =for apidoc p||call_pv
2724
2725 Performs a callback to the specified Perl sub.  See L<perlcall>.
2726
2727 =cut
2728 */
2729
2730 I32
2731 Perl_call_pv(pTHX_ const char *sub_name, I32 flags)
2732                         /* name of the subroutine */
2733                         /* See G_* flags in cop.h */
2734 {
2735     PERL_ARGS_ASSERT_CALL_PV;
2736
2737     return call_sv(MUTABLE_SV(get_cv(sub_name, GV_ADD)), flags);
2738 }
2739
2740 /*
2741 =for apidoc p||call_method
2742
2743 Performs a callback to the specified Perl method.  The blessed object must
2744 be on the stack.  See L<perlcall>.
2745
2746 =cut
2747 */
2748
2749 I32
2750 Perl_call_method(pTHX_ const char *methname, I32 flags)
2751                         /* name of the subroutine */
2752                         /* See G_* flags in cop.h */
2753 {
2754     STRLEN len;
2755     SV* sv;
2756     PERL_ARGS_ASSERT_CALL_METHOD;
2757
2758     len = strlen(methname);
2759     sv = flags & G_METHOD_NAMED
2760         ? sv_2mortal(newSVpvn_share(methname, len,0))
2761         : newSVpvn_flags(methname, len, SVs_TEMP);
2762
2763     return call_sv(sv, flags | G_METHOD);
2764 }
2765
2766 /* May be called with any of a CV, a GV, or an SV containing the name. */
2767 /*
2768 =for apidoc p||call_sv
2769
2770 Performs a callback to the Perl sub specified by the SV.
2771
2772 If neither the C<G_METHOD> nor C<G_METHOD_NAMED> flag is supplied, the
2773 SV may be any of a CV, a GV, a reference to a CV, a reference to a GV
2774 or C<SvPV(sv)> will be used as the name of the sub to call.
2775
2776 If the C<G_METHOD> flag is supplied, the SV may be a reference to a CV or
2777 C<SvPV(sv)> will be used as the name of the method to call.
2778
2779 If the C<G_METHOD_NAMED> flag is supplied, C<SvPV(sv)> will be used as
2780 the name of the method to call.
2781
2782 Some other values are treated specially for internal use and should
2783 not be depended on.
2784
2785 See L<perlcall>.
2786
2787 =cut
2788 */
2789
2790 I32
2791 Perl_call_sv(pTHX_ SV *sv, VOL I32 flags)
2792                         /* See G_* flags in cop.h */
2793 {
2794     dVAR;
2795     LOGOP myop;         /* fake syntax tree node */
2796     METHOP method_op;
2797     I32 oldmark;
2798     VOL I32 retval = 0;
2799     bool oldcatch = CATCH_GET;
2800     int ret;
2801     OP* const oldop = PL_op;
2802     dJMPENV;
2803
2804     PERL_ARGS_ASSERT_CALL_SV;
2805
2806     if (flags & G_DISCARD) {
2807         ENTER;
2808         SAVETMPS;
2809     }
2810     if (!(flags & G_WANT)) {
2811         /* Backwards compatibility - as G_SCALAR was 0, it could be omitted.
2812          */
2813         flags |= G_SCALAR;
2814     }
2815
2816     Zero(&myop, 1, LOGOP);
2817     if (!(flags & G_NOARGS))
2818         myop.op_flags |= OPf_STACKED;
2819     myop.op_flags |= OP_GIMME_REVERSE(flags);
2820     SAVEOP();
2821     PL_op = (OP*)&myop;
2822
2823     if (!(flags & G_METHOD_NAMED)) {
2824         dSP;
2825         EXTEND(SP, 1);
2826         PUSHs(sv);
2827         PUTBACK;
2828     }
2829     oldmark = TOPMARK;
2830
2831     if (PERLDB_SUB && PL_curstash != PL_debstash
2832            /* Handle first BEGIN of -d. */
2833           && (PL_DBcv || (PL_DBcv = GvCV(PL_DBsub)))
2834            /* Try harder, since this may have been a sighandler, thus
2835             * curstash may be meaningless. */
2836           && (SvTYPE(sv) != SVt_PVCV || CvSTASH((const CV *)sv) != PL_debstash)
2837           && !(flags & G_NODEBUG))
2838         myop.op_private |= OPpENTERSUB_DB;
2839
2840     if (flags & (G_METHOD|G_METHOD_NAMED)) {
2841         Zero(&method_op, 1, METHOP);
2842         method_op.op_next = (OP*)&myop;
2843         PL_op = (OP*)&method_op;
2844         if ( flags & G_METHOD_NAMED ) {
2845             method_op.op_ppaddr = PL_ppaddr[OP_METHOD_NAMED];
2846             method_op.op_type = OP_METHOD_NAMED;
2847             method_op.op_u.op_meth_sv = sv;
2848         } else {
2849             method_op.op_ppaddr = PL_ppaddr[OP_METHOD];
2850             method_op.op_type = OP_METHOD;
2851         }
2852         myop.op_ppaddr = PL_ppaddr[OP_ENTERSUB];
2853         myop.op_type = OP_ENTERSUB;
2854     }
2855
2856     if (!(flags & G_EVAL)) {
2857         CATCH_SET(TRUE);
2858         CALL_BODY_SUB((OP*)&myop);
2859         retval = PL_stack_sp - (PL_stack_base + oldmark);
2860         CATCH_SET(oldcatch);
2861     }
2862     else {
2863         I32 old_cxix;
2864         myop.op_other = (OP*)&myop;
2865         (void)POPMARK;
2866         old_cxix = cxstack_ix;
2867         create_eval_scope(NULL, flags|G_FAKINGEVAL);
2868         INCMARK;
2869
2870         JMPENV_PUSH(ret);
2871
2872         switch (ret) {
2873         case 0:
2874  redo_body:
2875             CALL_BODY_SUB((OP*)&myop);
2876             retval = PL_stack_sp - (PL_stack_base + oldmark);
2877             if (!(flags & G_KEEPERR)) {
2878                 CLEAR_ERRSV();
2879             }
2880             break;
2881         case 1:
2882             STATUS_ALL_FAILURE;
2883             /* FALLTHROUGH */
2884         case 2:
2885             /* my_exit() was called */
2886             SET_CURSTASH(PL_defstash);
2887             FREETMPS;
2888             JMPENV_POP;
2889             my_exit_jump();
2890             NOT_REACHED; /* NOTREACHED */
2891         case 3:
2892             if (PL_restartop) {
2893                 PL_restartjmpenv = NULL;
2894                 PL_op = PL_restartop;
2895                 PL_restartop = 0;
2896                 goto redo_body;
2897             }
2898             PL_stack_sp = PL_stack_base + oldmark;
2899             if ((flags & G_WANT) == G_ARRAY)
2900                 retval = 0;
2901             else {
2902                 retval = 1;
2903                 *++PL_stack_sp = &PL_sv_undef;
2904             }
2905             break;
2906         }
2907
2908         /* if we croaked, depending on how we croaked the eval scope
2909          * may or may not have already been popped */
2910         if (cxstack_ix > old_cxix) {
2911             assert(cxstack_ix == old_cxix + 1);
2912             assert(CxTYPE(CX_CUR()) == CXt_EVAL);
2913             delete_eval_scope();
2914         }
2915         JMPENV_POP;
2916     }
2917
2918     if (flags & G_DISCARD) {
2919         PL_stack_sp = PL_stack_base + oldmark;
2920         retval = 0;
2921         FREETMPS;
2922         LEAVE;
2923     }
2924     PL_op = oldop;
2925     return retval;
2926 }
2927
2928 /* Eval a string. The G_EVAL flag is always assumed. */
2929
2930 /*
2931 =for apidoc p||eval_sv
2932
2933 Tells Perl to C<eval> the string in the SV.  It supports the same flags
2934 as C<call_sv>, with the obvious exception of C<G_EVAL>.  See L<perlcall>.
2935
2936 =cut
2937 */
2938
2939 I32
2940 Perl_eval_sv(pTHX_ SV *sv, I32 flags)
2941
2942                         /* See G_* flags in cop.h */
2943 {
2944     dVAR;
2945     UNOP myop;          /* fake syntax tree node */
2946     VOL I32 oldmark;
2947     VOL I32 retval = 0;
2948     int ret;
2949     OP* const oldop = PL_op;
2950     dJMPENV;
2951
2952     PERL_ARGS_ASSERT_EVAL_SV;
2953
2954     if (flags & G_DISCARD) {
2955         ENTER;
2956         SAVETMPS;
2957     }
2958
2959     SAVEOP();
2960     PL_op = (OP*)&myop;
2961     Zero(&myop, 1, UNOP);
2962     {
2963         dSP;
2964         oldmark = SP - PL_stack_base;
2965         EXTEND(SP, 1);
2966         PUSHs(sv);
2967         PUTBACK;
2968     }
2969
2970     if (!(flags & G_NOARGS))
2971         myop.op_flags = OPf_STACKED;
2972     myop.op_type = OP_ENTEREVAL;
2973     myop.op_flags |= OP_GIMME_REVERSE(flags);
2974     if (flags & G_KEEPERR)
2975         myop.op_flags |= OPf_SPECIAL;
2976
2977     if (flags & G_RE_REPARSING)
2978         myop.op_private = (OPpEVAL_COPHH | OPpEVAL_RE_REPARSING);
2979
2980     /* fail now; otherwise we could fail after the JMPENV_PUSH but
2981      * before a cx_pusheval(), which corrupts the stack after a croak */
2982     TAINT_PROPER("eval_sv()");
2983
2984     JMPENV_PUSH(ret);
2985     switch (ret) {
2986     case 0:
2987  redo_body:
2988         if (PL_op == (OP*)(&myop)) {
2989             PL_op = PL_ppaddr[OP_ENTEREVAL](aTHX);
2990             if (!PL_op)
2991                 goto fail; /* failed in compilation */
2992         }
2993         CALLRUNOPS(aTHX);
2994         retval = PL_stack_sp - (PL_stack_base + oldmark);
2995         if (!(flags & G_KEEPERR)) {
2996             CLEAR_ERRSV();
2997         }
2998         break;
2999     case 1:
3000         STATUS_ALL_FAILURE;
3001         /* FALLTHROUGH */
3002     case 2:
3003         /* my_exit() was called */
3004         SET_CURSTASH(PL_defstash);
3005         FREETMPS;
3006         JMPENV_POP;
3007         my_exit_jump();
3008         NOT_REACHED; /* NOTREACHED */
3009     case 3:
3010         if (PL_restartop) {
3011             PL_restartjmpenv = NULL;
3012             PL_op = PL_restartop;
3013             PL_restartop = 0;
3014             goto redo_body;
3015         }
3016       fail:
3017         PL_stack_sp = PL_stack_base + oldmark;
3018         if ((flags & G_WANT) == G_ARRAY)
3019             retval = 0;
3020         else {
3021             retval = 1;
3022             *++PL_stack_sp = &PL_sv_undef;
3023         }
3024         break;
3025     }
3026
3027     JMPENV_POP;
3028     if (flags & G_DISCARD) {
3029         PL_stack_sp = PL_stack_base + oldmark;
3030         retval = 0;
3031         FREETMPS;
3032         LEAVE;
3033     }
3034     PL_op = oldop;
3035     return retval;
3036 }
3037
3038 /*
3039 =for apidoc p||eval_pv
3040
3041 Tells Perl to C<eval> the given string in scalar context and return an SV* result.
3042
3043 =cut
3044 */
3045
3046 SV*
3047 Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error)
3048 {
3049     SV* sv = newSVpv(p, 0);
3050
3051     PERL_ARGS_ASSERT_EVAL_PV;
3052
3053     eval_sv(sv, G_SCALAR);
3054     SvREFCNT_dec(sv);
3055
3056     {
3057         dSP;
3058         sv = POPs;
3059         PUTBACK;
3060     }
3061
3062     /* just check empty string or undef? */
3063     if (croak_on_error) {
3064         SV * const errsv = ERRSV;
3065         if(SvTRUE_NN(errsv))
3066             /* replace with croak_sv? */
3067             Perl_croak_nocontext("%s", SvPV_nolen_const(errsv));
3068     }
3069
3070     return sv;
3071 }
3072
3073 /* Require a module. */
3074
3075 /*
3076 =head1 Embedding Functions
3077
3078 =for apidoc p||require_pv
3079
3080 Tells Perl to C<require> the file named by the string argument.  It is
3081 analogous to the Perl code C<eval "require '$file'">.  It's even
3082 implemented that way; consider using load_module instead.
3083
3084 =cut */
3085
3086 void
3087 Perl_require_pv(pTHX_ const char *pv)
3088 {
3089     dSP;
3090     SV* sv;
3091
3092     PERL_ARGS_ASSERT_REQUIRE_PV;
3093
3094     PUSHSTACKi(PERLSI_REQUIRE);
3095     sv = Perl_newSVpvf(aTHX_ "require q%c%s%c", 0, pv, 0);
3096     eval_sv(sv_2mortal(sv), G_DISCARD);
3097     POPSTACK;
3098 }
3099
3100 STATIC void
3101 S_usage(pTHX)           /* XXX move this out into a module ? */
3102 {
3103     /* This message really ought to be max 23 lines.
3104      * Removed -h because the user already knows that option. Others? */
3105
3106     /* Grouped as 6 lines per C string literal, to keep under the ANSI C 89
3107        minimum of 509 character string literals.  */
3108     static const char * const usage_msg[] = {
3109 "  -0[octal]         specify record separator (\\0, if no argument)\n"
3110 "  -a                autosplit mode with -n or -p (splits $_ into @F)\n"
3111 "  -C[number/list]   enables the listed Unicode features\n"
3112 "  -c                check syntax only (runs BEGIN and CHECK blocks)\n"
3113 "  -d[:debugger]     run program under debugger\n"
3114 "  -D[number/list]   set debugging flags (argument is a bit mask or alphabets)\n",
3115 "  -e program        one line of program (several -e's allowed, omit programfile)\n"
3116 "  -E program        like -e, but enables all optional features\n"
3117 "  -f                don't do $sitelib/sitecustomize.pl at startup\n"
3118 "  -F/pattern/       split() pattern for -a switch (//'s are optional)\n"
3119 "  -i[extension]     edit <> files in place (makes backup if extension supplied)\n"
3120 "  -Idirectory       specify @INC/#include directory (several -I's allowed)\n",
3121 "  -l[octal]         enable line ending processing, specifies line terminator\n"
3122 "  -[mM][-]module    execute \"use/no module...\" before executing program\n"
3123 "  -n                assume \"while (<>) { ... }\" loop around program\n"
3124 "  -p                assume loop like -n but print line also, like sed\n"
3125 "  -s                enable rudimentary parsing for switches after programfile\n"
3126 "  -S                look for programfile using PATH environment variable\n",
3127 "  -t                enable tainting warnings\n"
3128 "  -T                enable tainting checks\n"
3129 "  -u                dump core after parsing program\n"
3130 "  -U                allow unsafe operations\n"
3131 "  -v                print version, patchlevel and license\n"
3132 "  -V[:variable]     print configuration summary (or a single Config.pm variable)\n",
3133 "  -w                enable many useful warnings\n"
3134 "  -W                enable all warnings\n"
3135 "  -x[directory]     ignore text before #!perl line (optionally cd to directory)\n"
3136 "  -X                disable all warnings\n"
3137 "  \n"
3138 "Run 'perldoc perl' for more help with Perl.\n\n",
3139 NULL
3140 };
3141     const char * const *p = usage_msg;
3142     PerlIO *out = PerlIO_stdout();
3143
3144     PerlIO_printf(out,
3145                   "\nUsage: %s [switches] [--] [programfile] [arguments]\n",
3146                   PL_origargv[0]);
3147     while (*p)
3148         PerlIO_puts(out, *p++);
3149     my_exit(0);
3150 }
3151
3152 /* convert a string of -D options (or digits) into an int.
3153  * sets *s to point to the char after the options */
3154
3155 #ifdef DEBUGGING
3156 int
3157 Perl_get_debug_opts(pTHX_ const char **s, bool givehelp)
3158 {
3159     static const char * const usage_msgd[] = {
3160       " Debugging flag values: (see also -d)\n"
3161       "  p  Tokenizing and parsing (with v, displays parse stack)\n"
3162       "  s  Stack snapshots (with v, displays all stacks)\n"
3163       "  l  Context (loop) stack processing\n"
3164       "  t  Trace execution\n"
3165       "  o  Method and overloading resolution\n",
3166       "  c  String/numeric conversions\n"
3167       "  P  Print profiling info, source file input state\n"
3168       "  m  Memory and SV allocation\n"
3169       "  f  Format processing\n"
3170       "  r  Regular expression parsing and execution\n"
3171       "  x  Syntax tree dump\n",
3172       "  u  Tainting checks\n"
3173       "  H  Hash dump -- usurps values()\n"
3174       "  X  Scratchpad allocation\n"
3175       "  D  Cleaning up\n"
3176       "  S  Op slab allocation\n"
3177       "  T  Tokenising\n"
3178       "  R  Include reference counts of dumped variables (eg when using -Ds)\n",
3179       "  J  Do not s,t,P-debug (Jump over) opcodes within package DB\n"
3180       "  v  Verbose: use in conjunction with other flags\n"
3181       "  C  Copy On Write\n"
3182       "  A  Consistency checks on internal structures\n"
3183       "  q  quiet - currently only suppresses the 'EXECUTING' message\n"
3184       "  M  trace smart match resolution\n"
3185       "  B  dump suBroutine definitions, including special Blocks like BEGIN\n",
3186       "  L  trace some locale setting information--for Perl core development\n",
3187       "  i  trace PerlIO layer processing\n",
3188       NULL
3189     };
3190     UV uv = 0;
3191
3192     PERL_ARGS_ASSERT_GET_DEBUG_OPTS;
3193
3194     if (isALPHA(**s)) {
3195         /* if adding extra options, remember to update DEBUG_MASK */
3196         static const char debopts[] = "psltocPmfrxuUHXDSTRJvCAqMBLi";
3197
3198         for (; isWORDCHAR(**s); (*s)++) {
3199             const char * const d = strchr(debopts,**s);
3200             if (d)
3201                 uv |= 1 << (d - debopts);
3202             else if (ckWARN_d(WARN_DEBUGGING))
3203                 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
3204                     "invalid option -D%c, use -D'' to see choices\n", **s);
3205         }
3206     }
3207     else if (isDIGIT(**s)) {
3208         const char* e;
3209         if (grok_atoUV(*s, &uv, &e))
3210             *s = e;
3211         for (; isWORDCHAR(**s); (*s)++) ;
3212     }
3213     else if (givehelp) {
3214       const char *const *p = usage_msgd;
3215       while (*p) PerlIO_puts(PerlIO_stdout(), *p++);
3216     }
3217     return (int)uv; /* ignore any UV->int conversion loss */
3218 }
3219 #endif
3220
3221 /* This routine handles any switches that can be given during run */
3222
3223 const char *
3224 Perl_moreswitches(pTHX_ const char *s)
3225 {
3226     dVAR;
3227     UV rschar;
3228     const char option = *s; /* used to remember option in -m/-M code */
3229
3230     PERL_ARGS_ASSERT_MORESWITCHES;
3231
3232     switch (*s) {
3233     case '0':
3234     {
3235          I32 flags = 0;
3236          STRLEN numlen;
3237
3238          SvREFCNT_dec(PL_rs);
3239          if (s[1] == 'x' && s[2]) {
3240               const char *e = s+=2;
3241               U8 *tmps;
3242
3243               while (*e)
3244                 e++;
3245               numlen = e - s;
3246               flags = PERL_SCAN_SILENT_ILLDIGIT;
3247               rschar = (U32)grok_hex(s, &numlen, &flags, NULL);
3248               if (s + numlen < e) {
3249                    rschar = 0; /* Grandfather -0xFOO as -0 -xFOO. */
3250                    numlen = 0;
3251                    s--;
3252               }
3253               PL_rs = newSVpvs("");
3254               tmps = (U8*) SvGROW(PL_rs, (STRLEN)(UVCHR_SKIP(rschar) + 1));
3255               uvchr_to_utf8(tmps, rschar);
3256               SvCUR_set(PL_rs, UVCHR_SKIP(rschar));
3257               SvUTF8_on(PL_rs);
3258          }
3259          else {
3260               numlen = 4;
3261               rschar = (U32)grok_oct(s, &numlen, &flags, NULL);
3262               if (rschar & ~((U8)~0))
3263                    PL_rs = &PL_sv_undef;
3264               else if (!rschar && numlen >= 2)
3265                    PL_rs = newSVpvs("");
3266               else {
3267                    char ch = (char)rschar;
3268                    PL_rs = newSVpvn(&ch, 1);
3269               }
3270          }
3271          sv_setsv(get_sv("/", GV_ADD), PL_rs);
3272          return s + numlen;
3273     }
3274     case 'C':
3275         s++;
3276         PL_unicode = parse_unicode_opts( (const char **)&s );
3277         if (PL_unicode & PERL_UNICODE_UTF8CACHEASSERT_FLAG)
3278             PL_utf8cache = -1;
3279         return s;
3280     case 'F':
3281         PL_minus_a = TRUE;
3282         PL_minus_F = TRUE;
3283         PL_minus_n = TRUE;
3284         PL_splitstr = ++s;
3285         while (*s && !isSPACE(*s)) ++s;
3286         PL_splitstr = savepvn(PL_splitstr, s - PL_splitstr);
3287         return s;
3288     case 'a':
3289         PL_minus_a = TRUE;
3290         PL_minus_n = TRUE;
3291         s++;
3292         return s;
3293     case 'c':
3294         PL_minus_c = TRUE;
3295         s++;
3296         return s;
3297     case 'd':
3298         forbid_setid('d', FALSE);
3299         s++;
3300
3301         /* -dt indicates to the debugger that threads will be used */
3302         if (*s == 't' && !isWORDCHAR(s[1])) {
3303             ++s;
3304             my_setenv("PERL5DB_THREADED", "1");
3305         }
3306
3307         /* The following permits -d:Mod to accepts arguments following an =
3308            in the fashion that -MSome::Mod does. */
3309         if (*s == ':' || *s == '=') {
3310             const char *start;
3311             const char *end;
3312             SV *sv;
3313
3314             if (*++s == '-') {
3315                 ++s;
3316                 sv = newSVpvs("no Devel::");
3317             } else {
3318                 sv = newSVpvs("use Devel::");
3319             }
3320
3321             start = s;
3322             end = s + strlen(s);
3323
3324             /* We now allow -d:Module=Foo,Bar and -d:-Module */
3325             while(isWORDCHAR(*s) || *s==':') ++s;
3326             if (*s != '=')
3327                 sv_catpvn(sv, start, end - start);
3328             else {
3329                 sv_catpvn(sv, start, s-start);
3330                 /* Don't use NUL as q// delimiter here, this string goes in the
3331                  * environment. */
3332                 Perl_sv_catpvf(aTHX_ sv, " split(/,/,q{%s});", ++s);
3333             }
3334             s = end;
3335             my_setenv("PERL5DB", SvPV_nolen_const(sv));
3336             SvREFCNT_dec(sv);
3337         }
3338         if (!PL_perldb) {
3339             PL_perldb = PERLDB_ALL;
3340             init_debugger();
3341         }
3342         return s;
3343     case 'D':
3344     {   
3345 #ifdef DEBUGGING
3346         forbid_setid('D', FALSE);
3347         s++;
3348         PL_debug = get_debug_opts( (const char **)&s, 1) | DEBUG_TOP_FLAG;
3349 #else /* !DEBUGGING */
3350         if (ckWARN_d(WARN_DEBUGGING))
3351             Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
3352                    "Recompile perl with -DDEBUGGING to use -D switch (did you mean -d ?)\n");
3353         for (s++; isWORDCHAR(*s); s++) ;
3354 #endif
3355         return s;
3356         NOT_REACHED; /* NOTREACHED */
3357     }   
3358     case 'h':
3359         usage();
3360         NOT_REACHED; /* NOTREACHED */
3361
3362     case 'i':
3363         Safefree(PL_inplace);
3364 #if defined(__CYGWIN__) /* do backup extension automagically */
3365         if (*(s+1) == '\0') {
3366         PL_inplace = savepvs(".bak");
3367         return s+1;
3368         }
3369 #endif /* __CYGWIN__ */
3370         {
3371             const char * const start = ++s;
3372             while (*s && !isSPACE(*s))
3373                 ++s;
3374
3375             PL_inplace = savepvn(start, s - start);
3376         }
3377         return s;
3378     case 'I':   /* -I handled both here and in parse_body() */
3379         forbid_setid('I', FALSE);
3380         ++s;
3381         while (*s && isSPACE(*s))
3382             ++s;
3383         if (*s) {
3384             const char *e, *p;
3385             p = s;
3386             /* ignore trailing spaces (possibly followed by other switches) */
3387             do {
3388                 for (e = p; *e && !isSPACE(*e); e++) ;
3389                 p = e;
3390                 while (isSPACE(*p))
3391                     p++;
3392             } while (*p && *p != '-');
3393             incpush(s, e-s,
3394                     INCPUSH_ADD_SUB_DIRS|INCPUSH_ADD_OLD_VERS|INCPUSH_UNSHIFT);
3395             s = p;
3396             if (*s == '-')
3397                 s++;
3398         }
3399         else
3400             Perl_croak(aTHX_ "No directory specified for -I");
3401         return s;
3402     case 'l':
3403         PL_minus_l = TRUE;
3404         s++;
3405         if (PL_ors_sv) {
3406             SvREFCNT_dec(PL_ors_sv);
3407             PL_ors_sv = NULL;
3408         }
3409         if (isDIGIT(*s)) {
3410             I32 flags = 0;
3411             STRLEN numlen;
3412             PL_ors_sv = newSVpvs("\n");
3413             numlen = 3 + (*s == '0');
3414             *SvPVX(PL_ors_sv) = (char)grok_oct(s, &numlen, &flags, NULL);
3415             s += numlen;
3416         }
3417         else {
3418             if (RsPARA(PL_rs)) {
3419                 PL_ors_sv = newSVpvs("\n\n");
3420             }
3421             else {
3422                 PL_ors_sv = newSVsv(PL_rs);
3423             }
3424         }
3425         return s;
3426     case 'M':
3427         forbid_setid('M', FALSE);       /* XXX ? */
3428         /* FALLTHROUGH */
3429     case 'm':
3430         forbid_setid('m', FALSE);       /* XXX ? */
3431         if (*++s) {
3432             const char *start;
3433             const char *end;
3434             SV *sv;
3435             const char *use = "use ";
3436             bool colon = FALSE;
3437             /* -M-foo == 'no foo'       */
3438             /* Leading space on " no " is deliberate, to make both
3439                possibilities the same length.  */
3440             if (*s == '-') { use = " no "; ++s; }
3441             sv = newSVpvn(use,4);
3442             start = s;
3443             /* We allow -M'Module qw(Foo Bar)'  */
3444             while(isWORDCHAR(*s) || *s==':') {
3445                 if( *s++ == ':' ) {
3446                     if( *s == ':' ) 
3447                         s++;
3448                     else
3449                         colon = TRUE;
3450                 }
3451             }
3452             if (s == start)
3453                 Perl_croak(aTHX_ "Module name required with -%c option",
3454                                     option);
3455             if (colon) 
3456                 Perl_croak(aTHX_ "Invalid module name %.*s with -%c option: "
3457                                     "contains single ':'",
3458                                     (int)(s - start), start, option);
3459             end = s + strlen(s);
3460             if (*s != '=') {
3461                 sv_catpvn(sv, start, end - start);
3462                 if (option == 'm') {
3463                     if (*s != '\0')
3464                         Perl_croak(aTHX_ "Can't use '%c' after -mname", *s);
3465                     sv_catpvs( sv, " ()");
3466                 }
3467             } else {
3468                 sv_catpvn(sv, start, s-start);
3469                 /* Use NUL as q''-delimiter.  */
3470                 sv_catpvs(sv, " split(/,/,q\0");
3471                 ++s;
3472                 sv_catpvn(sv, s, end - s);
3473                 sv_catpvs(sv,  "\0)");
3474             }
3475             s = end;
3476             Perl_av_create_and_push(aTHX_ &PL_preambleav, sv);
3477         }
3478         else
3479             Perl_croak(aTHX_ "Missing argument to -%c", option);
3480         return s;
3481     case 'n':
3482         PL_minus_n = TRUE;
3483         s++;
3484         return s;
3485     case 'p':
3486         PL_minus_p = TRUE;
3487         s++;
3488         return s;
3489     case 's':
3490         forbid_setid('s', FALSE);
3491         PL_doswitches = TRUE;
3492         s++;
3493         return s;
3494     case 't':
3495     case 'T':
3496 #if defined(SILENT_NO_TAINT_SUPPORT)
3497             /* silently ignore */
3498 #elif defined(NO_TAINT_SUPPORT)
3499         Perl_croak_nocontext("This perl was compiled without taint support. "
3500                    "Cowardly refusing to run with -t or -T flags");
3501 #else
3502         if (!TAINTING_get)
3503             TOO_LATE_FOR(*s);
3504 #endif
3505         s++;
3506         return s;
3507     case 'u':
3508         PL_do_undump = TRUE;
3509         s++;
3510         return s;
3511     case 'U':
3512         PL_unsafe = TRUE;
3513         s++;
3514         return s;
3515     case 'v':
3516         minus_v();
3517     case 'w':
3518         if (! (PL_dowarn & G_WARN_ALL_MASK)) {
3519             PL_dowarn |= G_WARN_ON;
3520         }
3521         s++;
3522         return s;
3523     case 'W':
3524         PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
3525         if (!specialWARN(PL_compiling.cop_warnings))
3526             PerlMemShared_free(PL_compiling.cop_warnings);
3527         PL_compiling.cop_warnings = pWARN_ALL ;
3528         s++;
3529         return s;
3530     case 'X':
3531         PL_dowarn = G_WARN_ALL_OFF;
3532         if (!specialWARN(PL_compiling.cop_warnings))
3533             PerlMemShared_free(PL_compiling.cop_warnings);
3534         PL_compiling.cop_warnings = pWARN_NONE ;
3535         s++;
3536         return s;
3537     case '*':
3538     case ' ':
3539         while( *s == ' ' )
3540           ++s;
3541         if (s[0] == '-')        /* Additional switches on #! line. */
3542             return s+1;
3543         break;
3544     case '-':
3545     case 0:
3546 #if defined(WIN32) || !defined(PERL_STRICT_CR)
3547     case '\r':
3548 #endif
3549     case '\n':
3550     case '\t':
3551         break;
3552 #ifdef ALTERNATE_SHEBANG
3553     case 'S':                   /* OS/2 needs -S on "extproc" line. */
3554         break;
3555 #endif
3556     case 'e': case 'f': case 'x': case 'E':
3557 #ifndef ALTERNATE_SHEBANG
3558     case 'S':
3559 #endif
3560     case 'V':
3561         Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s);
3562     default:
3563         Perl_croak(aTHX_
3564             "Unrecognized switch: -%.1s  (-h will show valid options)",s
3565         );
3566     }
3567     return NULL;
3568 }
3569
3570
3571 STATIC void
3572 S_minus_v(pTHX)
3573 {
3574         PerlIO * PIO_stdout;
3575         {
3576             const char * const level_str = "v" PERL_VERSION_STRING;
3577             const STRLEN level_len = sizeof("v" PERL_VERSION_STRING)-1;
3578 #ifdef PERL_PATCHNUM
3579             SV* level;
3580 #  ifdef PERL_GIT_UNCOMMITTED_CHANGES
3581             static const char num [] = PERL_PATCHNUM "*";
3582 #  else
3583             static const char num [] = PERL_PATCHNUM;
3584 #  endif
3585             {
3586                 const STRLEN num_len = sizeof(num)-1;
3587                 /* A very advanced compiler would fold away the strnEQ
3588                    and this whole conditional, but most (all?) won't do it.
3589                    SV level could also be replaced by with preprocessor
3590                    catenation.
3591                 */
3592                 if (num_len >= level_len && strnEQ(num,level_str,level_len)) {
3593                     /* per 46807d8e80, PERL_PATCHNUM is outside of the control
3594                        of the interp so it might contain format characters
3595                     */
3596                     level = newSVpvn(num, num_len);
3597                 } else {
3598                     level = Perl_newSVpvf_nocontext("%s (%s)", level_str, num);
3599                 }
3600             }
3601 #else
3602         SV* level = newSVpvn(level_str, level_len);
3603 #endif /* #ifdef PERL_PATCHNUM */
3604         PIO_stdout =  PerlIO_stdout();
3605             PerlIO_printf(PIO_stdout,
3606                 "\nThis is perl "       STRINGIFY(PERL_REVISION)
3607                 ", version "            STRINGIFY(PERL_VERSION)
3608                 ", subversion "         STRINGIFY(PERL_SUBVERSION)
3609                 " (%" SVf ") built for "        ARCHNAME, SVfARG(level)
3610                 );
3611             SvREFCNT_dec_NN(level);
3612         }
3613 #if defined(LOCAL_PATCH_COUNT)
3614         if (LOCAL_PATCH_COUNT > 0)
3615             PerlIO_printf(PIO_stdout,
3616                           "\n(with %d registered patch%s, "
3617                           "see perl -V for more detail)",
3618                           LOCAL_PATCH_COUNT,
3619                           (LOCAL_PATCH_COUNT!=1) ? "es" : "");
3620 #endif
3621
3622         PerlIO_printf(PIO_stdout,
3623                       "\n\nCopyright 1987-2017, Larry Wall\n");
3624 #ifdef MSDOS
3625         PerlIO_printf(PIO_stdout,
3626                       "\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
3627 #endif
3628 #ifdef DJGPP
3629         PerlIO_printf(PIO_stdout,
3630                       "djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n"
3631                       "djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n");
3632 #endif
3633 #ifdef OS2
3634         PerlIO_printf(PIO_stdout,
3635                       "\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
3636                       "Version 5 port Copyright (c) 1994-2002, Andreas Kaiser, Ilya Zakharevich\n");
3637 #endif
3638 #ifdef OEMVS
3639         PerlIO_printf(PIO_stdout,
3640                       "MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
3641 #endif
3642 #ifdef __VOS__
3643         PerlIO_printf(PIO_stdout,
3644                       "Stratus OpenVOS port by Paul.Green@stratus.com, 1997-2013\n");
3645 #endif
3646 #ifdef POSIX_BC
3647         PerlIO_printf(PIO_stdout,
3648                       "BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
3649 #endif
3650 #ifdef UNDER_CE
3651         PerlIO_printf(PIO_stdout,
3652                         "WINCE port by Rainer Keuchel, 2001-2002\n"
3653                         "Built on " __DATE__ " " __TIME__ "\n\n");
3654         wce_hitreturn();
3655 #endif
3656 #ifdef __SYMBIAN32__
3657         PerlIO_printf(PIO_stdout,
3658                       "Symbian port by Nokia, 2004-2005\n");
3659 #endif
3660 #ifdef BINARY_BUILD_NOTICE
3661         BINARY_BUILD_NOTICE;
3662 #endif
3663         PerlIO_printf(PIO_stdout,
3664                       "\n\
3665 Perl may be copied only under the terms of either the Artistic License or the\n\
3666 GNU General Public License, which may be found in the Perl 5 source kit.\n\n\
3667 Complete documentation for Perl, including FAQ lists, should be found on\n\
3668 this system using \"man perl\" or \"perldoc perl\".  If you have access to the\n\
3669 Internet, point your browser at http://www.perl.org/, the Perl Home Page.\n\n");
3670         my_exit(0);
3671 }
3672
3673 /* compliments of Tom Christiansen */
3674
3675 /* unexec() can be found in the Gnu emacs distribution */
3676 /* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
3677
3678 #ifdef VMS
3679 #include <lib$routines.h>
3680 #endif
3681
3682 void
3683 Perl_my_unexec(pTHX)
3684 {
3685 #ifdef UNEXEC
3686     SV *    prog = newSVpv(BIN_EXP, 0);
3687     SV *    file = newSVpv(PL_origfilename, 0);
3688     int    status = 1;
3689     extern int etext;
3690
3691     sv_catpvs(prog, "/perl");
3692     sv_catpvs(file, ".perldump");
3693
3694     unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
3695     /* unexec prints msg to stderr in case of failure */
3696     PerlProc_exit(status);
3697 #else
3698     PERL_UNUSED_CONTEXT;
3699 #  ifdef VMS
3700      lib$signal(SS$_DEBUG);  /* ssdef.h #included from vmsish.h */
3701 #  elif defined(WIN32) || defined(__CYGWIN__)
3702     Perl_croak_nocontext("dump is not supported");
3703 #  else
3704     ABORT();            /* for use with undump */
3705 #  endif
3706 #endif
3707 }
3708
3709 /* initialize curinterp */
3710 STATIC void
3711 S_init_interp(pTHX)
3712 {
3713 #ifdef MULTIPLICITY
3714 #  define PERLVAR(prefix,var,type)
3715 #  define PERLVARA(prefix,var,n,type)
3716 #  if defined(PERL_IMPLICIT_CONTEXT)
3717 #    define PERLVARI(prefix,var,type,init)      aTHX->prefix##var = init;
3718 #    define PERLVARIC(prefix,var,type,init)     aTHX->prefix##var = init;
3719 #  else
3720 #    define PERLVARI(prefix,var,type,init)      PERL_GET_INTERP->var = init;
3721 #    define PERLVARIC(prefix,var,type,init)     PERL_GET_INTERP->var = init;
3722 #  endif
3723 #  include "intrpvar.h"
3724 #  undef PERLVAR
3725 #  undef PERLVARA
3726 #  undef PERLVARI
3727 #  undef PERLVARIC
3728 #else
3729 #  define PERLVAR(prefix,var,type)
3730 #  define PERLVARA(prefix,var,n,type)
3731 #  define PERLVARI(prefix,var,type,init)        PL_##var = init;
3732 #  define PERLVARIC(prefix,var,type,init)       PL_##var = init;
3733 #  include "intrpvar.h"
3734 #  undef PERLVAR
3735 #  undef PERLVARA
3736 #  undef PERLVARI
3737 #  undef PERLVARIC
3738 #endif
3739
3740 }
3741
3742 STATIC void
3743 S_init_main_stash(pTHX)
3744 {
3745     GV *gv;
3746
3747     PL_curstash = PL_defstash = (HV *)SvREFCNT_inc_simple_NN(newHV());
3748     /* We know that the string "main" will be in the global shared string
3749        table, so it's a small saving to use it rather than allocate another
3750        8 bytes.  */
3751     PL_curstname = newSVpvs_share("main");
3752     gv = gv_fetchpvs("main::", GV_ADD|GV_NOTQUAL, SVt_PVHV);
3753     /* If we hadn't caused another reference to "main" to be in the shared
3754        string table above, then it would be worth reordering these two,
3755        because otherwise all we do is delete "main" from it as a consequence
3756        of the SvREFCNT_dec, only to add it again with hv_name_set */
3757     SvREFCNT_dec(GvHV(gv));
3758     hv_name_sets(PL_defstash, "main", 0);
3759     GvHV(gv) = MUTABLE_HV(SvREFCNT_inc_simple(PL_defstash));
3760     SvREADONLY_on(gv);
3761     PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpvs("INC", GV_ADD|GV_NOTQUAL,
3762                                              SVt_PVAV)));
3763     SvREFCNT_inc_simple_void(PL_incgv); /* Don't allow it to be freed */
3764     GvMULTI_on(PL_incgv);
3765     PL_hintgv = gv_fetchpvs("\010", GV_ADD|GV_NOTQUAL, SVt_PV); /* ^H */
3766     SvREFCNT_inc_simple_void(PL_hintgv);
3767     GvMULTI_on(PL_hintgv);
3768     PL_defgv = gv_fetchpvs("_", GV_ADD|GV_NOTQUAL, SVt_PVAV);
3769     SvREFCNT_inc_simple_void(PL_defgv);
3770     PL_errgv = gv_fetchpvs("@", GV_ADD|GV_NOTQUAL, SVt_PV);
3771     SvREFCNT_inc_simple_void(PL_errgv);
3772     GvMULTI_on(PL_errgv);
3773     PL_replgv = gv_fetchpvs("\022", GV_ADD|GV_NOTQUAL, SVt_PV); /* ^R */
3774     SvREFCNT_inc_simple_void(PL_replgv);
3775     GvMULTI_on(PL_replgv);
3776     (void)Perl_form(aTHX_ "%240s","");  /* Preallocate temp - for immediate signals. */
3777 #ifdef PERL_DONT_CREATE_GVSV
3778     (void)gv_SVadd(PL_errgv);
3779 #endif
3780     sv_grow(ERRSV, 240);        /* Preallocate - for immediate signals. */
3781     CLEAR_ERRSV();
3782     SET_CURSTASH(PL_defstash);
3783     CopSTASH_set(&PL_compiling, PL_defstash);
3784     PL_debstash = GvHV(gv_fetchpvs("DB::", GV_ADDMULTI, SVt_PVHV));
3785     PL_globalstash = GvHV(gv_fetchpvs("CORE::GLOBAL::", GV_ADDMULTI,
3786                                       SVt_PVHV));
3787     /* We must init $/ before switches are processed. */
3788     sv_setpvs(get_sv("/", GV_ADD), "\n");
3789 }
3790
3791 STATIC PerlIO *
3792 S_open_script(pTHX_ const char *scriptname, bool dosearch, bool *suidscript)
3793 {
3794     int fdscript = -1;
3795     PerlIO *rsfp = NULL;
3796     Stat_t tmpstatbuf;
3797     int fd;
3798
3799     PERL_ARGS_ASSERT_OPEN_SCRIPT;
3800
3801     if (PL_e_script) {
3802         PL_origfilename = savepvs("-e");
3803     }
3804     else {
3805         const char *s;
3806         UV uv;
3807         /* if find_script() returns, it returns a malloc()-ed value */
3808         scriptname = PL_origfilename = find_script(scriptname, dosearch, NULL, 1);
3809
3810         if (strEQs(scriptname, "/dev/fd/")
3811             && isDIGIT(scriptname[8])
3812             && grok_atoUV(scriptname + 8, &uv, &s)
3813             && uv <= PERL_INT_MAX
3814         ) {
3815             fdscript = (int)uv;
3816             if (*s) {
3817                 /* PSz 18 Feb 04
3818                  * Tell apart "normal" usage of fdscript, e.g.
3819                  * with bash on FreeBSD:
3820                  *   perl <( echo '#!perl -DA'; echo 'print "$0\n"')
3821                  * from usage in suidperl.
3822                  * Does any "normal" usage leave garbage after the number???
3823                  * Is it a mistake to use a similar /dev/fd/ construct for
3824                  * suidperl?
3825                  */
3826                 *suidscript = TRUE;
3827                 /* PSz 20 Feb 04  
3828                  * Be supersafe and do some sanity-checks.
3829                  * Still, can we be sure we got the right thing?
3830                  */
3831                 if (*s != '/') {
3832                     Perl_croak(aTHX_ "Wrong syntax (suid) fd script name \"%s\"\n", s);
3833                 }
3834                 if (! *(s+1)) {
3835                     Perl_croak(aTHX_ "Missing (suid) fd script name\n");
3836                 }
3837                 scriptname = savepv(s + 1);
3838                 Safefree(PL_origfilename);
3839                 PL_origfilename = (char *)scriptname;
3840             }
3841         }
3842     }
3843
3844     CopFILE_free(PL_curcop);
3845     CopFILE_set(PL_curcop, PL_origfilename);
3846     if (*PL_origfilename == '-' && PL_origfilename[1] == '\0')
3847         scriptname = (char *)"";
3848     if (fdscript >= 0) {
3849         rsfp = PerlIO_fdopen(fdscript,PERL_SCRIPT_MODE);
3850     }
3851     else if (!*scriptname) {
3852         forbid_setid(0, *suidscript);
3853         return NULL;
3854     }
3855     else {
3856 #ifdef FAKE_BIT_BUCKET
3857         /* This hack allows one not to have /dev/null (or BIT_BUCKET as it
3858          * is called) and still have the "-e" work.  (Believe it or not,
3859          * a /dev/null is required for the "-e" to work because source
3860          * filter magic is used to implement it. ) This is *not* a general
3861          * replacement for a /dev/null.  What we do here is create a temp
3862          * file (an empty file), open up that as the script, and then
3863          * immediately close and unlink it.  Close enough for jazz. */ 
3864 #define FAKE_BIT_BUCKET_PREFIX "/tmp/perlnull-"
3865 #define FAKE_BIT_BUCKET_SUFFIX "XXXXXXXX"
3866 #define FAKE_BIT_BUCKET_TEMPLATE FAKE_BIT_BUCKET_PREFIX FAKE_BIT_BUCKET_SUFFIX
3867         char tmpname[sizeof(FAKE_BIT_BUCKET_TEMPLATE)] = {
3868             FAKE_BIT_BUCKET_TEMPLATE
3869         };
3870         const char * const err = "Failed to create a fake bit bucket";
3871         if (strEQ(scriptname, BIT_BUCKET)) {
3872 #ifdef HAS_MKSTEMP /* Hopefully mkstemp() is safe here. */
3873             int old_umask = umask(0177);
3874             int tmpfd = mkstemp(tmpname);
3875             umask(old_umask);
3876             if (tmpfd > -1) {
3877                 scriptname = tmpname;
3878                 close(tmpfd);
3879             } else
3880                 Perl_croak(aTHX_ err);
3881 #else
3882 #  ifdef HAS_MKTEMP
3883             scriptname = mktemp(tmpname);
3884             if (!scriptname)
3885                 Perl_croak(aTHX_ err);
3886 #  endif
3887 #endif
3888         }
3889 #endif
3890         rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
3891 #ifdef FAKE_BIT_BUCKET
3892         if (memEQ(scriptname, FAKE_BIT_BUCKET_PREFIX,
3893                   sizeof(FAKE_BIT_BUCKET_PREFIX) - 1)
3894             && strlen(scriptname) == sizeof(tmpname) - 1) {
3895             unlink(scriptname);
3896         }
3897         scriptname = BIT_BUCKET;
3898 #endif
3899     }
3900     if (!rsfp) {
3901         /* PSz 16 Sep 03  Keep neat error message */
3902         if (PL_e_script)
3903             Perl_croak(aTHX_ "Can't open " BIT_BUCKET ": %s\n", Strerror(errno));
3904         else
3905             Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
3906                     CopFILE(PL_curcop), Strerror(errno));
3907     }
3908     fd = PerlIO_fileno(rsfp);
3909 #if defined(HAS_FCNTL) && defined(F_SETFD) && defined(FD_CLOEXEC)
3910     if (fd >= 0) {
3911         /* ensure close-on-exec */
3912         if (fcntl(fd, F_SETFD, FD_CLOEXEC) < 0) {
3913             Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
3914                        CopFILE(PL_curcop), Strerror(errno));
3915         }
3916     }
3917 #endif
3918
3919     if (fd < 0 ||
3920         (PerlLIO_fstat(fd, &tmpstatbuf) >= 0
3921          && S_ISDIR(tmpstatbuf.st_mode)))
3922         Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
3923             CopFILE(PL_curcop),
3924             Strerror(EISDIR));
3925
3926     return rsfp;
3927 }
3928
3929 /* Mention
3930  * I_SYSSTATVFS HAS_FSTATVFS
3931  * I_SYSMOUNT
3932  * I_STATFS     HAS_FSTATFS     HAS_GETFSSTAT
3933  * I_MNTENT     HAS_GETMNTENT   HAS_HASMNTOPT
3934  * here so that metaconfig picks them up. */
3935
3936
3937 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
3938 /* Don't even need this function.  */
3939 #else
3940 STATIC void
3941 S_validate_suid(pTHX_ PerlIO *rsfp)
3942 {
3943     const Uid_t  my_uid = PerlProc_getuid();
3944     const Uid_t my_euid = PerlProc_geteuid();
3945     const Gid_t  my_gid = PerlProc_getgid();
3946     const Gid_t my_egid = PerlProc_getegid();
3947
3948     PERL_ARGS_ASSERT_VALIDATE_SUID;
3949
3950     if (my_euid != my_uid || my_egid != my_gid) {       /* (suidperl doesn't exist, in fact) */
3951         dVAR;
3952         int fd = PerlIO_fileno(rsfp);
3953         Stat_t statbuf;
3954         if (fd < 0 || PerlLIO_fstat(fd, &statbuf) < 0) { /* may be either wrapped or real suid */
3955             Perl_croak_nocontext( "Illegal suidscript");
3956         }
3957         if ((my_euid != my_uid && my_euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
3958             ||
3959             (my_egid != my_gid && my_egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
3960             )
3961             if (!PL_do_undump)
3962                 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
3963 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
3964         /* not set-id, must be wrapped */
3965     }
3966 }
3967 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
3968
3969 STATIC void
3970 S_find_beginning(pTHX_ SV* linestr_sv, PerlIO *rsfp)
3971 {
3972     const char *s;
3973     const char *s2;
3974
3975     PERL_ARGS_ASSERT_FIND_BEGINNING;
3976
3977     /* skip forward in input to the real script? */
3978
3979     do {
3980         if ((s = sv_gets(linestr_sv, rsfp, 0)) == NULL)
3981             Perl_croak(aTHX_ "No Perl script found in input\n");
3982         s2 = s;
3983     } while (!(*s == '#' && s[1] == '!' && ((s = instr(s,"perl")) || (s = instr(s2,"PERL")))));
3984     PerlIO_ungetc(rsfp, '\n');          /* to keep line count right */
3985     while (*s && !(isSPACE (*s) || *s == '#')) s++;
3986     s2 = s;
3987     while (*s == ' ' || *s == '\t') s++;
3988     if (*s++ == '-') {
3989         while (isDIGIT(s2[-1]) || s2[-1] == '-' || s2[-1] == '.'
3990                || s2[-1] == '_') s2--;
3991         if (strEQs(s2-4,"perl"))
3992             while ((s = moreswitches(s)))
3993                 ;
3994     }
3995 }
3996
3997
3998 STATIC void
3999 S_init_ids(pTHX)
4000 {
4001     /* no need to do anything here any more if we don't
4002      * do tainting. */
4003 #ifndef NO_TAINT_SUPPORT
4004     const Uid_t my_uid = PerlProc_getuid();
4005     const Uid_t my_euid = PerlProc_geteuid();
4006     const Gid_t my_gid = PerlProc_getgid();
4007     const Gid_t my_egid = PerlProc_getegid();
4008
4009     PERL_UNUSED_CONTEXT;
4010
4011     /* Should not happen: */
4012     CHECK_MALLOC_TAINT(my_uid && (my_euid != my_uid || my_egid != my_gid));
4013     TAINTING_set( TAINTING_get | (my_uid && (my_euid != my_uid || my_egid != my_gid)) );
4014 #endif
4015     /* BUG */
4016     /* PSz 27 Feb 04
4017      * Should go by suidscript, not uid!=euid: why disallow
4018      * system("ls") in scripts run from setuid things?
4019      * Or, is this run before we check arguments and set suidscript?
4020      * What about SETUID_SCRIPTS_ARE_SECURE_NOW: could we use fdscript then?
4021      * (We never have suidscript, can we be sure to have fdscript?)
4022      * Or must then go by UID checks? See comments in forbid_setid also.
4023      */
4024 }
4025
4026 /* This is used very early in the lifetime of the program,
4027  * before even the options are parsed, so PL_tainting has
4028  * not been initialized properly.  */
4029 bool
4030 Perl_doing_taint(int argc, char *argv[], char *envp[])
4031 {
4032 #ifndef PERL_IMPLICIT_SYS
4033     /* If we have PERL_IMPLICIT_SYS we can't call getuid() et alia
4034      * before we have an interpreter-- and the whole point of this
4035      * function is to be called at such an early stage.  If you are on
4036      * a system with PERL_IMPLICIT_SYS but you do have a concept of
4037      * "tainted because running with altered effective ids', you'll
4038      * have to add your own checks somewhere in here.  The two most
4039      * known samples of 'implicitness' are Win32 and NetWare, neither
4040      * of which has much of concept of 'uids'. */
4041     Uid_t uid  = PerlProc_getuid();
4042     Uid_t euid = PerlProc_geteuid();
4043     Gid_t gid  = PerlProc_getgid();
4044     Gid_t egid = PerlProc_getegid();
4045     (void)envp;
4046
4047 #ifdef VMS
4048     uid  |=  gid << 16;
4049     euid |= egid << 16;
4050 #endif
4051     if (uid && (euid != uid || egid != gid))
4052         return 1;
4053 #endif /* !PERL_IMPLICIT_SYS */
4054     /* This is a really primitive check; environment gets ignored only
4055      * if -T are the first chars together; otherwise one gets
4056      *  "Too late" message. */
4057     if ( argc > 1 && argv[1][0] == '-'
4058          && isALPHA_FOLD_EQ(argv[1][1], 't'))
4059         return 1;
4060     return 0;
4061 }
4062
4063 /* Passing the flag as a single char rather than a string is a slight space
4064    optimisation.  The only message that isn't /^-.$/ is
4065    "program input from stdin", which is substituted in place of '\0', which
4066    could never be a command line flag.  */
4067 STATIC void
4068 S_forbid_setid(pTHX_ const char flag, const bool suidscript) /* g */
4069 {
4070     char string[3] = "-x";
4071     const char *message = "program input from stdin";
4072
4073     PERL_UNUSED_CONTEXT;
4074     if (flag) {
4075         string[1] = flag;
4076         message = string;
4077     }
4078
4079 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
4080     if (PerlProc_getuid() != PerlProc_geteuid())
4081         Perl_croak(aTHX_ "No %s allowed while running setuid", message);
4082     if (PerlProc_getgid() != PerlProc_getegid())
4083         Perl_croak(aTHX_ "No %s allowed while running setgid", message);
4084 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
4085     if (suidscript)
4086         Perl_croak(aTHX_ "No %s allowed with (suid) fdscript", message);
4087 }
4088
4089 void
4090 Perl_init_dbargs(pTHX)
4091 {
4092     AV *const args = PL_dbargs = GvAV(gv_AVadd((gv_fetchpvs("DB::args",
4093                                                             GV_ADDMULTI,
4094                                                             SVt_PVAV))));
4095
4096     if (AvREAL(args)) {
4097         /* Someone has already created it.
4098            It might have entries, and if we just turn off AvREAL(), they will
4099            "leak" until global destruction.  */
4100         av_clear(args);
4101         if (SvTIED_mg((const SV *)args, PERL_MAGIC_tied))
4102             Perl_croak(aTHX_ "Cannot set tied @DB::args");
4103     }
4104     AvREIFY_only(PL_dbargs);
4105 }
4106
4107 void
4108 Perl_init_debugger(pTHX)
4109 {
4110     HV * const ostash = PL_curstash;
4111     MAGIC *mg;
4112
4113     PL_curstash = (HV *)SvREFCNT_inc_simple(PL_debstash);
4114
4115     Perl_init_dbargs(aTHX);
4116     PL_DBgv = MUTABLE_GV(
4117         SvREFCNT_inc(gv_fetchpvs("DB::DB", GV_ADDMULTI, SVt_PVGV))
4118     );
4119     PL_DBline = MUTABLE_GV(
4120         SvREFCNT_inc(gv_fetchpvs("DB::dbline", GV_ADDMULTI, SVt_PVAV))
4121     );
4122     PL_DBsub = MUTABLE_GV(SvREFCNT_inc(
4123         gv_HVadd(gv_fetchpvs("DB::sub", GV_ADDMULTI, SVt_PVHV))
4124     ));
4125     PL_DBsingle = GvSV((gv_fetchpvs("DB::single", GV_ADDMULTI, SVt_PV)));
4126     if (!SvIOK(PL_DBsingle))
4127         sv_setiv(PL_DBsingle, 0);
4128     mg = sv_magicext(PL_DBsingle, NULL, PERL_MAGIC_debugvar, &PL_vtbl_debugvar, 0, 0);
4129     mg->mg_private = DBVARMG_SINGLE;
4130     SvSETMAGIC(PL_DBsingle);
4131
4132     PL_DBtrace = GvSV((gv_fetchpvs("DB::trace", GV_ADDMULTI, SVt_PV)));
4133     if (!SvIOK(PL_DBtrace))
4134         sv_setiv(PL_DBtrace, 0);
4135     mg = sv_magicext(PL_DBtrace, NULL, PERL_MAGIC_debugvar, &PL_vtbl_debugvar, 0, 0);
4136     mg->mg_private = DBVARMG_TRACE;
4137     SvSETMAGIC(PL_DBtrace);
4138
4139     PL_DBsignal = GvSV((gv_fetchpvs("DB::signal", GV_ADDMULTI, SVt_PV)));
4140     if (!SvIOK(PL_DBsignal))
4141         sv_setiv(PL_DBsignal, 0);
4142     mg = sv_magicext(PL_DBsignal, NULL, PERL_MAGIC_debugvar, &PL_vtbl_debugvar, 0, 0);
4143     mg->mg_private = DBVARMG_SIGNAL;
4144     SvSETMAGIC(PL_DBsignal);
4145
4146     SvREFCNT_dec(PL_curstash);
4147     PL_curstash = ostash;
4148 }
4149
4150 #ifndef STRESS_REALLOC
4151 #define REASONABLE(size) (size)
4152 #define REASONABLE_but_at_least(size,min) (size)
4153 #else
4154 #define REASONABLE(size) (1) /* unreasonable */
4155 #define REASONABLE_but_at_least(size,min) (min)
4156 #endif
4157
4158 void
4159 Perl_init_stacks(pTHX)
4160 {
4161     SSize_t size;
4162
4163     /* start with 128-item stack and 8K cxstack */
4164     PL_curstackinfo = new_stackinfo(REASONABLE(128),
4165                                  REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
4166     PL_curstackinfo->si_type = PERLSI_MAIN;
4167     PL_curstack = PL_curstackinfo->si_stack;
4168     PL_mainstack = PL_curstack;         /* remember in case we switch stacks */
4169
4170     PL_stack_base = AvARRAY(PL_curstack);
4171     PL_stack_sp = PL_stack_base;
4172     PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
4173
4174     Newx(PL_tmps_stack,REASONABLE(128),SV*);
4175     PL_tmps_floor = -1;
4176     PL_tmps_ix = -1;
4177     PL_tmps_max = REASONABLE(128);
4178
4179     Newx(PL_markstack,REASONABLE(32),I32);
4180     PL_markstack_ptr = PL_markstack;
4181     PL_markstack_max = PL_markstack + REASONABLE(32);
4182
4183     SET_MARK_OFFSET;
4184
4185     Newx(PL_scopestack,REASONABLE(32),I32);
4186 #ifdef DEBUGGING
4187     Newx(PL_scopestack_name,REASONABLE(32),const char*);
4188 #endif
4189     PL_scopestack_ix = 0;
4190     PL_scopestack_max = REASONABLE(32);
4191
4192     size = REASONABLE_but_at_least(128,SS_MAXPUSH);
4193     Newx(PL_savestack, size, ANY);
4194     PL_savestack_ix = 0;
4195     /*PL_savestack_max lies: it always has SS_MAXPUSH more than it claims */
4196     PL_savestack_max = size - SS_MAXPUSH;
4197 }
4198
4199 #undef REASONABLE
4200
4201 STATIC void
4202 S_nuke_stacks(pTHX)
4203 {
4204     while (PL_curstackinfo->si_next)
4205         PL_curstackinfo = PL_curstackinfo->si_next;
4206     while (PL_curstackinfo) {
4207         PERL_SI *p = PL_curstackinfo->si_prev;
4208         /* curstackinfo->si_stack got nuked by sv_free_arenas() */
4209         Safefree(PL_curstackinfo->si_cxstack);
4210         Safefree(PL_curstackinfo);
4211         PL_curstackinfo = p;
4212     }
4213     Safefree(PL_tmps_stack);
4214     Safefree(PL_markstack);
4215     Safefree(PL_scopestack);
4216 #ifdef DEBUGGING
4217     Safefree(PL_scopestack_name);
4218 #endif
4219     Safefree(PL_savestack);
4220 }
4221
4222 void
4223 Perl_populate_isa(pTHX_ const char *name, STRLEN len, ...)
4224 {
4225     GV *const gv = gv_fetchpvn(name, len, GV_ADD | GV_ADDMULTI, SVt_PVAV);
4226     AV *const isa = GvAVn(gv);
4227     va_list args;
4228
4229     PERL_ARGS_ASSERT_POPULATE_ISA;
4230
4231     if(AvFILLp(isa) != -1)
4232         return;
4233
4234     /* NOTE: No support for tied ISA */
4235
4236     va_start(args, len);
4237     do {
4238         const char *const parent = va_arg(args, const char*);
4239         size_t parent_len;
4240
4241         if (!parent)
4242             break;
4243         parent_len = va_arg(args, size_t);
4244
4245         /* Arguments are supplied with a trailing ::  */
4246         assert(parent_len > 2);
4247         assert(parent[parent_len - 1] == ':');
4248         assert(parent[parent_len - 2] == ':');
4249         av_push(isa, newSVpvn(parent, parent_len - 2));
4250         (void) gv_fetchpvn(parent, parent_len, GV_ADD, SVt_PVGV);
4251     } while (1);
4252     va_end(args);
4253 }
4254
4255
4256 STATIC void
4257 S_init_predump_symbols(pTHX)
4258 {
4259     GV *tmpgv;
4260     IO *io;
4261
4262     sv_setpvs(get_sv("\"", GV_ADD), " ");
4263     PL_ofsgv = (GV*)SvREFCNT_inc(gv_fetchpvs(",", GV_ADD|GV_NOTQUAL, SVt_PV));
4264
4265
4266     /* Historically, PVIOs were blessed into IO::Handle, unless
4267        FileHandle was loaded, in which case they were blessed into
4268        that. Action at a distance.
4269        However, if we simply bless into IO::Handle, we break code
4270        that assumes that PVIOs will have (among others) a seek
4271        method. IO::File inherits from IO::Handle and IO::Seekable,
4272        and provides the needed methods. But if we simply bless into
4273        it, then we break code that assumed that by loading
4274        IO::Handle, *it* would work.
4275        So a compromise is to set up the correct @IO::File::ISA,
4276        so that code that does C<use IO::Handle>; will still work.
4277     */
4278                    
4279     Perl_populate_isa(aTHX_ STR_WITH_LEN("IO::File::ISA"),
4280                       STR_WITH_LEN("IO::Handle::"),
4281                       STR_WITH_LEN("IO::Seekable::"),
4282                       STR_WITH_LEN("Exporter::"),
4283                       NULL);
4284
4285     PL_stdingv = gv_fetchpvs("STDIN", GV_ADD|GV_NOTQUAL, SVt_PVIO);
4286     GvMULTI_on(PL_stdingv);
4287     io = GvIOp(PL_stdingv);
4288     IoTYPE(io) = IoTYPE_RDONLY;
4289     IoIFP(io) = PerlIO_stdin();
4290     tmpgv = gv_fetchpvs("stdin", GV_ADD|GV_NOTQUAL, SVt_PV);
4291     GvMULTI_on(tmpgv);
4292     GvIOp(tmpgv) = MUTABLE_IO(SvREFCNT_inc_simple(io));
4293
4294     tmpgv = gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVIO);
4295     GvMULTI_on(tmpgv);
4296     io = GvIOp(tmpgv);
4297     IoTYPE(io) = IoTYPE_WRONLY;
4298     IoOFP(io) = IoIFP(io) = PerlIO_stdout();
4299     setdefout(tmpgv);
4300     tmpgv = gv_fetchpvs("stdout", GV_ADD|GV_NOTQUAL, SVt_PV);
4301     GvMULTI_on(tmpgv);
4302     GvIOp(tmpgv) = MUTABLE_IO(SvREFCNT_inc_simple(io));
4303
4304     PL_stderrgv = gv_fetchpvs("STDERR", GV_ADD|GV_NOTQUAL, SVt_PVIO);
4305     GvMULTI_on(PL_stderrgv);
4306     io = GvIOp(PL_stderrgv);
4307     IoTYPE(io) = IoTYPE_WRONLY;
4308     IoOFP(io) = IoIFP(io) = PerlIO_stderr();
4309     tmpgv = gv_fetchpvs("stderr", GV_ADD|GV_NOTQUAL, SVt_PV);
4310     GvMULTI_on(tmpgv);
4311     GvIOp(tmpgv) = MUTABLE_IO(SvREFCNT_inc_simple(io));
4312
4313     PL_statname = newSVpvs("");         /* last filename we did stat on */
4314 }
4315
4316 void
4317 Perl_init_argv_symbols(pTHX_ int argc, char **argv)
4318 {
4319     PERL_ARGS_ASSERT_INIT_ARGV_SYMBOLS;
4320
4321     argc--,argv++;      /* skip name of script */
4322     if (PL_doswitches) {
4323         for (; argc > 0 && **argv == '-'; argc--,argv++) {
4324             char *s;
4325             if (!argv[0][1])
4326                 break;
4327             if (argv[0][1] == '-' && !argv[0][2]) {
4328                 argc--,argv++;
4329                 break;
4330             }
4331             if ((s = strchr(argv[0], '='))) {
4332                 const char *const start_name = argv[0] + 1;
4333                 sv_setpv(GvSV(gv_fetchpvn_flags(start_name, s - start_name,
4334                                                 TRUE, SVt_PV)), s + 1);
4335             }
4336             else
4337                 sv_setiv(GvSV(gv_fetchpv(argv[0]+1, GV_ADD, SVt_PV)),1);
4338         }
4339     }
4340     if ((PL_argvgv = gv_fetchpvs("ARGV", GV_ADD|GV_NOTQUAL, SVt_PVAV))) {
4341         SvREFCNT_inc_simple_void_NN(PL_argvgv);
4342         GvMULTI_on(PL_argvgv);
4343         av_clear(GvAVn(PL_argvgv));
4344         for (; argc > 0; argc--,argv++) {
4345             SV * const sv = newSVpv(argv[0],0);
4346             av_push(GvAV(PL_argvgv),sv);
4347             if (!(PL_unicode & PERL_UNICODE_LOCALE_FLAG) || PL_utf8locale) {
4348                  if (PL_unicode & PERL_UNICODE_ARGV_FLAG)
4349                       SvUTF8_on(sv);
4350             }
4351             if (PL_unicode & PERL_UNICODE_WIDESYSCALLS_FLAG) /* Sarathy? */
4352                  (void)sv_utf8_decode(sv);
4353         }
4354     }
4355
4356     if (PL_inplace && (!PL_argvgv || AvFILL(GvAV(PL_argvgv)) == -1))
4357         Perl_ck_warner_d(aTHX_ packWARN(WARN_INPLACE),
4358                          "-i used with no filenames on the command line, "
4359                          "reading from STDIN");
4360 }
4361
4362 STATIC void
4363 S_init_postdump_symbols(pTHX_ int argc, char **argv, char **env)
4364 {
4365 #ifdef USE_ITHREADS
4366     dVAR;
4367 #endif
4368     GV* tmpgv;
4369
4370     PERL_ARGS_ASSERT_INIT_POSTDUMP_SYMBOLS;
4371
4372     PL_toptarget = newSV_type(SVt_PVIV);
4373     SvPVCLEAR(PL_toptarget);
4374     PL_bodytarget = newSV_type(SVt_PVIV);
4375     SvPVCLEAR(PL_bodytarget);
4376     PL_formtarget = PL_bodytarget;
4377
4378     TAINT;
4379
4380     init_argv_symbols(argc,argv);
4381
4382     if ((tmpgv = gv_fetchpvs("0", GV_ADD|GV_NOTQUAL, SVt_PV))) {
4383         sv_setpv(GvSV(tmpgv),PL_origfilename);
4384     }
4385     if ((PL_envgv = gv_fetchpvs("ENV", GV_ADD|GV_NOTQUAL, SVt_PVHV))) {
4386         HV *hv;
4387         bool env_is_not_environ;
4388         SvREFCNT_inc_simple_void_NN(PL_envgv);
4389         GvMULTI_on(PL_envgv);
4390         hv = GvHVn(PL_envgv);
4391         hv_magic(hv, NULL, PERL_MAGIC_env);
4392 #ifndef PERL_MICRO
4393 #ifdef USE_ENVIRON_ARRAY
4394         /* Note that if the supplied env parameter is actually a copy
4395            of the global environ then it may now point to free'd memory
4396            if the environment has been modified since. To avoid this
4397            problem we treat env==NULL as meaning 'use the default'
4398         */
4399         if (!env)
4400             env = environ;
4401         env_is_not_environ = env != environ;
4402         if (env_is_not_environ
4403 #  ifdef USE_ITHREADS
4404             && PL_curinterp == aTHX
4405 #  endif
4406            )
4407         {
4408             environ[0] = NULL;
4409         }
4410         if (env) {
4411           char *s, *old_var;
4412           STRLEN nlen;
4413           SV *sv;
4414           HV *dups = newHV();
4415
4416           for (; *env; env++) {
4417             old_var = *env;
4418
4419             if (!(s = strchr(old_var,'=')) || s == old_var)
4420                 continue;
4421             nlen = s - old_var;
4422
4423 #if defined(MSDOS) && !defined(DJGPP)
4424             *s = '\0';
4425             (void)strupr(old_var);
4426             *s = '=';
4427 #endif
4428             if (hv_exists(hv, old_var, nlen)) {
4429                 const char *name = savepvn(old_var, nlen);
4430
4431                 /* make sure we use the same value as getenv(), otherwise code that
4432                    uses getenv() (like setlocale()) might see a different value to %ENV
4433                  */
4434                 sv = newSVpv(PerlEnv_getenv(name), 0);
4435
4436                 /* keep a count of the dups of this name so we can de-dup environ later */
4437                 if (hv_exists(dups, name, nlen))
4438                     ++SvIVX(*hv_fetch(dups, name, nlen, 0));
4439                 else
4440                     (void)hv_store(dups, name, nlen, newSViv(1), 0);
4441
4442                 Safefree(name);
4443             }
4444             else {
4445                 sv = newSVpv(s+1, 0);
4446             }
4447             (void)hv_store(hv, old_var, nlen, sv, 0);
4448             if (env_is_not_environ)
4449                 mg_set(sv);
4450           }
4451           if (HvKEYS(dups)) {
4452               /* environ has some duplicate definitions, remove them */
4453               HE *entry;
4454               hv_iterinit(dups);
4455               while ((entry = hv_iternext_flags(dups, 0))) {
4456                   STRLEN nlen;
4457                   const char *name = HePV(entry, nlen);
4458                   IV count = SvIV(HeVAL(entry));
4459                   IV i;
4460                   SV **valp = hv_fetch(hv, name, nlen, 0);
4461
4462                   assert(valp);
4463
4464                   /* try to remove any duplicate names, depending on the
4465                    * implementation used in my_setenv() the iteration might
4466                    * not be necessary, but let's be safe.
4467                    */
4468                   for (i = 0; i < count; ++i)
4469                       my_setenv(name, 0);
4470
4471                   /* and set it back to the value we set $ENV{name} to */
4472                   my_setenv(name, SvPV_nolen(*valp));
4473               }
4474           }
4475           SvREFCNT_dec_NN(dups);
4476       }
4477 #endif /* USE_ENVIRON_ARRAY */
4478 #endif /* !PERL_MICRO */
4479     }
4480     TAINT_NOT;
4481
4482     /* touch @F array to prevent spurious warnings 20020415 MJD */
4483     if (PL_minus_a) {
4484       (void) get_av("main::F", GV_ADD | GV_ADDMULTI);
4485     }
4486 }
4487
4488 STATIC void
4489 S_init_perllib(pTHX)
4490 {
4491 #ifndef VMS
4492     const char *perl5lib = NULL;
4493 #endif
4494     const char *s;
4495 #if defined(WIN32) && !defined(PERL_IS_MINIPERL)
4496     STRLEN len;
4497 #endif
4498
4499     if (!TAINTING_get) {
4500 #ifndef VMS
4501         perl5lib = PerlEnv_getenv("PERL5LIB");
4502 /*
4503  * It isn't possible to delete an environment variable with
4504  * PERL_USE_SAFE_PUTENV set unless unsetenv() is also available, so in that
4505  * case we treat PERL5LIB as undefined if it has a zero-length value.
4506  */
4507 #if defined(PERL_USE_SAFE_PUTENV) && ! defined(HAS_UNSETENV)
4508         if (perl5lib && *perl5lib != '\0')
4509 #else
4510         if (perl5lib)
4511 #endif
4512             incpush_use_sep(perl5lib, 0, INCPUSH_ADD_SUB_DIRS);
4513         else {
4514             s = PerlEnv_getenv("PERLLIB");
4515             if (s)
4516                 incpush_use_sep(s, 0, 0);
4517         }
4518 #else /* VMS */
4519         /* Treat PERL5?LIB as a possible search list logical name -- the
4520          * "natural" VMS idiom for a Unix path string.  We allow each
4521          * element to be a set of |-separated directories for compatibility.
4522          */
4523         char buf[256];
4524         int idx = 0;
4525         if (vmstrnenv("PERL5LIB",buf,0,NULL,0))
4526             do {
4527                 incpush_use_sep(buf, 0, INCPUSH_ADD_SUB_DIRS);
4528             } while (vmstrnenv("PERL5LIB",buf,++idx,NULL,0));
4529         else {
4530             while (vmstrnenv("PERLLIB",buf,idx++,NULL,0))
4531                 incpush_use_sep(buf, 0, 0);
4532         }
4533 #endif /* VMS */
4534     }
4535
4536 #ifndef PERL_IS_MINIPERL
4537     /* miniperl gets just -I..., the split of $ENV{PERL5LIB}, and "." in @INC
4538        (and not the architecture specific directories from $ENV{PERL5LIB}) */
4539
4540 /* Use the ~-expanded versions of APPLLIB (undocumented),
4541     SITEARCH, SITELIB, VENDORARCH, VENDORLIB, ARCHLIB and PRIVLIB
4542 */
4543 #ifdef APPLLIB_EXP
4544     S_incpush_use_sep(aTHX_ STR_WITH_LEN(APPLLIB_EXP),
4545                       INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE);
4546 #endif
4547
4548 #ifdef SITEARCH_EXP
4549     /* sitearch is always relative to sitelib on Windows for
4550      * DLL-based path intuition to work correctly */
4551 #  if !defined(WIN32)
4552         S_incpush_use_sep(aTHX_ STR_WITH_LEN(SITEARCH_EXP),
4553                           INCPUSH_CAN_RELOCATE);
4554 #  endif
4555 #endif
4556
4557 #ifdef SITELIB_EXP
4558 #  if defined(WIN32)
4559     /* this picks up sitearch as well */
4560         s = PerlEnv_sitelib_path(PERL_FS_VERSION, &len);
4561         if (s)
4562             incpush_use_sep(s, len, INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE);
4563 #  else
4564         S_incpush_use_sep(aTHX_ STR_WITH_LEN(SITELIB_EXP), INCPUSH_CAN_RELOCATE);
4565 #  endif
4566 #endif
4567
4568 #ifdef PERL_VENDORARCH_EXP
4569     /* vendorarch is always relative to vendorlib on Windows for
4570      * DLL-based path intuition to work correctly */
4571 #  if !defined(WIN32)
4572     S_incpush_use_sep(aTHX_ STR_WITH_LEN(PERL_VENDORARCH_EXP),
4573                       INCPUSH_CAN_RELOCATE);
4574 #  endif
4575 #endif
4576
4577 #ifdef PERL_VENDORLIB_EXP
4578 #  if defined(WIN32)
4579     /* this picks up vendorarch as well */
4580         s = PerlEnv_vendorlib_path(PERL_FS_VERSION, &len);
4581         if (s)
4582             incpush_use_sep(s, len, INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE);
4583 #  else
4584         S_incpush_use_sep(aTHX_ STR_WITH_LEN(PERL_VENDORLIB_EXP),
4585                           INCPUSH_CAN_RELOCATE);
4586 #  endif
4587 #endif
4588
4589 #ifdef ARCHLIB_EXP
4590     S_incpush_use_sep(aTHX_ STR_WITH_LEN(ARCHLIB_EXP), INCPUSH_CAN_RELOCATE);
4591 #endif
4592
4593 #ifndef PRIVLIB_EXP
4594 #  define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
4595 #endif
4596
4597 #if defined(WIN32)
4598     s = PerlEnv_lib_path(PERL_FS_VERSION, &len);
4599     if (s)
4600         incpush_use_sep(s, len, INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE);
4601 #else
4602 #  ifdef NETWARE
4603     S_incpush_use_sep(aTHX_ PRIVLIB_EXP, 0, INCPUSH_CAN_RELOCATE);
4604 #  else
4605     S_incpush_use_sep(aTHX_ STR_WITH_LEN(PRIVLIB_EXP), INCPUSH_CAN_RELOCATE);
4606 #  endif
4607 #endif
4608
4609 #ifdef PERL_OTHERLIBDIRS
4610     S_incpush_use_sep(aTHX_ STR_WITH_LEN(PERL_OTHERLIBDIRS),
4611                       INCPUSH_ADD_VERSIONED_SUB_DIRS|INCPUSH_NOT_BASEDIR
4612                       |INCPUSH_CAN_RELOCATE);
4613 #endif
4614
4615     if (!TAINTING_get) {
4616 #ifndef VMS
4617 /*
4618  * It isn't possible to delete an environment variable with
4619  * PERL_USE_SAFE_PUTENV set unless unsetenv() is also available, so in that
4620  * case we treat PERL5LIB as undefined if it has a zero-length value.
4621  */
4622 #if defined(PERL_USE_SAFE_PUTENV) && ! defined(HAS_UNSETENV)
4623         if (perl5lib && *perl5lib != '\0')
4624 #else
4625         if (perl5lib)
4626 #endif
4627             incpush_use_sep(perl5lib, 0,
4628                             INCPUSH_ADD_OLD_VERS|INCPUSH_NOT_BASEDIR);
4629 #else /* VMS */
4630         /* Treat PERL5?LIB as a possible search list logical name -- the
4631          * "natural" VMS idiom for a Unix path string.  We allow each
4632          * element to be a set of |-separated directories for compatibility.
4633          */
4634         char buf[256];
4635         int idx = 0;
4636         if (vmstrnenv("PERL5LIB",buf,0,NULL,0))
4637             do {
4638                 incpush_use_sep(buf, 0,
4639                                 INCPUSH_ADD_OLD_VERS|INCPUSH_NOT_BASEDIR);
4640             } while (vmstrnenv("PERL5LIB",buf,++idx,NULL,0));
4641 #endif /* VMS */
4642     }
4643
4644 /* Use the ~-expanded versions of APPLLIB (undocumented),
4645     SITELIB and VENDORLIB for older versions
4646 */
4647 #ifdef APPLLIB_EXP
4648     S_incpush_use_sep(aTHX_ STR_WITH_LEN(APPLLIB_EXP), INCPUSH_ADD_OLD_VERS
4649                       |INCPUSH_NOT_BASEDIR|INCPUSH_CAN_RELOCATE);
4650 #endif
4651
4652 #if defined(SITELIB_STEM) && defined(PERL_INC_VERSION_LIST)
4653     /* Search for version-specific dirs below here */
4654     S_incpush_use_sep(aTHX_ STR_WITH_LEN(SITELIB_STEM),
4655                       INCPUSH_ADD_OLD_VERS|INCPUSH_CAN_RELOCATE);
4656 #endif
4657
4658
4659 #if defined(PERL_VENDORLIB_STEM) && defined(PERL_INC_VERSION_LIST)
4660     /* Search for version-specific dirs below here */
4661     S_incpush_use_sep(aTHX_ STR_WITH_LEN(PERL_VENDORLIB_STEM),
4662                       INCPUSH_ADD_OLD_VERS|INCPUSH_CAN_RELOCATE);
4663 #endif
4664
4665 #ifdef PERL_OTHERLIBDIRS
4666     S_incpush_use_sep(aTHX_ STR_WITH_LEN(PERL_OTHERLIBDIRS),
4667                       INCPUSH_ADD_OLD_VERS|INCPUSH_ADD_ARCHONLY_SUB_DIRS
4668                       |INCPUSH_CAN_RELOCATE);
4669 #endif
4670 #endif /* !PERL_IS_MINIPERL */
4671
4672     if (!TAINTING_get) {
4673 #if !defined(PERL_IS_MINIPERL) && defined(DEFAULT_INC_EXCLUDES_DOT)
4674         const char * const unsafe = PerlEnv_getenv("PERL_USE_UNSAFE_INC");
4675         if (unsafe && strEQ(unsafe, "1"))
4676 #endif
4677           S_incpush(aTHX_ STR_WITH_LEN("."), 0);
4678     }
4679 }
4680
4681 #if defined(DOSISH) || defined(__SYMBIAN32__)
4682 #    define PERLLIB_SEP ';'
4683 #else
4684 #  if defined(__VMS)
4685 #    define PERLLIB_SEP PL_perllib_sep
4686 #  else
4687 #    define PERLLIB_SEP ':'
4688 #  endif
4689 #endif
4690 #ifndef PERLLIB_MANGLE
4691 #  define PERLLIB_MANGLE(s,n) (s)
4692 #endif
4693
4694 #ifndef PERL_IS_MINIPERL
4695 /* Push a directory onto @INC if it exists.
4696    Generate a new SV if we do this, to save needing to copy the SV we push
4697    onto @INC  */
4698 STATIC SV *
4699 S_incpush_if_exists(pTHX_ AV *const av, SV *dir, SV *const stem)
4700 {
4701     Stat_t tmpstatbuf;
4702
4703     PERL_ARGS_ASSERT_INCPUSH_IF_EXISTS;
4704
4705     if (PerlLIO_stat(SvPVX_const(dir), &tmpstatbuf) >= 0 &&
4706         S_ISDIR(tmpstatbuf.st_mode)) {
4707         av_push(av, dir);
4708         dir = newSVsv(stem);
4709     } else {
4710         /* Truncate dir back to stem.  */
4711         SvCUR_set(dir, SvCUR(stem));
4712     }
4713     return dir;
4714 }
4715 #endif
4716
4717 STATIC SV *
4718 S_mayberelocate(pTHX_ const char *const dir, STRLEN len, U32 flags)
4719 {
4720     const U8 canrelocate = (U8)flags & INCPUSH_CAN_RELOCATE;
4721     SV *libdir;
4722
4723     PERL_ARGS_ASSERT_MAYBERELOCATE;
4724     assert(len > 0);
4725
4726     /* I am not convinced that this is valid when PERLLIB_MANGLE is
4727        defined to so something (in os2/os2.c), but the code has been
4728        this way, ignoring any possible changed of length, since
4729        760ac839baf413929cd31cc32ffd6dba6b781a81 (5.003_02) so I'll leave
4730        it be.  */
4731     libdir = newSVpvn(PERLLIB_MANGLE(dir, len), len);
4732
4733 #ifdef VMS
4734     {
4735         char *unix;
4736
4737         if ((unix = tounixspec_ts(SvPV(libdir,len),NULL)) != NULL) {
4738             len = strlen(unix);
4739             while (len > 1 && unix[len-1] == '/') len--;  /* Cosmetic */
4740             sv_usepvn(libdir,unix,len);
4741         }
4742         else
4743             PerlIO_printf(Perl_error_log,
4744                           "Failed to unixify @INC element \"%s\"\n",
4745                           SvPV_nolen_const(libdir));
4746     }
4747 #endif
4748
4749         /* Do the if() outside the #ifdef to avoid warnings about an unused
4750            parameter.  */
4751         if (canrelocate) {
4752 #ifdef PERL_RELOCATABLE_INC
4753         /*
4754          * Relocatable include entries are marked with a leading .../
4755          *
4756          * The algorithm is
4757          * 0: Remove that leading ".../"
4758          * 1: Remove trailing executable name (anything after the last '/')
4759          *    from the perl path to give a perl prefix
4760          * Then
4761          * While the @INC element starts "../" and the prefix ends with a real
4762          * directory (ie not . or ..) chop that real directory off the prefix
4763          * and the leading "../" from the @INC element. ie a logical "../"
4764          * cleanup
4765          * Finally concatenate the prefix and the remainder of the @INC element
4766          * The intent is that /usr/local/bin/perl and .../../lib/perl5
4767          * generates /usr/local/lib/perl5
4768          */
4769             const char *libpath = SvPVX(libdir);
4770             STRLEN libpath_len = SvCUR(libdir);
4771             if (libpath_len >= 4 && memEQ (libpath, ".../", 4)) {
4772                 /* Game on!  */
4773                 SV * const caret_X = get_sv("\030", 0);
4774                 /* Going to use the SV just as a scratch buffer holding a C
4775                    string:  */
4776                 SV *prefix_sv;
4777                 char *prefix;
4778                 char *lastslash;
4779
4780                 /* $^X is *the* source of taint if tainting is on, hence
4781                    SvPOK() won't be true.  */
4782                 assert(caret_X);
4783                 assert(SvPOKp(caret_X));
4784                 prefix_sv = newSVpvn_flags(SvPVX(caret_X), SvCUR(caret_X),
4785                                            SvUTF8(caret_X));
4786                 /* Firstly take off the leading .../
4787                    If all else fail we'll do the paths relative to the current
4788                    directory.  */
4789                 sv_chop(libdir, libpath + 4);
4790                 /* Don't use SvPV as we're intentionally bypassing taining,
4791                    mortal copies that the mg_get of tainting creates, and
4792                    corruption that seems to come via the save stack.
4793                    I guess that the save stack isn't correctly set up yet.  */
4794                 libpath = SvPVX(libdir);
4795                 libpath_len = SvCUR(libdir);
4796
4797                 /* This would work more efficiently with memrchr, but as it's
4798                    only a GNU extension we'd need to probe for it and
4799                    implement our own. Not hard, but maybe not worth it?  */
4800
4801                 prefix = SvPVX(prefix_sv);
4802                 lastslash = strrchr(prefix, '/');
4803
4804                 /* First time in with the *lastslash = '\0' we just wipe off
4805                    the trailing /perl from (say) /usr/foo/bin/perl
4806                 */
4807                 if (lastslash) {
4808                     SV *tempsv;
4809                     while ((*lastslash = '\0'), /* Do that, come what may.  */
4810                            (libpath_len >= 3 && _memEQs(libpath, "../")
4811                             && (lastslash = strrchr(prefix, '/')))) {
4812                         if (lastslash[1] == '\0'
4813                             || (lastslash[1] == '.'
4814                                 && (lastslash[2] == '/' /* ends "/."  */
4815                                     || (lastslash[2] == '/'
4816                                         && lastslash[3] == '/' /* or "/.."  */
4817                                         )))) {
4818                             /* Prefix ends "/" or "/." or "/..", any of which
4819                                are fishy, so don't do any more logical cleanup.
4820                             */
4821                             break;
4822                         }
4823                         /* Remove leading "../" from path  */
4824                         libpath += 3;
4825                         libpath_len -= 3;
4826                         /* Next iteration round the loop removes the last
4827                            directory name from prefix by writing a '\0' in
4828                            the while clause.  */
4829                     }
4830                     /* prefix has been terminated with a '\0' to the correct
4831                        length. libpath points somewhere into the libdir SV.
4832                        We need to join the 2 with '/' and drop the result into
4833                        libdir.  */
4834                     tempsv = Perl_newSVpvf(aTHX_ "%s/%s", prefix, libpath);
4835                     SvREFCNT_dec(libdir);
4836                     /* And this is the new libdir.  */
4837                     libdir = tempsv;