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