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