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