#include "EXTERN.h"

#define PERL_IN_PERL_C

#include "perl.h"

#include "patchlevel.h" /* for local_patches */

#ifdef I_UNISTD

#include <unistd.h>

#endif

#if !defined(STANDARD_C) && !defined(HAS_GETENV_PROTOTYPE)

char *getenv (char *); /* Usually in <stdlib.h> */

#endif

static I32 read_e_script(pTHXo_ 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

#ifdef PERL_OBJECT

#define perl_construct Perl_construct

#define perl_parse Perl_parse

#define perl_run Perl_run

#define perl_destruct Perl_destruct

#define perl_free Perl_free

#endif

#if defined(USE_THREADS)

# 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;

#ifdef PERL_OBJECT

my_perl = (PerlInterpreter*)new(ipM) CPerlObj(ipM, ipMS, ipMP, ipE, ipStd,

ipLIO, ipD, ipS, ipP);

INIT_TLS_AND_INTERP;

#else

/* 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;

#endif

return my_perl;

}

#else

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 */

perl_construct(pTHXx)

{

#ifdef USE_THREADS

int i;

#ifndef FAKE_THREADS

struct perl_thread *thr = NULL;

#endif /* FAKE_THREADS */

#endif /* USE_THREADS */

#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_THREADS

MUTEX_INIT(&PL_sv_mutex);

/*

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_THREADS */

#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

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;

}

#ifdef PERL_OBJECT

/* TODO: */

/* PL_sighandlerp = sighandler; */

#else

PL_sighandlerp = Perl_sighandler;

#endif

PL_pidstatus = newHV();

#ifdef MSDOS

/*

(void)fclose(stdaux);

(void)fclose(stdprn);

#endif

}

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

PL_rs = SvREFCNT_inc(PL_nrs);

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);

s = uv_to_utf8(s, (UV)PERL_REVISION);

s = uv_to_utf8(s, (UV)PERL_VERSION);

s = uv_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(); /* 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);

ENTER;

}

perl_destruct(pTHXx)

{

int destruct_level; /* 0=none, 1=full, 2=full with checks */

HV *hv;

#ifdef USE_THREADS

Thread t;

dTHX;

#endif /* USE_THREADS */

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

PERL_WAIT_FOR_CHILDREN;

#ifdef USE_THREADS

#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--;

/*

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);

/*

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_THREADS */

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

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;

if (PL_sv_objcount) {

/*

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(aTHXo_ PL_exitlist[PL_exitlistlen].ptr);

Safefree(PL_exitlist);

if (destruct_level == 0){

DEBUG_P(debprofdump());

/* The exit() function will do everything that needs doing. */

return;

}

/* 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

/* 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;

}

/* magical thingies */

Safefree(PL_ofs); /* $, */

PL_ofs = Nullch;

Safefree(PL_ors); /* $\ */

PL_ors = Nullch;

SvREFCNT_dec(PL_rs); /* $/ */

PL_rs = Nullsv;

SvREFCNT_dec(PL_nrs); /* $/ helper */

PL_nrs = 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_endav);

SvREFCNT_dec(PL_checkav);

SvREFCNT_dec(PL_initav);

PL_beginav = 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_tolower);

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;

if (!specialWARN(PL_compiling.cop_warnings))

SvREFCNT_dec(PL_compiling.cop_warnings);

PL_compiling.cop_warnings = 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,

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);

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);

nuke_stacks();

PL_hints = 0; /* Reset hints. Should hints be per-interpreter ? */

DEBUG_P(debprofdump());

#ifdef USE_THREADS

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_THREADS */

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 != 'g' && 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;

}

}

perl_free(pTHXx)

{

#if defined(PERL_OBJECT)

PerlMem_free(this);

#else

# if defined(PERL_IMPLICIT_SYS) && defined(WIN32)

void *host = w32_internal_host;

PerlMem_free(aTHXx);

win32_delete_internal_host(host);

# else

PerlMem_free(aTHXx);

# endif

#endif

}

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;

}

perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env)

{

I32 oldscope;

int ret;

dJMPENV;

#ifdef USE_THREADS

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

#if defined(__DYNAMIC__) && (defined(NeXT) || defined(__NeXT__))

_dyld_lookup_and_bind

("__environ", (unsigned long *) &environ_pointer, NULL);

#endif /* environ */

PL_origargv = argv;

PL_origargc = argc;

#ifdef USE_ENVIRON_ARRAY

PL_origenviron = environ;

#endif

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_THREADS

sv_catpv(PL_Sv," USE_THREADS");

# 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_OBJECT

sv_catpv(PL_Sv," PERL_OBJECT");

# 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{ %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, "; \

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")))

{

while (isSPACE(*s))

s++;

if (*s == '-' && *(s+1) == 'T')

PL_tainting = TRUE;

else {

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)) {

*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);

#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

#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_THREADS

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_THREADS */

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_UNIVERSAL();

#ifndef PERL_MICRO

boot_core_xsutils();

#endif

if (xsinit)

(*xsinit)(aTHXo); /* in case linked C routines want magical variables */

#if defined(VMS) || defined(WIN32) || defined(DJGPP) || defined(__CYGWIN__) || defined(EPOC)

init_os_extras();

#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;

}

/* now that script is parsed, we can modify record separator */

SvREFCNT_dec(PL_rs);

PL_rs = SvREFCNT_inc(PL_nrs);

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;

}

perl_run(pTHXx)

{

I32 oldscope;

int ret = 0;

dJMPENV;

#ifdef USE_THREADS

dTHX;

#endif

oldscope = PL_scopestack_ix;

#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_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;

}

SV*

Perl_get_sv(pTHX_ const char *name, I32 create)

