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