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