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