[perl #59908] \x, \0, and \N{} not ok in double-quotish when followed by > \x100
[p5sagit/p5-mst-13.2.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.  If C<create> is set and the
2419 Perl variable does not exist then it will be created.  If C<create> is not
2420 set and the variable does not exist then NULL is returned.
2421
2422 =cut
2423 */
2424
2425 SV*
2426 Perl_get_sv(pTHX_ const char *name, I32 create)
2427 {
2428     GV *gv;
2429
2430     PERL_ARGS_ASSERT_GET_SV;
2431
2432     gv = gv_fetchpv(name, create, SVt_PV);
2433     if (gv)
2434         return GvSV(gv);
2435     return NULL;
2436 }
2437
2438 /*
2439 =head1 Array Manipulation Functions
2440
2441 =for apidoc p||get_av
2442
2443 Returns the AV of the specified Perl array.  If C<create> is set and the
2444 Perl variable does not exist then it will be created.  If C<create> is not
2445 set and the variable does not exist then NULL is returned.
2446
2447 =cut
2448 */
2449
2450 AV*
2451 Perl_get_av(pTHX_ const char *name, I32 create)
2452 {
2453     GV* const gv = gv_fetchpv(name, create, SVt_PVAV);
2454
2455     PERL_ARGS_ASSERT_GET_AV;
2456
2457     if (create)
2458         return GvAVn(gv);
2459     if (gv)
2460         return GvAV(gv);
2461     return NULL;
2462 }
2463
2464 /*
2465 =head1 Hash Manipulation Functions
2466
2467 =for apidoc p||get_hv
2468
2469 Returns the HV of the specified Perl hash.  If C<create> is set and the
2470 Perl variable does not exist then it will be created.  If C<create> is not
2471 set and the variable does not exist then NULL is returned.
2472
2473 =cut
2474 */
2475
2476 HV*
2477 Perl_get_hv(pTHX_ const char *name, I32 create)
2478 {
2479     GV* const gv = gv_fetchpv(name, create, SVt_PVHV);
2480
2481     PERL_ARGS_ASSERT_GET_HV;
2482
2483     if (create)
2484         return GvHVn(gv);
2485     if (gv)
2486         return GvHV(gv);
2487     return NULL;
2488 }
2489
2490 /*
2491 =head1 CV Manipulation Functions
2492
2493 =for apidoc p||get_cvn_flags
2494
2495 Returns the CV of the specified Perl subroutine.  C<flags> are passed to
2496 C<gv_fetchpvn_flags>. If C<GV_ADD> is set and the Perl subroutine does not
2497 exist then it will be declared (which has the same effect as saying
2498 C<sub name;>).  If C<GV_ADD> is not set and the subroutine does not exist
2499 then NULL is returned.
2500
2501 =for apidoc p||get_cv
2502
2503 Uses C<strlen> to get the length of C<name>, then calls C<get_cvn_flags>.
2504
2505 =cut
2506 */
2507
2508 CV*
2509 Perl_get_cvn_flags(pTHX_ const char *name, STRLEN len, I32 flags)
2510 {
2511     GV* const gv = gv_fetchpvn_flags(name, len, flags, SVt_PVCV);
2512     /* XXX this is probably not what they think they're getting.
2513      * It has the same effect as "sub name;", i.e. just a forward
2514      * declaration! */
2515
2516     PERL_ARGS_ASSERT_GET_CVN_FLAGS;
2517
2518     if ((flags & ~GV_NOADD_MASK) && !GvCVu(gv)) {
2519         SV *const sv = newSVpvn_flags(name, len, flags & SVf_UTF8);
2520         return newSUB(start_subparse(FALSE, 0),
2521                       newSVOP(OP_CONST, 0, sv),
2522                       NULL, NULL);
2523     }
2524     if (gv)
2525         return GvCVu(gv);
2526     return NULL;
2527 }
2528
2529 CV*
2530 Perl_get_cv(pTHX_ const char *name, I32 flags)
2531 {
2532     PERL_ARGS_ASSERT_GET_CV;
2533
2534     return get_cvn_flags(name, strlen(name), flags);
2535 }
2536
2537 /* Be sure to refetch the stack pointer after calling these routines. */
2538
2539 /*
2540
2541 =head1 Callback Functions
2542
2543 =for apidoc p||call_argv
2544
2545 Performs a callback to the specified Perl sub.  See L<perlcall>.
2546
2547 =cut
2548 */
2549
2550 I32
2551 Perl_call_argv(pTHX_ const char *sub_name, I32 flags, register char **argv)
2552
2553                         /* See G_* flags in cop.h */
2554                         /* null terminated arg list */
2555 {
2556     dVAR;
2557     dSP;
2558
2559     PERL_ARGS_ASSERT_CALL_ARGV;
2560
2561     PUSHMARK(SP);
2562     if (argv) {
2563         while (*argv) {
2564             mXPUSHs(newSVpv(*argv,0));
2565             argv++;
2566         }
2567         PUTBACK;
2568     }
2569     return call_pv(sub_name, flags);
2570 }
2571
2572 /*
2573 =for apidoc p||call_pv
2574
2575 Performs a callback to the specified Perl sub.  See L<perlcall>.
2576
2577 =cut
2578 */
2579
2580 I32
2581 Perl_call_pv(pTHX_ const char *sub_name, I32 flags)
2582                         /* name of the subroutine */
2583                         /* See G_* flags in cop.h */
2584 {
2585     PERL_ARGS_ASSERT_CALL_PV;
2586
2587     return call_sv(MUTABLE_SV(get_cv(sub_name, TRUE)), flags);
2588 }
2589
2590 /*
2591 =for apidoc p||call_method
2592
2593 Performs a callback to the specified Perl method.  The blessed object must
2594 be on the stack.  See L<perlcall>.
2595
2596 =cut
2597 */
2598
2599 I32
2600 Perl_call_method(pTHX_ const char *methname, I32 flags)
2601                         /* name of the subroutine */
2602                         /* See G_* flags in cop.h */
2603 {
2604     PERL_ARGS_ASSERT_CALL_METHOD;
2605
2606     return call_sv(sv_2mortal(newSVpv(methname,0)), flags | G_METHOD);
2607 }
2608
2609 /* May be called with any of a CV, a GV, or an SV containing the name. */
2610 /*
2611 =for apidoc p||call_sv
2612
2613 Performs a callback to the Perl sub whose name is in the SV.  See
2614 L<perlcall>.
2615
2616 =cut
2617 */
2618
2619 I32
2620 Perl_call_sv(pTHX_ SV *sv, VOL I32 flags)
2621                         /* See G_* flags in cop.h */
2622 {
2623     dVAR; dSP;
2624     LOGOP myop;         /* fake syntax tree node */
2625     UNOP method_op;
2626     I32 oldmark;
2627     VOL I32 retval = 0;
2628     I32 oldscope;
2629     bool oldcatch = CATCH_GET;
2630     int ret;
2631     OP* const oldop = PL_op;
2632     dJMPENV;
2633
2634     PERL_ARGS_ASSERT_CALL_SV;
2635
2636     if (flags & G_DISCARD) {
2637         ENTER;
2638         SAVETMPS;
2639     }
2640     if (!(flags & G_WANT)) {
2641         /* Backwards compatibility - as G_SCALAR was 0, it could be omitted.
2642          */
2643         flags |= G_SCALAR;
2644     }
2645
2646     Zero(&myop, 1, LOGOP);
2647     myop.op_next = NULL;
2648     if (!(flags & G_NOARGS))
2649         myop.op_flags |= OPf_STACKED;
2650     myop.op_flags |= OP_GIMME_REVERSE(flags);
2651     SAVEOP();
2652     PL_op = (OP*)&myop;
2653
2654     EXTEND(PL_stack_sp, 1);
2655     *++PL_stack_sp = sv;
2656     oldmark = TOPMARK;
2657     oldscope = PL_scopestack_ix;
2658
2659     if (PERLDB_SUB && PL_curstash != PL_debstash
2660            /* Handle first BEGIN of -d. */
2661           && (PL_DBcv || (PL_DBcv = GvCV(PL_DBsub)))
2662            /* Try harder, since this may have been a sighandler, thus
2663             * curstash may be meaningless. */
2664           && (SvTYPE(sv) != SVt_PVCV || CvSTASH((const CV *)sv) != PL_debstash)
2665           && !(flags & G_NODEBUG))
2666         PL_op->op_private |= OPpENTERSUB_DB;
2667
2668     if (flags & G_METHOD) {
2669         Zero(&method_op, 1, UNOP);
2670         method_op.op_next = PL_op;
2671         method_op.op_ppaddr = PL_ppaddr[OP_METHOD];
2672         method_op.op_type = OP_METHOD;
2673         myop.op_ppaddr = PL_ppaddr[OP_ENTERSUB];
2674         myop.op_type = OP_ENTERSUB;
2675         PL_op = (OP*)&method_op;
2676     }
2677
2678     if (!(flags & G_EVAL)) {
2679         CATCH_SET(TRUE);
2680         CALL_BODY_SUB((OP*)&myop);
2681         retval = PL_stack_sp - (PL_stack_base + oldmark);
2682         CATCH_SET(oldcatch);
2683     }
2684     else {
2685         myop.op_other = (OP*)&myop;
2686         PL_markstack_ptr--;
2687         create_eval_scope(flags|G_FAKINGEVAL);
2688         PL_markstack_ptr++;
2689
2690         JMPENV_PUSH(ret);
2691
2692         switch (ret) {
2693         case 0:
2694  redo_body:
2695             CALL_BODY_SUB((OP*)&myop);
2696             retval = PL_stack_sp - (PL_stack_base + oldmark);
2697             if (!(flags & G_KEEPERR)) {
2698                 CLEAR_ERRSV();
2699             }
2700             break;
2701         case 1:
2702             STATUS_ALL_FAILURE;
2703             /* FALL THROUGH */
2704         case 2:
2705             /* my_exit() was called */
2706             PL_curstash = PL_defstash;
2707             FREETMPS;
2708             JMPENV_POP;
2709             if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
2710                 Perl_croak(aTHX_ "Callback called exit");
2711             my_exit_jump();
2712             /* NOTREACHED */
2713         case 3:
2714             if (PL_restartop) {
2715                 PL_op = PL_restartop;
2716                 PL_restartop = 0;
2717                 goto redo_body;
2718             }
2719             PL_stack_sp = PL_stack_base + oldmark;
2720             if ((flags & G_WANT) == G_ARRAY)
2721                 retval = 0;
2722             else {
2723                 retval = 1;
2724                 *++PL_stack_sp = &PL_sv_undef;
2725             }
2726             break;
2727         }
2728
2729         if (PL_scopestack_ix > oldscope)
2730             delete_eval_scope();
2731         JMPENV_POP;
2732     }
2733
2734     if (flags & G_DISCARD) {
2735         PL_stack_sp = PL_stack_base + oldmark;
2736         retval = 0;
2737         FREETMPS;
2738         LEAVE;
2739     }
2740     PL_op = oldop;
2741     return retval;
2742 }
2743
2744 /* Eval a string. The G_EVAL flag is always assumed. */
2745
2746 /*
2747 =for apidoc p||eval_sv
2748
2749 Tells Perl to C<eval> the string in the SV.
2750
2751 =cut
2752 */
2753
2754 I32
2755 Perl_eval_sv(pTHX_ SV *sv, I32 flags)
2756
2757                         /* See G_* flags in cop.h */
2758 {
2759     dVAR;
2760     dSP;
2761     UNOP myop;          /* fake syntax tree node */
2762     VOL I32 oldmark = SP - PL_stack_base;
2763     VOL I32 retval = 0;
2764     int ret;
2765     OP* const oldop = PL_op;
2766     dJMPENV;
2767
2768     PERL_ARGS_ASSERT_EVAL_SV;
2769
2770     if (flags & G_DISCARD) {
2771         ENTER;
2772         SAVETMPS;
2773     }
2774
2775     SAVEOP();
2776     PL_op = (OP*)&myop;
2777     Zero(PL_op, 1, UNOP);
2778     EXTEND(PL_stack_sp, 1);
2779     *++PL_stack_sp = sv;
2780
2781     if (!(flags & G_NOARGS))
2782         myop.op_flags = OPf_STACKED;
2783     myop.op_next = NULL;
2784     myop.op_type = OP_ENTEREVAL;
2785     myop.op_flags |= OP_GIMME_REVERSE(flags);
2786     if (flags & G_KEEPERR)
2787         myop.op_flags |= OPf_SPECIAL;
2788
2789     /* fail now; otherwise we could fail after the JMPENV_PUSH but
2790      * before a PUSHEVAL, which corrupts the stack after a croak */
2791     TAINT_PROPER("eval_sv()");
2792
2793     JMPENV_PUSH(ret);
2794     switch (ret) {
2795     case 0:
2796  redo_body:
2797         CALL_BODY_EVAL((OP*)&myop);
2798         retval = PL_stack_sp - (PL_stack_base + oldmark);
2799         if (!(flags & G_KEEPERR)) {
2800             CLEAR_ERRSV();
2801         }
2802         break;
2803     case 1:
2804         STATUS_ALL_FAILURE;
2805         /* FALL THROUGH */
2806     case 2:
2807         /* my_exit() was called */
2808         PL_curstash = PL_defstash;
2809         FREETMPS;
2810         JMPENV_POP;
2811         if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
2812             Perl_croak(aTHX_ "Callback called exit");
2813         my_exit_jump();
2814         /* NOTREACHED */
2815     case 3:
2816         if (PL_restartop) {
2817             PL_op = PL_restartop;
2818             PL_restartop = 0;
2819             goto redo_body;
2820         }
2821         PL_stack_sp = PL_stack_base + oldmark;
2822         if ((flags & G_WANT) == G_ARRAY)
2823             retval = 0;
2824         else {
2825             retval = 1;
2826             *++PL_stack_sp = &PL_sv_undef;
2827         }
2828         break;
2829     }
2830
2831     JMPENV_POP;
2832     if (flags & G_DISCARD) {
2833         PL_stack_sp = PL_stack_base + oldmark;
2834         retval = 0;
2835         FREETMPS;
2836         LEAVE;
2837     }
2838     PL_op = oldop;
2839     return retval;
2840 }
2841
2842 /*
2843 =for apidoc p||eval_pv
2844
2845 Tells Perl to C<eval> the given string and return an SV* result.
2846
2847 =cut
2848 */
2849
2850 SV*
2851 Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error)
2852 {
2853     dVAR;
2854     dSP;
2855     SV* sv = newSVpv(p, 0);
2856
2857     PERL_ARGS_ASSERT_EVAL_PV;
2858
2859     eval_sv(sv, G_SCALAR);
2860     SvREFCNT_dec(sv);
2861
2862     SPAGAIN;
2863     sv = POPs;
2864     PUTBACK;
2865
2866     if (croak_on_error && SvTRUE(ERRSV)) {
2867         Perl_croak(aTHX_ "%s", SvPVx_nolen_const(ERRSV));
2868     }
2869
2870     return sv;
2871 }
2872
2873 /* Require a module. */
2874
2875 /*
2876 =head1 Embedding Functions
2877
2878 =for apidoc p||require_pv
2879
2880 Tells Perl to C<require> the file named by the string argument.  It is
2881 analogous to the Perl code C<eval "require '$file'">.  It's even
2882 implemented that way; consider using load_module instead.
2883
2884 =cut */
2885
2886 void
2887 Perl_require_pv(pTHX_ const char *pv)
2888 {
2889     dVAR;
2890     dSP;
2891     SV* sv;
2892
2893     PERL_ARGS_ASSERT_REQUIRE_PV;
2894
2895     PUSHSTACKi(PERLSI_REQUIRE);
2896     PUTBACK;
2897     sv = Perl_newSVpvf(aTHX_ "require q%c%s%c", 0, pv, 0);
2898     eval_sv(sv_2mortal(sv), G_DISCARD);
2899     SPAGAIN;
2900     POPSTACK;
2901 }
2902
2903 STATIC void
2904 S_usage(pTHX_ const char *name)         /* XXX move this out into a module ? */
2905 {
2906     /* This message really ought to be max 23 lines.
2907      * Removed -h because the user already knows that option. Others? */
2908
2909     static const char * const usage_msg[] = {
2910 "-0[octal]         specify record separator (\\0, if no argument)",
2911 "-a                autosplit mode with -n or -p (splits $_ into @F)",
2912 "-C[number/list]   enables the listed Unicode features",
2913 "-c                check syntax only (runs BEGIN and CHECK blocks)",
2914 "-d[:debugger]     run program under debugger",
2915 "-D[number/list]   set debugging flags (argument is a bit mask or alphabets)",
2916 "-e program        one line of program (several -e's allowed, omit programfile)",
2917 "-E program        like -e, but enables all optional features",
2918 "-f                don't do $sitelib/sitecustomize.pl at startup",
2919 "-F/pattern/       split() pattern for -a switch (//'s are optional)",
2920 "-i[extension]     edit <> files in place (makes backup if extension supplied)",
2921 "-Idirectory       specify @INC/#include directory (several -I's allowed)",
2922 "-l[octal]         enable line ending processing, specifies line terminator",
2923 "-[mM][-]module    execute \"use/no module...\" before executing program",
2924 "-n                assume \"while (<>) { ... }\" loop around program",
2925 "-p                assume loop like -n but print line also, like sed",
2926 "-s                enable rudimentary parsing for switches after programfile",
2927 "-S                look for programfile using PATH environment variable",
2928 "-t                enable tainting warnings",
2929 "-T                enable tainting checks",
2930 "-u                dump core after parsing program",
2931 "-U                allow unsafe operations",
2932 "-v                print version, subversion (includes VERY IMPORTANT perl info)",
2933 "-V[:variable]     print configuration summary (or a single Config.pm variable)",
2934 "-w                enable many useful warnings (RECOMMENDED)",
2935 "-W                enable all warnings",
2936 "-x[directory]     strip off text before #!perl line and perhaps cd to directory",
2937 "-X                disable all warnings",
2938 "\n",
2939 NULL
2940 };
2941     const char * const *p = usage_msg;
2942
2943     PERL_ARGS_ASSERT_USAGE;
2944
2945     PerlIO_printf(PerlIO_stdout(),
2946                   "\nUsage: %s [switches] [--] [programfile] [arguments]",
2947                   name);
2948     while (*p)
2949         PerlIO_printf(PerlIO_stdout(), "\n  %s", *p++);
2950 }
2951
2952 /* convert a string of -D options (or digits) into an int.
2953  * sets *s to point to the char after the options */
2954
2955 #ifdef DEBUGGING
2956 int
2957 Perl_get_debug_opts(pTHX_ const char **s, bool givehelp)
2958 {
2959     static const char * const usage_msgd[] = {
2960       " Debugging flag values: (see also -d)",
2961       "  p  Tokenizing and parsing (with v, displays parse stack)",
2962       "  s  Stack snapshots (with v, displays all stacks)",
2963       "  l  Context (loop) stack processing",
2964       "  t  Trace execution",
2965       "  o  Method and overloading resolution",
2966       "  c  String/numeric conversions",
2967       "  P  Print profiling info, source file input state",
2968       "  m  Memory and SV allocation",
2969       "  f  Format processing",
2970       "  r  Regular expression parsing and execution",
2971       "  x  Syntax tree dump",
2972       "  u  Tainting checks",
2973       "  H  Hash dump -- usurps values()",
2974       "  X  Scratchpad allocation",
2975       "  D  Cleaning up",
2976       "  T  Tokenising",
2977       "  R  Include reference counts of dumped variables (eg when using -Ds)",
2978       "  J  Do not s,t,P-debug (Jump over) opcodes within package DB",
2979       "  v  Verbose: use in conjunction with other flags",
2980       "  C  Copy On Write",
2981       "  A  Consistency checks on internal structures",
2982       "  q  quiet - currently only suppresses the 'EXECUTING' message",
2983       NULL
2984     };
2985     int i = 0;
2986
2987     PERL_ARGS_ASSERT_GET_DEBUG_OPTS;
2988
2989     if (isALPHA(**s)) {
2990         /* if adding extra options, remember to update DEBUG_MASK */
2991         static const char debopts[] = "psltocPmfrxuUHXDSTRJvCAq";
2992
2993         for (; isALNUM(**s); (*s)++) {
2994             const char * const d = strchr(debopts,**s);
2995             if (d)
2996                 i |= 1 << (d - debopts);
2997             else if (ckWARN_d(WARN_DEBUGGING))
2998                 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
2999                     "invalid option -D%c, use -D'' to see choices\n", **s);
3000         }
3001     }
3002     else if (isDIGIT(**s)) {
3003         i = atoi(*s);
3004         for (; isALNUM(**s); (*s)++) ;
3005     }
3006     else if (givehelp) {
3007       const char *const *p = usage_msgd;
3008       while (*p) PerlIO_printf(PerlIO_stdout(), "%s\n", *p++);
3009     }
3010 #  ifdef EBCDIC
3011     if ((i & DEBUG_p_FLAG) && ckWARN_d(WARN_DEBUGGING))
3012         Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
3013                 "-Dp not implemented on this platform\n");
3014 #  endif
3015     return i;
3016 }
3017 #endif
3018
3019 /* This routine handles any switches that can be given during run */
3020
3021 const char *
3022 Perl_moreswitches(pTHX_ const char *s)
3023 {
3024     dVAR;
3025     UV rschar;
3026     const char option = *s; /* used to remember option in -m/-M code */
3027
3028     PERL_ARGS_ASSERT_MORESWITCHES;
3029
3030     switch (*s) {
3031     case '0':
3032     {
3033          I32 flags = 0;
3034          STRLEN numlen;
3035
3036          SvREFCNT_dec(PL_rs);
3037          if (s[1] == 'x' && s[2]) {
3038               const char *e = s+=2;
3039               U8 *tmps;
3040
3041               while (*e)
3042                 e++;
3043               numlen = e - s;
3044               flags = PERL_SCAN_SILENT_ILLDIGIT;
3045               rschar = (U32)grok_hex(s, &numlen, &flags, NULL);
3046               if (s + numlen < e) {
3047                    rschar = 0; /* Grandfather -0xFOO as -0 -xFOO. */
3048                    numlen = 0;
3049                    s--;
3050               }
3051               PL_rs = newSVpvs("");
3052               SvGROW(PL_rs, (STRLEN)(UNISKIP(rschar) + 1));
3053               tmps = (U8*)SvPVX(PL_rs);
3054               uvchr_to_utf8(tmps, rschar);
3055               SvCUR_set(PL_rs, UNISKIP(rschar));
3056               SvUTF8_on(PL_rs);
3057          }
3058          else {
3059               numlen = 4;
3060               rschar = (U32)grok_oct(s, &numlen, &flags, NULL);
3061               if (rschar & ~((U8)~0))
3062                    PL_rs = &PL_sv_undef;
3063               else if (!rschar && numlen >= 2)
3064                    PL_rs = newSVpvs("");
3065               else {
3066                    char ch = (char)rschar;
3067                    PL_rs = newSVpvn(&ch, 1);
3068               }
3069          }
3070          sv_setsv(get_sv("/", TRUE), PL_rs);
3071          return s + numlen;
3072     }
3073     case 'C':
3074         s++;
3075         PL_unicode = parse_unicode_opts( (const char **)&s );
3076         if (PL_unicode & PERL_UNICODE_UTF8CACHEASSERT_FLAG)
3077             PL_utf8cache = -1;
3078         return s;
3079     case 'F':
3080         PL_minus_F = TRUE;
3081         PL_splitstr = ++s;
3082         while (*s && !isSPACE(*s)) ++s;
3083         PL_splitstr = savepvn(PL_splitstr, s - PL_splitstr);
3084         return s;
3085     case 'a':
3086         PL_minus_a = TRUE;
3087         s++;
3088         return s;
3089     case 'c':
3090         PL_minus_c = TRUE;
3091         s++;
3092         return s;
3093     case 'd':
3094         forbid_setid('d', FALSE);
3095         s++;
3096
3097         /* -dt indicates to the debugger that threads will be used */
3098         if (*s == 't' && !isALNUM(s[1])) {
3099             ++s;
3100             my_setenv("PERL5DB_THREADED", "1");
3101         }
3102
3103         /* The following permits -d:Mod to accepts arguments following an =
3104            in the fashion that -MSome::Mod does. */
3105         if (*s == ':' || *s == '=') {
3106             const char *start = ++s;
3107             const char *const end = s + strlen(s);
3108             SV * const sv = newSVpvs("use Devel::");
3109
3110             /* We now allow -d:Module=Foo,Bar */
3111             while(isALNUM(*s) || *s==':') ++s;
3112             if (*s != '=')
3113                 sv_catpvn(sv, start, end - start);
3114             else {
3115                 sv_catpvn(sv, start, s-start);
3116                 /* Don't use NUL as q// delimiter here, this string goes in the
3117                  * environment. */
3118                 Perl_sv_catpvf(aTHX_ sv, " split(/,/,q{%s});", ++s);
3119             }
3120             s = end;
3121             my_setenv("PERL5DB", SvPV_nolen_const(sv));
3122             SvREFCNT_dec(sv);
3123         }
3124         if (!PL_perldb) {
3125             PL_perldb = PERLDB_ALL;
3126             init_debugger();
3127         }
3128         return s;
3129     case 'D':
3130     {   
3131 #ifdef DEBUGGING
3132         forbid_setid('D', FALSE);
3133         s++;
3134         PL_debug = get_debug_opts( (const char **)&s, 1) | DEBUG_TOP_FLAG;
3135 #else /* !DEBUGGING */
3136         if (ckWARN_d(WARN_DEBUGGING))
3137             Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
3138                    "Recompile perl with -DDEBUGGING to use -D switch (did you mean -d ?)\n");
3139         for (s++; isALNUM(*s); s++) ;
3140 #endif
3141         return s;
3142     }   
3143     case 'h':
3144         usage(PL_origargv[0]);
3145         my_exit(0);
3146     case 'i':
3147         Safefree(PL_inplace);
3148 #if defined(__CYGWIN__) /* do backup extension automagically */
3149         if (*(s+1) == '\0') {
3150         PL_inplace = savepvs(".bak");
3151         return s+1;
3152         }
3153 #endif /* __CYGWIN__ */
3154         {
3155             const char * const start = ++s;
3156             while (*s && !isSPACE(*s))
3157                 ++s;
3158
3159             PL_inplace = savepvn(start, s - start);
3160         }
3161         if (*s) {
3162             ++s;
3163             if (*s == '-')      /* Additional switches on #! line. */
3164                 s++;
3165         }
3166         return s;
3167     case 'I':   /* -I handled both here and in parse_body() */
3168         forbid_setid('I', FALSE);
3169         ++s;
3170         while (*s && isSPACE(*s))
3171             ++s;
3172         if (*s) {
3173             const char *e, *p;
3174             p = s;
3175             /* ignore trailing spaces (possibly followed by other switches) */
3176             do {
3177                 for (e = p; *e && !isSPACE(*e); e++) ;
3178                 p = e;
3179                 while (isSPACE(*p))
3180                     p++;
3181             } while (*p && *p != '-');
3182             e = savepvn(s, e-s);
3183             incpush(e, TRUE, TRUE, FALSE, FALSE, TRUE);
3184             Safefree(e);
3185             s = p;
3186             if (*s == '-')
3187                 s++;
3188         }
3189         else
3190             Perl_croak(aTHX_ "No directory specified for -I");
3191         return s;
3192     case 'l':
3193         PL_minus_l = TRUE;
3194         s++;
3195         if (PL_ors_sv) {
3196             SvREFCNT_dec(PL_ors_sv);
3197             PL_ors_sv = NULL;
3198         }
3199         if (isDIGIT(*s)) {
3200             I32 flags = 0;
3201             STRLEN numlen;
3202             PL_ors_sv = newSVpvs("\n");
3203             numlen = 3 + (*s == '0');
3204             *SvPVX(PL_ors_sv) = (char)grok_oct(s, &numlen, &flags, NULL);
3205             s += numlen;
3206         }
3207         else {
3208             if (RsPARA(PL_rs)) {
3209                 PL_ors_sv = newSVpvs("\n\n");
3210             }
3211             else {
3212                 PL_ors_sv = newSVsv(PL_rs);
3213             }
3214         }
3215         return s;
3216     case 'M':
3217         forbid_setid('M', FALSE);       /* XXX ? */
3218         /* FALL THROUGH */
3219     case 'm':
3220         forbid_setid('m', FALSE);       /* XXX ? */
3221         if (*++s) {
3222             const char *start;
3223             const char *end;
3224             SV *sv;
3225             const char *use = "use ";
3226             bool colon = FALSE;
3227             /* -M-foo == 'no foo'       */
3228             /* Leading space on " no " is deliberate, to make both
3229                possibilities the same length.  */
3230             if (*s == '-') { use = " no "; ++s; }
3231             sv = newSVpvn(use,4);
3232             start = s;
3233             /* We allow -M'Module qw(Foo Bar)'  */
3234             while(isALNUM(*s) || *s==':') {
3235                 if( *s++ == ':' ) {
3236                     if( *s == ':' ) 
3237                         s++;
3238                     else
3239                         colon = TRUE;
3240                 }
3241             }
3242             if (s == start)
3243                 Perl_croak(aTHX_ "Module name required with -%c option",
3244                                     option);
3245             if (colon) 
3246                 Perl_croak(aTHX_ "Invalid module name %.*s with -%c option: "
3247                                     "contains single ':'",
3248                                     (int)(s - start), start, option);
3249             end = s + strlen(s);
3250             if (*s != '=') {
3251                 sv_catpvn(sv, start, end - start);
3252                 if (option == 'm') {
3253                     if (*s != '\0')
3254                         Perl_croak(aTHX_ "Can't use '%c' after -mname", *s);
3255                     sv_catpvs( sv, " ()");
3256                 }
3257             } else {
3258                 sv_catpvn(sv, start, s-start);
3259                 /* Use NUL as q''-delimiter.  */
3260                 sv_catpvs(sv, " split(/,/,q\0");
3261                 ++s;
3262                 sv_catpvn(sv, s, end - s);
3263                 sv_catpvs(sv,  "\0)");
3264             }
3265             s = end;
3266             Perl_av_create_and_push(aTHX_ &PL_preambleav, sv);
3267         }
3268         else
3269             Perl_croak(aTHX_ "Missing argument to -%c", option);
3270         return s;
3271     case 'n':
3272         PL_minus_n = TRUE;
3273         s++;
3274         return s;
3275     case 'p':
3276         PL_minus_p = TRUE;
3277         s++;
3278         return s;
3279     case 's':
3280         forbid_setid('s', FALSE);
3281         PL_doswitches = TRUE;
3282         s++;
3283         return s;
3284     case 't':
3285         if (!PL_tainting)
3286             TOO_LATE_FOR('t');
3287         s++;
3288         return s;
3289     case 'T':
3290         if (!PL_tainting)
3291             TOO_LATE_FOR('T');
3292         s++;
3293         return s;
3294     case 'u':
3295 #ifdef MACOS_TRADITIONAL
3296         Perl_croak(aTHX_ "Believe me, you don't want to use \"-u\" on a Macintosh");
3297 #endif
3298         PL_do_undump = TRUE;
3299         s++;
3300         return s;
3301     case 'U':
3302         PL_unsafe = TRUE;
3303         s++;
3304         return s;
3305     case 'v':
3306         if (!sv_derived_from(PL_patchlevel, "version"))
3307             upg_version(PL_patchlevel, TRUE);
3308 #if !defined(DGUX)
3309         {
3310             SV* level= vstringify(PL_patchlevel);
3311 #ifdef PERL_PATCHNUM
3312             SV* num= newSVpvn(PERL_PATCHNUM,sizeof(PERL_PATCHNUM)-1);
3313 #ifdef PERL_GIT_UNCOMMITTED_CHANGES
3314             sv_catpvs(num, "*");
3315 #endif
3316
3317             if (sv_len(num)>=sv_len(level) && strnEQ(SvPV_nolen(num),SvPV_nolen(level),sv_len(level))) {
3318                 SvREFCNT_dec(level);
3319                 level= num;
3320             } else {
3321                 Perl_sv_catpvf(aTHX_ level, " (%"SVf")", num);
3322                 SvREFCNT_dec(num);
3323             }
3324  #endif
3325             PerlIO_printf(PerlIO_stdout(),
3326                 "\nThis is perl, %"SVf
3327                 " built for %s",
3328                 level,
3329                 ARCHNAME);
3330             SvREFCNT_dec(level);
3331         }
3332 #else /* DGUX */
3333 /* Adjust verbose output as in the perl that ships with the DG/UX OS from EMC */
3334         PerlIO_printf(PerlIO_stdout(),
3335                 Perl_form(aTHX_ "\nThis is perl, %"SVf"\n",
3336                     SVfARG(vstringify(PL_patchlevel))));
3337         PerlIO_printf(PerlIO_stdout(),
3338                         Perl_form(aTHX_ "        built under %s at %s %s\n",
3339                                         OSNAME, __DATE__, __TIME__));
3340         PerlIO_printf(PerlIO_stdout(),
3341                         Perl_form(aTHX_ "        OS Specific Release: %s\n",
3342                                         OSVERS));
3343 #endif /* !DGUX */
3344 #if defined(LOCAL_PATCH_COUNT)
3345         if (LOCAL_PATCH_COUNT > 0)
3346             PerlIO_printf(PerlIO_stdout(),
3347                           "\n(with %d registered patch%s, "
3348                           "see perl -V for more detail)",
3349                           LOCAL_PATCH_COUNT,
3350                           (LOCAL_PATCH_COUNT!=1) ? "es" : "");
3351 #endif
3352
3353         PerlIO_printf(PerlIO_stdout(),
3354                       "\n\nCopyright 1987-2009, Larry Wall\n");
3355 #ifdef MACOS_TRADITIONAL
3356         PerlIO_printf(PerlIO_stdout(),
3357                       "\nMac OS port Copyright 1991-2002, Matthias Neeracher;\n"
3358                       "maintained by Chris Nandor\n");
3359 #endif
3360 #ifdef MSDOS
3361         PerlIO_printf(PerlIO_stdout(),
3362                       "\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
3363 #endif
3364 #ifdef DJGPP
3365         PerlIO_printf(PerlIO_stdout(),
3366                       "djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n"
3367                       "djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n");
3368 #endif
3369 #ifdef OS2
3370         PerlIO_printf(PerlIO_stdout(),
3371                       "\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
3372                       "Version 5 port Copyright (c) 1994-2002, Andreas Kaiser, Ilya Zakharevich\n");
3373 #endif
3374 #ifdef atarist
3375         PerlIO_printf(PerlIO_stdout(),
3376                       "atariST series port, ++jrb  bammi@cadence.com\n");
3377 #endif
3378 #ifdef __BEOS__
3379         PerlIO_printf(PerlIO_stdout(),
3380                       "BeOS port Copyright Tom Spindler, 1997-1999\n");
3381 #endif
3382 #ifdef MPE
3383         PerlIO_printf(PerlIO_stdout(),
3384                       "MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-2003\n");
3385 #endif
3386 #ifdef OEMVS
3387         PerlIO_printf(PerlIO_stdout(),
3388                       "MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
3389 #endif
3390 #ifdef __VOS__
3391         PerlIO_printf(PerlIO_stdout(),
3392                       "Stratus VOS port by Paul.Green@stratus.com, 1997-2002\n");
3393 #endif
3394 #ifdef __OPEN_VM
3395         PerlIO_printf(PerlIO_stdout(),
3396                       "VM/ESA port by Neale Ferguson, 1998-1999\n");
3397 #endif
3398 #ifdef POSIX_BC
3399         PerlIO_printf(PerlIO_stdout(),
3400                       "BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
3401 #endif
3402 #ifdef __MINT__
3403         PerlIO_printf(PerlIO_stdout(),
3404                       "MiNT port by Guido Flohr, 1997-1999\n");
3405 #endif
3406 #ifdef EPOC
3407         PerlIO_printf(PerlIO_stdout(),
3408                       "EPOC port by Olaf Flebbe, 1999-2002\n");
3409 #endif
3410 #ifdef UNDER_CE
3411         PerlIO_printf(PerlIO_stdout(),"WINCE port by Rainer Keuchel, 2001-2002\n");
3412         PerlIO_printf(PerlIO_stdout(),"Built on " __DATE__ " " __TIME__ "\n\n");
3413         wce_hitreturn();
3414 #endif
3415 #ifdef __SYMBIAN32__
3416         PerlIO_printf(PerlIO_stdout(),
3417                       "Symbian port by Nokia, 2004-2005\n");
3418 #endif
3419 #ifdef BINARY_BUILD_NOTICE
3420         BINARY_BUILD_NOTICE;
3421 #endif
3422         PerlIO_printf(PerlIO_stdout(),
3423                       "\n\
3424 Perl may be copied only under the terms of either the Artistic License or the\n\
3425 GNU General Public License, which may be found in the Perl 5 source kit.\n\n\
3426 Complete documentation for Perl, including FAQ lists, should be found on\n\
3427 this system using \"man perl\" or \"perldoc perl\".  If you have access to the\n\
3428 Internet, point your browser at http://www.perl.org/, the Perl Home Page.\n\n");
3429         my_exit(0);
3430     case 'w':
3431         if (! (PL_dowarn & G_WARN_ALL_MASK)) {
3432             PL_dowarn |= G_WARN_ON;
3433         }
3434         s++;
3435         return s;
3436     case 'W':
3437         PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
3438         if (!specialWARN(PL_compiling.cop_warnings))
3439             PerlMemShared_free(PL_compiling.cop_warnings);
3440         PL_compiling.cop_warnings = pWARN_ALL ;
3441         s++;
3442         return s;
3443     case 'X':
3444         PL_dowarn = G_WARN_ALL_OFF;
3445         if (!specialWARN(PL_compiling.cop_warnings))
3446             PerlMemShared_free(PL_compiling.cop_warnings);
3447         PL_compiling.cop_warnings = pWARN_NONE ;
3448         s++;
3449         return s;
3450     case '*':
3451     case ' ':
3452         while( *s == ' ' )
3453           ++s;
3454         if (s[0] == '-')        /* Additional switches on #! line. */
3455             return s+1;
3456         break;
3457     case '-':
3458     case 0:
3459 #if defined(WIN32) || !defined(PERL_STRICT_CR)
3460     case '\r':
3461 #endif
3462     case '\n':
3463     case '\t':
3464         break;
3465 #ifdef ALTERNATE_SHEBANG
3466     case 'S':                   /* OS/2 needs -S on "extproc" line. */
3467         break;
3468 #endif
3469     default:
3470         Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s);
3471     }
3472     return NULL;
3473 }
3474
3475 /* compliments of Tom Christiansen */
3476
3477 /* unexec() can be found in the Gnu emacs distribution */
3478 /* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
3479
3480 void
3481 Perl_my_unexec(pTHX)
3482 {
3483     PERL_UNUSED_CONTEXT;
3484 #ifdef UNEXEC
3485     SV *    prog = newSVpv(BIN_EXP, 0);
3486     SV *    file = newSVpv(PL_origfilename, 0);
3487     int    status = 1;
3488     extern int etext;
3489
3490     sv_catpvs(prog, "/perl");
3491     sv_catpvs(file, ".perldump");
3492
3493     unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
3494     /* unexec prints msg to stderr in case of failure */
3495     PerlProc_exit(status);
3496 #else
3497 #  ifdef VMS
3498 #    include <lib$routines.h>
3499      lib$signal(SS$_DEBUG);  /* ssdef.h #included from vmsish.h */
3500 #  elif defined(WIN32) || defined(__CYGWIN__)
3501     Perl_croak(aTHX_ "dump is not supported");
3502 #  else
3503     ABORT();            /* for use with undump */
3504 #  endif
3505 #endif
3506 }
3507
3508 /* initialize curinterp */
3509 STATIC void
3510 S_init_interp(pTHX)
3511 {
3512     dVAR;
3513 #ifdef MULTIPLICITY
3514 #  define PERLVAR(var,type)
3515 #  define PERLVARA(var,n,type)
3516 #  if defined(PERL_IMPLICIT_CONTEXT)
3517 #    define PERLVARI(var,type,init)             aTHX->var = init;
3518 #    define PERLVARIC(var,type,init)    aTHX->var = init;
3519 #  else
3520 #    define PERLVARI(var,type,init)     PERL_GET_INTERP->var = init;
3521 #    define PERLVARIC(var,type,init)    PERL_GET_INTERP->var = init;
3522 #  endif
3523 #  include "intrpvar.h"
3524 #  undef PERLVAR
3525 #  undef PERLVARA
3526 #  undef PERLVARI
3527 #  undef PERLVARIC
3528 #else
3529 #  define PERLVAR(var,type)
3530 #  define PERLVARA(var,n,type)
3531 #  define PERLVARI(var,type,init)       PL_##var = init;
3532 #  define PERLVARIC(var,type,init)      PL_##var = init;
3533 #  include "intrpvar.h"
3534 #  undef PERLVAR
3535 #  undef PERLVARA
3536 #  undef PERLVARI
3537 #  undef PERLVARIC
3538 #endif
3539
3540     /* As these are inside a structure, PERLVARI isn't capable of initialising
3541        them  */
3542     PL_reg_oldcurpm = PL_reg_curpm = NULL;
3543     PL_reg_poscache = PL_reg_starttry = NULL;
3544 }
3545
3546 STATIC void
3547 S_init_main_stash(pTHX)
3548 {
3549     dVAR;
3550     GV *gv;
3551
3552     PL_curstash = PL_defstash = newHV();
3553     /* We know that the string "main" will be in the global shared string
3554        table, so it's a small saving to use it rather than allocate another
3555        8 bytes.  */
3556     PL_curstname = newSVpvs_share("main");
3557     gv = gv_fetchpvs("main::", GV_ADD|GV_NOTQUAL, SVt_PVHV);
3558     /* If we hadn't caused another reference to "main" to be in the shared
3559        string table above, then it would be worth reordering these two,
3560        because otherwise all we do is delete "main" from it as a consequence
3561        of the SvREFCNT_dec, only to add it again with hv_name_set */
3562     SvREFCNT_dec(GvHV(gv));
3563     hv_name_set(PL_defstash, "main", 4, 0);
3564     GvHV(gv) = MUTABLE_HV(SvREFCNT_inc_simple(PL_defstash));
3565     SvREADONLY_on(gv);
3566     PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpvs("INC", GV_ADD|GV_NOTQUAL,
3567                                              SVt_PVAV)));
3568     SvREFCNT_inc_simple_void(PL_incgv); /* Don't allow it to be freed */
3569     GvMULTI_on(PL_incgv);
3570     PL_hintgv = gv_fetchpvs("\010", GV_ADD|GV_NOTQUAL, SVt_PV); /* ^H */
3571     GvMULTI_on(PL_hintgv);
3572     PL_defgv = gv_fetchpvs("_", GV_ADD|GV_NOTQUAL, SVt_PVAV);
3573     SvREFCNT_inc_simple_void(PL_defgv);
3574     PL_errgv = gv_HVadd(gv_fetchpvs("@", GV_ADD|GV_NOTQUAL, SVt_PV));
3575     SvREFCNT_inc_simple_void(PL_errgv);
3576     GvMULTI_on(PL_errgv);
3577     PL_replgv = gv_fetchpvs("\022", GV_ADD|GV_NOTQUAL, SVt_PV); /* ^R */
3578     GvMULTI_on(PL_replgv);
3579     (void)Perl_form(aTHX_ "%240s","");  /* Preallocate temp - for immediate signals. */
3580 #ifdef PERL_DONT_CREATE_GVSV
3581     gv_SVadd(PL_errgv);
3582 #endif
3583     sv_grow(ERRSV, 240);        /* Preallocate - for immediate signals. */
3584     CLEAR_ERRSV();
3585     PL_curstash = PL_defstash;
3586     CopSTASH_set(&PL_compiling, PL_defstash);
3587     PL_debstash = GvHV(gv_fetchpvs("DB::", GV_ADDMULTI, SVt_PVHV));
3588     PL_globalstash = GvHV(gv_fetchpvs("CORE::GLOBAL::", GV_ADDMULTI,
3589                                       SVt_PVHV));
3590     /* We must init $/ before switches are processed. */
3591     sv_setpvs(get_sv("/", TRUE), "\n");
3592 }
3593
3594 STATIC int
3595 S_open_script(pTHX_ const char *scriptname, bool dosearch,
3596               bool *suidscript, PerlIO **rsfpp)
3597 {
3598     int fdscript = -1;
3599     dVAR;
3600
3601     PERL_ARGS_ASSERT_OPEN_SCRIPT;
3602
3603     if (PL_e_script) {
3604         PL_origfilename = (PL_minus_E ? savepvs("-E") : savepvs( "-e" ));
3605     }
3606     else {
3607         /* if find_script() returns, it returns a malloc()-ed value */
3608         scriptname = PL_origfilename = find_script(scriptname, dosearch, NULL, 1);
3609
3610         if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
3611             const char *s = scriptname + 8;
3612             fdscript = atoi(s);
3613             while (isDIGIT(*s))
3614                 s++;
3615             if (*s) {
3616                 /* PSz 18 Feb 04
3617                  * Tell apart "normal" usage of fdscript, e.g.
3618                  * with bash on FreeBSD:
3619                  *   perl <( echo '#!perl -DA'; echo 'print "$0\n"')
3620                  * from usage in suidperl.
3621                  * Does any "normal" usage leave garbage after the number???
3622                  * Is it a mistake to use a similar /dev/fd/ construct for
3623                  * suidperl?
3624                  */
3625                 *suidscript = TRUE;
3626                 /* PSz 20 Feb 04  
3627                  * Be supersafe and do some sanity-checks.
3628                  * Still, can we be sure we got the right thing?
3629                  */
3630                 if (*s != '/') {
3631                     Perl_croak(aTHX_ "Wrong syntax (suid) fd script name \"%s\"\n", s);
3632                 }
3633                 if (! *(s+1)) {
3634                     Perl_croak(aTHX_ "Missing (suid) fd script name\n");
3635                 }
3636                 scriptname = savepv(s + 1);
3637                 Safefree(PL_origfilename);
3638                 PL_origfilename = (char *)scriptname;
3639             }
3640         }
3641     }
3642
3643     CopFILE_free(PL_curcop);
3644     CopFILE_set(PL_curcop, PL_origfilename);
3645     if (*PL_origfilename == '-' && PL_origfilename[1] == '\0')
3646         scriptname = (char *)"";
3647     if (fdscript >= 0) {
3648         *rsfpp = PerlIO_fdopen(fdscript,PERL_SCRIPT_MODE);
3649 #       if defined(HAS_FCNTL) && defined(F_SETFD)
3650             if (*rsfpp)
3651                 /* ensure close-on-exec */
3652                 fcntl(PerlIO_fileno(*rsfpp),F_SETFD,1);
3653 #       endif
3654     }
3655 #ifdef IAMSUID
3656     else {
3657         Perl_croak(aTHX_ "sperl needs fd script\n"
3658                    "You should not call sperl directly; do you need to "
3659                    "change a #! line\nfrom sperl to perl?\n");
3660
3661 /* PSz 11 Nov 03
3662  * Do not open (or do other fancy stuff) while setuid.
3663  * Perl does the open, and hands script to suidperl on a fd;
3664  * suidperl only does some checks, sets up UIDs and re-execs
3665  * perl with that fd as it has always done.
3666  */
3667     }
3668     if (!*suidscript) {
3669         Perl_croak(aTHX_ "suidperl needs (suid) fd script\n");
3670     }
3671 #else /* IAMSUID */
3672     else if (!*scriptname) {
3673         forbid_setid(0, *suidscript);
3674         *rsfpp = PerlIO_stdin();
3675     }
3676     else {
3677 #ifdef FAKE_BIT_BUCKET
3678         /* This hack allows one not to have /dev/null (or BIT_BUCKET as it
3679          * is called) and still have the "-e" work.  (Believe it or not,
3680          * a /dev/null is required for the "-e" to work because source
3681          * filter magic is used to implement it. ) This is *not* a general
3682          * replacement for a /dev/null.  What we do here is create a temp
3683          * file (an empty file), open up that as the script, and then
3684          * immediately close and unlink it.  Close enough for jazz. */ 
3685 #define FAKE_BIT_BUCKET_PREFIX "/tmp/perlnull-"
3686 #define FAKE_BIT_BUCKET_SUFFIX "XXXXXXXX"
3687 #define FAKE_BIT_BUCKET_TEMPLATE FAKE_BIT_BUCKET_PREFIX FAKE_BIT_BUCKET_SUFFIX
3688         char tmpname[sizeof(FAKE_BIT_BUCKET_TEMPLATE)] = {
3689             FAKE_BIT_BUCKET_TEMPLATE
3690         };
3691         const char * const err = "Failed to create a fake bit bucket";
3692         if (strEQ(scriptname, BIT_BUCKET)) {
3693 #ifdef HAS_MKSTEMP /* Hopefully mkstemp() is safe here. */
3694             int tmpfd = mkstemp(tmpname);
3695             if (tmpfd > -1) {
3696                 scriptname = tmpname;
3697                 close(tmpfd);
3698             } else
3699                 Perl_croak(aTHX_ err);
3700 #else
3701 #  ifdef HAS_MKTEMP
3702             scriptname = mktemp(tmpname);
3703             if (!scriptname)
3704                 Perl_croak(aTHX_ err);
3705 #  endif
3706 #endif
3707         }
3708 #endif
3709         *rsfpp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
3710 #ifdef FAKE_BIT_BUCKET
3711         if (memEQ(scriptname, FAKE_BIT_BUCKET_PREFIX,
3712                   sizeof(FAKE_BIT_BUCKET_PREFIX) - 1)
3713             && strlen(scriptname) == sizeof(tmpname) - 1) {
3714             unlink(scriptname);
3715         }
3716         scriptname = BIT_BUCKET;
3717 #endif
3718 #       if defined(HAS_FCNTL) && defined(F_SETFD)
3719             if (*rsfpp)
3720                 /* ensure close-on-exec */
3721                 fcntl(PerlIO_fileno(*rsfpp),F_SETFD,1);
3722 #       endif
3723     }
3724 #endif /* IAMSUID */
3725     if (!*rsfpp) {
3726         /* PSz 16 Sep 03  Keep neat error message */
3727         if (PL_e_script)
3728             Perl_croak(aTHX_ "Can't open "BIT_BUCKET": %s\n", Strerror(errno));
3729         else
3730             Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
3731                     CopFILE(PL_curcop), Strerror(errno));
3732     }
3733     return fdscript;
3734 }
3735
3736 /* Mention
3737  * I_SYSSTATVFS HAS_FSTATVFS
3738  * I_SYSMOUNT
3739  * I_STATFS     HAS_FSTATFS     HAS_GETFSSTAT
3740  * I_MNTENT     HAS_GETMNTENT   HAS_HASMNTOPT
3741  * here so that metaconfig picks them up. */
3742
3743 #ifdef IAMSUID
3744 STATIC int
3745 S_fd_on_nosuid_fs(pTHX_ int fd)
3746 {
3747 /* PSz 27 Feb 04
3748  * We used to do this as "plain" user (after swapping UIDs with setreuid);
3749  * but is needed also on machines without setreuid.
3750  * Seems safe enough to run as root.
3751  */
3752     int check_okay = 0; /* able to do all the required sys/libcalls */
3753     int on_nosuid  = 0; /* the fd is on a nosuid fs */
3754     /* PSz 12 Nov 03
3755      * Need to check noexec also: nosuid might not be set, the average
3756      * sysadmin would say that nosuid is irrelevant once he sets noexec.
3757      */
3758     int on_noexec  = 0; /* the fd is on a noexec fs */
3759
3760 /*
3761  * Preferred order: fstatvfs(), fstatfs(), ustat()+getmnt(), getmntent().
3762  * fstatvfs() is UNIX98.
3763  * fstatfs() is 4.3 BSD.
3764  * ustat()+getmnt() is pre-4.3 BSD.
3765  * getmntent() is O(number-of-mounted-filesystems) and can hang on
3766  * an irrelevant filesystem while trying to reach the right one.
3767  */
3768
3769 #undef FD_ON_NOSUID_CHECK_OKAY  /* found the syscalls to do the check? */
3770
3771 #   if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
3772         defined(HAS_FSTATVFS)
3773 #   define FD_ON_NOSUID_CHECK_OKAY
3774     struct statvfs stfs;
3775
3776     check_okay = fstatvfs(fd, &stfs) == 0;
3777     on_nosuid  = check_okay && (stfs.f_flag  & ST_NOSUID);
3778 #ifdef ST_NOEXEC
3779     /* ST_NOEXEC certainly absent on AIX 5.1, and doesn't seem to be documented
3780        on platforms where it is present.  */
3781     on_noexec  = check_okay && (stfs.f_flag  & ST_NOEXEC);
3782 #endif
3783 #   endif /* fstatvfs */
3784
3785 #   if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
3786         defined(PERL_MOUNT_NOSUID)      && \
3787         defined(PERL_MOUNT_NOEXEC)      && \
3788         defined(HAS_FSTATFS)            && \
3789         defined(HAS_STRUCT_STATFS)      && \
3790         defined(HAS_STRUCT_STATFS_F_FLAGS)
3791 #   define FD_ON_NOSUID_CHECK_OKAY
3792     struct statfs  stfs;
3793
3794     check_okay = fstatfs(fd, &stfs)  == 0;
3795     on_nosuid  = check_okay && (stfs.f_flags & PERL_MOUNT_NOSUID);
3796     on_noexec  = check_okay && (stfs.f_flags & PERL_MOUNT_NOEXEC);
3797 #   endif /* fstatfs */
3798
3799 #   if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
3800         defined(PERL_MOUNT_NOSUID)      && \
3801         defined(PERL_MOUNT_NOEXEC)      && \
3802         defined(HAS_FSTAT)              && \
3803         defined(HAS_USTAT)              && \
3804         defined(HAS_GETMNT)             && \
3805         defined(HAS_STRUCT_FS_DATA)     && \
3806         defined(NOSTAT_ONE)
3807 #   define FD_ON_NOSUID_CHECK_OKAY
3808     Stat_t fdst;
3809
3810     if (fstat(fd, &fdst) == 0) {
3811         struct ustat us;
3812         if (ustat(fdst.st_dev, &us) == 0) {
3813             struct fs_data fsd;
3814             /* NOSTAT_ONE here because we're not examining fields which
3815              * vary between that case and STAT_ONE. */
3816             if (getmnt((int*)0, &fsd, (int)0, NOSTAT_ONE, us.f_fname) == 0) {
3817                 size_t cmplen = sizeof(us.f_fname);
3818                 if (sizeof(fsd.fd_req.path) < cmplen)
3819                     cmplen = sizeof(fsd.fd_req.path);
3820                 if (strnEQ(fsd.fd_req.path, us.f_fname, cmplen) &&
3821                     fdst.st_dev == fsd.fd_req.dev) {
3822                     check_okay = 1;
3823                     on_nosuid = fsd.fd_req.flags & PERL_MOUNT_NOSUID;
3824                     on_noexec = fsd.fd_req.flags & PERL_MOUNT_NOEXEC;
3825                 }
3826             }
3827         }
3828     }
3829 #   endif /* fstat+ustat+getmnt */
3830
3831 #   if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
3832         defined(HAS_GETMNTENT)          && \
3833         defined(HAS_HASMNTOPT)          && \
3834         defined(MNTOPT_NOSUID)          && \
3835         defined(MNTOPT_NOEXEC)
3836 #   define FD_ON_NOSUID_CHECK_OKAY
3837     FILE                *mtab = fopen("/etc/mtab", "r");
3838     struct mntent       *entry;
3839     Stat_t              stb, fsb;
3840
3841     if (mtab && (fstat(fd, &stb) == 0)) {
3842         while (entry = getmntent(mtab)) {
3843             if (stat(entry->mnt_dir, &fsb) == 0
3844                 && fsb.st_dev == stb.st_dev)
3845             {
3846                 /* found the filesystem */
3847                 check_okay = 1;
3848                 if (hasmntopt(entry, MNTOPT_NOSUID))
3849                     on_nosuid = 1;
3850                 if (hasmntopt(entry, MNTOPT_NOEXEC))
3851                     on_noexec = 1;
3852                 break;
3853             } /* A single fs may well fail its stat(). */
3854         }
3855     }
3856     if (mtab)
3857         fclose(mtab);
3858 #   endif /* getmntent+hasmntopt */
3859
3860     if (!check_okay)
3861         Perl_croak(aTHX_ "Can't check filesystem of script \"%s\" for nosuid/noexec", PL_origfilename);
3862     if (on_nosuid)
3863         Perl_croak(aTHX_ "Setuid script \"%s\" on nosuid filesystem", PL_origfilename);
3864     if (on_noexec)
3865         Perl_croak(aTHX_ "Setuid script \"%s\" on noexec filesystem", PL_origfilename);
3866     return ((!check_okay) || on_nosuid || on_noexec);
3867 }
3868 #endif /* IAMSUID */
3869
3870 #ifdef DOSUID
3871 STATIC void
3872 S_validate_suid(pTHX_ const char *validarg,
3873 #  ifndef IAMSUID
3874                 const char *scriptname,
3875 #  endif
3876                 int fdscript,
3877 #  ifdef IAMSUID
3878                 bool suidscript,
3879 #  endif
3880                 SV *linestr_sv, PerlIO *rsfp)
3881 {
3882     dVAR;
3883     const char *s, *s2;
3884
3885     PERL_ARGS_ASSERT_VALIDATE_SUID;
3886
3887     /* do we need to emulate setuid on scripts? */
3888
3889     /* This code is for those BSD systems that have setuid #! scripts disabled
3890      * in the kernel because of a security problem.  Merely defining DOSUID
3891      * in perl will not fix that problem, but if you have disabled setuid
3892      * scripts in the kernel, this will attempt to emulate setuid and setgid
3893      * on scripts that have those now-otherwise-useless bits set.  The setuid
3894      * root version must be called suidperl or sperlN.NNN.  If regular perl
3895      * discovers that it has opened a setuid script, it calls suidperl with
3896      * the same argv that it had.  If suidperl finds that the script it has
3897      * just opened is NOT setuid root, it sets the effective uid back to the
3898      * uid.  We don't just make perl setuid root because that loses the
3899      * effective uid we had before invoking perl, if it was different from the
3900      * uid.
3901      * PSz 27 Feb 04
3902      * Description/comments above do not match current workings:
3903      *   suidperl must be hardlinked to sperlN.NNN (that is what we exec);
3904      *   suidperl called with script open and name changed to /dev/fd/N/X;
3905      *   suidperl croaks if script is not setuid;
3906      *   making perl setuid would be a huge security risk (and yes, that
3907      *     would lose any euid we might have had).
3908      *
3909      * DOSUID must be defined in both perl and suidperl, and IAMSUID must
3910      * be defined in suidperl only.  suidperl must be setuid root.  The
3911      * Configure script will set this up for you if you want it.
3912      */
3913
3914     if (PerlLIO_fstat(PerlIO_fileno(rsfp),&PL_statbuf) < 0)     /* normal stat is insecure */
3915         Perl_croak(aTHX_ "Can't stat script \"%s\"",PL_origfilename);
3916     if (PL_statbuf.st_mode & (S_ISUID|S_ISGID)) {
3917         I32 len;
3918         const char *linestr;
3919         const char *s_end;
3920
3921 #  ifdef IAMSUID
3922         if (fdscript < 0 || !suidscript)
3923             Perl_croak(aTHX_ "Need (suid) fdscript in suidperl\n");     /* We already checked this */
3924         /* PSz 11 Nov 03
3925          * Since the script is opened by perl, not suidperl, some of these
3926          * checks are superfluous. Leaving them in probably does not lower
3927          * security(?!).
3928          */
3929         /* PSz 27 Feb 04
3930          * Do checks even for systems with no HAS_SETREUID.
3931          * We used to swap, then re-swap UIDs with
3932 #    ifdef HAS_SETREUID
3933             if (setreuid(PL_euid,PL_uid) < 0
3934                 || PerlProc_getuid() != PL_euid || PerlProc_geteuid() != PL_uid)
3935                 Perl_croak(aTHX_ "Can't swap uid and euid");
3936 #    endif
3937 #    ifdef HAS_SETREUID
3938             if (setreuid(PL_uid,PL_euid) < 0
3939                 || PerlProc_getuid() != PL_uid || PerlProc_geteuid() != PL_euid)
3940                 Perl_croak(aTHX_ "Can't reswap uid and euid");
3941 #    endif
3942          */
3943
3944         /* On this access check to make sure the directories are readable,
3945          * there is actually a small window that the user could use to make
3946          * filename point to an accessible directory.  So there is a faint
3947          * chance that someone could execute a setuid script down in a
3948          * non-accessible directory.  I don't know what to do about that.
3949          * But I don't think it's too important.  The manual lies when
3950          * it says access() is useful in setuid programs.
3951          * 
3952          * So, access() is pretty useless... but not harmful... do anyway.
3953          */
3954         if (PerlLIO_access(CopFILE(PL_curcop),1)) { /*double check*/
3955             Perl_croak(aTHX_ "Can't access() script\n");
3956         }
3957
3958         /* If we can swap euid and uid, then we can determine access rights
3959          * with a simple stat of the file, and then compare device and
3960          * inode to make sure we did stat() on the same file we opened.
3961          * Then we just have to make sure he or she can execute it.
3962          * 
3963          * PSz 24 Feb 04
3964          * As the script is opened by perl, not suidperl, we do not need to
3965          * care much about access rights.
3966          * 
3967          * The 'script changed' check is needed, or we can get lied to
3968          * about $0 with e.g.
3969          *  suidperl /dev/fd/4//bin/x 4<setuidscript
3970          * Without HAS_SETREUID, is it safe to stat() as root?
3971          * 
3972          * Are there any operating systems that pass /dev/fd/xxx for setuid
3973          * scripts, as suggested/described in perlsec(1)? Surely they do not
3974          * pass the script name as we do, so the "script changed" test would
3975          * fail for them... but we never get here with
3976          * SETUID_SCRIPTS_ARE_SECURE_NOW defined.
3977          * 
3978          * This is one place where we must "lie" about return status: not
3979          * say if the stat() failed. We are doing this as root, and could
3980          * be tricked into reporting existence or not of files that the
3981          * "plain" user cannot even see.
3982          */
3983         {
3984             Stat_t tmpstatbuf;
3985             if (PerlLIO_stat(CopFILE(PL_curcop),&tmpstatbuf) < 0 ||
3986                 tmpstatbuf.st_dev != PL_statbuf.st_dev ||
3987                 tmpstatbuf.st_ino != PL_statbuf.st_ino) {
3988                 Perl_croak(aTHX_ "Setuid script changed\n");
3989             }
3990
3991         }
3992         if (!cando(S_IXUSR,FALSE,&PL_statbuf))          /* can real uid exec? */
3993             Perl_croak(aTHX_ "Real UID cannot exec script\n");
3994
3995         /* PSz 27 Feb 04
3996          * We used to do this check as the "plain" user (after swapping
3997          * UIDs). But the check for nosuid and noexec filesystem is needed,
3998          * and should be done even without HAS_SETREUID. (Maybe those
3999          * operating systems do not have such mount options anyway...)
4000          * Seems safe enough to do as root.
4001          */
4002 #    if !defined(NO_NOSUID_CHECK)
4003         if (fd_on_nosuid_fs(PerlIO_fileno(rsfp))) {
4004             Perl_croak(aTHX_ "Setuid script on nosuid or noexec filesystem\n");
4005         }
4006 #    endif
4007 #  endif /* IAMSUID */
4008
4009         if (!S_ISREG(PL_statbuf.st_mode)) {
4010             Perl_croak(aTHX_ "Setuid script not plain file\n");
4011         }
4012         if (PL_statbuf.st_mode & S_IWOTH)
4013             Perl_croak(aTHX_ "Setuid/gid script is writable by world");
4014         PL_doswitches = FALSE;          /* -s is insecure in suid */
4015         /* PSz 13 Nov 03  But -s was caught elsewhere ... so unsetting it here is useless(?!) */
4016         CopLINE_inc(PL_curcop);
4017         if (sv_gets(linestr_sv, rsfp, 0) == NULL)
4018             Perl_croak(aTHX_ "No #! line");
4019         linestr = SvPV_nolen_const(linestr_sv);
4020         /* required even on Sys V */
4021         if (!*linestr || !linestr[1] || strnNE(linestr,"#!",2))
4022             Perl_croak(aTHX_ "No #! line");
4023         linestr += 2;
4024         s = linestr;
4025         /* PSz 27 Feb 04 */
4026         /* Sanity check on line length */
4027         s_end = s + strlen(s);
4028         if (s_end == s || (s_end - s) > 4000)
4029             Perl_croak(aTHX_ "Very long #! line");
4030         /* Allow more than a single space after #! */
4031         while (isSPACE(*s)) s++;
4032         /* Sanity check on buffer end */
4033         while ((*s) && !isSPACE(*s)) s++;
4034         for (s2 = s;  (s2 > linestr &&
4035                        (isDIGIT(s2[-1]) || s2[-1] == '.' || s2[-1] == '_'
4036                         || s2[-1] == '-'));  s2--) ;
4037         /* Sanity check on buffer start */
4038         if ( (s2-4 < linestr || strnNE(s2-4,"perl",4)) &&
4039               (s-9 < linestr || strnNE(s-9,"perl",4)) )
4040             Perl_croak(aTHX_ "Not a perl script");
4041         while (*s == ' ' || *s == '\t') s++;
4042         /*
4043          * #! arg must be what we saw above.  They can invoke it by
4044          * mentioning suidperl explicitly, but they may not add any strange
4045          * arguments beyond what #! says if they do invoke suidperl that way.
4046          */
4047         /*
4048          * The way validarg was set up, we rely on the kernel to start
4049          * scripts with argv[1] set to contain all #! line switches (the
4050          * whole line).
4051          */
4052         /*
4053          * Check that we got all the arguments listed in the #! line (not
4054          * just that there are no extraneous arguments). Might not matter
4055          * much, as switches from #! line seem to be acted upon (also), and
4056          * so may be checked and trapped in perl. But, security checks must
4057          * be done in suidperl and not deferred to perl. Note that suidperl
4058          * does not get around to parsing (and checking) the switches on
4059          * the #! line (but execs perl sooner).
4060          * Allow (require) a trailing newline (which may be of two
4061          * characters on some architectures?) (but no other trailing
4062          * whitespace).
4063          */
4064         len = strlen(validarg);
4065         if (strEQ(validarg," PHOOEY ") ||
4066             strnNE(s,validarg,len) || !isSPACE(s[len]) ||
4067             !((s_end - s) == len+1
4068               || ((s_end - s) == len+2 && isSPACE(s[len+1]))))
4069             Perl_croak(aTHX_ "Args must match #! line");
4070
4071 #  ifndef IAMSUID
4072         if (fdscript < 0 &&
4073             PL_euid != PL_uid && (PL_statbuf.st_mode & S_ISUID) &&
4074             PL_euid == PL_statbuf.st_uid)
4075             if (!PL_do_undump)
4076                 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
4077 FIX YOUR KERNEL, OR PUT A C WRAPPER AROUND THIS SCRIPT!\n");
4078 #  endif /* IAMSUID */
4079
4080         if (fdscript < 0 &&
4081             PL_euid) {  /* oops, we're not the setuid root perl */
4082             /* PSz 18 Feb 04
4083              * When root runs a setuid script, we do not go through the same
4084              * steps of execing sperl and then perl with fd scripts, but
4085              * simply set up UIDs within the same perl invocation; so do
4086              * not have the same checks (on options, whatever) that we have
4087              * for plain users. No problem really: would have to be a script
4088              * that does not actually work for plain users; and if root is
4089              * foolish and can be persuaded to run such an unsafe script, he
4090              * might run also non-setuid ones, and deserves what he gets.
4091              * 
4092              * Or, we might drop the PL_euid check above (and rely just on
4093              * fdscript to avoid loops), and do the execs
4094              * even for root.
4095              */
4096 #  ifndef IAMSUID
4097             int which;
4098             /* PSz 11 Nov 03
4099              * Pass fd script to suidperl.
4100              * Exec suidperl, substituting fd script for scriptname.
4101              * Pass script name as "subdir" of fd, which perl will grok;
4102              * in fact will use that to distinguish this from "normal"
4103              * usage, see comments above.
4104              */
4105             PerlIO_rewind(rsfp);
4106             PerlLIO_lseek(PerlIO_fileno(rsfp),(Off_t)0,0);  /* just in case rewind didn't */
4107             /* PSz 27 Feb 04  Sanity checks on scriptname */
4108             if ((!scriptname) || (!*scriptname) ) {
4109                 Perl_croak(aTHX_ "No setuid script name\n");
4110             }
4111             if (*scriptname == '-') {
4112                 Perl_croak(aTHX_ "Setuid script name may not begin with dash\n");
4113                 /* Or we might confuse it with an option when replacing
4114                  * name in argument list, below (though we do pointer, not
4115                  * string, comparisons).
4116                  */
4117             }
4118             for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ;
4119             if (!PL_origargv[which]) {
4120                 Perl_croak(aTHX_ "Can't change argv to have fd script\n");
4121             }
4122             PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s",
4123                                           PerlIO_fileno(rsfp), PL_origargv[which]));
4124 #    if defined(HAS_FCNTL) && defined(F_SETFD)
4125             fcntl(PerlIO_fileno(rsfp),F_SETFD,0);       /* ensure no close-on-exec */
4126 #    endif
4127             PERL_FPU_PRE_EXEC
4128             PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT, BIN_EXP,
4129                                      (int)PERL_REVISION, (int)PERL_VERSION,
4130                                      (int)PERL_SUBVERSION), PL_origargv);
4131             PERL_FPU_POST_EXEC
4132 #  endif /* IAMSUID */
4133             Perl_croak(aTHX_ "Can't do setuid (cannot exec sperl)\n");
4134         }
4135
4136         if (PL_statbuf.st_mode & S_ISGID && PL_statbuf.st_gid != PL_egid) {
4137 /* PSz 26 Feb 04
4138  * This seems back to front: we try HAS_SETEGID first; if not available
4139  * then try HAS_SETREGID; as a last chance we try HAS_SETRESGID. May be OK
4140  * in the sense that we only want to set EGID; but are there any machines
4141  * with either of the latter, but not the former? Same with UID, later.
4142  */
4143 #  ifdef HAS_SETEGID
4144             (void)setegid(PL_statbuf.st_gid);
4145 #  else
4146 #    ifdef HAS_SETREGID
4147            (void)setregid((Gid_t)-1,PL_statbuf.st_gid);
4148 #    else
4149 #      ifdef HAS_SETRESGID
4150            (void)setresgid((Gid_t)-1,PL_statbuf.st_gid,(Gid_t)-1);
4151 #      else
4152             PerlProc_setgid(PL_statbuf.st_gid);
4153 #      endif
4154 #    endif
4155 #  endif
4156             if (PerlProc_getegid() != PL_statbuf.st_gid)
4157                 Perl_croak(aTHX_ "Can't do setegid!\n");
4158         }
4159         if (PL_statbuf.st_mode & S_ISUID) {
4160             if (PL_statbuf.st_uid != PL_euid)
4161 #  ifdef HAS_SETEUID
4162                 (void)seteuid(PL_statbuf.st_uid);       /* all that for this */
4163 #  else
4164 #    ifdef HAS_SETREUID
4165                 (void)setreuid((Uid_t)-1,PL_statbuf.st_uid);
4166 #    else
4167 #      ifdef HAS_SETRESUID
4168                 (void)setresuid((Uid_t)-1,PL_statbuf.st_uid,(Uid_t)-1);
4169 #      else
4170                 PerlProc_setuid(PL_statbuf.st_uid);
4171 #      endif
4172 #    endif
4173 #  endif
4174             if (PerlProc_geteuid() != PL_statbuf.st_uid)
4175                 Perl_croak(aTHX_ "Can't do seteuid!\n");
4176         }
4177         else if (PL_uid) {                      /* oops, mustn't run as root */
4178 #  ifdef HAS_SETEUID
4179           (void)seteuid((Uid_t)PL_uid);
4180 #  else
4181 #    ifdef HAS_SETREUID
4182           (void)setreuid((Uid_t)-1,(Uid_t)PL_uid);
4183 #    else
4184 #      ifdef HAS_SETRESUID
4185           (void)setresuid((Uid_t)-1,(Uid_t)PL_uid,(Uid_t)-1);
4186 #      else
4187           PerlProc_setuid((Uid_t)PL_uid);
4188 #      endif
4189 #    endif
4190 #  endif
4191             if (PerlProc_geteuid() != PL_uid)
4192                 Perl_croak(aTHX_ "Can't do seteuid!\n");
4193         }
4194         init_ids();
4195         if (!cando(S_IXUSR,TRUE,&PL_statbuf))
4196             Perl_croak(aTHX_ "Effective UID cannot exec script\n");     /* they can't do this */
4197     }
4198 #  ifdef IAMSUID
4199     else if (fdscript < 0 || !suidscript)
4200         /* PSz 13 Nov 03  Caught elsewhere, useless(?!) here */
4201         Perl_croak(aTHX_ "(suid) fdscript needed in suidperl\n");
4202     else {
4203 /* PSz 16 Sep 03  Keep neat error message */
4204         Perl_croak(aTHX_ "Script is not setuid/setgid in suidperl\n");
4205     }
4206
4207     /* We absolutely must clear out any saved ids here, so we */
4208     /* exec the real perl, substituting fd script for scriptname. */
4209     /* (We pass script name as "subdir" of fd, which perl will grok.) */
4210     /* 
4211      * It might be thought that using setresgid and/or setresuid (changed to
4212      * set the saved IDs) above might obviate the need to exec, and we could
4213      * go on to "do the perl thing".
4214      * 
4215      * Is there such a thing as "saved GID", and is that set for setuid (but
4216      * not setgid) execution like suidperl? Without exec, it would not be
4217      * cleared for setuid (but not setgid) scripts (or might need a dummy
4218      * setresgid).
4219      * 
4220      * We need suidperl to do the exact same argument checking that perl
4221      * does. Thus it cannot be very small; while it could be significantly
4222      * smaller, it is safer (simpler?) to make it essentially the same
4223      * binary as perl (but they are not identical). - Maybe could defer that
4224      * check to the invoked perl, and suidperl be a tiny wrapper instead;
4225      * but prefer to do thorough checks in suidperl itself. Such deferral
4226      * would make suidperl security rely on perl, a design no-no.
4227      * 
4228      * Setuid things should be short and simple, thus easy to understand and
4229      * verify. They should do their "own thing", without influence by
4230      * attackers. It may help if their internal execution flow is fixed,
4231      * regardless of platform: it may be best to exec anyway.
4232      * 
4233      * Suidperl should at least be conceptually simple: a wrapper only,
4234      * never to do any real perl. Maybe we should put
4235      * #ifdef IAMSUID
4236      *         Perl_croak(aTHX_ "Suidperl should never do real perl\n");
4237      * #endif
4238      * into the perly bits.
4239      */
4240     PerlIO_rewind(rsfp);
4241     PerlLIO_lseek(PerlIO_fileno(rsfp),(Off_t)0,0);  /* just in case rewind didn't */
4242     /* PSz 11 Nov 03
4243      * Keep original arguments: suidperl already has fd script.
4244      */
4245 #  if defined(HAS_FCNTL) && defined(F_SETFD)
4246     fcntl(PerlIO_fileno(rsfp),F_SETFD,0);       /* ensure no close-on-exec */
4247 #  endif
4248     PERL_FPU_PRE_EXEC
4249     PerlProc_execv(Perl_form(aTHX_ "%s/perl"PERL_FS_VER_FMT, BIN_EXP,
4250                              (int)PERL_REVISION, (int)PERL_VERSION,
4251                              (int)PERL_SUBVERSION), PL_origargv);/* try again */
4252     PERL_FPU_POST_EXEC
4253     Perl_croak(aTHX_ "Can't do setuid (suidperl cannot exec perl)\n");
4254 #  endif /* IAMSUID */
4255 }
4256
4257 #else /* !DOSUID */
4258
4259 #  ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
4260 /* Don't even need this function.  */
4261 #  else
4262 STATIC void
4263 S_validate_suid(pTHX_ PerlIO *rsfp)
4264 {
4265     PERL_ARGS_ASSERT_VALIDATE_SUID;
4266
4267     if (PL_euid != PL_uid || PL_egid != PL_gid) {       /* (suidperl doesn't exist, in fact) */
4268 #  ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
4269         dVAR;
4270
4271         PerlLIO_fstat(PerlIO_fileno(rsfp),&PL_statbuf); /* may be either wrapped or real suid */
4272         if ((PL_euid != PL_uid && PL_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
4273             ||
4274             (PL_egid != PL_gid && PL_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
4275            )
4276             if (!PL_do_undump)
4277                 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
4278 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
4279 #  endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
4280         /* not set-id, must be wrapped */
4281     }
4282 }
4283 #  endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
4284 #endif /* DOSUID */
4285
4286 STATIC void
4287 S_find_beginning(pTHX_ SV* linestr_sv, PerlIO *rsfp)
4288 {
4289     dVAR;
4290     const char *s;
4291     register const char *s2;
4292 #ifdef MACOS_TRADITIONAL
4293     int maclines = 0;
4294 #endif
4295
4296     PERL_ARGS_ASSERT_FIND_BEGINNING;
4297
4298     /* skip forward in input to the real script? */
4299
4300 #ifdef MACOS_TRADITIONAL
4301     /* Since the Mac OS does not honor #! arguments for us, we do it ourselves */
4302
4303     while (PL_doextract || gMacPerl_AlwaysExtract) {
4304         if ((s = sv_gets(linestr_sv, rsfp, 0)) == NULL) {
4305             if (!gMacPerl_AlwaysExtract)
4306                 Perl_croak(aTHX_ "No Perl script found in input\n");
4307
4308             if (PL_doextract)                   /* require explicit override ? */
4309                 if (!OverrideExtract(PL_origfilename))
4310                     Perl_croak(aTHX_ "User aborted script\n");
4311                 else
4312                     PL_doextract = FALSE;
4313
4314             /* Pater peccavi, file does not have #! */
4315             PerlIO_rewind(rsfp);
4316
4317             break;
4318         }
4319 #else
4320     while (PL_doextract) {
4321         if ((s = sv_gets(linestr_sv, rsfp, 0)) == NULL)
4322             Perl_croak(aTHX_ "No Perl script found in input\n");
4323 #endif
4324         s2 = s;
4325         if (*s == '#' && s[1] == '!' && ((s = instr(s,"perl")) || (s = instr(s2,"PERL")))) {
4326             PerlIO_ungetc(rsfp, '\n');          /* to keep line count right */
4327             PL_doextract = FALSE;
4328             while (*s && !(isSPACE (*s) || *s == '#')) s++;
4329             s2 = s;
4330             while (*s == ' ' || *s == '\t') s++;
4331             if (*s++ == '-') {
4332                 while (isDIGIT(s2[-1]) || s2[-1] == '-' || s2[-1] == '.'
4333                        || s2[-1] == '_') s2--;
4334                 if (strnEQ(s2-4,"perl",4))
4335                     while ((s = moreswitches(s)))
4336                         ;
4337             }
4338 #ifdef MACOS_TRADITIONAL
4339             /* We are always searching for the #!perl line in MacPerl,
4340              * so if we find it, still keep the line count correct
4341              * by counting lines we already skipped over
4342              */
4343             for (; maclines > 0 ; maclines--)
4344                 PerlIO_ungetc(rsfp, '\n');
4345
4346             break;
4347
4348         /* gMacPerl_AlwaysExtract is false in MPW tool */
4349         } else if (gMacPerl_AlwaysExtract) {
4350             ++maclines;
4351 #endif
4352         }
4353     }
4354 }
4355
4356
4357 STATIC void
4358 S_init_ids(pTHX)
4359 {
4360     dVAR;
4361     PL_uid = PerlProc_getuid();
4362     PL_euid = PerlProc_geteuid();
4363     PL_gid = PerlProc_getgid();
4364     PL_egid = PerlProc_getegid();
4365 #ifdef VMS
4366     PL_uid |= PL_gid << 16;
4367     PL_euid |= PL_egid << 16;
4368 #endif
4369     /* Should not happen: */
4370     CHECK_MALLOC_TAINT(PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
4371     PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
4372     /* BUG */
4373     /* PSz 27 Feb 04
4374      * Should go by suidscript, not uid!=euid: why disallow
4375      * system("ls") in scripts run from setuid things?
4376      * Or, is this run before we check arguments and set suidscript?
4377      * What about SETUID_SCRIPTS_ARE_SECURE_NOW: could we use fdscript then?
4378      * (We never have suidscript, can we be sure to have fdscript?)
4379      * Or must then go by UID checks? See comments in forbid_setid also.
4380      */
4381 }
4382
4383 /* This is used very early in the lifetime of the program,
4384  * before even the options are parsed, so PL_tainting has
4385  * not been initialized properly.  */
4386 bool
4387 Perl_doing_taint(int argc, char *argv[], char *envp[])
4388 {
4389 #ifndef PERL_IMPLICIT_SYS
4390     /* If we have PERL_IMPLICIT_SYS we can't call getuid() et alia
4391      * before we have an interpreter-- and the whole point of this
4392      * function is to be called at such an early stage.  If you are on
4393      * a system with PERL_IMPLICIT_SYS but you do have a concept of
4394      * "tainted because running with altered effective ids', you'll
4395      * have to add your own checks somewhere in here.  The two most
4396      * known samples of 'implicitness' are Win32 and NetWare, neither
4397      * of which has much of concept of 'uids'. */
4398     int uid  = PerlProc_getuid();
4399     int euid = PerlProc_geteuid();
4400     int gid  = PerlProc_getgid();
4401     int egid = PerlProc_getegid();
4402     (void)envp;
4403
4404 #ifdef VMS
4405     uid  |=  gid << 16;
4406     euid |= egid << 16;
4407 #endif
4408     if (uid && (euid != uid || egid != gid))
4409         return 1;
4410 #endif /* !PERL_IMPLICIT_SYS */
4411     /* This is a really primitive check; environment gets ignored only
4412      * if -T are the first chars together; otherwise one gets
4413      *  "Too late" message. */
4414     if ( argc > 1 && argv[1][0] == '-'
4415          && (argv[1][1] == 't' || argv[1][1] == 'T') )
4416         return 1;
4417     return 0;
4418 }
4419
4420 /* Passing the flag as a single char rather than a string is a slight space
4421    optimisation.  The only message that isn't /^-.$/ is
4422    "program input from stdin", which is substituted in place of '\0', which
4423    could never be a command line flag.  */
4424 STATIC void
4425 S_forbid_setid(pTHX_ const char flag, const bool suidscript) /* g */
4426 {
4427     dVAR;
4428     char string[3] = "-x";
4429     const char *message = "program input from stdin";
4430
4431     if (flag) {
4432         string[1] = flag;
4433         message = string;
4434     }
4435
4436 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
4437     if (PL_euid != PL_uid)
4438         Perl_croak(aTHX_ "No %s allowed while running setuid", message);
4439     if (PL_egid != PL_gid)
4440         Perl_croak(aTHX_ "No %s allowed while running setgid", message);
4441 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
4442     /* PSz 29 Feb 04
4443      * Checks for UID/GID above "wrong": why disallow
4444      *   perl -e 'print "Hello\n"'
4445      * from within setuid things?? Simply drop them: replaced by
4446      * fdscript/suidscript and #ifdef IAMSUID checks below.
4447      * 
4448      * This may be too late for command-line switches. Will catch those on
4449      * the #! line, after finding the script name and setting up
4450      * fdscript/suidscript. Note that suidperl does not get around to
4451      * parsing (and checking) the switches on the #! line, but checks that
4452      * the two sets are identical.
4453      * 
4454      * With SETUID_SCRIPTS_ARE_SECURE_NOW, could we use fdscript, also or
4455      * instead, or would that be "too late"? (We never have suidscript, can
4456      * we be sure to have fdscript?)
4457      * 
4458      * Catch things with suidscript (in descendant of suidperl), even with
4459      * right UID/GID. Was already checked in suidperl, with #ifdef IAMSUID,
4460      * below; but I am paranoid.
4461      * 
4462      * Also see comments about root running a setuid script, elsewhere.
4463      */
4464     if (suidscript)
4465         Perl_croak(aTHX_ "No %s allowed with (suid) fdscript", message);
4466 #ifdef IAMSUID
4467     /* PSz 11 Nov 03  Catch it in suidperl, always! */
4468     Perl_croak(aTHX_ "No %s allowed in suidperl", message);
4469 #endif /* IAMSUID */
4470 }
4471
4472 void
4473 Perl_init_debugger(pTHX)
4474 {
4475     dVAR;
4476     HV * const ostash = PL_curstash;
4477
4478     PL_curstash = PL_debstash;
4479     PL_dbargs = GvAV(gv_AVadd((gv_fetchpvs("DB::args", GV_ADDMULTI,
4480                                            SVt_PVAV))));
4481     AvREAL_off(PL_dbargs);
4482     PL_DBgv = gv_fetchpvs("DB::DB", GV_ADDMULTI, SVt_PVGV);
4483     PL_DBline = gv_fetchpvs("DB::dbline", GV_ADDMULTI, SVt_PVAV);
4484     PL_DBsub = gv_HVadd(gv_fetchpvs("DB::sub", GV_ADDMULTI, SVt_PVHV));
4485     PL_DBsingle = GvSV((gv_fetchpvs("DB::single", GV_ADDMULTI, SVt_PV)));
4486     sv_setiv(PL_DBsingle, 0);
4487     PL_DBtrace = GvSV((gv_fetchpvs("DB::trace", GV_ADDMULTI, SVt_PV)));
4488     sv_setiv(PL_DBtrace, 0);
4489     PL_DBsignal = GvSV((gv_fetchpvs("DB::signal", GV_ADDMULTI, SVt_PV)));
4490     sv_setiv(PL_DBsignal, 0);
4491     PL_curstash = ostash;
4492 }
4493
4494 #ifndef STRESS_REALLOC
4495 #define REASONABLE(size) (size)
4496 #else
4497 #define REASONABLE(size) (1) /* unreasonable */
4498 #endif
4499
4500 void
4501 Perl_init_stacks(pTHX)
4502 {
4503     dVAR;
4504     /* start with 128-item stack and 8K cxstack */
4505     PL_curstackinfo = new_stackinfo(REASONABLE(128),
4506                                  REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
4507     PL_curstackinfo->si_type = PERLSI_MAIN;
4508     PL_curstack = PL_curstackinfo->si_stack;
4509     PL_mainstack = PL_curstack;         /* remember in case we switch stacks */
4510
4511     PL_stack_base = AvARRAY(PL_curstack);
4512     PL_stack_sp = PL_stack_base;
4513     PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
4514
4515     Newx(PL_tmps_stack,REASONABLE(128),SV*);
4516     PL_tmps_floor = -1;
4517     PL_tmps_ix = -1;
4518     PL_tmps_max = REASONABLE(128);
4519
4520     Newx(PL_markstack,REASONABLE(32),I32);
4521     PL_markstack_ptr = PL_markstack;
4522     PL_markstack_max = PL_markstack + REASONABLE(32);
4523
4524     SET_MARK_OFFSET;
4525
4526     Newx(PL_scopestack,REASONABLE(32),I32);
4527     PL_scopestack_ix = 0;
4528     PL_scopestack_max = REASONABLE(32);
4529
4530     Newx(PL_savestack,REASONABLE(128),ANY);
4531     PL_savestack_ix = 0;
4532     PL_savestack_max = REASONABLE(128);
4533 }
4534
4535 #undef REASONABLE
4536
4537 STATIC void
4538 S_nuke_stacks(pTHX)
4539 {
4540     dVAR;
4541     while (PL_curstackinfo->si_next)
4542         PL_curstackinfo = PL_curstackinfo->si_next;
4543     while (PL_curstackinfo) {
4544         PERL_SI *p = PL_curstackinfo->si_prev;
4545         /* curstackinfo->si_stack got nuked by sv_free_arenas() */
4546         Safefree(PL_curstackinfo->si_cxstack);
4547         Safefree(PL_curstackinfo);
4548         PL_curstackinfo = p;
4549     }
4550     Safefree(PL_tmps_stack);
4551     Safefree(PL_markstack);
4552     Safefree(PL_scopestack);
4553     Safefree(PL_savestack);
4554 }
4555
4556
4557 STATIC void
4558 S_init_predump_symbols(pTHX)
4559 {
4560     dVAR;
4561     GV *tmpgv;
4562     IO *io;
4563
4564     sv_setpvs(get_sv("\"", TRUE), " ");
4565     PL_ofsgv = (GV*)SvREFCNT_inc(gv_fetchpvs(",", GV_ADD|GV_NOTQUAL, SVt_PV));
4566
4567     PL_stdingv = gv_fetchpvs("STDIN", GV_ADD|GV_NOTQUAL, SVt_PVIO);
4568     GvMULTI_on(PL_stdingv);
4569     io = GvIOp(PL_stdingv);
4570     IoTYPE(io) = IoTYPE_RDONLY;
4571     IoIFP(io) = PerlIO_stdin();
4572     tmpgv = gv_fetchpvs("stdin", GV_ADD|GV_NOTQUAL, SVt_PV);
4573     GvMULTI_on(tmpgv);
4574     GvIOp(tmpgv) = MUTABLE_IO(SvREFCNT_inc_simple(io));
4575
4576     tmpgv = gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVIO);
4577     GvMULTI_on(tmpgv);
4578     io = GvIOp(tmpgv);
4579     IoTYPE(io) = IoTYPE_WRONLY;
4580     IoOFP(io) = IoIFP(io) = PerlIO_stdout();
4581     setdefout(tmpgv);
4582     tmpgv = gv_fetchpvs("stdout", GV_ADD|GV_NOTQUAL, SVt_PV);
4583     GvMULTI_on(tmpgv);
4584     GvIOp(tmpgv) = MUTABLE_IO(SvREFCNT_inc_simple(io));
4585
4586     PL_stderrgv = gv_fetchpvs("STDERR", GV_ADD|GV_NOTQUAL, SVt_PVIO);
4587     GvMULTI_on(PL_stderrgv);
4588     io = GvIOp(PL_stderrgv);
4589     IoTYPE(io) = IoTYPE_WRONLY;
4590     IoOFP(io) = IoIFP(io) = PerlIO_stderr();
4591     tmpgv = gv_fetchpvs("stderr", GV_ADD|GV_NOTQUAL, SVt_PV);
4592     GvMULTI_on(tmpgv);
4593     GvIOp(tmpgv) = MUTABLE_IO(SvREFCNT_inc_simple(io));
4594
4595     PL_statname = newSV(0);             /* last filename we did stat on */
4596
4597     Safefree(PL_osname);
4598     PL_osname = savepv(OSNAME);
4599 }
4600
4601 void
4602 Perl_init_argv_symbols(pTHX_ register int argc, register char **argv)
4603 {
4604     dVAR;
4605
4606     PERL_ARGS_ASSERT_INIT_ARGV_SYMBOLS;
4607
4608     argc--,argv++;      /* skip name of script */
4609     if (PL_doswitches) {
4610         for (; argc > 0 && **argv == '-'; argc--,argv++) {
4611             char *s;
4612             if (!argv[0][1])
4613                 break;
4614             if (argv[0][1] == '-' && !argv[0][2]) {
4615                 argc--,argv++;
4616                 break;
4617             }
4618             if ((s = strchr(argv[0], '='))) {
4619                 const char *const start_name = argv[0] + 1;
4620                 sv_setpv(GvSV(gv_fetchpvn_flags(start_name, s - start_name,
4621                                                 TRUE, SVt_PV)), s + 1);
4622             }
4623             else
4624                 sv_setiv(GvSV(gv_fetchpv(argv[0]+1, GV_ADD, SVt_PV)),1);
4625         }
4626     }
4627     if ((PL_argvgv = gv_fetchpvs("ARGV", GV_ADD|GV_NOTQUAL, SVt_PVAV))) {
4628         GvMULTI_on(PL_argvgv);
4629         (void)gv_AVadd(PL_argvgv);
4630         av_clear(GvAVn(PL_argvgv));
4631         for (; argc > 0; argc--,argv++) {
4632             SV * const sv = newSVpv(argv[0],0);
4633             av_push(GvAVn(PL_argvgv),sv);
4634             if (!(PL_unicode & PERL_UNICODE_LOCALE_FLAG) || PL_utf8locale) {
4635                  if (PL_unicode & PERL_UNICODE_ARGV_FLAG)
4636                       SvUTF8_on(sv);
4637             }
4638             if (PL_unicode & PERL_UNICODE_WIDESYSCALLS_FLAG) /* Sarathy? */
4639                  (void)sv_utf8_decode(sv);
4640         }
4641     }
4642 }
4643
4644 STATIC void
4645 S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env)
4646 {
4647     dVAR;
4648     GV* tmpgv;
4649
4650     PERL_ARGS_ASSERT_INIT_POSTDUMP_SYMBOLS;
4651
4652     PL_toptarget = newSV_type(SVt_PVFM);
4653     sv_setpvs(PL_toptarget, "");
4654     PL_bodytarget = newSV_type(SVt_PVFM);
4655     sv_setpvs(PL_bodytarget, "");
4656     PL_formtarget = PL_bodytarget;
4657
4658     TAINT;
4659
4660     init_argv_symbols(argc,argv);
4661
4662     if ((tmpgv = gv_fetchpvs("0", GV_ADD|GV_NOTQUAL, SVt_PV))) {
4663 #ifdef MACOS_TRADITIONAL
4664         /* $0 is not majick on a Mac */
4665         sv_setpv(GvSV(tmpgv),MacPerl_MPWFileName(PL_origfilename));
4666 #else
4667         sv_setpv(GvSV(tmpgv),PL_origfilename);
4668         {
4669             GV * const gv = gv_fetchpv("0", GV_ADD, SVt_PV);
4670             if (gv)
4671                 sv_magic(GvSV(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, "0", 1);
4672         }
4673 #endif
4674     }
4675     if ((PL_envgv = gv_fetchpvs("ENV", GV_ADD|GV_NOTQUAL, SVt_PVHV))) {
4676         HV *hv;
4677         bool env_is_not_environ;
4678         GvMULTI_on(PL_envgv);
4679         hv = GvHVn(PL_envgv);
4680         hv_magic(hv, NULL, PERL_MAGIC_env);
4681 #ifndef PERL_MICRO
4682 #ifdef USE_ENVIRON_ARRAY
4683         /* Note that if the supplied env parameter is actually a copy
4684            of the global environ then it may now point to free'd memory
4685            if the environment has been modified since. To avoid this
4686            problem we treat env==NULL as meaning 'use the default'
4687         */
4688         if (!env)
4689             env = environ;
4690         env_is_not_environ = env != environ;
4691         if (env_is_not_environ
4692 #  ifdef USE_ITHREADS
4693             && PL_curinterp == aTHX
4694 #  endif
4695            )
4696         {
4697             environ[0] = NULL;
4698         }
4699         if (env) {
4700           char *s, *old_var;
4701           SV *sv;
4702           for (; *env; env++) {
4703             old_var = *env;
4704
4705             if (!(s = strchr(old_var,'=')) || s == old_var)
4706                 continue;
4707
4708 #if defined(MSDOS) && !defined(DJGPP)
4709             *s = '\0';
4710             (void)strupr(old_var);
4711             *s = '=';
4712 #endif
4713             sv = newSVpv(s+1, 0);
4714             (void)hv_store(hv, old_var, s - old_var, sv, 0);
4715             if (env_is_not_environ)
4716                 mg_set(sv);
4717           }
4718       }
4719 #endif /* USE_ENVIRON_ARRAY */
4720 #endif /* !PERL_MICRO */
4721     }
4722     TAINT_NOT;
4723     if ((tmpgv = gv_fetchpvs("$", GV_ADD|GV_NOTQUAL, SVt_PV))) {
4724         SvREADONLY_off(GvSV(tmpgv));
4725         sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
4726         SvREADONLY_on(GvSV(tmpgv));
4727     }
4728 #ifdef THREADS_HAVE_PIDS
4729     PL_ppid = (IV)getppid();
4730 #endif
4731
4732     /* touch @F array to prevent spurious warnings 20020415 MJD */
4733     if (PL_minus_a) {
4734       (void) get_av("main::F", TRUE | GV_ADDMULTI);
4735     }
4736 }
4737
4738 STATIC void
4739 S_init_perllib(pTHX)
4740 {
4741     dVAR;
4742     char *s;
4743     if (!PL_tainting) {
4744 #ifndef VMS
4745         s = PerlEnv_getenv("PERL5LIB");
4746 /*
4747  * It isn't possible to delete an environment variable with
4748  * PERL_USE_SAFE_PUTENV set unless unsetenv() is also available, so in that
4749  * case we treat PERL5LIB as undefined if it has a zero-length value.
4750  */
4751 #if defined(PERL_USE_SAFE_PUTENV) && ! defined(HAS_UNSETENV)
4752         if (s && *s != '\0')
4753 #else
4754         if (s)
4755 #endif
4756             incpush(s, TRUE, TRUE, TRUE, FALSE, FALSE);
4757         else
4758             incpush(PerlEnv_getenv("PERLLIB"), FALSE, FALSE, TRUE, FALSE, FALSE);
4759 #else /* VMS */
4760         /* Treat PERL5?LIB as a possible search list logical name -- the
4761          * "natural" VMS idiom for a Unix path string.  We allow each
4762          * element to be a set of |-separated directories for compatibility.
4763          */
4764         char buf[256];
4765         int idx = 0;
4766         if (my_trnlnm("PERL5LIB",buf,0))
4767             do { incpush(buf,TRUE,TRUE,TRUE,FALSE, FALSE); } while (my_trnlnm("PERL5LIB",buf,++idx));
4768         else
4769             while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE,FALSE,TRUE,FALSE, FALSE);
4770 #endif /* VMS */
4771     }
4772
4773 /* Use the ~-expanded versions of APPLLIB (undocumented),
4774     ARCHLIB PRIVLIB SITEARCH SITELIB VENDORARCH and VENDORLIB
4775 */
4776 #ifdef APPLLIB_EXP
4777     incpush(APPLLIB_EXP, TRUE, TRUE, TRUE, TRUE, FALSE);
4778 #endif
4779
4780 #ifdef ARCHLIB_EXP
4781     incpush(ARCHLIB_EXP, FALSE, FALSE, TRUE, TRUE, FALSE);
4782 #endif
4783 #ifdef MACOS_TRADITIONAL
4784     {
4785         Stat_t tmpstatbuf;
4786         SV * privdir = newSV(0);
4787         char * macperl = PerlEnv_getenv("MACPERL");
4788         
4789         if (!macperl)
4790             macperl = "";
4791         
4792         Perl_sv_setpvf(aTHX_ privdir, "%slib:", macperl);
4793         if (PerlLIO_stat(SvPVX(privdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode))
4794             incpush(SvPVX(privdir), TRUE, FALSE, TRUE, FALSE, FALSE);
4795         Perl_sv_setpvf(aTHX_ privdir, "%ssite_perl:", macperl);
4796         if (PerlLIO_stat(SvPVX(privdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode))
4797             incpush(SvPVX(privdir), TRUE, FALSE, TRUE, FALSE, FALSE);
4798         
4799         SvREFCNT_dec(privdir);
4800     }
4801     if (!PL_tainting)
4802         incpush(":", FALSE, FALSE, FALSE, FALSE, FALSE);
4803 #else
4804 #ifndef PRIVLIB_EXP
4805 #  define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
4806 #endif
4807 #if defined(WIN32)
4808     incpush(PRIVLIB_EXP, TRUE, FALSE, TRUE, TRUE, FALSE);
4809 #else
4810     incpush(PRIVLIB_EXP, FALSE, FALSE, TRUE, TRUE, FALSE);
4811 #endif
4812
4813 #ifdef SITEARCH_EXP
4814     /* sitearch is always relative to sitelib on Windows for
4815      * DLL-based path intuition to work correctly */
4816 #  if !defined(WIN32)
4817     incpush(SITEARCH_EXP, FALSE, FALSE, TRUE, TRUE, FALSE);
4818 #  endif
4819 #endif
4820
4821 #ifdef SITELIB_EXP
4822 #  if defined(WIN32)
4823     /* this picks up sitearch as well */
4824     incpush(SITELIB_EXP, TRUE, FALSE, TRUE, TRUE, FALSE);
4825 #  else
4826     incpush(SITELIB_EXP, FALSE, FALSE, TRUE, TRUE, FALSE);
4827 #  endif
4828 #endif
4829
4830 #if defined(SITELIB_STEM) && defined(PERL_INC_VERSION_LIST)
4831     /* Search for version-specific dirs below here */
4832     incpush(SITELIB_STEM, FALSE, TRUE, TRUE, TRUE, FALSE);
4833 #endif
4834
4835 #ifdef PERL_VENDORARCH_EXP
4836     /* vendorarch is always relative to vendorlib on Windows for
4837      * DLL-based path intuition to work correctly */
4838 #  if !defined(WIN32)
4839     incpush(PERL_VENDORARCH_EXP, FALSE, FALSE, TRUE, TRUE, FALSE);
4840 #  endif
4841 #endif
4842
4843 #ifdef PERL_VENDORLIB_EXP
4844 #  if defined(WIN32)
4845     incpush(PERL_VENDORLIB_EXP, TRUE, FALSE, TRUE, TRUE, FALSE);        /* this picks up vendorarch as well */
4846 #  else
4847     incpush(PERL_VENDORLIB_EXP, FALSE, FALSE, TRUE, TRUE, FALSE);
4848 #  endif
4849 #endif
4850
4851 #if defined(PERL_VENDORLIB_STEM) && defined(PERL_INC_VERSION_LIST)
4852     /* Search for version-specific dirs below here */
4853     incpush(PERL_VENDORLIB_STEM, FALSE, TRUE, TRUE, TRUE, FALSE);
4854 #endif
4855
4856 #ifdef PERL_OTHERLIBDIRS
4857     incpush(PERL_OTHERLIBDIRS, TRUE, TRUE, TRUE, TRUE, FALSE);
4858 #endif
4859
4860     if (!PL_tainting)
4861         incpush(".", FALSE, FALSE, FALSE, FALSE, FALSE);
4862 #endif /* MACOS_TRADITIONAL */
4863 }
4864
4865 #if defined(DOSISH) || defined(EPOC) || defined(__SYMBIAN32__)
4866 #    define PERLLIB_SEP ';'
4867 #else
4868 #  if defined(VMS)
4869 #    define PERLLIB_SEP '|'
4870 #  else
4871 #    if defined(MACOS_TRADITIONAL)
4872 #      define PERLLIB_SEP ','
4873 #    else
4874 #      define PERLLIB_SEP ':'
4875 #    endif
4876 #  endif
4877 #endif
4878 #ifndef PERLLIB_MANGLE
4879 #  define PERLLIB_MANGLE(s,n) (s)
4880 #endif
4881
4882 /* Push a directory onto @INC if it exists.
4883    Generate a new SV if we do this, to save needing to copy the SV we push
4884    onto @INC  */
4885 STATIC SV *
4886 S_incpush_if_exists(pTHX_ SV *dir)
4887 {
4888     dVAR;
4889     Stat_t tmpstatbuf;
4890
4891     PERL_ARGS_ASSERT_INCPUSH_IF_EXISTS;
4892
4893     if (PerlLIO_stat(SvPVX_const(dir), &tmpstatbuf) >= 0 &&
4894         S_ISDIR(tmpstatbuf.st_mode)) {
4895         av_push(GvAVn(PL_incgv), dir);
4896         dir = newSV(0);
4897     }
4898     return dir;
4899 }
4900
4901 STATIC void
4902 S_incpush(pTHX_ const char *dir, bool addsubdirs, bool addoldvers, bool usesep,
4903           bool canrelocate, bool unshift)
4904 {
4905     dVAR;
4906     SV *subdir = NULL;
4907     const char *p = dir;
4908
4909     if (!p || !*p)
4910         return;
4911
4912     if (addsubdirs || addoldvers) {
4913         subdir = newSV(0);
4914     }
4915
4916     /* Break at all separators */
4917     while (p && *p) {
4918         SV *libdir = newSV(0);
4919         const char *s;
4920
4921         /* skip any consecutive separators */
4922         if (usesep) {
4923             while ( *p == PERLLIB_SEP ) {
4924                 /* Uncomment the next line for PATH semantics */
4925                 /* av_push(GvAVn(PL_incgv), newSVpvs(".")); */
4926                 p++;
4927             }
4928         }
4929
4930         if ( usesep && (s = strchr(p, PERLLIB_SEP)) != NULL ) {
4931             sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
4932                       (STRLEN)(s - p));
4933             p = s + 1;
4934         }
4935         else {
4936             sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
4937             p = NULL;   /* break out */
4938         }
4939 #ifdef MACOS_TRADITIONAL
4940         if (!strchr(SvPVX(libdir), ':')) {
4941             char buf[256];
4942
4943             sv_setpv(libdir, MacPerl_CanonDir(SvPVX(libdir), buf, 0));
4944         }
4945         if (SvPVX(libdir)[SvCUR(libdir)-1] != ':')
4946             sv_catpvs(libdir, ":");
4947 #endif
4948
4949         /* Do the if() outside the #ifdef to avoid warnings about an unused
4950            parameter.  */
4951         if (canrelocate) {
4952 #ifdef PERL_RELOCATABLE_INC
4953         /*
4954          * Relocatable include entries are marked with a leading .../
4955          *
4956          * The algorithm is
4957          * 0: Remove that leading ".../"
4958          * 1: Remove trailing executable name (anything after the last '/')
4959          *    from the perl path to give a perl prefix
4960          * Then
4961          * While the @INC element starts "../" and the prefix ends with a real
4962          * directory (ie not . or ..) chop that real directory off the prefix
4963          * and the leading "../" from the @INC element. ie a logical "../"
4964          * cleanup
4965          * Finally concatenate the prefix and the remainder of the @INC element
4966          * The intent is that /usr/local/bin/perl and .../../lib/perl5
4967          * generates /usr/local/lib/perl5
4968          */
4969             const char *libpath = SvPVX(libdir);
4970             STRLEN libpath_len = SvCUR(libdir);
4971             if (libpath_len >= 4 && memEQ (libpath, ".../", 4)) {
4972                 /* Game on!  */
4973                 SV * const caret_X = get_sv("\030", 0);
4974                 /* Going to use the SV just as a scratch buffer holding a C
4975                    string:  */
4976                 SV *prefix_sv;
4977                 char *prefix;
4978                 char *lastslash;
4979
4980                 /* $^X is *the* source of taint if tainting is on, hence
4981                    SvPOK() won't be true.  */
4982                 assert(caret_X);
4983                 assert(SvPOKp(caret_X));
4984                 prefix_sv = newSVpvn_flags(SvPVX(caret_X), SvCUR(caret_X),
4985                                            SvUTF8(caret_X));
4986                 /* Firstly take off the leading .../
4987                    If all else fail we'll do the paths relative to the current
4988                    directory.  */
4989                 sv_chop(libdir, libpath + 4);
4990                 /* Don't use SvPV as we're intentionally bypassing taining,
4991                    mortal copies that the mg_get of tainting creates, and
4992                    corruption that seems to come via the save stack.
4993                    I guess that the save stack isn't correctly set up yet.  */
4994                 libpath = SvPVX(libdir);
4995                 libpath_len = SvCUR(libdir);
4996
4997                 /* This would work more efficiently with memrchr, but as it's
4998                    only a GNU extension we'd need to probe for it and
4999                    implement our own. Not hard, but maybe not worth it?  */
5000
5001                 prefix = SvPVX(prefix_sv);
5002                 lastslash = strrchr(prefix, '/');
5003
5004                 /* First time in with the *lastslash = '\0' we just wipe off
5005                    the trailing /perl from (say) /usr/foo/bin/perl
5006                 */
5007                 if (lastslash) {
5008                     SV *tempsv;
5009                     while ((*lastslash = '\0'), /* Do that, come what may.  */
5010                            (libpath_len >= 3 && memEQ(libpath, "../", 3)
5011                             && (lastslash = strrchr(prefix, '/')))) {
5012                         if (lastslash[1] == '\0'
5013                             || (lastslash[1] == '.'
5014                                 && (lastslash[2] == '/' /* ends "/."  */
5015                                     || (lastslash[2] == '/'
5016                                         && lastslash[3] == '/' /* or "/.."  */
5017                                         )))) {
5018                             /* Prefix ends "/" or "/." or "/..", any of which
5019                                are fishy, so don't do any more logical cleanup.
5020                             */
5021                             break;
5022                         }
5023                         /* Remove leading "../" from path  */
5024                         libpath += 3;
5025                         libpath_len -= 3;
5026                         /* Next iteration round the loop removes the last
5027                            directory name from prefix by writing a '\0' in
5028                            the while clause.  */
5029                     }
5030                     /* prefix has been terminated with a '\0' to the correct
5031                        length. libpath points somewhere into the libdir SV.
5032                        We need to join the 2 with '/' and drop the result into
5033                        libdir.  */
5034                     tempsv = Perl_newSVpvf(aTHX_ "%s/%s", prefix, libpath);
5035                     SvREFCNT_dec(libdir);
5036                     /* And this is the new libdir.  */
5037                     libdir = tempsv;
5038                     if (PL_tainting &&
5039                         (PL_uid != PL_euid || PL_gid != PL_egid)) {
5040                         /* Need to taint reloccated paths if running set ID  */
5041                         SvTAINTED_on(libdir);
5042                     }
5043                 }
5044                 SvREFCNT_dec(prefix_sv);
5045             }
5046 #endif
5047         }
5048         /*
5049          * BEFORE pushing libdir onto @INC we may first push version- and
5050          * archname-specific sub-directories.
5051          */
5052         if (addsubdirs || addoldvers) {
5053 #ifdef PERL_INC_VERSION_LIST
5054             /* Configure terminates PERL_INC_VERSION_LIST with a NULL */
5055             const char * const incverlist[] = { PERL_INC_VERSION_LIST };
5056             const char * const *incver;
5057 #endif
5058 #ifdef VMS
5059             char *unix;
5060             STRLEN len;
5061
5062             if ((unix = tounixspec_ts(SvPV(libdir,len),NULL)) != NULL) {
5063                 len = strlen(unix);
5064                 while (unix[len-1] == '/') len--;  /* Cosmetic */
5065                 sv_usepvn(libdir,unix,len);
5066             }
5067             else
5068                 PerlIO_printf(Perl_error_log,
5069                               "Failed to unixify @INC element \"%s\"\n",
5070                               SvPV(libdir,len));
5071 #endif
5072             if (addsubdirs) {
5073 #ifdef MACOS_TRADITIONAL
5074 #define PERL_AV_SUFFIX_FMT      ""
5075 #define PERL_ARCH_FMT           "%s:"
5076 #define PERL_ARCH_FMT_PATH      PERL_FS_VER_FMT PERL_AV_SUFFIX_FMT
5077 #else
5078 #define PERL_AV_SUFFIX_FMT      "/"
5079 #define PERL_ARCH_FMT           "/%s"
5080 #define PERL_ARCH_FMT_PATH      PERL_AV_SUFFIX_FMT PERL_FS_VER_FMT
5081 #endif
5082                 /* .../version/archname if -d .../version/archname */
5083                 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT_PATH PERL_ARCH_FMT,
5084                                SVfARG(libdir),
5085                                (int)PERL_REVISION, (int)PERL_VERSION,
5086                                (int)PERL_SUBVERSION, ARCHNAME);
5087                 subdir = S_incpush_if_exists(aTHX_ subdir);
5088
5089                 /* .../version if -d .../version */
5090                 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT_PATH,
5091                                SVfARG(libdir),
5092                                (int)PERL_REVISION, (int)PERL_VERSION,
5093                                (int)PERL_SUBVERSION);
5094                 subdir = S_incpush_if_exists(aTHX_ subdir);
5095
5096                 /* .../archname if -d .../archname */
5097                 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT,
5098                                SVfARG(libdir), ARCHNAME);
5099                 subdir = S_incpush_if_exists(aTHX_ subdir);
5100
5101             }
5102
5103 #ifdef PERL_INC_VERSION_LIST
5104             if (addoldvers) {
5105                 for (incver = incverlist; *incver; incver++) {
5106                     /* .../xxx if -d .../xxx */
5107                     Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT,
5108                                    SVfARG(libdir), *incver);
5109                     subdir = S_incpush_if_exists(aTHX_ subdir);
5110                 }
5111             }
5112 #endif
5113         }
5114
5115         /* finally add this lib directory at the end of @INC */
5116         if (unshift) {
5117             av_unshift( GvAVn( PL_incgv ), 1 );
5118             av_store( GvAVn( PL_incgv ), 0, libdir );
5119         }
5120         else {
5121             av_push(GvAVn(PL_incgv), libdir);
5122         }
5123     }
5124     if (subdir) {
5125         assert (SvREFCNT(subdir) == 1);
5126         SvREFCNT_dec(subdir);
5127     }
5128 }
5129
5130
5131 void
5132 Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
5133 {
5134     dVAR;
5135     SV *atsv;
5136     volatile const line_t oldline = PL_curcop ? CopLINE(PL_curcop) : 0;
5137     CV *cv;
5138     STRLEN len;
5139     int ret;
5140     dJMPENV;
5141
5142     PERL_ARGS_ASSERT_CALL_LIST;
5143
5144     while (av_len(paramList) >= 0) {
5145         cv = MUTABLE_CV(av_shift(paramList));
5146         if (PL_savebegin) {
5147             if (paramList == PL_beginav) {
5148                 /* save PL_beginav for compiler */
5149                 Perl_av_create_and_push(aTHX_ &PL_beginav_save, MUTABLE_SV(cv));
5150             }
5151             else if (paramList == PL_checkav) {
5152                 /* save PL_checkav for compiler */
5153                 Perl_av_create_and_push(aTHX_ &PL_checkav_save, MUTABLE_SV(cv));
5154             }
5155             else if (paramList == PL_unitcheckav) {
5156                 /* save PL_unitcheckav for compiler */
5157                 Perl_av_create_and_push(aTHX_ &PL_unitcheckav_save, MUTABLE_SV(cv));
5158             }
5159         } else {
5160             if (!PL_madskills)
5161                 SAVEFREESV(cv);
5162         }
5163         JMPENV_PUSH(ret);
5164         switch (ret) {
5165         case 0:
5166 #ifdef PERL_MAD
5167             if (PL_madskills)
5168                 PL_madskills |= 16384;
5169 #endif
5170             CALL_LIST_BODY(cv);
5171 #ifdef PERL_MAD
5172             if (PL_madskills)
5173                 PL_madskills &= ~16384;
5174 #endif
5175             atsv = ERRSV;
5176             (void)SvPV_const(atsv, len);
5177             if (len) {
5178                 PL_curcop = &PL_compiling;
5179                 CopLINE_set(PL_curcop, oldline);
5180                 if (paramList == PL_beginav)
5181                     sv_catpvs(atsv, "BEGIN failed--compilation aborted");
5182                 else
5183                     Perl_sv_catpvf(aTHX_ atsv,
5184                                    "%s failed--call queue aborted",
5185                                    paramList == PL_checkav ? "CHECK"
5186                                    : paramList == PL_initav ? "INIT"
5187                                    : paramList == PL_unitcheckav ? "UNITCHECK"
5188                                    : "END");
5189                 while (PL_scopestack_ix > oldscope)
5190                     LEAVE;
5191                 JMPENV_POP;
5192                 Perl_croak(aTHX_ "%"SVf"", SVfARG(atsv));
5193             }
5194             break;
5195         case 1:
5196             STATUS_ALL_FAILURE;
5197             /* FALL THROUGH */
5198         case 2:
5199             /* my_exit() was called */
5200             while (PL_scopestack_ix > oldscope)
5201                 LEAVE;
5202             FREETMPS;
5203             PL_curstash = PL_defstash;
5204             PL_curcop = &PL_compiling;
5205             CopLINE_set(PL_curcop, oldline);
5206             JMPENV_POP;
5207             if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED)) {
5208                 if (paramList == PL_beginav)
5209                     Perl_croak(aTHX_ "BEGIN failed--compilation aborted");
5210                 else
5211                     Perl_croak(aTHX_ "%s failed--call queue aborted",
5212                                paramList == PL_checkav ? "CHECK"
5213                                : paramList == PL_initav ? "INIT"
5214                                : paramList == PL_unitcheckav ? "UNITCHECK"
5215                                : "END");
5216             }
5217             my_exit_jump();
5218             /* NOTREACHED */
5219         case 3:
5220             if (PL_restartop) {
5221                 PL_curcop = &PL_compiling;
5222                 CopLINE_set(PL_curcop, oldline);
5223                 JMPENV_JUMP(3);
5224             }
5225             PerlIO_printf(Perl_error_log, "panic: restartop\n");
5226             FREETMPS;
5227             break;
5228         }
5229         JMPENV_POP;
5230     }
5231 }
5232
5233 void
5234 Perl_my_exit(pTHX_ U32 status)
5235 {
5236     dVAR;
5237     switch (status) {
5238     case 0:
5239         STATUS_ALL_SUCCESS;
5240         break;
5241     case 1:
5242         STATUS_ALL_FAILURE;
5243         break;
5244     default:
5245         STATUS_EXIT_SET(status);
5246         break;
5247     }
5248     my_exit_jump();
5249 }
5250
5251 void
5252 Perl_my_failure_exit(pTHX)
5253 {
5254     dVAR;
5255 #ifdef VMS
5256      /* We have been called to fall on our sword.  The desired exit code
5257       * should be already set in STATUS_UNIX, but could be shifted over
5258       * by 8 bits.  STATUS_UNIX_EXIT_SET will handle the cases where a
5259       * that code is set.
5260       *
5261       * If an error code has not been set, then force the issue.
5262       */
5263     if (MY_POSIX_EXIT) {
5264
5265         /* According to the die_exit.t tests, if errno is non-zero */
5266         /* It should be used for the error status. */
5267
5268         if (errno == EVMSERR) {
5269             STATUS_NATIVE = vaxc$errno;
5270         } else {
5271
5272             /* According to die_exit.t tests, if the child_exit code is */
5273             /* also zero, then we need to exit with a code of 255 */
5274             if ((errno != 0) && (errno < 256))
5275                 STATUS_UNIX_EXIT_SET(errno);
5276             else if (STATUS_UNIX < 255) {
5277                 STATUS_UNIX_EXIT_SET(255);
5278             }
5279
5280         }
5281
5282         /* The exit code could have been set by $? or vmsish which
5283          * means that it may not have fatal set.  So convert
5284          * success/warning codes to fatal with out changing
5285          * the POSIX status code.  The severity makes VMS native
5286          * status handling work, while UNIX mode programs use the
5287          * the POSIX exit codes.
5288          */
5289          if ((STATUS_NATIVE & (STS$K_SEVERE|STS$K_ERROR)) == 0) {
5290             STATUS_NATIVE &= STS$M_COND_ID;
5291             STATUS_NATIVE |= STS$K_ERROR | STS$M_INHIB_MSG;
5292          }
5293     }
5294     else {
5295         /* Traditionally Perl on VMS always expects a Fatal Error. */
5296         if (vaxc$errno & 1) {
5297
5298             /* So force success status to failure */
5299             if (STATUS_NATIVE & 1)
5300                 STATUS_ALL_FAILURE;
5301         }
5302         else {
5303             if (!vaxc$errno) {
5304                 STATUS_UNIX = EINTR; /* In case something cares */
5305                 STATUS_ALL_FAILURE;
5306             }
5307             else {
5308                 int severity;
5309                 STATUS_NATIVE = vaxc$errno; /* Should already be this */
5310
5311                 /* Encode the severity code */
5312                 severity = STATUS_NATIVE & STS$M_SEVERITY;
5313                 STATUS_UNIX = (severity ? severity : 1) << 8;
5314
5315                 /* Perl expects this to be a fatal error */
5316                 if (severity != STS$K_SEVERE)
5317                     STATUS_ALL_FAILURE;
5318             }
5319         }
5320     }
5321
5322 #else
5323     int exitstatus;
5324     if (errno & 255)
5325         STATUS_UNIX_SET(errno);
5326     else {
5327         exitstatus = STATUS_UNIX >> 8;
5328         if (exitstatus & 255)
5329             STATUS_UNIX_SET(exitstatus);
5330         else
5331             STATUS_UNIX_SET(255);
5332     }
5333 #endif
5334     my_exit_jump();
5335 }
5336
5337 STATIC void
5338 S_my_exit_jump(pTHX)
5339 {
5340     dVAR;
5341
5342     if (PL_e_script) {
5343         SvREFCNT_dec(PL_e_script);
5344         PL_e_script = NULL;
5345     }
5346
5347     POPSTACK_TO(PL_mainstack);
5348     dounwind(-1);
5349     LEAVE_SCOPE(0);
5350
5351     JMPENV_JUMP(2);
5352 }
5353
5354 static I32
5355 read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen)
5356 {
5357     dVAR;
5358     const char * const p  = SvPVX_const(PL_e_script);
5359     const char *nl = strchr(p, '\n');
5360
5361     PERL_UNUSED_ARG(idx);
5362     PERL_UNUSED_ARG(maxlen);
5363
5364     nl = (nl) ? nl+1 : SvEND(PL_e_script);
5365     if (nl-p == 0) {
5366         filter_del(read_e_script);
5367         return 0;
5368     }
5369     sv_catpvn(buf_sv, p, nl-p);
5370     sv_chop(PL_e_script, nl);
5371     return 1;
5372 }
5373
5374 /*
5375  * Local variables:
5376  * c-indentation-style: bsd
5377  * c-basic-offset: 4
5378  * indent-tabs-mode: t
5379  * End:
5380  *
5381  * ex: set ts=8 sts=4 sw=4 noet:
5382  */