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