This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
53129a80b3ed9eef57b3c3e14dcb4d8621529de6
[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_fetchpv("\030",TRUE, 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_fetchpv("\017PEN", TRUE, SVt_PV)))) {
2239                    U32 in  = PL_unicode & PERL_UNICODE_IN_FLAG;
2240                    U32 out = PL_unicode & PERL_UNICODE_OUT_FLAG;
2241                    if (in) {
2242                         if (out)
2243                              sv_setpvn(sv, ":utf8\0:utf8", 11);
2244                         else
2245                              sv_setpvn(sv, ":utf8\0", 6);
2246                    }
2247                    else if (out)
2248                         sv_setpvn(sv, "\0:utf8", 6);
2249                    SvSETMAGIC(sv);
2250               }
2251          }
2252     }
2253
2254     if ((s = PerlEnv_getenv("PERL_SIGNALS"))) {
2255          if (strEQ(s, "unsafe"))
2256               PL_signals |=  PERL_SIGNALS_UNSAFE_FLAG;
2257          else if (strEQ(s, "safe"))
2258               PL_signals &= ~PERL_SIGNALS_UNSAFE_FLAG;
2259          else
2260               Perl_croak(aTHX_ "PERL_SIGNALS illegal: \"%s\"", s);
2261     }
2262
2263     init_lexer();
2264
2265     /* now parse the script */
2266
2267     SETERRNO(0,SS_NORMAL);
2268     PL_error_count = 0;
2269 #ifdef MACOS_TRADITIONAL
2270     if (gMacPerl_SyntaxError = (yyparse() || PL_error_count)) {
2271         if (PL_minus_c)
2272             Perl_croak(aTHX_ "%s had compilation errors.\n", MacPerl_MPWFileName(PL_origfilename));
2273         else {
2274             Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
2275                        MacPerl_MPWFileName(PL_origfilename));
2276         }
2277     }
2278 #else
2279     if (yyparse() || PL_error_count) {
2280         if (PL_minus_c)
2281             Perl_croak(aTHX_ "%s had compilation errors.\n", PL_origfilename);
2282         else {
2283             Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
2284                        PL_origfilename);
2285         }
2286     }
2287 #endif
2288     CopLINE_set(PL_curcop, 0);
2289     PL_curstash = PL_defstash;
2290     PL_preprocess = FALSE;
2291     if (PL_e_script) {
2292         SvREFCNT_dec(PL_e_script);
2293         PL_e_script = NULL;
2294     }
2295
2296     if (PL_do_undump)
2297         my_unexec();
2298
2299     if (isWARN_ONCE) {
2300         SAVECOPFILE(PL_curcop);
2301         SAVECOPLINE(PL_curcop);
2302         gv_check(PL_defstash);
2303     }
2304
2305     LEAVE;
2306     FREETMPS;
2307
2308 #ifdef MYMALLOC
2309     if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
2310         dump_mstats("after compilation:");
2311 #endif
2312
2313     ENTER;
2314     PL_restartop = 0;
2315     return NULL;
2316 }
2317
2318 /*
2319 =for apidoc perl_run
2320
2321 Tells a Perl interpreter to run.  See L<perlembed>.
2322
2323 =cut
2324 */
2325
2326 int
2327 perl_run(pTHXx)
2328 {
2329     I32 oldscope;
2330     int ret = 0;
2331     dJMPENV;
2332 #ifdef USE_5005THREADS
2333     dTHX;
2334 #endif
2335
2336     PERL_UNUSED_ARG(my_perl);
2337
2338     oldscope = PL_scopestack_ix;
2339 #ifdef VMS
2340     VMSISH_HUSHED = 0;
2341 #endif
2342
2343 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2344  redo_body:
2345     CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vrun_body), oldscope);
2346 #else
2347     JMPENV_PUSH(ret);
2348 #endif
2349     switch (ret) {
2350     case 1:
2351         cxstack_ix = -1;                /* start context stack again */
2352         goto redo_body;
2353     case 0:                             /* normal completion */
2354 #ifndef PERL_FLEXIBLE_EXCEPTIONS
2355  redo_body:
2356         run_body(oldscope);
2357 #endif
2358         /* FALL THROUGH */
2359     case 2:                             /* my_exit() */
2360         while (PL_scopestack_ix > oldscope)
2361             LEAVE;
2362         FREETMPS;
2363         PL_curstash = PL_defstash;
2364         if (!(PL_exit_flags & PERL_EXIT_DESTRUCT_END) &&
2365             PL_endav && !PL_minus_c)
2366             call_list(oldscope, PL_endav);
2367 #ifdef MYMALLOC
2368         if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
2369             dump_mstats("after execution:  ");
2370 #endif
2371         ret = STATUS_EXIT;
2372         break;
2373     case 3:
2374         if (PL_restartop) {
2375             POPSTACK_TO(PL_mainstack);
2376             goto redo_body;
2377         }
2378         PerlIO_printf(Perl_error_log, "panic: restartop\n");
2379         FREETMPS;
2380         ret = 1;
2381         break;
2382     }
2383
2384     JMPENV_POP;
2385     return ret;
2386 }
2387
2388 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2389 STATIC void *
2390 S_vrun_body(pTHX_ va_list args)
2391 {
2392     I32 oldscope = va_arg(args, I32);
2393
2394     run_body(oldscope);
2395     return NULL;
2396 }
2397 #endif
2398
2399
2400 STATIC void
2401 S_run_body(pTHX_ I32 oldscope)
2402 {
2403     DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
2404                     PL_sawampersand ? "Enabling" : "Omitting"));
2405
2406     if (!PL_restartop) {
2407         DEBUG_x(dump_all());
2408 #ifdef DEBUGGING
2409         if (!DEBUG_q_TEST)
2410           PERL_DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
2411 #endif
2412         DEBUG_S(PerlIO_printf(Perl_debug_log, "main thread is 0x%"UVxf"\n",
2413                               PTR2UV(thr)));
2414
2415         if (PL_minus_c) {
2416 #ifdef MACOS_TRADITIONAL
2417             PerlIO_printf(Perl_error_log, "%s%s syntax OK\n",
2418                 (gMacPerl_ErrorFormat ? "# " : ""),
2419                 MacPerl_MPWFileName(PL_origfilename));
2420 #else
2421             PerlIO_printf(Perl_error_log, "%s syntax OK\n", PL_origfilename);
2422 #endif
2423             my_exit(0);
2424         }
2425         if (PERLDB_SINGLE && PL_DBsingle)
2426             sv_setiv(PL_DBsingle, 1);
2427         if (PL_initav)
2428             call_list(oldscope, PL_initav);
2429     }
2430
2431     /* do it */
2432
2433     if (PL_restartop) {
2434         PL_op = PL_restartop;
2435         PL_restartop = 0;
2436         CALLRUNOPS(aTHX);
2437     }
2438     else if (PL_main_start) {
2439         CvDEPTH(PL_main_cv) = 1;
2440         PL_op = PL_main_start;
2441         CALLRUNOPS(aTHX);
2442     }
2443     my_exit(0);
2444     /* NOTREACHED */
2445 }
2446
2447 /*
2448 =head1 SV Manipulation Functions
2449
2450 =for apidoc p||get_sv
2451
2452 Returns the SV of the specified Perl scalar.  If C<create> is set and the
2453 Perl variable does not exist then it will be created.  If C<create> is not
2454 set and the variable does not exist then NULL is returned.
2455
2456 =cut
2457 */
2458
2459 SV*
2460 Perl_get_sv(pTHX_ const char *name, I32 create)
2461 {
2462     GV *gv;
2463 #ifdef USE_5005THREADS
2464     if (name[1] == '\0' && !isALPHA(name[0])) {
2465         PADOFFSET tmp = find_threadsv(name);
2466         if (tmp != NOT_IN_PAD)
2467             return THREADSV(tmp);
2468     }
2469 #endif /* USE_5005THREADS */
2470     gv = gv_fetchpv(name, create, SVt_PV);
2471     if (gv)
2472         return GvSV(gv);
2473     return NULL;
2474 }
2475
2476 /*
2477 =head1 Array Manipulation Functions
2478
2479 =for apidoc p||get_av
2480
2481 Returns the AV of the specified Perl array.  If C<create> is set and the
2482 Perl variable does not exist then it will be created.  If C<create> is not
2483 set and the variable does not exist then NULL is returned.
2484
2485 =cut
2486 */
2487
2488 AV*
2489 Perl_get_av(pTHX_ const char *name, I32 create)
2490 {
2491     GV* const gv = gv_fetchpv(name, create, SVt_PVAV);
2492     if (create)
2493         return GvAVn(gv);
2494     if (gv)
2495         return GvAV(gv);
2496     return NULL;
2497 }
2498
2499 /*
2500 =head1 Hash Manipulation Functions
2501
2502 =for apidoc p||get_hv
2503
2504 Returns the HV of the specified Perl hash.  If C<create> is set and the
2505 Perl variable does not exist then it will be created.  If C<create> is not
2506 set and the variable does not exist then NULL is returned.
2507
2508 =cut
2509 */
2510
2511 HV*
2512 Perl_get_hv(pTHX_ const char *name, I32 create)
2513 {
2514     GV* const gv = gv_fetchpv(name, create, SVt_PVHV);
2515     if (create)
2516         return GvHVn(gv);
2517     if (gv)
2518         return GvHV(gv);
2519     return NULL;
2520 }
2521
2522 /*
2523 =head1 CV Manipulation Functions
2524
2525 =for apidoc p||get_cv
2526
2527 Returns the CV of the specified Perl subroutine.  If C<create> is set and
2528 the Perl subroutine does not exist then it will be declared (which has the
2529 same effect as saying C<sub name;>).  If C<create> is not set and the
2530 subroutine does not exist then NULL is returned.
2531
2532 =cut
2533 */
2534
2535 CV*
2536 Perl_get_cv(pTHX_ const char *name, I32 create)
2537 {
2538     GV* const gv = gv_fetchpv(name, create, SVt_PVCV);
2539     /* XXX unsafe for threads if eval_owner isn't held */
2540     /* XXX this is probably not what they think they're getting.
2541      * It has the same effect as "sub name;", i.e. just a forward
2542      * declaration! */
2543     if (create && !GvCVu(gv))
2544         return newSUB(start_subparse(FALSE, 0),
2545                       newSVOP(OP_CONST, 0, newSVpv(name,0)),
2546                       Nullop,
2547                       Nullop);
2548     if (gv)
2549         return GvCVu(gv);
2550     return Nullcv;
2551 }
2552
2553 /* Be sure to refetch the stack pointer after calling these routines. */
2554
2555 /*
2556
2557 =head1 Callback Functions
2558
2559 =for apidoc p||call_argv
2560
2561 Performs a callback to the specified Perl sub.  See L<perlcall>.
2562
2563 =cut
2564 */
2565
2566 I32
2567 Perl_call_argv(pTHX_ const char *sub_name, I32 flags, register char **argv)
2568
2569                         /* See G_* flags in cop.h */
2570                         /* null terminated arg list */
2571 {
2572     dSP;
2573
2574     PUSHMARK(SP);
2575     if (argv) {
2576         while (*argv) {
2577             XPUSHs(sv_2mortal(newSVpv(*argv,0)));
2578             argv++;
2579         }
2580         PUTBACK;
2581     }
2582     return call_pv(sub_name, flags);
2583 }
2584
2585 /*
2586 =for apidoc p||call_pv
2587
2588 Performs a callback to the specified Perl sub.  See L<perlcall>.
2589
2590 =cut
2591 */
2592
2593 I32
2594 Perl_call_pv(pTHX_ const char *sub_name, I32 flags)
2595                         /* name of the subroutine */
2596                         /* See G_* flags in cop.h */
2597 {
2598     return call_sv((SV*)get_cv(sub_name, TRUE), flags);
2599 }
2600
2601 /*
2602 =for apidoc p||call_method
2603
2604 Performs a callback to the specified Perl method.  The blessed object must
2605 be on the stack.  See L<perlcall>.
2606
2607 =cut
2608 */
2609
2610 I32
2611 Perl_call_method(pTHX_ const char *methname, I32 flags)
2612                         /* name of the subroutine */
2613                         /* See G_* flags in cop.h */
2614 {
2615     return call_sv(sv_2mortal(newSVpv(methname,0)), flags | G_METHOD);
2616 }
2617
2618 /* May be called with any of a CV, a GV, or an SV containing the name. */
2619 /*
2620 =for apidoc p||call_sv
2621
2622 Performs a callback to the Perl sub whose name is in the SV.  See
2623 L<perlcall>.
2624
2625 =cut
2626 */
2627
2628 I32
2629 Perl_call_sv(pTHX_ SV *sv, I32 flags)
2630                         /* See G_* flags in cop.h */
2631 {
2632     dSP;
2633     LOGOP myop;         /* fake syntax tree node */
2634     UNOP method_op;
2635     I32 oldmark;
2636     volatile I32 retval = 0;
2637     I32 oldscope;
2638     bool oldcatch = CATCH_GET;
2639     int ret;
2640     OP* const oldop = PL_op;
2641     dJMPENV;
2642
2643     if (flags & G_DISCARD) {
2644         ENTER;
2645         SAVETMPS;
2646     }
2647
2648     Zero(&myop, 1, LOGOP);
2649     myop.op_next = Nullop;
2650     if (!(flags & G_NOARGS))
2651         myop.op_flags |= OPf_STACKED;
2652     myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
2653                       (flags & G_ARRAY) ? OPf_WANT_LIST :
2654                       OPf_WANT_SCALAR);
2655     SAVEOP();
2656     PL_op = (OP*)&myop;
2657
2658     EXTEND(PL_stack_sp, 1);
2659     *++PL_stack_sp = sv;
2660     oldmark = TOPMARK;
2661     oldscope = PL_scopestack_ix;
2662
2663     if (PERLDB_SUB && PL_curstash != PL_debstash
2664            /* Handle first BEGIN of -d. */
2665           && (PL_DBcv || (PL_DBcv = GvCV(PL_DBsub)))
2666            /* Try harder, since this may have been a sighandler, thus
2667             * curstash may be meaningless. */
2668           && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != PL_debstash)
2669           && !(flags & G_NODEBUG))
2670         PL_op->op_private |= OPpENTERSUB_DB;
2671
2672     if (flags & G_METHOD) {
2673         Zero(&method_op, 1, UNOP);
2674         method_op.op_next = PL_op;
2675         method_op.op_ppaddr = PL_ppaddr[OP_METHOD];
2676         myop.op_ppaddr = PL_ppaddr[OP_ENTERSUB];
2677         PL_op = (OP*)&method_op;
2678     }
2679
2680     if (!(flags & G_EVAL)) {
2681         CATCH_SET(TRUE);
2682         call_body((OP*)&myop, FALSE);
2683         retval = PL_stack_sp - (PL_stack_base + oldmark);
2684         CATCH_SET(oldcatch);
2685     }
2686     else {
2687         myop.op_other = (OP*)&myop;
2688         PL_markstack_ptr--;
2689         /* we're trying to emulate pp_entertry() here */
2690         {
2691             register PERL_CONTEXT *cx;
2692             const I32 gimme = GIMME_V;
2693         
2694             ENTER;
2695             SAVETMPS;
2696         
2697             push_return(Nullop);
2698             PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
2699             PUSHEVAL(cx, 0, 0);
2700             PL_eval_root = PL_op;             /* Only needed so that goto works right. */
2701         
2702             PL_in_eval = EVAL_INEVAL;
2703             if (flags & G_KEEPERR)
2704                 PL_in_eval |= EVAL_KEEPERR;
2705             else
2706                 sv_setpvn(ERRSV,"",0);
2707         }
2708         PL_markstack_ptr++;
2709
2710 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2711  redo_body:
2712         CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_body),
2713                     (OP*)&myop, FALSE);
2714 #else
2715         JMPENV_PUSH(ret);
2716 #endif
2717         switch (ret) {
2718         case 0:
2719 #ifndef PERL_FLEXIBLE_EXCEPTIONS
2720  redo_body:
2721             call_body((OP*)&myop, FALSE);
2722 #endif
2723             retval = PL_stack_sp - (PL_stack_base + oldmark);
2724             if (!(flags & G_KEEPERR))
2725                 sv_setpvn(ERRSV,"",0);
2726             break;
2727         case 1:
2728             STATUS_ALL_FAILURE;
2729             /* FALL THROUGH */
2730         case 2:
2731             /* my_exit() was called */
2732             PL_curstash = PL_defstash;
2733             FREETMPS;
2734             JMPENV_POP;
2735             if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
2736                 Perl_croak(aTHX_ "Callback called exit");
2737             my_exit_jump();
2738             /* NOTREACHED */
2739         case 3:
2740             if (PL_restartop) {
2741                 PL_op = PL_restartop;
2742                 PL_restartop = 0;
2743                 goto redo_body;
2744             }
2745             PL_stack_sp = PL_stack_base + oldmark;
2746             if (flags & G_ARRAY)
2747                 retval = 0;
2748             else {
2749                 retval = 1;
2750                 *++PL_stack_sp = &PL_sv_undef;
2751             }
2752             break;
2753         }
2754
2755         if (PL_scopestack_ix > oldscope) {
2756             SV **newsp;
2757             PMOP *newpm;
2758             I32 gimme;
2759             register PERL_CONTEXT *cx;
2760             I32 optype;
2761
2762             POPBLOCK(cx,newpm);
2763             POPEVAL(cx);
2764             pop_return();
2765             PL_curpm = newpm;
2766             LEAVE;
2767             PERL_UNUSED_VAR(newsp);
2768             PERL_UNUSED_VAR(gimme);
2769             PERL_UNUSED_VAR(optype);
2770         }
2771         JMPENV_POP;
2772     }
2773
2774     if (flags & G_DISCARD) {
2775         PL_stack_sp = PL_stack_base + oldmark;
2776         retval = 0;
2777         FREETMPS;
2778         LEAVE;
2779     }
2780     PL_op = oldop;
2781     return retval;
2782 }
2783
2784 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2785 STATIC void *
2786 S_vcall_body(pTHX_ va_list args)
2787 {
2788     OP *myop = va_arg(args, OP*);
2789     int is_eval = va_arg(args, int);
2790
2791     call_body(myop, is_eval);
2792     return NULL;
2793 }
2794 #endif
2795
2796 STATIC void
2797 S_call_body(pTHX_ const OP *myop, bool is_eval)
2798 {
2799     if (PL_op == myop) {
2800         if (is_eval)
2801             PL_op = Perl_pp_entereval(aTHX);    /* this doesn't do a POPMARK */
2802         else
2803             PL_op = Perl_pp_entersub(aTHX);     /* this does */
2804     }
2805     if (PL_op)
2806         CALLRUNOPS(aTHX);
2807 }
2808
2809 /* Eval a string. The G_EVAL flag is always assumed. */
2810
2811 /*
2812 =for apidoc p||eval_sv
2813
2814 Tells Perl to C<eval> the string in the SV.
2815
2816 =cut
2817 */
2818
2819 I32
2820 Perl_eval_sv(pTHX_ SV *sv, I32 flags)
2821
2822                         /* See G_* flags in cop.h */
2823 {
2824     dSP;
2825     UNOP myop;          /* fake syntax tree node */
2826     volatile I32 oldmark = SP - PL_stack_base;
2827     volatile I32 retval = 0;
2828     int ret;
2829     OP* const oldop = PL_op;
2830     dJMPENV;
2831
2832     if (flags & G_DISCARD) {
2833         ENTER;
2834         SAVETMPS;
2835     }
2836
2837     SAVEOP();
2838     PL_op = (OP*)&myop;
2839     Zero(PL_op, 1, UNOP);
2840     EXTEND(PL_stack_sp, 1);
2841     *++PL_stack_sp = sv;
2842
2843     if (!(flags & G_NOARGS))
2844         myop.op_flags = OPf_STACKED;
2845     myop.op_next = Nullop;
2846     myop.op_type = OP_ENTEREVAL;
2847     myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
2848                       (flags & G_ARRAY) ? OPf_WANT_LIST :
2849                       OPf_WANT_SCALAR);
2850     if (flags & G_KEEPERR)
2851         myop.op_flags |= OPf_SPECIAL;
2852
2853 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2854  redo_body:
2855     CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_body),
2856                 (OP*)&myop, TRUE);
2857 #else
2858     /* fail now; otherwise we could fail after the JMPENV_PUSH but
2859      * before a PUSHEVAL, which corrupts the stack after a croak */
2860     TAINT_PROPER("eval_sv()");
2861
2862     JMPENV_PUSH(ret);
2863 #endif
2864     switch (ret) {
2865     case 0:
2866 #ifndef PERL_FLEXIBLE_EXCEPTIONS
2867  redo_body:
2868         call_body((OP*)&myop,TRUE);
2869 #endif
2870         retval = PL_stack_sp - (PL_stack_base + oldmark);
2871         if (!(flags & G_KEEPERR))
2872             sv_setpvn(ERRSV,"",0);
2873         break;
2874     case 1:
2875         STATUS_ALL_FAILURE;
2876         /* FALL THROUGH */
2877     case 2:
2878         /* my_exit() was called */
2879         PL_curstash = PL_defstash;
2880         FREETMPS;
2881         JMPENV_POP;
2882         if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
2883             Perl_croak(aTHX_ "Callback called exit");
2884         my_exit_jump();
2885         /* NOTREACHED */
2886     case 3:
2887         if (PL_restartop) {
2888             PL_op = PL_restartop;
2889             PL_restartop = 0;
2890             goto redo_body;
2891         }
2892         PL_stack_sp = PL_stack_base + oldmark;
2893         if (flags & G_ARRAY)
2894             retval = 0;
2895         else {
2896             retval = 1;
2897             *++PL_stack_sp = &PL_sv_undef;
2898         }
2899         break;
2900     }
2901
2902     JMPENV_POP;
2903     if (flags & G_DISCARD) {
2904         PL_stack_sp = PL_stack_base + oldmark;
2905         retval = 0;
2906         FREETMPS;
2907         LEAVE;
2908     }
2909     PL_op = oldop;
2910     return retval;
2911 }
2912
2913 /*
2914 =for apidoc p||eval_pv
2915
2916 Tells Perl to C<eval> the given string and return an SV* result.
2917
2918 =cut
2919 */
2920
2921 SV*
2922 Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error)
2923 {
2924     dSP;
2925     SV* sv = newSVpv(p, 0);
2926
2927     eval_sv(sv, G_SCALAR);
2928     SvREFCNT_dec(sv);
2929
2930     SPAGAIN;
2931     sv = POPs;
2932     PUTBACK;
2933
2934     if (croak_on_error && SvTRUE(ERRSV)) {
2935         Perl_croak(aTHX_ SvPVx_nolen_const(ERRSV));
2936     }
2937
2938     return sv;
2939 }
2940
2941 /* Require a module. */
2942
2943 /*
2944 =head1 Embedding Functions
2945
2946 =for apidoc p||require_pv
2947
2948 Tells Perl to C<require> the file named by the string argument.  It is
2949 analogous to the Perl code C<eval "require '$file'">.  It's even
2950 implemented that way; consider using load_module instead.
2951
2952 =cut */
2953
2954 void
2955 Perl_require_pv(pTHX_ const char *pv)
2956 {
2957     SV* sv;
2958     dSP;
2959     PUSHSTACKi(PERLSI_REQUIRE);
2960     PUTBACK;
2961     sv = Perl_newSVpvf(aTHX_ "require q%c%s%c", 0, pv, 0);
2962     eval_sv(sv_2mortal(sv), G_DISCARD);
2963     SPAGAIN;
2964     POPSTACK;
2965 }
2966
2967 void
2968 Perl_magicname(pTHX_ char *sym, char *name, I32 namlen)
2969 {
2970     register GV * const gv = gv_fetchpv(sym,TRUE, SVt_PV);
2971
2972     if (gv)
2973         sv_magic(GvSV(gv), (SV*)gv, PERL_MAGIC_sv, name, namlen);
2974 }
2975
2976 STATIC void
2977 S_usage(pTHX_ const char *name)         /* XXX move this out into a module ? */
2978 {
2979     /* This message really ought to be max 23 lines.
2980      * Removed -h because the user already knows that option. Others? */
2981
2982     static const char * const usage_msg[] = {
2983 "-0[octal]       specify record separator (\\0, if no argument)",
2984 "-a              autosplit mode with -n or -p (splits $_ into @F)",
2985 "-C[number/list] enables the listed Unicode features",
2986 "-c              check syntax only (runs BEGIN and CHECK blocks)",
2987 "-d[:debugger]   run program under debugger",
2988 "-D[number/list] set debugging flags (argument is a bit mask or alphabets)",
2989 "-e program      one line of program (several -e's allowed, omit programfile)",
2990 "-f              don't do $sitelib/sitecustomize.pl at startup",
2991 "-F/pattern/     split() pattern for -a switch (//'s are optional)",
2992 "-i[extension]   edit <> files in place (makes backup if extension supplied)",
2993 "-Idirectory     specify @INC/#include directory (several -I's allowed)",
2994 "-l[octal]       enable line ending processing, specifies line terminator",
2995 "-[mM][-]module  execute \"use/no module...\" before executing program",
2996 "-n              assume \"while (<>) { ... }\" loop around program",
2997 "-p              assume loop like -n but print line also, like sed",
2998 "-P              run program through C preprocessor before compilation",
2999 "-s              enable rudimentary parsing for switches after programfile",
3000 "-S              look for programfile using PATH environment variable",
3001 "-t              enable tainting warnings",
3002 "-T              enable tainting checks",
3003 "-u              dump core after parsing program",
3004 "-U              allow unsafe operations",
3005 "-v              print version, subversion (includes VERY IMPORTANT perl info)",
3006 "-V[:variable]   print configuration summary (or a single Config.pm variable)",
3007 "-w              enable many useful warnings (RECOMMENDED)",
3008 "-W              enable all warnings",
3009 "-x[directory]   strip off text before #!perl line and perhaps cd to directory",
3010 "-X              disable all warnings",
3011 "\n",
3012 NULL
3013 };
3014     const char * const *p = usage_msg;
3015
3016     PerlIO_printf(PerlIO_stdout(),
3017                   "\nUsage: %s [switches] [--] [programfile] [arguments]",
3018                   name);
3019     while (*p)
3020         PerlIO_printf(PerlIO_stdout(), "\n  %s", *p++);
3021 }
3022
3023 /* convert a string of -D options (or digits) into an int.
3024  * sets *s to point to the char after the options */
3025
3026 #ifdef DEBUGGING
3027 int
3028 Perl_get_debug_opts(pTHX_ char **s)
3029 {
3030   return get_debug_opts_flags(s, 1);
3031 }
3032
3033 int
3034 Perl_get_debug_opts_flags(pTHX_ char **s, int flags)
3035 {
3036     static const char * const usage_msgd[] = {
3037       " Debugging flag values: (see also -d)",
3038       "  p  Tokenizing and parsing (with v, displays parse stack)",
3039       "  s  Stack snapshots (with v, displays all stacks)",
3040       "  l  Context (loop) stack processing",
3041       "  t  Trace execution",
3042       "  o  Method and overloading resolution",
3043       "  c  String/numeric conversions",
3044       "  P  Print profiling info, preprocessor command for -P, source file input state",
3045       "  m  Memory allocation",
3046       "  f  Format processing",
3047       "  r  Regular expression parsing and execution",
3048       "  x  Syntax tree dump",
3049       "  u  Tainting checks",
3050       "  H  Hash dump -- usurps values()",
3051       "  X  Scratchpad allocation",
3052       "  D  Cleaning up",
3053       "  S  Thread synchronization",
3054       "  T  Tokenising",
3055       "  R  Include reference counts of dumped variables (eg when using -Ds)",
3056       "  J  Do not s,t,P-debug (Jump over) opcodes within package DB",
3057       "  v  Verbose: use in conjunction with other flags",
3058       "  C  Copy On Write",
3059       "  A  Consistency checks on internal structures",
3060       "  q  quiet - currently only suppresses the 'EXECUTING' message",
3061       NULL
3062     };
3063     int i = 0;
3064     if (isALPHA(**s)) {
3065         /* if adding extra options, remember to update DEBUG_MASK */
3066         static const char debopts[] = "psltocPmfrxu HXDSTRJvCAq";
3067
3068         for (; isALNUM(**s); (*s)++) {
3069             const char * const d = strchr(debopts,**s);
3070             if (d)
3071                 i |= 1 << (d - debopts);
3072             else if (ckWARN_d(WARN_DEBUGGING))
3073                 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
3074                     "invalid option -D%c, use -D'' to see choices\n", **s);
3075         }
3076     }
3077     else if (isDIGIT(**s)) {
3078         i = atoi(*s);
3079         for (; isALNUM(**s); (*s)++) ;
3080     }
3081     else if (flags & 1) {
3082       /* Give help.  */
3083       const char *const *p = usage_msgd;
3084       while (*p) PerlIO_printf(PerlIO_stdout(), "%s\n", *p++);
3085     }
3086 #  ifdef EBCDIC
3087     if ((i & DEBUG_p_FLAG) && ckWARN_d(WARN_DEBUGGING))
3088         Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
3089                 "-Dp not implemented on this platform\n");
3090 #  endif
3091     return i;
3092 }
3093 #endif
3094
3095 /* This routine handles any switches that can be given during run */
3096
3097 char *
3098 Perl_moreswitches(pTHX_ char *s)
3099 {
3100     UV rschar;
3101
3102     switch (*s) {
3103     case '0':
3104     {
3105          I32 flags = 0;
3106          STRLEN numlen;
3107
3108          SvREFCNT_dec(PL_rs);
3109          if (s[1] == 'x' && s[2]) {
3110               const char *e = s+=2;
3111               U8 *tmps;
3112
3113               while (*e)
3114                 e++;
3115               numlen = e - s;
3116               flags = PERL_SCAN_SILENT_ILLDIGIT;
3117               rschar = (U32)grok_hex(s, &numlen, &flags, NULL);
3118               if (s + numlen < e) {
3119                    rschar = 0; /* Grandfather -0xFOO as -0 -xFOO. */
3120                    numlen = 0;
3121                    s--;
3122               }
3123               PL_rs = newSVpvs("");
3124               SvGROW(PL_rs, (STRLEN)(UNISKIP(rschar) + 1));
3125               tmps = (U8*)SvPVX(PL_rs);
3126               uvchr_to_utf8(tmps, rschar);
3127               SvCUR_set(PL_rs, UNISKIP(rschar));
3128               SvUTF8_on(PL_rs);
3129          }
3130          else {
3131               numlen = 4;
3132               rschar = (U32)grok_oct(s, &numlen, &flags, NULL);
3133               if (rschar & ~((U8)~0))
3134                    PL_rs = &PL_sv_undef;
3135               else if (!rschar && numlen >= 2)
3136                    PL_rs = newSVpvs("");
3137               else {
3138                    char ch = (char)rschar;
3139                    PL_rs = newSVpvn(&ch, 1);
3140               }
3141          }
3142          sv_setsv(get_sv("/", TRUE), PL_rs);
3143          return s + numlen;
3144     }
3145     case 'C':
3146         s++;
3147         PL_unicode = parse_unicode_opts(&s);
3148         if (PL_unicode & PERL_UNICODE_UTF8CACHEASSERT_FLAG)
3149             PL_utf8cache = -1;
3150         return s;
3151     case 'F':
3152         PL_minus_F = TRUE;
3153         PL_splitstr = ++s;
3154         while (*s && !isSPACE(*s)) ++s;
3155         PL_splitstr = savepvn(PL_splitstr, s - PL_splitstr);
3156         return s;
3157     case 'a':
3158         PL_minus_a = TRUE;
3159         s++;
3160         return s;
3161     case 'c':
3162         PL_minus_c = TRUE;
3163         s++;
3164         return s;
3165     case 'd':
3166         forbid_setid("-d");
3167         s++;
3168
3169         /* -dt indicates to the debugger that threads will be used */
3170         if (*s == 't' && !isALNUM(s[1])) {
3171             ++s;
3172             my_setenv("PERL5DB_THREADED", "1");
3173         }
3174
3175         /* The following permits -d:Mod to accepts arguments following an =
3176            in the fashion that -MSome::Mod does. */
3177         if (*s == ':' || *s == '=') {
3178             const char *start;
3179             SV * const sv = newSVpvs("use Devel::");
3180             start = ++s;
3181             /* We now allow -d:Module=Foo,Bar */
3182             while(isALNUM(*s) || *s==':') ++s;
3183             if (*s != '=')
3184                 sv_catpv(sv, start);
3185             else {
3186                 sv_catpvn(sv, start, s-start);
3187                 Perl_sv_catpvf(aTHX_ sv, " split(/,/,q%c%s%c)", 0, ++s, 0);
3188             }
3189             s += strlen(s);
3190             my_setenv("PERL5DB", (char *)SvPV_nolen_const(sv));
3191         }
3192         if (!PL_perldb) {
3193             PL_perldb = PERLDB_ALL;
3194             init_debugger();
3195         }
3196         return s;
3197     case 'D':
3198     {   
3199 #ifdef DEBUGGING
3200         forbid_setid("-D");
3201         s++;
3202         PL_debug = get_debug_opts_flags( &s, 1) | DEBUG_TOP_FLAG;
3203 #else /* !DEBUGGING */
3204         if (ckWARN_d(WARN_DEBUGGING))
3205             Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
3206                    "Recompile perl with -DDEBUGGING to use -D switch (did you mean -d ?)\n");
3207         for (s++; isALNUM(*s); s++) ;
3208 #endif
3209         return s;
3210     }   
3211     case 'h':
3212         usage(PL_origargv[0]);
3213         my_exit(0);
3214     case 'i':
3215         Safefree(PL_inplace);
3216 #if defined(__CYGWIN__) /* do backup extension automagically */
3217         if (*(s+1) == '\0') {
3218         PL_inplace = savepvs(".bak");
3219         return s+1;
3220         }
3221 #endif /* __CYGWIN__ */
3222         PL_inplace = savepv(s+1);
3223         for (s = PL_inplace; *s && !isSPACE(*s); s++)
3224             ;
3225         if (*s) {
3226             *s++ = '\0';
3227             if (*s == '-')      /* Additional switches on #! line. */
3228                 s++;
3229         }
3230         return s;
3231     case 'I':   /* -I handled both here and in parse_body() */
3232         forbid_setid("-I");
3233         ++s;
3234         while (*s && isSPACE(*s))
3235             ++s;
3236         if (*s) {
3237             char *e, *p;
3238             p = s;
3239             /* ignore trailing spaces (possibly followed by other switches) */
3240             do {
3241                 for (e = p; *e && !isSPACE(*e); e++) ;
3242                 p = e;
3243                 while (isSPACE(*p))
3244                     p++;
3245             } while (*p && *p != '-');
3246             e = savepvn(s, e-s);
3247             incpush(e, TRUE, TRUE, FALSE, FALSE);
3248             Safefree(e);
3249             s = p;
3250             if (*s == '-')
3251                 s++;
3252         }
3253         else
3254             Perl_croak(aTHX_ "No directory specified for -I");
3255         return s;
3256     case 'l':
3257         PL_minus_l = TRUE;
3258         s++;
3259         if (PL_ors_sv) {
3260             SvREFCNT_dec(PL_ors_sv);
3261             PL_ors_sv = NULL;
3262         }
3263         if (isDIGIT(*s)) {
3264             I32 flags = 0;
3265             STRLEN numlen;
3266             PL_ors_sv = newSVpvs("\n");
3267             numlen = 3 + (*s == '0');
3268             *SvPVX(PL_ors_sv) = (char)grok_oct(s, &numlen, &flags, NULL);
3269             s += numlen;
3270         }
3271         else {
3272             if (RsPARA(PL_rs)) {
3273                 PL_ors_sv = newSVpvs("\n\n");
3274             }
3275             else {
3276                 PL_ors_sv = newSVsv(PL_rs);
3277             }
3278         }
3279         return s;
3280     case 'M':
3281         forbid_setid("-M");     /* XXX ? */
3282         /* FALL THROUGH */
3283     case 'm':
3284         forbid_setid("-m");     /* XXX ? */
3285         if (*++s) {
3286             char *start;
3287             SV *sv;
3288             const char *use = "use ";
3289             /* -M-foo == 'no foo'       */
3290             /* Leading space on " no " is deliberate, to make both
3291                possibilities the same length.  */
3292             if (*s == '-') { use = " no "; ++s; }
3293             sv = newSVpvn(use,4);
3294             start = s;
3295             /* We allow -M'Module qw(Foo Bar)'  */
3296             while(isALNUM(*s) || *s==':') ++s;
3297             if (*s != '=') {
3298                 sv_catpv(sv, start);
3299                 if (*(start-1) == 'm') {
3300                     if (*s != '\0')
3301                         Perl_croak(aTHX_ "Can't use '%c' after -mname", *s);
3302                     sv_catpvs( sv, " ()");
3303                 }
3304             } else {
3305                 if (s == start)
3306                     Perl_croak(aTHX_ "Module name required with -%c option",
3307                                s[-1]);
3308                 sv_catpvn(sv, start, s-start);
3309                 sv_catpvs(sv, " split(/,/,q");
3310                 sv_catpvs(sv, "\0");        /* Use NUL as q//-delimiter. */
3311                 sv_catpv(sv, ++s);
3312                 sv_catpvs(sv,  "\0)");
3313             }
3314             s += strlen(s);
3315             if (!PL_preambleav)
3316                 PL_preambleav = newAV();
3317             av_push(PL_preambleav, sv);
3318         }
3319         else
3320             Perl_croak(aTHX_ "Missing argument to -%c", *(s-1));
3321         return s;
3322     case 'n':
3323         PL_minus_n = TRUE;
3324         s++;
3325         return s;
3326     case 'p':
3327         PL_minus_p = TRUE;
3328         s++;
3329         return s;
3330     case 's':
3331         forbid_setid("-s");
3332         PL_doswitches = TRUE;
3333         s++;
3334         return s;
3335     case 't':
3336         if (!PL_tainting)
3337             TOO_LATE_FOR('t');
3338         s++;
3339         return s;
3340     case 'T':
3341         if (!PL_tainting)
3342             TOO_LATE_FOR('T');
3343         s++;
3344         return s;
3345     case 'u':
3346 #ifdef MACOS_TRADITIONAL
3347         Perl_croak(aTHX_ "Believe me, you don't want to use \"-u\" on a Macintosh");
3348 #endif
3349         PL_do_undump = TRUE;
3350         s++;
3351         return s;
3352     case 'U':
3353         PL_unsafe = TRUE;
3354         s++;
3355         return s;
3356     case 'v':
3357 #if !defined(DGUX)
3358         PerlIO_printf(PerlIO_stdout(),
3359                       Perl_form(aTHX_ "\nThis is perl, v%"VDf" built for %s",
3360                                 PL_patchlevel, ARCHNAME));
3361 #else /* DGUX */
3362 /* Adjust verbose output as in the perl that ships with the DG/UX OS from EMC */
3363         PerlIO_printf(PerlIO_stdout(),
3364                         Perl_form(aTHX_ "\nThis is perl, version %vd\n", PL_patchlevel));
3365         PerlIO_printf(PerlIO_stdout(),
3366                         Perl_form(aTHX_ "        built under %s at %s %s\n",
3367                                         OSNAME, __DATE__, __TIME__));
3368         PerlIO_printf(PerlIO_stdout(),
3369                         Perl_form(aTHX_ "        OS Specific Release: %s\n",
3370                                         OSVERS));
3371 #endif /* !DGUX */
3372
3373 #if defined(LOCAL_PATCH_COUNT)
3374         if (LOCAL_PATCH_COUNT > 0)
3375             PerlIO_printf(PerlIO_stdout(),
3376                           "\n(with %d registered patch%s, "
3377                           "see perl -V for more detail)",
3378                           (int)LOCAL_PATCH_COUNT,
3379                           (LOCAL_PATCH_COUNT!=1) ? "es" : "");
3380 #endif
3381
3382         PerlIO_printf(PerlIO_stdout(),
3383                       "\n\nCopyright 1987-2006, Larry Wall\n");
3384 #ifdef MACOS_TRADITIONAL
3385         PerlIO_printf(PerlIO_stdout(),
3386                       "\nMac OS port Copyright 1991-2002, Matthias Neeracher;\n"
3387                       "maintained by Chris Nandor\n");
3388 #endif
3389 #ifdef MSDOS
3390         PerlIO_printf(PerlIO_stdout(),
3391                       "\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
3392 #endif
3393 #ifdef DJGPP
3394         PerlIO_printf(PerlIO_stdout(),
3395                       "djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n"
3396                       "djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n");
3397 #endif
3398 #ifdef OS2
3399         PerlIO_printf(PerlIO_stdout(),
3400                       "\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
3401                       "Version 5 port Copyright (c) 1994-2002, Andreas Kaiser, Ilya Zakharevich\n");
3402 #endif
3403 #ifdef atarist
3404         PerlIO_printf(PerlIO_stdout(),
3405                       "atariST series port, ++jrb  bammi@cadence.com\n");
3406 #endif
3407 #ifdef __BEOS__
3408         PerlIO_printf(PerlIO_stdout(),
3409                       "BeOS port Copyright Tom Spindler, 1997-1999\n");
3410 #endif
3411 #ifdef MPE
3412         PerlIO_printf(PerlIO_stdout(),
3413                       "MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-2003\n");
3414 #endif
3415 #ifdef OEMVS
3416         PerlIO_printf(PerlIO_stdout(),
3417                       "MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
3418 #endif
3419 #ifdef __VOS__
3420         PerlIO_printf(PerlIO_stdout(),
3421                       "Stratus VOS port by Paul.Green@stratus.com, 1997-2002\n");
3422 #endif
3423 #ifdef __OPEN_VM
3424         PerlIO_printf(PerlIO_stdout(),
3425                       "VM/ESA port by Neale Ferguson, 1998-1999\n");
3426 #endif
3427 #ifdef POSIX_BC
3428         PerlIO_printf(PerlIO_stdout(),
3429                       "BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
3430 #endif
3431 #ifdef __MINT__
3432         PerlIO_printf(PerlIO_stdout(),
3433                       "MiNT port by Guido Flohr, 1997-1999\n");
3434 #endif
3435 #ifdef EPOC
3436         PerlIO_printf(PerlIO_stdout(),
3437                       "EPOC port by Olaf Flebbe, 1999-2002\n");
3438 #endif
3439 #ifdef UNDER_CE
3440         PerlIO_printf(PerlIO_stdout(),"WINCE port by Rainer Keuchel, 2001-2002\n");
3441         PerlIO_printf(PerlIO_stdout(),"Built on " __DATE__ " " __TIME__ "\n\n");
3442         wce_hitreturn();
3443 #endif
3444 #ifdef BINARY_BUILD_NOTICE
3445         BINARY_BUILD_NOTICE;
3446 #endif
3447         PerlIO_printf(PerlIO_stdout(),
3448                       "\n\
3449 Perl may be copied only under the terms of either the Artistic License or the\n\
3450 GNU General Public License, which may be found in the Perl 5 source kit.\n\n\
3451 Complete documentation for Perl, including FAQ lists, should be found on\n\
3452 this system using \"man perl\" or \"perldoc perl\".  If you have access to the\n\
3453 Internet, point your browser at http://www.perl.org/, the Perl Home Page.\n\n");
3454         my_exit(0);
3455     case 'w':
3456         if (! (PL_dowarn & G_WARN_ALL_MASK))
3457             PL_dowarn |= G_WARN_ON;
3458         s++;
3459         return s;
3460     case 'W':
3461         PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
3462         if (!specialWARN(PL_compiling.cop_warnings))
3463             SvREFCNT_dec(PL_compiling.cop_warnings);
3464         PL_compiling.cop_warnings = pWARN_ALL ;
3465         s++;
3466         return s;
3467     case 'X':
3468         PL_dowarn = G_WARN_ALL_OFF;
3469         if (!specialWARN(PL_compiling.cop_warnings))
3470             SvREFCNT_dec(PL_compiling.cop_warnings);
3471         PL_compiling.cop_warnings = pWARN_NONE ;
3472         s++;
3473         return s;
3474     case '*':
3475     case ' ':
3476         if (s[1] == '-')        /* Additional switches on #! line. */
3477             return s+2;
3478         break;
3479     case '-':
3480     case 0:
3481 #if defined(WIN32) || !defined(PERL_STRICT_CR)
3482     case '\r':
3483 #endif
3484     case '\n':
3485     case '\t':
3486         break;
3487 #ifdef ALTERNATE_SHEBANG
3488     case 'S':                   /* OS/2 needs -S on "extproc" line. */
3489         break;
3490 #endif
3491     case 'P':
3492         if (PL_preprocess)
3493             return s+1;
3494         /* FALL THROUGH */
3495     default:
3496         Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s);
3497     }
3498     return NULL;
3499 }
3500
3501 /* compliments of Tom Christiansen */
3502
3503 /* unexec() can be found in the Gnu emacs distribution */
3504 /* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
3505
3506 void
3507 Perl_my_unexec(pTHX)
3508 {
3509 #ifdef UNEXEC
3510     SV *    prog = newSVpv(BIN_EXP, 0);
3511     SV *    file = newSVpv(PL_origfilename, 0);
3512     int    status = 1;
3513     extern int etext;
3514
3515     sv_catpvs(prog, "/perl");
3516     sv_catpvs(file, ".perldump");
3517
3518     unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
3519     /* unexec prints msg to stderr in case of failure */
3520     PerlProc_exit(status);
3521 #else
3522 #  ifdef VMS
3523 #    include <lib$routines.h>
3524      lib$signal(SS$_DEBUG);  /* ssdef.h #included from vmsish.h */
3525 #  else
3526     ABORT();            /* for use with undump */
3527 #  endif
3528 #endif
3529 }
3530
3531 /* initialize curinterp */
3532 STATIC void
3533 S_init_interp(pTHX)
3534 {
3535
3536 #ifdef MULTIPLICITY
3537 #  define PERLVAR(var,type)
3538 #  define PERLVARA(var,n,type)
3539 #  if defined(PERL_IMPLICIT_CONTEXT)
3540 #    if defined(USE_5005THREADS)
3541 #      define PERLVARI(var,type,init)           PERL_GET_INTERP->var = init;
3542 #      define PERLVARIC(var,type,init)          PERL_GET_INTERP->var = init;
3543 #    else /* !USE_5005THREADS */
3544 #      define PERLVARI(var,type,init)           aTHX->var = init;
3545 #      define PERLVARIC(var,type,init)  aTHX->var = init;
3546 #    endif /* USE_5005THREADS */
3547 #  else
3548 #    define PERLVARI(var,type,init)     PERL_GET_INTERP->var = init;
3549 #    define PERLVARIC(var,type,init)    PERL_GET_INTERP->var = init;
3550 #  endif
3551 #  include "intrpvar.h"
3552 #  ifndef USE_5005THREADS
3553 #    include "thrdvar.h"
3554 #  endif
3555 #  undef PERLVAR
3556 #  undef PERLVARA
3557 #  undef PERLVARI
3558 #  undef PERLVARIC
3559 #else
3560 #  define PERLVAR(var,type)
3561 #  define PERLVARA(var,n,type)
3562 #  define PERLVARI(var,type,init)       PL_##var = init;
3563 #  define PERLVARIC(var,type,init)      PL_##var = init;
3564 #  include "intrpvar.h"
3565 #  ifndef USE_5005THREADS
3566 #    include "thrdvar.h"
3567 #  endif
3568 #  undef PERLVAR
3569 #  undef PERLVARA
3570 #  undef PERLVARI
3571 #  undef PERLVARIC
3572 #endif
3573
3574 }
3575
3576 STATIC void
3577 S_init_main_stash(pTHX)
3578 {
3579     GV *gv;
3580
3581     PL_curstash = PL_defstash = newHV();
3582     /* We know that the string "main" will be in the global shared string
3583        table, so it's a small saving to use it rather than allocate another
3584        8 bytes.  */
3585     PL_curstname = newSVpvs_share("main");
3586     gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
3587     /* If we hadn't caused another reference to "main" to be in the shared
3588        string table above, then it would be worth reordering these two,
3589        because otherwise all we do is delete "main" from it as a consequence
3590        of the SvREFCNT_dec, only to add it again with hv_name_set */
3591     SvREFCNT_dec(GvHV(gv));
3592     hv_name_set(PL_defstash, "main", 4, 0);
3593     GvHV(gv) = (HV*)SvREFCNT_inc_simple(PL_defstash);
3594     SvREADONLY_on(gv);
3595     PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
3596     GvMULTI_on(PL_incgv);
3597     PL_hintgv = gv_fetchpv("\010",TRUE, SVt_PV); /* ^H */
3598     GvMULTI_on(PL_hintgv);
3599     PL_defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
3600     PL_errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
3601     GvMULTI_on(PL_errgv);
3602     PL_replgv = gv_fetchpv("\022", TRUE, SVt_PV); /* ^R */
3603     GvMULTI_on(PL_replgv);
3604     (void)Perl_form(aTHX_ "%240s","");  /* Preallocate temp - for immediate signals. */
3605 #ifdef PERL_DONT_CREATE_GVSV
3606     gv_SVadd(PL_errgv);
3607 #endif
3608     sv_grow(ERRSV, 240);        /* Preallocate - for immediate signals. */
3609     sv_setpvn(ERRSV, "", 0);
3610     PL_curstash = PL_defstash;
3611     CopSTASH_set(&PL_compiling, PL_defstash);
3612     PL_debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
3613     PL_globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
3614     PL_nullstash = GvHV(gv_fetchpv("<none>::", GV_ADDMULTI, SVt_PVHV));
3615     /* We must init $/ before switches are processed. */
3616     sv_setpvn(get_sv("/", TRUE), "\n", 1);
3617 }
3618
3619 /* PSz 18 Nov 03  fdscript now global but do not change prototype */
3620 STATIC void
3621 S_open_script(pTHX_ const char *scriptname, bool dosearch, SV *sv)
3622 {
3623 #ifndef IAMSUID
3624     const char *quote;
3625     const char *code;
3626     const char *cpp_discard_flag;
3627     const char *perl;
3628 #endif
3629
3630     PL_fdscript = -1;
3631     PL_suidscript = -1;
3632
3633     if (PL_e_script) {
3634         PL_origfilename = savepvs("-e");
3635     }
3636     else {
3637         /* if find_script() returns, it returns a malloc()-ed value */
3638         scriptname = PL_origfilename = find_script((char *)scriptname, dosearch, NULL, 1);
3639
3640         if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
3641             const char *s = scriptname + 8;
3642             PL_fdscript = atoi(s);
3643             while (isDIGIT(*s))
3644                 s++;
3645             if (*s) {
3646                 /* PSz 18 Feb 04
3647                  * Tell apart "normal" usage of fdscript, e.g.
3648                  * with bash on FreeBSD:
3649                  *   perl <( echo '#!perl -DA'; echo 'print "$0\n"')
3650                  * from usage in suidperl.
3651                  * Does any "normal" usage leave garbage after the number???
3652                  * Is it a mistake to use a similar /dev/fd/ construct for
3653                  * suidperl?
3654                  */
3655                 PL_suidscript = 1;
3656                 /* PSz 20 Feb 04  
3657                  * Be supersafe and do some sanity-checks.
3658                  * Still, can we be sure we got the right thing?
3659                  */
3660                 if (*s != '/') {
3661                     Perl_croak(aTHX_ "Wrong syntax (suid) fd script name \"%s\"\n", s);
3662                 }
3663                 if (! *(s+1)) {
3664                     Perl_croak(aTHX_ "Missing (suid) fd script name\n");
3665                 }
3666                 scriptname = savepv(s + 1);
3667                 Safefree(PL_origfilename);
3668                 PL_origfilename = (char *)scriptname;
3669             }
3670         }
3671     }
3672
3673     CopFILE_free(PL_curcop);
3674     CopFILE_set(PL_curcop, PL_origfilename);
3675     if (*PL_origfilename == '-' && PL_origfilename[1] == '\0')
3676         scriptname = (char *)"";
3677     if (PL_fdscript >= 0) {
3678         PL_rsfp = PerlIO_fdopen(PL_fdscript,PERL_SCRIPT_MODE);
3679 #       if defined(HAS_FCNTL) && defined(F_SETFD)
3680             if (PL_rsfp)
3681                 /* ensure close-on-exec */
3682                 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1);
3683 #       endif
3684     }
3685 #ifdef IAMSUID
3686     else {
3687         Perl_croak(aTHX_ "sperl needs fd script\n"
3688                    "You should not call sperl directly; do you need to "
3689                    "change a #! line\nfrom sperl to perl?\n");
3690
3691 /* PSz 11 Nov 03
3692  * Do not open (or do other fancy stuff) while setuid.
3693  * Perl does the open, and hands script to suidperl on a fd;
3694  * suidperl only does some checks, sets up UIDs and re-execs
3695  * perl with that fd as it has always done.
3696  */
3697     }
3698     if (PL_suidscript != 1) {
3699         Perl_croak(aTHX_ "suidperl needs (suid) fd script\n");
3700     }
3701 #else /* IAMSUID */
3702     else if (PL_preprocess) {
3703         const char * const cpp_cfg = CPPSTDIN;
3704         SV * const cpp = newSVpvs("");
3705         SV * const cmd = newSV(0);
3706
3707         if (cpp_cfg[0] == 0) /* PERL_MICRO? */
3708              Perl_croak(aTHX_ "Can't run with cpp -P with CPPSTDIN undefined");
3709         if (strEQ(cpp_cfg, "cppstdin"))
3710             Perl_sv_catpvf(aTHX_ cpp, "%s/", BIN_EXP);
3711         sv_catpv(cpp, cpp_cfg);
3712
3713 #       ifndef VMS
3714             sv_catpvs(sv, "-I");
3715             sv_catpv(sv,PRIVLIB_EXP);
3716 #       endif
3717
3718         DEBUG_P(PerlIO_printf(Perl_debug_log,
3719                               "PL_preprocess: scriptname=\"%s\", cpp=\"%s\", sv=\"%s\", CPPMINUS=\"%s\"\n",
3720                               scriptname, SvPVX_const (cpp), SvPVX_const (sv),
3721                               CPPMINUS));
3722
3723 #       if defined(MSDOS) || defined(WIN32) || defined(VMS)
3724             quote = "\"";
3725 #       else
3726             quote = "'";
3727 #       endif
3728
3729 #       ifdef VMS
3730             cpp_discard_flag = "";
3731 #       else
3732             cpp_discard_flag = "-C";
3733 #       endif
3734
3735 #       ifdef OS2
3736             perl = os2_execname(aTHX);
3737 #       else
3738             perl = PL_origargv[0];
3739 #       endif
3740
3741
3742         /* This strips off Perl comments which might interfere with
3743            the C pre-processor, including #!.  #line directives are
3744            deliberately stripped to avoid confusion with Perl's version
3745            of #line.  FWP played some golf with it so it will fit
3746            into VMS's 255 character buffer.
3747         */
3748         if( PL_doextract )
3749             code = "(1../^#!.*perl/i)|/^\\s*#(?!\\s*((ifn?|un)def|(el|end)?if|define|include|else|error|pragma)\\b)/||!($|=1)||print";
3750         else
3751             code = "/^\\s*#(?!\\s*((ifn?|un)def|(el|end)?if|define|include|else|error|pragma)\\b)/||!($|=1)||print";
3752
3753         Perl_sv_setpvf(aTHX_ cmd, "\
3754 %s -ne%s%s%s %s | %"SVf" %s %"SVf" %s",
3755                        perl, quote, code, quote, scriptname, cpp,
3756                        cpp_discard_flag, sv, CPPMINUS);
3757
3758         PL_doextract = FALSE;
3759
3760         DEBUG_P(PerlIO_printf(Perl_debug_log,
3761                               "PL_preprocess: cmd=\"%s\"\n",
3762                               SvPVX_const(cmd)));
3763
3764         PL_rsfp = PerlProc_popen((char *)SvPVX_const(cmd), (char *)"r");
3765         SvREFCNT_dec(cmd);
3766         SvREFCNT_dec(cpp);
3767     }
3768     else if (!*scriptname) {
3769         forbid_setid("program input from stdin");
3770         PL_rsfp = PerlIO_stdin();
3771     }
3772     else {
3773         PL_rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
3774 #       if defined(HAS_FCNTL) && defined(F_SETFD)
3775             if (PL_rsfp)
3776                 /* ensure close-on-exec */
3777                 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1);
3778 #       endif
3779     }
3780 #endif /* IAMSUID */
3781     if (!PL_rsfp) {
3782         /* PSz 16 Sep 03  Keep neat error message */
3783         if (PL_e_script)
3784             Perl_croak(aTHX_ "Can't open "BIT_BUCKET": %s\n", Strerror(errno));
3785         else
3786             Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
3787                     CopFILE(PL_curcop), Strerror(errno));
3788     }
3789 }
3790
3791 /* Mention
3792  * I_SYSSTATVFS HAS_FSTATVFS
3793  * I_SYSMOUNT
3794  * I_STATFS     HAS_FSTATFS     HAS_GETFSSTAT
3795  * I_MNTENT     HAS_GETMNTENT   HAS_HASMNTOPT
3796  * here so that metaconfig picks them up. */
3797
3798 #ifdef IAMSUID
3799 STATIC int
3800 S_fd_on_nosuid_fs(pTHX_ int fd)
3801 {
3802 /* PSz 27 Feb 04
3803  * We used to do this as "plain" user (after swapping UIDs with setreuid);
3804  * but is needed also on machines without setreuid.
3805  * Seems safe enough to run as root.
3806  */
3807     int check_okay = 0; /* able to do all the required sys/libcalls */
3808     int on_nosuid  = 0; /* the fd is on a nosuid fs */
3809     /* PSz 12 Nov 03
3810      * Need to check noexec also: nosuid might not be set, the average
3811      * sysadmin would say that nosuid is irrelevant once he sets noexec.
3812      */
3813     int on_noexec  = 0; /* the fd is on a noexec fs */
3814
3815 /*
3816  * Preferred order: fstatvfs(), fstatfs(), ustat()+getmnt(), getmntent().
3817  * fstatvfs() is UNIX98.
3818  * fstatfs() is 4.3 BSD.
3819  * ustat()+getmnt() is pre-4.3 BSD.
3820  * getmntent() is O(number-of-mounted-filesystems) and can hang on
3821  * an irrelevant filesystem while trying to reach the right one.
3822  */
3823
3824 #undef FD_ON_NOSUID_CHECK_OKAY  /* found the syscalls to do the check? */
3825
3826 #   if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
3827         defined(HAS_FSTATVFS)
3828 #   define FD_ON_NOSUID_CHECK_OKAY
3829     struct statvfs stfs;
3830
3831     check_okay = fstatvfs(fd, &stfs) == 0;
3832     on_nosuid  = check_okay && (stfs.f_flag  & ST_NOSUID);
3833 #ifdef ST_NOEXEC
3834     /* ST_NOEXEC certainly absent on AIX 5.1, and doesn't seem to be documented
3835        on platforms where it is present.  */
3836     on_noexec  = check_okay && (stfs.f_flag  & ST_NOEXEC);
3837 #endif
3838 #   endif /* fstatvfs */
3839
3840 #   if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
3841         defined(PERL_MOUNT_NOSUID)      && \
3842         defined(PERL_MOUNT_NOEXEC)      && \
3843         defined(HAS_FSTATFS)            && \
3844         defined(HAS_STRUCT_STATFS)      && \
3845         defined(HAS_STRUCT_STATFS_F_FLAGS)
3846 #   define FD_ON_NOSUID_CHECK_OKAY
3847     struct statfs  stfs;
3848
3849     check_okay = fstatfs(fd, &stfs)  == 0;
3850     on_nosuid  = check_okay && (stfs.f_flags & PERL_MOUNT_NOSUID);
3851     on_noexec  = check_okay && (stfs.f_flags & PERL_MOUNT_NOEXEC);
3852 #   endif /* fstatfs */
3853
3854 #   if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
3855         defined(PERL_MOUNT_NOSUID)      && \
3856         defined(PERL_MOUNT_NOEXEC)      && \
3857         defined(HAS_FSTAT)              && \
3858         defined(HAS_USTAT)              && \
3859         defined(HAS_GETMNT)             && \
3860         defined(HAS_STRUCT_FS_DATA)     && \
3861         defined(NOSTAT_ONE)
3862 #   define FD_ON_NOSUID_CHECK_OKAY
3863     Stat_t fdst;
3864
3865     if (fstat(fd, &fdst) == 0) {
3866         struct ustat us;
3867         if (ustat(fdst.st_dev, &us) == 0) {
3868             struct fs_data fsd;
3869             /* NOSTAT_ONE here because we're not examining fields which
3870              * vary between that case and STAT_ONE. */
3871             if (getmnt((int*)0, &fsd, (int)0, NOSTAT_ONE, us.f_fname) == 0) {
3872                 size_t cmplen = sizeof(us.f_fname);
3873                 if (sizeof(fsd.fd_req.path) < cmplen)
3874                     cmplen = sizeof(fsd.fd_req.path);
3875                 if (strnEQ(fsd.fd_req.path, us.f_fname, cmplen) &&
3876                     fdst.st_dev == fsd.fd_req.dev) {
3877                     check_okay = 1;
3878                     on_nosuid = fsd.fd_req.flags & PERL_MOUNT_NOSUID;
3879                     on_noexec = fsd.fd_req.flags & PERL_MOUNT_NOEXEC;
3880                 }
3881             }
3882         }
3883     }
3884 #   endif /* fstat+ustat+getmnt */
3885
3886 #   if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
3887         defined(HAS_GETMNTENT)          && \
3888         defined(HAS_HASMNTOPT)          && \
3889         defined(MNTOPT_NOSUID)          && \
3890         defined(MNTOPT_NOEXEC)
3891 #   define FD_ON_NOSUID_CHECK_OKAY
3892     FILE                *mtab = fopen("/etc/mtab", "r");
3893     struct mntent       *entry;
3894     Stat_t              stb, fsb;
3895
3896     if (mtab && (fstat(fd, &stb) == 0)) {
3897         while (entry = getmntent(mtab)) {
3898             if (stat(entry->mnt_dir, &fsb) == 0
3899                 && fsb.st_dev == stb.st_dev)
3900             {
3901                 /* found the filesystem */
3902                 check_okay = 1;
3903                 if (hasmntopt(entry, MNTOPT_NOSUID))
3904                     on_nosuid = 1;
3905                 if (hasmntopt(entry, MNTOPT_NOEXEC))
3906                     on_noexec = 1;
3907                 break;
3908             } /* A single fs may well fail its stat(). */
3909         }
3910     }
3911     if (mtab)
3912         fclose(mtab);
3913 #   endif /* getmntent+hasmntopt */
3914
3915     if (!check_okay)
3916         Perl_croak(aTHX_ "Can't check filesystem of script \"%s\" for nosuid/noexec", PL_origfilename);
3917     if (on_nosuid)
3918         Perl_croak(aTHX_ "Setuid script \"%s\" on nosuid filesystem", PL_origfilename);
3919     if (on_noexec)
3920         Perl_croak(aTHX_ "Setuid script \"%s\" on noexec filesystem", PL_origfilename);
3921     return ((!check_okay) || on_nosuid || on_noexec);
3922 }
3923 #endif /* IAMSUID */
3924
3925 STATIC void
3926 S_validate_suid(pTHX_ const char *validarg, const char *scriptname)
3927 {
3928 #ifdef IAMSUID
3929     /* int which; */
3930 #endif /* IAMSUID */
3931
3932     /* do we need to emulate setuid on scripts? */
3933
3934     /* This code is for those BSD systems that have setuid #! scripts disabled
3935      * in the kernel because of a security problem.  Merely defining DOSUID
3936      * in perl will not fix that problem, but if you have disabled setuid
3937      * scripts in the kernel, this will attempt to emulate setuid and setgid
3938      * on scripts that have those now-otherwise-useless bits set.  The setuid
3939      * root version must be called suidperl or sperlN.NNN.  If regular perl
3940      * discovers that it has opened a setuid script, it calls suidperl with
3941      * the same argv that it had.  If suidperl finds that the script it has
3942      * just opened is NOT setuid root, it sets the effective uid back to the
3943      * uid.  We don't just make perl setuid root because that loses the
3944      * effective uid we had before invoking perl, if it was different from the
3945      * uid.
3946      * PSz 27 Feb 04
3947      * Description/comments above do not match current workings:
3948      *   suidperl must be hardlinked to sperlN.NNN (that is what we exec);
3949      *   suidperl called with script open and name changed to /dev/fd/N/X;
3950      *   suidperl croaks if script is not setuid;
3951      *   making perl setuid would be a huge security risk (and yes, that
3952      *     would lose any euid we might have had).
3953      *
3954      * DOSUID must be defined in both perl and suidperl, and IAMSUID must
3955      * be defined in suidperl only.  suidperl must be setuid root.  The
3956      * Configure script will set this up for you if you want it.
3957      */
3958
3959 #ifdef DOSUID
3960     const char *s, *s2;
3961
3962     if (PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf) < 0)  /* normal stat is insecure */
3963         Perl_croak(aTHX_ "Can't stat script \"%s\"",PL_origfilename);
3964     if (PL_statbuf.st_mode & (S_ISUID|S_ISGID)) {
3965         I32 len;
3966         const char *linestr;
3967         const char *s_end;
3968
3969 #ifdef IAMSUID
3970         if (PL_fdscript < 0 || PL_suidscript != 1)
3971             Perl_croak(aTHX_ "Need (suid) fdscript in suidperl\n");     /* We already checked this */
3972         /* PSz 11 Nov 03
3973          * Since the script is opened by perl, not suidperl, some of these
3974          * checks are superfluous. Leaving them in probably does not lower
3975          * security(?!).
3976          */
3977         /* PSz 27 Feb 04
3978          * Do checks even for systems with no HAS_SETREUID.
3979          * We used to swap, then re-swap UIDs with
3980 #ifdef HAS_SETREUID
3981             if (setreuid(PL_euid,PL_uid) < 0
3982                 || PerlProc_getuid() != PL_euid || PerlProc_geteuid() != PL_uid)
3983                 Perl_croak(aTHX_ "Can't swap uid and euid");
3984 #endif
3985 #ifdef HAS_SETREUID
3986             if (setreuid(PL_uid,PL_euid) < 0
3987                 || PerlProc_getuid() != PL_uid || PerlProc_geteuid() != PL_euid)
3988                 Perl_croak(aTHX_ "Can't reswap uid and euid");
3989 #endif
3990          */
3991
3992         /* On this access check to make sure the directories are readable,
3993          * there is actually a small window that the user could use to make
3994          * filename point to an accessible directory.  So there is a faint
3995          * chance that someone could execute a setuid script down in a
3996          * non-accessible directory.  I don't know what to do about that.
3997          * But I don't think it's too important.  The manual lies when
3998          * it says access() is useful in setuid programs.
3999          * 
4000          * So, access() is pretty useless... but not harmful... do anyway.
4001          */
4002         if (PerlLIO_access(CopFILE(PL_curcop),1)) { /*double check*/
4003             Perl_croak(aTHX_ "Can't access() script\n");
4004         }
4005
4006         /* If we can swap euid and uid, then we can determine access rights
4007          * with a simple stat of the file, and then compare device and
4008          * inode to make sure we did stat() on the same file we opened.
4009          * Then we just have to make sure he or she can execute it.
4010          * 
4011          * PSz 24 Feb 04
4012          * As the script is opened by perl, not suidperl, we do not need to
4013          * care much about access rights.
4014          * 
4015          * The 'script changed' check is needed, or we can get lied to
4016          * about $0 with e.g.
4017          *  suidperl /dev/fd/4//bin/x 4<setuidscript
4018          * Without HAS_SETREUID, is it safe to stat() as root?
4019          * 
4020          * Are there any operating systems that pass /dev/fd/xxx for setuid
4021          * scripts, as suggested/described in perlsec(1)? Surely they do not
4022          * pass the script name as we do, so the "script changed" test would
4023          * fail for them... but we never get here with
4024          * SETUID_SCRIPTS_ARE_SECURE_NOW defined.
4025          * 
4026          * This is one place where we must "lie" about return status: not
4027          * say if the stat() failed. We are doing this as root, and could
4028          * be tricked into reporting existence or not of files that the
4029          * "plain" user cannot even see.
4030          */
4031         {
4032             Stat_t tmpstatbuf;
4033             if (PerlLIO_stat(CopFILE(PL_curcop),&tmpstatbuf) < 0 ||
4034                 tmpstatbuf.st_dev != PL_statbuf.st_dev ||
4035                 tmpstatbuf.st_ino != PL_statbuf.st_ino) {
4036                 Perl_croak(aTHX_ "Setuid script changed\n");
4037             }
4038
4039         }
4040         if (!cando(S_IXUSR,FALSE,&PL_statbuf))          /* can real uid exec? */
4041             Perl_croak(aTHX_ "Real UID cannot exec script\n");
4042
4043         /* PSz 27 Feb 04
4044          * We used to do this check as the "plain" user (after swapping
4045          * UIDs). But the check for nosuid and noexec filesystem is needed,
4046          * and should be done even without HAS_SETREUID. (Maybe those
4047          * operating systems do not have such mount options anyway...)
4048          * Seems safe enough to do as root.
4049          */
4050 #if !defined(NO_NOSUID_CHECK)
4051         if (fd_on_nosuid_fs(PerlIO_fileno(PL_rsfp))) {
4052             Perl_croak(aTHX_ "Setuid script on nosuid or noexec filesystem\n");
4053         }
4054 #endif
4055 #endif /* IAMSUID */
4056
4057         if (!S_ISREG(PL_statbuf.st_mode)) {
4058             Perl_croak(aTHX_ "Setuid script not plain file\n");
4059         }
4060         if (PL_statbuf.st_mode & S_IWOTH)
4061             Perl_croak(aTHX_ "Setuid/gid script is writable by world");
4062         PL_doswitches = FALSE;          /* -s is insecure in suid */
4063         /* PSz 13 Nov 03  But -s was caught elsewhere ... so unsetting it here is useless(?!) */
4064         CopLINE_inc(PL_curcop);
4065         if (sv_gets(PL_linestr, PL_rsfp, 0) == NULL)
4066             Perl_croak(aTHX_ "No #! line");
4067         linestr = SvPV_nolen_const(PL_linestr);
4068         /* required even on Sys V */
4069         if (!*linestr || !linestr[1] || strnNE(linestr,"#!",2))
4070             Perl_croak(aTHX_ "No #! line");
4071         linestr += 2;
4072         s = linestr;
4073         /* PSz 27 Feb 04 */
4074         /* Sanity check on line length */
4075         s_end = s + strlen(s);
4076         if (s_end == s || (s_end - s) > 4000)
4077             Perl_croak(aTHX_ "Very long #! line");
4078         /* Allow more than a single space after #! */
4079         while (isSPACE(*s)) s++;
4080         /* Sanity check on buffer end */
4081         while ((*s) && !isSPACE(*s)) s++;
4082         for (s2 = s;  (s2 > linestr &&
4083                        (isDIGIT(s2[-1]) || s2[-1] == '.' || s2[-1] == '_'
4084                         || s2[-1] == '-'));  s2--) ;
4085         /* Sanity check on buffer start */
4086         if ( (s2-4 < linestr || strnNE(s2-4,"perl",4)) &&
4087               (s-9 < linestr || strnNE(s-9,"perl",4)) )
4088             Perl_croak(aTHX_ "Not a perl script");
4089         while (*s == ' ' || *s == '\t') s++;
4090         /*
4091          * #! arg must be what we saw above.  They can invoke it by
4092          * mentioning suidperl explicitly, but they may not add any strange
4093          * arguments beyond what #! says if they do invoke suidperl that way.
4094          */
4095         /*
4096          * The way validarg was set up, we rely on the kernel to start
4097          * scripts with argv[1] set to contain all #! line switches (the
4098          * whole line).
4099          */
4100         /*
4101          * Check that we got all the arguments listed in the #! line (not
4102          * just that there are no extraneous arguments). Might not matter
4103          * much, as switches from #! line seem to be acted upon (also), and
4104          * so may be checked and trapped in perl. But, security checks must
4105          * be done in suidperl and not deferred to perl. Note that suidperl
4106          * does not get around to parsing (and checking) the switches on
4107          * the #! line (but execs perl sooner).
4108          * Allow (require) a trailing newline (which may be of two
4109          * characters on some architectures?) (but no other trailing
4110          * whitespace).
4111          */
4112         len = strlen(validarg);
4113         if (strEQ(validarg," PHOOEY ") ||
4114             strnNE(s,validarg,len) || !isSPACE(s[len]) ||
4115             !((s_end - s) == len+1
4116               || ((s_end - s) == len+2 && isSPACE(s[len+1]))))
4117             Perl_croak(aTHX_ "Args must match #! line");
4118
4119 #ifndef IAMSUID
4120         if (PL_fdscript < 0 &&
4121             PL_euid != PL_uid && (PL_statbuf.st_mode & S_ISUID) &&
4122             PL_euid == PL_statbuf.st_uid)
4123             if (!PL_do_undump)
4124                 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
4125 FIX YOUR KERNEL, OR PUT A C WRAPPER AROUND THIS SCRIPT!\n");
4126 #endif /* IAMSUID */
4127
4128         if (PL_fdscript < 0 &&
4129             PL_euid) {  /* oops, we're not the setuid root perl */
4130             /* PSz 18 Feb 04
4131              * When root runs a setuid script, we do not go through the same
4132              * steps of execing sperl and then perl with fd scripts, but
4133              * simply set up UIDs within the same perl invocation; so do
4134              * not have the same checks (on options, whatever) that we have
4135              * for plain users. No problem really: would have to be a script
4136              * that does not actually work for plain users; and if root is
4137              * foolish and can be persuaded to run such an unsafe script, he
4138              * might run also non-setuid ones, and deserves what he gets.
4139              * 
4140              * Or, we might drop the PL_euid check above (and rely just on
4141              * PL_fdscript to avoid loops), and do the execs
4142              * even for root.
4143              */
4144 #ifndef IAMSUID
4145             int which;
4146             /* PSz 11 Nov 03
4147              * Pass fd script to suidperl.
4148              * Exec suidperl, substituting fd script for scriptname.
4149              * Pass script name as "subdir" of fd, which perl will grok;
4150              * in fact will use that to distinguish this from "normal"
4151              * usage, see comments above.
4152              */
4153             PerlIO_rewind(PL_rsfp);
4154             PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0);  /* just in case rewind didn't */
4155             /* PSz 27 Feb 04  Sanity checks on scriptname */
4156             if ((!scriptname) || (!*scriptname) ) {
4157                 Perl_croak(aTHX_ "No setuid script name\n");
4158             }
4159             if (*scriptname == '-') {
4160                 Perl_croak(aTHX_ "Setuid script name may not begin with dash\n");
4161                 /* Or we might confuse it with an option when replacing
4162                  * name in argument list, below (though we do pointer, not
4163                  * string, comparisons).
4164                  */
4165             }
4166             for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ;
4167             if (!PL_origargv[which]) {
4168                 Perl_croak(aTHX_ "Can't change argv to have fd script\n");
4169             }
4170             PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s",
4171                                           PerlIO_fileno(PL_rsfp), PL_origargv[which]));
4172 #if defined(HAS_FCNTL) && defined(F_SETFD)
4173             fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0);    /* ensure no close-on-exec */
4174 #endif
4175             PERL_FPU_PRE_EXEC
4176             PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT, BIN_EXP,
4177                                      (int)PERL_REVISION, (int)PERL_VERSION,
4178                                      (int)PERL_SUBVERSION), PL_origargv);
4179             PERL_FPU_POST_EXEC
4180 #endif /* IAMSUID */
4181             Perl_croak(aTHX_ "Can't do setuid (cannot exec sperl)\n");
4182         }
4183
4184         if (PL_statbuf.st_mode & S_ISGID && PL_statbuf.st_gid != PL_egid) {
4185 /* PSz 26 Feb 04
4186  * This seems back to front: we try HAS_SETEGID first; if not available
4187  * then try HAS_SETREGID; as a last chance we try HAS_SETRESGID. May be OK
4188  * in the sense that we only want to set EGID; but are there any machines
4189  * with either of the latter, but not the former? Same with UID, later.
4190  */
4191 #ifdef HAS_SETEGID
4192             (void)setegid(PL_statbuf.st_gid);
4193 #else
4194 #ifdef HAS_SETREGID
4195            (void)setregid((Gid_t)-1,PL_statbuf.st_gid);
4196 #else
4197 #ifdef HAS_SETRESGID
4198            (void)setresgid((Gid_t)-1,PL_statbuf.st_gid,(Gid_t)-1);
4199 #else
4200             PerlProc_setgid(PL_statbuf.st_gid);
4201 #endif
4202 #endif
4203 #endif
4204             if (PerlProc_getegid() != PL_statbuf.st_gid)
4205                 Perl_croak(aTHX_ "Can't do setegid!\n");
4206         }
4207         if (PL_statbuf.st_mode & S_ISUID) {
4208             if (PL_statbuf.st_uid != PL_euid)
4209 #ifdef HAS_SETEUID
4210                 (void)seteuid(PL_statbuf.st_uid);       /* all that for this */
4211 #else
4212 #ifdef HAS_SETREUID
4213                 (void)setreuid((Uid_t)-1,PL_statbuf.st_uid);
4214 #else
4215 #ifdef HAS_SETRESUID
4216                 (void)setresuid((Uid_t)-1,PL_statbuf.st_uid,(Uid_t)-1);
4217 #else
4218                 PerlProc_setuid(PL_statbuf.st_uid);
4219 #endif
4220 #endif
4221 #endif
4222             if (PerlProc_geteuid() != PL_statbuf.st_uid)
4223                 Perl_croak(aTHX_ "Can't do seteuid!\n");
4224         }
4225         else if (PL_uid) {                      /* oops, mustn't run as root */
4226 #ifdef HAS_SETEUID
4227           (void)seteuid((Uid_t)PL_uid);
4228 #else
4229 #ifdef HAS_SETREUID
4230           (void)setreuid((Uid_t)-1,(Uid_t)PL_uid);
4231 #else
4232 #ifdef HAS_SETRESUID
4233           (void)setresuid((Uid_t)-1,(Uid_t)PL_uid,(Uid_t)-1);
4234 #else
4235           PerlProc_setuid((Uid_t)PL_uid);
4236 #endif
4237 #endif
4238 #endif
4239             if (PerlProc_geteuid() != PL_uid)
4240                 Perl_croak(aTHX_ "Can't do seteuid!\n");
4241         }
4242         init_ids();
4243         if (!cando(S_IXUSR,TRUE,&PL_statbuf))
4244             Perl_croak(aTHX_ "Effective UID cannot exec script\n");     /* they can't do this */
4245     }
4246 #ifdef IAMSUID
4247     else if (PL_preprocess)     /* PSz 13 Nov 03  Caught elsewhere, useless(?!) here */
4248         Perl_croak(aTHX_ "-P not allowed for setuid/setgid script\n");
4249     else if (PL_fdscript < 0 || PL_suidscript != 1)
4250         /* PSz 13 Nov 03  Caught elsewhere, useless(?!) here */
4251         Perl_croak(aTHX_ "(suid) fdscript needed in suidperl\n");
4252     else {
4253 /* PSz 16 Sep 03  Keep neat error message */
4254         Perl_croak(aTHX_ "Script is not setuid/setgid in suidperl\n");
4255     }
4256
4257     /* We absolutely must clear out any saved ids here, so we */
4258     /* exec the real perl, substituting fd script for scriptname. */
4259     /* (We pass script name as "subdir" of fd, which perl will grok.) */
4260     /* 
4261      * It might be thought that using setresgid and/or setresuid (changed to
4262      * set the saved IDs) above might obviate the need to exec, and we could
4263      * go on to "do the perl thing".
4264      * 
4265      * Is there such a thing as "saved GID", and is that set for setuid (but
4266      * not setgid) execution like suidperl? Without exec, it would not be
4267      * cleared for setuid (but not setgid) scripts (or might need a dummy
4268      * setresgid).
4269      * 
4270      * We need suidperl to do the exact same argument checking that perl
4271      * does. Thus it cannot be very small; while it could be significantly
4272      * smaller, it is safer (simpler?) to make it essentially the same
4273      * binary as perl (but they are not identical). - Maybe could defer that
4274      * check to the invoked perl, and suidperl be a tiny wrapper instead;
4275      * but prefer to do thorough checks in suidperl itself. Such deferral
4276      * would make suidperl security rely on perl, a design no-no.
4277      * 
4278      * Setuid things should be short and simple, thus easy to understand and
4279      * verify. They should do their "own thing", without influence by
4280      * attackers. It may help if their internal execution flow is fixed,
4281      * regardless of platform: it may be best to exec anyway.
4282      * 
4283      * Suidperl should at least be conceptually simple: a wrapper only,
4284      * never to do any real perl. Maybe we should put
4285      * #ifdef IAMSUID
4286      *         Perl_croak(aTHX_ "Suidperl should never do real perl\n");
4287      * #endif
4288      * into the perly bits.
4289      */
4290     PerlIO_rewind(PL_rsfp);
4291     PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0);  /* just in case rewind didn't */
4292     /* PSz 11 Nov 03
4293      * Keep original arguments: suidperl already has fd script.
4294      */
4295 /*  for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ;  */
4296 /*  if (!PL_origargv[which]) {                                          */
4297 /*      errno = EPERM;                                                  */
4298 /*      Perl_croak(aTHX_ "Permission denied\n");                        */
4299 /*  }                                                                   */
4300 /*  PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s",        */
4301 /*                                PerlIO_fileno(PL_rsfp), PL_origargv[which])); */
4302 #if defined(HAS_FCNTL) && defined(F_SETFD)
4303     fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0);    /* ensure no close-on-exec */
4304 #endif
4305     PERL_FPU_PRE_EXEC
4306     PerlProc_execv(Perl_form(aTHX_ "%s/perl"PERL_FS_VER_FMT, BIN_EXP,
4307                              (int)PERL_REVISION, (int)PERL_VERSION,
4308                              (int)PERL_SUBVERSION), PL_origargv);/* try again */
4309     PERL_FPU_POST_EXEC
4310     Perl_croak(aTHX_ "Can't do setuid (suidperl cannot exec perl)\n");
4311 #endif /* IAMSUID */
4312 #else /* !DOSUID */
4313     if (PL_euid != PL_uid || PL_egid != PL_gid) {       /* (suidperl doesn't exist, in fact) */
4314 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
4315         PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf);      /* may be either wrapped or real suid */
4316         if ((PL_euid != PL_uid && PL_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
4317             ||
4318             (PL_egid != PL_gid && PL_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
4319            )
4320             if (!PL_do_undump)
4321                 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
4322 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
4323 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
4324         /* not set-id, must be wrapped */
4325     }
4326 #endif /* DOSUID */
4327     (void)validarg;
4328     (void)scriptname;
4329 }
4330
4331 STATIC void
4332 S_find_beginning(pTHX)
4333 {
4334     register char *s;
4335     register const char *s2;
4336 #ifdef MACOS_TRADITIONAL
4337     int maclines = 0;
4338 #endif
4339
4340     /* skip forward in input to the real script? */
4341
4342     forbid_setid("-x");
4343 #ifdef MACOS_TRADITIONAL
4344     /* Since the Mac OS does not honor #! arguments for us, we do it ourselves */
4345
4346     while (PL_doextract || gMacPerl_AlwaysExtract) {
4347         if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == NULL) {
4348             if (!gMacPerl_AlwaysExtract)
4349                 Perl_croak(aTHX_ "No Perl script found in input\n");
4350
4351             if (PL_doextract)                   /* require explicit override ? */
4352                 if (!OverrideExtract(PL_origfilename))
4353                     Perl_croak(aTHX_ "User aborted script\n");
4354                 else
4355                     PL_doextract = FALSE;
4356
4357             /* Pater peccavi, file does not have #! */
4358             PerlIO_rewind(PL_rsfp);
4359
4360             break;
4361         }
4362 #else
4363     while (PL_doextract) {
4364         if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == NULL)
4365             Perl_croak(aTHX_ "No Perl script found in input\n");
4366 #endif
4367         s2 = s;
4368         if (*s == '#' && s[1] == '!' && ((s = instr(s,"perl")) || (s = instr(s2,"PERL")))) {
4369             PerlIO_ungetc(PL_rsfp, '\n');               /* to keep line count right */
4370             PL_doextract = FALSE;
4371             while (*s && !(isSPACE (*s) || *s == '#')) s++;
4372             s2 = s;
4373             while (*s == ' ' || *s == '\t') s++;
4374             if (*s++ == '-') {
4375                 while (isDIGIT(s2[-1]) || s2[-1] == '-' || s2[-1] == '.'
4376                        || s2[-1] == '_') s2--;
4377                 if (strnEQ(s2-4,"perl",4))
4378                     while ((s = moreswitches(s)))
4379                         ;
4380             }
4381 #ifdef MACOS_TRADITIONAL
4382             /* We are always searching for the #!perl line in MacPerl,
4383              * so if we find it, still keep the line count correct
4384              * by counting lines we already skipped over
4385              */
4386             for (; maclines > 0 ; maclines--)
4387                 PerlIO_ungetc(PL_rsfp, '\n');
4388
4389             break;
4390
4391         /* gMacPerl_AlwaysExtract is false in MPW tool */
4392         } else if (gMacPerl_AlwaysExtract) {
4393             ++maclines;
4394 #endif
4395         }
4396     }
4397 }
4398
4399
4400 STATIC void
4401 S_init_ids(pTHX)
4402 {
4403     PL_uid = PerlProc_getuid();
4404     PL_euid = PerlProc_geteuid();
4405     PL_gid = PerlProc_getgid();
4406     PL_egid = PerlProc_getegid();
4407 #ifdef VMS
4408     PL_uid |= PL_gid << 16;
4409     PL_euid |= PL_egid << 16;
4410 #endif
4411     /* Should not happen: */
4412     CHECK_MALLOC_TAINT(PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
4413     PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
4414     /* BUG */
4415     /* PSz 27 Feb 04
4416      * Should go by suidscript, not uid!=euid: why disallow
4417      * system("ls") in scripts run from setuid things?
4418      * Or, is this run before we check arguments and set suidscript?
4419      * What about SETUID_SCRIPTS_ARE_SECURE_NOW: could we use fdscript then?
4420      * (We never have suidscript, can we be sure to have fdscript?)
4421      * Or must then go by UID checks? See comments in forbid_setid also.
4422      */
4423 }
4424
4425 /* This is used very early in the lifetime of the program,
4426  * before even the options are parsed, so PL_tainting has
4427  * not been initialized properly.  */
4428 bool
4429 Perl_doing_taint(int argc, char *argv[], char *envp[])
4430 {
4431 #ifndef PERL_IMPLICIT_SYS
4432     /* If we have PERL_IMPLICIT_SYS we can't call getuid() et alia
4433      * before we have an interpreter-- and the whole point of this
4434      * function is to be called at such an early stage.  If you are on
4435      * a system with PERL_IMPLICIT_SYS but you do have a concept of
4436      * "tainted because running with altered effective ids', you'll
4437      * have to add your own checks somewhere in here.  The two most
4438      * known samples of 'implicitness' are Win32 and NetWare, neither
4439      * of which has much of concept of 'uids'. */
4440     int uid  = PerlProc_getuid();
4441     int euid = PerlProc_geteuid();
4442     int gid  = PerlProc_getgid();
4443     int egid = PerlProc_getegid();
4444     (void)envp;
4445
4446 #ifdef VMS
4447     uid  |=  gid << 16;
4448     euid |= egid << 16;
4449 #endif
4450     if (uid && (euid != uid || egid != gid))
4451         return 1;
4452 #endif /* !PERL_IMPLICIT_SYS */
4453     /* This is a really primitive check; environment gets ignored only
4454      * if -T are the first chars together; otherwise one gets
4455      *  "Too late" message. */
4456     if ( argc > 1 && argv[1][0] == '-'
4457          && (argv[1][1] == 't' || argv[1][1] == 'T') )
4458         return 1;
4459     return 0;
4460 }
4461
4462 STATIC void
4463 S_forbid_setid(pTHX_ const char *s)
4464 {
4465 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
4466     if (PL_euid != PL_uid)
4467         Perl_croak(aTHX_ "No %s allowed while running setuid", s);
4468     if (PL_egid != PL_gid)
4469         Perl_croak(aTHX_ "No %s allowed while running setgid", s);
4470 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
4471     /* PSz 29 Feb 04
4472      * Checks for UID/GID above "wrong": why disallow
4473      *   perl -e 'print "Hello\n"'
4474      * from within setuid things?? Simply drop them: replaced by
4475      * fdscript/suidscript and #ifdef IAMSUID checks below.
4476      * 
4477      * This may be too late for command-line switches. Will catch those on
4478      * the #! line, after finding the script name and setting up
4479      * fdscript/suidscript. Note that suidperl does not get around to
4480      * parsing (and checking) the switches on the #! line, but checks that
4481      * the two sets are identical.
4482      * 
4483      * With SETUID_SCRIPTS_ARE_SECURE_NOW, could we use fdscript, also or
4484      * instead, or would that be "too late"? (We never have suidscript, can
4485      * we be sure to have fdscript?)
4486      * 
4487      * Catch things with suidscript (in descendant of suidperl), even with
4488      * right UID/GID. Was already checked in suidperl, with #ifdef IAMSUID,
4489      * below; but I am paranoid.
4490      * 
4491      * Also see comments about root running a setuid script, elsewhere.
4492      */
4493     if (PL_suidscript >= 0)
4494         Perl_croak(aTHX_ "No %s allowed with (suid) fdscript", s);
4495 #ifdef IAMSUID
4496     /* PSz 11 Nov 03  Catch it in suidperl, always! */
4497     Perl_croak(aTHX_ "No %s allowed in suidperl", s);
4498 #endif /* IAMSUID */
4499 }
4500
4501 void
4502 Perl_init_debugger(pTHX)
4503 {
4504     HV * const ostash = PL_curstash;
4505
4506     PL_curstash = PL_debstash;
4507     PL_dbargs = GvAV(gv_AVadd((gv_fetchpv("DB::args", GV_ADDMULTI, SVt_PVAV))));
4508     AvREAL_off(PL_dbargs);
4509     PL_DBgv = gv_fetchpv("DB::DB", GV_ADDMULTI, SVt_PVGV);
4510     PL_DBline = gv_fetchpv("DB::dbline", GV_ADDMULTI, SVt_PVAV);
4511     PL_DBsub = gv_HVadd(gv_fetchpv("DB::sub", GV_ADDMULTI, SVt_PVHV));
4512     PL_DBsingle = GvSV((gv_fetchpv("DB::single", GV_ADDMULTI, SVt_PV)));
4513     sv_setiv(PL_DBsingle, 0);
4514     PL_DBtrace = GvSV((gv_fetchpv("DB::trace", GV_ADDMULTI, SVt_PV)));
4515     sv_setiv(PL_DBtrace, 0);
4516     PL_DBsignal = GvSV((gv_fetchpv("DB::signal", GV_ADDMULTI, SVt_PV)));
4517     sv_setiv(PL_DBsignal, 0);
4518     PL_curstash = ostash;
4519 }
4520
4521 #ifndef STRESS_REALLOC
4522 #define REASONABLE(size) (size)
4523 #else
4524 #define REASONABLE(size) (1) /* unreasonable */
4525 #endif
4526
4527 void
4528 Perl_init_stacks(pTHX)
4529 {
4530     /* start with 128-item stack and 8K cxstack */
4531     PL_curstackinfo = new_stackinfo(REASONABLE(128),
4532                                  REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
4533     PL_curstackinfo->si_type = PERLSI_MAIN;
4534     PL_curstack = PL_curstackinfo->si_stack;
4535     PL_mainstack = PL_curstack;         /* remember in case we switch stacks */
4536
4537     PL_stack_base = AvARRAY(PL_curstack);
4538     PL_stack_sp = PL_stack_base;
4539     PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
4540
4541     Newx(PL_tmps_stack,REASONABLE(128),SV*);
4542     PL_tmps_floor = -1;
4543     PL_tmps_ix = -1;
4544     PL_tmps_max = REASONABLE(128);
4545
4546     Newx(PL_markstack,REASONABLE(32),I32);
4547     PL_markstack_ptr = PL_markstack;
4548     PL_markstack_max = PL_markstack + REASONABLE(32);
4549
4550     SET_MARK_OFFSET;
4551
4552     Newx(PL_scopestack,REASONABLE(32),I32);
4553     PL_scopestack_ix = 0;
4554     PL_scopestack_max = REASONABLE(32);
4555
4556     Newx(PL_savestack,REASONABLE(128),ANY);
4557     PL_savestack_ix = 0;
4558     PL_savestack_max = REASONABLE(128);
4559
4560     New(54,PL_retstack,REASONABLE(16),OP*);
4561     PL_retstack_ix = 0;
4562     PL_retstack_max = REASONABLE(16);
4563 }
4564
4565 #undef REASONABLE
4566
4567 STATIC void
4568 S_nuke_stacks(pTHX)
4569 {
4570     while (PL_curstackinfo->si_next)
4571         PL_curstackinfo = PL_curstackinfo->si_next;
4572     while (PL_curstackinfo) {
4573         PERL_SI *p = PL_curstackinfo->si_prev;
4574         /* curstackinfo->si_stack got nuked by sv_free_arenas() */
4575         Safefree(PL_curstackinfo->si_cxstack);
4576         Safefree(PL_curstackinfo);
4577         PL_curstackinfo = p;
4578     }
4579     Safefree(PL_tmps_stack);
4580     Safefree(PL_markstack);
4581     Safefree(PL_scopestack);
4582     Safefree(PL_savestack);
4583     Safefree(PL_retstack);
4584 }
4585
4586 STATIC void
4587 S_init_lexer(pTHX)
4588 {
4589     PerlIO *tmpfp;
4590     tmpfp = PL_rsfp;
4591     PL_rsfp = NULL;
4592     lex_start(PL_linestr);
4593     PL_rsfp = tmpfp;
4594     PL_subname = newSVpvs("main");
4595 }
4596
4597 STATIC void
4598 S_init_predump_symbols(pTHX)
4599 {
4600     GV *tmpgv;
4601     IO *io;
4602
4603     sv_setpvn(get_sv("\"", TRUE), " ", 1);
4604     PL_stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
4605     GvMULTI_on(PL_stdingv);
4606     io = GvIOp(PL_stdingv);
4607     IoTYPE(io) = IoTYPE_RDONLY;
4608     IoIFP(io) = PerlIO_stdin();
4609     tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
4610     GvMULTI_on(tmpgv);
4611     GvIOp(tmpgv) = (IO*)SvREFCNT_inc_simple(io);
4612
4613     tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
4614     GvMULTI_on(tmpgv);
4615     io = GvIOp(tmpgv);
4616     IoTYPE(io) = IoTYPE_WRONLY;
4617     IoOFP(io) = IoIFP(io) = PerlIO_stdout();
4618     setdefout(tmpgv);
4619     tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
4620     GvMULTI_on(tmpgv);
4621     GvIOp(tmpgv) = (IO*)SvREFCNT_inc_simple(io);
4622
4623     PL_stderrgv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
4624     GvMULTI_on(PL_stderrgv);
4625     io = GvIOp(PL_stderrgv);
4626     IoTYPE(io) = IoTYPE_WRONLY;
4627     IoOFP(io) = IoIFP(io) = PerlIO_stderr();
4628     tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
4629     GvMULTI_on(tmpgv);
4630     GvIOp(tmpgv) = (IO*)SvREFCNT_inc_simple(io);
4631
4632     PL_statname = newSV(0);             /* last filename we did stat on */
4633
4634     Safefree(PL_osname);
4635     PL_osname = savepv(OSNAME);
4636 }
4637
4638 void
4639 Perl_init_argv_symbols(pTHX_ register int argc, register char **argv)
4640 {
4641     argc--,argv++;      /* skip name of script */
4642     if (PL_doswitches) {
4643         for (; argc > 0 && **argv == '-'; argc--,argv++) {
4644             char *s;
4645             if (!argv[0][1])
4646                 break;
4647             if (argv[0][1] == '-' && !argv[0][2]) {
4648                 argc--,argv++;
4649                 break;
4650             }
4651             if ((s = strchr(argv[0], '='))) {
4652                 const char *const start_name = argv[0] + 1;
4653                 sv_setpv(GvSV(gv_fetchpvn_flags(start_name, s - start_name,
4654                                                 TRUE, SVt_PV)), s + 1);
4655             }
4656             else
4657                 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
4658         }
4659     }
4660     if ((PL_argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV))) {
4661         GvMULTI_on(PL_argvgv);
4662         (void)gv_AVadd(PL_argvgv);
4663         av_clear(GvAVn(PL_argvgv));
4664         for (; argc > 0; argc--,argv++) {
4665             SV * const sv = newSVpv(argv[0],0);
4666             av_push(GvAVn(PL_argvgv),sv);
4667             if (!(PL_unicode & PERL_UNICODE_LOCALE_FLAG) || PL_utf8locale) {
4668                  if (PL_unicode & PERL_UNICODE_ARGV_FLAG)
4669                       SvUTF8_on(sv);
4670             }
4671             if (PL_unicode & PERL_UNICODE_WIDESYSCALLS_FLAG) /* Sarathy? */
4672                  (void)sv_utf8_decode(sv);
4673         }
4674     }
4675 }
4676
4677 STATIC void
4678 S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env)
4679 {
4680     GV* tmpgv;
4681
4682     PL_toptarget = newSV(0);
4683     sv_upgrade(PL_toptarget, SVt_PVFM);
4684     sv_setpvn(PL_toptarget, "", 0);
4685     PL_bodytarget = newSV(0);
4686     sv_upgrade(PL_bodytarget, SVt_PVFM);
4687     sv_setpvn(PL_bodytarget, "", 0);
4688     PL_formtarget = PL_bodytarget;
4689
4690     TAINT;
4691
4692     init_argv_symbols(argc,argv);
4693
4694     if ((tmpgv = gv_fetchpv("0",TRUE, SVt_PV))) {
4695 #ifdef MACOS_TRADITIONAL
4696         /* $0 is not majick on a Mac */
4697         sv_setpv(GvSV(tmpgv),MacPerl_MPWFileName(PL_origfilename));
4698 #else
4699         sv_setpv(GvSV(tmpgv),PL_origfilename);
4700         magicname("0", "0", 1);
4701 #endif
4702     }
4703     if ((PL_envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV))) {
4704         HV *hv;
4705         GvMULTI_on(PL_envgv);
4706         hv = GvHVn(PL_envgv);
4707         hv_magic(hv, NULL, PERL_MAGIC_env);
4708 #ifndef PERL_MICRO
4709 #ifdef USE_ENVIRON_ARRAY
4710         /* Note that if the supplied env parameter is actually a copy
4711            of the global environ then it may now point to free'd memory
4712            if the environment has been modified since. To avoid this
4713            problem we treat env==NULL as meaning 'use the default'
4714         */
4715         if (!env)
4716             env = environ;
4717         if (env != environ
4718 #  ifdef USE_ITHREADS
4719             && PL_curinterp == aTHX
4720 #  endif
4721            )
4722         {
4723             environ[0] = NULL;
4724         }
4725         if (env) {
4726           char** origenv = environ;
4727           char *s;
4728           SV *sv;
4729           for (; *env; env++) {
4730             if (!(s = strchr(*env,'=')) || s == *env)
4731                 continue;
4732 #if defined(MSDOS) && !defined(DJGPP)
4733             *s = '\0';
4734             (void)strupr(*env);
4735             *s = '=';
4736 #endif
4737             sv = newSVpv(s+1, 0);
4738             (void)hv_store(hv, *env, s - *env, sv, 0);
4739             if (env != environ)
4740                 mg_set(sv);
4741             if (origenv != environ) {
4742               /* realloc has shifted us */
4743               env = (env - origenv) + environ;
4744               origenv = environ;