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