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