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