/*    perl.c
 *
 *    Copyright (c) 1987-2001 Larry Wall
 *
 *    You may distribute under the terms of either the GNU General Public
 *    License or the Artistic License, as specified in the README file.
 *
 */

/*
 * "A ship then new they built for him/of mithril and of elven glass" --Bilbo
 */

#include "EXTERN.h"
#define PERL_IN_PERL_C
#include "perl.h"
#include "patchlevel.h"			/* for local_patches */

/* XXX If this causes problems, set i_unistd=undef in the hint file.  */
#ifdef I_UNISTD
#include <unistd.h>
#endif

#if !defined(STANDARD_C) && !defined(HAS_GETENV_PROTOTYPE) && !defined(PERL_MICRO)
char *getenv (char *); /* Usually in <stdlib.h> */
#endif

static I32 read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen);

#ifdef IAMSUID
#ifndef DOSUID
#define DOSUID
#endif
#endif

#ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
#ifdef DOSUID
#undef DOSUID
#endif
#endif

#if defined(USE_5005THREADS)
#  define INIT_TLS_AND_INTERP \
    STMT_START {				\
	if (!PL_curinterp) {			\
	    PERL_SET_INTERP(my_perl);		\
	    INIT_THREADS;			\
	    ALLOC_THREAD_KEY;			\
	}					\
    } STMT_END
#else
#  if defined(USE_ITHREADS)
#  define INIT_TLS_AND_INTERP \
    STMT_START {				\
	if (!PL_curinterp) {			\
	    PERL_SET_INTERP(my_perl);		\
	    INIT_THREADS;			\
	    ALLOC_THREAD_KEY;			\
	    PERL_SET_THX(my_perl);		\
	    OP_REFCNT_INIT;			\
	}					\
	else {					\
	    PERL_SET_THX(my_perl);		\
	}					\
    } STMT_END
#  else
#  define INIT_TLS_AND_INTERP \
    STMT_START {				\
	if (!PL_curinterp) {			\
	    PERL_SET_INTERP(my_perl);		\
	}					\
	PERL_SET_THX(my_perl);			\
    } STMT_END
#  endif
#endif

#ifdef PERL_IMPLICIT_SYS
PerlInterpreter *
perl_alloc_using(struct IPerlMem* ipM, struct IPerlMem* ipMS,
		 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
		 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
		 struct IPerlDir* ipD, struct IPerlSock* ipS,
		 struct IPerlProc* ipP)
{
    PerlInterpreter *my_perl;
    /* New() needs interpreter, so call malloc() instead */
    my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
    INIT_TLS_AND_INTERP;
    Zero(my_perl, 1, PerlInterpreter);
    PL_Mem = ipM;
    PL_MemShared = ipMS;
    PL_MemParse = ipMP;
    PL_Env = ipE;
    PL_StdIO = ipStd;
    PL_LIO = ipLIO;
    PL_Dir = ipD;
    PL_Sock = ipS;
    PL_Proc = ipP;

    return my_perl;
}
#else

/*
=for apidoc perl_alloc

Allocates a new Perl interpreter.  See L<perlembed>.

=cut
*/

PerlInterpreter *
perl_alloc(void)
{
    PerlInterpreter *my_perl;

    /* New() needs interpreter, so call malloc() instead */
    my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));

    INIT_TLS_AND_INTERP;
    Zero(my_perl, 1, PerlInterpreter);
    return my_perl;
}
#endif /* PERL_IMPLICIT_SYS */

/*
=for apidoc perl_construct

Initializes a new Perl interpreter.  See L<perlembed>.

=cut
*/

void
perl_construct(pTHXx)
{
#ifdef USE_5005THREADS
#ifndef FAKE_THREADS
    struct perl_thread *thr = NULL;
#endif /* FAKE_THREADS */
#endif /* USE_5005THREADS */

#ifdef MULTIPLICITY
    init_interp();
    PL_perl_destruct_level = 1;
#else
   if (PL_perl_destruct_level > 0)
       init_interp();
#endif

   /* Init the real globals (and main thread)? */
    if (!PL_linestr) {
#ifdef USE_5005THREADS
	MUTEX_INIT(&PL_sv_mutex);
	/*
	 * Safe to use basic SV functions from now on (though
	 * not things like mortals or tainting yet).
	 */
	MUTEX_INIT(&PL_eval_mutex);
	COND_INIT(&PL_eval_cond);
	MUTEX_INIT(&PL_threads_mutex);
	COND_INIT(&PL_nthreads_cond);
#  ifdef EMULATE_ATOMIC_REFCOUNTS
	MUTEX_INIT(&PL_svref_mutex);
#  endif /* EMULATE_ATOMIC_REFCOUNTS */
	
	MUTEX_INIT(&PL_cred_mutex);
	MUTEX_INIT(&PL_sv_lock_mutex);
	MUTEX_INIT(&PL_fdpid_mutex);

	thr = init_main_thread();
#endif /* USE_5005THREADS */

#ifdef PERL_FLEXIBLE_EXCEPTIONS
	PL_protect = MEMBER_TO_FPTR(Perl_default_protect); /* for exceptions */
#endif

	PL_curcop = &PL_compiling;	/* needed by ckWARN, right away */

	PL_linestr = NEWSV(65,79);
	sv_upgrade(PL_linestr,SVt_PVIV);

	if (!SvREADONLY(&PL_sv_undef)) {
	    /* set read-only and try to insure than we wont see REFCNT==0
	       very often */

	    SvREADONLY_on(&PL_sv_undef);
	    SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;

	    sv_setpv(&PL_sv_no,PL_No);
	    SvNV(&PL_sv_no);
	    SvREADONLY_on(&PL_sv_no);
	    SvREFCNT(&PL_sv_no) = (~(U32)0)/2;

	    sv_setpv(&PL_sv_yes,PL_Yes);
	    SvNV(&PL_sv_yes);
	    SvREADONLY_on(&PL_sv_yes);
	    SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
	}

	PL_sighandlerp = Perl_sighandler;
	PL_pidstatus = newHV();

#ifdef MSDOS
	/*
	 * There is no way we can refer to them from Perl so close them to save
	 * space.  The other alternative would be to provide STDAUX and STDPRN
	 * filehandles.
	 */
	(void)PerlIO_close(PerlIO_importFILE(stdaux, 0));
	(void)PerlIO_close(PerlIO_importFILE(stdprn, 0));
#endif
    }

    PL_rs = newSVpvn("\n", 1);

    init_stacks();

    init_ids();
    PL_lex_state = LEX_NOTPARSING;

    JMPENV_BOOTSTRAP;
    STATUS_ALL_SUCCESS;

    init_i18nl10n(1);
    SET_NUMERIC_STANDARD();

    {
	U8 *s;
	PL_patchlevel = NEWSV(0,4);
	(void)SvUPGRADE(PL_patchlevel, SVt_PVNV);
	if (PERL_REVISION > 127 || PERL_VERSION > 127 || PERL_SUBVERSION > 127)
	    SvGROW(PL_patchlevel, UTF8_MAXLEN*3+1);
	s = (U8*)SvPVX(PL_patchlevel);
	/* Build version strings using "native" characters */
	s = uvchr_to_utf8(s, (UV)PERL_REVISION);
	s = uvchr_to_utf8(s, (UV)PERL_VERSION);
	s = uvchr_to_utf8(s, (UV)PERL_SUBVERSION);
	*s = '\0';
	SvCUR_set(PL_patchlevel, s - (U8*)SvPVX(PL_patchlevel));
	SvPOK_on(PL_patchlevel);
	SvNVX(PL_patchlevel) = (NV)PERL_REVISION
				+ ((NV)PERL_VERSION / (NV)1000)
#if defined(PERL_SUBVERSION) && PERL_SUBVERSION > 0
				+ ((NV)PERL_SUBVERSION / (NV)1000000)
#endif
				;
	SvNOK_on(PL_patchlevel);	/* dual valued */
	SvUTF8_on(PL_patchlevel);
	SvREADONLY_on(PL_patchlevel);
    }

#if defined(LOCAL_PATCH_COUNT)
    PL_localpatches = local_patches;	/* For possible -v */
#endif

#ifdef HAVE_INTERP_INTERN
    sys_intern_init();
#endif

    PerlIO_init(aTHX);			/* Hook to IO system */

    PL_fdpid = newAV();			/* for remembering popen pids by fd */
    PL_modglobal = newHV();		/* pointers to per-interpreter module globals */
    PL_errors = newSVpvn("",0);
#ifdef USE_ITHREADS
    PL_regex_padav = newAV();
    av_push(PL_regex_padav,(SV*)newAV());    /* First entry is an array of empty elements */
    PL_regex_pad = AvARRAY(PL_regex_padav);
#endif
#ifdef USE_REENTRANT_API
    New(31337, PL_reentrant_buffer,1, REBUF);
    New(31337, PL_reentrant_buffer->tmbuff,1, struct tm);
#endif

    /* Note that strtab is a rather special HV.  Assumptions are made
       about not iterating on it, and not adding tie magic to it.
       It is properly deallocated in perl_destruct() */
    PL_strtab = newHV();

#ifdef USE_5005THREADS
    MUTEX_INIT(&PL_strtab_mutex);
#endif
    HvSHAREKEYS_off(PL_strtab);			/* mandatory */
    hv_ksplit(PL_strtab, 512);

#if defined(__DYNAMIC__) && (defined(NeXT) || defined(__NeXT__))
    _dyld_lookup_and_bind
	("__environ", (unsigned long *) &environ_pointer, NULL);
#endif /* environ */

#ifdef  USE_ENVIRON_ARRAY
    PL_origenviron = environ;
#endif

    ENTER;
}

/*
=for apidoc perl_destruct

Shuts down a Perl interpreter.  See L<perlembed>.

=cut
*/

