X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=perl.c;h=4c1eecc1e5f8059b6df6eab1a28b12e8baa51b57;hb=430530eaa0b8fbcca89ff5a168c2b5f9ba65a8ce;hp=b3f76ebff943014b23f3c7281fbc97e485592d66;hpb=3280af22f58e7b37514ed104858e2c2fc55ceeeb;p=p5sagit%2Fp5-mst-13.2.git diff --git a/perl.c b/perl.c index b3f76eb..4c1eecc 100644 --- a/perl.c +++ b/perl.c @@ -1,6 +1,6 @@ /* perl.c * - * Copyright (c) 1987-1998 Larry Wall + * Copyright (c) 1987-1999 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. @@ -12,8 +12,8 @@ */ #include "EXTERN.h" +#define PERL_IN_PERL_C #include "perl.h" -#include "patchlevel.h" /* XXX If this causes problems, set i_unistd=undef in the hint file. */ #ifdef I_UNISTD @@ -21,9 +21,11 @@ #endif #if !defined(STANDARD_C) && !defined(HAS_GETENV_PROTOTYPE) -char *getenv _((char *)); /* Usually in */ +char *getenv (char *); /* Usually in */ #endif +static I32 read_e_script(pTHXo_ int idx, SV *buf_sv, int maxlen); + #ifdef I_FCNTL #include #endif @@ -31,8 +33,6 @@ char *getenv _((char *)); /* Usually in */ #include #endif -dEXTCONST char rcsid[] = "perl.c\nPatch level: ###\n"; - #ifdef IAMSUID #ifndef DOSUID #define DOSUID @@ -46,33 +46,8 @@ dEXTCONST char rcsid[] = "perl.c\nPatch level: ###\n"; #endif #ifdef PERL_OBJECT -static I32 read_e_script _((CPerlObj* pPerl, int idx, SV *buf_sv, int maxlen)); -#else -static void find_beginning _((void)); -static void forbid_setid _((char *)); -static void incpush _((char *, int)); -static void init_interp _((void)); -static void init_ids _((void)); -static void init_debugger _((void)); -static void init_lexer _((void)); -static void init_main_stash _((void)); -#ifdef USE_THREADS -static struct perl_thread * init_main_thread _((void)); -#endif /* USE_THREADS */ -static void init_perllib _((void)); -static void init_postdump_symbols _((int, char **, char **)); -static void init_predump_symbols _((void)); -static void my_exit_jump _((void)) __attribute__((noreturn)); -static void nuke_stacks _((void)); -static void open_script _((char *, bool, SV *, int *fd)); -static void usage _((char *)); -static void validate_suid _((char *, char*, int)); -static I32 read_e_script _((int idx, SV *buf_sv, int maxlen)); -#endif - -#ifdef PERL_OBJECT CPerlObj* perl_alloc(IPerlMem* ipM, IPerlEnv* ipE, IPerlStdIO* ipStd, - IPerlLIO* ipLIO, IPerlDir* ipD, IPerlSock* ipS, IPerlProc* ipP) + IPerlLIO* ipLIO, IPerlDir* ipD, IPerlSock* ipS, IPerlProc* ipP) { CPerlObj* pPerl = new(ipM) CPerlObj(ipM, ipE, ipStd, ipLIO, ipD, ipS, ipP); if(pPerl != NULL) @@ -84,20 +59,18 @@ CPerlObj* perl_alloc(IPerlMem* ipM, IPerlEnv* ipE, IPerlStdIO* ipStd, PerlInterpreter * perl_alloc(void) { - PerlInterpreter *sv_interp; + PerlInterpreter *my_perl; +#if !defined(PERL_IMPLICIT_CONTEXT) PL_curinterp = 0; - New(53, sv_interp, 1, PerlInterpreter); - return sv_interp; +#endif + New(53, my_perl, 1, PerlInterpreter); + return my_perl; } #endif /* PERL_OBJECT */ void -#ifdef PERL_OBJECT -CPerlObj::perl_construct(void) -#else -perl_construct(register PerlInterpreter *sv_interp) -#endif +perl_construct(pTHXx) { #ifdef USE_THREADS int i; @@ -107,13 +80,12 @@ perl_construct(register PerlInterpreter *sv_interp) #endif /* USE_THREADS */ #ifndef PERL_OBJECT - if (!(PL_curinterp = sv_interp)) + if (!(PL_curinterp = my_perl)) return; #endif #ifdef MULTIPLICITY - ++ninterps; - Zero(sv_interp, 1, PerlInterpreter); + Zero(my_perl, 1, PerlInterpreter); #endif /* Init the real globals (and main thread)? */ @@ -124,25 +96,31 @@ perl_construct(register PerlInterpreter *sv_interp) #ifdef ALLOC_THREAD_KEY ALLOC_THREAD_KEY; #else - if (pthread_key_create(&thr_key, 0)) - croak("panic: pthread_key_create"); + if (pthread_key_create(&PL_thr_key, 0)) + Perl_croak(aTHX_ "panic: pthread_key_create"); #endif - MUTEX_INIT(&sv_mutex); + MUTEX_INIT(&PL_sv_mutex); /* * Safe to use basic SV functions from now on (though * not things like mortals or tainting yet). */ - MUTEX_INIT(&eval_mutex); - COND_INIT(&eval_cond); - MUTEX_INIT(&threads_mutex); - COND_INIT(&nthreads_cond); + 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(&svref_mutex); + MUTEX_INIT(&PL_svref_mutex); #endif /* EMULATE_ATOMIC_REFCOUNTS */ + MUTEX_INIT(&PL_cred_mutex); + thr = init_main_thread(); #endif /* USE_THREADS */ + PL_protect = FUNC_NAME_TO_PTR(Perl_default_protect); /* for exceptions */ + + PL_curcop = &PL_compiling; /* needed by ckWARN, right away */ + PL_linestr = NEWSV(65,79); sv_upgrade(PL_linestr,SVt_PVIV); @@ -166,9 +144,9 @@ perl_construct(register PerlInterpreter *sv_interp) #ifdef PERL_OBJECT /* TODO: */ - /* sighandlerp = sighandler; */ + /* PL_sighandlerp = sighandler; */ #else - PL_sighandlerp = sighandler; + PL_sighandlerp = Perl_sighandler; #endif PL_pidstatus = newHV(); @@ -183,13 +161,13 @@ perl_construct(register PerlInterpreter *sv_interp) #endif } - PL_nrs = newSVpv("\n", 1); + PL_nrs = newSVpvn("\n", 1); PL_rs = SvREFCNT_inc(PL_nrs); - init_stacks(ARGS); + init_stacks(); #ifdef MULTIPLICITY init_interp(); - perl_destruct_level = 1; + PL_perl_destruct_level = 1; #else if (PL_perl_destruct_level > 0) init_interp(); @@ -198,20 +176,18 @@ perl_construct(register PerlInterpreter *sv_interp) init_ids(); PL_lex_state = LEX_NOTPARSING; - PL_start_env.je_prev = NULL; - PL_start_env.je_ret = -1; - PL_start_env.je_mustcatch = TRUE; - PL_top_env = &PL_start_env; + JMPENV_BOOTSTRAP; STATUS_ALL_SUCCESS; + init_i18nl10n(1); SET_NUMERIC_STANDARD(); -#if defined(SUBVERSION) && SUBVERSION > 0 - sprintf(PL_patchlevel, "%7.5f", (double) 5 - + ((double) PATCHLEVEL / (double) 1000) - + ((double) SUBVERSION / (double) 100000)); +#if defined(PERL_SUBVERSION) && PERL_SUBVERSION > 0 + sprintf(PL_patchlevel, "%7.5f", (double) PERL_REVISION + + ((double) PERL_VERSION / (double) 1000) + + ((double) PERL_SUBVERSION / (double) 100000)); #else - sprintf(patchlevel, "%5.3f", (double) 5 + - ((double) PATCHLEVEL / (double) 1000)); + sprintf(PL_patchlevel, "%5.3f", (double) PERL_REVISION + + ((double) PERL_VERSION / (double) 1000)); #endif #if defined(LOCAL_PATCH_COUNT) @@ -232,11 +208,7 @@ perl_construct(register PerlInterpreter *sv_interp) } void -#ifdef PERL_OBJECT -CPerlObj::perl_destruct(void) -#else -perl_destruct(register PerlInterpreter *sv_interp) -#endif +perl_destruct(pTHXx) { dTHR; int destruct_level; /* 0=none, 1=full, 2=full with checks */ @@ -244,10 +216,11 @@ perl_destruct(register PerlInterpreter *sv_interp) HV *hv; #ifdef USE_THREADS Thread t; + dTHX; #endif /* USE_THREADS */ -#ifndef PERL_OBJECT - if (!(PL_curinterp = sv_interp)) +#if !defined(PERL_OBJECT) && !defined(PERL_IMPLICIT_CONTEXT) + if (!(PL_curinterp = my_perl)) return; #endif @@ -255,34 +228,34 @@ perl_destruct(register PerlInterpreter *sv_interp) #ifndef FAKE_THREADS /* Pass 1 on any remaining threads: detach joinables, join zombies */ retry_cleanup: - MUTEX_LOCK(&threads_mutex); - DEBUG_L(PerlIO_printf(PerlIO_stderr(), + MUTEX_LOCK(&PL_threads_mutex); + DEBUG_S(PerlIO_printf(PerlIO_stderr(), "perl_destruct: waiting for %d threads...\n", - nthreads - 1)); + 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_L(PerlIO_printf(PerlIO_stderr(), + DEBUG_S(PerlIO_printf(PerlIO_stderr(), "perl_destruct: joining zombie %p\n", t)); ThrSETSTATE(t, THRf_DEAD); MUTEX_UNLOCK(&t->mutex); - nthreads--; + 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(&threads_mutex); + MUTEX_UNLOCK(&PL_threads_mutex); JOIN(t, &av); SvREFCNT_dec((SV*)av); - DEBUG_L(PerlIO_printf(PerlIO_stderr(), + DEBUG_S(PerlIO_printf(PerlIO_stderr(), "perl_destruct: joined zombie %p OK\n", t)); goto retry_cleanup; case THRf_R_JOINABLE: - DEBUG_L(PerlIO_printf(PerlIO_stderr(), + DEBUG_S(PerlIO_printf(PerlIO_stderr(), "perl_destruct: detaching thread %p\n", t)); ThrSETSTATE(t, THRf_R_DETACHED); /* @@ -291,12 +264,12 @@ perl_destruct(register PerlInterpreter *sv_interp) * deadlock if it panics. It's only a breach of good style * not a bug since they are unlocks not locks. */ - MUTEX_UNLOCK(&threads_mutex); + MUTEX_UNLOCK(&PL_threads_mutex); DETACH(t); MUTEX_UNLOCK(&t->mutex); goto retry_cleanup; default: - DEBUG_L(PerlIO_printf(PerlIO_stderr(), + DEBUG_S(PerlIO_printf(PerlIO_stderr(), "perl_destruct: ignoring %p (state %u)\n", t, ThrSTATE(t))); MUTEX_UNLOCK(&t->mutex); @@ -306,18 +279,18 @@ perl_destruct(register PerlInterpreter *sv_interp) /* 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 (nthreads > 1) + while (PL_nthreads > 1) { - DEBUG_L(PerlIO_printf(PerlIO_stderr(), + DEBUG_S(PerlIO_printf(PerlIO_stderr(), "perl_destruct: final wait for %d threads\n", - nthreads - 1)); - COND_WAIT(&nthreads_cond, &threads_mutex); + PL_nthreads - 1)); + COND_WAIT(&PL_nthreads_cond, &PL_threads_mutex); } /* At this point, we're the last thread */ - MUTEX_UNLOCK(&threads_mutex); - DEBUG_L(PerlIO_printf(PerlIO_stderr(), "perl_destruct: armageddon has arrived\n")); - MUTEX_DESTROY(&threads_mutex); - COND_DESTROY(&nthreads_cond); + MUTEX_UNLOCK(&PL_threads_mutex); + DEBUG_S(PerlIO_printf(PerlIO_stderr(), "perl_destruct: armageddon has arrived\n")); + MUTEX_DESTROY(&PL_threads_mutex); + COND_DESTROY(&PL_nthreads_cond); #endif /* !defined(FAKE_THREADS) */ #endif /* USE_THREADS */ @@ -336,10 +309,6 @@ perl_destruct(register PerlInterpreter *sv_interp) LEAVE; FREETMPS; -#ifdef MULTIPLICITY - --ninterps; -#endif - /* We must account for everything. */ /* Destroy the main CV and syntax tree */ @@ -352,6 +321,7 @@ perl_destruct(register PerlInterpreter *sv_interp) PL_main_start = Nullop; SvREFCNT_dec(PL_main_cv); PL_main_cv = Nullcv; + PL_dirty = TRUE; if (PL_sv_objcount) { /* @@ -359,8 +329,6 @@ perl_destruct(register PerlInterpreter *sv_interp) * destructors and destructees still exist. Some sv's might remain. * Non-referenced objects are on their own. */ - - PL_dirty = TRUE; sv_clean_objs(); } @@ -374,7 +342,7 @@ perl_destruct(register PerlInterpreter *sv_interp) /* call exit list functions */ while (PL_exitlistlen-- > 0) - PL_exitlist[PL_exitlistlen].fn(PERL_OBJECT_THIS_ PL_exitlist[PL_exitlistlen].ptr); + PL_exitlist[PL_exitlistlen].fn(aTHXo_ PL_exitlist[PL_exitlistlen].ptr); Safefree(PL_exitlist); @@ -405,7 +373,7 @@ perl_destruct(register PerlInterpreter *sv_interp) PL_minus_a = FALSE; PL_minus_F = FALSE; PL_doswitches = FALSE; - PL_dowarn = FALSE; + PL_dowarn = G_WARN_OFF; PL_doextract = FALSE; PL_sawampersand = FALSE; /* must save all match strings */ PL_sawstudy = FALSE; /* do fbm_instr on all strings */ @@ -482,16 +450,16 @@ perl_destruct(register PerlInterpreter *sv_interp) FREETMPS; if (destruct_level >= 2) { if (PL_scopestack_ix != 0) - warn("Unbalanced scopes: %ld more ENTERs than LEAVEs\n", + Perl_warn(aTHX_ "Unbalanced scopes: %ld more ENTERs than LEAVEs\n", (long)PL_scopestack_ix); if (PL_savestack_ix != 0) - warn("Unbalanced saves: %ld more saves than restores\n", + Perl_warn(aTHX_ "Unbalanced saves: %ld more saves than restores\n", (long)PL_savestack_ix); if (PL_tmps_floor != -1) - warn("Unbalanced tmps: %ld more allocs than frees\n", + Perl_warn(aTHX_ "Unbalanced tmps: %ld more allocs than frees\n", (long)PL_tmps_floor + 1); if (cxstack_ix != -1) - warn("Unbalanced context: %ld more PUSHes than POPs\n", + Perl_warn(aTHX_ "Unbalanced context: %ld more PUSHes than POPs\n", (long)cxstack_ix + 1); } @@ -521,7 +489,7 @@ perl_destruct(register PerlInterpreter *sv_interp) hent = array[0]; for (;;) { if (hent) { - warn("Unbalanced string table refcount: (%d) for \"%s\"", + Perl_warn(aTHX_ "Unbalanced string table refcount: (%d) for \"%s\"", HeVAL(hent) - Nullsv, HeKEY(hent)); HeVAL(hent) = Nullsv; hent = HeNEXT(hent); @@ -536,7 +504,7 @@ perl_destruct(register PerlInterpreter *sv_interp) SvREFCNT_dec(PL_strtab); if (PL_sv_count != 0) - warn("Scalars leaked: %ld\n", (long)PL_sv_count); + Perl_warn(aTHX_ "Scalars leaked: %ld\n", (long)PL_sv_count); sv_free_arenas(); @@ -546,6 +514,8 @@ perl_destruct(register PerlInterpreter *sv_interp) Safefree(PL_origfilename); Safefree(PL_archpat_auto); Safefree(PL_reg_start_tmp); + if (PL_reg_curpm) + Safefree(PL_reg_curpm); Safefree(HeKEY_hek(&PL_hv_fetch_ent_mh)); Safefree(PL_op_mask); nuke_stacks(); @@ -553,20 +523,36 @@ perl_destruct(register PerlInterpreter *sv_interp) DEBUG_P(debprofdump()); #ifdef USE_THREADS - MUTEX_DESTROY(&sv_mutex); - MUTEX_DESTROY(&eval_mutex); - COND_DESTROY(&eval_cond); + MUTEX_DESTROY(&PL_strtab_mutex); + MUTEX_DESTROY(&PL_sv_mutex); + MUTEX_DESTROY(&PL_eval_mutex); + MUTEX_DESTROY(&PL_cred_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(thrsv)); - Safefree(SvANY(thrsv)); - Safefree(thrsv); - thrsv = Nullsv; + Safefree(SvPVX(PL_thrsv)); + Safefree(SvANY(PL_thrsv)); + Safefree(PL_thrsv); + PL_thrsv = Nullsv; #endif /* USE_THREADS */ /* 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 */ SvOOK_off(PL_mess_sv); Safefree(SvPVX(PL_mess_sv)); @@ -577,27 +563,21 @@ perl_destruct(register PerlInterpreter *sv_interp) } void -#ifdef PERL_OBJECT -CPerlObj::perl_free(void) -#else -perl_free(PerlInterpreter *sv_interp) -#endif +perl_free(pTHXx) { #ifdef PERL_OBJECT Safefree(this); #else - if (!(PL_curinterp = sv_interp)) +# if !defined(PERL_IMPLICIT_CONTEXT) + if (!(PL_curinterp = my_perl)) return; - Safefree(sv_interp); +# endif + Safefree(my_perl); #endif } void -#ifdef PERL_OBJECT -CPerlObj::perl_atexit(void (*fn) (CPerlObj*,void *), void *ptr) -#else -perl_atexit(void (*fn) (void *), void *ptr) -#endif +Perl_call_atexit(pTHX_ ATEXIT_t fn, void *ptr) { Renew(PL_exitlist, PL_exitlistlen+1, PerlExitListEntry); PL_exitlist[PL_exitlistlen].fn = fn; @@ -606,38 +586,29 @@ perl_atexit(void (*fn) (void *), void *ptr) } int -#ifdef PERL_OBJECT -CPerlObj::perl_parse(void (*xsinit) (CPerlObj*), int argc, char **argv, char **env) -#else -perl_parse(PerlInterpreter *sv_interp, void (*xsinit) (void), int argc, char **argv, char **env) -#endif +perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env) { dTHR; - register SV *sv; - register char *s; - char *scriptname = NULL; - VOL bool dosearch = FALSE; - char *validarg = ""; I32 oldscope; - AV* comppadlist; - dJMPENV; int ret; - int fdscript = -1; +#ifdef USE_THREADS + dTHX; +#endif #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW #ifdef IAMSUID #undef IAMSUID - croak("suidperl is no longer needed since the kernel can now execute\n\ + Perl_croak(aTHX_ "suidperl is no longer needed since the kernel can now execute\n\ setuid perl scripts securely.\n"); #endif #endif -#ifndef PERL_OBJECT - if (!(PL_curinterp = sv_interp)) +#if !defined(PERL_OBJECT) && !defined(PERL_IMPLICIT_CONTEXT) + if (!(PL_curinterp = my_perl)) return 255; #endif -#if defined(NeXT) && defined(__DYNAMIC__) +#if defined(__DYNAMIC__) && (defined(NeXT) || defined(__NeXT__)) _dyld_lookup_and_bind ("__environ", (unsigned long *) &environ_pointer, NULL); #endif /* environ */ @@ -671,9 +642,12 @@ setuid perl scripts securely.\n"); time(&PL_basetime); oldscope = PL_scopestack_ix; + PL_dowarn = G_WARN_OFF; - JMPENV_PUSH(ret); + CALLPROTECT(aTHX_ &ret, FUNC_NAME_TO_PTR(S_parse_body), env, xsinit); switch (ret) { + case 0: + return 0; case 1: STATUS_ALL_FAILURE; /* FALL THROUGH */ @@ -685,16 +659,33 @@ setuid perl scripts securely.\n"); PL_curstash = PL_defstash; if (PL_endav) call_list(oldscope, PL_endav); - JMPENV_POP; return STATUS_NATIVE_EXPORT; case 3: - JMPENV_POP; PerlIO_printf(PerlIO_stderr(), "panic: top_env\n"); return 1; } + return 0; +} + +STATIC void * +S_parse_body(pTHX_ va_list args) +{ + dTHR; + int argc = PL_origargc; + char **argv = PL_origargv; + char **env = va_arg(args, char**); + char *scriptname = NULL; + int fdscript = -1; + VOL bool dosearch = FALSE; + char *validarg = ""; + AV* comppadlist; + register SV *sv; + register char *s; + + XSINIT_t xsinit = va_arg(args, XSINIT_t); sv_setpvn(PL_linestr,"",0); - sv = newSVpv("",0); /* first used for -I flags */ + sv = newSVpvn("",0); /* first used for -I flags */ SAVEFREESV(sv); init_main_stash(); @@ -710,6 +701,9 @@ setuid perl scripts securely.\n"); s = argv[0]+1; reswitch: switch (*s) { +#ifndef PERL_STRICT_CR + case '\r': +#endif case ' ': case '0': case 'F': @@ -728,6 +722,8 @@ setuid perl scripts securely.\n"); case 'u': case 'U': case 'v': + case 'W': + case 'X': case 'w': if (s = moreswitches(s)) goto reswitch; @@ -740,9 +736,9 @@ setuid perl scripts securely.\n"); case 'e': if (PL_euid != PL_uid || PL_egid != PL_gid) - croak("No -e allowed in setuid scripts"); + Perl_croak(aTHX_ "No -e allowed in setuid scripts"); if (!PL_e_script) { - PL_e_script = newSVpv("",0); + PL_e_script = newSVpvn("",0); filter_add(read_e_script, NULL); } if (*++s) @@ -752,7 +748,7 @@ setuid perl scripts securely.\n"); argc--,argv++; } else - croak("No code specified for -e"); + Perl_croak(aTHX_ "No code specified for -e"); sv_catpv(PL_e_script, "\n"); break; @@ -791,20 +787,17 @@ setuid perl scripts securely.\n"); if (*++s != ':') { PL_Sv = newSVpv("print myconfig();",0); #ifdef VMS - sv_catpv(Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\","); + 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 -#if defined(DEBUGGING) || defined(NO_EMBED) || defined(MULTIPLICITY) +#if defined(DEBUGGING) || defined(MULTIPLICITY) sv_catpv(PL_Sv,"\" Compile-time options:"); # ifdef DEBUGGING sv_catpv(PL_Sv," DEBUGGING"); # endif -# ifdef NO_EMBED - sv_catpv(Sv," NO_EMBED"); -# endif # ifdef MULTIPLICITY - sv_catpv(Sv," MULTIPLICITY"); + sv_catpv(PL_Sv," MULTIPLICITY"); # endif sv_catpv(PL_Sv,"\\n\","); #endif @@ -814,16 +807,16 @@ setuid perl scripts securely.\n"); sv_catpv(PL_Sv,"\" Locally applied patches:\\n\","); for (i = 1; i <= LOCAL_PATCH_COUNT; i++) { if (PL_localpatches[i]) - sv_catpvf(PL_Sv,"\" \\t%s\\n\",",PL_localpatches[i]); + Perl_sv_catpvf(aTHX_ PL_Sv,"q\" \t%s\n\",",PL_localpatches[i]); } } #endif - sv_catpvf(PL_Sv,"\" Built under %s\\n\"",OSNAME); + Perl_sv_catpvf(aTHX_ PL_Sv,"\" Built under %s\\n\"",OSNAME); #ifdef __DATE__ # ifdef __TIME__ - sv_catpvf(PL_Sv,",\" Compiled at %s %s\\n\"",__DATE__,__TIME__); + Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled at %s %s\\n\"",__DATE__,__TIME__); # else - sv_catpvf(Sv,",\" Compiled on %s\\n\"",__DATE__); + Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled on %s\\n\"",__DATE__); # endif #endif sv_catpv(PL_Sv, "; \ @@ -866,25 +859,35 @@ print \" \\@INC:\\n @INC\\n\";"); s--; /* FALL THROUGH */ default: - croak("Unrecognized switch: -%s (-h will show valid options)",s); + Perl_croak(aTHX_ "Unrecognized switch: -%s (-h will show valid options)",s); } } switch_end: - if (!PL_tainting && (s = PerlEnv_getenv("PERL5OPT"))) { - while (s && *s) { - while (isSPACE(*s)) - s++; - if (*s == '-') { - s++; - if (isSPACE(*s)) - continue; + 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) { + while (isSPACE(*s)) + s++; + if (*s == '-') { + s++; + if (isSPACE(*s)) + continue; + } + if (!*s) + break; + if (!strchr("DIMUdmw", *s)) + Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s); + s = moreswitches(s); } - if (!*s) - break; - if (!strchr("DIMUdmw", *s)) - croak("Illegal switch in PERL5OPT: -%c", *s); - s = moreswitches(s); } } @@ -923,12 +926,12 @@ print \" \\@INC:\\n @INC\\n\";"); PL_min_intro_pending = 0; PL_padix = 0; #ifdef USE_THREADS - av_store(comppad_name, 0, newSVpv("@_", 2)); - curpad[0] = (SV*)newAV(); - SvPADMY_on(curpad[0]); /* XXX Needed? */ - CvOWNER(compcv) = 0; - New(666, CvMUTEXP(compcv), 1, perl_mutex); - MUTEX_INIT(CvMUTEXP(compcv)); + 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(); @@ -940,9 +943,9 @@ print \" \\@INC:\\n @INC\\n\";"); boot_core_UNIVERSAL(); if (xsinit) - (*xsinit)(PERL_OBJECT_THIS); /* in case linked C routines want magical variables */ + (*xsinit)(aTHXo); /* in case linked C routines want magical variables */ #if defined(VMS) || defined(WIN32) || defined(DJGPP) - init_os_extras(); + init_os_extras(aTHX); #endif init_predump_symbols(); @@ -960,10 +963,10 @@ print \" \\@INC:\\n @INC\\n\";"); PL_error_count = 0; if (yyparse() || PL_error_count) { if (PL_minus_c) - croak("%s had compilation errors.\n", PL_origfilename); + Perl_croak(aTHX_ "%s had compilation errors.\n", PL_origfilename); else { - croak("Execution of %s aborted due to compilation errors.\n", - PL_origfilename); + Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n", + PL_origfilename); } } PL_curcop->cop_line = 0; @@ -977,11 +980,11 @@ print \" \\@INC:\\n @INC\\n\";"); /* now that script is parsed, we can modify record separator */ SvREFCNT_dec(PL_rs); PL_rs = SvREFCNT_inc(PL_nrs); - sv_setsv(perl_get_sv("/", TRUE), PL_rs); + sv_setsv(get_sv("/", TRUE), PL_rs); if (PL_do_undump) my_unexec(); - if (PL_dowarn) + if (ckWARN(WARN_ONCE)) gv_check(PL_defstash); LEAVE; @@ -994,36 +997,34 @@ print \" \\@INC:\\n @INC\\n\";"); ENTER; PL_restartop = 0; - JMPENV_POP; - return 0; + return NULL; } int -#ifdef PERL_OBJECT -CPerlObj::perl_run(void) -#else -perl_run(PerlInterpreter *sv_interp) -#endif +perl_run(pTHXx) { - dSP; + dTHR; I32 oldscope; - dJMPENV; int ret; +#ifdef USE_THREADS + dTHX; +#endif -#ifndef PERL_OBJECT - if (!(PL_curinterp = sv_interp)) +#if !defined(PERL_OBJECT) && !defined(PERL_IMPLICIT_CONTEXT) + if (!(PL_curinterp = my_perl)) return 255; #endif oldscope = PL_scopestack_ix; - JMPENV_PUSH(ret); + redo_body: + CALLPROTECT(aTHX_ &ret, FUNC_NAME_TO_PTR(S_run_body), oldscope); switch (ret) { case 1: cxstack_ix = -1; /* start context stack again */ - break; - case 2: - /* my_exit() was called */ + goto redo_body; + case 0: /* normal completion */ + case 2: /* my_exit() */ while (PL_scopestack_ix > oldscope) LEAVE; FREETMPS; @@ -1034,36 +1035,42 @@ perl_run(PerlInterpreter *sv_interp) if (PerlEnv_getenv("PERL_DEBUG_MSTATS")) dump_mstats("after execution: "); #endif - JMPENV_POP; return STATUS_NATIVE_EXPORT; case 3: - if (!PL_restartop) { - PerlIO_printf(PerlIO_stderr(), "panic: restartop\n"); - FREETMPS; - JMPENV_POP; - return 1; + if (PL_restartop) { + POPSTACK_TO(PL_mainstack); + goto redo_body; } - POPSTACK_TO(PL_mainstack); - break; + PerlIO_printf(PerlIO_stderr(), "panic: restartop\n"); + FREETMPS; + return 1; } + /* NOTREACHED */ + return 0; +} + +STATIC void * +S_run_body(pTHX_ va_list args) +{ + dTHR; + I32 oldscope = va_arg(args, I32); + 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")); -#ifdef USE_THREADS - DEBUG_L(PerlIO_printf(Perl_debug_log, "main thread is 0x%lx\n", + DEBUG_S(PerlIO_printf(Perl_debug_log, "main thread is 0x%lx\n", (unsigned long) thr)); -#endif /* USE_THREADS */ if (PL_minus_c) { PerlIO_printf(PerlIO_stderr(), "%s syntax OK\n", PL_origfilename); my_exit(0); } if (PERLDB_SINGLE && PL_DBsingle) - sv_setiv(PL_DBsingle, 1); + sv_setiv(PL_DBsingle, 1); if (PL_initav) call_list(oldscope, PL_initav); } @@ -1071,23 +1078,21 @@ perl_run(PerlInterpreter *sv_interp) /* do it */ if (PL_restartop) { - op = PL_restartop; + PL_op = PL_restartop; PL_restartop = 0; - CALLRUNOPS(); + CALLRUNOPS(aTHX); } else if (PL_main_start) { CvDEPTH(PL_main_cv) = 1; - op = PL_main_start; - CALLRUNOPS(); + PL_op = PL_main_start; + CALLRUNOPS(aTHX); } - my_exit(0); - /* NOTREACHED */ - return 0; + return NULL; } SV* -perl_get_sv(char *name, I32 create) +Perl_get_sv(pTHX_ const char *name, I32 create) { GV *gv; #ifdef USE_THREADS @@ -1106,7 +1111,7 @@ perl_get_sv(char *name, I32 create) } AV* -perl_get_av(char *name, I32 create) +Perl_get_av(pTHX_ const char *name, I32 create) { GV* gv = gv_fetchpv(name, create, SVt_PVAV); if (create) @@ -1117,7 +1122,7 @@ perl_get_av(char *name, I32 create) } HV* -perl_get_hv(char *name, I32 create) +Perl_get_hv(pTHX_ const char *name, I32 create) { GV* gv = gv_fetchpv(name, create, SVt_PVHV); if (create) @@ -1128,9 +1133,13 @@ perl_get_hv(char *name, I32 create) } CV* -perl_get_cv(char *name, I32 create) +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)), @@ -1144,7 +1153,7 @@ perl_get_cv(char *name, I32 create) /* Be sure to refetch the stack pointer after calling these routines. */ I32 -perl_call_argv(char *sub_name, I32 flags, register char **argv) +Perl_call_argv(pTHX_ const char *sub_name, I32 flags, register char **argv) /* See G_* flags in cop.h */ /* null terminated arg list */ @@ -1159,37 +1168,37 @@ perl_call_argv(char *sub_name, I32 flags, register char **argv) } PUTBACK; } - return perl_call_pv(sub_name, flags); + return call_pv(sub_name, flags); } I32 -perl_call_pv(char *sub_name, I32 flags) +Perl_call_pv(pTHX_ const char *sub_name, I32 flags) /* name of the subroutine */ /* See G_* flags in cop.h */ { - return perl_call_sv((SV*)perl_get_cv(sub_name, TRUE), flags); + return call_sv((SV*)get_cv(sub_name, TRUE), flags); } I32 -perl_call_method(char *methname, I32 flags) +Perl_call_method(pTHX_ const char *methname, I32 flags) /* name of the subroutine */ /* See G_* flags in cop.h */ { dSP; OP myop; - if (!op) - op = &myop; + if (!PL_op) + PL_op = &myop; XPUSHs(sv_2mortal(newSVpv(methname,0))); PUTBACK; - pp_method(ARGS); - if(op == &myop) - op = Nullop; - return perl_call_sv(*PL_stack_sp--, flags); + pp_method(); + if(PL_op == &myop) + PL_op = Nullop; + return call_sv(*PL_stack_sp--, flags); } /* May be called with any of a CV, a GV, or an SV containing the name. */ I32 -perl_call_sv(SV *sv, I32 flags) +Perl_call_sv(pTHX_ SV *sv, I32 flags) /* See G_* flags in cop.h */ { @@ -1199,9 +1208,8 @@ perl_call_sv(SV *sv, I32 flags) I32 retval; I32 oldscope; bool oldcatch = CATCH_GET; - dJMPENV; int ret; - OP* oldop = op; + OP* oldop = PL_op; if (flags & G_DISCARD) { ENTER; @@ -1216,7 +1224,7 @@ perl_call_sv(SV *sv, I32 flags) (flags & G_ARRAY) ? OPf_WANT_LIST : OPf_WANT_SCALAR); SAVEOP(); - op = (OP*)&myop; + PL_op = (OP*)&myop; EXTEND(PL_stack_sp, 1); *++PL_stack_sp = sv; @@ -1230,10 +1238,16 @@ perl_call_sv(SV *sv, I32 flags) * curstash may be meaningless. */ && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != PL_debstash) && !(flags & G_NODEBUG)) - op->op_private |= OPpENTERSUB_DB; + PL_op->op_private |= OPpENTERSUB_DB; - if (flags & G_EVAL) { - cLOGOP->op_other = op; + if (!(flags & G_EVAL)) { + CATCH_SET(TRUE); + call_xbody((OP*)&myop, FALSE); + retval = PL_stack_sp - (PL_stack_base + oldmark); + CATCH_SET(FALSE); + } + else { + cLOGOP->op_other = PL_op; PL_markstack_ptr--; /* we're trying to emulate pp_entertry() here */ { @@ -1243,22 +1257,26 @@ perl_call_sv(SV *sv, I32 flags) ENTER; SAVETMPS; - push_return(op->op_next); + push_return(PL_op->op_next); PUSHBLOCK(cx, CXt_EVAL, PL_stack_sp); PUSHEVAL(cx, 0, 0); - PL_eval_root = op; /* Only needed so that goto works right. */ + PL_eval_root = PL_op; /* Only needed so that goto works right. */ - PL_in_eval = 1; + PL_in_eval = EVAL_INEVAL; if (flags & G_KEEPERR) - PL_in_eval |= 4; + PL_in_eval |= EVAL_KEEPERR; else sv_setpv(ERRSV,""); } PL_markstack_ptr++; - JMPENV_PUSH(ret); + redo_body: + CALLPROTECT(aTHX_ &ret, FUNC_NAME_TO_PTR(S_call_body), (OP*)&myop, FALSE); switch (ret) { case 0: + retval = PL_stack_sp - (PL_stack_base + oldmark); + if (!(flags & G_KEEPERR)) + sv_setpv(ERRSV,""); break; case 1: STATUS_ALL_FAILURE; @@ -1267,16 +1285,15 @@ perl_call_sv(SV *sv, I32 flags) /* my_exit() was called */ PL_curstash = PL_defstash; FREETMPS; - JMPENV_POP; if (PL_statusvalue) - croak("Callback called exit"); + Perl_croak(aTHX_ "Callback called exit"); my_exit_jump(); /* NOTREACHED */ case 3: if (PL_restartop) { - op = PL_restartop; + PL_op = PL_restartop; PL_restartop = 0; - break; + goto redo_body; } PL_stack_sp = PL_stack_base + oldmark; if (flags & G_ARRAY) @@ -1285,22 +1302,9 @@ perl_call_sv(SV *sv, I32 flags) retval = 1; *++PL_stack_sp = &PL_sv_undef; } - goto cleanup; + break; } - } - else - CATCH_SET(TRUE); - if (op == (OP*)&myop) - op = pp_entersub(ARGS); - if (op) - CALLRUNOPS(); - retval = PL_stack_sp - (PL_stack_base + oldmark); - if ((flags & G_EVAL) && !(flags & G_KEEPERR)) - sv_setpv(ERRSV,""); - - cleanup: - if (flags & G_EVAL) { if (PL_scopestack_ix > oldscope) { SV **newsp; PMOP *newpm; @@ -1314,10 +1318,7 @@ perl_call_sv(SV *sv, I32 flags) PL_curpm = newpm; LEAVE; } - JMPENV_POP; } - else - CATCH_SET(oldcatch); if (flags & G_DISCARD) { PL_stack_sp = PL_stack_base + oldmark; @@ -1325,14 +1326,39 @@ perl_call_sv(SV *sv, I32 flags) FREETMPS; LEAVE; } - op = oldop; + PL_op = oldop; return retval; } +STATIC void * +S_call_body(pTHX_ va_list args) +{ + OP *myop = va_arg(args, OP*); + int is_eval = va_arg(args, int); + + call_xbody(myop, is_eval); + return NULL; +} + +STATIC void +S_call_xbody(pTHX_ OP *myop, int is_eval) +{ + dTHR; + + if (PL_op == myop) { + if (is_eval) + PL_op = Perl_pp_entereval(aTHX); + else + PL_op = Perl_pp_entersub(aTHX); + } + if (PL_op) + CALLRUNOPS(aTHX); +} + /* Eval a string. The G_EVAL flag is always assumed. */ I32 -perl_eval_sv(SV *sv, I32 flags) +Perl_eval_sv(pTHX_ SV *sv, I32 flags) /* See G_* flags in cop.h */ { @@ -1341,9 +1367,8 @@ perl_eval_sv(SV *sv, I32 flags) I32 oldmark = SP - PL_stack_base; I32 retval; I32 oldscope; - dJMPENV; int ret; - OP* oldop = op; + OP* oldop = PL_op; if (flags & G_DISCARD) { ENTER; @@ -1351,8 +1376,8 @@ perl_eval_sv(SV *sv, I32 flags) } SAVEOP(); - op = (OP*)&myop; - Zero(op, 1, UNOP); + PL_op = (OP*)&myop; + Zero(PL_op, 1, UNOP); EXTEND(PL_stack_sp, 1); *++PL_stack_sp = sv; oldscope = PL_scopestack_ix; @@ -1367,9 +1392,13 @@ perl_eval_sv(SV *sv, I32 flags) if (flags & G_KEEPERR) myop.op_flags |= OPf_SPECIAL; - JMPENV_PUSH(ret); + redo_body: + CALLPROTECT(aTHX_ &ret, FUNC_NAME_TO_PTR(S_call_body), (OP*)&myop, TRUE); switch (ret) { case 0: + retval = PL_stack_sp - (PL_stack_base + oldmark); + if (!(flags & G_KEEPERR)) + sv_setpv(ERRSV,""); break; case 1: STATUS_ALL_FAILURE; @@ -1378,16 +1407,15 @@ perl_eval_sv(SV *sv, I32 flags) /* my_exit() was called */ PL_curstash = PL_defstash; FREETMPS; - JMPENV_POP; if (PL_statusvalue) - croak("Callback called exit"); + Perl_croak(aTHX_ "Callback called exit"); my_exit_jump(); /* NOTREACHED */ case 3: if (PL_restartop) { - op = PL_restartop; + PL_op = PL_restartop; PL_restartop = 0; - break; + goto redo_body; } PL_stack_sp = PL_stack_base + oldmark; if (flags & G_ARRAY) @@ -1396,45 +1424,37 @@ perl_eval_sv(SV *sv, I32 flags) retval = 1; *++PL_stack_sp = &PL_sv_undef; } - goto cleanup; + break; } - if (op == (OP*)&myop) - op = pp_entereval(ARGS); - if (op) - CALLRUNOPS(); - retval = PL_stack_sp - (PL_stack_base + oldmark); - if (!(flags & G_KEEPERR)) - sv_setpv(ERRSV,""); - - cleanup: - JMPENV_POP; if (flags & G_DISCARD) { PL_stack_sp = PL_stack_base + oldmark; retval = 0; FREETMPS; LEAVE; } - op = oldop; + PL_op = oldop; return retval; } SV* -perl_eval_pv(char *p, I32 croak_on_error) +Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error) { dSP; SV* sv = newSVpv(p, 0); PUSHMARK(SP); - perl_eval_sv(sv, G_SCALAR); + eval_sv(sv, G_SCALAR); SvREFCNT_dec(sv); SPAGAIN; sv = POPs; PUTBACK; - if (croak_on_error && SvTRUE(ERRSV)) - croak(SvPVx(ERRSV, PL_na)); + if (croak_on_error && SvTRUE(ERRSV)) { + STRLEN n_a; + Perl_croak(aTHX_ SvPVx(ERRSV, n_a)); + } return sv; } @@ -1442,7 +1462,7 @@ perl_eval_pv(char *p, I32 croak_on_error) /* Require a module. */ void -perl_require_pv(char *pv) +Perl_require_pv(pTHX_ const char *pv) { SV* sv; dSP; @@ -1452,13 +1472,13 @@ perl_require_pv(char *pv) sv_setpv(sv, "require '"); sv_catpv(sv, pv); sv_catpv(sv, "'"); - perl_eval_sv(sv, G_DISCARD); + eval_sv(sv, G_DISCARD); SPAGAIN; POPSTACK; } void -magicname(char *sym, char *name, I32 namlen) +Perl_magicname(pTHX_ char *sym, char *name, I32 namlen) { register GV *gv; @@ -1467,8 +1487,7 @@ magicname(char *sym, char *name, I32 namlen) } STATIC void -usage(char *name) /* XXX move this out into a module ? */ - +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 opton. Others? */ @@ -1477,25 +1496,25 @@ usage(char *name) /* XXX move this out into a module ? */ "-0[octal] specify record separator (\\0, if no argument)", "-a autosplit mode with -n or -p (splits $_ into @F)", "-c check syntax only (runs BEGIN and END blocks)", -"-d[:debugger] run scripts under debugger", -"-D[number/list] set debugging flags (argument is a bit mask or flags)", -"-e 'command' one line of script. Several -e's allowed. Omit [programfile].", -"-F/pattern/ split() pattern for autosplit (-a). The //'s are optional.", -"-i[extension] edit <> files in place (make backup if extension supplied)", -"-Idirectory specify @INC/#include directory (may be used more than once)", +"-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.. executes `use/no module...' before executing your script.", -"-n assume 'while (<>) { ... }' loop around your script", -"-p assume loop like -n but print line also like sed", -"-P run script through C preprocessor before compilation", -"-s enable some switch parsing for switches after script name", -"-S look for the script using PATH environment variable", -"-T turn on tainting checks", -"-u dump core after parsing script", +"-[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 number, patchlevel plus VERY IMPORTANT perl info", -"-V[:variable] print perl configuration information", -"-w TURN WARNINGS ON FOR COMPILATION OF YOUR SCRIPT. Recommended.", +"-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)", "-x[directory] strip off text before #!perl line and perhaps cd to directory", "\n", NULL @@ -1510,7 +1529,7 @@ NULL /* This routine handles any switches that can be given during run */ char * -moreswitches(char *s) +Perl_moreswitches(pTHX_ char *s) { I32 numlen; U32 rschar; @@ -1524,10 +1543,10 @@ moreswitches(char *s) if (rschar & ~((U8)~0)) PL_nrs = &PL_sv_undef; else if (!rschar && numlen >= 2) - PL_nrs = newSVpv("", 0); + PL_nrs = newSVpvn("", 0); else { char ch = rschar; - PL_nrs = newSVpv(&ch, 1); + PL_nrs = newSVpvn(&ch, 1); } return s + numlen; } @@ -1548,7 +1567,7 @@ moreswitches(char *s) forbid_setid("-d"); s++; if (*s == ':' || *s == '=') { - my_setenv("PERL5DB", form("use Devel::%s;", ++s)); + my_setenv("PERL5DB", Perl_form(aTHX_ "use Devel::%s;", ++s)); s += strlen(s); } if (!PL_perldb) { @@ -1560,7 +1579,7 @@ moreswitches(char *s) #ifdef DEBUGGING forbid_setid("-D"); if (isALPHA(s[1])) { - static char debopts[] = "psltocPmfrxuLHXD"; + static char debopts[] = "psltocPmfrxuLHXDS"; char *d; for (s++; *s && (d = strchr(debopts,*s)); s++) @@ -1572,7 +1591,7 @@ moreswitches(char *s) } PL_debug |= 0x80000000; #else - warn("Recompile perl with -DDEBUGGING to use -D switch\n"); + Perl_warn(aTHX_ "Recompile perl with -DDEBUGGING to use -D switch\n"); for (s++; isALNUM(*s); s++) ; #endif /*SUPPRESS 530*/ @@ -1606,7 +1625,7 @@ moreswitches(char *s) s = e; } else - croak("No space allowed after -I"); + Perl_croak(aTHX_ "No space allowed after -I"); return s; case 'l': PL_minus_l = TRUE; @@ -1649,7 +1668,7 @@ moreswitches(char *s) sv_catpv(sv, start); if (*(start-1) == 'm') { if (*s != '\0') - croak("Can't use '%c' after -mname", *s); + Perl_croak(aTHX_ "Can't use '%c' after -mname", *s); sv_catpv( sv, " ()"); } } else { @@ -1664,7 +1683,7 @@ moreswitches(char *s) av_push(PL_preambleav, sv); } else - croak("No space allowed after -%c", *(s-1)); + Perl_croak(aTHX_ "No space allowed after -%c", *(s-1)); return s; case 'n': PL_minus_n = TRUE; @@ -1681,7 +1700,7 @@ moreswitches(char *s) return s; case 'T': if (!PL_tainting) - croak("Too late for \"-T\" option"); + Perl_croak(aTHX_ "Too late for \"-T\" option"); s++; return s; case 'u': @@ -1693,12 +1712,12 @@ moreswitches(char *s) s++; return s; case 'v': -#if defined(SUBVERSION) && SUBVERSION > 0 - printf("\nThis is perl, version 5.%03d_%02d built for %s", - PATCHLEVEL, SUBVERSION, ARCHNAME); +#if defined(PERL_SUBVERSION) && PERL_SUBVERSION > 0 + printf("\nThis is perl, version %d.%03d_%02d built for %s", + PERL_REVISION, PERL_VERSION, PERL_SUBVERSION, ARCHNAME); #else printf("\nThis is perl, version %s built for %s", - patchlevel, ARCHNAME); + PL_patchlevel, ARCHNAME); #endif #if defined(LOCAL_PATCH_COUNT) if (LOCAL_PATCH_COUNT > 0) @@ -1706,26 +1725,41 @@ moreswitches(char *s) LOCAL_PATCH_COUNT, (LOCAL_PATCH_COUNT!=1) ? "es" : ""); #endif - printf("\n\nCopyright 1987-1998, Larry Wall\n"); + printf("\n\nCopyright 1987-1999, Larry Wall\n"); #ifdef MSDOS printf("\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n"); #endif #ifdef DJGPP printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n"); - printf("djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1998\n"); + printf("djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n"); #endif #ifdef OS2 printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n" - "Version 5 port Copyright (c) 1994-1998, Andreas Kaiser, Ilya Zakharevich\n"); + "Version 5 port Copyright (c) 1994-1999, Andreas Kaiser, Ilya Zakharevich\n"); #endif #ifdef atarist printf("atariST series port, ++jrb bammi@cadence.com\n"); #endif #ifdef __BEOS__ - printf("BeOS port Copyright Tom Spindler, 1997-1998\n"); + printf("BeOS port Copyright Tom Spindler, 1997-1999\n"); #endif #ifdef MPE - printf("MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-1998\n"); + printf("MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-1999\n"); +#endif +#ifdef OEMVS + printf("MVS (OS390) port by Mortice Kern Systems, 1997-1999\n"); +#endif +#ifdef __VOS__ + printf("Stratus VOS port by Paul_Green@stratus.com, 1997-1999\n"); +#endif +#ifdef __OPEN_VM + printf("VM/ESA port by Neale Ferguson, 1998-1999\n"); +#endif +#ifdef POSIX_BC + printf("BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n"); +#endif +#ifdef __MINT__ + printf("MiNT port by Guido Flohr, 1997-1999\n"); #endif #ifdef BINARY_BUILD_NOTICE BINARY_BUILD_NOTICE; @@ -1738,7 +1772,18 @@ 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': - PL_dowarn = TRUE; + 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 = WARN_ALL ; + s++; + return s; + case 'X': + PL_dowarn = G_WARN_ALL_OFF; + PL_compiling.cop_warnings = WARN_NONE ; s++; return s; case '*': @@ -1748,7 +1793,7 @@ Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n"); break; case '-': case 0: -#ifdef WIN32 +#if defined(WIN32) || !defined(PERL_STRICT_CR) case '\r': #endif case '\n': @@ -1763,7 +1808,7 @@ Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n"); return s+1; /* FALL THROUGH */ default: - croak("Can't emulate -%.1s on #! line",s); + Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s); } return Nullch; } @@ -1774,7 +1819,7 @@ Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n"); /* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */ void -my_unexec(void) +Perl_my_unexec(pTHX) { #ifdef UNEXEC SV* prog; @@ -1784,7 +1829,7 @@ my_unexec(void) prog = newSVpv(BIN_EXP, 0); sv_catpv(prog, "/perl"); - file = newSVpv(origfilename, 0); + file = newSVpv(PL_origfilename, 0); sv_catpv(file, ".perldump"); unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0); @@ -1802,47 +1847,54 @@ my_unexec(void) /* initialize curinterp */ STATIC void -init_interp(void) +S_init_interp(pTHX) { #ifdef PERL_OBJECT /* XXX kludge */ #define I_REINIT \ - STMT_START { \ - chopset = " \n-"; \ - copline = NOLINE; \ - curcop = &compiling; \ - curcopdb = NULL; \ - dbargs = 0; \ - dlmax = 128; \ - laststatval = -1; \ - laststype = OP_STAT; \ - maxscream = -1; \ - maxsysfd = MAXSYSFD; \ - statname = Nullsv; \ - tmps_floor = -1; \ - tmps_ix = -1; \ - op_mask = NULL; \ - dlmax = 128; \ - laststatval = -1; \ - laststype = OP_STAT; \ - mess_sv = Nullsv; \ - splitstr = " "; \ - generation = 100; \ - exitlist = NULL; \ - exitlistlen = 0; \ - regindent = 0; \ - in_clean_objs = FALSE; \ - in_clean_all= FALSE; \ - profiledata = NULL; \ - rsfp = Nullfp; \ - rsfp_filters= Nullav; \ + STMT_START { \ + PL_chopset = " \n-"; \ + PL_copline = NOLINE; \ + PL_curcop = &PL_compiling;\ + PL_curcopdb = NULL; \ + PL_dbargs = 0; \ + PL_dlmax = 128; \ + 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_dlmax = 128; \ + 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 PERLVARI(var,type,init) curinterp->var = init; -# define PERLVARIC(var,type,init) curinterp->var = init; +# if defined(PERL_IMPLICIT_CONTEXT) +# define PERLVARI(var,type,init) my_perl->var = init; +# define PERLVARIC(var,type,init) my_perl->var = init; +# else +# define PERLVARI(var,type,init) PL_curinterp->var = init; +# define PERLVARIC(var,type,init) PL_curinterp->var = init; +# endif # include "intrpvar.h" # ifndef USE_THREADS # include "thrdvar.h" @@ -1850,10 +1902,10 @@ init_interp(void) # undef PERLVAR # undef PERLVARI # undef PERLVARIC -# else +# else # define PERLVAR(var,type) -# define PERLVARI(var,type,init) var = init; -# define PERLVARIC(var,type,init) var = init; +# 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" @@ -1867,7 +1919,7 @@ init_interp(void) } STATIC void -init_main_stash(void) +S_init_main_stash(pTHX) { dTHR; GV *gv; @@ -1876,11 +1928,14 @@ init_main_stash(void) about not iterating on it, and not adding tie magic to it. It is properly deallocated in perl_destruct() */ 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 = newSVpv("main",4); + PL_curstname = newSVpvn("main",4); gv = gv_fetchpv("main::",TRUE, SVt_PVHV); SvREFCNT_dec(GvHV(gv)); GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash); @@ -1895,7 +1950,7 @@ init_main_stash(void) GvMULTI_on(PL_errgv); PL_replgv = gv_fetchpv("\022", TRUE, SVt_PV); /* ^R */ GvMULTI_on(PL_replgv); - (void)form("%240s",""); /* Preallocate temp - for immediate signals. */ + (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; @@ -1903,11 +1958,11 @@ init_main_stash(void) PL_debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV)); PL_globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV)); /* We must init $/ before switches are processed. */ - sv_setpvn(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), "\n", 1); + sv_setpvn(get_sv("/", TRUE), "\n", 1); } STATIC void -open_script(char *scriptname, bool dosearch, SV *sv, int *fdscript) +S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript) { dTHR; register char *s; @@ -1946,18 +2001,18 @@ open_script(char *scriptname, bool dosearch, SV *sv, int *fdscript) } else if (PL_preprocess) { char *cpp_cfg = CPPSTDIN; - SV *cpp = newSVpv("",0); + SV *cpp = newSVpvn("",0); SV *cmd = NEWSV(0,0); if (strEQ(cpp_cfg, "cppstdin")) - sv_catpvf(cpp, "%s/", BIN_EXP); + Perl_sv_catpvf(aTHX_ cpp, "%s/", BIN_EXP); sv_catpv(cpp, cpp_cfg); sv_catpv(sv,"-I"); sv_catpv(sv,PRIVLIB_EXP); #ifdef MSDOS - sv_setpvf(cmd, "\ + Perl_sv_setpvf(aTHX_ cmd, "\ sed %s -e \"/^[^#]/b\" \ -e \"/^#[ ]*include[ ]/b\" \ -e \"/^#[ ]*define[ ]/b\" \ @@ -1970,9 +2025,24 @@ sed %s -e \"/^[^#]/b\" \ -e \"/^#[ ]*endif/b\" \ -e \"s/^#.*//\" \ %s | %_ -C %_ %s", - (doextract ? "-e \"1,/^#/d\n\"" : ""), + (PL_doextract ? "-e \"1,/^#/d\n\"" : ""), #else - sv_setpvf(cmd, "\ +# 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 | %_ %_ %s", +# else + Perl_sv_setpvf(aTHX_ cmd, "\ %s %s -e '/^[^#]/b' \ -e '/^#[ ]*include[ ]/b' \ -e '/^#[ ]*define[ ]/b' \ @@ -1985,6 +2055,7 @@ sed %s -e \"/^[^#]/b\" \ -e '/^#[ ]*endif/b' \ -e 's/^[ ]*#.*//' \ %s | %_ -C %_ %s", +# endif #ifdef LOC_SED LOC_SED, #else @@ -1995,22 +2066,22 @@ sed %s -e \"/^[^#]/b\" \ scriptname, cpp, sv, CPPMINUS); PL_doextract = FALSE; #ifdef IAMSUID /* actually, this is caught earlier */ - if (euid != uid && !euid) { /* if running suidperl */ + if (PL_euid != PL_uid && !PL_euid) { /* if running suidperl */ #ifdef HAS_SETEUID - (void)seteuid(uid); /* musn't stay setuid root */ + (void)seteuid(PL_uid); /* musn't stay setuid root */ #else #ifdef HAS_SETREUID - (void)setreuid((Uid_t)-1, uid); + (void)setreuid((Uid_t)-1, PL_uid); #else #ifdef HAS_SETRESUID - (void)setresuid((Uid_t)-1, uid, (Uid_t)-1); + (void)setresuid((Uid_t)-1, PL_uid, (Uid_t)-1); #else - PerlProc_setuid(uid); + PerlProc_setuid(PL_uid); #endif #endif #endif - if (PerlProc_geteuid() != uid) - croak("Can't do seteuid!\n"); + if (PerlProc_geteuid() != PL_uid) + Perl_croak(aTHX_ "Can't do seteuid!\n"); } #endif /* IAMSUID */ PL_rsfp = PerlProc_popen(SvPVX(cmd), "r"); @@ -2031,21 +2102,94 @@ sed %s -e \"/^[^#]/b\" \ if (!PL_rsfp) { #ifdef DOSUID #ifndef IAMSUID /* in case script is not readable before setuid */ - if (euid && PerlLIO_stat(SvPVX(GvSV(curcop->cop_filegv)),&statbuf) >= 0 && - statbuf.st_mode & (S_ISUID|S_ISGID)) { + if (PL_euid && + PerlLIO_stat(SvPVX(GvSV(PL_curcop->cop_filegv)),&PL_statbuf) >= 0 && + PL_statbuf.st_mode & (S_ISUID|S_ISGID)) + { /* try again */ - PerlProc_execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv); - croak("Can't do setuid\n"); + PerlProc_execv(Perl_form(aTHX_ "%s/sperl%s", BIN_EXP, PL_patchlevel), PL_origargv); + Perl_croak(aTHX_ "Can't do setuid\n"); } #endif #endif - croak("Can't open perl script \"%s\": %s\n", + Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n", SvPVX(GvSV(PL_curcop->cop_filegv)), Strerror(errno)); } } +/* Mention + * I_SYSSTATVFS HAS_FSTATVFS + * I_SYSMOUNT + * I_STATFS HAS_FSTATFS + * 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 on_nosuid = 0; + int check_okay = 0; +/* + * Preferred order: fstatvfs(), fstatfs(), getmntent(). + * fstatvfs() is UNIX98. + * fstatfs() is BSD. + * getmntent() is O(number-of-mounted-filesystems) and can hang. + */ + +# ifdef HAS_FSTATVFS + struct statvfs stfs; + check_okay = fstatvfs(fd, &stfs) == 0; + on_nosuid = check_okay && (stfs.f_flag & ST_NOSUID); +# else +# if defined(HAS_FSTATFS) && defined(HAS_STRUCT_STATFS_FLAGS) + struct statfs stfs; + check_okay = fstatfs(fd, &stfs) == 0; +# undef PERL_MOUNT_NOSUID +# if !defined(PERL_MOUNT_NOSUID) && defined(MNT_NOSUID) +# define PERL_MOUNT_NOSUID MNT_NOSUID +# endif +# if !defined(PERL_MOUNT_NOSUID) && defined(MS_NOSUID) +# define PERL_MOUNT_NOSUID MS_NOSUID +# endif +# if !defined(PERL_MOUNT_NOSUID) && defined(M_NOSUID) +# define PERL_MOUNT_NOSUID M_NOSUID +# endif +# ifdef PERL_MOUNT_NOSUID + on_nosuid = check_okay && (stfs.f_flags & PERL_MOUNT_NOSUID); +# endif +# else +# if defined(HAS_GETMNTENT) && defined(HAS_HASMNTOPT) && defined(MNTOPT_NOSUID) + 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 /* mntent */ +# endif /* statfs */ +# endif /* statvfs */ + if (!check_okay) + Perl_croak(aTHX_ "Can't check filesystem of script \"%s\"", PL_origfilename); + return on_nosuid; +} +#endif /* IAMSUID */ + STATIC void -validate_suid(char *validarg, char *scriptname, int fdscript) +S_validate_suid(pTHX_ char *validarg, char *scriptname, int fdscript) { int which; @@ -2073,10 +2217,11 @@ validate_suid(char *validarg, char *scriptname, int fdscript) dTHR; char *s, *s2; - if (PerlLIO_fstat(PerlIO_fileno(rsfp),&statbuf) < 0) /* normal stat is insecure */ - croak("Can't stat script \"%s\"",origfilename); - if (fdscript < 0 && statbuf.st_mode & (S_ISUID|S_ISGID)) { + 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 @@ -2088,8 +2233,8 @@ validate_suid(char *validarg, char *scriptname, int fdscript) * But I don't think it's too important. The manual lies when * it says access() is useful in setuid programs. */ - if (PerlLIO_access(SvPVX(GvSV(curcop->cop_filegv)),1)) /*double check*/ - croak("Permission denied"); + if (PerlLIO_access(SvPVX(GvSV(PL_curcop->cop_filegv)),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 @@ -2101,63 +2246,67 @@ validate_suid(char *validarg, char *scriptname, int fdscript) if ( #ifdef HAS_SETREUID - setreuid(euid,uid) < 0 + setreuid(PL_euid,PL_uid) < 0 #else # if HAS_SETRESUID - setresuid(euid,uid,(Uid_t)-1) < 0 + setresuid(PL_euid,PL_uid,(Uid_t)-1) < 0 # endif #endif - || PerlProc_getuid() != euid || PerlProc_geteuid() != uid) - croak("Can't swap uid and euid"); /* really paranoid */ - if (PerlLIO_stat(SvPVX(GvSV(curcop->cop_filegv)),&tmpstatbuf) < 0) - croak("Permission denied"); /* testing full pathname here */ - if (tmpstatbuf.st_dev != statbuf.st_dev || - tmpstatbuf.st_ino != statbuf.st_ino) { - (void)PerlIO_close(rsfp); - if (rsfp = PerlProc_popen("/bin/mail root","w")) { /* heh, heh */ - PerlIO_printf(rsfp, + || PerlProc_getuid() != PL_euid || PerlProc_geteuid() != PL_uid) + Perl_croak(aTHX_ "Can't swap uid and euid"); /* really paranoid */ + if (PerlLIO_stat(SvPVX(GvSV(PL_curcop->cop_filegv)),&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); + if (PL_rsfp = PerlProc_popen("/bin/mail root","w")) { /* heh, heh */ + PerlIO_printf(PL_rsfp, "User %ld tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\ (Filename of set-id script was %s, uid %ld gid %ld.)\n\nSincerely,\nperl\n", - (long)uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino, - (long)statbuf.st_dev, (long)statbuf.st_ino, - SvPVX(GvSV(curcop->cop_filegv)), - (long)statbuf.st_uid, (long)statbuf.st_gid); - (void)PerlProc_pclose(rsfp); + (long)PL_uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino, + (long)PL_statbuf.st_dev, (long)PL_statbuf.st_ino, + SvPVX(GvSV(PL_curcop->cop_filegv)), + (long)PL_statbuf.st_uid, (long)PL_statbuf.st_gid); + (void)PerlProc_pclose(PL_rsfp); } - croak("Permission denied\n"); + Perl_croak(aTHX_ "Permission denied\n"); } if ( #ifdef HAS_SETREUID - setreuid(uid,euid) < 0 + setreuid(PL_uid,PL_euid) < 0 #else # if defined(HAS_SETRESUID) - setresuid(uid,euid,(Uid_t)-1) < 0 + setresuid(PL_uid,PL_euid,(Uid_t)-1) < 0 # endif #endif - || PerlProc_getuid() != uid || PerlProc_geteuid() != euid) - croak("Can't reswap uid and euid"); - if (!cando(S_IXUSR,FALSE,&statbuf)) /* can real uid exec? */ - croak("Permission denied\n"); + || 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(statbuf.st_mode)) - croak("Permission denied"); - if (statbuf.st_mode & S_IWOTH) - croak("Setuid/gid script is writable by world"); - doswitches = FALSE; /* -s is insecure in suid */ - curcop->cop_line++; - if (sv_gets(linestr, rsfp, 0) == Nullch || - strnNE(SvPV(linestr,na),"#!",2) ) /* required even on Sys V */ - croak("No #! line"); - s = SvPV(linestr,na)+2; + 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 */ + PL_curcop->cop_line++; + 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(linestr,na)+2 && + 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 */ - croak("Not a perl script"); + Perl_croak(aTHX_ "Not a perl script"); while (*s == ' ' || *s == '\t') s++; /* * #! arg must be what we saw above. They can invoke it by @@ -2167,116 +2316,116 @@ validate_suid(char *validarg, char *scriptname, int fdscript) len = strlen(validarg); if (strEQ(validarg," PHOOEY ") || strnNE(s,validarg,len) || !isSPACE(s[len])) - croak("Args must match #! line"); + Perl_croak(aTHX_ "Args must match #! line"); #ifndef IAMSUID - if (euid != uid && (statbuf.st_mode & S_ISUID) && - euid == statbuf.st_uid) - if (!do_undump) - croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\ + 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 (euid) { /* oops, we're not the setuid root perl */ - (void)PerlIO_close(rsfp); + if (PL_euid) { /* oops, we're not the setuid root perl */ + (void)PerlIO_close(PL_rsfp); #ifndef IAMSUID /* try again */ - PerlProc_execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv); + PerlProc_execv(Perl_form(aTHX_ "%s/sperl%s", BIN_EXP, PL_patchlevel), PL_origargv); #endif - croak("Can't do setuid\n"); + Perl_croak(aTHX_ "Can't do setuid\n"); } - if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid) { + if (PL_statbuf.st_mode & S_ISGID && PL_statbuf.st_gid != PL_egid) { #ifdef HAS_SETEGID - (void)setegid(statbuf.st_gid); + (void)setegid(PL_statbuf.st_gid); #else #ifdef HAS_SETREGID - (void)setregid((Gid_t)-1,statbuf.st_gid); + (void)setregid((Gid_t)-1,PL_statbuf.st_gid); #else #ifdef HAS_SETRESGID - (void)setresgid((Gid_t)-1,statbuf.st_gid,(Gid_t)-1); + (void)setresgid((Gid_t)-1,PL_statbuf.st_gid,(Gid_t)-1); #else - PerlProc_setgid(statbuf.st_gid); + PerlProc_setgid(PL_statbuf.st_gid); #endif #endif #endif - if (PerlProc_getegid() != statbuf.st_gid) - croak("Can't do setegid!\n"); + if (PerlProc_getegid() != PL_statbuf.st_gid) + Perl_croak(aTHX_ "Can't do setegid!\n"); } - if (statbuf.st_mode & S_ISUID) { - if (statbuf.st_uid != euid) + if (PL_statbuf.st_mode & S_ISUID) { + if (PL_statbuf.st_uid != PL_euid) #ifdef HAS_SETEUID - (void)seteuid(statbuf.st_uid); /* all that for this */ + (void)seteuid(PL_statbuf.st_uid); /* all that for this */ #else #ifdef HAS_SETREUID - (void)setreuid((Uid_t)-1,statbuf.st_uid); + (void)setreuid((Uid_t)-1,PL_statbuf.st_uid); #else #ifdef HAS_SETRESUID - (void)setresuid((Uid_t)-1,statbuf.st_uid,(Uid_t)-1); + (void)setresuid((Uid_t)-1,PL_statbuf.st_uid,(Uid_t)-1); #else - PerlProc_setuid(statbuf.st_uid); + PerlProc_setuid(PL_statbuf.st_uid); #endif #endif #endif - if (PerlProc_geteuid() != statbuf.st_uid) - croak("Can't do seteuid!\n"); + if (PerlProc_geteuid() != PL_statbuf.st_uid) + Perl_croak(aTHX_ "Can't do seteuid!\n"); } - else if (uid) { /* oops, mustn't run as root */ + else if (PL_uid) { /* oops, mustn't run as root */ #ifdef HAS_SETEUID - (void)seteuid((Uid_t)uid); + (void)seteuid((Uid_t)PL_uid); #else #ifdef HAS_SETREUID - (void)setreuid((Uid_t)-1,(Uid_t)uid); + (void)setreuid((Uid_t)-1,(Uid_t)PL_uid); #else #ifdef HAS_SETRESUID - (void)setresuid((Uid_t)-1,(Uid_t)uid,(Uid_t)-1); + (void)setresuid((Uid_t)-1,(Uid_t)PL_uid,(Uid_t)-1); #else - PerlProc_setuid((Uid_t)uid); + PerlProc_setuid((Uid_t)PL_uid); #endif #endif #endif - if (PerlProc_geteuid() != uid) - croak("Can't do seteuid!\n"); + if (PerlProc_geteuid() != PL_uid) + Perl_croak(aTHX_ "Can't do seteuid!\n"); } init_ids(); - if (!cando(S_IXUSR,TRUE,&statbuf)) - croak("Permission denied\n"); /* they can't do this */ + if (!cando(S_IXUSR,TRUE,&PL_statbuf)) + Perl_croak(aTHX_ "Permission denied\n"); /* they can't do this */ } #ifdef IAMSUID - else if (preprocess) - croak("-P not allowed for setuid/setgid script\n"); + else if (PL_preprocess) + Perl_croak(aTHX_ "-P not allowed for setuid/setgid script\n"); else if (fdscript >= 0) - croak("fd script not allowed in suidperl\n"); + Perl_croak(aTHX_ "fd script not allowed in suidperl\n"); else - croak("Script is not setuid/setgid in suidperl\n"); + 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(rsfp); - PerlLIO_lseek(PerlIO_fileno(rsfp),(Off_t)0,0); /* just in case rewind didn't */ - for (which = 1; origargv[which] && origargv[which] != scriptname; which++) ; - if (!origargv[which]) - croak("Permission denied"); - origargv[which] = savepv(form("/dev/fd/%d/%s", - PerlIO_fileno(rsfp), origargv[which])); + 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(rsfp),F_SETFD,0); /* ensure no close-on-exec */ + fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0); /* ensure no close-on-exec */ #endif - PerlProc_execv(form("%s/perl%s", BIN_EXP, patchlevel), origargv); /* try again */ - croak("Can't do setuid\n"); + PerlProc_execv(Perl_form(aTHX_ "%s/perl%s", BIN_EXP, PL_patchlevel), 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 dTHR; - PerlLIO_fstat(PerlIO_fileno(rsfp),&statbuf); /* may be either wrapped or real suid */ - if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID) + 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) || - (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID) + (PL_egid != PL_gid && PL_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID) ) - if (!do_undump) - croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\ + 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 */ @@ -2285,7 +2434,7 @@ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n"); } STATIC void -find_beginning(void) +S_find_beginning(pTHX) { register char *s, *s2; @@ -2294,7 +2443,7 @@ find_beginning(void) forbid_setid("-x"); while (PL_doextract) { if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch) - croak("No Perl script found in input\n"); + Perl_croak(aTHX_ "No Perl script found in input\n"); if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) { PerlIO_ungetc(PL_rsfp, '\n'); /* to keep line count right */ PL_doextract = FALSE; @@ -2308,37 +2457,37 @@ find_beginning(void) while (s = moreswitches(s)) ; } if (PL_cddir && PerlDir_chdir(PL_cddir) < 0) - croak("Can't chdir to %s",PL_cddir); + Perl_croak(aTHX_ "Can't chdir to %s",PL_cddir); } } } STATIC void -init_ids(void) +S_init_ids(pTHX) { PL_uid = (int)PerlProc_getuid(); PL_euid = (int)PerlProc_geteuid(); PL_gid = (int)PerlProc_getgid(); PL_egid = (int)PerlProc_getegid(); #ifdef VMS - uid |= gid << 16; - euid |= egid << 16; + 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 -forbid_setid(char *s) +S_forbid_setid(pTHX_ char *s) { if (PL_euid != PL_uid) - croak("No %s allowed while running setuid", s); + Perl_croak(aTHX_ "No %s allowed while running setuid", s); if (PL_egid != PL_gid) - croak("No %s allowed while running setgid", s); + Perl_croak(aTHX_ "No %s allowed while running setgid", s); } STATIC void -init_debugger(void) +S_init_debugger(pTHX) { dTHR; PL_curstash = PL_debstash; @@ -2363,7 +2512,7 @@ init_debugger(void) #endif void -init_stacks(ARGSproto) +Perl_init_stacks(pTHX) { /* start with 128-item stack and 8K cxstack */ PL_curstackinfo = new_stackinfo(REASONABLE(128), @@ -2403,7 +2552,7 @@ init_stacks(ARGSproto) #undef REASONABLE STATIC void -nuke_stacks(void) +S_nuke_stacks(pTHX) { dTHR; while (PL_curstackinfo->si_next) @@ -2431,7 +2580,7 @@ static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */ #endif STATIC void -init_lexer(void) +S_init_lexer(pTHX) { #ifdef PERL_OBJECT PerlIO *tmpfp; @@ -2440,17 +2589,17 @@ init_lexer(void) PL_rsfp = Nullfp; lex_start(PL_linestr); PL_rsfp = tmpfp; - PL_subname = newSVpv("main",4); + PL_subname = newSVpvn("main",4); } STATIC void -init_predump_symbols(void) +S_init_predump_symbols(pTHX) { dTHR; GV *tmpgv; GV *othergv; - sv_setpvn(perl_get_sv("\"", TRUE), " ", 1); + sv_setpvn(get_sv("\"", TRUE), " ", 1); PL_stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO); GvMULTI_on(PL_stdingv); IoIFP(GvIOp(PL_stdingv)) = PerlIO_stdin(); @@ -2480,7 +2629,7 @@ init_predump_symbols(void) } STATIC void -init_postdump_symbols(register int argc, register char **argv, register char **env) +S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env) { dTHR; char *s; @@ -2568,7 +2717,7 @@ init_postdump_symbols(register int argc, register char **argv, register char **e } STATIC void -init_perllib(void) +S_init_perllib(pTHX) { char *s; if (!PL_tainting) { @@ -2639,7 +2788,7 @@ init_perllib(void) #endif STATIC void -incpush(char *p, int addsubdirs) +S_incpush(pTHX_ char *p, int addsubdirs) { SV *subdir = Nullsv; @@ -2655,8 +2804,8 @@ incpush(char *p, int addsubdirs) sprintf(PL_archpat_auto, "/%s/%s/auto", ARCHNAME, PL_patchlevel); #ifdef VMS for (len = sizeof(ARCHNAME) + 2; - archpat_auto[len] != '\0' && archpat_auto[len] != '/'; len++) - if (archpat_auto[len] == '.') archpat_auto[len] = '_'; + PL_archpat_auto[len] != '\0' && PL_archpat_auto[len] != '/'; len++) + if (PL_archpat_auto[len] == '.') PL_archpat_auto[len] = '_'; #endif } } @@ -2669,7 +2818,7 @@ incpush(char *p, int addsubdirs) /* skip any consecutive separators */ while ( *p == PERLLIB_SEP ) { /* Uncomment the next line for PATH semantics */ - /* av_push(GvAVn(incgv), newSVpv(".", 1)); */ + /* av_push(GvAVn(PL_incgv), newSVpvn(".", 1)); */ p++; } @@ -2693,7 +2842,7 @@ incpush(char *p, int addsubdirs) char *unix; STRLEN len; - if ((unix = tounixspec_ts(SvPV(libdir,na),Nullch)) != Nullch) { + if ((unix = tounixspec_ts(SvPV(libdir,len),Nullch)) != Nullch) { len = strlen(unix); while (unix[len-1] == '/') len--; /* Cosmetic */ sv_usepvn(libdir,unix,len); @@ -2701,7 +2850,7 @@ incpush(char *p, int addsubdirs) else PerlIO_printf(PerlIO_stderr(), "Failed to unixify @INC element \"%s\"\n", - SvPV(libdir,na)); + SvPV(libdir,len)); #endif /* .../archname/version if -d .../archname/version/auto */ sv_setsv(subdir, libdir); @@ -2709,7 +2858,7 @@ incpush(char *p, int addsubdirs) if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode)) av_push(GvAVn(PL_incgv), - newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto")); + newSVpvn(SvPVX(subdir), SvCUR(subdir) - sizeof "auto")); /* .../archname if -d .../archname/auto */ sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME), @@ -2717,7 +2866,7 @@ incpush(char *p, int addsubdirs) if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode)) av_push(GvAVn(PL_incgv), - newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto")); + newSVpvn(SvPVX(subdir), SvCUR(subdir) - sizeof "auto")); } /* finally push this lib directory on the end of @INC */ @@ -2727,13 +2876,15 @@ incpush(char *p, int addsubdirs) #ifdef USE_THREADS STATIC struct perl_thread * -init_main_thread() +S_init_main_thread(pTHX) { +#ifndef PERL_IMPLICIT_CONTEXT struct perl_thread *thr; +#endif XPV *xpv; Newz(53, thr, 1, struct perl_thread); - curcop = &compiling; + PL_curcop = &PL_compiling; thr->cvcache = newHV(); thr->threadsv = newAV(); /* thr->threadsvp is set when find_threadsv is called */ @@ -2742,27 +2893,28 @@ init_main_thread() thr->flags = THRf_R_JOINABLE; MUTEX_INIT(&thr->mutex); /* Handcraft thrsv similarly to mess_sv */ - New(53, thrsv, 1, SV); + New(53, PL_thrsv, 1, SV); Newz(53, xpv, 1, XPV); - SvFLAGS(thrsv) = SVt_PV; - SvANY(thrsv) = (void*)xpv; - SvREFCNT(thrsv) = 1 << 30; /* practically infinite */ - SvPVX(thrsv) = (char*)thr; - SvCUR_set(thrsv, sizeof(thr)); - SvLEN_set(thrsv, sizeof(thr)); - *SvEND(thrsv) = '\0'; /* in the trailing_nul field */ - thr->oursv = thrsv; - chopset = " \n-"; - - MUTEX_LOCK(&threads_mutex); - nthreads++; + 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; - MUTEX_UNLOCK(&threads_mutex); + MUTEX_UNLOCK(&PL_threads_mutex); #ifdef HAVE_THREAD_INTERN - init_thread_intern(thr); + Perl_init_thread_intern(thr); #endif #ifdef SET_THREAD_SELF @@ -2776,59 +2928,53 @@ init_main_thread() * These must come after the SET_THR because sv_setpvn does * SvTAINT and the taint fields require dTHR. */ - toptarget = NEWSV(0,0); - sv_upgrade(toptarget, SVt_PVFM); - sv_setpvn(toptarget, "", 0); - bodytarget = NEWSV(0,0); - sv_upgrade(bodytarget, SVt_PVFM); - sv_setpvn(bodytarget, "", 0); - formtarget = bodytarget; - thr->errsv = newSVpv("", 0); + 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 */ - maxscream = -1; - regcompp = FUNC_NAME_TO_PTR(pregcomp); - regexecp = FUNC_NAME_TO_PTR(regexec_flags); - regindent = 0; - reginterp_cnt = 0; + PL_maxscream = -1; + PL_regcompp = FUNC_NAME_TO_PTR(Perl_pregcomp); + PL_regexecp = FUNC_NAME_TO_PTR(Perl_regexec_flags); + PL_regindent = 0; + PL_reginterp_cnt = 0; return thr; } #endif /* USE_THREADS */ void -call_list(I32 oldscope, AV *paramList) +Perl_call_list(pTHX_ I32 oldscope, AV *paramList) { dTHR; + SV *atsv = ERRSV; line_t oldline = PL_curcop->cop_line; + CV *cv; STRLEN len; - dJMPENV; int ret; while (AvFILL(paramList) >= 0) { - CV *cv = (CV*)av_shift(paramList); - + cv = (CV*)av_shift(paramList); SAVEFREESV(cv); - - JMPENV_PUSH(ret); + CALLPROTECT(aTHX_ &ret, FUNC_NAME_TO_PTR(S_call_list_body), cv); switch (ret) { - case 0: { - SV* atsv = ERRSV; - PUSHMARK(PL_stack_sp); - perl_call_sv((SV*)cv, G_EVAL|G_DISCARD); - (void)SvPV(atsv, len); - if (len) { - JMPENV_POP; - PL_curcop = &PL_compiling; - PL_curcop->cop_line = oldline; - if (paramList == PL_beginav) - sv_catpv(atsv, "BEGIN failed--compilation aborted"); - else - sv_catpv(atsv, "END failed--cleanup aborted"); - while (PL_scopestack_ix > oldscope) - LEAVE; - croak("%s", SvPVX(atsv)); - } + case 0: + (void)SvPV(atsv, len); + if (len) { + PL_curcop = &PL_compiling; + PL_curcop->cop_line = oldline; + if (paramList == PL_beginav) + sv_catpv(atsv, "BEGIN failed--compilation aborted"); + else + sv_catpv(atsv, "END failed--cleanup aborted"); + while (PL_scopestack_ix > oldscope) + LEAVE; + Perl_croak(aTHX_ "%s", SvPVX(atsv)); } break; case 1: @@ -2842,41 +2988,47 @@ call_list(I32 oldscope, AV *paramList) PL_curstash = PL_defstash; if (PL_endav) call_list(oldscope, PL_endav); - JMPENV_POP; PL_curcop = &PL_compiling; PL_curcop->cop_line = oldline; if (PL_statusvalue) { if (paramList == PL_beginav) - croak("BEGIN failed--compilation aborted"); + Perl_croak(aTHX_ "BEGIN failed--compilation aborted"); else - croak("END failed--cleanup aborted"); + Perl_croak(aTHX_ "END failed--cleanup aborted"); } my_exit_jump(); /* NOTREACHED */ case 3: - if (!PL_restartop) { - PerlIO_printf(PerlIO_stderr(), "panic: restartop\n"); - FREETMPS; - break; + if (PL_restartop) { + PL_curcop = &PL_compiling; + PL_curcop->cop_line = oldline; + JMPENV_JUMP(3); } - JMPENV_POP; - PL_curcop = &PL_compiling; - PL_curcop->cop_line = oldline; - JMPENV_JUMP(3); + PerlIO_printf(PerlIO_stderr(), "panic: restartop\n"); + FREETMPS; + break; } - JMPENV_POP; } } +STATIC void * +S_call_list_body(pTHX_ va_list args) +{ + dTHR; + CV *cv = va_arg(args, CV*); + + PUSHMARK(PL_stack_sp); + call_sv((SV*)cv, G_EVAL|G_DISCARD); + return NULL; +} + void -my_exit(U32 status) +Perl_my_exit(pTHX_ U32 status) { dTHR; -#ifdef USE_THREADS - DEBUG_L(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n", + DEBUG_S(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n", thr, (unsigned long) status)); -#endif /* USE_THREADS */ switch (status) { case 0: STATUS_ALL_SUCCESS; @@ -2892,7 +3044,7 @@ my_exit(U32 status) } void -my_failure_exit(void) +Perl_my_failure_exit(pTHX) { #ifdef VMS if (vaxc$errno & 1) { @@ -2921,9 +3073,9 @@ my_failure_exit(void) } STATIC void -my_exit_jump(void) +S_my_exit_jump(pTHX) { - dSP; + dTHR; register PERL_CONTEXT *cx; I32 gimme; SV **newsp; @@ -2944,22 +3096,23 @@ my_exit_jump(void) JMPENV_JUMP(2); } +#ifdef PERL_OBJECT +#define NO_XSLOCKS +#endif /* PERL_OBJECT */ #include "XSUB.h" static I32 -#ifdef PERL_OBJECT -read_e_script(CPerlObj *pPerl, int idx, SV *buf_sv, int maxlen) -#else -read_e_script(int idx, SV *buf_sv, int maxlen) -#endif +read_e_script(pTHXo_ 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) + 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;