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