int
perl_destruct(pTHXx)
{
    volatile int destruct_level;  /* 0=none, 1=full, 2=full with checks */
    HV *hv;
#ifdef USE_5005THREADS
    Thread t;
    dTHX;
#endif /* USE_5005THREADS */

    /* wait for all pseudo-forked children to finish */
    PERL_WAIT_FOR_CHILDREN;

#ifdef USE_5005THREADS
#ifndef FAKE_THREADS
    /* Pass 1 on any remaining threads: detach joinables, join zombies */
  retry_cleanup:
    MUTEX_LOCK(&PL_threads_mutex);
    DEBUG_S(PerlIO_printf(Perl_debug_log,
			  "perl_destruct: waiting for %d threads...\n",
			  PL_nthreads - 1));
    for (t = thr->next; t != thr; t = t->next) {
	MUTEX_LOCK(&t->mutex);
	switch (ThrSTATE(t)) {
	    AV *av;
	case THRf_ZOMBIE:
	    DEBUG_S(PerlIO_printf(Perl_debug_log,
				  "perl_destruct: joining zombie %p\n", t));
	    ThrSETSTATE(t, THRf_DEAD);
	    MUTEX_UNLOCK(&t->mutex);
	    PL_nthreads--;
	    /*
	     * The SvREFCNT_dec below may take a long time (e.g. av
	     * may contain an object scalar whose destructor gets
	     * called) so we have to unlock threads_mutex and start
	     * all over again.
	     */
	    MUTEX_UNLOCK(&PL_threads_mutex);
	    JOIN(t, &av);
	    SvREFCNT_dec((SV*)av);
	    DEBUG_S(PerlIO_printf(Perl_debug_log,
				  "perl_destruct: joined zombie %p OK\n", t));
	    goto retry_cleanup;
	case THRf_R_JOINABLE:
	    DEBUG_S(PerlIO_printf(Perl_debug_log,
				  "perl_destruct: detaching thread %p\n", t));
	    ThrSETSTATE(t, THRf_R_DETACHED);
	    /*
	     * We unlock threads_mutex and t->mutex in the opposite order
	     * from which we locked them just so that DETACH won't
	     * deadlock if it panics. It's only a breach of good style
	     * not a bug since they are unlocks not locks.
	     */
	    MUTEX_UNLOCK(&PL_threads_mutex);
	    DETACH(t);
	    MUTEX_UNLOCK(&t->mutex);
	    goto retry_cleanup;
	default:
	    DEBUG_S(PerlIO_printf(Perl_debug_log,
				  "perl_destruct: ignoring %p (state %u)\n",
				  t, ThrSTATE(t)));
	    MUTEX_UNLOCK(&t->mutex);
	    /* fall through and out */
	}
    }
    /* We leave the above "Pass 1" loop with threads_mutex still locked */

    /* Pass 2 on remaining threads: wait for the thread count to drop to one */
    while (PL_nthreads > 1)
    {
	DEBUG_S(PerlIO_printf(Perl_debug_log,
			      "perl_destruct: final wait for %d threads\n",
			      PL_nthreads - 1));
	COND_WAIT(&PL_nthreads_cond, &PL_threads_mutex);
    }
    /* At this point, we're the last thread */
    MUTEX_UNLOCK(&PL_threads_mutex);
    DEBUG_S(PerlIO_printf(Perl_debug_log, "perl_destruct: armageddon has arrived\n"));
    MUTEX_DESTROY(&PL_threads_mutex);
    COND_DESTROY(&PL_nthreads_cond);
    PL_nthreads--;
#endif /* !defined(FAKE_THREADS) */
#endif /* USE_5005THREADS */

    destruct_level = PL_perl_destruct_level;
#ifdef DEBUGGING
    {
	char *s;
	if ((s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL"))) {
	    int i = atoi(s);
	    if (destruct_level < i)
		destruct_level = i;
	}
    }
#endif


    if(PL_exit_flags & PERL_EXIT_DESTRUCT_END) {
        dJMPENV;
        int x = 0;

        JMPENV_PUSH(x);
        if (PL_endav && !PL_minus_c)
            call_list(PL_scopestack_ix, PL_endav);
        JMPENV_POP;
    }
    LEAVE;
    FREETMPS;

    /* We must account for everything.  */

    /* Destroy the main CV and syntax tree */
    if (PL_main_root) {
	PL_curpad = AvARRAY(PL_comppad);
	op_free(PL_main_root);
	PL_main_root = Nullop;
    }
    PL_curcop = &PL_compiling;
    PL_main_start = Nullop;
    SvREFCNT_dec(PL_main_cv);
    PL_main_cv = Nullcv;
    PL_dirty = TRUE;

    /* Tell PerlIO we are about to tear things apart in case
       we have layers which are using resources that should
       be cleaned up now.
     */

    PerlIO_destruct(aTHX);

    if (PL_sv_objcount) {
	/*
	 * Try to destruct global references.  We do this first so that the
	 * destructors and destructees still exist.  Some sv's might remain.
	 * Non-referenced objects are on their own.
	 */
	sv_clean_objs();
    }

    /* unhook hooks which will soon be, or use, destroyed data */
    SvREFCNT_dec(PL_warnhook);
    PL_warnhook = Nullsv;
    SvREFCNT_dec(PL_diehook);
    PL_diehook = Nullsv;

    /* call exit list functions */
    while (PL_exitlistlen-- > 0)
	PL_exitlist[PL_exitlistlen].fn(aTHX_ PL_exitlist[PL_exitlistlen].ptr);

    Safefree(PL_exitlist);

    if (destruct_level == 0){

	DEBUG_P(debprofdump());

#if defined(PERLIO_LAYERS)
	/* No more IO - including error messages ! */
	PerlIO_cleanup(aTHX);
#endif

	/* The exit() function will do everything that needs doing. */
        return STATUS_NATIVE_EXPORT;;
    }

    /* jettison our possibly duplicated environment */

#ifdef USE_ENVIRON_ARRAY
    if (environ != PL_origenviron) {
	I32 i;

	for (i = 0; environ[i]; i++)
	    safesysfree(environ[i]);

	/* Must use safesysfree() when working with environ. */
	safesysfree(environ);		

	environ = PL_origenviron;
    }
#endif

#ifdef USE_ITHREADS
    /* the syntax tree is shared between clones
     * so op_free(PL_main_root) only ReREFCNT_dec's
     * REGEXPs in the parent interpreter
     * we need to manually ReREFCNT_dec for the clones
     */
    {
        I32 i = AvFILLp(PL_regex_padav) + 1;
        SV **ary = AvARRAY(PL_regex_padav);

        while (i) {
            SV *resv = ary[--i];
            REGEXP *re = INT2PTR(REGEXP *,SvIVX(resv));

            if (SvFLAGS(resv) & SVf_BREAK) {
                /* this is PL_reg_curpm, already freed
                 * flag is set in regexec.c:S_regtry
                 */
                SvFLAGS(resv) &= ~SVf_BREAK;
            }
	    else if(SvREPADTMP(resv)) {
	      SvREPADTMP_off(resv);
	    }
            else {
                ReREFCNT_dec(re);
            }
        }
    }
    SvREFCNT_dec(PL_regex_padav);
    PL_regex_padav = Nullav;
    PL_regex_pad = NULL;
#endif

    /* loosen bonds of global variables */

    if(PL_rsfp) {
	(void)PerlIO_close(PL_rsfp);
	PL_rsfp = Nullfp;
    }

    /* Filters for program text */
    SvREFCNT_dec(PL_rsfp_filters);
    PL_rsfp_filters = Nullav;

    /* switches */
    PL_preprocess   = FALSE;
    PL_minus_n      = FALSE;
    PL_minus_p      = FALSE;
    PL_minus_l      = FALSE;
    PL_minus_a      = FALSE;
    PL_minus_F      = FALSE;
    PL_doswitches   = FALSE;
    PL_dowarn       = G_WARN_OFF;
    PL_doextract    = FALSE;
    PL_sawampersand = FALSE;	/* must save all match strings */
    PL_unsafe       = FALSE;

    Safefree(PL_inplace);
    PL_inplace = Nullch;
    SvREFCNT_dec(PL_patchlevel);

    if (PL_e_script) {
	SvREFCNT_dec(PL_e_script);
	PL_e_script = Nullsv;
    }

    while (--PL_origargc >= 0) {
        Safefree(PL_origargv[PL_origargc]);
    }
    Safefree(PL_origargv);

    /* magical thingies */

    SvREFCNT_dec(PL_ofs_sv);	/* $, */
    PL_ofs_sv = Nullsv;

    SvREFCNT_dec(PL_ors_sv);	/* $\ */
    PL_ors_sv = Nullsv;

    SvREFCNT_dec(PL_rs);	/* $/ */
    PL_rs = Nullsv;

    PL_multiline = 0;		/* $* */
    Safefree(PL_osname);	/* $^O */
    PL_osname = Nullch;

    SvREFCNT_dec(PL_statname);
    PL_statname = Nullsv;
    PL_statgv = Nullgv;

    /* defgv, aka *_ should be taken care of elsewhere */

    /* clean up after study() */
    SvREFCNT_dec(PL_lastscream);
    PL_lastscream = Nullsv;
    Safefree(PL_screamfirst);
    PL_screamfirst = 0;
    Safefree(PL_screamnext);
    PL_screamnext  = 0;

    /* float buffer */
    Safefree(PL_efloatbuf);
    PL_efloatbuf = Nullch;
    PL_efloatsize = 0;

    /* startup and shutdown function lists */
    SvREFCNT_dec(PL_beginav);
    SvREFCNT_dec(PL_beginav_save);
    SvREFCNT_dec(PL_endav);
    SvREFCNT_dec(PL_checkav);
    SvREFCNT_dec(PL_initav);
    PL_beginav = Nullav;
    PL_beginav_save = Nullav;
    PL_endav = Nullav;
    PL_checkav = Nullav;
    PL_initav = Nullav;

    /* shortcuts just get cleared */
    PL_envgv = Nullgv;
    PL_incgv = Nullgv;
    PL_hintgv = Nullgv;
    PL_errgv = Nullgv;
    PL_argvgv = Nullgv;
    PL_argvoutgv = Nullgv;
    PL_stdingv = Nullgv;
    PL_stderrgv = Nullgv;
    PL_last_in_gv = Nullgv;
    PL_replgv = Nullgv;
    PL_debstash = Nullhv;

    /* reset so print() ends up where we expect */
    setdefout(Nullgv);

    SvREFCNT_dec(PL_argvout_stack);
    PL_argvout_stack = Nullav;

    SvREFCNT_dec(PL_modglobal);
    PL_modglobal = Nullhv;
    SvREFCNT_dec(PL_preambleav);
    PL_preambleav = Nullav;
    SvREFCNT_dec(PL_subname);
    PL_subname = Nullsv;
    SvREFCNT_dec(PL_linestr);
    PL_linestr = Nullsv;
    SvREFCNT_dec(PL_pidstatus);
    PL_pidstatus = Nullhv;
    SvREFCNT_dec(PL_toptarget);
    PL_toptarget = Nullsv;
    SvREFCNT_dec(PL_bodytarget);
    PL_bodytarget = Nullsv;
    PL_formtarget = Nullsv;

    /* free locale stuff */
#ifdef USE_LOCALE_COLLATE
    Safefree(PL_collation_name);
    PL_collation_name = Nullch;
#endif

#ifdef USE_LOCALE_NUMERIC
    Safefree(PL_numeric_name);
    PL_numeric_name = Nullch;
    SvREFCNT_dec(PL_numeric_radix_sv);
#endif

    /* clear utf8 character classes */
    SvREFCNT_dec(PL_utf8_alnum);
    SvREFCNT_dec(PL_utf8_alnumc);
    SvREFCNT_dec(PL_utf8_ascii);
    SvREFCNT_dec(PL_utf8_alpha);
    SvREFCNT_dec(PL_utf8_space);
    SvREFCNT_dec(PL_utf8_cntrl);
    SvREFCNT_dec(PL_utf8_graph);
    SvREFCNT_dec(PL_utf8_digit);
    SvREFCNT_dec(PL_utf8_upper);
    SvREFCNT_dec(PL_utf8_lower);
    SvREFCNT_dec(PL_utf8_print);
    SvREFCNT_dec(PL_utf8_punct);
    SvREFCNT_dec(PL_utf8_xdigit);
    SvREFCNT_dec(PL_utf8_mark);
    SvREFCNT_dec(PL_utf8_toupper);
    SvREFCNT_dec(PL_utf8_totitle);
    SvREFCNT_dec(PL_utf8_tolower);
    SvREFCNT_dec(PL_utf8_tofold);
    PL_utf8_alnum	= Nullsv;
    PL_utf8_alnumc	= Nullsv;
    PL_utf8_ascii	= Nullsv;
    PL_utf8_alpha	= Nullsv;
    PL_utf8_space	= Nullsv;
    PL_utf8_cntrl	= Nullsv;
    PL_utf8_graph	= Nullsv;
    PL_utf8_digit	= Nullsv;
    PL_utf8_upper	= Nullsv;
    PL_utf8_lower	= Nullsv;
    PL_utf8_print	= Nullsv;
    PL_utf8_punct	= Nullsv;
    PL_utf8_xdigit	= Nullsv;
    PL_utf8_mark	= Nullsv;
    PL_utf8_toupper	= Nullsv;
    PL_utf8_totitle	= Nullsv;
    PL_utf8_tolower	= Nullsv;
    PL_utf8_tofold	= Nullsv;

    if (!specialWARN(PL_compiling.cop_warnings))
	SvREFCNT_dec(PL_compiling.cop_warnings);
    PL_compiling.cop_warnings = Nullsv;
    if (!specialCopIO(PL_compiling.cop_io))
	SvREFCNT_dec(PL_compiling.cop_io);
    PL_compiling.cop_io = Nullsv;
#ifdef USE_ITHREADS
    Safefree(CopFILE(&PL_compiling));
    CopFILE(&PL_compiling) = Nullch;
    Safefree(CopSTASHPV(&PL_compiling));
#else
    SvREFCNT_dec(CopFILEGV(&PL_compiling));
    CopFILEGV(&PL_compiling) = Nullgv;
    /* cop_stash is not refcounted */
#endif

    /* Prepare to destruct main symbol table.  */

    hv = PL_defstash;
    PL_defstash = 0;
    SvREFCNT_dec(hv);
    SvREFCNT_dec(PL_curstname);
    PL_curstname = Nullsv;

    /* clear queued errors */
    SvREFCNT_dec(PL_errors);
    PL_errors = Nullsv;

    FREETMPS;
    if (destruct_level >= 2 && ckWARN_d(WARN_INTERNAL)) {
	if (PL_scopestack_ix != 0)
	    Perl_warner(aTHX_ WARN_INTERNAL,
	         "Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
		 (long)PL_scopestack_ix);
	if (PL_savestack_ix != 0)
	    Perl_warner(aTHX_ WARN_INTERNAL,
		 "Unbalanced saves: %ld more saves than restores\n",
		 (long)PL_savestack_ix);
	if (PL_tmps_floor != -1)
	    Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced tmps: %ld more allocs than frees\n",
		 (long)PL_tmps_floor + 1);
	if (cxstack_ix != -1)
	    Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced context: %ld more PUSHes than POPs\n",
		 (long)cxstack_ix + 1);
    }

    /* Now absolutely destruct everything, somehow or other, loops or no. */
    SvFLAGS(PL_fdpid) |= SVTYPEMASK;		/* don't clean out pid table now */
    SvFLAGS(PL_strtab) |= SVTYPEMASK;		/* don't clean out strtab now */

    /* the 2 is for PL_fdpid and PL_strtab */
    while (PL_sv_count > 2 && sv_clean_all())
	;

    SvFLAGS(PL_fdpid) &= ~SVTYPEMASK;
    SvFLAGS(PL_fdpid) |= SVt_PVAV;
    SvFLAGS(PL_strtab) &= ~SVTYPEMASK;
    SvFLAGS(PL_strtab) |= SVt_PVHV;

    AvREAL_off(PL_fdpid);		/* no surviving entries */
    SvREFCNT_dec(PL_fdpid);		/* needed in io_close() */
    PL_fdpid = Nullav;

#ifdef HAVE_INTERP_INTERN
    sys_intern_clear();
#endif

    /* Destruct the global string table. */
    {
	/* Yell and reset the HeVAL() slots that are still holding refcounts,
	 * so that sv_free() won't fail on them.
	 */
	I32 riter;
	I32 max;
	HE *hent;
	HE **array;

	riter = 0;
	max = HvMAX(PL_strtab);
	array = HvARRAY(PL_strtab);
	hent = array[0];
	for (;;) {
	    if (hent && ckWARN_d(WARN_INTERNAL)) {
		Perl_warner(aTHX_ WARN_INTERNAL,
		     "Unbalanced string table refcount: (%d) for \"%s\"",
		     HeVAL(hent) - Nullsv, HeKEY(hent));
		HeVAL(hent) = Nullsv;
		hent = HeNEXT(hent);
	    }
	    if (!hent) {
		if (++riter > max)
		    break;
		hent = array[riter];
	    }
	}
    }
    SvREFCNT_dec(PL_strtab);

#ifdef USE_ITHREADS
    /* free the pointer table used for cloning */
    ptr_table_free(PL_ptr_table);
#endif

    /* free special SVs */

    SvREFCNT(&PL_sv_yes) = 0;
    sv_clear(&PL_sv_yes);
    SvANY(&PL_sv_yes) = NULL;
    SvFLAGS(&PL_sv_yes) = 0;

    SvREFCNT(&PL_sv_no) = 0;
    sv_clear(&PL_sv_no);
    SvANY(&PL_sv_no) = NULL;
    SvFLAGS(&PL_sv_no) = 0;

    SvREFCNT(&PL_sv_undef) = 0;
    SvREADONLY_off(&PL_sv_undef);

    if (PL_sv_count != 0 && ckWARN_d(WARN_INTERNAL))
	Perl_warner(aTHX_ WARN_INTERNAL,"Scalars leaked: %ld\n", (long)PL_sv_count);

#if defined(PERLIO_LAYERS)
    /* No more IO - including error messages ! */
    PerlIO_cleanup(aTHX);
#endif

    Safefree(PL_origfilename);
    Safefree(PL_reg_start_tmp);
    if (PL_reg_curpm)
	Safefree(PL_reg_curpm);
    Safefree(PL_reg_poscache);
    Safefree(HeKEY_hek(&PL_hv_fetch_ent_mh));
    Safefree(PL_op_mask);
    Safefree(PL_psig_ptr);
    Safefree(PL_psig_name);
    Safefree(PL_bitcount);
    Safefree(PL_psig_pend);
    nuke_stacks();
    PL_hints = 0;		/* Reset hints. Should hints be per-interpreter ? */

    DEBUG_P(debprofdump());
#ifdef USE_5005THREADS
    MUTEX_DESTROY(&PL_strtab_mutex);
    MUTEX_DESTROY(&PL_sv_mutex);
    MUTEX_DESTROY(&PL_eval_mutex);
    MUTEX_DESTROY(&PL_cred_mutex);
    MUTEX_DESTROY(&PL_fdpid_mutex);
    COND_DESTROY(&PL_eval_cond);
#ifdef EMULATE_ATOMIC_REFCOUNTS
    MUTEX_DESTROY(&PL_svref_mutex);
#endif /* EMULATE_ATOMIC_REFCOUNTS */

    /* As the penultimate thing, free the non-arena SV for thrsv */
    Safefree(SvPVX(PL_thrsv));
    Safefree(SvANY(PL_thrsv));
    Safefree(PL_thrsv);
    PL_thrsv = Nullsv;
#endif /* USE_5005THREADS */

#ifdef USE_REENTRANT_API
    Safefree(PL_reentrant_buffer->tmbuff);
    Safefree(PL_reentrant_buffer);
#endif

    sv_free_arenas();

    /* As the absolutely last thing, free the non-arena SV for mess() */

    if (PL_mess_sv) {
	/* it could have accumulated taint magic */
	if (SvTYPE(PL_mess_sv) >= SVt_PVMG) {
	    MAGIC* mg;
	    MAGIC* moremagic;
	    for (mg = SvMAGIC(PL_mess_sv); mg; mg = moremagic) {
		moremagic = mg->mg_moremagic;
		if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global
						&& mg->mg_len >= 0)
		    Safefree(mg->mg_ptr);
		Safefree(mg);
	    }
	}
	/* we know that type >= SVt_PV */
	(void)SvOOK_off(PL_mess_sv);
	Safefree(SvPVX(PL_mess_sv));
	Safefree(SvANY(PL_mess_sv));
	Safefree(PL_mess_sv);
	PL_mess_sv = Nullsv;
    }
    return STATUS_NATIVE_EXPORT;
}

/*
=for apidoc perl_free

Releases a Perl interpreter.  See L<perlembed>.

=cut
*/

void
perl_free(pTHXx)
{
#if defined(WIN32) || defined(NETWARE)
#  if defined(PERL_IMPLICIT_SYS)
#    ifdef NETWARE
    void *host = nw_internal_host;
#    else
    void *host = w32_internal_host;
#    endif
    PerlMem_free(aTHXx);
#    ifdef NETWARE
    nw5_delete_internal_host(host);
#    else
    win32_delete_internal_host(host);
#    endif
#  else
    PerlMem_free(aTHXx);
#  endif
#else
    PerlMem_free(aTHXx);
#endif
}

void
Perl_call_atexit(pTHX_ ATEXIT_t fn, void *ptr)
{
    Renew(PL_exitlist, PL_exitlistlen+1, PerlExitListEntry);
    PL_exitlist[PL_exitlistlen].fn = fn;
    PL_exitlist[PL_exitlistlen].ptr = ptr;
    ++PL_exitlistlen;
}

/*
=for apidoc perl_parse

Tells a Perl interpreter to parse a Perl script.  See L<perlembed>.

=cut
*/

int
perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env)
{
    I32 oldscope;
    int ret;
    dJMPENV;
#ifdef USE_5005THREADS
    dTHX;
#endif

#ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
#ifdef IAMSUID
#undef IAMSUID
    Perl_croak(aTHX_ "suidperl is no longer needed since the kernel can now execute\n\
setuid perl scripts securely.\n");
#endif
#endif

    PL_origargc = argc;
    {
        /* we copy rather than point to argv
         * since perl_clone will copy and perl_destruct
         * has no way of knowing if we've made a copy or
         * just point to argv
         */
        int i = PL_origargc;
        New(0, PL_origargv, i+1, char*);
        PL_origargv[i] = '\0';
        while (i-- > 0) {
            PL_origargv[i] = savepv(argv[i]);
        }
    }



    if (PL_do_undump) {

	/* Come here if running an undumped a.out. */

	PL_origfilename = savepv(argv[0]);
	PL_do_undump = FALSE;
	cxstack_ix = -1;		/* start label stack again */
	init_ids();
	init_postdump_symbols(argc,argv,env);
	return 0;
    }

    if (PL_main_root) {
	PL_curpad = AvARRAY(PL_comppad);
	op_free(PL_main_root);
	PL_main_root = Nullop;
    }
    PL_main_start = Nullop;
    SvREFCNT_dec(PL_main_cv);
    PL_main_cv = Nullcv;

    time(&PL_basetime);
    oldscope = PL_scopestack_ix;
    PL_dowarn = G_WARN_OFF;

#ifdef PERL_FLEXIBLE_EXCEPTIONS
    CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vparse_body), env, xsinit);
