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