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