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