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