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