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