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