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