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