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