#else
    JMPENV_PUSH(ret);
#endif
    switch (ret) {
    case 0:
#ifndef PERL_FLEXIBLE_EXCEPTIONS
	parse_body(env,xsinit);
#endif
	if (PL_checkav)
	    call_list(oldscope, PL_checkav);
	ret = 0;
	break;
    case 1:
	STATUS_ALL_FAILURE;
	/* FALL THROUGH */
    case 2:
	/* my_exit() was called */
	while (PL_scopestack_ix > oldscope)
	    LEAVE;
	FREETMPS;
	PL_curstash = PL_defstash;
	if (PL_checkav)
	    call_list(oldscope, PL_checkav);
	ret = STATUS_NATIVE_EXPORT;
	break;
    case 3:
	PerlIO_printf(Perl_error_log, "panic: top_env\n");
	ret = 1;
	break;
    }
    JMPENV_POP;
    return ret;
}

#ifdef PERL_FLEXIBLE_EXCEPTIONS
STATIC void *
S_vparse_body(pTHX_ va_list args)
{
    char **env = va_arg(args, char**);
    XSINIT_t xsinit = va_arg(args, XSINIT_t);

    return parse_body(env, xsinit);
}
#endif

STATIC void *
S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
{
    int argc = PL_origargc;
    char **argv = PL_origargv;
    char *scriptname = NULL;
    int fdscript = -1;
    VOL bool dosearch = FALSE;
    char *validarg = "";
    AV* comppadlist;
    register SV *sv;
    register char *s;
    char *cddir = Nullch;

    sv_setpvn(PL_linestr,"",0);
    sv = newSVpvn("",0);		/* first used for -I flags */
    SAVEFREESV(sv);
    init_main_stash();

    for (argc--,argv++; argc > 0; argc--,argv++) {
	if (argv[0][0] != '-' || !argv[0][1])
	    break;
#ifdef DOSUID
    if (*validarg)
	validarg = " PHOOEY ";
    else
	validarg = argv[0];
#endif
	s = argv[0]+1;
      reswitch:
	switch (*s) {
	case 'C':
#ifdef	WIN32
	    win32_argv2utf8(argc-1, argv+1);
	    /* FALL THROUGH */
#endif
#ifndef PERL_STRICT_CR
	case '\r':
#endif
	case ' ':
	case '0':
	case 'F':
	case 'a':
	case 'c':
	case 'd':
	case 'D':
	case 'h':
	case 'i':
	case 'l':
	case 'M':
	case 'm':
	case 'n':
	case 'p':
	case 's':
	case 'u':
	case 'U':
	case 'v':
	case 'W':
	case 'X':
	case 'w':
	    if ((s = moreswitches(s)))
		goto reswitch;
	    break;

	case 'T':
	    PL_tainting = TRUE;
	    s++;
	    goto reswitch;

	case 'e':
#ifdef MACOS_TRADITIONAL
	    /* ignore -e for Dev:Pseudo argument */
	    if (argv[1] && !strcmp(argv[1], "Dev:Pseudo"))
	    	break;
#endif
	    if (PL_euid != PL_uid || PL_egid != PL_gid)
		Perl_croak(aTHX_ "No -e allowed in setuid scripts");
	    if (!PL_e_script) {
		PL_e_script = newSVpvn("",0);
		filter_add(read_e_script, NULL);
	    }
	    if (*++s)
		sv_catpv(PL_e_script, s);
	    else if (argv[1]) {
		sv_catpv(PL_e_script, argv[1]);
		argc--,argv++;
	    }
	    else
		Perl_croak(aTHX_ "No code specified for -e");
	    sv_catpv(PL_e_script, "\n");
	    break;

	case 'I':	/* -I handled both here and in moreswitches() */
	    forbid_setid("-I");
	    if (!*++s && (s=argv[1]) != Nullch) {
		argc--,argv++;
	    }
	    if (s && *s) {
		char *p;
		STRLEN len = strlen(s);
		p = savepvn(s, len);
		incpush(p, TRUE, TRUE);
		sv_catpvn(sv, "-I", 2);
		sv_catpvn(sv, p, len);
		sv_catpvn(sv, " ", 1);
		Safefree(p);
	    }
	    else
		Perl_croak(aTHX_ "No directory specified for -I");
	    break;
	case 'P':
	    forbid_setid("-P");
	    PL_preprocess = TRUE;
	    s++;
	    goto reswitch;
	case 'S':
	    forbid_setid("-S");
	    dosearch = TRUE;
	    s++;
	    goto reswitch;
	case 'V':
	    if (!PL_preambleav)
		PL_preambleav = newAV();
	    av_push(PL_preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
	    if (*++s != ':')  {
		PL_Sv = newSVpv("print myconfig();",0);
#ifdef VMS
		sv_catpv(PL_Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
#else
		sv_catpv(PL_Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
#endif
		sv_catpv(PL_Sv,"\"  Compile-time options:");
#  ifdef DEBUGGING
		sv_catpv(PL_Sv," DEBUGGING");
#  endif
#  ifdef MULTIPLICITY
		sv_catpv(PL_Sv," MULTIPLICITY");
#  endif
#  ifdef USE_5005THREADS
		sv_catpv(PL_Sv," USE_5005THREADS");
#  endif
#  ifdef USE_ITHREADS
		sv_catpv(PL_Sv," USE_ITHREADS");
#  endif
#  ifdef USE_64_BIT_INT
		sv_catpv(PL_Sv," USE_64_BIT_INT");
#  endif
#  ifdef USE_64_BIT_ALL
		sv_catpv(PL_Sv," USE_64_BIT_ALL");
#  endif
#  ifdef USE_LONG_DOUBLE
		sv_catpv(PL_Sv," USE_LONG_DOUBLE");
#  endif
#  ifdef USE_LARGE_FILES
		sv_catpv(PL_Sv," USE_LARGE_FILES");
#  endif
#  ifdef USE_SOCKS
		sv_catpv(PL_Sv," USE_SOCKS");
#  endif
#  ifdef PERL_IMPLICIT_CONTEXT
		sv_catpv(PL_Sv," PERL_IMPLICIT_CONTEXT");
#  endif
#  ifdef PERL_IMPLICIT_SYS
		sv_catpv(PL_Sv," PERL_IMPLICIT_SYS");
#  endif
		sv_catpv(PL_Sv,"\\n\",");

#if defined(LOCAL_PATCH_COUNT)
		if (LOCAL_PATCH_COUNT > 0) {
		    int i;
		    sv_catpv(PL_Sv,"\"  Locally applied patches:\\n\",");
		    for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
			if (PL_localpatches[i])
			    Perl_sv_catpvf(aTHX_ PL_Sv,"q\"  \t%s\n\",",PL_localpatches[i]);
		    }
		}
#endif
		Perl_sv_catpvf(aTHX_ PL_Sv,"\"  Built under %s\\n\"",OSNAME);
#ifdef __DATE__
#  ifdef __TIME__
		Perl_sv_catpvf(aTHX_ PL_Sv,",\"  Compiled at %s %s\\n\"",__DATE__,__TIME__);
#  else
		Perl_sv_catpvf(aTHX_ PL_Sv,",\"  Compiled on %s\\n\"",__DATE__);
#  endif
#endif
		sv_catpv(PL_Sv, "; \
$\"=\"\\n    \"; \
@env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; ");
#ifdef __CYGWIN__
		sv_catpv(PL_Sv,"\
push @env, \"CYGWIN=\\\"$ENV{CYGWIN}\\\"\";");
#endif
		sv_catpv(PL_Sv, "\
print \"  \\%ENV:\\n    @env\\n\" if @env; \
print \"  \\@INC:\\n    @INC\\n\";");
	    }
	    else {
		PL_Sv = newSVpv("config_vars(qw(",0);
		sv_catpv(PL_Sv, ++s);
		sv_catpv(PL_Sv, "))");
		s += strlen(s);
	    }
	    av_push(PL_preambleav, PL_Sv);
	    scriptname = BIT_BUCKET;	/* don't look for script or read stdin */
	    goto reswitch;
	case 'x':
	    PL_doextract = TRUE;
	    s++;
	    if (*s)
		cddir = s;
	    break;
	case 0:
	    break;
	case '-':
	    if (!*++s || isSPACE(*s)) {
		argc--,argv++;
		goto switch_end;
	    }
	    /* catch use of gnu style long options */
	    if (strEQ(s, "version")) {
		s = "v";
		goto reswitch;
	    }
	    if (strEQ(s, "help")) {
		s = "h";
		goto reswitch;
	    }
	    s--;
	    /* FALL THROUGH */
	default:
	    Perl_croak(aTHX_ "Unrecognized switch: -%s  (-h will show valid options)",s);
	}
    }
  switch_end:

    if (
#ifndef SECURE_INTERNAL_GETENV
        !PL_tainting &&
#endif
	(s = PerlEnv_getenv("PERL5OPT")))
    {
    	char *popt = s;
	while (isSPACE(*s))
	    s++;
	if (*s == '-' && *(s+1) == 'T')
	    PL_tainting = TRUE;
	else {
	    char *popt_copy = Nullch;
	    while (s && *s) {
	        char *d;
		while (isSPACE(*s))
		    s++;
		if (*s == '-') {
		    s++;
		    if (isSPACE(*s))
			continue;
		}
		d = s;
		if (!*s)
		    break;
		if (!strchr("DIMUdmw", *s))
		    Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s);
		while (++s && *s) {
		    if (isSPACE(*s)) {
			if (!popt_copy) {
			    popt_copy = SvPVX(sv_2mortal(newSVpv(popt,0)));
			    s = popt_copy + (s - popt);
			    d = popt_copy + (d - popt);
			}
		        *s++ = '\0';
			break;
		    }
		}
		moreswitches(d);
	    }
	}
    }

    if (!scriptname)
	scriptname = argv[0];
    if (PL_e_script) {
	argc++,argv--;
	scriptname = BIT_BUCKET;	/* don't look for script or read stdin */
    }
    else if (scriptname == Nullch) {
#ifdef MSDOS
	if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) )
	    moreswitches("h");
#endif
	scriptname = "-";
    }

    init_perllib();

    open_script(scriptname,dosearch,sv,&fdscript);

    validate_suid(validarg, scriptname,fdscript);

#ifndef PERL_MICRO
#if defined(SIGCHLD) || defined(SIGCLD)
    {
#ifndef SIGCHLD
#  define SIGCHLD SIGCLD
#endif
	Sighandler_t sigstate = rsignal_state(SIGCHLD);
	if (sigstate == SIG_IGN) {
	    if (ckWARN(WARN_SIGNAL))
		Perl_warner(aTHX_ WARN_SIGNAL,
			    "Can't ignore signal CHLD, forcing to default");
	    (void)rsignal(SIGCHLD, (Sighandler_t)SIG_DFL);
	}
    }
#endif
#endif

#ifdef MACOS_TRADITIONAL
    if (PL_doextract || gMacPerl_AlwaysExtract) {
#else
    if (PL_doextract) {
#endif
	find_beginning();
	if (cddir && PerlDir_chdir(cddir) < 0)
	    Perl_croak(aTHX_ "Can't chdir to %s",cddir);

    }

    PL_main_cv = PL_compcv = (CV*)NEWSV(1104,0);
    sv_upgrade((SV *)PL_compcv, SVt_PVCV);
    CvUNIQUE_on(PL_compcv);

    PL_comppad = newAV();
    av_push(PL_comppad, Nullsv);
    PL_curpad = AvARRAY(PL_comppad);
    PL_comppad_name = newAV();
    PL_comppad_name_fill = 0;
    PL_min_intro_pending = 0;
    PL_padix = 0;
#ifdef USE_5005THREADS
    av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
    PL_curpad[0] = (SV*)newAV();
    SvPADMY_on(PL_curpad[0]);	/* XXX Needed? */
    CvOWNER(PL_compcv) = 0;
    New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
    MUTEX_INIT(CvMUTEXP(PL_compcv));
#endif /* USE_5005THREADS */

    comppadlist = newAV();
    AvREAL_off(comppadlist);
    av_store(comppadlist, 0, (SV*)PL_comppad_name);
    av_store(comppadlist, 1, (SV*)PL_comppad);
    CvPADLIST(PL_compcv) = comppadlist;

    boot_core_PerlIO();
    boot_core_UNIVERSAL();
#ifndef PERL_MICRO
    boot_core_xsutils();
#endif

    if (xsinit)
	(*xsinit)(aTHX);	/* in case linked C routines want magical variables */
#ifndef PERL_MICRO
#if defined(VMS) || defined(WIN32) || defined(DJGPP) || defined(__CYGWIN__) || defined(EPOC)
    init_os_extras();
#endif
#endif

#ifdef USE_SOCKS
#   ifdef HAS_SOCKS5_INIT
    socks5_init(argv[0]);
#   else
    SOCKSinit(argv[0]);
#   endif
#endif

    init_predump_symbols();
    /* init_postdump_symbols not currently designed to be called */
    /* more than once (ENV isn't cleared first, for example)	 */
    /* But running with -u leaves %ENV & @ARGV undefined!    XXX */
    if (!PL_do_undump)
	init_postdump_symbols(argc,argv,env);

    init_lexer();

    /* now parse the script */

    SETERRNO(0,SS$_NORMAL);
    PL_error_count = 0;
#ifdef MACOS_TRADITIONAL
    if (gMacPerl_SyntaxError = (yyparse() || PL_error_count)) {
	if (PL_minus_c)
	    Perl_croak(aTHX_ "%s had compilation errors.\n", MacPerl_MPWFileName(PL_origfilename));
	else {
	    Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
		       MacPerl_MPWFileName(PL_origfilename));
	}
    }
#else
    if (yyparse() || PL_error_count) {
	if (PL_minus_c)
	    Perl_croak(aTHX_ "%s had compilation errors.\n", PL_origfilename);
	else {
	    Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
		       PL_origfilename);
	}
    }
#endif
    CopLINE_set(PL_curcop, 0);
    PL_curstash = PL_defstash;
    PL_preprocess = FALSE;
    if (PL_e_script) {
	SvREFCNT_dec(PL_e_script);
	PL_e_script = Nullsv;
    }

/*
   Not sure that this is still the right place to do this now that we
   no longer use PL_nrs. HVDS 2001/09/09
*/
    sv_setsv(get_sv("/", TRUE), PL_rs);

    if (PL_do_undump)
	my_unexec();

    if (isWARN_ONCE) {
	SAVECOPFILE(PL_curcop);
	SAVECOPLINE(PL_curcop);
	gv_check(PL_defstash);
    }

    LEAVE;
    FREETMPS;

#ifdef MYMALLOC
    if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
	dump_mstats("after compilation:");
#endif

    ENTER;
    PL_restartop = 0;
    return NULL;
}

/*
=for apidoc perl_run

Tells a Perl interpreter to run.  See L<perlembed>.

=cut
*/

int
perl_run(pTHXx)
{
    I32 oldscope;
    int ret = 0;
    dJMPENV;
#ifdef USE_5005THREADS
    dTHX;
#endif

    oldscope = PL_scopestack_ix;
#ifdef VMS
    VMSISH_HUSHED = 0;
#endif

#ifdef PERL_FLEXIBLE_EXCEPTIONS
 redo_body:
    CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vrun_body), oldscope);
#else
    JMPENV_PUSH(ret);
#endif
    switch (ret) {
    case 1:
	cxstack_ix = -1;		/* start context stack again */
	goto redo_body;
    case 0:				/* normal completion */
#ifndef PERL_FLEXIBLE_EXCEPTIONS
 redo_body:
	run_body(oldscope);
#endif
	/* FALL THROUGH */
    case 2:				/* my_exit() */
	while (PL_scopestack_ix > oldscope)
	    LEAVE;
	FREETMPS;
	PL_curstash = PL_defstash;
	if (!(PL_exit_flags & PERL_EXIT_DESTRUCT_END) &&
	    PL_endav && !PL_minus_c)
	    call_list(oldscope, PL_endav);
#ifdef MYMALLOC
	if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
	    dump_mstats("after execution:  ");
#endif
	ret = STATUS_NATIVE_EXPORT;
	break;
    case 3:
	if (PL_restartop) {
	    POPSTACK_TO(PL_mainstack);
	    goto redo_body;
	}
	PerlIO_printf(Perl_error_log, "panic: restartop\n");
	FREETMPS;
	ret = 1;
	break;
    }

    JMPENV_POP;
    return ret;
}

