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