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