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