#ifdef PERL_FLEXIBLE_EXCEPTIONS
STATIC void *
S_vrun_body(pTHX_ va_list args)
{
    I32 oldscope = va_arg(args, I32);

    return run_body(oldscope);
}
#endif


STATIC void *
S_run_body(pTHX_ I32 oldscope)
{
    DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
                    PL_sawampersand ? "Enabling" : "Omitting"));

    if (!PL_restartop) {
	DEBUG_x(dump_all());
	DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
	DEBUG_S(PerlIO_printf(Perl_debug_log, "main thread is 0x%"UVxf"\n",
			      PTR2UV(thr)));

	if (PL_minus_c) {
#ifdef MACOS_TRADITIONAL
	    PerlIO_printf(Perl_error_log, "# %s syntax OK\n", MacPerl_MPWFileName(PL_origfilename));
#else
	    PerlIO_printf(Perl_error_log, "%s syntax OK\n", PL_origfilename);
#endif
	    my_exit(0);
	}
	if (PERLDB_SINGLE && PL_DBsingle)
	    sv_setiv(PL_DBsingle, 1);
	if (PL_initav)
	    call_list(oldscope, PL_initav);
    }

    /* do it */

    if (PL_restartop) {
	PL_op = PL_restartop;
	PL_restartop = 0;
	CALLRUNOPS(aTHX);
    }
    else if (PL_main_start) {
	CvDEPTH(PL_main_cv) = 1;
	PL_op = PL_main_start;
	CALLRUNOPS(aTHX);
    }

    my_exit(0);
    /* NOTREACHED */
    return NULL;
}

/*
=for apidoc p||get_sv

Returns the SV of the specified Perl scalar.  If C<create> is set and the
Perl variable does not exist then it will be created.  If C<create> is not
set and the variable does not exist then NULL is returned.

=cut
*/

SV*
Perl_get_sv(pTHX_ const char *name, I32 create)
{
    GV *gv;
#ifdef USE_5005THREADS
    if (name[1] == '\0' && !isALPHA(name[0])) {
	PADOFFSET tmp = find_threadsv(name);
    	if (tmp != NOT_IN_PAD)
	    return THREADSV(tmp);
    }
#endif /* USE_5005THREADS */
    gv = gv_fetchpv(name, create, SVt_PV);
    if (gv)
	return GvSV(gv);
    return Nullsv;
}

/*
=for apidoc p||get_av

Returns the AV of the specified Perl array.  If C<create> is set and the
Perl variable does not exist then it will be created.  If C<create> is not
set and the variable does not exist then NULL is returned.

=cut
*/

AV*
Perl_get_av(pTHX_ const char *name, I32 create)
{
    GV* gv = gv_fetchpv(name, create, SVt_PVAV);
    if (create)
    	return GvAVn(gv);
    if (gv)
	return GvAV(gv);
    return Nullav;
}

/*
=for apidoc p||get_hv

Returns the HV of the specified Perl hash.  If C<create> is set and the
Perl variable does not exist then it will be created.  If C<create> is not
set and the variable does not exist then NULL is returned.

=cut
*/

HV*
Perl_get_hv(pTHX_ const char *name, I32 create)
{
    GV* gv = gv_fetchpv(name, create, SVt_PVHV);
    if (create)
    	return GvHVn(gv);
    if (gv)
	return GvHV(gv);
    return Nullhv;
}

/*
=for apidoc p||get_cv

Returns the CV of the specified Perl subroutine.  If C<create> is set and
the Perl subroutine does not exist then it will be declared (which has the
same effect as saying C<sub name;>).  If C<create> is not set and the
subroutine does not exist then NULL is returned.

=cut
*/

CV*
Perl_get_cv(pTHX_ const char *name, I32 create)
{
    GV* gv = gv_fetchpv(name, create, SVt_PVCV);
    /* XXX unsafe for threads if eval_owner isn't held */
    /* XXX this is probably not what they think they're getting.
     * It has the same effect as "sub name;", i.e. just a forward
     * declaration! */
    if (create && !GvCVu(gv))
    	return newSUB(start_subparse(FALSE, 0),
		      newSVOP(OP_CONST, 0, newSVpv(name,0)),
		      Nullop,
		      Nullop);
    if (gv)
	return GvCVu(gv);
    return Nullcv;
}

/* Be sure to refetch the stack pointer after calling these routines. */

/*
=for apidoc p||call_argv

Performs a callback to the specified Perl sub.  See L<perlcall>.

=cut
*/

I32
Perl_call_argv(pTHX_ const char *sub_name, I32 flags, register char **argv)

          		/* See G_* flags in cop.h */
                     	/* null terminated arg list */
{
    dSP;

    PUSHMARK(SP);
    if (argv) {
	while (*argv) {
	    XPUSHs(sv_2mortal(newSVpv(*argv,0)));
	    argv++;
	}
	PUTBACK;
    }
    return call_pv(sub_name, flags);
}

/*
=for apidoc p||call_pv

Performs a callback to the specified Perl sub.  See L<perlcall>.

=cut
*/

I32
Perl_call_pv(pTHX_ const char *sub_name, I32 flags)
              		/* name of the subroutine */
          		/* See G_* flags in cop.h */
{
    return call_sv((SV*)get_cv(sub_name, TRUE), flags);
}

/*
=for apidoc p||call_method

Performs a callback to the specified Perl method.  The blessed object must
be on the stack.  See L<perlcall>.

=cut
*/

I32
Perl_call_method(pTHX_ const char *methname, I32 flags)
               		/* name of the subroutine */
          		/* See G_* flags in cop.h */
{
    return call_sv(sv_2mortal(newSVpv(methname,0)), flags | G_METHOD);
}

/* May be called with any of a CV, a GV, or an SV containing the name. */
/*
=for apidoc p||call_sv

Performs a callback to the Perl sub whose name is in the SV.  See
L<perlcall>.

=cut
*/

I32
Perl_call_sv(pTHX_ SV *sv, I32 flags)
          		/* See G_* flags in cop.h */
{
    dSP;
    LOGOP myop;		/* fake syntax tree node */
    UNOP method_op;
    I32 oldmark;
    volatile I32 retval = 0;
    I32 oldscope;
    bool oldcatch = CATCH_GET;
    int ret;
    OP* oldop = PL_op;
    dJMPENV;

    if (flags & G_DISCARD) {
	ENTER;
	SAVETMPS;
    }

    Zero(&myop, 1, LOGOP);
    myop.op_next = Nullop;
    if (!(flags & G_NOARGS))
	myop.op_flags |= OPf_STACKED;
    myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
		      (flags & G_ARRAY) ? OPf_WANT_LIST :
		      OPf_WANT_SCALAR);
    SAVEOP();
    PL_op = (OP*)&myop;

    EXTEND(PL_stack_sp, 1);
    *++PL_stack_sp = sv;
    oldmark = TOPMARK;
    oldscope = PL_scopestack_ix;

    if (PERLDB_SUB && PL_curstash != PL_debstash
	   /* Handle first BEGIN of -d. */
	  && (PL_DBcv || (PL_DBcv = GvCV(PL_DBsub)))
	   /* Try harder, since this may have been a sighandler, thus
	    * curstash may be meaningless. */
	  && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != PL_debstash)
	  && !(flags & G_NODEBUG))
	PL_op->op_private |= OPpENTERSUB_DB;

    if (flags & G_METHOD) {
	Zero(&method_op, 1, UNOP);
	method_op.op_next = PL_op;
	method_op.op_ppaddr = PL_ppaddr[OP_METHOD];
	myop.op_ppaddr = PL_ppaddr[OP_ENTERSUB];
	PL_op = (OP*)&method_op;
    }

    if (!(flags & G_EVAL)) {
	CATCH_SET(TRUE);
	call_body((OP*)&myop, FALSE);
	retval = PL_stack_sp - (PL_stack_base + oldmark);
	CATCH_SET(oldcatch);
    }
    else {
	myop.op_other = (OP*)&myop;
	PL_markstack_ptr--;
	/* we're trying to emulate pp_entertry() here */
	{
	    register PERL_CONTEXT *cx;
	    I32 gimme = GIMME_V;
	
	    ENTER;
	    SAVETMPS;
	
	    push_return(Nullop);
	    PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
	    PUSHEVAL(cx, 0, 0);
	    PL_eval_root = PL_op;             /* Only needed so that goto works right. */
	
	    PL_in_eval = EVAL_INEVAL;
	    if (flags & G_KEEPERR)
		PL_in_eval |= EVAL_KEEPERR;
	    else
		sv_setpv(ERRSV,"");
	}
	PL_markstack_ptr++;

#ifdef PERL_FLEXIBLE_EXCEPTIONS
 redo_body:
	CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_body),
		    (OP*)&myop, FALSE);
#else
	JMPENV_PUSH(ret);
#endif
	switch (ret) {
	case 0:
#ifndef PERL_FLEXIBLE_EXCEPTIONS
 redo_body:
	    call_body((OP*)&myop, FALSE);
#endif
	    retval = PL_stack_sp - (PL_stack_base + oldmark);
	    if (!(flags & G_KEEPERR))
		sv_setpv(ERRSV,"");
	    break;
	case 1:
	    STATUS_ALL_FAILURE;
	    /* FALL THROUGH */
	case 2:
	    /* my_exit() was called */
	    PL_curstash = PL_defstash;
	    FREETMPS;
	    JMPENV_POP;
	    if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
		Perl_croak(aTHX_ "Callback called exit");
	    my_exit_jump();
	    /* NOTREACHED */
	case 3:
	    if (PL_restartop) {
		PL_op = PL_restartop;
		PL_restartop = 0;
		goto redo_body;
	    }
	    PL_stack_sp = PL_stack_base + oldmark;
	    if (flags & G_ARRAY)
		retval = 0;
	    else {
		retval = 1;
		*++PL_stack_sp = &PL_sv_undef;
	    }
	    break;
	}

	if (PL_scopestack_ix > oldscope) {
	    SV **newsp;
	    PMOP *newpm;
	    I32 gimme;
	    register PERL_CONTEXT *cx;
	    I32 optype;

	    POPBLOCK(cx,newpm);
	    POPEVAL(cx);
	    pop_return();
	    PL_curpm = newpm;
	    LEAVE;
	}
	JMPENV_POP;
    }

    if (flags & G_DISCARD) {
	PL_stack_sp = PL_stack_base + oldmark;
	retval = 0;
	FREETMPS;
	LEAVE;
    }
    PL_op = oldop;
    return retval;
}

#ifdef PERL_FLEXIBLE_EXCEPTIONS
STATIC void *
S_vcall_body(pTHX_ va_list args)
{
    OP *myop = va_arg(args, OP*);
    int is_eval = va_arg(args, int);

    call_body(myop, is_eval);
    return NULL;
}
#endif

STATIC void
S_call_body(pTHX_ OP *myop, int is_eval)
{
    if (PL_op == myop) {
	if (is_eval)
	    PL_op = Perl_pp_entereval(aTHX);	/* this doesn't do a POPMARK */
	else
	    PL_op = Perl_pp_entersub(aTHX);	/* this does */
    }
    if (PL_op)
	CALLRUNOPS(aTHX);
}

/* Eval a string. The G_EVAL flag is always assumed. */

/*
=for apidoc p||eval_sv

Tells Perl to C<eval> the string in the SV.

=cut
*/

I32
Perl_eval_sv(pTHX_ SV *sv, I32 flags)

          		/* See G_* flags in cop.h */
{
    dSP;
    UNOP myop;		/* fake syntax tree node */
    volatile I32 oldmark = SP - PL_stack_base;
    volatile I32 retval = 0;
    I32 oldscope;
    int ret;
    OP* oldop = PL_op;
    dJMPENV;

    if (flags & G_DISCARD) {
	ENTER;
	SAVETMPS;
    }

    SAVEOP();
    PL_op = (OP*)&myop;
    Zero(PL_op, 1, UNOP);
    EXTEND(PL_stack_sp, 1);
    *++PL_stack_sp = sv;
    oldscope = PL_scopestack_ix;

    if (!(flags & G_NOARGS))
	myop.op_flags = OPf_STACKED;
    myop.op_next = Nullop;
    myop.op_type = OP_ENTEREVAL;
    myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
		      (flags & G_ARRAY) ? OPf_WANT_LIST :
		      OPf_WANT_SCALAR);
    if (flags & G_KEEPERR)
	myop.op_flags |= OPf_SPECIAL;

#ifdef PERL_FLEXIBLE_EXCEPTIONS
 redo_body:
    CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_body),
		(OP*)&myop, TRUE);
#else
    JMPENV_PUSH(ret);
#endif
    switch (ret) {
    case 0:
#ifndef PERL_FLEXIBLE_EXCEPTIONS
 redo_body:
	call_body((OP*)&myop,TRUE);
#endif
	retval = PL_stack_sp - (PL_stack_base + oldmark);
	if (!(flags & G_KEEPERR))
	    sv_setpv(ERRSV,"");
	break;
    case 1:
	STATUS_ALL_FAILURE;
	/* FALL THROUGH */
    case 2:
	/* my_exit() was called */
	PL_curstash = PL_defstash;
	FREETMPS;
	JMPENV_POP;
	if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
	    Perl_croak(aTHX_ "Callback called exit");
	my_exit_jump();
	/* NOTREACHED */
    case 3:
	if (PL_restartop) {
	    PL_op = PL_restartop;
	    PL_restartop = 0;
	    goto redo_body;
	}
	PL_stack_sp = PL_stack_base + oldmark;
	if (flags & G_ARRAY)
	    retval = 0;
	else {
	    retval = 1;
	    *++PL_stack_sp = &PL_sv_undef;
	}
	break;
    }

    JMPENV_POP;
    if (flags & G_DISCARD) {
	PL_stack_sp = PL_stack_base + oldmark;
	retval = 0;
	FREETMPS;
	LEAVE;
    }
    PL_op = oldop;
    return retval;
}

/*
=for apidoc p||eval_pv

Tells Perl to C<eval> the given string and return an SV* result.

=cut
*/

SV*
Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error)
{
    dSP;
    SV* sv = newSVpv(p, 0);

    eval_sv(sv, G_SCALAR);
    SvREFCNT_dec(sv);

    SPAGAIN;
    sv = POPs;
    PUTBACK;

    if (croak_on_error && SvTRUE(ERRSV)) {
	STRLEN n_a;
	Perl_croak(aTHX_ SvPVx(ERRSV, n_a));
    }

    return sv;
}

/* Require a module. */

/*
=for apidoc p||require_pv

Tells Perl to C<require> the file named by the string argument.  It is
analogous to the Perl code C<eval "require '$file'">.  It's even
implemented that way; consider using Perl_load_module instead.

=cut */

void
Perl_require_pv(pTHX_ const char *pv)
{
    SV* sv;
    dSP;
    PUSHSTACKi(PERLSI_REQUIRE);
    PUTBACK;
    sv = sv_newmortal();
    sv_setpv(sv, "require '");
    sv_catpv(sv, pv);
    sv_catpv(sv, "'");
    eval_sv(sv, G_DISCARD);
    SPAGAIN;
    POPSTACK;
}

void
Perl_magicname(pTHX_ char *sym, char *name, I32 namlen)
{
    register GV *gv;

    if ((gv = gv_fetchpv(sym,TRUE, SVt_PV)))
	sv_magic(GvSV(gv), (SV*)gv, PERL_MAGIC_sv, name, namlen);
}

STATIC void
S_usage(pTHX_ char *name)		/* XXX move this out into a module ? */
{
    /* This message really ought to be max 23 lines.
     * Removed -h because the user already knows that option. Others? */

    static char *usage_msg[] = {
"-0[octal]       specify record separator (\\0, if no argument)",
"-a              autosplit mode with -n or -p (splits $_ into @F)",
"-C              enable native wide character system interfaces",
"-c              check syntax only (runs BEGIN and CHECK blocks)",
"-d[:debugger]   run program under debugger",
"-D[number/list] set debugging flags (argument is a bit mask or alphabets)",
"-e 'command'    one line of program (several -e's allowed, omit programfile)",
"-F/pattern/     split() pattern for -a switch (//'s are optional)",
"-i[extension]   edit <> files in place (makes backup if extension supplied)",
"-Idirectory     specify @INC/#include directory (several -I's allowed)",
"-l[octal]       enable line ending processing, specifies line terminator",
"-[mM][-]module  execute `use/no module...' before executing program",
"-n              assume 'while (<>) { ... }' loop around program",
"-p              assume loop like -n but print line also, like sed",
"-P              run program through C preprocessor before compilation",
"-s              enable rudimentary parsing for switches after programfile",
"-S              look for programfile using PATH environment variable",
"-T              enable tainting checks",
"-u              dump core after parsing program",
"-U              allow unsafe operations",
"-v              print version, subversion (includes VERY IMPORTANT perl info)",
"-V[:variable]   print configuration summary (or a single Config.pm variable)",
"-w              enable many useful warnings (RECOMMENDED)",
"-W              enable all warnings",
"-X              disable all warnings",
"-x[directory]   strip off text before #!perl line and perhaps cd to directory",
"\n",
NULL
};
    char **p = usage_msg;

    PerlIO_printf(PerlIO_stdout(),
		  "\nUsage: %s [switches] [--] [programfile] [arguments]",
		  name);
    while (*p)
	PerlIO_printf(PerlIO_stdout(), "\n  %s", *p++);
}

