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