Update Filter::Util::Call to CPAN version 1.58
[perl.git] / perl.c
1 #line 2 "perl.c"
2 /*    perl.c
3  *
4  *    Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001
5  *    2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012
6  *    2013, 2014, 2015, 2016, 2017 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     {
1697         int i;
1698         assert(argc >= 0);
1699         for(i = 0; i != argc; i++)
1700             assert(argv[i]);
1701         assert(!argv[argc]);
1702     }
1703     PL_origargc = argc;
1704     PL_origargv = argv;
1705
1706     if (PL_origalen != 0) {
1707         PL_origalen = 1; /* don't use old PL_origalen if perl_parse() is called again */
1708     }
1709     else {
1710         /* Set PL_origalen be the sum of the contiguous argv[]
1711          * elements plus the size of the env in case that it is
1712          * contiguous with the argv[].  This is used in mg.c:Perl_magic_set()
1713          * as the maximum modifiable length of $0.  In the worst case
1714          * the area we are able to modify is limited to the size of
1715          * the original argv[0].  (See below for 'contiguous', though.)
1716          * --jhi */
1717          const char *s = NULL;
1718          const UV mask = ~(UV)(PTRSIZE-1);
1719          /* Do the mask check only if the args seem like aligned. */
1720          const UV aligned =
1721            (mask < ~(UV)0) && ((PTR2UV(argv[0]) & mask) == PTR2UV(argv[0]));
1722
1723          /* See if all the arguments are contiguous in memory.  Note
1724           * that 'contiguous' is a loose term because some platforms
1725           * align the argv[] and the envp[].  If the arguments look
1726           * like non-aligned, assume that they are 'strictly' or
1727           * 'traditionally' contiguous.  If the arguments look like
1728           * aligned, we just check that they are within aligned
1729           * PTRSIZE bytes.  As long as no system has something bizarre
1730           * like the argv[] interleaved with some other data, we are
1731           * fine.  (Did I just evoke Murphy's Law?)  --jhi */
1732          if (PL_origargv && PL_origargc >= 1 && (s = PL_origargv[0])) {
1733               int i;
1734               while (*s) s++;
1735               for (i = 1; i < PL_origargc; i++) {
1736                    if ((PL_origargv[i] == s + 1
1737 #ifdef OS2
1738                         || PL_origargv[i] == s + 2
1739 #endif 
1740                             )
1741                        ||
1742                        (aligned &&
1743                         (PL_origargv[i] >  s &&
1744                          PL_origargv[i] <=
1745                          INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask)))
1746                         )
1747                    {
1748                         s = PL_origargv[i];
1749                         while (*s) s++;
1750                    }
1751                    else
1752                         break;
1753               }
1754          }
1755
1756 #ifndef PERL_USE_SAFE_PUTENV
1757          /* Can we grab env area too to be used as the area for $0? */
1758          if (s && PL_origenviron && !PL_use_safe_putenv) {
1759               if ((PL_origenviron[0] == s + 1)
1760                   ||
1761                   (aligned &&
1762                    (PL_origenviron[0] >  s &&
1763                     PL_origenviron[0] <=
1764                     INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask)))
1765                  )
1766               {
1767                    int i;
1768 #ifndef OS2             /* ENVIRON is read by the kernel too. */
1769                    s = PL_origenviron[0];
1770                    while (*s) s++;
1771 #endif
1772                    my_setenv("NoNe  SuCh", NULL);
1773                    /* Force copy of environment. */
1774                    for (i = 1; PL_origenviron[i]; i++) {
1775                         if (PL_origenviron[i] == s + 1
1776                             ||
1777                             (aligned &&
1778                              (PL_origenviron[i] >  s &&
1779                               PL_origenviron[i] <=
1780                               INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask)))
1781                            )
1782                         {
1783                              s = PL_origenviron[i];
1784                              while (*s) s++;
1785                         }
1786                         else
1787                              break;
1788                    }
1789               }
1790          }
1791 #endif /* !defined(PERL_USE_SAFE_PUTENV) */
1792
1793          PL_origalen = s ? s - PL_origargv[0] + 1 : 0;
1794     }
1795
1796     if (PL_do_undump) {
1797
1798         /* Come here if running an undumped a.out. */
1799
1800         PL_origfilename = savepv(argv[0]);
1801         PL_do_undump = FALSE;
1802         cxstack_ix = -1;                /* start label stack again */
1803         init_ids();
1804         assert (!TAINT_get);
1805         TAINT;
1806         set_caret_X();
1807         TAINT_NOT;
1808         init_postdump_symbols(argc,argv,env);
1809         return 0;
1810     }
1811
1812     if (PL_main_root) {
1813         op_free(PL_main_root);
1814         PL_main_root = NULL;
1815     }
1816     PL_main_start = NULL;
1817     SvREFCNT_dec(PL_main_cv);
1818     PL_main_cv = NULL;
1819
1820     time(&PL_basetime);
1821     oldscope = PL_scopestack_ix;
1822     PL_dowarn = G_WARN_OFF;
1823
1824     JMPENV_PUSH(ret);
1825     switch (ret) {
1826     case 0:
1827         parse_body(env,xsinit);
1828         if (PL_unitcheckav) {
1829             call_list(oldscope, PL_unitcheckav);
1830         }
1831         if (PL_checkav) {
1832             PERL_SET_PHASE(PERL_PHASE_CHECK);
1833             call_list(oldscope, PL_checkav);
1834         }
1835         ret = 0;
1836         break;
1837     case 1:
1838         STATUS_ALL_FAILURE;
1839         /* FALLTHROUGH */
1840     case 2:
1841         /* my_exit() was called */
1842         while (PL_scopestack_ix > oldscope)
1843             LEAVE;
1844         FREETMPS;
1845         SET_CURSTASH(PL_defstash);
1846         if (PL_unitcheckav) {
1847             call_list(oldscope, PL_unitcheckav);
1848         }
1849         if (PL_checkav) {
1850             PERL_SET_PHASE(PERL_PHASE_CHECK);
1851             call_list(oldscope, PL_checkav);
1852         }
1853         ret = STATUS_EXIT;
1854         if (ret == 0) ret = 0x100;
1855         break;
1856     case 3:
1857         PerlIO_printf(Perl_error_log, "panic: top_env\n");
1858         ret = 1;
1859         break;
1860     }
1861     JMPENV_POP;
1862     return ret;
1863 }
1864
1865 /* This needs to stay in perl.c, as perl.c is compiled with different flags for
1866    miniperl, and we need to see those flags reflected in the values here.  */
1867
1868 /* What this returns is subject to change.  Use the public interface in Config.
1869  */
1870 static void
1871 S_Internals_V(pTHX_ CV *cv)
1872 {
1873     dXSARGS;
1874 #ifdef LOCAL_PATCH_COUNT
1875     const int local_patch_count = LOCAL_PATCH_COUNT;
1876 #else
1877     const int local_patch_count = 0;
1878 #endif
1879     const int entries = 3 + local_patch_count;
1880     int i;
1881     static const char non_bincompat_options[] = 
1882 #  ifdef DEBUGGING
1883                              " DEBUGGING"
1884 #  endif
1885 #  ifdef NO_MATHOMS
1886                              " NO_MATHOMS"
1887 #  endif
1888 #  ifdef NO_HASH_SEED
1889                              " NO_HASH_SEED"
1890 #  endif
1891 #  ifdef NO_TAINT_SUPPORT
1892                              " NO_TAINT_SUPPORT"
1893 #  endif
1894 #  ifdef PERL_BOOL_AS_CHAR
1895                              " PERL_BOOL_AS_CHAR"
1896 #  endif
1897 #  ifdef PERL_COPY_ON_WRITE
1898                              " PERL_COPY_ON_WRITE"
1899 #  endif
1900 #  ifdef PERL_DISABLE_PMC
1901                              " PERL_DISABLE_PMC"
1902 #  endif
1903 #  ifdef PERL_DONT_CREATE_GVSV
1904                              " PERL_DONT_CREATE_GVSV"
1905 #  endif
1906 #  ifdef PERL_EXTERNAL_GLOB
1907                              " PERL_EXTERNAL_GLOB"
1908 #  endif
1909 #  ifdef PERL_HASH_FUNC_SIPHASH
1910                              " PERL_HASH_FUNC_SIPHASH"
1911 #  endif
1912 #  ifdef PERL_HASH_FUNC_SDBM
1913                              " PERL_HASH_FUNC_SDBM"
1914 #  endif
1915 #  ifdef PERL_HASH_FUNC_DJB2
1916                              " PERL_HASH_FUNC_DJB2"
1917 #  endif
1918 #  ifdef PERL_HASH_FUNC_SUPERFAST
1919                              " PERL_HASH_FUNC_SUPERFAST"
1920 #  endif
1921 #  ifdef PERL_HASH_FUNC_MURMUR3
1922                              " PERL_HASH_FUNC_MURMUR3"
1923 #  endif
1924 #  ifdef PERL_HASH_FUNC_ONE_AT_A_TIME
1925                              " PERL_HASH_FUNC_ONE_AT_A_TIME"
1926 #  endif
1927 #  ifdef PERL_HASH_FUNC_ONE_AT_A_TIME_HARD
1928                              " PERL_HASH_FUNC_ONE_AT_A_TIME_HARD"
1929 #  endif
1930 #  ifdef PERL_HASH_FUNC_ONE_AT_A_TIME_OLD
1931                              " PERL_HASH_FUNC_ONE_AT_A_TIME_OLD"
1932 #  endif
1933 #  ifdef PERL_IS_MINIPERL
1934                              " PERL_IS_MINIPERL"
1935 #  endif
1936 #  ifdef PERL_MALLOC_WRAP
1937                              " PERL_MALLOC_WRAP"
1938 #  endif
1939 #  ifdef PERL_MEM_LOG
1940                              " PERL_MEM_LOG"
1941 #  endif
1942 #  ifdef PERL_MEM_LOG_NOIMPL
1943                              " PERL_MEM_LOG_NOIMPL"
1944 #  endif
1945 #  ifdef PERL_OP_PARENT
1946                              " PERL_OP_PARENT"
1947 #  endif
1948 #  ifdef PERL_PERTURB_KEYS_DETERMINISTIC
1949                              " PERL_PERTURB_KEYS_DETERMINISTIC"
1950 #  endif
1951 #  ifdef PERL_PERTURB_KEYS_DISABLED
1952                              " PERL_PERTURB_KEYS_DISABLED"
1953 #  endif
1954 #  ifdef PERL_PERTURB_KEYS_RANDOM
1955                              " PERL_PERTURB_KEYS_RANDOM"
1956 #  endif
1957 #  ifdef PERL_PRESERVE_IVUV
1958                              " PERL_PRESERVE_IVUV"
1959 #  endif
1960 #  ifdef PERL_RELOCATABLE_INCPUSH
1961                              " PERL_RELOCATABLE_INCPUSH"
1962 #  endif
1963 #  ifdef PERL_USE_DEVEL
1964                              " PERL_USE_DEVEL"
1965 #  endif
1966 #  ifdef PERL_USE_SAFE_PUTENV
1967                              " PERL_USE_SAFE_PUTENV"
1968 #  endif
1969 #  ifdef SILENT_NO_TAINT_SUPPORT
1970                              " SILENT_NO_TAINT_SUPPORT"
1971 #  endif
1972 #  ifdef UNLINK_ALL_VERSIONS
1973                              " UNLINK_ALL_VERSIONS"
1974 #  endif
1975 #  ifdef USE_ATTRIBUTES_FOR_PERLIO
1976                              " USE_ATTRIBUTES_FOR_PERLIO"
1977 #  endif
1978 #  ifdef USE_FAST_STDIO
1979                              " USE_FAST_STDIO"
1980 #  endif               
1981 #  ifdef USE_LOCALE
1982                              " USE_LOCALE"
1983 #  endif
1984 #  ifdef USE_LOCALE_CTYPE
1985                              " USE_LOCALE_CTYPE"
1986 #  endif
1987 #  ifdef WIN32_NO_REGISTRY
1988                              " USE_NO_REGISTRY"
1989 #  endif
1990 #  ifdef USE_PERL_ATOF
1991                              " USE_PERL_ATOF"
1992 #  endif               
1993 #  ifdef USE_SITECUSTOMIZE
1994                              " USE_SITECUSTOMIZE"
1995 #  endif               
1996         ;
1997     PERL_UNUSED_ARG(cv);
1998     PERL_UNUSED_VAR(items);
1999
2000     EXTEND(SP, entries);
2001
2002     PUSHs(sv_2mortal(newSVpv(PL_bincompat_options, 0)));
2003     PUSHs(Perl_newSVpvn_flags(aTHX_ non_bincompat_options,
2004                               sizeof(non_bincompat_options) - 1, SVs_TEMP));
2005
2006 #ifndef PERL_BUILD_DATE
2007 #  ifdef __DATE__
2008 #    ifdef __TIME__
2009 #      define PERL_BUILD_DATE __DATE__ " " __TIME__
2010 #    else
2011 #      define PERL_BUILD_DATE __DATE__
2012 #    endif
2013 #  endif
2014 #endif
2015
2016 #ifdef PERL_BUILD_DATE
2017     PUSHs(Perl_newSVpvn_flags(aTHX_
2018                               STR_WITH_LEN("Compiled at " PERL_BUILD_DATE),
2019                               SVs_TEMP));
2020 #else
2021     PUSHs(&PL_sv_undef);
2022 #endif
2023
2024     for (i = 1; i <= local_patch_count; i++) {
2025         /* This will be an undef, if PL_localpatches[i] is NULL.  */
2026         PUSHs(sv_2mortal(newSVpv(PL_localpatches[i], 0)));
2027     }
2028
2029     XSRETURN(entries);
2030 }
2031
2032 #define INCPUSH_UNSHIFT                 0x01
2033 #define INCPUSH_ADD_OLD_VERS            0x02
2034 #define INCPUSH_ADD_VERSIONED_SUB_DIRS  0x04
2035 #define INCPUSH_ADD_ARCHONLY_SUB_DIRS   0x08
2036 #define INCPUSH_NOT_BASEDIR             0x10
2037 #define INCPUSH_CAN_RELOCATE            0x20
2038 #define INCPUSH_ADD_SUB_DIRS    \
2039     (INCPUSH_ADD_VERSIONED_SUB_DIRS|INCPUSH_ADD_ARCHONLY_SUB_DIRS)
2040
2041 STATIC void *
2042 S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
2043 {
2044     dVAR;
2045     PerlIO *rsfp;
2046     int argc = PL_origargc;
2047     char **argv = PL_origargv;
2048     const char *scriptname = NULL;
2049     bool dosearch = FALSE;
2050     char c;
2051     bool doextract = FALSE;
2052     const char *cddir = NULL;
2053 #ifdef USE_SITECUSTOMIZE
2054     bool minus_f = FALSE;
2055 #endif
2056     SV *linestr_sv = NULL;
2057     bool add_read_e_script = FALSE;
2058     U32 lex_start_flags = 0;
2059
2060     PERL_SET_PHASE(PERL_PHASE_START);
2061
2062     init_main_stash();
2063
2064     {
2065         const char *s;
2066     for (argc--,argv++; argc > 0; argc--,argv++) {
2067         if (argv[0][0] != '-' || !argv[0][1])
2068             break;
2069         s = argv[0]+1;
2070       reswitch:
2071         switch ((c = *s)) {
2072         case 'C':
2073 #ifndef PERL_STRICT_CR
2074         case '\r':
2075 #endif
2076         case ' ':
2077         case '0':
2078         case 'F':
2079         case 'a':
2080         case 'c':
2081         case 'd':
2082         case 'D':
2083         case 'h':
2084         case 'i':
2085         case 'l':
2086         case 'M':
2087         case 'm':
2088         case 'n':
2089         case 'p':
2090         case 's':
2091         case 'u':
2092         case 'U':
2093         case 'v':
2094         case 'W':
2095         case 'X':
2096         case 'w':
2097             if ((s = moreswitches(s)))
2098                 goto reswitch;
2099             break;
2100
2101         case 't':
2102 #if defined(SILENT_NO_TAINT_SUPPORT)
2103             /* silently ignore */
2104 #elif defined(NO_TAINT_SUPPORT)
2105             Perl_croak_nocontext("This perl was compiled without taint support. "
2106                        "Cowardly refusing to run with -t or -T flags");
2107 #else
2108             CHECK_MALLOC_TOO_LATE_FOR('t');
2109             if( !TAINTING_get ) {
2110                  TAINT_WARN_set(TRUE);
2111                  TAINTING_set(TRUE);
2112             }
2113 #endif
2114             s++;
2115             goto reswitch;
2116         case 'T':
2117 #if defined(SILENT_NO_TAINT_SUPPORT)
2118             /* silently ignore */
2119 #elif defined(NO_TAINT_SUPPORT)
2120             Perl_croak_nocontext("This perl was compiled without taint support. "
2121                        "Cowardly refusing to run with -t or -T flags");
2122 #else
2123             CHECK_MALLOC_TOO_LATE_FOR('T');
2124             TAINTING_set(TRUE);
2125             TAINT_WARN_set(FALSE);
2126 #endif
2127             s++;
2128             goto reswitch;
2129
2130         case 'E':
2131             PL_minus_E = TRUE;
2132             /* FALLTHROUGH */
2133         case 'e':
2134             forbid_setid('e', FALSE);
2135             if (!PL_e_script) {
2136                 PL_e_script = newSVpvs("");
2137                 add_read_e_script = TRUE;
2138             }
2139             if (*++s)
2140                 sv_catpv(PL_e_script, s);
2141             else if (argv[1]) {
2142                 sv_catpv(PL_e_script, argv[1]);
2143                 argc--,argv++;
2144             }
2145             else
2146                 Perl_croak(aTHX_ "No code specified for -%c", c);
2147             sv_catpvs(PL_e_script, "\n");
2148             break;
2149
2150         case 'f':
2151 #ifdef USE_SITECUSTOMIZE
2152             minus_f = TRUE;
2153 #endif
2154             s++;
2155             goto reswitch;
2156
2157         case 'I':       /* -I handled both here and in moreswitches() */
2158             forbid_setid('I', FALSE);
2159             if (!*++s && (s=argv[1]) != NULL) {
2160                 argc--,argv++;
2161             }
2162             if (s && *s) {
2163                 STRLEN len = strlen(s);
2164                 incpush(s, len, INCPUSH_ADD_SUB_DIRS|INCPUSH_ADD_OLD_VERS);
2165             }
2166             else
2167                 Perl_croak(aTHX_ "No directory specified for -I");
2168             break;
2169         case 'S':
2170             forbid_setid('S', FALSE);
2171             dosearch = TRUE;
2172             s++;
2173             goto reswitch;
2174         case 'V':
2175             {
2176                 SV *opts_prog;
2177
2178                 if (*++s != ':')  {
2179                     opts_prog = newSVpvs("use Config; Config::_V()");
2180                 }
2181                 else {
2182                     ++s;
2183                     opts_prog = Perl_newSVpvf(aTHX_
2184                                               "use Config; Config::config_vars(qw%c%s%c)",
2185                                               0, s, 0);
2186                     s += strlen(s);
2187                 }
2188                 Perl_av_create_and_push(aTHX_ &PL_preambleav, opts_prog);
2189                 /* don't look for script or read stdin */
2190                 scriptname = BIT_BUCKET;
2191                 goto reswitch;
2192             }
2193         case 'x':
2194             doextract = TRUE;
2195             s++;
2196             if (*s)
2197                 cddir = s;
2198             break;
2199         case 0:
2200             break;
2201         case '-':
2202             if (!*++s || isSPACE(*s)) {
2203                 argc--,argv++;
2204                 goto switch_end;
2205             }
2206             /* catch use of gnu style long options.
2207                Both of these exit immediately.  */
2208             if (strEQ(s, "version"))
2209                 minus_v();
2210             if (strEQ(s, "help"))
2211                 usage();
2212             s--;
2213             /* FALLTHROUGH */
2214         default:
2215             Perl_croak(aTHX_ "Unrecognized switch: -%s  (-h will show valid options)",s);
2216         }
2217     }
2218     }
2219
2220   switch_end:
2221
2222     {
2223         char *s;
2224
2225     if (
2226 #ifndef SECURE_INTERNAL_GETENV
2227         !TAINTING_get &&
2228 #endif
2229         (s = PerlEnv_getenv("PERL5OPT")))
2230     {
2231         /* s points to static memory in getenv(), which may be overwritten at
2232          * any time; use a mortal copy instead */
2233         s = SvPVX(sv_2mortal(newSVpv(s, 0)));
2234
2235         while (isSPACE(*s))
2236             s++;
2237         if (*s == '-' && *(s+1) == 'T') {
2238 #if defined(SILENT_NO_TAINT_SUPPORT)
2239             /* silently ignore */
2240 #elif defined(NO_TAINT_SUPPORT)
2241             Perl_croak_nocontext("This perl was compiled without taint support. "
2242                        "Cowardly refusing to run with -t or -T flags");
2243 #else
2244             CHECK_MALLOC_TOO_LATE_FOR('T');
2245             TAINTING_set(TRUE);
2246             TAINT_WARN_set(FALSE);
2247 #endif
2248         }
2249         else {
2250             char *popt_copy = NULL;
2251             while (s && *s) {
2252                 const char *d;
2253                 while (isSPACE(*s))
2254                     s++;
2255                 if (*s == '-') {
2256                     s++;
2257                     if (isSPACE(*s))
2258                         continue;
2259                 }
2260                 d = s;
2261                 if (!*s)
2262                     break;
2263                 if (!strchr("CDIMUdmtwW", *s))
2264                     Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s);
2265                 while (++s && *s) {
2266                     if (isSPACE(*s)) {
2267                         if (!popt_copy) {
2268                             popt_copy = SvPVX(sv_2mortal(newSVpv(d,0)));
2269                             s = popt_copy + (s - d);
2270                             d = popt_copy;
2271                         }
2272                         *s++ = '\0';
2273                         break;
2274                     }
2275                 }
2276                 if (*d == 't') {
2277 #if defined(SILENT_NO_TAINT_SUPPORT)
2278             /* silently ignore */
2279 #elif defined(NO_TAINT_SUPPORT)
2280                     Perl_croak_nocontext("This perl was compiled without taint support. "
2281                                "Cowardly refusing to run with -t or -T flags");
2282 #else
2283                     if( !TAINTING_get) {
2284                         TAINT_WARN_set(TRUE);
2285                         TAINTING_set(TRUE);
2286                     }
2287 #endif
2288                 } else {
2289                     moreswitches(d);
2290                 }
2291             }
2292         }
2293     }
2294     }
2295
2296 #ifndef NO_PERL_INTERNAL_RAND_SEED
2297     /* If we're not set[ug]id, we might have honored
2298        PERL_INTERNAL_RAND_SEED in perl_construct().
2299        At this point command-line options have been parsed, so if
2300        we're now tainting and not set[ug]id re-seed.
2301        This could possibly be wasteful if PERL_INTERNAL_RAND_SEED is invalid,
2302        but avoids duplicating the logic from perl_construct().
2303     */
2304     if (PL_tainting &&
2305         PerlProc_getuid() == PerlProc_geteuid() &&
2306         PerlProc_getgid() == PerlProc_getegid()) {
2307         Perl_drand48_init_r(&PL_internal_random_state, seed());
2308     }
2309 #endif
2310
2311     /* Set $^X early so that it can be used for relocatable paths in @INC  */
2312     /* and for SITELIB_EXP in USE_SITECUSTOMIZE                            */
2313     assert (!TAINT_get);
2314     TAINT;
2315     set_caret_X();
2316     TAINT_NOT;
2317
2318 #if defined(USE_SITECUSTOMIZE)
2319     if (!minus_f) {
2320         /* The games with local $! are to avoid setting errno if there is no
2321            sitecustomize script.  "q%c...%c", 0, ..., 0 becomes "q\0...\0",
2322            ie a q() operator with a NUL byte as a the delimiter. This avoids
2323            problems with pathnames containing (say) '  */
2324 #  ifdef PERL_IS_MINIPERL
2325         AV *const inc = GvAV(PL_incgv);
2326         SV **const inc0 = inc ? av_fetch(inc, 0, FALSE) : NULL;
2327
2328         if (inc0) {
2329             /* if lib/buildcustomize.pl exists, it should not fail. If it does,
2330                it should be reported immediately as a build failure.  */
2331             (void)Perl_av_create_and_unshift_one(aTHX_ &PL_preambleav,
2332                                                  Perl_newSVpvf(aTHX_
2333                 "BEGIN { my $f = q%c%s%" SVf "/buildcustomize.pl%c; "
2334                         "do {local $!; -f $f }"
2335                         " and do $f || die $@ || qq '$f: $!' }",
2336                                 0, (TAINTING_get ? "./" : ""), SVfARG(*inc0), 0));
2337         }
2338 #  else
2339         /* SITELIB_EXP is a function call on Win32.  */
2340         const char *const raw_sitelib = SITELIB_EXP;
2341         if (raw_sitelib) {
2342             /* process .../.. if PERL_RELOCATABLE_INC is defined */
2343             SV *sitelib_sv = mayberelocate(raw_sitelib, strlen(raw_sitelib),
2344                                            INCPUSH_CAN_RELOCATE);
2345             const char *const sitelib = SvPVX(sitelib_sv);
2346             (void)Perl_av_create_and_unshift_one(aTHX_ &PL_preambleav,
2347                                                  Perl_newSVpvf(aTHX_
2348                                                                "BEGIN { do {local $!; -f q%c%s/sitecustomize.pl%c} && do q%c%s/sitecustomize.pl%c }",
2349                                                                0, SVfARG(sitelib), 0,
2350                                                                0, SVfARG(sitelib), 0));
2351             assert (SvREFCNT(sitelib_sv) == 1);
2352             SvREFCNT_dec(sitelib_sv);
2353         }
2354 #  endif
2355     }
2356 #endif
2357
2358     if (!scriptname)
2359         scriptname = argv[0];
2360     if (PL_e_script) {
2361         argc++,argv--;
2362         scriptname = BIT_BUCKET;        /* don't look for script or read stdin */
2363     }
2364     else if (scriptname == NULL) {
2365 #ifdef MSDOS
2366         if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) )
2367             moreswitches("h");
2368 #endif
2369         scriptname = "-";
2370     }
2371
2372     assert (!TAINT_get);
2373     init_perllib();
2374
2375     {
2376         bool suidscript = FALSE;
2377
2378         rsfp = open_script(scriptname, dosearch, &suidscript);
2379         if (!rsfp) {
2380             rsfp = PerlIO_stdin();
2381             lex_start_flags = LEX_DONT_CLOSE_RSFP;
2382         }
2383
2384         validate_suid(rsfp);
2385
2386 #ifndef PERL_MICRO
2387 #  if defined(SIGCHLD) || defined(SIGCLD)
2388         {
2389 #  ifndef SIGCHLD
2390 #    define SIGCHLD SIGCLD
2391 #  endif
2392             Sighandler_t sigstate = rsignal_state(SIGCHLD);
2393             if (sigstate == (Sighandler_t) SIG_IGN) {
2394                 Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL),
2395                                "Can't ignore signal CHLD, forcing to default");
2396                 (void)rsignal(SIGCHLD, (Sighandler_t)SIG_DFL);
2397             }
2398         }
2399 #  endif
2400 #endif
2401
2402         if (doextract) {
2403
2404             /* This will croak if suidscript is true, as -x cannot be used with
2405                setuid scripts.  */
2406             forbid_setid('x', suidscript);
2407             /* Hence you can't get here if suidscript is true */
2408
2409             linestr_sv = newSV_type(SVt_PV);
2410             lex_start_flags |= LEX_START_COPIED;
2411             find_beginning(linestr_sv, rsfp);
2412             if (cddir && PerlDir_chdir( (char *)cddir ) < 0)
2413                 Perl_croak(aTHX_ "Can't chdir to %s",cddir);
2414         }
2415     }
2416
2417     PL_main_cv = PL_compcv = MUTABLE_CV(newSV_type(SVt_PVCV));
2418     CvUNIQUE_on(PL_compcv);
2419
2420     CvPADLIST_set(PL_compcv, pad_new(0));
2421
2422     PL_isarev = newHV();
2423
2424     boot_core_PerlIO();
2425     boot_core_UNIVERSAL();
2426     boot_core_mro();
2427     newXS("Internals::V", S_Internals_V, __FILE__);
2428
2429     if (xsinit)
2430         (*xsinit)(aTHX);        /* in case linked C routines want magical variables */
2431 #ifndef PERL_MICRO
2432 #if defined(VMS) || defined(WIN32) || defined(DJGPP) || defined(__CYGWIN__) || defined(SYMBIAN)
2433     init_os_extras();
2434 #endif
2435 #endif
2436
2437 #ifdef USE_SOCKS
2438 #   ifdef HAS_SOCKS5_INIT
2439     socks5_init(argv[0]);
2440 #   else
2441     SOCKSinit(argv[0]);
2442 #   endif
2443 #endif
2444
2445     init_predump_symbols();
2446     /* init_postdump_symbols not currently designed to be called */
2447     /* more than once (ENV isn't cleared first, for example)     */
2448     /* But running with -u leaves %ENV & @ARGV undefined!    XXX */
2449     if (!PL_do_undump)
2450         init_postdump_symbols(argc,argv,env);
2451
2452     /* PL_unicode is turned on by -C, or by $ENV{PERL_UNICODE},
2453      * or explicitly in some platforms.
2454      * PL_utf8locale is conditionally turned on by
2455      * locale.c:Perl_init_i18nl10n() if the environment
2456      * look like the user wants to use UTF-8. */
2457 #if defined(__SYMBIAN32__)
2458     PL_unicode = PERL_UNICODE_STD_FLAG; /* See PERL_SYMBIAN_CONSOLE_UTF8. */
2459 #endif
2460 #  ifndef PERL_IS_MINIPERL
2461     if (PL_unicode) {
2462          /* Requires init_predump_symbols(). */
2463          if (!(PL_unicode & PERL_UNICODE_LOCALE_FLAG) || PL_utf8locale) {
2464               IO* io;
2465               PerlIO* fp;
2466               SV* sv;
2467
2468               /* Turn on UTF-8-ness on STDIN, STDOUT, STDERR
2469                * and the default open disciplines. */
2470               if ((PL_unicode & PERL_UNICODE_STDIN_FLAG) &&
2471                   PL_stdingv  && (io = GvIO(PL_stdingv)) &&
2472                   (fp = IoIFP(io)))
2473                    PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
2474               if ((PL_unicode & PERL_UNICODE_STDOUT_FLAG) &&
2475                   PL_defoutgv && (io = GvIO(PL_defoutgv)) &&
2476                   (fp = IoOFP(io)))
2477                    PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
2478               if ((PL_unicode & PERL_UNICODE_STDERR_FLAG) &&
2479                   PL_stderrgv && (io = GvIO(PL_stderrgv)) &&
2480                   (fp = IoOFP(io)))
2481                    PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
2482               if ((PL_unicode & PERL_UNICODE_INOUT_FLAG) &&
2483                   (sv = GvSV(gv_fetchpvs("\017PEN", GV_ADD|GV_NOTQUAL,
2484                                          SVt_PV)))) {
2485                    U32 in  = PL_unicode & PERL_UNICODE_IN_FLAG;
2486                    U32 out = PL_unicode & PERL_UNICODE_OUT_FLAG;
2487                    if (in) {
2488                         if (out)
2489                              sv_setpvs(sv, ":utf8\0:utf8");
2490                         else
2491                              sv_setpvs(sv, ":utf8\0");
2492                    }
2493                    else if (out)
2494                         sv_setpvs(sv, "\0:utf8");
2495                    SvSETMAGIC(sv);
2496               }
2497          }
2498     }
2499 #endif
2500
2501     {
2502         const char *s;
2503     if ((s = PerlEnv_getenv("PERL_SIGNALS"))) {
2504          if (strEQ(s, "unsafe"))
2505               PL_signals |=  PERL_SIGNALS_UNSAFE_FLAG;
2506          else if (strEQ(s, "safe"))
2507               PL_signals &= ~PERL_SIGNALS_UNSAFE_FLAG;
2508          else
2509               Perl_croak(aTHX_ "PERL_SIGNALS illegal: \"%s\"", s);
2510     }
2511     }
2512
2513
2514     lex_start(linestr_sv, rsfp, lex_start_flags);
2515     SvREFCNT_dec(linestr_sv);
2516
2517     PL_subname = newSVpvs("main");
2518
2519     if (add_read_e_script)
2520         filter_add(read_e_script, NULL);
2521
2522     /* now parse the script */
2523
2524     SETERRNO(0,SS_NORMAL);
2525     if (yyparse(GRAMPROG) || PL_parser->error_count) {
2526         abort_execution("", PL_origfilename);
2527     }
2528     CopLINE_set(PL_curcop, 0);
2529     SET_CURSTASH(PL_defstash);
2530     if (PL_e_script) {
2531         SvREFCNT_dec(PL_e_script);
2532         PL_e_script = NULL;
2533     }
2534
2535     if (PL_do_undump)
2536         my_unexec();
2537
2538     if (isWARN_ONCE) {
2539         SAVECOPFILE(PL_curcop);
2540         SAVECOPLINE(PL_curcop);
2541         gv_check(PL_defstash);
2542     }
2543
2544     LEAVE;
2545     FREETMPS;
2546
2547 #ifdef MYMALLOC
2548     {
2549         const char *s;
2550         UV uv;
2551         s = PerlEnv_getenv("PERL_DEBUG_MSTATS");
2552         if (s && grok_atoUV(s, &uv, NULL) && uv >= 2)
2553             dump_mstats("after compilation:");
2554     }
2555 #endif
2556
2557     ENTER;
2558     PL_restartjmpenv = NULL;
2559     PL_restartop = 0;
2560     return NULL;
2561 }
2562
2563 /*
2564 =for apidoc Am|int|perl_run|PerlInterpreter *my_perl
2565
2566 Tells a Perl interpreter to run its main program.  See L<perlembed>
2567 for a tutorial.
2568
2569 C<my_perl> points to the Perl interpreter.  It must have been previously
2570 created through the use of L</perl_alloc> and L</perl_construct>, and
2571 initialised through L</perl_parse>.  This function should not be called
2572 if L</perl_parse> returned a non-zero value, indicating a failure in
2573 initialisation or compilation.
2574
2575 This function executes code in C<INIT> blocks, and then executes the
2576 main program.  The code to be executed is that established by the prior
2577 call to L</perl_parse>.  If the interpreter's C<PL_exit_flags> word
2578 does not have the C<PERL_EXIT_DESTRUCT_END> flag set, then this function
2579 will also execute code in C<END> blocks.  If it is desired to make any
2580 further use of the interpreter after calling this function, then C<END>
2581 blocks should be postponed to L</perl_destruct> time by setting that flag.
2582
2583 Returns an integer of slightly tricky interpretation.  The correct use
2584 of the return value is as a truth value indicating whether the program
2585 terminated non-locally.  If zero is returned, this indicates that
2586 the program ran to completion, and it is safe to make other use of the
2587 interpreter (provided that the C<PERL_EXIT_DESTRUCT_END> flag was set as
2588 described above).  If a non-zero value is returned, this indicates that
2589 the interpreter wants to terminate early.  The interpreter should not be
2590 just abandoned because of this desire to terminate; the caller should
2591 proceed to shut the interpreter down cleanly with L</perl_destruct>
2592 and free it with L</perl_free>.
2593
2594 For historical reasons, the non-zero return value also attempts to
2595 be a suitable value to pass to the C library function C<exit> (or to
2596 return from C<main>), to serve as an exit code indicating the nature of
2597 the way the program terminated.  However, this isn't portable, due to
2598 differing exit code conventions.  An attempt is made to return an exit
2599 code of the type required by the host operating system, but because
2600 it is constrained to be non-zero, it is not necessarily possible to
2601 indicate every type of exit.  It is only reliable on Unix, where a zero
2602 exit code can be augmented with a set bit that will be ignored.  In any
2603 case, this function is not the correct place to acquire an exit code:
2604 one should get that from L</perl_destruct>.
2605
2606 =cut
2607 */
2608
2609 int
2610 perl_run(pTHXx)
2611 {
2612     I32 oldscope;
2613     int ret = 0, exit_called = 0;
2614     dJMPENV;
2615
2616     PERL_ARGS_ASSERT_PERL_RUN;
2617 #ifndef MULTIPLICITY
2618     PERL_UNUSED_ARG(my_perl);
2619 #endif
2620
2621     oldscope = PL_scopestack_ix;
2622 #ifdef VMS
2623     VMSISH_HUSHED = 0;
2624 #endif
2625
2626     JMPENV_PUSH(ret);
2627     switch (ret) {
2628     case 1:
2629         cxstack_ix = -1;                /* start context stack again */
2630         goto redo_body;
2631     case 0:                             /* normal completion */
2632  redo_body:
2633         run_body(oldscope);
2634         goto handle_exit;
2635     case 2:                             /* my_exit() */
2636         exit_called = 1;
2637     handle_exit:
2638         while (PL_scopestack_ix > oldscope)
2639             LEAVE;
2640         FREETMPS;
2641         SET_CURSTASH(PL_defstash);
2642         if (!(PL_exit_flags & PERL_EXIT_DESTRUCT_END) &&
2643             PL_endav && !PL_minus_c) {
2644             PERL_SET_PHASE(PERL_PHASE_END);
2645             call_list(oldscope, PL_endav);
2646         }
2647 #ifdef MYMALLOC
2648         if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
2649             dump_mstats("after execution:  ");
2650 #endif
2651         if (exit_called) {
2652             ret = STATUS_EXIT;
2653             if (ret == 0) ret = 0x100;
2654         } else {
2655             ret = 0;
2656         }
2657         break;
2658     case 3:
2659         if (PL_restartop) {
2660             POPSTACK_TO(PL_mainstack);
2661             goto redo_body;
2662         }
2663         PerlIO_printf(Perl_error_log, "panic: restartop in perl_run\n");
2664         FREETMPS;
2665         ret = 1;
2666         break;
2667     }
2668
2669     JMPENV_POP;
2670     return ret;
2671 }
2672
2673 STATIC void
2674 S_run_body(pTHX_ I32 oldscope)
2675 {
2676     DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support (0x%x).\n",
2677                     PL_sawampersand ? "Enabling" : "Omitting",
2678                     (unsigned int)(PL_sawampersand)));
2679
2680     if (!PL_restartop) {
2681 #ifdef DEBUGGING
2682         if (DEBUG_x_TEST || DEBUG_B_TEST)
2683             dump_all_perl(!DEBUG_B_TEST);
2684         if (!DEBUG_q_TEST)
2685           PERL_DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
2686 #endif
2687
2688         if (PL_minus_c) {
2689             PerlIO_printf(Perl_error_log, "%s syntax OK\n", PL_origfilename);
2690             my_exit(0);
2691         }
2692         if (PERLDB_SINGLE && PL_DBsingle)
2693             PL_DBsingle_iv = 1;
2694         if (PL_initav) {
2695             PERL_SET_PHASE(PERL_PHASE_INIT);
2696             call_list(oldscope, PL_initav);
2697         }
2698 #ifdef PERL_DEBUG_READONLY_OPS
2699         if (PL_main_root && PL_main_root->op_slabbed)
2700             Slab_to_ro(OpSLAB(PL_main_root));
2701 #endif
2702     }
2703
2704     /* do it */
2705
2706     PERL_SET_PHASE(PERL_PHASE_RUN);
2707
2708     if (PL_restartop) {
2709         PL_restartjmpenv = NULL;
2710         PL_op = PL_restartop;
2711         PL_restartop = 0;
2712         CALLRUNOPS(aTHX);
2713     }
2714     else if (PL_main_start) {
2715         CvDEPTH(PL_main_cv) = 1;
2716         PL_op = PL_main_start;
2717         CALLRUNOPS(aTHX);
2718     }
2719     my_exit(0);
2720     NOT_REACHED; /* NOTREACHED */
2721 }
2722
2723 /*
2724 =head1 SV Manipulation Functions
2725
2726 =for apidoc p||get_sv
2727
2728 Returns the SV of the specified Perl scalar.  C<flags> are passed to
2729 C<gv_fetchpv>.  If C<GV_ADD> is set and the
2730 Perl variable does not exist then it will be created.  If C<flags> is zero
2731 and the variable does not exist then NULL is returned.
2732
2733 =cut
2734 */
2735
2736 SV*
2737 Perl_get_sv(pTHX_ const char *name, I32 flags)
2738 {
2739     GV *gv;
2740
2741     PERL_ARGS_ASSERT_GET_SV;
2742
2743     gv = gv_fetchpv(name, flags, SVt_PV);
2744     if (gv)
2745         return GvSV(gv);
2746     return NULL;
2747 }
2748
2749 /*
2750 =head1 Array Manipulation Functions
2751
2752 =for apidoc p||get_av
2753
2754 Returns the AV of the specified Perl global or package array with the given
2755 name (so it won't work on lexical variables).  C<flags> are passed 
2756 to C<gv_fetchpv>.  If C<GV_ADD> is set and the
2757 Perl variable does not exist then it will be created.  If C<flags> is zero
2758 and the variable does not exist then NULL is returned.
2759
2760 Perl equivalent: C<@{"$name"}>.
2761
2762 =cut
2763 */
2764
2765 AV*
2766 Perl_get_av(pTHX_ const char *name, I32 flags)
2767 {
2768     GV* const gv = gv_fetchpv(name, flags, SVt_PVAV);
2769
2770     PERL_ARGS_ASSERT_GET_AV;
2771
2772     if (flags)
2773         return GvAVn(gv);
2774     if (gv)
2775         return GvAV(gv);
2776     return NULL;
2777 }
2778
2779 /*
2780 =head1 Hash Manipulation Functions
2781
2782 =for apidoc p||get_hv
2783
2784 Returns the HV of the specified Perl hash.  C<flags> are passed to
2785 C<gv_fetchpv>.  If C<GV_ADD> is set and the
2786 Perl variable does not exist then it will be created.  If C<flags> is zero
2787 and the variable does not exist then C<NULL> is returned.
2788
2789 =cut
2790 */
2791
2792 HV*
2793 Perl_get_hv(pTHX_ const char *name, I32 flags)
2794 {
2795     GV* const gv = gv_fetchpv(name, flags, SVt_PVHV);
2796
2797     PERL_ARGS_ASSERT_GET_HV;
2798
2799     if (flags)
2800         return GvHVn(gv);
2801     if (gv)
2802         return GvHV(gv);
2803     return NULL;
2804 }
2805
2806 /*
2807 =head1 CV Manipulation Functions
2808
2809 =for apidoc p||get_cvn_flags
2810
2811 Returns the CV of the specified Perl subroutine.  C<flags> are passed to
2812 C<gv_fetchpvn_flags>.  If C<GV_ADD> is set and the Perl subroutine does not
2813 exist then it will be declared (which has the same effect as saying
2814 C<sub name;>).  If C<GV_ADD> is not set and the subroutine does not exist
2815 then NULL is returned.
2816
2817 =for apidoc p||get_cv
2818
2819 Uses C<strlen> to get the length of C<name>, then calls C<get_cvn_flags>.
2820
2821 =cut
2822 */
2823
2824 CV*
2825 Perl_get_cvn_flags(pTHX_ const char *name, STRLEN len, I32 flags)
2826 {
2827     GV* const gv = gv_fetchpvn_flags(name, len, flags, SVt_PVCV);
2828
2829     PERL_ARGS_ASSERT_GET_CVN_FLAGS;
2830
2831     if (gv && UNLIKELY(SvROK(gv)) && SvTYPE(SvRV((SV *)gv)) == SVt_PVCV)
2832         return (CV*)SvRV((SV *)gv);
2833
2834     /* XXX this is probably not what they think they're getting.
2835      * It has the same effect as "sub name;", i.e. just a forward
2836      * declaration! */
2837     if ((flags & ~GV_NOADD_MASK) && !GvCVu(gv)) {
2838         return newSTUB(gv,0);
2839     }
2840     if (gv)
2841         return GvCVu(gv);
2842     return NULL;
2843 }
2844
2845 /* Nothing in core calls this now, but we can't replace it with a macro and
2846    move it to mathoms.c as a macro would evaluate name twice.  */
2847 CV*
2848 Perl_get_cv(pTHX_ const char *name, I32 flags)
2849 {
2850     PERL_ARGS_ASSERT_GET_CV;
2851
2852     return get_cvn_flags(name, strlen(name), flags);
2853 }
2854
2855 /* Be sure to refetch the stack pointer after calling these routines. */
2856
2857 /*
2858
2859 =head1 Callback Functions
2860
2861 =for apidoc p||call_argv
2862
2863 Performs a callback to the specified named and package-scoped Perl subroutine 
2864 with C<argv> (a C<NULL>-terminated array of strings) as arguments.  See
2865 L<perlcall>.
2866
2867 Approximate Perl equivalent: C<&{"$sub_name"}(@$argv)>.
2868
2869 =cut
2870 */
2871
2872 I32
2873 Perl_call_argv(pTHX_ const char *sub_name, I32 flags, char **argv)
2874
2875                         /* See G_* flags in cop.h */
2876                         /* null terminated arg list */
2877 {
2878     dSP;
2879
2880     PERL_ARGS_ASSERT_CALL_ARGV;
2881
2882     PUSHMARK(SP);
2883     while (*argv) {
2884         mXPUSHs(newSVpv(*argv,0));
2885         argv++;
2886     }
2887     PUTBACK;
2888     return call_pv(sub_name, flags);
2889 }
2890
2891 /*
2892 =for apidoc p||call_pv
2893
2894 Performs a callback to the specified Perl sub.  See L<perlcall>.
2895
2896 =cut
2897 */
2898
2899 I32
2900 Perl_call_pv(pTHX_ const char *sub_name, I32 flags)
2901                         /* name of the subroutine */
2902                         /* See G_* flags in cop.h */
2903 {
2904     PERL_ARGS_ASSERT_CALL_PV;
2905
2906     return call_sv(MUTABLE_SV(get_cv(sub_name, GV_ADD)), flags);
2907 }
2908
2909 /*
2910 =for apidoc p||call_method
2911
2912 Performs a callback to the specified Perl method.  The blessed object must
2913 be on the stack.  See L<perlcall>.
2914
2915 =cut
2916 */
2917
2918 I32
2919 Perl_call_method(pTHX_ const char *methname, I32 flags)
2920                         /* name of the subroutine */
2921                         /* See G_* flags in cop.h */
2922 {
2923     STRLEN len;
2924     SV* sv;
2925     PERL_ARGS_ASSERT_CALL_METHOD;
2926
2927     len = strlen(methname);
2928     sv = flags & G_METHOD_NAMED
2929         ? sv_2mortal(newSVpvn_share(methname, len,0))
2930         : newSVpvn_flags(methname, len, SVs_TEMP);
2931
2932     return call_sv(sv, flags | G_METHOD);
2933 }
2934
2935 /* May be called with any of a CV, a GV, or an SV containing the name. */
2936 /*
2937 =for apidoc p||call_sv
2938
2939 Performs a callback to the Perl sub specified by the SV.
2940
2941 If neither the C<G_METHOD> nor C<G_METHOD_NAMED> flag is supplied, the
2942 SV may be any of a CV, a GV, a reference to a CV, a reference to a GV
2943 or C<SvPV(sv)> will be used as the name of the sub to call.
2944
2945 If the C<G_METHOD> flag is supplied, the SV may be a reference to a CV or
2946 C<SvPV(sv)> will be used as the name of the method to call.
2947
2948 If the C<G_METHOD_NAMED> flag is supplied, C<SvPV(sv)> will be used as
2949 the name of the method to call.
2950
2951 Some other values are treated specially for internal use and should
2952 not be depended on.
2953
2954 See L<perlcall>.
2955
2956 =cut
2957 */
2958
2959 I32
2960 Perl_call_sv(pTHX_ SV *sv, volatile I32 flags)
2961                         /* See G_* flags in cop.h */
2962 {
2963     dVAR;
2964     LOGOP myop;         /* fake syntax tree node */
2965     METHOP method_op;
2966     I32 oldmark;
2967     volatile I32 retval = 0;
2968     bool oldcatch = CATCH_GET;
2969     int ret;
2970     OP* const oldop = PL_op;
2971     dJMPENV;
2972
2973     PERL_ARGS_ASSERT_CALL_SV;
2974
2975     if (flags & G_DISCARD) {
2976         ENTER;
2977         SAVETMPS;
2978     }
2979     if (!(flags & G_WANT)) {
2980         /* Backwards compatibility - as G_SCALAR was 0, it could be omitted.
2981          */
2982         flags |= G_SCALAR;
2983     }
2984
2985     Zero(&myop, 1, LOGOP);
2986     if (!(flags & G_NOARGS))
2987         myop.op_flags |= OPf_STACKED;
2988     myop.op_flags |= OP_GIMME_REVERSE(flags);
2989     SAVEOP();
2990     PL_op = (OP*)&myop;
2991
2992     if (!(flags & G_METHOD_NAMED)) {
2993         dSP;
2994         EXTEND(SP, 1);
2995         PUSHs(sv);
2996         PUTBACK;
2997     }
2998     oldmark = TOPMARK;
2999
3000     if (PERLDB_SUB && PL_curstash != PL_debstash
3001            /* Handle first BEGIN of -d. */
3002           && (PL_DBcv || (PL_DBcv = GvCV(PL_DBsub)))
3003            /* Try harder, since this may have been a sighandler, thus
3004             * curstash may be meaningless. */
3005           && (SvTYPE(sv) != SVt_PVCV || CvSTASH((const CV *)sv) != PL_debstash)
3006           && !(flags & G_NODEBUG))
3007         myop.op_private |= OPpENTERSUB_DB;
3008
3009     if (flags & (G_METHOD|G_METHOD_NAMED)) {
3010         Zero(&method_op, 1, METHOP);
3011         method_op.op_next = (OP*)&myop;
3012         PL_op = (OP*)&method_op;
3013         if ( flags & G_METHOD_NAMED ) {
3014             method_op.op_ppaddr = PL_ppaddr[OP_METHOD_NAMED];
3015             method_op.op_type = OP_METHOD_NAMED;
3016             method_op.op_u.op_meth_sv = sv;
3017         } else {
3018             method_op.op_ppaddr = PL_ppaddr[OP_METHOD];
3019             method_op.op_type = OP_METHOD;
3020         }
3021         myop.op_ppaddr = PL_ppaddr[OP_ENTERSUB];
3022         myop.op_type = OP_ENTERSUB;
3023     }
3024
3025     if (!(flags & G_EVAL)) {
3026         CATCH_SET(TRUE);
3027         CALL_BODY_SUB((OP*)&myop);
3028         retval = PL_stack_sp - (PL_stack_base + oldmark);
3029         CATCH_SET(oldcatch);
3030     }
3031     else {
3032         I32 old_cxix;
3033         myop.op_other = (OP*)&myop;
3034         (void)POPMARK;
3035         old_cxix = cxstack_ix;
3036         create_eval_scope(NULL, flags|G_FAKINGEVAL);
3037         INCMARK;
3038
3039         JMPENV_PUSH(ret);
3040
3041         switch (ret) {
3042         case 0:
3043  redo_body:
3044             CALL_BODY_SUB((OP*)&myop);
3045             retval = PL_stack_sp - (PL_stack_base + oldmark);
3046             if (!(flags & G_KEEPERR)) {
3047                 CLEAR_ERRSV();
3048             }
3049             break;
3050         case 1:
3051             STATUS_ALL_FAILURE;
3052             /* FALLTHROUGH */
3053         case 2:
3054             /* my_exit() was called */
3055             SET_CURSTASH(PL_defstash);
3056             FREETMPS;
3057             JMPENV_POP;
3058             my_exit_jump();
3059             NOT_REACHED; /* NOTREACHED */
3060         case 3:
3061             if (PL_restartop) {
3062                 PL_restartjmpenv = NULL;
3063                 PL_op = PL_restartop;
3064                 PL_restartop = 0;
3065                 goto redo_body;
3066             }
3067             PL_stack_sp = PL_stack_base + oldmark;
3068             if ((flags & G_WANT) == G_ARRAY)
3069                 retval = 0;
3070             else {
3071                 retval = 1;
3072                 *++PL_stack_sp = &PL_sv_undef;
3073             }
3074             break;
3075         }
3076
3077         /* if we croaked, depending on how we croaked the eval scope
3078          * may or may not have already been popped */
3079         if (cxstack_ix > old_cxix) {
3080             assert(cxstack_ix == old_cxix + 1);
3081             assert(CxTYPE(CX_CUR()) == CXt_EVAL);
3082             delete_eval_scope();
3083         }
3084         JMPENV_POP;
3085     }
3086
3087     if (flags & G_DISCARD) {
3088         PL_stack_sp = PL_stack_base + oldmark;
3089         retval = 0;
3090         FREETMPS;
3091         LEAVE;
3092     }
3093     PL_op = oldop;
3094     return retval;
3095 }
3096
3097 /* Eval a string. The G_EVAL flag is always assumed. */
3098
3099 /*
3100 =for apidoc p||eval_sv
3101
3102 Tells Perl to C<eval> the string in the SV.  It supports the same flags
3103 as C<call_sv>, with the obvious exception of C<G_EVAL>.  See L<perlcall>.
3104
3105 =cut
3106 */
3107
3108 I32
3109 Perl_eval_sv(pTHX_ SV *sv, I32 flags)
3110
3111                         /* See G_* flags in cop.h */
3112 {
3113     dVAR;
3114     UNOP myop;          /* fake syntax tree node */
3115     volatile I32 oldmark;
3116     volatile I32 retval = 0;
3117     int ret;
3118     OP* const oldop = PL_op;
3119     dJMPENV;
3120
3121     PERL_ARGS_ASSERT_EVAL_SV;
3122
3123     if (flags & G_DISCARD) {
3124         ENTER;
3125         SAVETMPS;
3126     }
3127
3128     SAVEOP();
3129     PL_op = (OP*)&myop;
3130     Zero(&myop, 1, UNOP);
3131     {
3132         dSP;
3133         oldmark = SP - PL_stack_base;
3134         EXTEND(SP, 1);
3135         PUSHs(sv);
3136         PUTBACK;
3137     }
3138
3139     if (!(flags & G_NOARGS))
3140         myop.op_flags = OPf_STACKED;
3141     myop.op_type = OP_ENTEREVAL;
3142     myop.op_flags |= OP_GIMME_REVERSE(flags);
3143     if (flags & G_KEEPERR)
3144         myop.op_flags |= OPf_SPECIAL;
3145
3146     if (flags & G_RE_REPARSING)
3147         myop.op_private = (OPpEVAL_COPHH | OPpEVAL_RE_REPARSING);
3148
3149     /* fail now; otherwise we could fail after the JMPENV_PUSH but
3150      * before a cx_pusheval(), which corrupts the stack after a croak */
3151     TAINT_PROPER("eval_sv()");
3152
3153     JMPENV_PUSH(ret);
3154     switch (ret) {
3155     case 0:
3156  redo_body:
3157         if (PL_op == (OP*)(&myop)) {
3158             PL_op = PL_ppaddr[OP_ENTEREVAL](aTHX);
3159             if (!PL_op)
3160                 goto fail; /* failed in compilation */
3161         }
3162         CALLRUNOPS(aTHX);
3163         retval = PL_stack_sp - (PL_stack_base + oldmark);
3164         if (!(flags & G_KEEPERR)) {
3165             CLEAR_ERRSV();
3166         }
3167         break;
3168     case 1:
3169         STATUS_ALL_FAILURE;
3170         /* FALLTHROUGH */
3171     case 2:
3172         /* my_exit() was called */
3173         SET_CURSTASH(PL_defstash);
3174         FREETMPS;
3175         JMPENV_POP;
3176         my_exit_jump();
3177         NOT_REACHED; /* NOTREACHED */
3178     case 3:
3179         if (PL_restartop) {
3180             PL_restartjmpenv = NULL;
3181             PL_op = PL_restartop;
3182             PL_restartop = 0;
3183             goto redo_body;
3184         }
3185       fail:
3186         PL_stack_sp = PL_stack_base + oldmark;
3187         if ((flags & G_WANT) == G_ARRAY)
3188             retval = 0;
3189         else {
3190             retval = 1;
3191             *++PL_stack_sp = &PL_sv_undef;
3192         }
3193         break;
3194     }
3195
3196     JMPENV_POP;
3197     if (flags & G_DISCARD) {
3198         PL_stack_sp = PL_stack_base + oldmark;
3199         retval = 0;
3200         FREETMPS;
3201         LEAVE;
3202     }
3203     PL_op = oldop;
3204     return retval;
3205 }
3206
3207 /*
3208 =for apidoc p||eval_pv
3209
3210 Tells Perl to C<eval> the given string in scalar context and return an SV* result.
3211
3212 =cut
3213 */
3214
3215 SV*
3216 Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error)
3217 {
3218     SV* sv = newSVpv(p, 0);
3219
3220     PERL_ARGS_ASSERT_EVAL_PV;
3221
3222     eval_sv(sv, G_SCALAR);
3223     SvREFCNT_dec(sv);
3224
3225     {
3226         dSP;
3227         sv = POPs;
3228         PUTBACK;
3229     }
3230
3231     /* just check empty string or undef? */
3232     if (croak_on_error) {
3233         SV * const errsv = ERRSV;
3234         if(SvTRUE_NN(errsv))
3235             /* replace with croak_sv? */
3236             Perl_croak_nocontext("%s", SvPV_nolen_const(errsv));
3237     }
3238
3239     return sv;
3240 }
3241
3242 /* Require a module. */
3243
3244 /*
3245 =head1 Embedding Functions
3246
3247 =for apidoc p||require_pv
3248
3249 Tells Perl to C<require> the file named by the string argument.  It is
3250 analogous to the Perl code C<eval "require '$file'">.  It's even
3251 implemented that way; consider using load_module instead.
3252
3253 =cut */
3254
3255 void
3256 Perl_require_pv(pTHX_ const char *pv)
3257 {
3258     dSP;
3259     SV* sv;
3260
3261     PERL_ARGS_ASSERT_REQUIRE_PV;
3262
3263     PUSHSTACKi(PERLSI_REQUIRE);
3264     sv = Perl_newSVpvf(aTHX_ "require q%c%s%c", 0, pv, 0);
3265     eval_sv(sv_2mortal(sv), G_DISCARD);
3266     POPSTACK;
3267 }
3268
3269 STATIC void
3270 S_usage(pTHX)           /* XXX move this out into a module ? */
3271 {
3272     /* This message really ought to be max 23 lines.
3273      * Removed -h because the user already knows that option. Others? */
3274
3275     /* Grouped as 6 lines per C string literal, to keep under the ANSI C 89
3276        minimum of 509 character string literals.  */
3277     static const char * const usage_msg[] = {
3278 "  -0[octal]         specify record separator (\\0, if no argument)\n"
3279 "  -a                autosplit mode with -n or -p (splits $_ into @F)\n"
3280 "  -C[number/list]   enables the listed Unicode features\n"
3281 "  -c                check syntax only (runs BEGIN and CHECK blocks)\n"
3282 "  -d[:debugger]     run program under debugger\n"
3283 "  -D[number/list]   set debugging flags (argument is a bit mask or alphabets)\n",
3284 "  -e program        one line of program (several -e's allowed, omit programfile)\n"
3285 "  -E program        like -e, but enables all optional features\n"
3286 "  -f                don't do $sitelib/sitecustomize.pl at startup\n"
3287 "  -F/pattern/       split() pattern for -a switch (//'s are optional)\n"
3288 "  -i[extension]     edit <> files in place (makes backup if extension supplied)\n"
3289 "  -Idirectory       specify @INC/#include directory (several -I's allowed)\n",
3290 "  -l[octal]         enable line ending processing, specifies line terminator\n"
3291 "  -[mM][-]module    execute \"use/no module...\" before executing program\n"
3292 "  -n                assume \"while (<>) { ... }\" loop around program\n"
3293 "  -p                assume loop like -n but print line also, like sed\n"
3294 "  -s                enable rudimentary parsing for switches after programfile\n"
3295 "  -S                look for programfile using PATH environment variable\n",
3296 "  -t                enable tainting warnings\n"
3297 "  -T                enable tainting checks\n"
3298 "  -u                dump core after parsing program\n"
3299 "  -U                allow unsafe operations\n"
3300 "  -v                print version, patchlevel and license\n"
3301 "  -V[:variable]     print configuration summary (or a single Config.pm variable)\n",
3302 "  -w                enable many useful warnings\n"
3303 "  -W                enable all warnings\n"
3304 "  -x[directory]     ignore text before #!perl line (optionally cd to directory)\n"
3305 "  -X                disable all warnings\n"
3306 "  \n"
3307 "Run 'perldoc perl' for more help with Perl.\n\n",
3308 NULL
3309 };
3310     const char * const *p = usage_msg;
3311     PerlIO *out = PerlIO_stdout();
3312
3313     PerlIO_printf(out,
3314                   "\nUsage: %s [switches] [--] [programfile] [arguments]\n",
3315                   PL_origargv[0]);
3316     while (*p)
3317         PerlIO_puts(out, *p++);
3318     my_exit(0);
3319 }
3320
3321 /* convert a string of -D options (or digits) into an int.
3322  * sets *s to point to the char after the options */
3323
3324 #ifdef DEBUGGING
3325 int
3326 Perl_get_debug_opts(pTHX_ const char **s, bool givehelp)
3327 {
3328     static const char * const usage_msgd[] = {
3329       " Debugging flag values: (see also -d)\n"
3330       "  p  Tokenizing and parsing (with v, displays parse stack)\n"
3331       "  s  Stack snapshots (with v, displays all stacks)\n"
3332       "  l  Context (loop) stack processing\n"
3333       "  t  Trace execution\n"
3334       "  o  Method and overloading resolution\n",
3335       "  c  String/numeric conversions\n"
3336       "  P  Print profiling info, source file input state\n"
3337       "  m  Memory and SV allocation\n"
3338       "  f  Format processing\n"
3339       "  r  Regular expression parsing and execution\n"
3340       "  x  Syntax tree dump\n",
3341       "  u  Tainting checks\n"
3342       "  H  Hash dump -- usurps values()\n"
3343       "  X  Scratchpad allocation\n"
3344       "  D  Cleaning up\n"
3345       "  S  Op slab allocation\n"
3346       "  T  Tokenising\n"
3347       "  R  Include reference counts of dumped variables (eg when using -Ds)\n",
3348       "  J  Do not s,t,P-debug (Jump over) opcodes within package DB\n"
3349       "  v  Verbose: use in conjunction with other flags\n"
3350       "  C  Copy On Write\n"
3351       "  A  Consistency checks on internal structures\n"
3352       "  q  quiet - currently only suppresses the 'EXECUTING' message\n"
3353       "  M  trace smart match resolution\n"
3354       "  B  dump suBroutine definitions, including special Blocks like BEGIN\n",
3355       "  L  trace some locale setting information--for Perl core development\n",
3356       "  i  trace PerlIO layer processing\n",
3357       NULL
3358     };
3359     UV uv = 0;
3360
3361     PERL_ARGS_ASSERT_GET_DEBUG_OPTS;
3362
3363     if (isALPHA(**s)) {
3364         /* if adding extra options, remember to update DEBUG_MASK */
3365         static const char debopts[] = "psltocPmfrxuUHXDSTRJvCAqMBLi";
3366
3367         for (; isWORDCHAR(**s); (*s)++) {
3368             const char * const d = strchr(debopts,**s);
3369             if (d)
3370                 uv |= 1 << (d - debopts);
3371             else if (ckWARN_d(WARN_DEBUGGING))
3372                 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
3373                     "invalid option -D%c, use -D'' to see choices\n", **s);
3374         }
3375     }
3376     else if (isDIGIT(**s)) {
3377         const char* e;
3378         if (grok_atoUV(*s, &uv, &e))
3379             *s = e;
3380         for (; isWORDCHAR(**s); (*s)++) ;
3381     }
3382     else if (givehelp) {
3383       const char *const *p = usage_msgd;
3384       while (*p) PerlIO_puts(PerlIO_stdout(), *p++);
3385     }
3386     return (int)uv; /* ignore any UV->int conversion loss */
3387 }
3388 #endif
3389
3390 /* This routine handles any switches that can be given during run */
3391
3392 const char *
3393 Perl_moreswitches(pTHX_ const char *s)
3394 {
3395     dVAR;
3396     UV rschar;
3397     const char option = *s; /* used to remember option in -m/-M code */
3398
3399     PERL_ARGS_ASSERT_MORESWITCHES;
3400
3401     switch (*s) {
3402     case '0':
3403     {
3404          I32 flags = 0;
3405          STRLEN numlen;
3406
3407          SvREFCNT_dec(PL_rs);
3408          if (s[1] == 'x' && s[2]) {
3409               const char *e = s+=2;
3410               U8 *tmps;
3411
3412               while (*e)
3413                 e++;
3414               numlen = e - s;
3415               flags = PERL_SCAN_SILENT_ILLDIGIT;
3416               rschar = (U32)grok_hex(s, &numlen, &flags, NULL);
3417               if (s + numlen < e) {
3418                    rschar = 0; /* Grandfather -0xFOO as -0 -xFOO. */
3419                    numlen = 0;
3420                    s--;
3421               }
3422               PL_rs = newSVpvs("");
3423               tmps = (U8*) SvGROW(PL_rs, (STRLEN)(UVCHR_SKIP(rschar) + 1));
3424               uvchr_to_utf8(tmps, rschar);
3425               SvCUR_set(PL_rs, UVCHR_SKIP(rschar));
3426               SvUTF8_on(PL_rs);
3427          }
3428          else {
3429               numlen = 4;
3430               rschar = (U32)grok_oct(s, &numlen, &flags, NULL);
3431               if (rschar & ~((U8)~0))
3432                    PL_rs = &PL_sv_undef;
3433               else if (!rschar && numlen >= 2)
3434                    PL_rs = newSVpvs("");
3435               else {
3436                    char ch = (char)rschar;
3437                    PL_rs = newSVpvn(&ch, 1);
3438               }
3439          }
3440          sv_setsv(get_sv("/", GV_ADD), PL_rs);
3441          return s + numlen;
3442     }
3443     case 'C':
3444         s++;
3445         PL_unicode = parse_unicode_opts( (const char **)&s );
3446         if (PL_unicode & PERL_UNICODE_UTF8CACHEASSERT_FLAG)
3447             PL_utf8cache = -1;
3448         return s;
3449     case 'F':
3450         PL_minus_a = TRUE;
3451         PL_minus_F = TRUE;
3452         PL_minus_n = TRUE;
3453         PL_splitstr = ++s;
3454         while (*s && !isSPACE(*s)) ++s;
3455         PL_splitstr = savepvn(PL_splitstr, s - PL_splitstr);
3456         return s;
3457     case 'a':
3458         PL_minus_a = TRUE;
3459         PL_minus_n = TRUE;
3460         s++;
3461         return s;
3462     case 'c':
3463         PL_minus_c = TRUE;
3464         s++;
3465         return s;
3466     case 'd':
3467         forbid_setid('d', FALSE);
3468         s++;
3469
3470         /* -dt indicates to the debugger that threads will be used */
3471         if (*s == 't' && !isWORDCHAR(s[1])) {
3472             ++s;
3473             my_setenv("PERL5DB_THREADED", "1");
3474         }
3475
3476         /* The following permits -d:Mod to accepts arguments following an =
3477            in the fashion that -MSome::Mod does. */
3478         if (*s == ':' || *s == '=') {
3479             const char *start;
3480             const char *end;
3481             SV *sv;
3482
3483             if (*++s == '-') {
3484                 ++s;
3485                 sv = newSVpvs("no Devel::");
3486             } else {
3487                 sv = newSVpvs("use Devel::");
3488             }
3489
3490             start = s;
3491             end = s + strlen(s);
3492
3493             /* We now allow -d:Module=Foo,Bar and -d:-Module */
3494             while(isWORDCHAR(*s) || *s==':') ++s;
3495             if (*s != '=')
3496                 sv_catpvn(sv, start, end - start);
3497             else {
3498                 sv_catpvn(sv, start, s-start);
3499                 /* Don't use NUL as q// delimiter here, this string goes in the
3500                  * environment. */
3501                 Perl_sv_catpvf(aTHX_ sv, " split(/,/,q{%s});", ++s);
3502             }
3503             s = end;
3504             my_setenv("PERL5DB", SvPV_nolen_const(sv));
3505             SvREFCNT_dec(sv);
3506         }
3507         if (!PL_perldb) {
3508             PL_perldb = PERLDB_ALL;
3509             init_debugger();
3510         }
3511         return s;
3512     case 'D':
3513     {   
3514 #ifdef DEBUGGING
3515         forbid_setid('D', FALSE);
3516         s++;
3517         PL_debug = get_debug_opts( (const char **)&s, 1) | DEBUG_TOP_FLAG;
3518 #else /* !DEBUGGING */
3519         if (ckWARN_d(WARN_DEBUGGING))
3520             Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
3521                    "Recompile perl with -DDEBUGGING to use -D switch (did you mean -d ?)\n");
3522         for (s++; isWORDCHAR(*s); s++) ;
3523 #endif
3524         return s;
3525         NOT_REACHED; /* NOTREACHED */
3526     }   
3527     case 'h':
3528         usage();
3529         NOT_REACHED; /* NOTREACHED */
3530
3531     case 'i':
3532         Safefree(PL_inplace);
3533         {
3534             const char * const start = ++s;
3535             while (*s && !isSPACE(*s))
3536                 ++s;
3537
3538             PL_inplace = savepvn(start, s - start);
3539         }
3540         return s;
3541     case 'I':   /* -I handled both here and in parse_body() */
3542         forbid_setid('I', FALSE);
3543         ++s;
3544         while (*s && isSPACE(*s))
3545             ++s;
3546         if (*s) {
3547             const char *e, *p;
3548             p = s;
3549             /* ignore trailing spaces (possibly followed by other switches) */
3550             do {
3551                 for (e = p; *e && !isSPACE(*e); e++) ;
3552                 p = e;
3553                 while (isSPACE(*p))
3554                     p++;
3555             } while (*p && *p != '-');
3556             incpush(s, e-s,
3557                     INCPUSH_ADD_SUB_DIRS|INCPUSH_ADD_OLD_VERS|INCPUSH_UNSHIFT);
3558             s = p;
3559             if (*s == '-')
3560                 s++;
3561         }
3562         else
3563             Perl_croak(aTHX_ "No directory specified for -I");
3564         return s;
3565     case 'l':
3566         PL_minus_l = TRUE;
3567         s++;
3568         if (PL_ors_sv) {
3569             SvREFCNT_dec(PL_ors_sv);
3570             PL_ors_sv = NULL;
3571         }
3572         if (isDIGIT(*s)) {
3573             I32 flags = 0;
3574             STRLEN numlen;
3575             PL_ors_sv = newSVpvs("\n");
3576             numlen = 3 + (*s == '0');
3577             *SvPVX(PL_ors_sv) = (char)grok_oct(s, &numlen, &flags, NULL);
3578             s += numlen;
3579         }
3580         else {
3581             if (RsPARA(PL_rs)) {
3582                 PL_ors_sv = newSVpvs("\n\n");
3583             }
3584             else {
3585                 PL_ors_sv = newSVsv(PL_rs);
3586             }
3587         }
3588         return s;
3589     case 'M':
3590         forbid_setid('M', FALSE);       /* XXX ? */
3591         /* FALLTHROUGH */
3592     case 'm':
3593         forbid_setid('m', FALSE);       /* XXX ? */
3594         if (*++s) {
3595             const char *start;
3596             const char *end;
3597             SV *sv;
3598             const char *use = "use ";
3599             bool colon = FALSE;
3600             /* -M-foo == 'no foo'       */
3601             /* Leading space on " no " is deliberate, to make both
3602                possibilities the same length.  */
3603             if (*s == '-') { use = " no "; ++s; }
3604             sv = newSVpvn(use,4);
3605             start = s;
3606             /* We allow -M'Module qw(Foo Bar)'  */
3607             while(isWORDCHAR(*s) || *s==':') {
3608                 if( *s++ == ':' ) {
3609                     if( *s == ':' ) 
3610                         s++;
3611                     else
3612                         colon = TRUE;
3613                 }
3614             }
3615             if (s == start)
3616                 Perl_croak(aTHX_ "Module name required with -%c option",
3617                                     option);
3618             if (colon) 
3619                 Perl_croak(aTHX_ "Invalid module name %.*s with -%c option: "
3620                                     "contains single ':'",
3621                                     (int)(s - start), start, option);
3622             end = s + strlen(s);
3623             if (*s != '=') {
3624                 sv_catpvn(sv, start, end - start);
3625                 if (option == 'm') {
3626                     if (*s != '\0')
3627                         Perl_croak(aTHX_ "Can't use '%c' after -mname", *s);
3628                     sv_catpvs( sv, " ()");
3629                 }
3630             } else {
3631                 sv_catpvn(sv, start, s-start);
3632                 /* Use NUL as q''-delimiter.  */
3633                 sv_catpvs(sv, " split(/,/,q\0");
3634                 ++s;
3635                 sv_catpvn(sv, s, end - s);
3636                 sv_catpvs(sv,  "\0)");
3637             }
3638             s = end;
3639             Perl_av_create_and_push(aTHX_ &PL_preambleav, sv);
3640         }
3641         else
3642             Perl_croak(aTHX_ "Missing argument to -%c", option);
3643         return s;
3644     case 'n':
3645         PL_minus_n = TRUE;
3646         s++;
3647         return s;
3648     case 'p':
3649         PL_minus_p = TRUE;
3650         s++;
3651         return s;
3652     case 's':
3653         forbid_setid('s', FALSE);
3654         PL_doswitches = TRUE;
3655         s++;
3656         return s;
3657     case 't':
3658     case 'T':
3659 #if defined(SILENT_NO_TAINT_SUPPORT)
3660             /* silently ignore */
3661 #elif defined(NO_TAINT_SUPPORT)
3662         Perl_croak_nocontext("This perl was compiled without taint support. "
3663                    "Cowardly refusing to run with -t or -T flags");
3664 #else
3665         if (!TAINTING_get)
3666             TOO_LATE_FOR(*s);
3667 #endif
3668         s++;
3669         return s;
3670     case 'u':
3671         PL_do_undump = TRUE;
3672         s++;
3673         return s;
3674     case 'U':
3675         PL_unsafe = TRUE;
3676         s++;
3677         return s;
3678     case 'v':
3679         minus_v();
3680     case 'w':
3681         if (! (PL_dowarn & G_WARN_ALL_MASK)) {
3682             PL_dowarn |= G_WARN_ON;
3683         }
3684         s++;
3685         return s;
3686     case 'W':
3687         PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
3688         if (!specialWARN(PL_compiling.cop_warnings))
3689             PerlMemShared_free(PL_compiling.cop_warnings);
3690         PL_compiling.cop_warnings = pWARN_ALL ;
3691         s++;
3692         return s;
3693     case 'X':
3694         PL_dowarn = G_WARN_ALL_OFF;
3695         if (!specialWARN(PL_compiling.cop_warnings))
3696             PerlMemShared_free(PL_compiling.cop_warnings);
3697         PL_compiling.cop_warnings = pWARN_NONE ;
3698         s++;
3699         return s;
3700     case '*':
3701     case ' ':
3702         while( *s == ' ' )
3703           ++s;
3704         if (s[0] == '-')        /* Additional switches on #! line. */
3705             return s+1;
3706         break;
3707     case '-':
3708     case 0:
3709 #if defined(WIN32) || !defined(PERL_STRICT_CR)
3710     case '\r':
3711 #endif
3712     case '\n':
3713     case '\t':
3714         break;
3715 #ifdef ALTERNATE_SHEBANG
3716     case 'S':                   /* OS/2 needs -S on "extproc" line. */
3717         break;
3718 #endif
3719     case 'e': case 'f': case 'x': case 'E':
3720 #ifndef ALTERNATE_SHEBANG
3721     case 'S':
3722 #endif
3723     case 'V':
3724         Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s);
3725     default:
3726         Perl_croak(aTHX_
3727             "Unrecognized switch: -%.1s  (-h will show valid options)",s
3728         );
3729     }
3730     return NULL;
3731 }
3732
3733
3734 STATIC void
3735 S_minus_v(pTHX)
3736 {
3737         PerlIO * PIO_stdout;
3738         {
3739             const char * const level_str = "v" PERL_VERSION_STRING;
3740             const STRLEN level_len = sizeof("v" PERL_VERSION_STRING)-1;
3741 #ifdef PERL_PATCHNUM
3742             SV* level;
3743 #  ifdef PERL_GIT_UNCOMMITTED_CHANGES
3744             static const char num [] = PERL_PATCHNUM "*";
3745 #  else
3746             static const char num [] = PERL_PATCHNUM;
3747 #  endif
3748             {
3749                 const STRLEN num_len = sizeof(num)-1;
3750                 /* A very advanced compiler would fold away the strnEQ
3751                    and this whole conditional, but most (all?) won't do it.
3752                    SV level could also be replaced by with preprocessor
3753                    catenation.
3754                 */
3755                 if (num_len >= level_len && strnEQ(num,level_str,level_len)) {
3756                     /* per 46807d8e80, PERL_PATCHNUM is outside of the control
3757                        of the interp so it might contain format characters
3758                     */
3759                     level = newSVpvn(num, num_len);
3760                 } else {
3761                     level = Perl_newSVpvf_nocontext("%s (%s)", level_str, num);
3762                 }
3763             }
3764 #else
3765         SV* level = newSVpvn(level_str, level_len);
3766 #endif /* #ifdef PERL_PATCHNUM */
3767         PIO_stdout =  PerlIO_stdout();
3768             PerlIO_printf(PIO_stdout,
3769                 "\nThis is perl "       STRINGIFY(PERL_REVISION)
3770                 ", version "            STRINGIFY(PERL_VERSION)
3771                 ", subversion "         STRINGIFY(PERL_SUBVERSION)
3772                 " (%" SVf ") built for "        ARCHNAME, SVfARG(level)
3773                 );
3774             SvREFCNT_dec_NN(level);
3775         }
3776 #if defined(LOCAL_PATCH_COUNT)
3777         if (LOCAL_PATCH_COUNT > 0)
3778             PerlIO_printf(PIO_stdout,
3779                           "\n(with %d registered patch%s, "
3780                           "see perl -V for more detail)",
3781                           LOCAL_PATCH_COUNT,
3782                           (LOCAL_PATCH_COUNT!=1) ? "es" : "");
3783 #endif
3784
3785         PerlIO_printf(PIO_stdout,
3786                       "\n\nCopyright 1987-2017, Larry Wall\n");
3787 #ifdef MSDOS
3788         PerlIO_printf(PIO_stdout,
3789                       "\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
3790 #endif
3791 #ifdef DJGPP
3792         PerlIO_printf(PIO_stdout,
3793                       "djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n"
3794                       "djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n");
3795 #endif
3796 #ifdef OS2
3797         PerlIO_printf(PIO_stdout,
3798                       "\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
3799                       "Version 5 port Copyright (c) 1994-2002, Andreas Kaiser, Ilya Zakharevich\n");
3800 #endif
3801 #ifdef OEMVS
3802         PerlIO_printf(PIO_stdout,
3803                       "MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
3804 #endif
3805 #ifdef __VOS__
3806         PerlIO_printf(PIO_stdout,
3807                       "Stratus OpenVOS port by Paul.Green@stratus.com, 1997-2013\n");
3808 #endif
3809 #ifdef POSIX_BC
3810         PerlIO_printf(PIO_stdout,
3811                       "BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
3812 #endif
3813 #ifdef UNDER_CE
3814         PerlIO_printf(PIO_stdout,
3815                         "WINCE port by Rainer Keuchel, 2001-2002\n"
3816                         "Built on " __DATE__ " " __TIME__ "\n\n");
3817         wce_hitreturn();
3818 #endif
3819 #ifdef __SYMBIAN32__
3820         PerlIO_printf(PIO_stdout,
3821                       "Symbian port by Nokia, 2004-2005\n");
3822 #endif
3823 #ifdef BINARY_BUILD_NOTICE
3824         BINARY_BUILD_NOTICE;
3825 #endif
3826         PerlIO_printf(PIO_stdout,
3827                       "\n\
3828 Perl may be copied only under the terms of either the Artistic License or the\n\
3829 GNU General Public License, which may be found in the Perl 5 source kit.\n\n\
3830 Complete documentation for Perl, including FAQ lists, should be found on\n\
3831 this system using \"man perl\" or \"perldoc perl\".  If you have access to the\n\
3832 Internet, point your browser at http://www.perl.org/, the Perl Home Page.\n\n");
3833         my_exit(0);
3834 }
3835
3836 /* compliments of Tom Christiansen */
3837
3838 /* unexec() can be found in the Gnu emacs distribution */
3839 /* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
3840
3841 #ifdef VMS
3842 #include <lib$routines.h>
3843 #endif
3844
3845 void
3846 Perl_my_unexec(pTHX)
3847 {
3848 #ifdef UNEXEC
3849     SV *    prog = newSVpv(BIN_EXP, 0);
3850     SV *    file = newSVpv(PL_origfilename, 0);
3851     int    status = 1;
3852     extern int etext;
3853
3854     sv_catpvs(prog, "/perl");
3855     sv_catpvs(file, ".perldump");
3856
3857     unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
3858     /* unexec prints msg to stderr in case of failure */
3859     PerlProc_exit(status);
3860 #else
3861     PERL_UNUSED_CONTEXT;
3862 #  ifdef VMS
3863      lib$signal(SS$_DEBUG);  /* ssdef.h #included from vmsish.h */
3864 #  elif defined(WIN32) || defined(__CYGWIN__)
3865     Perl_croak_nocontext("dump is not supported");
3866 #  else
3867     ABORT();            /* for use with undump */
3868 #  endif
3869 #endif
3870 }
3871
3872 /* initialize curinterp */
3873 STATIC void
3874 S_init_interp(pTHX)
3875 {
3876 #ifdef MULTIPLICITY
3877 #  define PERLVAR(prefix,var,type)
3878 #  define PERLVARA(prefix,var,n,type)
3879 #  if defined(PERL_IMPLICIT_CONTEXT)
3880 #    define PERLVARI(prefix,var,type,init)      aTHX->prefix##var = init;
3881 #    define PERLVARIC(prefix,var,type,init)     aTHX->prefix##var = init;
3882 #  else
3883 #    define PERLVARI(prefix,var,type,init)      PERL_GET_INTERP->var = init;
3884 #    define PERLVARIC(prefix,var,type,init)     PERL_GET_INTERP->var = init;
3885 #  endif
3886 #  include "intrpvar.h"
3887 #  undef PERLVAR
3888 #  undef PERLVARA
3889 #  undef PERLVARI
3890 #  undef PERLVARIC
3891 #else
3892 #  define PERLVAR(prefix,var,type)
3893 #  define PERLVARA(prefix,var,n,type)
3894 #  define PERLVARI(prefix,var,type,init)        PL_##var = init;
3895 #  define PERLVARIC(prefix,var,type,init)       PL_##var = init;
3896 #  include "intrpvar.h"
3897 #  undef PERLVAR
3898 #  undef PERLVARA
3899 #  undef PERLVARI
3900 #  undef PERLVARIC
3901 #endif
3902
3903 }
3904
3905 STATIC void
3906 S_init_main_stash(pTHX)
3907 {
3908     GV *gv;
3909     HV *hv = newHV();
3910
3911     PL_curstash = PL_defstash = (HV *)SvREFCNT_inc_simple_NN(hv);
3912     /* We know that the string "main" will be in the global shared string
3913        table, so it's a small saving to use it rather than allocate another
3914        8 bytes.  */
3915     PL_curstname = newSVpvs_share("main");
3916     gv = gv_fetchpvs("main::", GV_ADD|GV_NOTQUAL, SVt_PVHV);
3917     /* If we hadn't caused another reference to "main" to be in the shared
3918        string table above, then it would be worth reordering these two,
3919        because otherwise all we do is delete "main" from it as a consequence
3920        of the SvREFCNT_dec, only to add it again with hv_name_set */
3921     SvREFCNT_dec(GvHV(gv));
3922     hv_name_sets(PL_defstash, "main", 0);
3923     GvHV(gv) = MUTABLE_HV(SvREFCNT_inc_simple(PL_defstash));
3924     SvREADONLY_on(gv);
3925     PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpvs("INC", GV_ADD|GV_NOTQUAL,
3926                                              SVt_PVAV)));
3927     SvREFCNT_inc_simple_void(PL_incgv); /* Don't allow it to be freed */
3928     GvMULTI_on(PL_incgv);
3929     PL_hintgv = gv_fetchpvs("\010", GV_ADD|GV_NOTQUAL, SVt_PV); /* ^H */
3930     SvREFCNT_inc_simple_void(PL_hintgv);
3931     GvMULTI_on(PL_hintgv);
3932     PL_defgv = gv_fetchpvs("_", GV_ADD|GV_NOTQUAL, SVt_PVAV);
3933     SvREFCNT_inc_simple_void(PL_defgv);
3934     PL_errgv = gv_fetchpvs("@", GV_ADD|GV_NOTQUAL, SVt_PV);
3935     SvREFCNT_inc_simple_void(PL_errgv);
3936     GvMULTI_on(PL_errgv);
3937     PL_replgv = gv_fetchpvs("\022", GV_ADD|GV_NOTQUAL, SVt_PV); /* ^R */
3938     SvREFCNT_inc_simple_void(PL_replgv);
3939     GvMULTI_on(PL_replgv);
3940     (void)Perl_form(aTHX_ "%240s","");  /* Preallocate temp - for immediate signals. */
3941 #ifdef PERL_DONT_CREATE_GVSV
3942     (void)gv_SVadd(PL_errgv);
3943 #endif
3944     sv_grow(ERRSV, 240);        /* Preallocate - for immediate signals. */
3945     CLEAR_ERRSV();
3946     CopSTASH_set(&PL_compiling, PL_defstash);
3947     PL_debstash = GvHV(gv_fetchpvs("DB::", GV_ADDMULTI, SVt_PVHV));
3948     PL_globalstash = GvHV(gv_fetchpvs("CORE::GLOBAL::", GV_ADDMULTI,
3949                                       SVt_PVHV));
3950     /* We must init $/ before switches are processed. */
3951     sv_setpvs(get_sv("/", GV_ADD), "\n");
3952 }
3953
3954 STATIC PerlIO *
3955 S_open_script(pTHX_ const char *scriptname, bool dosearch, bool *suidscript)
3956 {
3957     int fdscript = -1;
3958     PerlIO *rsfp = NULL;
3959     Stat_t tmpstatbuf;
3960     int fd;
3961
3962     PERL_ARGS_ASSERT_OPEN_SCRIPT;
3963
3964     if (PL_e_script) {
3965         PL_origfilename = savepvs("-e");
3966     }
3967     else {
3968         const char *s;
3969         UV uv;
3970         /* if find_script() returns, it returns a malloc()-ed value */
3971         scriptname = PL_origfilename = find_script(scriptname, dosearch, NULL, 1);
3972
3973         if (strBEGINs(scriptname, "/dev/fd/")
3974             && isDIGIT(scriptname[8])
3975             && grok_atoUV(scriptname + 8, &uv, &s)
3976             && uv <= PERL_INT_MAX
3977         ) {
3978             fdscript = (int)uv;
3979             if (*s) {
3980                 /* PSz 18 Feb 04
3981                  * Tell apart "normal" usage of fdscript, e.g.
3982                  * with bash on FreeBSD:
3983                  *   perl <( echo '#!perl -DA'; echo 'print "$0\n"')
3984                  * from usage in suidperl.
3985                  * Does any "normal" usage leave garbage after the number???
3986                  * Is it a mistake to use a similar /dev/fd/ construct for
3987                  * suidperl?
3988                  */
3989                 *suidscript = TRUE;
3990                 /* PSz 20 Feb 04  
3991                  * Be supersafe and do some sanity-checks.
3992                  * Still, can we be sure we got the right thing?
3993                  */
3994                 if (*s != '/') {
3995                     Perl_croak(aTHX_ "Wrong syntax (suid) fd script name \"%s\"\n", s);
3996                 }
3997                 if (! *(s+1)) {
3998                     Perl_croak(aTHX_ "Missing (suid) fd script name\n");
3999                 }
4000                 scriptname = savepv(s + 1);
4001                 Safefree(PL_origfilename);
4002                 PL_origfilename = (char *)scriptname;
4003             }
4004         }
4005     }
4006
4007     CopFILE_free(PL_curcop);
4008     CopFILE_set(PL_curcop, PL_origfilename);
4009     if (*PL_origfilename == '-' && PL_origfilename[1] == '\0')
4010         scriptname = (char *)"";
4011     if (fdscript >= 0) {
4012         rsfp = PerlIO_fdopen(fdscript,PERL_SCRIPT_MODE);
4013     }
4014     else if (!*scriptname) {
4015         forbid_setid(0, *suidscript);
4016         return NULL;
4017     }
4018     else {
4019 #ifdef FAKE_BIT_BUCKET
4020         /* This hack allows one not to have /dev/null (or BIT_BUCKET as it
4021          * is called) and still have the "-e" work.  (Believe it or not,
4022          * a /dev/null is required for the "-e" to work because source
4023          * filter magic is used to implement it. ) This is *not* a general
4024          * replacement for a /dev/null.  What we do here is create a temp
4025          * file (an empty file), open up that as the script, and then
4026          * immediately close and unlink it.  Close enough for jazz. */ 
4027 #define FAKE_BIT_BUCKET_PREFIX "/tmp/perlnull-"
4028 #define FAKE_BIT_BUCKET_SUFFIX "XXXXXXXX"
4029 #define FAKE_BIT_BUCKET_TEMPLATE FAKE_BIT_BUCKET_PREFIX FAKE_BIT_BUCKET_SUFFIX
4030         char tmpname[sizeof(FAKE_BIT_BUCKET_TEMPLATE)] = {
4031             FAKE_BIT_BUCKET_TEMPLATE
4032         };
4033         const char * const err = "Failed to create a fake bit bucket";
4034         if (strEQ(scriptname, BIT_BUCKET)) {
4035 #ifdef HAS_MKSTEMP /* Hopefully mkstemp() is safe here. */
4036             int old_umask = umask(0177);
4037             int tmpfd = mkstemp(tmpname);
4038             umask(old_umask);
4039             if (tmpfd > -1) {
4040                 scriptname = tmpname;
4041                 close(tmpfd);
4042             } else
4043                 Perl_croak(aTHX_ err);
4044 #endif
4045         }
4046 #endif
4047         rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
4048 #ifdef FAKE_BIT_BUCKET
4049         if (   strBEGINs(scriptname, FAKE_BIT_BUCKET_PREFIX)
4050             && strlen(scriptname) == sizeof(tmpname) - 1)
4051         {
4052             unlink(scriptname);
4053         }
4054         scriptname = BIT_BUCKET;
4055 #endif
4056     }
4057     if (!rsfp) {
4058         /* PSz 16 Sep 03  Keep neat error message */
4059         if (PL_e_script)
4060             Perl_croak(aTHX_ "Can't open " BIT_BUCKET ": %s\n", Strerror(errno));
4061         else
4062             Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
4063                     CopFILE(PL_curcop), Strerror(errno));
4064     }
4065     fd = PerlIO_fileno(rsfp);
4066 #if defined(HAS_FCNTL) && defined(F_SETFD) && defined(FD_CLOEXEC)
4067     if (fd >= 0) {
4068         /* ensure close-on-exec */
4069         if (fcntl(fd, F_SETFD, FD_CLOEXEC) < 0) {
4070             Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
4071                        CopFILE(PL_curcop), Strerror(errno));
4072         }
4073     }
4074 #endif
4075
4076     if (fd < 0 ||
4077         (PerlLIO_fstat(fd, &tmpstatbuf) >= 0
4078          && S_ISDIR(tmpstatbuf.st_mode)))
4079         Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
4080             CopFILE(PL_curcop),
4081             Strerror(EISDIR));
4082
4083     return rsfp;
4084 }
4085
4086 /* In the days of suidperl, we refused to execute a setuid script stored on
4087  * a filesystem mounted nosuid and/or noexec. This meant that we probed for the
4088  * existence of the appropriate filesystem-statting function, and behaved
4089  * accordingly. But even though suidperl is long gone, we must still include
4090  * those probes for the benefit of modules like Filesys::Df, which expect the
4091  * results of those probes to be stored in %Config; see RT#126368. So mention
4092  * the relevant cpp symbols here, to ensure that metaconfig will include their
4093  * probes in the generated Configure:
4094  *
4095  * I_SYSSTATVFS HAS_FSTATVFS
4096  * I_SYSMOUNT
4097  * I_STATFS     HAS_FSTATFS     HAS_GETFSSTAT
4098  * I_MNTENT     HAS_GETMNTENT   HAS_HASMNTOPT
4099  */
4100
4101
4102 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
4103 /* Don't even need this function.  */
4104 #else
4105 STATIC void
4106 S_validate_suid(pTHX_ PerlIO *rsfp)
4107 {
4108     const Uid_t  my_uid = PerlProc_getuid();
4109     const Uid_t my_euid = PerlProc_geteuid();
4110     const Gid_t  my_gid = PerlProc_getgid();
4111     const Gid_t my_egid = PerlProc_getegid();
4112
4113     PERL_ARGS_ASSERT_VALIDATE_SUID;
4114
4115     if (my_euid != my_uid || my_egid != my_gid) {       /* (suidperl doesn't exist, in fact) */
4116         dVAR;
4117         int fd = PerlIO_fileno(rsfp);
4118         Stat_t statbuf;
4119         if (fd < 0 || PerlLIO_fstat(fd, &statbuf) < 0) { /* may be either wrapped or real suid */
4120             Perl_croak_nocontext( "Illegal suidscript");
4121         }
4122         if ((my_euid != my_uid && my_euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
4123             ||
4124             (my_egid != my_gid && my_egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
4125             )
4126             if (!PL_do_undump)
4127                 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
4128 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
4129         /* not set-id, must be wrapped */
4130     }
4131 }
4132 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
4133
4134 STATIC void
4135 S_find_beginning(pTHX_ SV* linestr_sv, PerlIO *rsfp)
4136 {
4137     const char *s;
4138     const char *s2;
4139
4140     PERL_ARGS_ASSERT_FIND_BEGINNING;
4141
4142     /* skip forward in input to the real script? */
4143
4144     do {
4145         if ((s = sv_gets(linestr_sv, rsfp, 0)) == NULL)
4146             Perl_croak(aTHX_ "No Perl script found in input\n");
4147         s2 = s;
4148     } while (!(*s == '#' && s[1] == '!' && ((s = instr(s,"perl")) || (s = instr(s2,"PERL")))));
4149     PerlIO_ungetc(rsfp, '\n');          /* to keep line count right */
4150     while (*s && !(isSPACE (*s) || *s == '#')) s++;
4151     s2 = s;
4152     while (*s == ' ' || *s == '\t') s++;
4153     if (*s++ == '-') {
4154         while (isDIGIT(s2[-1]) || s2[-1] == '-' || s2[-1] == '.'
4155                || s2[-1] == '_') s2--;
4156         if (strBEGINs(s2-4,"perl"))
4157             while ((s = moreswitches(s)))
4158                 ;
4159     }
4160 }
4161
4162
4163 STATIC void
4164 S_init_ids(pTHX)
4165 {
4166     /* no need to do anything here any more if we don't
4167      * do tainting. */
4168 #ifndef NO_TAINT_SUPPORT
4169     const Uid_t my_uid = PerlProc_getuid();
4170     const Uid_t my_euid = PerlProc_geteuid();
4171     const Gid_t my_gid = PerlProc_getgid();
4172     const Gid_t my_egid = PerlProc_getegid();
4173
4174     PERL_UNUSED_CONTEXT;
4175
4176     /* Should not happen: */
4177     CHECK_MALLOC_TAINT(my_uid && (my_euid != my_uid || my_egid != my_gid));
4178     TAINTING_set( TAINTING_get | (my_uid && (my_euid != my_uid || my_egid != my_gid)) );
4179 #endif
4180     /* BUG */
4181     /* PSz 27 Feb 04
4182      * Should go by suidscript, not uid!=euid: why disallow
4183      * system("ls") in scripts run from setuid things?
4184      * Or, is this run before we check arguments and set suidscript?
4185      * What about SETUID_SCRIPTS_ARE_SECURE_NOW: could we use fdscript then?
4186      * (We never have suidscript, can we be sure to have fdscript?)
4187      * Or must then go by UID checks? See comments in forbid_setid also.
4188      */
4189 }
4190
4191 /* This is used very early in the lifetime of the program,
4192  * before even the options are parsed, so PL_tainting has
4193  * not been initialized properly.  */
4194 bool
4195 Perl_doing_taint(int argc, char *argv[], char *envp[])
4196 {
4197 #ifndef PERL_IMPLICIT_SYS
4198     /* If we have PERL_IMPLICIT_SYS we can't call getuid() et alia
4199      * before we have an interpreter-- and the whole point of this
4200      * function is to be called at such an early stage.  If you are on
4201      * a system with PERL_IMPLICIT_SYS but you do have a concept of
4202      * "tainted because running with altered effective ids', you'll
4203      * have to add your own checks somewhere in here.  The two most
4204      * known samples of 'implicitness' are Win32 and NetWare, neither
4205      * of which has much of concept of 'uids'. */
4206     Uid_t uid  = PerlProc_getuid();
4207     Uid_t euid = PerlProc_geteuid();
4208     Gid_t gid  = PerlProc_getgid();
4209     Gid_t egid = PerlProc_getegid();
4210     (void)envp;
4211
4212 #ifdef VMS
4213     uid  |=  gid << 16;
4214     euid |= egid << 16;
4215 #endif
4216     if (uid && (euid != uid || egid != gid))
4217         return 1;
4218 #endif /* !PERL_IMPLICIT_SYS */
4219     /* This is a really primitive check; environment gets ignored only
4220      * if -T are the first chars together; otherwise one gets
4221      *  "Too late" message. */
4222     if ( argc > 1 && argv[1][0] == '-'
4223          && isALPHA_FOLD_EQ(argv[1][1], 't'))
4224         return 1;
4225     return 0;
4226 }
4227
4228 /* Passing the flag as a single char rather than a string is a slight space
4229    optimisation.  The only message that isn't /^-.$/ is
4230    "program input from stdin", which is substituted in place of '\0', which
4231    could never be a command line flag.  */
4232 STATIC void
4233 S_forbid_setid(pTHX_ const char flag, const bool suidscript) /* g */
4234 {
4235     char string[3] = "-x";
4236     const char *message = "program input from stdin";
4237
4238     PERL_UNUSED_CONTEXT;
4239     if (flag) {
4240         string[1] = flag;
4241         message = string;
4242     }
4243
4244 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
4245     if (PerlProc_getuid() != PerlProc_geteuid())
4246         Perl_croak(aTHX_ "No %s allowed while running setuid", message);
4247     if (PerlProc_getgid() != PerlProc_getegid())
4248         Perl_croak(aTHX_ "No %s allowed while running setgid", message);
4249 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
4250     if (suidscript)
4251         Perl_croak(aTHX_ "No %s allowed with (suid) fdscript", message);
4252 }
4253
4254 void
4255 Perl_init_dbargs(pTHX)
4256 {
4257     AV *const args = PL_dbargs = GvAV(gv_AVadd((gv_fetchpvs("DB::args",
4258                                                             GV_ADDMULTI,
4259                                                             SVt_PVAV))));
4260
4261     if (AvREAL(args)) {
4262         /* Someone has already created it.
4263            It might have entries, and if we just turn off AvREAL(), they will
4264            "leak" until global destruction.  */
4265         av_clear(args);
4266         if (SvTIED_mg((const SV *)args, PERL_MAGIC_tied))
4267             Perl_croak(aTHX_ "Cannot set tied @DB::args");
4268     }
4269     AvREIFY_only(PL_dbargs);
4270 }
4271
4272 void
4273 Perl_init_debugger(pTHX)
4274 {
4275     HV * const ostash = PL_curstash;
4276     MAGIC *mg;
4277
4278     PL_curstash = (HV *)SvREFCNT_inc_simple(PL_debstash);
4279
4280     Perl_init_dbargs(aTHX);
4281     PL_DBgv = MUTABLE_GV(
4282         SvREFCNT_inc(gv_fetchpvs("DB::DB", GV_ADDMULTI, SVt_PVGV))
4283     );
4284     PL_DBline = MUTABLE_GV(
4285         SvREFCNT_inc(gv_fetchpvs("DB::dbline", GV_ADDMULTI, SVt_PVAV))
4286     );
4287     PL_DBsub = MUTABLE_GV(SvREFCNT_inc(
4288         gv_HVadd(gv_fetchpvs("DB::sub", GV_ADDMULTI, SVt_PVHV))
4289     ));
4290     PL_DBsingle = GvSV((gv_fetchpvs("DB::single", GV_ADDMULTI, SVt_PV)));
4291     if (!SvIOK(PL_DBsingle))
4292         sv_setiv(PL_DBsingle, 0);
4293     mg = sv_magicext(PL_DBsingle, NULL, PERL_MAGIC_debugvar, &PL_vtbl_debugvar, 0, 0);
4294     mg->mg_private = DBVARMG_SINGLE;
4295     SvSETMAGIC(PL_DBsingle);
4296
4297     PL_DBtrace = GvSV((gv_fetchpvs("DB::trace", GV_ADDMULTI, SVt_PV)));
4298     if (!SvIOK(PL_DBtrace))
4299         sv_setiv(PL_DBtrace, 0);
4300     mg = sv_magicext(PL_DBtrace, NULL, PERL_MAGIC_debugvar, &PL_vtbl_debugvar, 0, 0);
4301     mg->mg_private = DBVARMG_TRACE;
4302     SvSETMAGIC(PL_DBtrace);
4303
4304     PL_DBsignal = GvSV((gv_fetchpvs("DB::signal", GV_ADDMULTI, SVt_PV)));
4305     if (!SvIOK(PL_DBsignal))
4306         sv_setiv(PL_DBsignal, 0);
4307     mg = sv_magicext(PL_DBsignal, NULL, PERL_MAGIC_debugvar, &PL_vtbl_debugvar, 0, 0);
4308     mg->mg_private = DBVARMG_SIGNAL;
4309     SvSETMAGIC(PL_DBsignal);
4310
4311     SvREFCNT_dec(PL_curstash);
4312     PL_curstash = ostash;
4313 }
4314
4315 #ifndef STRESS_REALLOC
4316 #define REASONABLE(size) (size)
4317 #define REASONABLE_but_at_least(size,min) (size)
4318 #else
4319 #define REASONABLE(size) (1) /* unreasonable */
4320 #define REASONABLE_but_at_least(size,min) (min)
4321 #endif
4322
4323 void
4324 Perl_init_stacks(pTHX)
4325 {
4326     SSize_t size;
4327
4328     /* start with 128-item stack and 8K cxstack */
4329     PL_curstackinfo = new_stackinfo(REASONABLE(128),
4330                                  REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
4331     PL_curstackinfo->si_type = PERLSI_MAIN;
4332 #if defined DEBUGGING && !defined DEBUGGING_RE_ONLY
4333     PL_curstackinfo->si_stack_hwm = 0;
4334 #endif
4335     PL_curstack = PL_curstackinfo->si_stack;
4336     PL_mainstack = PL_curstack;         /* remember in case we switch stacks */
4337
4338     PL_stack_base = AvARRAY(PL_curstack);
4339     PL_stack_sp = PL_stack_base;
4340     PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
4341
4342     Newx(PL_tmps_stack,REASONABLE(128),SV*);
4343     PL_tmps_floor = -1;
4344     PL_tmps_ix = -1;
4345     PL_tmps_max = REASONABLE(128);
4346
4347     Newx(PL_markstack,REASONABLE(32),I32);
4348     PL_markstack_ptr = PL_markstack;
4349     PL_markstack_max = PL_markstack + REASONABLE(32);
4350
4351     SET_MARK_OFFSET;
4352
4353     Newx(PL_scopestack,REASONABLE(32),I32);
4354 #ifdef DEBUGGING
4355     Newx(PL_scopestack_name,REASONABLE(32),const char*);
4356 #endif
4357     PL_scopestack_ix = 0;
4358     PL_scopestack_max = REASONABLE(32);
4359
4360     size = REASONABLE_but_at_least(128,SS_MAXPUSH);
4361     Newx(PL_savestack, size, ANY);
4362     PL_savestack_ix = 0;
4363     /*PL_savestack_max lies: it always has SS_MAXPUSH more than it claims */
4364     PL_savestack_max = size - SS_MAXPUSH;
4365 }
4366
4367 #undef REASONABLE
4368
4369 STATIC void
4370 S_nuke_stacks(pTHX)
4371 {
4372     while (PL_curstackinfo->si_next)
4373         PL_curstackinfo = PL_curstackinfo->si_next;
4374     while (PL_curstackinfo) {
4375         PERL_SI *p = PL_curstackinfo->si_prev;
4376         /* curstackinfo->si_stack got nuked by sv_free_arenas() */
4377         Safefree(PL_curstackinfo->si_cxstack);
4378         Safefree(PL_curstackinfo);
4379         PL_curstackinfo = p;
4380     }
4381     Safefree(PL_tmps_stack);
4382     Safefree(PL_markstack);
4383     Safefree(PL_scopestack);
4384 #ifdef DEBUGGING
4385     Safefree(PL_scopestack_name);
4386 #endif
4387     Safefree(PL_savestack);
4388 }
4389
4390 void
4391 Perl_populate_isa(pTHX_ const char *name, STRLEN len, ...)
4392 {
4393     GV *const gv = gv_fetchpvn(name, len, GV_ADD | GV_ADDMULTI, SVt_PVAV);
4394     AV *const isa = GvAVn(gv);
4395     va_list args;
4396
4397     PERL_ARGS_ASSERT_POPULATE_ISA;
4398
4399     if(AvFILLp(isa) != -1)
4400         return;
4401
4402     /* NOTE: No support for tied ISA */
4403
4404     va_start(args, len);
4405     do {
4406         const char *const parent = va_arg(args, const char*);
4407         size_t parent_len;
4408
4409         if (!parent)
4410             break;
4411         parent_len = va_arg(args, size_t);
4412
4413         /* Arguments are supplied with a trailing ::  */
4414         assert(parent_len > 2);
4415         assert(parent[parent_len - 1] == ':');
4416         assert(parent[parent_len - 2] == ':');
4417         av_push(isa, newSVpvn(parent, parent_len - 2));
4418         (void) gv_fetchpvn(parent, parent_len, GV_ADD, SVt_PVGV);
4419     } while (1);
4420     va_end(args);
4421 }
4422
4423
4424 STATIC void
4425 S_init_predump_symbols(pTHX)
4426 {
4427     GV *tmpgv;
4428     IO *io;
4429
4430     sv_setpvs(get_sv("\"", GV_ADD), " ");
4431     PL_ofsgv = (GV*)SvREFCNT_inc(gv_fetchpvs(",", GV_ADD|GV_NOTQUAL, SVt_PV));
4432
4433
4434     /* Historically, PVIOs were blessed into IO::Handle, unless
4435        FileHandle was loaded, in which case they were blessed into
4436        that. Action at a distance.
4437        However, if we simply bless into IO::Handle, we break code
4438        that assumes that PVIOs will have (among others) a seek
4439        method. IO::File inherits from IO::Handle and IO::Seekable,
4440        and provides the needed methods. But if we simply bless into
4441        it, then we break code that assumed that by loading
4442        IO::Handle, *it* would work.
4443        So a compromise is to set up the correct @IO::File::ISA,
4444        so that code that does C<use IO::Handle>; will still work.
4445     */
4446                    
4447     Perl_populate_isa(aTHX_ STR_WITH_LEN("IO::File::ISA"),
4448                       STR_WITH_LEN("IO::Handle::"),
4449                       STR_WITH_LEN("IO::Seekable::"),
4450                       STR_WITH_LEN("Exporter::"),
4451                       NULL);
4452
4453     PL_stdingv = gv_fetchpvs("STDIN", GV_ADD|GV_NOTQUAL, SVt_PVIO);
4454     GvMULTI_on(PL_stdingv);
4455     io = GvIOp(PL_stdingv);
4456     IoTYPE(io) = IoTYPE_RDONLY;
4457     IoIFP(io) = PerlIO_stdin();
4458     tmpgv = gv_fetchpvs("stdin", GV_ADD|GV_NOTQUAL, SVt_PV);
4459     GvMULTI_on(tmpgv);
4460     GvIOp(tmpgv) = MUTABLE_IO(SvREFCNT_inc_simple(io));
4461
4462     tmpgv = gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVIO);
4463     GvMULTI_on(tmpgv);
4464     io = GvIOp(tmpgv);
4465     IoTYPE(io) = IoTYPE_WRONLY;
4466     IoOFP(io) = IoIFP(io) = PerlIO_stdout();
4467     setdefout(tmpgv);
4468     tmpgv = gv_fetchpvs("stdout", GV_ADD|GV_NOTQUAL, SVt_PV);
4469     GvMULTI_on(tmpgv);
4470     GvIOp(tmpgv) = MUTABLE_IO(SvREFCNT_inc_simple(io));
4471
4472     PL_stderrgv = gv_fetchpvs("STDERR", GV_ADD|GV_NOTQUAL, SVt_PVIO);
4473     GvMULTI_on(PL_stderrgv);
4474     io = GvIOp(PL_stderrgv);
4475     IoTYPE(io) = IoTYPE_WRONLY;
4476     IoOFP(io) = IoIFP(io) = PerlIO_stderr();
4477     tmpgv = gv_fetchpvs("stderr", GV_ADD|GV_NOTQUAL, SVt_PV);
4478     GvMULTI_on(tmpgv);
4479     GvIOp(tmpgv) = MUTABLE_IO(SvREFCNT_inc_simple(io));
4480
4481     PL_statname = newSVpvs("");         /* last filename we did stat on */
4482 }
4483
4484 void
4485 Perl_init_argv_symbols(pTHX_ int argc, char **argv)
4486 {
4487     PERL_ARGS_ASSERT_INIT_ARGV_SYMBOLS;
4488
4489     argc--,argv++;      /* skip name of script */
4490     if (PL_doswitches) {
4491         for (; argc > 0 && **argv == '-'; argc--,argv++) {
4492             char *s;
4493             if (!argv[0][1])
4494                 break;
4495             if (argv[0][1] == '-' && !argv[0][2]) {
4496                 argc--,argv++;
4497                 break;
4498             }
4499             if ((s = strchr(argv[0], '='))) {
4500                 const char *const start_name = argv[0] + 1;
4501                 sv_setpv(GvSV(gv_fetchpvn_flags(start_name, s - start_name,
4502                                                 TRUE, SVt_PV)), s + 1);
4503             }
4504             else
4505                 sv_setiv(GvSV(gv_fetchpv(argv[0]+1, GV_ADD, SVt_PV)),1);
4506         }
4507     }
4508     if ((PL_argvgv = gv_fetchpvs("ARGV", GV_ADD|GV_NOTQUAL, SVt_PVAV))) {
4509         SvREFCNT_inc_simple_void_NN(PL_argvgv);
4510         GvMULTI_on(PL_argvgv);
4511         av_clear(GvAVn(PL_argvgv));
4512         for (; argc > 0; argc--,argv++) {
4513             SV * const sv = newSVpv(argv[0],0);
4514             av_push(GvAV(PL_argvgv),sv);
4515             if (!(PL_unicode & PERL_UNICODE_LOCALE_FLAG) || PL_utf8locale) {
4516                  if (PL_unicode & PERL_UNICODE_ARGV_FLAG)
4517                       SvUTF8_on(sv);
4518             }
4519             if (PL_unicode & PERL_UNICODE_WIDESYSCALLS_FLAG) /* Sarathy? */
4520                  (void)sv_utf8_decode(sv);
4521         }
4522     }
4523
4524     if (PL_inplace && (!PL_argvgv || AvFILL(GvAV(PL_argvgv)) == -1))
4525         Perl_ck_warner_d(aTHX_ packWARN(WARN_INPLACE),
4526                          "-i used with no filenames on the command line, "
4527                          "reading from STDIN");
4528 }
4529
4530 STATIC void
4531 S_init_postdump_symbols(pTHX_ int argc, char **argv, char **env)
4532 {
4533 #ifdef USE_ITHREADS
4534     dVAR;
4535 #endif
4536     GV* tmpgv;
4537
4538     PERL_ARGS_ASSERT_INIT_POSTDUMP_SYMBOLS;
4539
4540     PL_toptarget = newSV_type(SVt_PVIV);
4541     SvPVCLEAR(PL_toptarget);
4542     PL_bodytarget = newSV_type(SVt_PVIV);
4543     SvPVCLEAR(PL_bodytarget);
4544     PL_formtarget = PL_bodytarget;
4545
4546     TAINT;
4547
4548     init_argv_symbols(argc,argv);
4549
4550     if ((tmpgv = gv_fetchpvs("0", GV_ADD|GV_NOTQUAL, SVt_PV))) {
4551         sv_setpv(GvSV(tmpgv),PL_origfilename);
4552     }
4553     if ((PL_envgv = gv_fetchpvs("ENV", GV_ADD|GV_NOTQUAL, SVt_PVHV))) {
4554         HV *hv;
4555         bool env_is_not_environ;
4556         SvREFCNT_inc_simple_void_NN(PL_envgv);
4557         GvMULTI_on(PL_envgv);
4558         hv = GvHVn(PL_envgv);
4559         hv_magic(hv, NULL, PERL_MAGIC_env);
4560 #ifndef PERL_MICRO
4561 #ifdef USE_ENVIRON_ARRAY
4562         /* Note that if the supplied env parameter is actually a copy
4563            of the global environ then it may now point to free'd memory
4564            if the environment has been modified since. To avoid this
4565            problem we treat env==NULL as meaning 'use the default'
4566         */
4567         if (!env)
4568             env = environ;
4569         env_is_not_environ = env != environ;
4570         if (env_is_not_environ
4571 #  ifdef USE_ITHREADS
4572             && PL_curinterp == aTHX
4573 #  endif
4574            )
4575         {
4576             environ[0] = NULL;
4577         }
4578         if (env) {
4579           char *s, *old_var;
4580           STRLEN nlen;
4581           SV *sv;
4582           HV *dups = newHV();
4583
4584           for (; *env; env++) {
4585             old_var = *env;
4586
4587             if (!(s = strchr(old_var,'=')) || s == old_var)
4588                 continue;
4589             nlen = s - old_var;
4590
4591 #if defined(MSDOS) && !defined(DJGPP)
4592             *s = '\0';
4593             (void)strupr(old_var);
4594             *s = '=';
4595 #endif
4596             if (hv_exists(hv, old_var, nlen)) {
4597                 const char *name = savepvn(old_var, nlen);
4598
4599                 /* make sure we use the same value as getenv(), otherwise code that
4600                    uses getenv() (like setlocale()) might see a different value to %ENV
4601                  */
4602                 sv = newSVpv(PerlEnv_getenv(name), 0);
4603
4604                 /* keep a count of the dups of this name so we can de-dup environ later */
4605                 if (hv_exists(dups, name, nlen))
4606                     ++SvIVX(*hv_fetch(dups, name, nlen, 0));
4607                 else
4608                     (void)hv_store(dups, name, nlen, newSViv(1), 0);
4609
4610                 Safefree(name);
4611             }
4612             else {
4613                 sv = newSVpv(s+1, 0);
4614             }
4615             (void)hv_store(hv, old_var, nlen, sv, 0);
4616             if (env_is_not_environ)
4617                 mg_set(sv);
4618           }
4619           if (HvKEYS(dups)) {
4620               /* environ has some duplicate definitions, remove them */
4621               HE *entry;
4622               hv_iterinit(dups);
4623               while ((entry = hv_iternext_flags(dups, 0))) {
4624                   STRLEN nlen;
4625                   const char *name = HePV(entry, nlen);
4626                   IV count = SvIV(HeVAL(entry));
4627                   IV i;
4628                   SV **valp = hv_fetch(hv, name, nlen, 0);
4629
4630                   assert(valp);
4631
4632                   /* try to remove any duplicate names, depending on the
4633                    * implementation used in my_setenv() the iteration might
4634                    * not be necessary, but let's be safe.
4635                    */
4636                   for (i = 0; i < count; ++i)
4637                       my_setenv(name, 0);
4638
4639                   /* and set it back to the value we set $ENV{name} to */
4640                   my_setenv(name, SvPV_nolen(*valp));
4641               }
4642           }
4643           SvREFCNT_dec_NN(dups);
4644       }
4645 #endif /* USE_ENVIRON_ARRAY */
4646 #endif /* !PERL_MICRO */
4647     }
4648     TAINT_NOT;
4649
4650     /* touch @F array to prevent spurious warnings 20020415 MJD */
4651     if (PL_minus_a) {
4652       (void) get_av("main::F", GV_ADD | GV_ADDMULTI);
4653     }
4654 }
4655
4656 STATIC void
4657 S_init_perllib(pTHX)
4658 {
4659 #ifndef VMS
4660     const char *perl5lib = NULL;
4661 #endif
4662     const char *s;
4663 #if defined(WIN32) && !defined(PERL_IS_MINIPERL)
4664     STRLEN len;
4665 #endif
4666
4667     if (!TAINTING_get) {
4668 #ifndef VMS
4669         perl5lib = PerlEnv_getenv("PERL5LIB");
4670 /*
4671  * It isn't possible to delete an environment variable with
4672  * PERL_USE_SAFE_PUTENV set unless unsetenv() is also available, so in that
4673  * case we treat PERL5LIB as undefined if it has a zero-length value.
4674  */
4675 #if defined(PERL_USE_SAFE_PUTENV) && ! defined(HAS_UNSETENV)
4676         if (perl5lib && *perl5lib != '\0')
4677 #else
4678         if (perl5lib)
4679 #endif
4680             incpush_use_sep(perl5lib, 0, INCPUSH_ADD_SUB_DIRS);
4681         else {
4682             s = PerlEnv_getenv("PERLLIB");
4683             if (s)
4684                 incpush_use_sep(s, 0, 0);
4685         }
4686 #else /* VMS */
4687         /* Treat PERL5?LIB as a possible search list logical name -- the
4688          * "natural" VMS idiom for a Unix path string.  We allow each
4689          * element to be a set of |-separated directories for compatibility.
4690          */
4691         char buf[256];
4692         int idx = 0;
4693         if (vmstrnenv("PERL5LIB",buf,0,NULL,0))
4694             do {
4695                 incpush_use_sep(buf, 0, INCPUSH_ADD_SUB_DIRS);
4696             } while (vmstrnenv("PERL5LIB",buf,++idx,NULL,0));
4697         else {
4698             while (vmstrnenv("PERLLIB",buf,idx++,NULL,0))
4699                 incpush_use_sep(buf, 0, 0);
4700         }
4701 #endif /* VMS */
4702     }
4703
4704 #ifndef PERL_IS_MINIPERL
4705     /* miniperl gets just -I..., the split of $ENV{PERL5LIB}, and "." in @INC
4706        (and not the architecture specific directories from $ENV{PERL5LIB}) */
4707
4708 #include "perl_inc_macro.h"
4709 /* Use the ~-expanded versions of APPLLIB (undocumented),
4710     SITEARCH, SITELIB, VENDORARCH, VENDORLIB, ARCHLIB and PRIVLIB
4711 */
4712     INCPUSH_APPLLIB_EXP
4713     INCPUSH_SITEARCH_EXP
4714     INCPUSH_SITELIB_EXP
4715     INCPUSH_PERL_VENDORARCH_EXP
4716     INCPUSH_PERL_VENDORLIB_EXP
4717     INCPUSH_ARCHLIB_EXP
4718     INCPUSH_PRIVLIB_EXP
4719     INCPUSH_PERL_OTHERLIBDIRS
4720     INCPUSH_PERL5LIB
4721     INCPUSH_APPLLIB_OLD_EXP
4722     INCPUSH_SITELIB_STEM
4723     INCPUSH_PERL_VENDORLIB_STEM
4724     INCPUSH_PERL_OTHERLIBDIRS_ARCHONLY
4725
4726 #endif /* !PERL_IS_MINIPERL */
4727
4728     if (!TAINTING_get) {
4729 #if !defined(PERL_IS_MINIPERL) && defined(DEFAULT_INC_EXCLUDES_DOT)
4730         const char * const unsafe = PerlEnv_getenv("PERL_USE_UNSAFE_INC");
4731         if (unsafe && strEQ(unsafe, "1"))
4732 #endif
4733           S_incpush(aTHX_ STR_WITH_LEN("."), 0);
4734     }
4735 }
4736
4737 #if defined(DOSISH) || defined(__SYMBIAN32__)
4738 #    define PERLLIB_SEP ';'
4739 #elif defined(__VMS)
4740 #    define PERLLIB_SEP PL_perllib_sep
4741 #else
4742 #    define PERLLIB_SEP ':'
4743 #endif
4744 #ifndef PERLLIB_MANGLE
4745 #  define PERLLIB_MANGLE(s,n) (s)
4746 #endif
4747
4748 #ifndef PERL_IS_MINIPERL
4749 /* Push a directory onto @INC if it exists.
4750    Generate a new SV if we do this, to save needing to copy the SV we push
4751    onto @INC  */
4752 STATIC SV *
4753 S_incpush_if_exists(pTHX_ AV *const av, SV *dir, SV *const stem)
4754 {
4755     Stat_t tmpstatbuf;
4756
4757     PERL_ARGS_ASSERT_INCPUSH_IF_EXISTS;
4758
4759     if (PerlLIO_stat(SvPVX_const(dir), &tmpstatbuf) >= 0 &&
4760         S_ISDIR(tmpstatbuf.st_mode)) {
4761         av_push(av, dir);
4762         dir = newSVsv(stem);
4763     } else {
4764         /* Truncate dir back to stem.  */
4765         SvCUR_set(dir, SvCUR(stem));
4766     }
4767     return dir;
4768 }
4769 #endif
4770
4771 STATIC SV *
4772 S_mayberelocate(pTHX_ const char *const dir, STRLEN len, U32 flags)
4773 {
4774     const U8 canrelocate = (U8)flags & INCPUSH_CAN_RELOCATE;
4775     SV *libdir;
4776
4777     PERL_ARGS_ASSERT_MAYBERELOCATE;
4778     assert(len > 0);
4779
4780     /* I am not convinced that this is valid when PERLLIB_MANGLE is
4781        defined to so something (in os2/os2.c), but the code has been
4782        this way, ignoring any possible changed of length, since
4783        760ac839baf413929cd31cc32ffd6dba6b781a81 (5.003_02) so I'll leave
4784        it be.  */
4785     libdir = newSVpvn(PERLLIB_MANGLE(dir, len), len);
4786
4787 #ifdef VMS
4788     {
4789         char *unix;
4790
4791         if ((unix = tounixspec_ts(SvPV(libdir,len),NULL)) != NULL) {
4792             len = strlen(unix);
4793             while (len > 1 && unix[len-1] == '/') len--;  /* Cosmetic */
4794             sv_usepvn(libdir,unix,len);
4795         }
4796         else
4797             PerlIO_printf(Perl_error_log,
4798                           "Failed to unixify @INC element \"%s\"\n",
4799                           SvPV_nolen_const(libdir));
4800     }
4801 #endif
4802
4803         /* Do the if() outside the #ifdef to avoid warnings about an unused
4804            parameter.  */
4805         if (canrelocate) {
4806 #ifdef PERL_RELOCATABLE_INC
4807         /*
4808          * Relocatable include entries are marked with a leading .../
4809          *
4810          * The algorithm is
4811          * 0: Remove that leading ".../"
4812          * 1: Remove trailing executable name (anything after the last '/')
4813          *    from the perl path to give a perl prefix
4814          * Then
4815          * While the @INC element starts "../" and the prefix ends with a real
4816          * directory (ie not . or ..) chop that real directory off the prefix
4817          * and the leading "../" from the @INC element. ie a logical "../"
4818          * cleanup
4819          * Finally concatenate the prefix and the remainder of the @INC element
4820          * The intent is that /usr/local/bin/perl and .../../lib/perl5
4821          * generates /usr/local/lib/perl5
4822          */
4823             const char *libpath = SvPVX(libdir);
4824             STRLEN libpath_len = SvCUR(libdir);
4825             if (memBEGINs(libpath, libpath_len, ".../")) {
4826                 /* Game on!  */
4827                 SV * const caret_X = get_sv("\030", 0);
4828                 /* Going to use the SV just as a scratch buffer holding a C
4829                    string:  */
4830                 SV *prefix_sv;
4831                 char *prefix;
4832                 char *lastslash;
4833
4834                 /* $^X is *the* source of taint if tainting is on, hence
4835                    SvPOK() won't be true.  */
4836                 assert(caret_X);
4837                 assert(SvPOKp(caret_X));
4838                 prefix_sv = newSVpvn_flags(SvPVX(caret_X), SvCUR(caret_X),
4839                                            SvUTF8(caret_X));
4840                 /* Firstly take off the leading .../
4841                    If all else fail we'll do the paths relative to the current
4842                    directory.  */
4843                 sv_chop(libdir, libpath + 4);
4844                 /* Don't use SvPV as we're intentionally bypassing taining,
4845                    mortal copies that the mg_get of tainting creates, and
4846                    corruption that seems to come via the save stack.
4847                    I guess that the save stack isn't correctly set up yet.  */
4848                 libpath = SvPVX(libdir);
4849                 libpath_len = SvCUR(libdir);
4850
4851                 prefix = SvPVX(prefix_sv);
4852                 lastslash = (char *) my_memrchr(prefix, '/',
4853                              SvEND(prefix_sv) - prefix);
4854
4855                 /* First time in with the *lastslash = '\0' we just wipe off
4856                    the trailing /perl from (say) /usr/foo/bin/perl
4857                 */
4858                 if (lastslash) {
4859                     SV *tempsv;
4860                     while ((*lastslash = '\0'), /* Do that, come what may.  */
4861                            (   memBEGINs(libpath, libpath_len, "../")
4862                             && (lastslash =
4863                                   (char *) my_memrchr(prefix, '/',
4864                                                    SvEND(prefix_sv) - prefix))))
4865                     {
4866                         if (lastslash[1] == '\0'
4867                             || (lastslash[1] == '.'
4868                                 && (lastslash[2] == '/' /* ends "/."  */
4869                                     || (lastslash[2] == '/'
4870                                         && lastslash[3] == '/' /* or "/.."  */
4871                                         )))) {
4872                             /* Prefix ends "/" or "/." or "/..", any of which
4873                                are fishy, so don't do any more logical cleanup.
4874                             */
4875                             break;
4876                         }
4877                         /* Remove leading "../" from path  */
4878                         libpath += 3;
4879                         libpath_len -= 3;
4880                         /* Next iteration round the loop removes the last
4881                            directory name from prefix by writing a '\0' in
4882                            the while clause.  */
4883                     }
4884                     /* prefix has been terminated with a '\0' to the correct
4885                        length. libpath points somewhere into the libdir SV.
4886                        We need to join the 2 with '/' and drop the result into
4887                        libdir.  */
4888                     tempsv = Perl_newSVpvf(aTHX_ "%s/%s", prefix, libpath);
4889                     SvREFCNT_dec(libdir);
4890                     /* And this is the new libdir.  */
4891                     libdir = tempsv;
4892                     if (TAINTING_get &&
4893                         (PerlProc_getuid() != PerlProc_geteuid() ||
4894                          PerlProc_getgid() != PerlProc_getegid())) {
4895                         /* Need to taint relocated paths if running set ID  */
4896                         SvTAINTED_on(libdir);
4897                     }
4898                 }
4899                 SvREFCNT_dec(prefix_sv);
4900             }
4901 #endif
4902         }
4903     return libdir;
4904 }
4905
4906 STATIC void
4907 S_incpush(pTHX_ const char *const dir, STRLEN len, U32 flags)
4908 {
4909 #ifndef PERL_IS_MINIPERL
4910     const U8 using_sub_dirs
4911         = (U8)flags & (INCPUSH_ADD_VERSIONED_SUB_DIRS
4912                        |INCPUSH_ADD_ARCHONLY_SUB_DIRS|INCPUSH_ADD_OLD_VERS);
4913     const U8 add_versioned_sub_dirs
4914         = (U8)flags & INCPUSH_ADD_VERSIONED_SUB_DIRS;
4915     const U8 add_archonly_sub_dirs
4916         = (U8)flags & INCPUSH_ADD_ARCHONLY_SUB_DIRS;
4917 #ifdef PERL_INC_VERSION_LIST
4918     const U8 addoldvers  = (U8)flags & INCPUSH_ADD_OLD_VERS;
4919 #endif
4920 #endif
4921     const U8 unshift     = (U8)flags & INCPUSH_UNSHIFT;
4922     const U8 push_basedir = (flags & INCPUSH_NOT_BASEDIR) ? 0 : 1;
4923     AV *const inc = GvAVn(PL_incgv);
4924
4925     PERL_ARGS_ASSERT_INCPUSH;
4926     assert(len > 0);
4927
4928     /* Could remove this vestigial extra block, if we don't mind a lot of
4929        re-indenting diff noise.  */
4930     {
4931         SV *const libdir = mayberelocate(dir, len, flags);
4932         /* Change 20189146be79a0596543441fa369c6bf7f85103f, to fix RT#6665,
4933            arranged to unshift #! line -I onto the front of @INC. However,
4934            -I can add version and architecture specific libraries, and they
4935            need to go first. The old code assumed that it was always
4936            pushing. Hence to make it work, need to push the architecture
4937            (etc) libraries onto a temporary array, then "unshift" that onto
4938            the front of @INC.  */
4939 #ifndef PERL_IS_MINIPERL
4940         AV *const av = (using_sub_dirs) ? (unshift ? newAV() : inc) : NULL;
4941
4942         /*
4943          * BEFORE pushing libdir onto @INC we may first push version- and
4944          * archname-specific sub-directories.
4945          */
4946         if (using_sub_dirs) {
4947             SV *subdir = newSVsv(libdir);
4948 #ifdef PERL_INC_VERSION_LIST
4949             /* Configure terminates PERL_INC_VERSION_LIST with a NULL */
4950             const char * const incverlist[] = { PERL_INC_VERSION_LIST };
4951             const char * const *incver;
4952 #endif
4953
4954             if (add_versioned_sub_dirs) {
4955                 /* .../version/archname if -d .../version/archname */
4956                 sv_catpvs(subdir, "/" PERL_FS_VERSION "/" ARCHNAME);
4957                 subdir = S_incpush_if_exists(aTHX_ av, subdir, libdir);
4958
4959                 /* .../version if -d .../version */
4960                 sv_catpvs(subdir, "/" PERL_FS_VERSION);
4961                 subdir = S_incpush_if_exists(aTHX_ av, subdir, libdir);
4962             }
4963
4964 #ifdef PERL_INC_VERSION_LIST
4965             if (addoldvers) {
4966                 for (incver = incverlist; *incver; incver++) {
4967                     /* .../xxx if -d .../xxx */
4968                     Perl_sv_catpvf(aTHX_ subdir, "/%s", *incver);
4969                     subdir = S_incpush_if_exists(aTHX_ av, subdir, libdir);
4970                 }
4971             }
4972 #endif
4973
4974             if (add_archonly_sub_dirs) {
4975                 /* .../archname if -d .../archname */
4976                 sv_catpvs(subdir, "/" ARCHNAME);
4977                 subdir = S_incpush_if_exists(aTHX_ av, subdir, libdir);
4978
4979             }
4980
4981             assert (SvREFCNT(subdir) == 1);
4982             SvREFCNT_dec(subdir);
4983         }
4984 #endif /* !PERL_IS_MINIPERL */
4985         /* finally add this lib directory at the end of @INC */
4986         if (unshift) {
4987 #ifdef PERL_IS_MINIPERL
4988             const Size_t extra = 0;
4989 #else
4990             Size_t extra = av_tindex(av) + 1;
4991 #endif
4992             av_unshift(inc, extra + push_basedir);
4993             if (push_basedir)
4994                 av_store(inc, extra, libdir);
4995 #ifndef PERL_IS_MINIPERL
4996             while (extra--) {
4997                 /* av owns a reference, av_store() expects to be donated a
4998                    reference, and av expects to be sane when it's cleared.
4999                    If I wanted to be naughty and wrong, I could peek inside the
5000                    implementation of av_clear(), realise that it uses
5001                    SvREFCNT_dec() too, so av's array could be a run of NULLs,
5002                    and so directly steal from it (with a memcpy() to inc, and
5003                    then memset() to NULL them out. But people copy code from the
5004                    core expecting it to be best practise, so let's use the API.
5005                    Although studious readers will note that I'm not checking any
5006                    return codes.  */
5007                 av_store(inc, extra, SvREFCNT_inc(*av_fetch(av, extra, FALSE)));
5008             }
5009             SvREFCNT_dec(av);
5010 #endif
5011         }
5012         else if (push_basedir) {
5013             av_push(inc, libdir);
5014         }
5015
5016         if (!push_basedir) {
5017             assert (SvREFCNT(libdir) == 1);
5018             SvREFCNT_dec(libdir);
5019         }
5020     }
5021 }
5022
5023 STATIC void
5024 S_incpush_use_sep(pTHX_ const char *p, STRLEN len, U32 flags)
5025 {
5026     const char *s;
5027     const char *end;
5028     /* This logic has been broken out from S_incpush(). It may be possible to
5029        simplify it.  */
5030
5031     PERL_ARGS_ASSERT_INCPUSH_USE_SEP;
5032
5033     /* perl compiled with -DPERL_RELOCATABLE_INCPUSH will ignore the len
5034      * argument to incpush_use_sep.  This allows creation of relocatable
5035      * Perl distributions that patch the binary at install time.  Those
5036      * distributions will have to provide their own relocation tools; this
5037      * is not a feature otherwise supported by core Perl.
5038      */
5039 #ifndef PERL_RELOCATABLE_INCPUSH
5040     if (!len)
5041 #endif
5042         len = strlen(p);
5043
5044     end = p + len;
5045
5046     /* Break at all separators */
5047     while ((s = (const char*)memchr(p, PERLLIB_SEP, end - p))) {
5048         if (s == p) {
5049             /* skip any consecutive separators */
5050
5051             /* Uncomment the next line for PATH semantics */
5052             /* But you'll need to write tests */
5053             /* av_push(GvAVn(PL_incgv), newSVpvs(".")); */
5054         } else {
5055             incpush(p, (STRLEN)(s - p), flags);
5056         }
5057         p = s + 1;
5058     }
5059     if (p != end)
5060         incpush(p, (STRLEN)(end - p), flags);
5061
5062 }
5063
5064 void
5065 Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
5066 {
5067     SV *atsv;
5068     volatile const line_t oldline = PL_curcop ? CopLINE(PL_curcop) : 0;
5069     CV *cv;
5070     STRLEN len;
5071     int ret;
5072     dJMPENV;
5073
5074     PERL_ARGS_ASSERT_CALL_LIST;
5075
5076     while (av_tindex(paramList) >= 0) {
5077         cv = MUTABLE_CV(av_shift(paramList));
5078         if (PL_savebegin) {
5079             if (paramList == PL_beginav) {
5080                 /* save PL_beginav for compiler */
5081                 Perl_av_create_and_push(aTHX_ &PL_beginav_save, MUTABLE_SV(cv));
5082             }
5083             else if (paramList == PL_checkav) {
5084                 /* save PL_checkav for compiler */
5085                 Perl_av_create_and_push(aTHX_ &PL_checkav_save, MUTABLE_SV(cv));
5086             }
5087             else if (paramList == PL_unitcheckav) {
5088                 /* save PL_unitcheckav for compiler */
5089                 Perl_av_create_and_push(aTHX_ &PL_unitcheckav_save, MUTABLE_SV(cv));
5090             }
5091         } else {
5092             SAVEFREESV(cv);
5093         }
5094         JMPENV_PUSH(ret);
5095         switch (ret) {
5096         case 0:
5097             CALL_LIST_BODY(cv);
5098             atsv = ERRSV;
5099             (void)SvPV_const(atsv, len);
5100             if (len) {
5101                 PL_curcop = &PL_compiling;
5102                 CopLINE_set(PL_curcop, oldline);
5103                 if (paramList == PL_beginav)
5104                     sv_catpvs(atsv, "BEGIN failed--compilation aborted");
5105                 else
5106                     Perl_sv_catpvf(aTHX_ atsv,
5107                                    "%s failed--call queue aborted",
5108                                    paramList == PL_checkav ? "CHECK"
5109                                    : paramList == PL_initav ? "INIT"
5110                                    : paramList == PL_unitcheckav ? "UNITCHECK"
5111                                    : "END");
5112                 while (PL_scopestack_ix > oldscope)
5113                     LEAVE;
5114                 JMPENV_POP;
5115                 Perl_croak(aTHX_ "%" SVf, SVfARG(atsv));
5116             }
5117             break;
5118         case 1:
5119             STATUS_ALL_FAILURE;
5120             /* FALLTHROUGH */
5121         case 2:
5122             /* my_exit() was called */
5123             while (PL_scopestack_ix > oldscope)
5124                 LEAVE;
5125             FREETMPS;
5126             SET_CURSTASH(PL_defstash);
5127             PL_curcop = &PL_compiling;
5128             CopLINE_set(PL_curcop, oldline);
5129             JMPENV_POP;
5130             my_exit_jump();
5131             NOT_REACHED; /* NOTREACHED */
5132         case 3:
5133             if (PL_restartop) {
5134                 PL_curcop = &PL_compiling;
5135                 CopLINE_set(PL_curcop, oldline);
5136                 JMPENV_JUMP(3);
5137             }
5138             PerlIO_printf(Perl_error_log, "panic: restartop in call_list\n");
5139             FREETMPS;
5140             break;
5141         }
5142         JMPENV_POP;
5143     }
5144 }
5145
5146 void
5147 Perl_my_exit(pTHX_ U32 status)
5148 {
5149     if (PL_exit_flags & PERL_EXIT_ABORT) {
5150         abort();
5151     }
5152     if (PL_exit_flags & PERL_EXIT_WARN) {
5153         PL_exit_flags |= PERL_EXIT_ABORT; /* Protect against reentrant calls */
5154         Perl_warn(aTHX_ "Unexpected exit %lu", (unsigned long)status);
5155         PL_exit_flags &= ~PERL_EXIT_ABORT;
5156     }
5157     switch (status) {
5158     case 0:
5159         STATUS_ALL_SUCCESS;
5160         break;
5161     case 1:
5162         STATUS_ALL_FAILURE;
5163         break;
5164     default:
5165         STATUS_EXIT_SET(status);
5166         break;
5167     }
5168     my_exit_jump();
5169 }
5170
5171 void
5172 Perl_my_failure_exit(pTHX)
5173 {
5174 #ifdef VMS
5175      /* We have been called to fall on our sword.  The desired exit code
5176       * should be already set in STATUS_UNIX, but could be shifted over
5177       * by 8 bits.  STATUS_UNIX_EXIT_SET will handle the cases where a
5178       * that code is set.
5179       *
5180       * If an error code has not been set, then force the issue.
5181       */
5182     if (MY_POSIX_EXIT) {
5183
5184         /* According to the die_exit.t tests, if errno is non-zero */
5185         /* It should be used for the error status. */
5186
5187         if (errno == EVMSERR) {
5188             STATUS_NATIVE = vaxc$errno;
5189         } else {
5190
5191             /* According to die_exit.t tests, if the child_exit code is */
5192             /* also zero, then we need to exit with a code of 255 */
5193             if ((errno != 0) && (errno < 256))
5194                 STATUS_UNIX_EXIT_SET(errno);
5195             else if (STATUS_UNIX < 255) {
5196                 STATUS_UNIX_EXIT_SET(255);
5197             }
5198
5199         }
5200
5201         /* The exit code could have been set by $? or vmsish which
5202          * means that it may not have fatal set.  So convert
5203          * success/warning codes to fatal with out changing
5204          * the POSIX status code.  The severity makes VMS native
5205          * status handling work, while UNIX mode programs use the
5206          * the POSIX exit codes.
5207          */
5208          if ((STATUS_NATIVE & (STS$K_SEVERE|STS$K_ERROR)) == 0) {
5209             STATUS_NATIVE &= STS$M_COND_ID;
5210             STATUS_NATIVE |= STS$K_ERROR | STS$M_INHIB_MSG;
5211          }
5212     }
5213     else {
5214         /* Traditionally Perl on VMS always expects a Fatal Error. */
5215         if (vaxc$errno & 1) {
5216
5217             /* So force success status to failure */
5218             if (STATUS_NATIVE & 1)
5219                 STATUS_ALL_FAILURE;
5220         }
5221         else {
5222             if (!vaxc$errno) {
5223                 STATUS_UNIX = EINTR; /* In case something cares */
5224                 STATUS_ALL_FAILURE;
5225             }
5226             else {
5227                 int severity;
5228                 STATUS_NATIVE = vaxc$errno; /* Should already be this */
5229
5230                 /* Encode the severity code */
5231                 severity = STATUS_NATIVE & STS$M_SEVERITY;
5232                 STATUS_UNIX = (severity ? severity : 1) << 8;
5233
5234                 /* Perl expects this to be a fatal error */
5235                 if (severity != STS$K_SEVERE)
5236                     STATUS_ALL_FAILURE;
5237             }
5238         }
5239     }
5240
5241 #else
5242     int exitstatus;
5243     int eno = errno;
5244     if (eno & 255)
5245         STATUS_UNIX_SET(eno);
5246     else {
5247         exitstatus = STATUS_UNIX >> 8;
5248         if (exitstatus & 255)
5249             STATUS_UNIX_SET(exitstatus);
5250         else
5251             STATUS_UNIX_SET(255);
5252     }
5253 #endif
5254     if (PL_exit_flags & PERL_EXIT_ABORT) {
5255         abort();
5256     }
5257     if (PL_exit_flags & PERL_EXIT_WARN) {
5258         PL_exit_flags |= PERL_EXIT_ABORT; /* Protect against reentrant calls */
5259         Perl_warn(aTHX_ "Unexpected exit failure %ld", (long)PL_statusvalue);
5260         PL_exit_flags &= ~PERL_EXIT_ABORT;
5261     }
5262     my_exit_jump();
5263 }
5264
5265 STATIC void
5266 S_my_exit_jump(pTHX)
5267 {
5268     if (PL_e_script) {
5269         SvREFCNT_dec(PL_e_script);
5270         PL_e_script = NULL;
5271     }
5272
5273     POPSTACK_TO(PL_mainstack);
5274     if (cxstack_ix >= 0) {
5275         dounwind(-1);
5276         cx_popblock(cxstack);
5277     }
5278     LEAVE_SCOPE(0);
5279
5280     JMPENV_JUMP(2);
5281 }
5282
5283 static I32
5284 read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen)
5285 {
5286     const char * const p  = SvPVX_const(PL_e_script);
5287     const char * const e  = SvEND(PL_e_script);
5288     const char *nl = (char *) memchr(p, '\n', e - p);
5289
5290     PERL_UNUSED_ARG(idx);
5291     PERL_UNUSED_ARG(maxlen);
5292
5293     nl = (nl) ? nl+1 : e;
5294     if (nl-p == 0) {
5295         filter_del(read_e_script);
5296         return 0;
5297     }
5298     sv_catpvn(buf_sv, p, nl-p);
5299     sv_chop(PL_e_script, nl);
5300     return 1;
5301 }
5302
5303 /* removes boilerplate code at the end of each boot_Module xsub */
5304 void
5305 Perl_xs_boot_epilog(pTHX_ const I32 ax)
5306 {
5307   if (PL_unitcheckav)
5308         call_list(PL_scopestack_ix, PL_unitcheckav);
5309     XSRETURN_YES;
5310 }
5311
5312 /*
5313  * ex: set ts=8 sts=4 sw=4 et:
5314  */