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