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