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