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