/* This routine handles any switches that can be given during run */

char *
Perl_moreswitches(pTHX_ char *s)
{
    STRLEN numlen;
    U32 rschar;

    switch (*s) {
    case '0':
    {
        I32 flags = 0;
	numlen = 4;
	rschar = (U32)grok_oct(s, &numlen, &flags, NULL);
	SvREFCNT_dec(PL_rs);
	if (rschar & ~((U8)~0))
	    PL_rs = &PL_sv_undef;
	else if (!rschar && numlen >= 2)
	    PL_rs = newSVpvn("", 0);
	else {
	    char ch = rschar;
	    PL_rs = newSVpvn(&ch, 1);
	}
	return s + numlen;
    }
    case 'C':
	PL_widesyscalls = TRUE;
	s++;
	return s;
    case 'F':
	PL_minus_F = TRUE;
	PL_splitstr = savepv(s + 1);
	s += strlen(s);
	return s;
    case 'a':
	PL_minus_a = TRUE;
	s++;
	return s;
    case 'c':
	PL_minus_c = TRUE;
	s++;
	return s;
    case 'd':
	forbid_setid("-d");
	s++;
	/* The following permits -d:Mod to accepts arguments following an =
	   in the fashion that -MSome::Mod does. */
	if (*s == ':' || *s == '=') {
	    char *start;
	    SV *sv;
	    sv = newSVpv("use Devel::", 0);
	    start = ++s;
	    /* We now allow -d:Module=Foo,Bar */
	    while(isALNUM(*s) || *s==':') ++s;
	    if (*s != '=')
		sv_catpv(sv, start);
	    else {
		sv_catpvn(sv, start, s-start);
		sv_catpv(sv, " split(/,/,q{");
		sv_catpv(sv, ++s);
		sv_catpv(sv,    "})");
	    }
	    s += strlen(s);
	    my_setenv("PERL5DB", SvPV(sv, PL_na));
	}
	if (!PL_perldb) {
	    PL_perldb = PERLDB_ALL;
	    init_debugger();
	}
	return s;
    case 'D':
    {	
#ifdef DEBUGGING
	forbid_setid("-D");
	if (isALPHA(s[1])) {
	    /* if adding extra options, remember to update DEBUG_MASK */
	    static char debopts[] = "psltocPmfrxuLHXDSTR";
	    char *d;

	    for (s++; *s && (d = strchr(debopts,*s)); s++)
		PL_debug |= 1 << (d - debopts);
	}
	else {
	    PL_debug = atoi(s+1);
	    for (s++; isDIGIT(*s); s++) ;
	}
	PL_debug |= DEBUG_TOP_FLAG;
#else
	if (ckWARN_d(WARN_DEBUGGING))
	    Perl_warner(aTHX_ WARN_DEBUGGING,
	           "Recompile perl with -DDEBUGGING to use -D switch\n");
	for (s++; isALNUM(*s); s++) ;
#endif
	/*SUPPRESS 530*/
	return s;
    }	
    case 'h':
	usage(PL_origargv[0]);
	PerlProc_exit(0);
    case 'i':
	if (PL_inplace)
	    Safefree(PL_inplace);
	PL_inplace = savepv(s+1);
	/*SUPPRESS 530*/
	for (s = PL_inplace; *s && !isSPACE(*s); s++) ;
	if (*s) {
	    *s++ = '\0';
	    if (*s == '-')	/* Additional switches on #! line. */
	        s++;
	}
	return s;
    case 'I':	/* -I handled both here and in parse_perl() */
	forbid_setid("-I");
	++s;
	while (*s && isSPACE(*s))
	    ++s;
	if (*s) {
	    char *e, *p;
	    p = s;
	    /* ignore trailing spaces (possibly followed by other switches) */
	    do {
		for (e = p; *e && !isSPACE(*e); e++) ;
		p = e;
		while (isSPACE(*p))
		    p++;
	    } while (*p && *p != '-');
	    e = savepvn(s, e-s);
	    incpush(e, TRUE, TRUE);
	    Safefree(e);
	    s = p;
	    if (*s == '-')
		s++;
	}
	else
	    Perl_croak(aTHX_ "No directory specified for -I");
	return s;
    case 'l':
	PL_minus_l = TRUE;
	s++;
	if (PL_ors_sv) {
	    SvREFCNT_dec(PL_ors_sv);
	    PL_ors_sv = Nullsv;
	}
	if (isDIGIT(*s)) {
            I32 flags = 0;
	    PL_ors_sv = newSVpvn("\n",1);
	    numlen = 3 + (*s == '0');
	    *SvPVX(PL_ors_sv) = (char)grok_oct(s, &numlen, &flags, NULL);
	    s += numlen;
	}
	else {
	    if (RsPARA(PL_rs)) {
		PL_ors_sv = newSVpvn("\n\n",2);
	    }
	    else {
		PL_ors_sv = newSVsv(PL_rs);
	    }
	}
	return s;
    case 'M':
	forbid_setid("-M");	/* XXX ? */
	/* FALL THROUGH */
    case 'm':
	forbid_setid("-m");	/* XXX ? */
	if (*++s) {
	    char *start;
	    SV *sv;
	    char *use = "use ";
	    /* -M-foo == 'no foo'	*/
	    if (*s == '-') { use = "no "; ++s; }
	    sv = newSVpv(use,0);
	    start = s;
	    /* We allow -M'Module qw(Foo Bar)'	*/
	    while(isALNUM(*s) || *s==':') ++s;
	    if (*s != '=') {
		sv_catpv(sv, start);
		if (*(start-1) == 'm') {
		    if (*s != '\0')
			Perl_croak(aTHX_ "Can't use '%c' after -mname", *s);
		    sv_catpv( sv, " ()");
		}
	    } else {
                if (s == start)
                    Perl_croak(aTHX_ "Module name required with -%c option",
			       s[-1]);
		sv_catpvn(sv, start, s-start);
		sv_catpv(sv, " split(/,/,q{");
		sv_catpv(sv, ++s);
		sv_catpv(sv,    "})");
	    }
	    s += strlen(s);
	    if (!PL_preambleav)
		PL_preambleav = newAV();
	    av_push(PL_preambleav, sv);
	}
	else
	    Perl_croak(aTHX_ "No space allowed after -%c", *(s-1));
	return s;
    case 'n':
	PL_minus_n = TRUE;
	s++;
	return s;
    case 'p':
	PL_minus_p = TRUE;
	s++;
	return s;
    case 's':
	forbid_setid("-s");
	PL_doswitches = TRUE;
	s++;
	return s;
    case 'T':
	if (!PL_tainting)
	    Perl_croak(aTHX_ "Too late for \"-T\" option");
	s++;
	return s;
    case 'u':
#ifdef MACOS_TRADITIONAL
	Perl_croak(aTHX_ "Believe me, you don't want to use \"-u\" on a Macintosh");
#endif
	PL_do_undump = TRUE;
	s++;
	return s;
    case 'U':
	PL_unsafe = TRUE;
	s++;
	return s;
    case 'v':
#if !defined(DGUX)
	PerlIO_printf(PerlIO_stdout(),
		      Perl_form(aTHX_ "\nThis is perl, v%"VDf" built for %s",
				PL_patchlevel, ARCHNAME));
#else /* DGUX */
/* Adjust verbose output as in the perl that ships with the DG/UX OS from EMC */
	PerlIO_printf(PerlIO_stdout(),
			Perl_form(aTHX_ "\nThis is perl, version %vd\n", PL_patchlevel));
	PerlIO_printf(PerlIO_stdout(),
			Perl_form(aTHX_ "        built under %s at %s %s\n",
					OSNAME, __DATE__, __TIME__));
	PerlIO_printf(PerlIO_stdout(),
			Perl_form(aTHX_ "        OS Specific Release: %s\n",
					OSVERS));
#endif /* !DGUX */

#if defined(LOCAL_PATCH_COUNT)
	if (LOCAL_PATCH_COUNT > 0)
	    PerlIO_printf(PerlIO_stdout(),
			  "\n(with %d registered patch%s, "
			  "see perl -V for more detail)",
			  (int)LOCAL_PATCH_COUNT,
			  (LOCAL_PATCH_COUNT!=1) ? "es" : "");
#endif

	PerlIO_printf(PerlIO_stdout(),
		      "\n\nCopyright 1987-2001, Larry Wall\n");
#ifdef MACOS_TRADITIONAL
	PerlIO_printf(PerlIO_stdout(),
		      "\nMac OS port Copyright 1991-2001, Matthias Neeracher;\n"
		      "maintained by Chris Nandor\n");
#endif
#ifdef MSDOS
	PerlIO_printf(PerlIO_stdout(),
		      "\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
#endif
#ifdef DJGPP
	PerlIO_printf(PerlIO_stdout(),
		      "djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n"
		      "djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n");
#endif
#ifdef OS2
	PerlIO_printf(PerlIO_stdout(),
		      "\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
		      "Version 5 port Copyright (c) 1994-1999, Andreas Kaiser, Ilya Zakharevich\n");
#endif
#ifdef atarist
	PerlIO_printf(PerlIO_stdout(),
		      "atariST series port, ++jrb  bammi@cadence.com\n");
#endif
#ifdef __BEOS__
	PerlIO_printf(PerlIO_stdout(),
		      "BeOS port Copyright Tom Spindler, 1997-1999\n");
#endif
#ifdef MPE
	PerlIO_printf(PerlIO_stdout(),
		      "MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-2001\n");
#endif
#ifdef OEMVS
	PerlIO_printf(PerlIO_stdout(),
		      "MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
#endif
#ifdef __VOS__
	PerlIO_printf(PerlIO_stdout(),
		      "Stratus VOS port by Paul_Green@stratus.com, 1997-1999\n");
#endif
#ifdef __OPEN_VM
	PerlIO_printf(PerlIO_stdout(),
		      "VM/ESA port by Neale Ferguson, 1998-1999\n");
#endif
#ifdef POSIX_BC
	PerlIO_printf(PerlIO_stdout(),
		      "BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
#endif
#ifdef __MINT__
	PerlIO_printf(PerlIO_stdout(),
		      "MiNT port by Guido Flohr, 1997-1999\n");
#endif
#ifdef EPOC
	PerlIO_printf(PerlIO_stdout(),
		      "EPOC port by Olaf Flebbe, 1999-2000\n");
#endif
#ifdef UNDER_CE
	printf("WINCE port by Rainer Keuchel, 2001\n");
	printf("Built on " __DATE__ " " __TIME__ "\n\n");
	wce_hitreturn();
#endif
#ifdef BINARY_BUILD_NOTICE
	BINARY_BUILD_NOTICE;
#endif
	PerlIO_printf(PerlIO_stdout(),
		      "\n\
Perl may be copied only under the terms of either the Artistic License or the\n\
GNU General Public License, which may be found in the Perl 5 source kit.\n\n\
Complete documentation for Perl, including FAQ lists, should be found on\n\
this system using `man perl' or `perldoc perl'.  If you have access to the\n\
Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n");
	PerlProc_exit(0);
    case 'w':
	if (! (PL_dowarn & G_WARN_ALL_MASK))
	    PL_dowarn |= G_WARN_ON;
	s++;
	return s;
    case 'W':
	PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
	PL_compiling.cop_warnings = pWARN_ALL ;
	s++;
	return s;
    case 'X':
	PL_dowarn = G_WARN_ALL_OFF;
	PL_compiling.cop_warnings = pWARN_NONE ;
	s++;
	return s;
    case '*':
    case ' ':
	if (s[1] == '-')	/* Additional switches on #! line. */
	    return s+2;
	break;
    case '-':
    case 0:
#if defined(WIN32) || !defined(PERL_STRICT_CR)
    case '\r':
#endif
    case '\n':
    case '\t':
	break;
#ifdef ALTERNATE_SHEBANG
    case 'S':			/* OS/2 needs -S on "extproc" line. */
	break;
#endif
    case 'P':
	if (PL_preprocess)
	    return s+1;
	/* FALL THROUGH */
    default:
	Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s);
    }
    return Nullch;
}

/* compliments of Tom Christiansen */

/* unexec() can be found in the Gnu emacs distribution */
/* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */

void
Perl_my_unexec(pTHX)
{
#ifdef UNEXEC
    SV*    prog;
    SV*    file;
    int    status = 1;
    extern int etext;

    prog = newSVpv(BIN_EXP, 0);
    sv_catpv(prog, "/perl");
    file = newSVpv(PL_origfilename, 0);
    sv_catpv(file, ".perldump");

    unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
    /* unexec prints msg to stderr in case of failure */
    PerlProc_exit(status);
#else
#  ifdef VMS
#    include <lib$routines.h>
     lib$signal(SS$_DEBUG);  /* ssdef.h #included from vmsish.h */
#  else
    ABORT();		/* for use with undump */
#  endif
#endif
}

/* initialize curinterp */
STATIC void
S_init_interp(pTHX)
{

#ifdef MULTIPLICITY
#  define PERLVAR(var,type)
#  define PERLVARA(var,n,type)
#  if defined(PERL_IMPLICIT_CONTEXT)
#    if defined(USE_5005THREADS)
#      define PERLVARI(var,type,init)		PERL_GET_INTERP->var = init;
#      define PERLVARIC(var,type,init)	PERL_GET_INTERP->var = init;
#    else /* !USE_5005THREADS */
#      define PERLVARI(var,type,init)		aTHX->var = init;
#      define PERLVARIC(var,type,init)	aTHX->var = init;
#    endif /* USE_5005THREADS */
#  else
#    define PERLVARI(var,type,init)	PERL_GET_INTERP->var = init;
#    define PERLVARIC(var,type,init)	PERL_GET_INTERP->var = init;
#  endif
#  include "intrpvar.h"
#  ifndef USE_5005THREADS
#    include "thrdvar.h"
#  endif
#  undef PERLVAR
#  undef PERLVARA
#  undef PERLVARI
#  undef PERLVARIC
#else
#  define PERLVAR(var,type)
#  define PERLVARA(var,n,type)
#  define PERLVARI(var,type,init)	PL_##var = init;
#  define PERLVARIC(var,type,init)	PL_##var = init;
#  include "intrpvar.h"
#  ifndef USE_5005THREADS
#    include "thrdvar.h"
#  endif
#  undef PERLVAR
#  undef PERLVARA
#  undef PERLVARI
#  undef PERLVARIC
#endif

}

STATIC void
S_init_main_stash(pTHX)
{
    GV *gv;



    PL_curstash = PL_defstash = newHV();
    PL_curstname = newSVpvn("main",4);
    gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
    SvREFCNT_dec(GvHV(gv));
    GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash);
    SvREADONLY_on(gv);
    HvNAME(PL_defstash) = savepv("main");
    PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
    GvMULTI_on(PL_incgv);
    PL_hintgv = gv_fetchpv("\010",TRUE, SVt_PV); /* ^H */
    GvMULTI_on(PL_hintgv);
    PL_defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
    PL_errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
    GvMULTI_on(PL_errgv);
    PL_replgv = gv_fetchpv("\022", TRUE, SVt_PV); /* ^R */
    GvMULTI_on(PL_replgv);
    (void)Perl_form(aTHX_ "%240s","");	/* Preallocate temp - for immediate signals. */
    sv_grow(ERRSV, 240);	/* Preallocate - for immediate signals. */
    sv_setpvn(ERRSV, "", 0);
    PL_curstash = PL_defstash;
    CopSTASH_set(&PL_compiling, PL_defstash);
    PL_debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
    PL_globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
    PL_nullstash = GvHV(gv_fetchpv("<none>::", GV_ADDMULTI, SVt_PVHV));
    /* We must init $/ before switches are processed. */
    sv_setpvn(get_sv("/", TRUE), "\n", 1);
}

STATIC void
S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript)
{
    *fdscript = -1;

    if (PL_e_script) {
	PL_origfilename = savepv("-e");
    }
    else {
	/* if find_script() returns, it returns a malloc()-ed value */
	PL_origfilename = scriptname = find_script(scriptname, dosearch, NULL, 1);

	if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
	    char *s = scriptname + 8;
	    *fdscript = atoi(s);
	    while (isDIGIT(*s))
		s++;
	    if (*s) {
		scriptname = savepv(s + 1);
		Safefree(PL_origfilename);
		PL_origfilename = scriptname;
	    }
	}
    }