{

GV *gv;

#ifdef USE_THREADS

if (name[1] == '\0' && !isALPHA(name[0])) {

PADOFFSET tmp = find_threadsv(name);

if (tmp != NOT_IN_PAD)

return THREADSV(tmp);

}

#endif /* USE_THREADS */

gv = gv_fetchpv(name, create, SVt_PV);

if (gv)

return GvSV(gv);

return Nullsv;

}

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;

}

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;

}

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.

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;

}

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);

}

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);

}

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);

}

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;

I32 retval;

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

&& (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);

}

Perl_eval_sv(pTHX_ SV *sv, I32 flags)

/* See G_* flags in cop.h */

{

dSP;

UNOP myop; /* fake syntax tree node */

I32 oldmark = SP - PL_stack_base;

I32 retval;

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;

}

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;

}

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;

}

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, 0, 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.

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",

};

char **p = usage_msg;

PerlIO_printf(PerlIO_stdout(),

"\nUsage: %s [switches] [--] [programfile] [arguments]",

name);

while (*p)

PerlIO_printf(PerlIO_stdout(), "\n %s", *p++);

}

char *

Perl_moreswitches(pTHX_ char *s)

{

STRLEN numlen;

U32 rschar;

switch (*s) {

case '0':

{

numlen = 0; /* disallow underscores */

rschar = (U32)scan_oct(s, 4, &numlen);

SvREFCNT_dec(PL_nrs);

if (rschar & ~((U8)~0))

PL_nrs = &PL_sv_undef;

else if (!rschar && numlen >= 2)

PL_nrs = newSVpvn("", 0);

else {

char ch = rschar;

PL_nrs = 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 =

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])) {

static char debopts[] = "psltocPmfrxuLHXDST";

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 |= 0x80000000;

#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)

Safefree(PL_ors);

if (isDIGIT(*s)) {

PL_ors = savepv("\n");

PL_orslen = 1;

numlen = 0; /* disallow underscores */

*PL_ors = (char)scan_oct(s, 3 + (*s == '0'), &numlen);

s += numlen;

}

else {

if (RsPARA(PL_nrs)) {

PL_ors = "\n\n";

PL_orslen = 2;

}

else

PL_ors = SvPV(PL_nrs, PL_orslen);

PL_ors = savepvn(PL_ors, PL_orslen);

}

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':

PerlIO_printf(PerlIO_stdout(),

Perl_form(aTHX_ "\nThis is perl, v%"VDf" built for %s",

PL_patchlevel, ARCHNAME));

#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 (c) 1991-2001, Matthias Neeracher\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-1999\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 BINARY_BUILD_NOTICE

BINARY_BUILD_NOTICE;

#endif

PerlIO_printf(PerlIO_stdout(),

"\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;

}

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

}

STATIC void

S_init_interp(pTHX)

{

#ifdef PERL_OBJECT /* XXX kludge */

#define I_REINIT \

STMT_START { \

PL_chopset = " \n-"; \

PL_copline = NOLINE; \

PL_curcop = &PL_compiling;\

PL_curcopdb = NULL; \

PL_dbargs = 0; \

PL_dumpindent = 4; \

PL_laststatval = -1; \

PL_laststype = OP_STAT; \

PL_maxscream = -1; \

PL_maxsysfd = MAXSYSFD; \

PL_statname = Nullsv; \

PL_tmps_floor = -1; \

PL_tmps_ix = -1; \

PL_op_mask = NULL; \

PL_laststatval = -1; \

PL_laststype = OP_STAT; \

PL_mess_sv = Nullsv; \

PL_splitstr = " "; \

PL_generation = 100; \

PL_exitlist = NULL; \

PL_exitlistlen = 0; \

PL_regindent = 0; \

PL_in_clean_objs = FALSE; \

PL_in_clean_all = FALSE; \

PL_profiledata = NULL; \

PL_rsfp = Nullfp; \

PL_rsfp_filters = Nullav; \

PL_dirty = FALSE; \

} STMT_END

I_REINIT;

#else

# ifdef MULTIPLICITY

# define PERLVAR(var,type)

# define PERLVARA(var,n,type)

# if defined(PERL_IMPLICIT_CONTEXT)

# if defined(USE_THREADS)

# define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;

# define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;

# else /* !USE_THREADS */

# define PERLVARI(var,type,init) aTHX->var = init;

# define PERLVARIC(var,type,init) aTHX->var = init;

# endif /* USE_THREADS */

# 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_THREADS

# 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_THREADS

# include "thrdvar.h"

# endif

# undef PERLVAR

# undef PERLVARA

# undef PERLVARI

# undef PERLVARIC

# endif

#endif

}

STATIC void

S_init_main_stash(pTHX)

{

GV *gv;

/* Note that strtab is a rather special HV. Assumptions are made

PL_strtab = newHV();

#ifdef USE_THREADS

MUTEX_INIT(&PL_strtab_mutex);

#endif

HvSHAREKEYS_off(PL_strtab); /* mandatory */

hv_ksplit(PL_strtab, 512);

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);

#if defined(MSDOS) || defined(WIN32)

Perl_sv_setpvf(aTHX_ cmd, "\

%s | %"SVf" -C %"SVf" %s",

(PL_doextract ? "-e \"1,/^#/d\n\"" : ""),

#else

# ifdef __OPEN_VM

Perl_sv_setpvf(aTHX_ cmd, "\

%s | %"SVf" %"SVf" %s",

# else

Perl_sv_setpvf(aTHX_ cmd, "\

%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

Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",

CopFILE(PL_curcop), Strerror(errno));

}

}

#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 */

#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

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

#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,

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

{

struct stat tmpstatbuf;

if (

#ifdef HAS_SETREUID

setreuid(PL_euid,PL_uid) < 0