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