#ifdef USE_ITHREADS
    Safefree(CopFILE(PL_curcop));
#else
    SvREFCNT_dec(CopFILEGV(PL_curcop));
#endif
    CopFILE_set(PL_curcop, PL_origfilename);
    if (strEQ(PL_origfilename,"-"))
	scriptname = "";
    if (*fdscript >= 0) {
	PL_rsfp = PerlIO_fdopen(*fdscript,PERL_SCRIPT_MODE);
#if defined(HAS_FCNTL) && defined(F_SETFD)
	if (PL_rsfp)
	    fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1);  /* ensure close-on-exec */
#endif
    }
    else if (PL_preprocess) {
	char *cpp_cfg = CPPSTDIN;
	SV *cpp = newSVpvn("",0);
	SV *cmd = NEWSV(0,0);

	if (strEQ(cpp_cfg, "cppstdin"))
	    Perl_sv_catpvf(aTHX_ cpp, "%s/", BIN_EXP);
	sv_catpv(cpp, cpp_cfg);

	sv_catpvn(sv, "-I", 2);
	sv_catpv(sv,PRIVLIB_EXP);

	DEBUG_P(PerlIO_printf(Perl_debug_log,
			      "PL_preprocess: scriptname=\"%s\", cpp=\"%s\", sv=\"%s\", CPPMINUS=\"%s\"\n",
			      scriptname, SvPVX (cpp), SvPVX (sv), CPPMINUS));
#if defined(MSDOS) || defined(WIN32)
	Perl_sv_setpvf(aTHX_ cmd, "\
sed %s -e \"/^[^#]/b\" \
 -e \"/^#[ 	]*include[ 	]/b\" \
 -e \"/^#[ 	]*define[ 	]/b\" \
 -e \"/^#[ 	]*if[ 	]/b\" \
 -e \"/^#[ 	]*ifdef[ 	]/b\" \
 -e \"/^#[ 	]*ifndef[ 	]/b\" \
 -e \"/^#[ 	]*else/b\" \
 -e \"/^#[ 	]*elif[ 	]/b\" \
 -e \"/^#[ 	]*undef[ 	]/b\" \
 -e \"/^#[ 	]*endif/b\" \
 -e \"s/^#.*//\" \
 %s | %"SVf" -C %"SVf" %s",
	  (PL_doextract ? "-e \"1,/^#/d\n\"" : ""),
#else
#  ifdef __OPEN_VM
	Perl_sv_setpvf(aTHX_ cmd, "\
%s %s -e '/^[^#]/b' \
 -e '/^#[ 	]*include[ 	]/b' \
 -e '/^#[ 	]*define[ 	]/b' \
 -e '/^#[ 	]*if[ 	]/b' \
 -e '/^#[ 	]*ifdef[ 	]/b' \
 -e '/^#[ 	]*ifndef[ 	]/b' \
 -e '/^#[ 	]*else/b' \
 -e '/^#[ 	]*elif[ 	]/b' \
 -e '/^#[ 	]*undef[ 	]/b' \
 -e '/^#[ 	]*endif/b' \
 -e 's/^[ 	]*#.*//' \
 %s | %"SVf" %"SVf" %s",
#  else
	Perl_sv_setpvf(aTHX_ cmd, "\
%s %s -e '/^[^#]/b' \
 -e '/^#[ 	]*include[ 	]/b' \
 -e '/^#[ 	]*define[ 	]/b' \
 -e '/^#[ 	]*if[ 	]/b' \
 -e '/^#[ 	]*ifdef[ 	]/b' \
 -e '/^#[ 	]*ifndef[ 	]/b' \
 -e '/^#[ 	]*else/b' \
 -e '/^#[ 	]*elif[ 	]/b' \
 -e '/^#[ 	]*undef[ 	]/b' \
 -e '/^#[ 	]*endif/b' \
 -e 's/^[ 	]*#.*//' \
 %s | %"SVf" -C %"SVf" %s",
#  endif
#ifdef LOC_SED
	  LOC_SED,
#else
	  "sed",
#endif
	  (PL_doextract ? "-e '1,/^#/d\n'" : ""),
#endif
	  scriptname, cpp, sv, CPPMINUS);
	PL_doextract = FALSE;
#ifdef IAMSUID				/* actually, this is caught earlier */
	if (PL_euid != PL_uid && !PL_euid) {	/* if running suidperl */
#ifdef HAS_SETEUID
	    (void)seteuid(PL_uid);		/* musn't stay setuid root */
#else
#ifdef HAS_SETREUID
	    (void)setreuid((Uid_t)-1, PL_uid);
#else
#ifdef HAS_SETRESUID
	    (void)setresuid((Uid_t)-1, PL_uid, (Uid_t)-1);
#else
	    PerlProc_setuid(PL_uid);
#endif
#endif
#endif
	    if (PerlProc_geteuid() != PL_uid)
		Perl_croak(aTHX_ "Can't do seteuid!\n");
	}
#endif /* IAMSUID */
	PL_rsfp = PerlProc_popen(SvPVX(cmd), "r");
	SvREFCNT_dec(cmd);
	SvREFCNT_dec(cpp);
    }
    else if (!*scriptname) {
	forbid_setid("program input from stdin");
	PL_rsfp = PerlIO_stdin();
    }
    else {
	PL_rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
#if defined(HAS_FCNTL) && defined(F_SETFD)
	if (PL_rsfp)
	    fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1);  /* ensure close-on-exec */
#endif
    }
    if (!PL_rsfp) {
#ifdef DOSUID
#ifndef IAMSUID		/* in case script is not readable before setuid */
	if (PL_euid &&
	    PerlLIO_stat(CopFILE(PL_curcop),&PL_statbuf) >= 0 &&
	    PL_statbuf.st_mode & (S_ISUID|S_ISGID))
	{
	    /* try again */
	    PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT, BIN_EXP,
				     (int)PERL_REVISION, (int)PERL_VERSION,
				     (int)PERL_SUBVERSION), PL_origargv);
	    Perl_croak(aTHX_ "Can't do setuid\n");
	}
#endif
#endif
#ifdef IAMSUID
	errno = EPERM;
	Perl_croak(aTHX_ "Can't open perl script: %s\n",
		   Strerror(errno));
#else
	Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
		   CopFILE(PL_curcop), Strerror(errno));
#endif
    }
}

/* Mention
 * I_SYSSTATVFS	HAS_FSTATVFS
 * I_SYSMOUNT
 * I_STATFS	HAS_FSTATFS	HAS_GETFSSTAT
 * I_MNTENT	HAS_GETMNTENT	HAS_HASMNTOPT
 * here so that metaconfig picks them up. */

#ifdef IAMSUID
STATIC int
S_fd_on_nosuid_fs(pTHX_ int fd)
{
    int check_okay = 0; /* able to do all the required sys/libcalls */
    int on_nosuid  = 0; /* the fd is on a nosuid fs */
/*
 * Preferred order: fstatvfs(), fstatfs(), ustat()+getmnt(), getmntent().
 * fstatvfs() is UNIX98.
 * fstatfs() is 4.3 BSD.
 * ustat()+getmnt() is pre-4.3 BSD.
 * getmntent() is O(number-of-mounted-filesystems) and can hang on
 * an irrelevant filesystem while trying to reach the right one.
 */

#undef FD_ON_NOSUID_CHECK_OKAY  /* found the syscalls to do the check? */

#   if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
        defined(HAS_FSTATVFS)
#   define FD_ON_NOSUID_CHECK_OKAY
    struct statvfs stfs;

    check_okay = fstatvfs(fd, &stfs) == 0;
    on_nosuid  = check_okay && (stfs.f_flag  & ST_NOSUID);
#   endif /* fstatvfs */

#   if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
        defined(PERL_MOUNT_NOSUID)	&& \
        defined(HAS_FSTATFS) 		&& \
        defined(HAS_STRUCT_STATFS)	&& \
        defined(HAS_STRUCT_STATFS_F_FLAGS)
#   define FD_ON_NOSUID_CHECK_OKAY
    struct statfs  stfs;

    check_okay = fstatfs(fd, &stfs)  == 0;
    on_nosuid  = check_okay && (stfs.f_flags & PERL_MOUNT_NOSUID);
#   endif /* fstatfs */

#   if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
        defined(PERL_MOUNT_NOSUID)	&& \
        defined(HAS_FSTAT)		&& \
        defined(HAS_USTAT)		&& \
        defined(HAS_GETMNT)		&& \
        defined(HAS_STRUCT_FS_DATA)	&& \
        defined(NOSTAT_ONE)
#   define FD_ON_NOSUID_CHECK_OKAY
    struct stat fdst;

    if (fstat(fd, &fdst) == 0) {
        struct ustat us;
        if (ustat(fdst.st_dev, &us) == 0) {
            struct fs_data fsd;
            /* NOSTAT_ONE here because we're not examining fields which
             * vary between that case and STAT_ONE. */
            if (getmnt((int*)0, &fsd, (int)0, NOSTAT_ONE, us.f_fname) == 0) {
                size_t cmplen = sizeof(us.f_fname);
                if (sizeof(fsd.fd_req.path) < cmplen)
                    cmplen = sizeof(fsd.fd_req.path);
                if (strnEQ(fsd.fd_req.path, us.f_fname, cmplen) &&
                    fdst.st_dev == fsd.fd_req.dev) {
                        check_okay = 1;
                        on_nosuid = fsd.fd_req.flags & PERL_MOUNT_NOSUID;
                    }
                }
            }
        }
    }
#   endif /* fstat+ustat+getmnt */

#   if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
        defined(HAS_GETMNTENT)		&& \
        defined(HAS_HASMNTOPT)		&& \
        defined(MNTOPT_NOSUID)
#   define FD_ON_NOSUID_CHECK_OKAY
    FILE                *mtab = fopen("/etc/mtab", "r");
    struct mntent       *entry;
    struct stat         stb, fsb;

    if (mtab && (fstat(fd, &stb) == 0)) {
        while (entry = getmntent(mtab)) {
            if (stat(entry->mnt_dir, &fsb) == 0
                && fsb.st_dev == stb.st_dev)
            {
                /* found the filesystem */
                check_okay = 1;
                if (hasmntopt(entry, MNTOPT_NOSUID))
                    on_nosuid = 1;
                break;
            } /* A single fs may well fail its stat(). */
        }
    }
    if (mtab)
        fclose(mtab);
#   endif /* getmntent+hasmntopt */

    if (!check_okay)
	Perl_croak(aTHX_ "Can't check filesystem of script \"%s\" for nosuid", PL_origfilename);
    return on_nosuid;
}
#endif /* IAMSUID */

STATIC void
S_validate_suid(pTHX_ char *validarg, char *scriptname, int fdscript)
{
#ifdef IAMSUID
    int which;
#endif

    /* do we need to emulate setuid on scripts? */

    /* This code is for those BSD systems that have setuid #! scripts disabled
     * in the kernel because of a security problem.  Merely defining DOSUID
     * in perl will not fix that problem, but if you have disabled setuid
     * scripts in the kernel, this will attempt to emulate setuid and setgid
     * on scripts that have those now-otherwise-useless bits set.  The setuid
     * root version must be called suidperl or sperlN.NNN.  If regular perl
     * discovers that it has opened a setuid script, it calls suidperl with
     * the same argv that it had.  If suidperl finds that the script it has
     * just opened is NOT setuid root, it sets the effective uid back to the
     * uid.  We don't just make perl setuid root because that loses the
     * effective uid we had before invoking perl, if it was different from the
     * uid.
     *
     * DOSUID must be defined in both perl and suidperl, and IAMSUID must
     * be defined in suidperl only.  suidperl must be setuid root.  The
     * Configure script will set this up for you if you want it.
     */

#ifdef DOSUID
    char *s, *s2;

    if (PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf) < 0)	/* normal stat is insecure */
	Perl_croak(aTHX_ "Can't stat script \"%s\"",PL_origfilename);
    if (fdscript < 0 && PL_statbuf.st_mode & (S_ISUID|S_ISGID)) {
	I32 len;
	STRLEN n_a;

#ifdef IAMSUID
#ifndef HAS_SETREUID
	/* On this access check to make sure the directories are readable,
	 * there is actually a small window that the user could use to make
	 * filename point to an accessible directory.  So there is a faint
	 * chance that someone could execute a setuid script down in a
	 * non-accessible directory.  I don't know what to do about that.
	 * But I don't think it's too important.  The manual lies when
	 * it says access() is useful in setuid programs.
	 */
	if (PerlLIO_access(CopFILE(PL_curcop),1)) /*double check*/
	    Perl_croak(aTHX_ "Permission denied");
#else
	/* If we can swap euid and uid, then we can determine access rights
	 * with a simple stat of the file, and then compare device and
	 * inode to make sure we did stat() on the same file we opened.
	 * Then we just have to make sure he or she can execute it.
	 */
	{
	    struct stat tmpstatbuf;

	    if (
#ifdef HAS_SETREUID
		setreuid(PL_euid,PL_uid) < 0
#else
# if HAS_SETRESUID
		setresuid(PL_euid,PL_uid,(Uid_t)-1) < 0
# endif
#endif
		|| PerlProc_getuid() != PL_euid || PerlProc_geteuid() != PL_uid)
		Perl_croak(aTHX_ "Can't swap uid and euid");	/* really paranoid */
	    if (PerlLIO_stat(CopFILE(PL_curcop),&tmpstatbuf) < 0)
		Perl_croak(aTHX_ "Permission denied");	/* testing full pathname here */
#if defined(IAMSUID) && !defined(NO_NOSUID_CHECK)
	    if (fd_on_nosuid_fs(PerlIO_fileno(PL_rsfp)))
		Perl_croak(aTHX_ "Permission denied");
#endif
	    if (tmpstatbuf.st_dev != PL_statbuf.st_dev ||
		tmpstatbuf.st_ino != PL_statbuf.st_ino) {
		(void)PerlIO_close(PL_rsfp);
		Perl_croak(aTHX_ "Permission denied\n");
	    }
	    if (
#ifdef HAS_SETREUID
              setreuid(PL_uid,PL_euid) < 0
#else
# if defined(HAS_SETRESUID)
              setresuid(PL_uid,PL_euid,(Uid_t)-1) < 0
# endif
#endif
              || PerlProc_getuid() != PL_uid || PerlProc_geteuid() != PL_euid)
		Perl_croak(aTHX_ "Can't reswap uid and euid");
	    if (!cando(S_IXUSR,FALSE,&PL_statbuf))		/* can real uid exec? */
		Perl_croak(aTHX_ "Permission denied\n");
	}
#endif /* HAS_SETREUID */
#endif /* IAMSUID */

	if (!S_ISREG(PL_statbuf.st_mode))
	    Perl_croak(aTHX_ "Permission denied");
	if (PL_statbuf.st_mode & S_IWOTH)
	    Perl_croak(aTHX_ "Setuid/gid script is writable by world");
	PL_doswitches = FALSE;		/* -s is insecure in suid */
	CopLINE_inc(PL_curcop);
	if (sv_gets(PL_linestr, PL_rsfp, 0) == Nullch ||
	  strnNE(SvPV(PL_linestr,n_a),"#!",2) )	/* required even on Sys V */
	    Perl_croak(aTHX_ "No #! line");
	s = SvPV(PL_linestr,n_a)+2;
	if (*s == ' ') s++;
	while (!isSPACE(*s)) s++;
	for (s2 = s;  (s2 > SvPV(PL_linestr,n_a)+2 &&
		       (isDIGIT(s2[-1]) || strchr("._-", s2[-1])));  s2--) ;
	if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4))  /* sanity check */
	    Perl_croak(aTHX_ "Not a perl script");
	while (*s == ' ' || *s == '\t') s++;
	/*
	 * #! arg must be what we saw above.  They can invoke it by
	 * mentioning suidperl explicitly, but they may not add any strange
	 * arguments beyond what #! says if they do invoke suidperl that way.
	 */
	len = strlen(validarg);
	if (strEQ(validarg," PHOOEY ") ||
	    strnNE(s,validarg,len) || !isSPACE(s[len]))
	    Perl_croak(aTHX_ "Args must match #! line");

