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