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