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