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