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