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