#ifndef IAMSUID
	if (PL_euid != PL_uid && (PL_statbuf.st_mode & S_ISUID) &&
	    PL_euid == PL_statbuf.st_uid)
	    if (!PL_do_undump)
		Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
#endif /* IAMSUID */

	if (PL_euid) {	/* oops, we're not the setuid root perl */
	    (void)PerlIO_close(PL_rsfp);
#ifndef IAMSUID
	    /* try again */
	    PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT, BIN_EXP,
				     (int)PERL_REVISION, (int)PERL_VERSION,
				     (int)PERL_SUBVERSION), PL_origargv);
#endif
	    Perl_croak(aTHX_ "Can't do setuid\n");
	}

	if (PL_statbuf.st_mode & S_ISGID && PL_statbuf.st_gid != PL_egid) {
#ifdef HAS_SETEGID
	    (void)setegid(PL_statbuf.st_gid);
#else
#ifdef HAS_SETREGID
           (void)setregid((Gid_t)-1,PL_statbuf.st_gid);
#else
#ifdef HAS_SETRESGID
           (void)setresgid((Gid_t)-1,PL_statbuf.st_gid,(Gid_t)-1);
#else
	    PerlProc_setgid(PL_statbuf.st_gid);
#endif
#endif
#endif
	    if (PerlProc_getegid() != PL_statbuf.st_gid)
		Perl_croak(aTHX_ "Can't do setegid!\n");
	}
	if (PL_statbuf.st_mode & S_ISUID) {
	    if (PL_statbuf.st_uid != PL_euid)
#ifdef HAS_SETEUID
		(void)seteuid(PL_statbuf.st_uid);	/* all that for this */
#else
#ifdef HAS_SETREUID
                (void)setreuid((Uid_t)-1,PL_statbuf.st_uid);
#else
#ifdef HAS_SETRESUID
                (void)setresuid((Uid_t)-1,PL_statbuf.st_uid,(Uid_t)-1);
#else
		PerlProc_setuid(PL_statbuf.st_uid);
#endif
#endif
#endif
	    if (PerlProc_geteuid() != PL_statbuf.st_uid)
		Perl_croak(aTHX_ "Can't do seteuid!\n");
	}
	else if (PL_uid) {			/* oops, mustn't run as root */
#ifdef HAS_SETEUID
          (void)seteuid((Uid_t)PL_uid);
#else
#ifdef HAS_SETREUID
          (void)setreuid((Uid_t)-1,(Uid_t)PL_uid);
#else
#ifdef HAS_SETRESUID
          (void)setresuid((Uid_t)-1,(Uid_t)PL_uid,(Uid_t)-1);
#else
          PerlProc_setuid((Uid_t)PL_uid);
#endif
#endif
#endif
	    if (PerlProc_geteuid() != PL_uid)
		Perl_croak(aTHX_ "Can't do seteuid!\n");
	}
	init_ids();
	if (!cando(S_IXUSR,TRUE,&PL_statbuf))
	    Perl_croak(aTHX_ "Permission denied\n");	/* they can't do this */
    }
#ifdef IAMSUID
    else if (PL_preprocess)
	Perl_croak(aTHX_ "-P not allowed for setuid/setgid script\n");
    else if (fdscript >= 0)
	Perl_croak(aTHX_ "fd script not allowed in suidperl\n");
    else
	Perl_croak(aTHX_ "Script is not setuid/setgid in suidperl\n");

    /* We absolutely must clear out any saved ids here, so we */
    /* exec the real perl, substituting fd script for scriptname. */
    /* (We pass script name as "subdir" of fd, which perl will grok.) */
    PerlIO_rewind(PL_rsfp);
    PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0);  /* just in case rewind didn't */
    for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ;
    if (!PL_origargv[which])
	Perl_croak(aTHX_ "Permission denied");
    PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s",
				  PerlIO_fileno(PL_rsfp), PL_origargv[which]));
#if defined(HAS_FCNTL) && defined(F_SETFD)
    fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0);	/* ensure no close-on-exec */
#endif
    PerlProc_execv(Perl_form(aTHX_ "%s/perl"PERL_FS_VER_FMT, BIN_EXP,
			     (int)PERL_REVISION, (int)PERL_VERSION,
			     (int)PERL_SUBVERSION), PL_origargv);/* try again */
    Perl_croak(aTHX_ "Can't do setuid\n");
#endif /* IAMSUID */
#else /* !DOSUID */
    if (PL_euid != PL_uid || PL_egid != PL_gid) {	/* (suidperl doesn't exist, in fact) */
#ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
	PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf);	/* may be either wrapped or real suid */
	if ((PL_euid != PL_uid && PL_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
	    ||
	    (PL_egid != PL_gid && PL_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
	   )
	    if (!PL_do_undump)
		Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
#endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
	/* not set-id, must be wrapped */
    }
#endif /* DOSUID */
}

STATIC void
S_find_beginning(pTHX)
{
    register char *s, *s2;

    /* skip forward in input to the real script? */

    forbid_setid("-x");
#ifdef MACOS_TRADITIONAL
    /* Since the Mac OS does not honor #! arguments for us, we do it ourselves */

    while (PL_doextract || gMacPerl_AlwaysExtract) {
	if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
	    if (!gMacPerl_AlwaysExtract)
		Perl_croak(aTHX_ "No Perl script found in input\n");
		
	    if (PL_doextract)			/* require explicit override ? */
		if (!OverrideExtract(PL_origfilename))
		    Perl_croak(aTHX_ "User aborted script\n");
		else
		    PL_doextract = FALSE;
		
	    /* Pater peccavi, file does not have #! */
	    PerlIO_rewind(PL_rsfp);
	
	    break;
	}
#else
    while (PL_doextract) {
	if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch)
	    Perl_croak(aTHX_ "No Perl script found in input\n");
#endif
	s2 = s;
	if (*s == '#' && s[1] == '!' && ((s = instr(s,"perl")) || (s = instr(s2,"PERL")))) {
	    PerlIO_ungetc(PL_rsfp, '\n');		/* to keep line count right */
	    PL_doextract = FALSE;
	    while (*s && !(isSPACE (*s) || *s == '#')) s++;
	    s2 = s;
	    while (*s == ' ' || *s == '\t') s++;
	    if (*s++ == '-') {
		while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
		if (strnEQ(s2-4,"perl",4))
		    /*SUPPRESS 530*/
		    while ((s = moreswitches(s)))
			;
	    }
#ifdef MACOS_TRADITIONAL
	    break;
#endif
	}
    }
}


STATIC void
S_init_ids(pTHX)
{
    PL_uid = PerlProc_getuid();
    PL_euid = PerlProc_geteuid();
    PL_gid = PerlProc_getgid();
    PL_egid = PerlProc_getegid();
#ifdef VMS
    PL_uid |= PL_gid << 16;
    PL_euid |= PL_egid << 16;
#endif
    PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
}

STATIC void
S_forbid_setid(pTHX_ char *s)
{
    if (PL_euid != PL_uid)
        Perl_croak(aTHX_ "No %s allowed while running setuid", s);
    if (PL_egid != PL_gid)
        Perl_croak(aTHX_ "No %s allowed while running setgid", s);
}

void
Perl_init_debugger(pTHX)
{
    HV *ostash = PL_curstash;

    PL_curstash = PL_debstash;
    PL_dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
    AvREAL_off(PL_dbargs);
    PL_DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
    PL_DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
    PL_DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
    sv_upgrade(GvSV(PL_DBsub), SVt_IV);	/* IVX accessed if PERLDB_SUB_NN */
    PL_DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
    sv_setiv(PL_DBsingle, 0);
    PL_DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
    sv_setiv(PL_DBtrace, 0);
    PL_DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
    sv_setiv(PL_DBsignal, 0);
    PL_curstash = ostash;
}

#ifndef STRESS_REALLOC
#define REASONABLE(size) (size)
#else
#define REASONABLE(size) (1) /* unreasonable */
#endif

void
Perl_init_stacks(pTHX)
{
    /* start with 128-item stack and 8K cxstack */
    PL_curstackinfo = new_stackinfo(REASONABLE(128),
				 REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
    PL_curstackinfo->si_type = PERLSI_MAIN;
    PL_curstack = PL_curstackinfo->si_stack;
    PL_mainstack = PL_curstack;		/* remember in case we switch stacks */

    PL_stack_base = AvARRAY(PL_curstack);
    PL_stack_sp = PL_stack_base;
    PL_stack_max = PL_stack_base + AvMAX(PL_curstack);

    New(50,PL_tmps_stack,REASONABLE(128),SV*);
    PL_tmps_floor = -1;
    PL_tmps_ix = -1;
    PL_tmps_max = REASONABLE(128);

    New(54,PL_markstack,REASONABLE(32),I32);
    PL_markstack_ptr = PL_markstack;
    PL_markstack_max = PL_markstack + REASONABLE(32);

    SET_MARK_OFFSET;

    New(54,PL_scopestack,REASONABLE(32),I32);
    PL_scopestack_ix = 0;
    PL_scopestack_max = REASONABLE(32);

    New(54,PL_savestack,REASONABLE(128),ANY);
    PL_savestack_ix = 0;
    PL_savestack_max = REASONABLE(128);

    New(54,PL_retstack,REASONABLE(16),OP*);
    PL_retstack_ix = 0;
    PL_retstack_max = REASONABLE(16);
}

#undef REASONABLE

STATIC void
S_nuke_stacks(pTHX)
{
    while (PL_curstackinfo->si_next)
	PL_curstackinfo = PL_curstackinfo->si_next;
    while (PL_curstackinfo) {
	PERL_SI *p = PL_curstackinfo->si_prev;
	/* curstackinfo->si_stack got nuked by sv_free_arenas() */
	Safefree(PL_curstackinfo->si_cxstack);
	Safefree(PL_curstackinfo);
	PL_curstackinfo = p;
    }
    Safefree(PL_tmps_stack);
    Safefree(PL_markstack);
    Safefree(PL_scopestack);
    Safefree(PL_savestack);
    Safefree(PL_retstack);
}

STATIC void
S_init_lexer(pTHX)
{
    PerlIO *tmpfp;
    tmpfp = PL_rsfp;
    PL_rsfp = Nullfp;
    lex_start(PL_linestr);
    PL_rsfp = tmpfp;
    PL_subname = newSVpvn("main",4);
}

STATIC void
S_init_predump_symbols(pTHX)
{
    GV *tmpgv;
    IO *io;

    sv_setpvn(get_sv("\"", TRUE), " ", 1);
    PL_stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
    GvMULTI_on(PL_stdingv);
    io = GvIOp(PL_stdingv);
    IoTYPE(io) = IoTYPE_RDONLY;
    IoIFP(io) = PerlIO_stdin();
    tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
    GvMULTI_on(tmpgv);
    GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);

    tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
    GvMULTI_on(tmpgv);
    io = GvIOp(tmpgv);
    IoTYPE(io) = IoTYPE_WRONLY;
    IoOFP(io) = IoIFP(io) = PerlIO_stdout();
    setdefout(tmpgv);
    tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
    GvMULTI_on(tmpgv);
    GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);

    PL_stderrgv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
    GvMULTI_on(PL_stderrgv);
    io = GvIOp(PL_stderrgv);
    IoTYPE(io) = IoTYPE_WRONLY;
    IoOFP(io) = IoIFP(io) = PerlIO_stderr();
    tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
    GvMULTI_on(tmpgv);
    GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);

    PL_statname = NEWSV(66,0);		/* last filename we did stat on */

    if (PL_osname)
    	Safefree(PL_osname);
    PL_osname = savepv(OSNAME);
}

STATIC void
S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env)
{
    char *s;
    SV *sv;
    GV* tmpgv;
#ifdef NEED_ENVIRON_DUP_FOR_MODIFY
    char **dup_env_base = 0;
    int dup_env_count = 0;
#endif

    argc--,argv++;	/* skip name of script */
    if (PL_doswitches) {
	for (; argc > 0 && **argv == '-'; argc--,argv++) {
	    if (!argv[0][1])
		break;
	    if (argv[0][1] == '-' && !argv[0][2]) {
		argc--,argv++;
		break;
	    }
	    if ((s = strchr(argv[0], '='))) {
		*s++ = '\0';
		sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
	    }
	    else
		sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
	}
    }
    PL_toptarget = NEWSV(0,0);
    sv_upgrade(PL_toptarget, SVt_PVFM);
    sv_setpvn(PL_toptarget, "", 0);
    PL_bodytarget = NEWSV(0,0);
    sv_upgrade(PL_bodytarget, SVt_PVFM);
    sv_setpvn(PL_bodytarget, "", 0);
    PL_formtarget = PL_bodytarget;

    TAINT;
    if ((tmpgv = gv_fetchpv("0",TRUE, SVt_PV))) {
#ifdef MACOS_TRADITIONAL
	/* $0 is not majick on a Mac */
	sv_setpv(GvSV(tmpgv),MacPerl_MPWFileName(PL_origfilename));
#else
	sv_setpv(GvSV(tmpgv),PL_origfilename);
	magicname("0", "0", 1);
#endif
    }
    if ((tmpgv = gv_fetchpv("\030",TRUE, SVt_PV)))
#ifdef OS2
	sv_setpv(GvSV(tmpgv), os2_execname(aTHX));
#else
	sv_setpv(GvSV(tmpgv),PL_origargv[0]);
#endif
    if ((PL_argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV))) {
	GvMULTI_on(PL_argvgv);
	(void)gv_AVadd(PL_argvgv);
	av_clear(GvAVn(PL_argvgv));
	for (; argc > 0; argc--,argv++) {
	    SV *sv = newSVpv(argv[0],0);
	    av_push(GvAVn(PL_argvgv),sv);
	    if (PL_widesyscalls)
		(void)sv_utf8_decode(sv);
	}
    }
    if ((PL_envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV))) {
	HV *hv;
	GvMULTI_on(PL_envgv);
	hv = GvHVn(PL_envgv);
	hv_magic(hv, Nullgv, PERL_MAGIC_env);
#ifdef USE_ENVIRON_ARRAY
	/* Note that if the supplied env parameter is actually a copy
	   of the global environ then it may now point to free'd memory
	   if the environment has been modified since. To avoid this
	   problem we treat env==NULL as meaning 'use the default'
	*/
	if (!env)
	    env = environ;
	if (env != environ)
	    environ[0] = Nullch;
#ifdef NEED_ENVIRON_DUP_FOR_MODIFY
	{
	    char **env_base;
	    for (env_base = env; *env; env++)
		dup_env_count++;
	    if ((dup_env_base = (char **)
		 safesysmalloc( sizeof(char *) * (dup_env_count+1) ))) {
		char **dup_env;
		for (env = env_base, dup_env = dup_env_base;
		     *env;
		     env++, dup_env++) {
		    /* With environ one needs to use safesysmalloc(). */
		    *dup_env = safesysmalloc(strlen(*env) + 1);
		    (void)strcpy(*dup_env, *env);
		}
		*dup_env = Nullch;
		env = dup_env_base;
	    } /* else what? */
	}
#endif /* NEED_ENVIRON_DUP_FOR_MODIFY */
	if (env)
	  for (; *env; env++) {
	    if (!(s = strchr(*env,'=')))
		continue;
	    *s++ = '\0';
#if defined(MSDOS)
	    (void)strupr(*env);
#endif
	    sv = newSVpv(s--,0);
	    (void)hv_store(hv, *env, s - *env, sv, 0);
	    *s = '=';
	  }
#ifdef NEED_ENVIRON_DUP_FOR_MODIFY
	if (dup_env_base) {
	    char **dup_env;
	    for (dup_env = dup_env_base; *dup_env; dup_env++)
		safesysfree(*dup_env);
	    safesysfree(dup_env_base);
	}
#endif /* NEED_ENVIRON_DUP_FOR_MODIFY */
#endif /* USE_ENVIRON_ARRAY */
    }
    TAINT_NOT;
    if ((tmpgv = gv_fetchpv("$",TRUE, SVt_PV)))
	sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
}

