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