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