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