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