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