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