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