STATIC void
S_init_perllib(pTHX)
{
    char *s;
    if (!PL_tainting) {
#ifndef VMS
	s = PerlEnv_getenv("PERL5LIB");
	if (s)
	    incpush(s, TRUE, TRUE);
	else
	    incpush(PerlEnv_getenv("PERLLIB"), FALSE, FALSE);
#else /* VMS */
	/* Treat PERL5?LIB as a possible search list logical name -- the
	 * "natural" VMS idiom for a Unix path string.  We allow each
	 * element to be a set of |-separated directories for compatibility.
	 */
	char buf[256];
	int idx = 0;
	if (my_trnlnm("PERL5LIB",buf,0))
	    do { incpush(buf,TRUE,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
	else
	    while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE,FALSE);
#endif /* VMS */
    }

/* Use the ~-expanded versions of APPLLIB (undocumented),
    ARCHLIB PRIVLIB SITEARCH SITELIB VENDORARCH and VENDORLIB
*/
#ifdef APPLLIB_EXP
    incpush(APPLLIB_EXP, TRUE, TRUE);
#endif

#ifdef ARCHLIB_EXP
    incpush(ARCHLIB_EXP, FALSE, FALSE);
#endif
#ifdef MACOS_TRADITIONAL
    {
	struct stat tmpstatbuf;
    	SV * privdir = NEWSV(55, 0);
	char * macperl = PerlEnv_getenv("MACPERL");
	
	if (!macperl)
	    macperl = "";
	
	Perl_sv_setpvf(aTHX_ privdir, "%slib:", macperl);
	if (PerlLIO_stat(SvPVX(privdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode))
	    incpush(SvPVX(privdir), TRUE, FALSE);
	Perl_sv_setpvf(aTHX_ privdir, "%ssite_perl:", macperl);
	if (PerlLIO_stat(SvPVX(privdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode))
	    incpush(SvPVX(privdir), TRUE, FALSE);
	
   	SvREFCNT_dec(privdir);
    }
    if (!PL_tainting)
	incpush(":", FALSE, FALSE);
#else
#ifndef PRIVLIB_EXP
#  define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
#endif
#if defined(WIN32)
    incpush(PRIVLIB_EXP, TRUE, FALSE);
#else
    incpush(PRIVLIB_EXP, FALSE, FALSE);
#endif

#ifdef SITEARCH_EXP
    /* sitearch is always relative to sitelib on Windows for
     * DLL-based path intuition to work correctly */
#  if !defined(WIN32)
    incpush(SITEARCH_EXP, FALSE, FALSE);
#  endif
#endif

#ifdef SITELIB_EXP
#  if defined(WIN32)
    incpush(SITELIB_EXP, TRUE, FALSE);	/* this picks up sitearch as well */
#  else
    incpush(SITELIB_EXP, FALSE, FALSE);
#  endif
#endif

#ifdef SITELIB_STEM /* Search for version-specific dirs below here */
    incpush(SITELIB_STEM, FALSE, TRUE);
#endif

#ifdef PERL_VENDORARCH_EXP
    /* vendorarch is always relative to vendorlib on Windows for
     * DLL-based path intuition to work correctly */
#  if !defined(WIN32)
    incpush(PERL_VENDORARCH_EXP, FALSE, FALSE);
#  endif
#endif

#ifdef PERL_VENDORLIB_EXP
#  if defined(WIN32)
    incpush(PERL_VENDORLIB_EXP, TRUE, FALSE);	/* this picks up vendorarch as well */
#  else
    incpush(PERL_VENDORLIB_EXP, FALSE, FALSE);
#  endif
#endif

#ifdef PERL_VENDORLIB_STEM /* Search for version-specific dirs below here */
    incpush(PERL_VENDORLIB_STEM, FALSE, TRUE);
#endif

#ifdef PERL_OTHERLIBDIRS
    incpush(PERL_OTHERLIBDIRS, TRUE, TRUE);
#endif

    if (!PL_tainting)
	incpush(".", FALSE, FALSE);
#endif /* MACOS_TRADITIONAL */
}

#if defined(DOSISH) || defined(EPOC)
#    define PERLLIB_SEP ';'
#else
#  if defined(VMS)
#    define PERLLIB_SEP '|'
#  else
#    if defined(MACOS_TRADITIONAL)
#      define PERLLIB_SEP ','
#    else
#      define PERLLIB_SEP ':'
#    endif
#  endif
#endif
#ifndef PERLLIB_MANGLE
#  define PERLLIB_MANGLE(s,n) (s)
#endif

STATIC void
S_incpush(pTHX_ char *p, int addsubdirs, int addoldvers)
{
    SV *subdir = Nullsv;

    if (!p || !*p)
	return;

    if (addsubdirs || addoldvers) {
	subdir = sv_newmortal();
    }

    /* Break at all separators */
    while (p && *p) {
	SV *libdir = NEWSV(55,0);
	char *s;

	/* skip any consecutive separators */
	while ( *p == PERLLIB_SEP ) {
	    /* Uncomment the next line for PATH semantics */
	    /* av_push(GvAVn(PL_incgv), newSVpvn(".", 1)); */
	    p++;
	}

	if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
	    sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
		      (STRLEN)(s - p));
	    p = s + 1;
	}
	else {
	    sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
	    p = Nullch;	/* break out */
	}
#ifdef MACOS_TRADITIONAL
	if (!strchr(SvPVX(libdir), ':'))
	    sv_insert(libdir, 0, 0, ":", 1);
	if (SvPVX(libdir)[SvCUR(libdir)-1] != ':')
	    sv_catpv(libdir, ":");
#endif

	/*
	 * BEFORE pushing libdir onto @INC we may first push version- and
	 * archname-specific sub-directories.
	 */
	if (addsubdirs || addoldvers) {
#ifdef PERL_INC_VERSION_LIST
	    /* Configure terminates PERL_INC_VERSION_LIST with a NULL */
	    const char *incverlist[] = { PERL_INC_VERSION_LIST };
	    const char **incver;
#endif
	    struct stat tmpstatbuf;
#ifdef VMS
	    char *unix;
	    STRLEN len;

	    if ((unix = tounixspec_ts(SvPV(libdir,len),Nullch)) != Nullch) {
		len = strlen(unix);
		while (unix[len-1] == '/') len--;  /* Cosmetic */
		sv_usepvn(libdir,unix,len);
	    }
	    else
		PerlIO_printf(Perl_error_log,
		              "Failed to unixify @INC element \"%s\"\n",
			      SvPV(libdir,len));
#endif
	    if (addsubdirs) {
#ifdef MACOS_TRADITIONAL
#define PERL_AV_SUFFIX_FMT	""
#define PERL_ARCH_FMT 		"%s:"
#define PERL_ARCH_FMT_PATH	PERL_FS_VER_FMT PERL_AV_SUFFIX_FMT
#else
#define PERL_AV_SUFFIX_FMT 	"/"
#define PERL_ARCH_FMT 		"/%s"
#define PERL_ARCH_FMT_PATH	PERL_AV_SUFFIX_FMT PERL_FS_VER_FMT
#endif
		/* .../version/archname if -d .../version/archname */
		Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT_PATH PERL_ARCH_FMT,
				libdir,
			       (int)PERL_REVISION, (int)PERL_VERSION,
			       (int)PERL_SUBVERSION, ARCHNAME);
		if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
		      S_ISDIR(tmpstatbuf.st_mode))
		    av_push(GvAVn(PL_incgv), newSVsv(subdir));

		/* .../version if -d .../version */
		Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT_PATH, libdir,
			       (int)PERL_REVISION, (int)PERL_VERSION,
			       (int)PERL_SUBVERSION);
		if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
		      S_ISDIR(tmpstatbuf.st_mode))
		    av_push(GvAVn(PL_incgv), newSVsv(subdir));

		/* .../archname if -d .../archname */
		Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT, libdir, ARCHNAME);
		if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
		      S_ISDIR(tmpstatbuf.st_mode))
		    av_push(GvAVn(PL_incgv), newSVsv(subdir));
	    }

#ifdef PERL_INC_VERSION_LIST
	    if (addoldvers) {
		for (incver = incverlist; *incver; incver++) {
		    /* .../xxx if -d .../xxx */
		    Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT, libdir, *incver);
		    if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
			  S_ISDIR(tmpstatbuf.st_mode))
			av_push(GvAVn(PL_incgv), newSVsv(subdir));
		}
	    }
#endif
	}

	/* finally push this lib directory on the end of @INC */
	av_push(GvAVn(PL_incgv), libdir);
    }
}

#ifdef USE_5005THREADS
STATIC struct perl_thread *
S_init_main_thread(pTHX)
{
#if !defined(PERL_IMPLICIT_CONTEXT)
    struct perl_thread *thr;
#endif
    XPV *xpv;

    Newz(53, thr, 1, struct perl_thread);
    PL_curcop = &PL_compiling;
    thr->interp = PERL_GET_INTERP;
    thr->cvcache = newHV();
    thr->threadsv = newAV();
    /* thr->threadsvp is set when find_threadsv is called */
    thr->specific = newAV();
    thr->flags = THRf_R_JOINABLE;
    MUTEX_INIT(&thr->mutex);
    /* Handcraft thrsv similarly to mess_sv */
    New(53, PL_thrsv, 1, SV);
    Newz(53, xpv, 1, XPV);
    SvFLAGS(PL_thrsv) = SVt_PV;
    SvANY(PL_thrsv) = (void*)xpv;
    SvREFCNT(PL_thrsv) = 1 << 30;	/* practically infinite */
    SvPVX(PL_thrsv) = (char*)thr;
    SvCUR_set(PL_thrsv, sizeof(thr));
    SvLEN_set(PL_thrsv, sizeof(thr));
    *SvEND(PL_thrsv) = '\0';	/* in the trailing_nul field */
    thr->oursv = PL_thrsv;
    PL_chopset = " \n-";
    PL_dumpindent = 4;

    MUTEX_LOCK(&PL_threads_mutex);
    PL_nthreads++;
    thr->tid = 0;
    thr->next = thr;
    thr->prev = thr;
    thr->thr_done = 0;
    MUTEX_UNLOCK(&PL_threads_mutex);

#ifdef HAVE_THREAD_INTERN
    Perl_init_thread_intern(thr);
#endif

#ifdef SET_THREAD_SELF
    SET_THREAD_SELF(thr);
#else
    thr->self = pthread_self();
#endif /* SET_THREAD_SELF */
    PERL_SET_THX(thr);

    /*
     * These must come after the thread self setting
     * because sv_setpvn does SvTAINT and the taint
     * fields thread selfness being set.
     */
    PL_toptarget = NEWSV(0,0);
    sv_upgrade(PL_toptarget, SVt_PVFM);
    sv_setpvn(PL_toptarget, "", 0);
    PL_bodytarget = NEWSV(0,0);
    sv_upgrade(PL_bodytarget, SVt_PVFM);
    sv_setpvn(PL_bodytarget, "", 0);
    PL_formtarget = PL_bodytarget;
    thr->errsv = newSVpvn("", 0);
    (void) find_threadsv("@");	/* Ensure $@ is initialised early */

    PL_maxscream = -1;
    PL_peepp = MEMBER_TO_FPTR(Perl_peep);
    PL_regcompp = MEMBER_TO_FPTR(Perl_pregcomp);
    PL_regexecp = MEMBER_TO_FPTR(Perl_regexec_flags);
    PL_regint_start = MEMBER_TO_FPTR(Perl_re_intuit_start);
    PL_regint_string = MEMBER_TO_FPTR(Perl_re_intuit_string);
    PL_regfree = MEMBER_TO_FPTR(Perl_pregfree);
    PL_regindent = 0;
    PL_reginterp_cnt = 0;

    return thr;
}
#endif /* USE_5005THREADS */

void
Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
{
    SV *atsv;
    line_t oldline = CopLINE(PL_curcop);
    CV *cv;
    STRLEN len;
    int ret;
    dJMPENV;

    while (AvFILL(paramList) >= 0) {
	cv = (CV*)av_shift(paramList);
	if (PL_savebegin && (paramList == PL_beginav)) {
		/* save PL_beginav for compiler */
	    if (! PL_beginav_save)
		PL_beginav_save = newAV();
	    av_push(PL_beginav_save, (SV*)cv);
	} else {
	    SAVEFREESV(cv);
	}
#ifdef PERL_FLEXIBLE_EXCEPTIONS
	CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_list_body), cv);
#else
	JMPENV_PUSH(ret);
#endif
	switch (ret) {
	case 0:
#ifndef PERL_FLEXIBLE_EXCEPTIONS
	    call_list_body(cv);
#endif
	    atsv = ERRSV;
	    (void)SvPV(atsv, len);
	    if (len) {
		STRLEN n_a;
		PL_curcop = &PL_compiling;
		CopLINE_set(PL_curcop, oldline);
		if (paramList == PL_beginav)
		    sv_catpv(atsv, "BEGIN failed--compilation aborted");
		else
		    Perl_sv_catpvf(aTHX_ atsv,
				   "%s failed--call queue aborted",
				   paramList == PL_checkav ? "CHECK"
				   : paramList == PL_initav ? "INIT"
				   : "END");
		while (PL_scopestack_ix > oldscope)
		    LEAVE;
		JMPENV_POP;
		Perl_croak(aTHX_ "%s", SvPVx(atsv, n_a));
	    }
	    break;
	case 1:
	    STATUS_ALL_FAILURE;
	    /* FALL THROUGH */
	case 2:
	    /* my_exit() was called */
	    while (PL_scopestack_ix > oldscope)
		LEAVE;
	    FREETMPS;
	    PL_curstash = PL_defstash;
	    PL_curcop = &PL_compiling;
	    CopLINE_set(PL_curcop, oldline);
	    JMPENV_POP;
	    if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED)) {
		if (paramList == PL_beginav)
		    Perl_croak(aTHX_ "BEGIN failed--compilation aborted");
		else
		    Perl_croak(aTHX_ "%s failed--call queue aborted",
			       paramList == PL_checkav ? "CHECK"
			       : paramList == PL_initav ? "INIT"
			       : "END");
	    }
	    my_exit_jump();
	    /* NOTREACHED */
	case 3:
	    if (PL_restartop) {
		PL_curcop = &PL_compiling;
		CopLINE_set(PL_curcop, oldline);
		JMPENV_JUMP(3);
	    }
	    PerlIO_printf(Perl_error_log, "panic: restartop\n");
	    FREETMPS;
	    break;
	}
	JMPENV_POP;
    }
}

#ifdef PERL_FLEXIBLE_EXCEPTIONS
STATIC void *
S_vcall_list_body(pTHX_ va_list args)
{
    CV *cv = va_arg(args, CV*);
    return call_list_body(cv);
}
#endif

STATIC void *
S_call_list_body(pTHX_ CV *cv)
{
    PUSHMARK(PL_stack_sp);
    call_sv((SV*)cv, G_EVAL|G_DISCARD);
    return NULL;
}

void
Perl_my_exit(pTHX_ U32 status)
{
    DEBUG_S(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
			  thr, (unsigned long) status));
    switch (status) {
    case 0:
	STATUS_ALL_SUCCESS;
	break;
    case 1:
	STATUS_ALL_FAILURE;
	break;
    default:
	STATUS_NATIVE_SET(status);
	break;
    }
    my_exit_jump();
}

void
Perl_my_failure_exit(pTHX)
{
#ifdef VMS
    if (vaxc$errno & 1) {
	if (STATUS_NATIVE & 1)		/* fortuitiously includes "-1" */
	    STATUS_NATIVE_SET(44);
    }
    else {
	if (!vaxc$errno && errno)	/* unlikely */
	    STATUS_NATIVE_SET(44);
	else
	    STATUS_NATIVE_SET(vaxc$errno);
    }
#else
    int exitstatus;
    if (errno & 255)
	STATUS_POSIX_SET(errno);
    else {
	exitstatus = STATUS_POSIX >> 8;
	if (exitstatus & 255)
	    STATUS_POSIX_SET(exitstatus);
	else
	    STATUS_POSIX_SET(255);
    }
#endif
    my_exit_jump();
}

STATIC void
S_my_exit_jump(pTHX)
{
    register PERL_CONTEXT *cx;
    I32 gimme;
    SV **newsp;

    if (PL_e_script) {
	SvREFCNT_dec(PL_e_script);
	PL_e_script = Nullsv;
    }

    POPSTACK_TO(PL_mainstack);
    if (cxstack_ix >= 0) {
	if (cxstack_ix > 0)
	    dounwind(0);
	POPBLOCK(cx,PL_curpm);
	LEAVE;
    }

    JMPENV_JUMP(2);
}

static I32
read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen)
{
    char *p, *nl;
    p  = SvPVX(PL_e_script);
    nl = strchr(p, '\n');
    nl = (nl) ? nl+1 : SvEND(PL_e_script);
    if (nl-p == 0) {
	filter_del(read_e_script);
	return 0;
    }
    sv_catpvn(buf_sv, p, nl-p);
    sv_chop(PL_e_script, nl);
    return 1;
}