diff options
Diffstat (limited to 'contrib/perl5/perl.c')
| -rw-r--r-- | contrib/perl5/perl.c | 1875 |
1 files changed, 1247 insertions, 628 deletions
diff --git a/contrib/perl5/perl.c b/contrib/perl5/perl.c index cc1f7ed..578fafc 100644 --- a/contrib/perl5/perl.c +++ b/contrib/perl5/perl.c @@ -1,6 +1,6 @@ /* perl.c * - * Copyright (c) 1987-1999 Larry Wall + * Copyright (c) 1987-2000 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,9 @@ */ #include "EXTERN.h" +#define PERL_IN_PERL_C #include "perl.h" -#include "patchlevel.h" +#include "patchlevel.h" /* for local_patches */ /* XXX If this causes problems, set i_unistd=undef in the hint file. */ #ifdef I_UNISTD @@ -21,15 +22,10 @@ #endif #if !defined(STANDARD_C) && !defined(HAS_GETENV_PROTOTYPE) -char *getenv _((char *)); /* Usually in <stdlib.h> */ +char *getenv (char *); /* Usually in <stdlib.h> */ #endif -#ifdef I_FCNTL -#include <fcntl.h> -#endif -#ifdef I_SYS_FILE -#include <sys/file.h> -#endif +static I32 read_e_script(pTHXo_ int idx, SV *buf_sv, int maxlen); #ifdef IAMSUID #ifndef DOSUID @@ -44,92 +40,133 @@ char *getenv _((char *)); /* Usually in <stdlib.h> */ #endif #ifdef PERL_OBJECT -static I32 read_e_script _((CPerlObj* pPerl, int idx, SV *buf_sv, int maxlen)); +#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 -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 *)); -#ifdef IAMSUID -static int fd_on_nosuid_fs _((int)); -#endif -static void validate_suid _((char *, char*, int)); -static I32 read_e_script _((int idx, SV *buf_sv, int maxlen)); +# 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_OBJECT -CPerlObj* perl_alloc(IPerlMem* ipM, IPerlEnv* ipE, IPerlStdIO* ipStd, - IPerlLIO* ipLIO, IPerlDir* ipD, IPerlSock* ipS, IPerlProc* ipP) +#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) { - CPerlObj* pPerl = new(ipM) CPerlObj(ipM, ipE, ipStd, ipLIO, ipD, ipS, ipP); - if(pPerl != NULL) - pPerl->Init(); - - return pPerl; + 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 + +/* +=for apidoc perl_alloc + +Allocates a new Perl interpreter. See L<perlembed>. + +=cut +*/ + PerlInterpreter * perl_alloc(void) { - PerlInterpreter *sv_interp; + PerlInterpreter *my_perl; + + /* New() needs interpreter, so call malloc() instead */ + my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter)); - PL_curinterp = 0; - New(53, sv_interp, 1, PerlInterpreter); - return sv_interp; + INIT_TLS_AND_INTERP; + Zero(my_perl, 1, PerlInterpreter); + return my_perl; } -#endif /* PERL_OBJECT */ +#endif /* PERL_IMPLICIT_SYS */ + +/* +=for apidoc perl_construct + +Initializes a new Perl interpreter. See L<perlembed>. + +=cut +*/ void -#ifdef PERL_OBJECT -CPerlObj::perl_construct(void) -#else -perl_construct(register PerlInterpreter *sv_interp) -#endif +perl_construct(pTHXx) { #ifdef USE_THREADS int i; #ifndef FAKE_THREADS - struct perl_thread *thr; + struct perl_thread *thr = NULL; #endif /* FAKE_THREADS */ #endif /* USE_THREADS */ - -#ifndef PERL_OBJECT - if (!(PL_curinterp = sv_interp)) - return; -#endif #ifdef MULTIPLICITY - ++PL_ninterps; - Zero(sv_interp, 1, PerlInterpreter); + 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 - - INIT_THREADS; -#ifdef ALLOC_THREAD_KEY - ALLOC_THREAD_KEY; -#else - if (pthread_key_create(&PL_thr_key, 0)) - croak("panic: pthread_key_create"); -#endif MUTEX_INIT(&PL_sv_mutex); - MUTEX_INIT(&PL_cred_mutex); /* * Safe to use basic SV functions from now on (though * not things like mortals or tainting yet). @@ -138,13 +175,21 @@ perl_construct(register PerlInterpreter *sv_interp) COND_INIT(&PL_eval_cond); MUTEX_INIT(&PL_threads_mutex); COND_INIT(&PL_nthreads_cond); -#ifdef EMULATE_ATOMIC_REFCOUNTS +# ifdef EMULATE_ATOMIC_REFCOUNTS MUTEX_INIT(&PL_svref_mutex); -#endif /* EMULATE_ATOMIC_REFCOUNTS */ +# endif /* EMULATE_ATOMIC_REFCOUNTS */ + MUTEX_INIT(&PL_cred_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); @@ -170,7 +215,7 @@ perl_construct(register PerlInterpreter *sv_interp) /* TODO: */ /* PL_sighandlerp = sighandler; */ #else - PL_sighandlerp = sighandler; + PL_sighandlerp = Perl_sighandler; #endif PL_pidstatus = newHV(); @@ -185,36 +230,43 @@ 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); -#ifdef MULTIPLICITY - init_interp(); - PL_perl_destruct_level = 1; -#else - if (PL_perl_destruct_level > 0) - init_interp(); -#endif + init_stacks(); 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)); -#else - sprintf(PL_patchlevel, "%5.3f", (double) 5 + - ((double) PATCHLEVEL / (double) 1000)); -#endif + + { + 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 */ @@ -225,20 +277,19 @@ perl_construct(register PerlInterpreter *sv_interp) PL_fdpid = newAV(); /* for remembering popen pids by fd */ PL_modglobal = newHV(); /* pointers to per-interpreter module globals */ - DEBUG( { - New(51,PL_debname,128,char); - New(52,PL_debdelim,128,char); - } ) - ENTER; } +/* +=for apidoc perl_destruct + +Shuts down a Perl interpreter. See L<perlembed>. + +=cut +*/ + 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 */ @@ -246,19 +297,18 @@ 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)) - return; -#endif + /* 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(PerlIO_stderr(), + 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) { @@ -266,7 +316,7 @@ perl_destruct(register PerlInterpreter *sv_interp) switch (ThrSTATE(t)) { AV *av; case THRf_ZOMBIE: - DEBUG_S(PerlIO_printf(PerlIO_stderr(), + DEBUG_S(PerlIO_printf(Perl_debug_log, "perl_destruct: joining zombie %p\n", t)); ThrSETSTATE(t, THRf_DEAD); MUTEX_UNLOCK(&t->mutex); @@ -280,11 +330,11 @@ perl_destruct(register PerlInterpreter *sv_interp) MUTEX_UNLOCK(&PL_threads_mutex); JOIN(t, &av); SvREFCNT_dec((SV*)av); - DEBUG_S(PerlIO_printf(PerlIO_stderr(), + 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(PerlIO_stderr(), + DEBUG_S(PerlIO_printf(Perl_debug_log, "perl_destruct: detaching thread %p\n", t)); ThrSETSTATE(t, THRf_R_DETACHED); /* @@ -298,7 +348,7 @@ perl_destruct(register PerlInterpreter *sv_interp) MUTEX_UNLOCK(&t->mutex); goto retry_cleanup; default: - DEBUG_S(PerlIO_printf(PerlIO_stderr(), + DEBUG_S(PerlIO_printf(Perl_debug_log, "perl_destruct: ignoring %p (state %u)\n", t, ThrSTATE(t))); MUTEX_UNLOCK(&t->mutex); @@ -310,14 +360,14 @@ perl_destruct(register PerlInterpreter *sv_interp) /* Pass 2 on remaining threads: wait for the thread count to drop to one */ while (PL_nthreads > 1) { - DEBUG_S(PerlIO_printf(PerlIO_stderr(), + 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(PerlIO_stderr(), "perl_destruct: armageddon has arrived\n")); + DEBUG_S(PerlIO_printf(Perl_debug_log, "perl_destruct: armageddon has arrived\n")); MUTEX_DESTROY(&PL_threads_mutex); COND_DESTROY(&PL_nthreads_cond); #endif /* !defined(FAKE_THREADS) */ @@ -327,7 +377,7 @@ perl_destruct(register PerlInterpreter *sv_interp) #ifdef DEBUGGING { char *s; - if (s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL")) { + if ((s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL"))) { int i = atoi(s); if (destruct_level < i) destruct_level = i; @@ -338,10 +388,6 @@ perl_destruct(register PerlInterpreter *sv_interp) LEAVE; FREETMPS; -#ifdef MULTIPLICITY - --PL_ninterps; -#endif - /* We must account for everything. */ /* Destroy the main CV and syntax tree */ @@ -354,6 +400,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) { /* @@ -361,8 +408,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(); } @@ -371,12 +416,10 @@ perl_destruct(register PerlInterpreter *sv_interp) PL_warnhook = Nullsv; SvREFCNT_dec(PL_diehook); PL_diehook = Nullsv; - SvREFCNT_dec(PL_parsehook); - PL_parsehook = Nullsv; /* 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); @@ -407,15 +450,14 @@ 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 */ - PL_sawvec = FALSE; PL_unsafe = FALSE; Safefree(PL_inplace); PL_inplace = Nullch; + SvREFCNT_dec(PL_patchlevel); if (PL_e_script) { SvREFCNT_dec(PL_e_script); @@ -424,10 +466,10 @@ perl_destruct(register PerlInterpreter *sv_interp) /* magical thingies */ - Safefree(PL_ofs); /* $, */ + Safefree(PL_ofs); /* $, */ PL_ofs = Nullch; - Safefree(PL_ors); /* $\ */ + Safefree(PL_ors); /* $\ */ PL_ors = Nullch; SvREFCNT_dec(PL_rs); /* $/ */ @@ -436,7 +478,9 @@ perl_destruct(register PerlInterpreter *sv_interp) SvREFCNT_dec(PL_nrs); /* $/ helper */ PL_nrs = Nullsv; - PL_multiline = 0; /* $* */ + PL_multiline = 0; /* $* */ + Safefree(PL_osname); /* $^O */ + PL_osname = Nullch; SvREFCNT_dec(PL_statname); PL_statname = Nullsv; @@ -452,61 +496,157 @@ perl_destruct(register PerlInterpreter *sv_interp) 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_siggv = 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; +#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; +#ifndef USE_ITHREADS + SvREFCNT_dec(CopFILEGV(&PL_compiling)); + CopFILEGV_set(&PL_compiling, Nullgv); +#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) { + if (destruct_level >= 2 && ckWARN_d(WARN_INTERNAL)) { if (PL_scopestack_ix != 0) - warn("Unbalanced scopes: %ld more ENTERs than LEAVEs\n", + Perl_warner(aTHX_ WARN_INTERNAL, + "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_warner(aTHX_ WARN_INTERNAL, + "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_warner(aTHX_ WARN_INTERNAL,"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_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. */ last_sv_count = 0; + SvFLAGS(PL_fdpid) |= SVTYPEMASK; /* don't clean out pid table now */ SvFLAGS(PL_strtab) |= SVTYPEMASK; /* don't clean out strtab now */ while (PL_sv_count != 0 && PL_sv_count != last_sv_count) { last_sv_count = PL_sv_count; 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; + /* Destruct the global string table. */ { /* Yell and reset the HeVAL() slots that are still holding refcounts, @@ -522,8 +662,9 @@ perl_destruct(register PerlInterpreter *sv_interp) array = HvARRAY(PL_strtab); hent = array[0]; for (;;) { - if (hent) { - warn("Unbalanced string table refcount: (%d) for \"%s\"", + 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); @@ -537,17 +678,32 @@ perl_destruct(register PerlInterpreter *sv_interp) } SvREFCNT_dec(PL_strtab); - if (PL_sv_count != 0) - warn("Scalars leaked: %ld\n", (long)PL_sv_count); + /* 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); sv_free_arenas(); /* No SVs have survived, need to clean out */ - PL_linestr = NULL; - PL_pidstatus = Nullhv; Safefree(PL_origfilename); - Safefree(PL_archpat_auto); 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); nuke_stacks(); @@ -557,8 +713,8 @@ perl_destruct(register PerlInterpreter *sv_interp) #ifdef USE_THREADS MUTEX_DESTROY(&PL_strtab_mutex); MUTEX_DESTROY(&PL_sv_mutex); - MUTEX_DESTROY(&PL_cred_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); @@ -570,7 +726,7 @@ perl_destruct(register PerlInterpreter *sv_interp) 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) { @@ -586,7 +742,7 @@ perl_destruct(register PerlInterpreter *sv_interp) } } /* we know that type >= SVt_PV */ - SvOOK_off(PL_mess_sv); + (void)SvOOK_off(PL_mess_sv); Safefree(SvPVX(PL_mess_sv)); Safefree(SvANY(PL_mess_sv)); Safefree(PL_mess_sv); @@ -594,28 +750,32 @@ perl_destruct(register PerlInterpreter *sv_interp) } } +/* +=for apidoc perl_free + +Releases a Perl interpreter. See L<perlembed>. + +=cut +*/ + void -#ifdef PERL_OBJECT -CPerlObj::perl_free(void) -#else -perl_free(PerlInterpreter *sv_interp) -#endif +perl_free(pTHXx) { -#ifdef PERL_OBJECT - Safefree(this); +#if defined(PERL_OBJECT) + PerlMem_free(this); #else - if (!(PL_curinterp = sv_interp)) - return; - Safefree(sv_interp); +# 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 } 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; @@ -623,39 +783,34 @@ perl_atexit(void (*fn) (void *), void *ptr) ++PL_exitlistlen; } +/* +=for apidoc perl_parse + +Tells a Perl interpreter to parse a Perl script. See L<perlembed>. + +=cut +*/ + 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; + dJMPENV; +#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)) - 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 */ @@ -689,9 +844,22 @@ setuid perl scripts securely.\n"); 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 */ @@ -701,18 +869,47 @@ setuid perl scripts securely.\n"); LEAVE; FREETMPS; PL_curstash = PL_defstash; - if (PL_endav) - call_list(oldscope, PL_endav); - JMPENV_POP; - return STATUS_NATIVE_EXPORT; + if (PL_checkav) + call_list(oldscope, PL_checkav); + ret = STATUS_NATIVE_EXPORT; + break; case 3: - JMPENV_POP; - PerlIO_printf(PerlIO_stderr(), "panic: top_env\n"); - return 1; + 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) +{ + dTHR; + 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 = newSVpv("",0); /* first used for -I flags */ + sv = newSVpvn("",0); /* first used for -I flags */ SAVEFREESV(sv); init_main_stash(); @@ -728,6 +925,11 @@ setuid perl scripts securely.\n"); 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 @@ -749,8 +951,10 @@ setuid perl scripts securely.\n"); case 'u': case 'U': case 'v': + case 'W': + case 'X': case 'w': - if (s = moreswitches(s)) + if ((s = moreswitches(s))) goto reswitch; break; @@ -761,9 +965,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) @@ -773,7 +977,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; @@ -782,18 +986,18 @@ setuid perl scripts securely.\n"); if (!*++s && (s=argv[1]) != Nullch) { argc--,argv++; } - while (s && isSPACE(*s)) - ++s; if (s && *s) { - char *e, *p; - for (e = s; *e && !isSPACE(*e); e++) ; - p = savepvn(s, e-s); - incpush(p, TRUE); - sv_catpv(sv,"-I"); - sv_catpv(sv,p); - sv_catpv(sv," "); + 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); - } /* XXX else croak? */ + } + else + Perl_croak(aTHX_ "No directory specified for -I"); break; case 'P': forbid_setid("-P"); @@ -816,35 +1020,61 @@ setuid perl scripts securely.\n"); #else sv_catpv(PL_Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\","); #endif -#if defined(DEBUGGING) || defined(NO_EMBED) || defined(MULTIPLICITY) sv_catpv(PL_Sv,"\" Compile-time options:"); # ifdef DEBUGGING sv_catpv(PL_Sv," DEBUGGING"); # endif -# ifdef NO_EMBED - sv_catpv(PL_Sv," NO_EMBED"); -# 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\","); -#endif + #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]) - 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(PL_Sv,",\" Compiled on %s\\n\"",__DATE__); + Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled on %s\\n\"",__DATE__); # endif #endif sv_catpv(PL_Sv, "; \ @@ -866,7 +1096,7 @@ print \" \\@INC:\\n @INC\\n\";"); PL_doextract = TRUE; s++; if (*s) - PL_cddir = savepv(s); + cddir = s; break; case 0: break; @@ -887,25 +1117,36 @@ 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); } } @@ -929,8 +1170,27 @@ print \" \\@INC:\\n @INC\\n\";"); validate_suid(validarg, scriptname,fdscript); - if (PL_doextract) +#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 + + if (PL_doextract) { 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); @@ -944,7 +1204,7 @@ print \" \\@INC:\\n @INC\\n\";"); PL_min_intro_pending = 0; PL_padix = 0; #ifdef USE_THREADS - av_store(PL_comppad_name, 0, newSVpv("@_", 2)); + av_store(PL_comppad_name, 0, newSVpvn("@_", 2)); PL_curpad[0] = (SV*)newAV(); SvPADMY_on(PL_curpad[0]); /* XXX Needed? */ CvOWNER(PL_compcv) = 0; @@ -959,13 +1219,20 @@ print \" \\@INC:\\n @INC\\n\";"); CvPADLIST(PL_compcv) = comppadlist; boot_core_UNIVERSAL(); +#ifndef PERL_MICRO + boot_core_xsutils(); +#endif if (xsinit) - (*xsinit)(PERL_OBJECT_THIS); /* in case linked C routines want magical variables */ -#if defined(VMS) || defined(WIN32) || defined(DJGPP) + (*xsinit)(aTHXo); /* in case linked C routines want magical variables */ +#if defined(VMS) || defined(WIN32) || defined(DJGPP) || defined(__CYGWIN__) init_os_extras(); #endif +#ifdef USE_SOCKS + SOCKSinit(argv[0]); +#endif + init_predump_symbols(); /* init_postdump_symbols not currently designed to be called */ /* more than once (ENV isn't cleared first, for example) */ @@ -981,13 +1248,13 @@ 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; + CopLINE_set(PL_curcop, 0); PL_curstash = PL_defstash; PL_preprocess = FALSE; if (PL_e_script) { @@ -998,12 +1265,15 @@ 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 (isWARN_ONCE) { + SAVECOPFILE(PL_curcop); + SAVECOPLINE(PL_curcop); gv_check(PL_defstash); + } LEAVE; FREETMPS; @@ -1015,74 +1285,105 @@ print \" \\@INC:\\n @INC\\n\";"); ENTER; PL_restartop = 0; - JMPENV_POP; - return 0; + return NULL; } +/* +=for apidoc perl_run + +Tells a Perl interpreter to run. See L<perlembed>. + +=cut +*/ + int -#ifdef PERL_OBJECT -CPerlObj::perl_run(void) -#else -perl_run(PerlInterpreter *sv_interp) -#endif +perl_run(pTHXx) { - dSP; + dTHR; I32 oldscope; + int ret = 0; dJMPENV; - int ret; - -#ifndef PERL_OBJECT - if (!(PL_curinterp = sv_interp)) - return 255; +#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 */ - break; - case 2: - /* my_exit() was called */ + 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) + if (PL_endav && !PL_minus_c) call_list(oldscope, PL_endav); #ifdef MYMALLOC if (PerlEnv_getenv("PERL_DEBUG_MSTATS")) dump_mstats("after execution: "); #endif - JMPENV_POP; - return STATUS_NATIVE_EXPORT; + ret = STATUS_NATIVE_EXPORT; + break; 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); + 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) +{ + dTHR; + 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%lx\n", - (unsigned long) thr)); + DEBUG_S(PerlIO_printf(Perl_debug_log, "main thread is 0x%"UVxf"\n", + PTR2UV(thr))); if (PL_minus_c) { - PerlIO_printf(PerlIO_stderr(), "%s syntax OK\n", PL_origfilename); + PerlIO_printf(Perl_error_log, "%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); } @@ -1092,21 +1393,31 @@ perl_run(PerlInterpreter *sv_interp) if (PL_restartop) { PL_op = PL_restartop; PL_restartop = 0; - CALLRUNOPS(); + CALLRUNOPS(aTHX); } else if (PL_main_start) { CvDEPTH(PL_main_cv) = 1; PL_op = PL_main_start; - CALLRUNOPS(); + CALLRUNOPS(aTHX); } my_exit(0); /* NOTREACHED */ - return 0; + return NULL; } +/* +=for apidoc p||get_sv + +Returns the SV of the specified Perl scalar. If C<create> is set and the +Perl variable does not exist then it will be created. If C<create> is not +set and the variable does not exist then NULL is returned. + +=cut +*/ + SV* -perl_get_sv(char *name, I32 create) +Perl_get_sv(pTHX_ const char *name, I32 create) { GV *gv; #ifdef USE_THREADS @@ -1124,8 +1435,18 @@ perl_get_sv(char *name, I32 create) return Nullsv; } +/* +=for apidoc p||get_av + +Returns the AV of the specified Perl array. If C<create> is set and the +Perl variable does not exist then it will be created. If C<create> is not +set and the variable does not exist then NULL is returned. + +=cut +*/ + AV* -perl_get_av(char *name, I32 create) +Perl_get_av(pTHX_ const char *name, I32 create) { GV* gv = gv_fetchpv(name, create, SVt_PVAV); if (create) @@ -1135,8 +1456,18 @@ perl_get_av(char *name, I32 create) return Nullav; } +/* +=for apidoc p||get_hv + +Returns the HV of the specified Perl hash. If C<create> is set and the +Perl variable does not exist then it will be created. If C<create> is not +set and the variable does not exist then NULL is returned. + +=cut +*/ + HV* -perl_get_hv(char *name, I32 create) +Perl_get_hv(pTHX_ const char *name, I32 create) { GV* gv = gv_fetchpv(name, create, SVt_PVHV); if (create) @@ -1146,11 +1477,25 @@ perl_get_hv(char *name, I32 create) return Nullhv; } +/* +=for apidoc p||get_cv + +Returns the CV of the specified Perl subroutine. If C<create> is set and +the Perl subroutine does not exist then it will be declared (which has the +same effect as saying C<sub name;>). If C<create> is not set and the +subroutine does not exist then NULL is returned. + +=cut +*/ + CV* -perl_get_cv(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)), @@ -1163,8 +1508,16 @@ perl_get_cv(char *name, I32 create) /* Be sure to refetch the stack pointer after calling these routines. */ +/* +=for apidoc p||call_argv + +Performs a callback to the specified Perl sub. See L<perlcall>. + +=cut +*/ + I32 -perl_call_argv(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 */ @@ -1179,37 +1532,65 @@ 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); } +/* +=for apidoc p||call_pv + +Performs a callback to the specified Perl sub. See L<perlcall>. + +=cut +*/ + 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); } +/* +=for apidoc p||call_method + +Performs a callback to the specified Perl method. The blessed object must +be on the stack. See L<perlcall>. + +=cut +*/ + I32 -perl_call_method(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 (!PL_op) + if (!PL_op) { + Zero(&myop, 1, OP); PL_op = &myop; + } XPUSHs(sv_2mortal(newSVpv(methname,0))); PUTBACK; - pp_method(ARGS); - if(PL_op == &myop) - PL_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. */ +/* +=for apidoc p||call_sv + +Performs a callback to the Perl sub whose name is in the SV. See +L<perlcall>. + +=cut +*/ + I32 -perl_call_sv(SV *sv, I32 flags) +Perl_call_sv(pTHX_ SV *sv, I32 flags) /* See G_* flags in cop.h */ { @@ -1219,9 +1600,9 @@ perl_call_sv(SV *sv, I32 flags) I32 retval; I32 oldscope; bool oldcatch = CATCH_GET; - dJMPENV; int ret; OP* oldop = PL_op; + dJMPENV; if (flags & G_DISCARD) { ENTER; @@ -1252,7 +1633,13 @@ perl_call_sv(SV *sv, I32 flags) && !(flags & G_NODEBUG)) PL_op->op_private |= OPpENTERSUB_DB; - if (flags & G_EVAL) { + if (!(flags & G_EVAL)) { + CATCH_SET(TRUE); + call_body((OP*)&myop, FALSE); + retval = PL_stack_sp - (PL_stack_base + oldmark); + CATCH_SET(oldcatch); + } + else { cLOGOP->op_other = PL_op; PL_markstack_ptr--; /* we're trying to emulate pp_entertry() here */ @@ -1264,21 +1651,34 @@ perl_call_sv(SV *sv, I32 flags) SAVETMPS; push_return(PL_op->op_next); - PUSHBLOCK(cx, CXt_EVAL, PL_stack_sp); + 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 = 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++; +#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; @@ -1288,15 +1688,15 @@ perl_call_sv(SV *sv, I32 flags) PL_curstash = PL_defstash; FREETMPS; JMPENV_POP; - if (PL_statusvalue) - croak("Callback called exit"); + 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; - break; + goto redo_body; } PL_stack_sp = PL_stack_base + oldmark; if (flags & G_ARRAY) @@ -1305,22 +1705,9 @@ perl_call_sv(SV *sv, I32 flags) retval = 1; *++PL_stack_sp = &PL_sv_undef; } - goto cleanup; + break; } - } - else - CATCH_SET(TRUE); - - if (PL_op == (OP*)&myop) - PL_op = pp_entersub(ARGS); - if (PL_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; @@ -1336,8 +1723,6 @@ perl_call_sv(SV *sv, I32 flags) } JMPENV_POP; } - else - CATCH_SET(oldcatch); if (flags & G_DISCARD) { PL_stack_sp = PL_stack_base + oldmark; @@ -1349,10 +1734,45 @@ perl_call_sv(SV *sv, I32 flags) 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) +{ + 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. */ +/* +=for apidoc p||eval_sv + +Tells Perl to C<eval> the string in the SV. + +=cut +*/ + I32 -perl_eval_sv(SV *sv, I32 flags) +Perl_eval_sv(pTHX_ SV *sv, I32 flags) /* See G_* flags in cop.h */ { @@ -1361,9 +1781,9 @@ perl_eval_sv(SV *sv, I32 flags) I32 oldmark = SP - PL_stack_base; I32 retval; I32 oldscope; - dJMPENV; int ret; OP* oldop = PL_op; + dJMPENV; if (flags & G_DISCARD) { ENTER; @@ -1387,9 +1807,22 @@ perl_eval_sv(SV *sv, I32 flags) 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; @@ -1399,15 +1832,15 @@ perl_eval_sv(SV *sv, I32 flags) PL_curstash = PL_defstash; FREETMPS; JMPENV_POP; - if (PL_statusvalue) - croak("Callback called exit"); + 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; - break; + goto redo_body; } PL_stack_sp = PL_stack_base + oldmark; if (flags & G_ARRAY) @@ -1416,18 +1849,9 @@ perl_eval_sv(SV *sv, I32 flags) retval = 1; *++PL_stack_sp = &PL_sv_undef; } - goto cleanup; + break; } - if (PL_op == (OP*)&myop) - PL_op = pp_entereval(ARGS); - if (PL_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; @@ -1439,14 +1863,22 @@ perl_eval_sv(SV *sv, I32 flags) return retval; } +/* +=for apidoc p||eval_pv + +Tells Perl to C<eval> the given string and return an SV* result. + +=cut +*/ + SV* -perl_eval_pv(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; @@ -1455,7 +1887,7 @@ perl_eval_pv(char *p, I32 croak_on_error) if (croak_on_error && SvTRUE(ERRSV)) { STRLEN n_a; - croak(SvPVx(ERRSV, n_a)); + Perl_croak(aTHX_ SvPVx(ERRSV, n_a)); } return sv; @@ -1463,8 +1895,16 @@ perl_eval_pv(char *p, I32 croak_on_error) /* Require a module. */ +/* +=for apidoc p||require_pv + +Tells Perl to C<require> a module. + +=cut +*/ + void -perl_require_pv(char *pv) +Perl_require_pv(pTHX_ const char *pv) { SV* sv; dSP; @@ -1474,23 +1914,22 @@ 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; - if (gv = gv_fetchpv(sym,TRUE, SVt_PV)) + if ((gv = gv_fetchpv(sym,TRUE, SVt_PV))) sv_magic(GvSV(gv), (SV*)gv, 0, name, 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? */ @@ -1498,26 +1937,29 @@ usage(char *name) /* XXX move this out into a module ? */ 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 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)", +"-W enable all warnings", +"-X disable all warnings", "-x[directory] strip off text before #!perl line and perhaps cd to directory", "\n", NULL @@ -1532,7 +1974,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; @@ -1541,18 +1983,22 @@ moreswitches(char *s) case '0': { dTHR; - rschar = scan_oct(s, 4, &numlen); + 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 = newSVpv("", 0); + PL_nrs = newSVpvn("", 0); else { char ch = rschar; - PL_nrs = newSVpv(&ch, 1); + 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); @@ -1570,7 +2016,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) { @@ -1579,6 +2025,7 @@ moreswitches(char *s) } return s; case 'D': + { #ifdef DEBUGGING forbid_setid("-D"); if (isALPHA(s[1])) { @@ -1594,11 +2041,15 @@ moreswitches(char *s) } PL_debug |= 0x80000000; #else - warn("Recompile perl with -DDEBUGGING to use -D switch\n"); + dTHR; + 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); @@ -1621,14 +2072,23 @@ moreswitches(char *s) ++s; if (*s) { char *e, *p; - for (e = s; *e && !isSPACE(*e); e++) ; - p = savepvn(s, e-s); - incpush(p, TRUE); - Safefree(p); - s = e; + 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 - croak("No space allowed after -I"); + Perl_croak(aTHX_ "No directory specified for -I"); return s; case 'l': PL_minus_l = TRUE; @@ -1638,7 +2098,7 @@ moreswitches(char *s) if (isDIGIT(*s)) { PL_ors = savepv("\n"); PL_orslen = 1; - *PL_ors = scan_oct(s, 3 + (*s == '0'), &numlen); + *PL_ors = (char)scan_oct(s, 3 + (*s == '0'), &numlen); s += numlen; } else { @@ -1671,7 +2131,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 { @@ -1681,12 +2141,12 @@ moreswitches(char *s) sv_catpv(sv, "})"); } s += strlen(s); - if (PL_preambleav == NULL) + if (!PL_preambleav) PL_preambleav = newAV(); 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; @@ -1703,7 +2163,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': @@ -1715,48 +2175,52 @@ 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); -#else - printf("\nThis is perl, version %s built for %s", - PL_patchlevel, ARCHNAME); -#endif + printf(Perl_form(aTHX_ "\nThis is perl, v%vd built for %s", + PL_patchlevel, ARCHNAME)); #if defined(LOCAL_PATCH_COUNT) if (LOCAL_PATCH_COUNT > 0) printf("\n(with %d registered patch%s, see perl -V for more detail)", - LOCAL_PATCH_COUNT, (LOCAL_PATCH_COUNT!=1) ? "es" : ""); + (int)LOCAL_PATCH_COUNT, (LOCAL_PATCH_COUNT!=1) ? "es" : ""); #endif - printf("\n\nCopyright 1987-1999, Larry Wall\n"); + printf("\n\nCopyright 1987-2000, 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-1998\n"); + 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\n"); + printf("MiNT port by Guido Flohr, 1997-1999\n"); +#endif +#ifdef EPOC + printf("EPOC port by Olaf Flebbe, 1999-2000\n"); #endif #ifdef BINARY_BUILD_NOTICE BINARY_BUILD_NOTICE; @@ -1769,7 +2233,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 = pWARN_ALL ; + s++; + return s; + case 'X': + PL_dowarn = G_WARN_ALL_OFF; + PL_compiling.cop_warnings = pWARN_NONE ; s++; return s; case '*': @@ -1794,7 +2269,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; } @@ -1805,7 +2280,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; @@ -1833,7 +2308,7 @@ my_unexec(void) /* initialize curinterp */ STATIC void -init_interp(void) +S_init_interp(pTHX) { #ifdef PERL_OBJECT /* XXX kludge */ @@ -1844,7 +2319,7 @@ init_interp(void) 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; \ @@ -1853,7 +2328,6 @@ init_interp(void) 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; \ @@ -1867,22 +2341,36 @@ init_interp(void) 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) PL_curinterp->var = init; -# define PERLVARIC(var,type,init) PL_curinterp->var = init; +# 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 +# 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" @@ -1890,6 +2378,7 @@ init_interp(void) # include "thrdvar.h" # endif # undef PERLVAR +# undef PERLVARA # undef PERLVARI # undef PERLVARIC # endif @@ -1898,7 +2387,7 @@ init_interp(void) } STATIC void -init_main_stash(void) +S_init_main_stash(pTHX) { dTHR; GV *gv; @@ -1914,7 +2403,7 @@ init_main_stash(void) 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); @@ -1929,22 +2418,21 @@ 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; - PL_compiling.cop_stash = 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)); /* We must init $/ before switches are processed. */ - sv_setpvn(perl_get_sv("/", TRUE), "\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; *fdscript = -1; @@ -1968,7 +2456,7 @@ open_script(char *scriptname, bool dosearch, SV *sv, int *fdscript) } } - PL_curcop->cop_filegv = gv_fetchfile(PL_origfilename); + CopFILE_set(PL_curcop, PL_origfilename); if (strEQ(PL_origfilename,"-")) scriptname = ""; if (*fdscript >= 0) { @@ -1980,18 +2468,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_catpvn(sv, "-I", 2); 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\" \ @@ -2003,10 +2491,11 @@ sed %s -e \"/^[^#]/b\" \ -e \"/^#[ ]*undef[ ]/b\" \ -e \"/^#[ ]*endif/b\" \ -e \"s/^#.*//\" \ - %s | %_ -C %_ %s", + %s | %"SVf" -C %"SVf" %s", (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' \ @@ -2018,7 +2507,22 @@ sed %s -e \"/^[^#]/b\" \ -e '/^#[ ]*undef[ ]/b' \ -e '/^#[ ]*endif/b' \ -e 's/^[ ]*#.*//' \ - %s | %_ -C %_ %s", + %s | %"SVf" %"SVf" %s", +# else + Perl_sv_setpvf(aTHX_ cmd, "\ +%s %s -e '/^[^#]/b' \ + -e '/^#[ ]*include[ ]/b' \ + -e '/^#[ ]*define[ ]/b' \ + -e '/^#[ ]*if[ ]/b' \ + -e '/^#[ ]*ifdef[ ]/b' \ + -e '/^#[ ]*ifndef[ ]/b' \ + -e '/^#[ ]*else/b' \ + -e '/^#[ ]*elif[ ]/b' \ + -e '/^#[ ]*undef[ ]/b' \ + -e '/^#[ ]*endif/b' \ + -e 's/^[ ]*#.*//' \ + %s | %"SVf" -C %"SVf" %s", +# endif #ifdef LOC_SED LOC_SED, #else @@ -2044,7 +2548,7 @@ sed %s -e \"/^[^#]/b\" \ #endif #endif if (PerlProc_geteuid() != PL_uid) - croak("Can't do seteuid!\n"); + Perl_croak(aTHX_ "Can't do seteuid!\n"); } #endif /* IAMSUID */ PL_rsfp = PerlProc_popen(SvPVX(cmd), "r"); @@ -2066,31 +2570,42 @@ sed %s -e \"/^[^#]/b\" \ #ifdef DOSUID #ifndef IAMSUID /* in case script is not readable before setuid */ if (PL_euid && - PerlLIO_stat(SvPVX(GvSV(PL_curcop->cop_filegv)),&PL_statbuf) >= 0 && + PerlLIO_stat(CopFILE(PL_curcop),&PL_statbuf) >= 0 && PL_statbuf.st_mode & (S_ISUID|S_ISGID)) { /* try again */ - PerlProc_execv(form("%s/sperl%s", BIN_EXP, PL_patchlevel), PL_origargv); - croak("Can't do setuid\n"); + 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 - croak("Can't open perl script \"%s\": %s\n", - SvPVX(GvSV(PL_curcop->cop_filegv)), Strerror(errno)); + Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n", + CopFILE(PL_curcop), Strerror(errno)); } } +/* Mention + * I_SYSSTATVFS HAS_FSTATVFS + * I_SYSMOUNT + * I_STATFS HAS_FSTATFS HAS_GETFSSTAT + * I_MNTENT HAS_GETMNTENT HAS_HASMNTOPT + * here so that metaconfig picks them up. */ + #ifdef IAMSUID -static int -fd_on_nosuid_fs(int fd) +STATIC int +S_fd_on_nosuid_fs(pTHX_ int fd) { - int on_nosuid = 0; - int check_okay = 0; + int check_okay = 0; /* able to do all the required sys/libcalls */ + int on_nosuid = 0; /* the fd is on a nosuid fs */ /* - * Preferred order: fstatvfs(), fstatfs(), getmntent(). + * Preferred order: fstatvfs(), fstatfs(), ustat()+getmnt(), getmntent(). * fstatvfs() is UNIX98. - * fstatfs() is BSD. - * getmntent() is O(number-of-mounted-filesystems) and can hang. + * fstatfs() is 4.3 BSD. + * ustat()+getmnt() is pre-4.3 BSD. + * getmntent() is O(number-of-mounted-filesystems) and can hang on + * an irrelevant filesystem while trying to reach the right one. */ # ifdef HAS_FSTATVFS @@ -2098,24 +2613,45 @@ fd_on_nosuid_fs(int fd) 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) +# ifdef PERL_MOUNT_NOSUID +# if defined(HAS_FSTATFS) && \ + defined(HAS_STRUCT_STATFS) && \ + defined(HAS_STRUCT_STATFS_F_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_FSTAT) && \ + defined(HAS_USTAT) && \ + defined(HAS_GETMNT) && \ + defined(HAS_STRUCT_FS_DATA) && \ + defined(NOSTAT_ONE) + struct stat fdst; + if (fstat(fd, &fdst) == 0) { + struct ustat us; + if (ustat(fdst.st_dev, &us) == 0) { + struct fs_data fsd; + /* NOSTAT_ONE here because we're not examining fields which + * vary between that case and STAT_ONE. */ + if (getmnt((int*)0, &fsd, (int)0, NOSTAT_ONE, us.f_fname) == 0) { + size_t cmplen = sizeof(us.f_fname); + if (sizeof(fsd.fd_req.path) < cmplen) + cmplen = sizeof(fsd.fd_req.path); + if (strnEQ(fsd.fd_req.path, us.f_fname, cmplen) && + fdst.st_dev == fsd.fd_req.dev) { + check_okay = 1; + on_nosuid = fsd.fd_req.flags & PERL_MOUNT_NOSUID; + } + } + } + } + } +# endif /* fstat+ustat+getmnt */ +# endif /* fstatfs */ # else -# if defined(HAS_GETMNTENT) && defined(HAS_HASMNTOPT) && defined(MNTOPT_NOSUID) +# if defined(HAS_GETMNTENT) && \ + defined(HAS_HASMNTOPT) && \ + defined(MNTOPT_NOSUID) FILE *mtab = fopen("/etc/mtab", "r"); struct mntent *entry; struct stat stb, fsb; @@ -2135,20 +2671,22 @@ fd_on_nosuid_fs(int fd) } if (mtab) fclose(mtab); -# endif /* mntent */ -# endif /* statfs */ +# endif /* getmntent+hasmntopt */ +# endif /* PERL_MOUNT_NOSUID: fstatfs or fstat+ustat+statfs */ # endif /* statvfs */ + if (!check_okay) - croak("Can't check filesystem of script \"%s\" for nosuid", - PL_origfilename); + Perl_croak(aTHX_ "Can't check filesystem of script \"%s\" for nosuid", 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) { +#ifdef IAMSUID int which; +#endif /* do we need to emulate setuid on scripts? */ @@ -2175,7 +2713,7 @@ validate_suid(char *validarg, char *scriptname, int fdscript) char *s, *s2; if (PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf) < 0) /* normal stat is insecure */ - croak("Can't stat script \"%s\"",PL_origfilename); + 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; @@ -2190,8 +2728,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(PL_curcop->cop_filegv)),1)) /*double check*/ - croak("Permission denied"); + if (PerlLIO_access(CopFILE(PL_curcop),1)) /*double check*/ + Perl_croak(aTHX_ "Permission denied"); #else /* If we can swap euid and uid, then we can determine access rights * with a simple stat of the file, and then compare device and @@ -2210,27 +2748,27 @@ validate_suid(char *validarg, char *scriptname, int fdscript) # endif #endif || PerlProc_getuid() != PL_euid || PerlProc_geteuid() != PL_uid) - croak("Can't swap uid and euid"); /* really paranoid */ - if (PerlLIO_stat(SvPVX(GvSV(PL_curcop->cop_filegv)),&tmpstatbuf) < 0) - croak("Permission denied"); /* testing full pathname here */ + Perl_croak(aTHX_ "Can't swap uid and euid"); /* really paranoid */ + if (PerlLIO_stat(CopFILE(PL_curcop),&tmpstatbuf) < 0) + Perl_croak(aTHX_ "Permission denied"); /* testing full pathname here */ #if defined(IAMSUID) && !defined(NO_NOSUID_CHECK) if (fd_on_nosuid_fs(PerlIO_fileno(PL_rsfp))) - croak("Permission denied"); + 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)PL_uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino, +"User %"Uid_t_f" tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\ +(Filename of set-id script was %s, uid %"Uid_t_f" gid %"Gid_t_f".)\n\nSincerely,\nperl\n", + 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); + CopFILE(PL_curcop), + PL_statbuf.st_uid, PL_statbuf.st_gid); (void)PerlProc_pclose(PL_rsfp); } - croak("Permission denied\n"); + Perl_croak(aTHX_ "Permission denied\n"); } if ( #ifdef HAS_SETREUID @@ -2241,29 +2779,29 @@ validate_suid(char *validarg, char *scriptname, int fdscript) # endif #endif || PerlProc_getuid() != PL_uid || PerlProc_geteuid() != PL_euid) - croak("Can't reswap uid and euid"); + Perl_croak(aTHX_ "Can't reswap uid and euid"); if (!cando(S_IXUSR,FALSE,&PL_statbuf)) /* can real uid exec? */ - croak("Permission denied\n"); + Perl_croak(aTHX_ "Permission denied\n"); } #endif /* HAS_SETREUID */ #endif /* IAMSUID */ if (!S_ISREG(PL_statbuf.st_mode)) - croak("Permission denied"); + Perl_croak(aTHX_ "Permission denied"); if (PL_statbuf.st_mode & S_IWOTH) - croak("Setuid/gid script is writable by world"); + Perl_croak(aTHX_ "Setuid/gid script is writable by world"); PL_doswitches = FALSE; /* -s is insecure in suid */ - PL_curcop->cop_line++; + CopLINE_inc(PL_curcop); if (sv_gets(PL_linestr, PL_rsfp, 0) == Nullch || strnNE(SvPV(PL_linestr,n_a),"#!",2) ) /* required even on Sys V */ - croak("No #! line"); + Perl_croak(aTHX_ "No #! line"); s = SvPV(PL_linestr,n_a)+2; if (*s == ' ') s++; while (!isSPACE(*s)) s++; for (s2 = s; (s2 > SvPV(PL_linestr,n_a)+2 && (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ; if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */ - 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 @@ -2273,13 +2811,13 @@ 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 (PL_euid != PL_uid && (PL_statbuf.st_mode & S_ISUID) && PL_euid == PL_statbuf.st_uid) if (!PL_do_undump) - croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\ + 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 */ @@ -2287,9 +2825,11 @@ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n"); (void)PerlIO_close(PL_rsfp); #ifndef IAMSUID /* try again */ - PerlProc_execv(form("%s/sperl%s", BIN_EXP, PL_patchlevel), PL_origargv); + PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT, BIN_EXP, + (int)PERL_REVISION, (int)PERL_VERSION, + (int)PERL_SUBVERSION), PL_origargv); #endif - croak("Can't do setuid\n"); + Perl_croak(aTHX_ "Can't do setuid\n"); } if (PL_statbuf.st_mode & S_ISGID && PL_statbuf.st_gid != PL_egid) { @@ -2307,7 +2847,7 @@ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n"); #endif #endif if (PerlProc_getegid() != PL_statbuf.st_gid) - croak("Can't do setegid!\n"); + Perl_croak(aTHX_ "Can't do setegid!\n"); } if (PL_statbuf.st_mode & S_ISUID) { if (PL_statbuf.st_uid != PL_euid) @@ -2325,7 +2865,7 @@ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n"); #endif #endif if (PerlProc_geteuid() != PL_statbuf.st_uid) - croak("Can't do seteuid!\n"); + Perl_croak(aTHX_ "Can't do seteuid!\n"); } else if (PL_uid) { /* oops, mustn't run as root */ #ifdef HAS_SETEUID @@ -2342,19 +2882,19 @@ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n"); #endif #endif if (PerlProc_geteuid() != PL_uid) - croak("Can't do seteuid!\n"); + Perl_croak(aTHX_ "Can't do seteuid!\n"); } init_ids(); if (!cando(S_IXUSR,TRUE,&PL_statbuf)) - croak("Permission denied\n"); /* they can't do this */ + Perl_croak(aTHX_ "Permission denied\n"); /* they can't do this */ } #ifdef IAMSUID else if (PL_preprocess) - croak("-P not allowed for setuid/setgid script\n"); + 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. */ @@ -2363,14 +2903,16 @@ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n"); 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]) - croak("Permission denied"); - PL_origargv[which] = savepv(form("/dev/fd/%d/%s", + Perl_croak(aTHX_ "Permission denied"); + PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s", PerlIO_fileno(PL_rsfp), PL_origargv[which])); #if defined(HAS_FCNTL) && defined(F_SETFD) fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0); /* ensure no close-on-exec */ #endif - PerlProc_execv(form("%s/perl%s", BIN_EXP, PL_patchlevel), PL_origargv);/* try again */ - croak("Can't do setuid\n"); + PerlProc_execv(Perl_form(aTHX_ "%s/perl"PERL_FS_VER_FMT, BIN_EXP, + (int)PERL_REVISION, (int)PERL_VERSION, + (int)PERL_SUBVERSION), PL_origargv);/* try again */ + Perl_croak(aTHX_ "Can't do setuid\n"); #endif /* IAMSUID */ #else /* !DOSUID */ if (PL_euid != PL_uid || PL_egid != PL_gid) { /* (suidperl doesn't exist, in fact) */ @@ -2382,7 +2924,7 @@ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n"); (PL_egid != PL_gid && PL_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID) ) if (!PL_do_undump) - croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\ + 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 */ @@ -2391,7 +2933,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; @@ -2400,7 +2942,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; @@ -2411,22 +2953,21 @@ find_beginning(void) while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--; if (strnEQ(s2-4,"perl",4)) /*SUPPRESS 530*/ - while (s = moreswitches(s)) ; + while ((s = moreswitches(s))) + ; } - if (PL_cddir && PerlDir_chdir(PL_cddir) < 0) - croak("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(); + PL_uid = PerlProc_getuid(); + PL_euid = PerlProc_geteuid(); + PL_gid = PerlProc_getgid(); + PL_egid = PerlProc_getegid(); #ifdef VMS PL_uid |= PL_gid << 16; PL_euid |= PL_egid << 16; @@ -2435,31 +2976,34 @@ init_ids(void) } 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) +void +Perl_init_debugger(pTHX) { dTHR; + HV *ostash = PL_curstash; + PL_curstash = PL_debstash; PL_dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV)))); AvREAL_off(PL_dbargs); PL_DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV); PL_DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV); PL_DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV)); + sv_upgrade(GvSV(PL_DBsub), SVt_IV); /* IVX accessed if PERLDB_SUB_NN */ PL_DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV))); sv_setiv(PL_DBsingle, 0); PL_DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV))); sv_setiv(PL_DBtrace, 0); PL_DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV))); sv_setiv(PL_DBsignal, 0); - PL_curstash = PL_defstash; + PL_curstash = ostash; } #ifndef STRESS_REALLOC @@ -2469,7 +3013,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), @@ -2491,7 +3035,7 @@ init_stacks(ARGSproto) PL_markstack_ptr = PL_markstack; PL_markstack_max = PL_markstack + REASONABLE(32); - SET_MARKBASE; + SET_MARK_OFFSET; New(54,PL_scopestack,REASONABLE(32),I32); PL_scopestack_ix = 0; @@ -2509,7 +3053,7 @@ init_stacks(ARGSproto) #undef REASONABLE STATIC void -nuke_stacks(void) +S_nuke_stacks(pTHX) { dTHR; while (PL_curstackinfo->si_next) @@ -2526,10 +3070,6 @@ nuke_stacks(void) Safefree(PL_scopestack); Safefree(PL_savestack); Safefree(PL_retstack); - DEBUG( { - Safefree(PL_debname); - Safefree(PL_debdelim); - } ) } #ifndef PERL_OBJECT @@ -2537,7 +3077,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; @@ -2546,38 +3086,41 @@ 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; + IO *io; - 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(); + io = GvIOp(PL_stdingv); + IoIFP(io) = PerlIO_stdin(); tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV); GvMULTI_on(tmpgv); - GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(PL_stdingv)); + GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io); tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO); GvMULTI_on(tmpgv); - IoOFP(GvIOp(tmpgv)) = IoIFP(GvIOp(tmpgv)) = PerlIO_stdout(); + io = GvIOp(tmpgv); + IoOFP(io) = IoIFP(io) = PerlIO_stdout(); setdefout(tmpgv); tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV); GvMULTI_on(tmpgv); - GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(PL_defoutgv)); + GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io); - othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO); - GvMULTI_on(othergv); - IoOFP(GvIOp(othergv)) = IoIFP(GvIOp(othergv)) = PerlIO_stderr(); + PL_stderrgv = gv_fetchpv("STDERR",TRUE, SVt_PVIO); + GvMULTI_on(PL_stderrgv); + io = GvIOp(PL_stderrgv); + IoOFP(io) = IoIFP(io) = PerlIO_stderr(); tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV); GvMULTI_on(tmpgv); - GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(othergv)); + GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io); PL_statname = NEWSV(66,0); /* last filename we did stat on */ @@ -2586,7 +3129,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; @@ -2598,11 +3141,11 @@ init_postdump_symbols(register int argc, register char **argv, register char **e for (; argc > 0 && **argv == '-'; argc--,argv++) { if (!argv[0][1]) break; - if (argv[0][1] == '-') { + if (argv[0][1] == '-' && !argv[0][2]) { argc--,argv++; break; } - if (s = strchr(argv[0], '=')) { + if ((s = strchr(argv[0], '='))) { *s++ = '\0'; sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s); } @@ -2619,26 +3162,33 @@ init_postdump_symbols(register int argc, register char **argv, register char **e PL_formtarget = PL_bodytarget; TAINT; - if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) { + if ((tmpgv = gv_fetchpv("0",TRUE, SVt_PV))) { sv_setpv(GvSV(tmpgv),PL_origfilename); magicname("0", "0", 1); } - if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV)) + if ((tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))) +#ifdef OS2 + sv_setpv(GvSV(tmpgv), os2_execname()); +#else sv_setpv(GvSV(tmpgv),PL_origargv[0]); - if (PL_argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) { +#endif + if ((PL_argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV))) { GvMULTI_on(PL_argvgv); (void)gv_AVadd(PL_argvgv); av_clear(GvAVn(PL_argvgv)); for (; argc > 0; argc--,argv++) { - av_push(GvAVn(PL_argvgv),newSVpv(argv[0],0)); + SV *sv = newSVpv(argv[0],0); + av_push(GvAVn(PL_argvgv),sv); + if (PL_widesyscalls) + sv_utf8_upgrade(sv); } } - if (PL_envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) { + if ((PL_envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV))) { HV *hv; GvMULTI_on(PL_envgv); hv = GvHVn(PL_envgv); hv_magic(hv, PL_envgv, 'E'); -#ifndef VMS /* VMS doesn't have environ array */ +#if !defined( VMS) && !defined(EPOC) /* VMS doesn't have environ array */ /* Note that if the supplied env parameter is actually a copy of the global environ then it may now point to free'd memory if the environment has been modified since. To avoid this @@ -2669,21 +3219,21 @@ init_postdump_symbols(register int argc, register char **argv, register char **e #endif } TAINT_NOT; - if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV)) - sv_setiv(GvSV(tmpgv), (IV)getpid()); + if ((tmpgv = gv_fetchpv("$",TRUE, SVt_PV))) + sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid()); } STATIC void -init_perllib(void) +S_init_perllib(pTHX) { char *s; if (!PL_tainting) { #ifndef VMS s = PerlEnv_getenv("PERL5LIB"); if (s) - incpush(s, TRUE); + incpush(s, TRUE, TRUE); else - incpush(PerlEnv_getenv("PERLLIB"), FALSE); + incpush(PerlEnv_getenv("PERLLIB"), FALSE, FALSE); #else /* VMS */ /* Treat PERL5?LIB as a possible search list logical name -- the * "natural" VMS idiom for a Unix path string. We allow each @@ -2692,43 +3242,73 @@ init_perllib(void) char buf[256]; int idx = 0; if (my_trnlnm("PERL5LIB",buf,0)) - do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx)); + do { incpush(buf,TRUE,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx)); else - while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE); + while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE,FALSE); #endif /* VMS */ } /* Use the ~-expanded versions of APPLLIB (undocumented), - ARCHLIB PRIVLIB SITEARCH and SITELIB + ARCHLIB PRIVLIB SITEARCH SITELIB VENDORARCH and VENDORLIB */ #ifdef APPLLIB_EXP - incpush(APPLLIB_EXP, TRUE); + incpush(APPLLIB_EXP, TRUE, TRUE); #endif #ifdef ARCHLIB_EXP - incpush(ARCHLIB_EXP, FALSE); + incpush(ARCHLIB_EXP, FALSE, FALSE); #endif #ifndef PRIVLIB_EXP -#define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl" +# define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl" #endif #if defined(WIN32) - incpush(PRIVLIB_EXP, TRUE); + incpush(PRIVLIB_EXP, TRUE, FALSE); #else - incpush(PRIVLIB_EXP, FALSE); + incpush(PRIVLIB_EXP, FALSE, FALSE); #endif #ifdef SITEARCH_EXP - incpush(SITEARCH_EXP, FALSE); + /* sitearch is always relative to sitelib on Windows for + * DLL-based path intuition to work correctly */ +# if !defined(WIN32) + incpush(SITEARCH_EXP, FALSE, FALSE); +# endif #endif + #ifdef SITELIB_EXP -#if defined(WIN32) - incpush(SITELIB_EXP, TRUE); -#else - incpush(SITELIB_EXP, FALSE); +# if defined(WIN32) + incpush(SITELIB_EXP, TRUE, FALSE); /* this picks up sitearch as well */ +# else + incpush(SITELIB_EXP, FALSE, FALSE); +# endif #endif + +#ifdef SITELIB_STEM /* Search for version-specific dirs below here */ + incpush(SITELIB_STEM, FALSE, TRUE); +#endif + +#ifdef PERL_VENDORARCH_EXP + /* vendorarch is always relative to vendorlib on Windows for + * DLL-based path intuition to work correctly */ +# if !defined(WIN32) + incpush(PERL_VENDORARCH_EXP, FALSE, FALSE); +# endif +#endif + +#ifdef PERL_VENDORLIB_EXP +# if defined(WIN32) + incpush(PERL_VENDORLIB_EXP, TRUE, FALSE); /* this picks up vendorarch as well */ +# else + incpush(PERL_VENDORLIB_EXP, FALSE, FALSE); +# endif +#endif + +#ifdef PERL_VENDORLIB_STEM /* Search for version-specific dirs below here */ + incpush(PERL_VENDORLIB_STEM, FALSE, TRUE); #endif + if (!PL_tainting) - incpush(".", FALSE); + incpush(".", FALSE, FALSE); } #if defined(DOSISH) @@ -2745,26 +3325,15 @@ init_perllib(void) #endif STATIC void -incpush(char *p, int addsubdirs) +S_incpush(pTHX_ char *p, int addsubdirs, int addoldvers) { SV *subdir = Nullsv; - if (!p) + if (!p || !*p) return; - if (addsubdirs) { + if (addsubdirs || addoldvers) { subdir = sv_newmortal(); - if (!PL_archpat_auto) { - STRLEN len = (sizeof(ARCHNAME) + strlen(PL_patchlevel) - + sizeof("//auto")); - New(55, PL_archpat_auto, len, char); - sprintf(PL_archpat_auto, "/%s/%s/auto", ARCHNAME, PL_patchlevel); -#ifdef VMS - for (len = sizeof(ARCHNAME) + 2; - PL_archpat_auto[len] != '\0' && PL_archpat_auto[len] != '/'; len++) - if (PL_archpat_auto[len] == '.') PL_archpat_auto[len] = '_'; -#endif - } } /* Break at all separators */ @@ -2775,7 +3344,7 @@ incpush(char *p, int addsubdirs) /* skip any consecutive separators */ while ( *p == PERLLIB_SEP ) { /* Uncomment the next line for PATH semantics */ - /* av_push(GvAVn(PL_incgv), newSVpv(".", 1)); */ + /* av_push(GvAVn(PL_incgv), newSVpvn(".", 1)); */ p++; } @@ -2793,7 +3362,12 @@ incpush(char *p, int addsubdirs) * BEFORE pushing libdir onto @INC we may first push version- and * archname-specific sub-directories. */ - if (addsubdirs) { + if (addsubdirs || addoldvers) { +#ifdef PERL_INC_VERSION_LIST + /* Configure terminates PERL_INC_VERSION_LIST with a NULL */ + const char *incverlist[] = { PERL_INC_VERSION_LIST }; + const char **incver; +#endif struct stat tmpstatbuf; #ifdef VMS char *unix; @@ -2805,25 +3379,46 @@ incpush(char *p, int addsubdirs) sv_usepvn(libdir,unix,len); } else - PerlIO_printf(PerlIO_stderr(), + PerlIO_printf(Perl_error_log, "Failed to unixify @INC element \"%s\"\n", SvPV(libdir,len)); #endif - /* .../archname/version if -d .../archname/version/auto */ - sv_setsv(subdir, libdir); - sv_catpv(subdir, PL_archpat_auto); - if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 && - S_ISDIR(tmpstatbuf.st_mode)) - av_push(GvAVn(PL_incgv), - newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto")); - - /* .../archname if -d .../archname/auto */ - sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME), - strlen(PL_patchlevel) + 1, "", 0); - if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 && - S_ISDIR(tmpstatbuf.st_mode)) - av_push(GvAVn(PL_incgv), - newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto")); + if (addsubdirs) { + /* .../version/archname if -d .../version/archname */ + Perl_sv_setpvf(aTHX_ subdir, "%"SVf"/"PERL_FS_VER_FMT"/%s", + libdir, + (int)PERL_REVISION, (int)PERL_VERSION, + (int)PERL_SUBVERSION, ARCHNAME); + if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 && + S_ISDIR(tmpstatbuf.st_mode)) + av_push(GvAVn(PL_incgv), newSVsv(subdir)); + + /* .../version if -d .../version */ + Perl_sv_setpvf(aTHX_ subdir, "%"SVf"/"PERL_FS_VER_FMT, libdir, + (int)PERL_REVISION, (int)PERL_VERSION, + (int)PERL_SUBVERSION); + if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 && + S_ISDIR(tmpstatbuf.st_mode)) + av_push(GvAVn(PL_incgv), newSVsv(subdir)); + + /* .../archname if -d .../archname */ + Perl_sv_setpvf(aTHX_ subdir, "%"SVf"/%s", libdir, ARCHNAME); + if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 && + S_ISDIR(tmpstatbuf.st_mode)) + av_push(GvAVn(PL_incgv), newSVsv(subdir)); + } + +#ifdef PERL_INC_VERSION_LIST + if (addoldvers) { + for (incver = incverlist; *incver; incver++) { + /* .../xxx if -d .../xxx */ + Perl_sv_setpvf(aTHX_ subdir, "%"SVf"/%s", libdir, *incver); + if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 && + S_ISDIR(tmpstatbuf.st_mode)) + av_push(GvAVn(PL_incgv), newSVsv(subdir)); + } + } +#endif } /* finally push this lib directory on the end of @INC */ @@ -2833,18 +3428,20 @@ incpush(char *p, int addsubdirs) #ifdef USE_THREADS STATIC struct perl_thread * -init_main_thread() +S_init_main_thread(pTHX) { +#if !defined(PERL_IMPLICIT_CONTEXT) struct perl_thread *thr; +#endif XPV *xpv; Newz(53, thr, 1, struct perl_thread); PL_curcop = &PL_compiling; + thr->interp = PERL_GET_INTERP; thr->cvcache = newHV(); thr->threadsv = newAV(); /* thr->threadsvp is set when find_threadsv is called */ thr->specific = newAV(); - thr->errhv = newHV(); thr->flags = THRf_R_JOINABLE; MUTEX_INIT(&thr->mutex); /* Handcraft thrsv similarly to mess_sv */ @@ -2859,6 +3456,7 @@ init_main_thread() *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++; @@ -2868,7 +3466,7 @@ init_main_thread() MUTEX_UNLOCK(&PL_threads_mutex); #ifdef HAVE_THREAD_INTERN - init_thread_intern(thr); + Perl_init_thread_intern(thr); #endif #ifdef SET_THREAD_SELF @@ -2876,7 +3474,7 @@ init_main_thread() #else thr->self = pthread_self(); #endif /* SET_THREAD_SELF */ - SET_THR(thr); + PERL_SET_THX(thr); /* * These must come after the SET_THR because sv_setpvn does @@ -2889,12 +3487,15 @@ init_main_thread() sv_upgrade(PL_bodytarget, SVt_PVFM); sv_setpvn(PL_bodytarget, "", 0); PL_formtarget = PL_bodytarget; - thr->errsv = newSVpv("", 0); + thr->errsv = newSVpvn("", 0); (void) find_threadsv("@"); /* Ensure $@ is initialised early */ PL_maxscream = -1; - PL_regcompp = FUNC_NAME_TO_PTR(pregcomp); - PL_regexecp = FUNC_NAME_TO_PTR(regexec_flags); + PL_regcompp = MEMBER_TO_FPTR(Perl_pregcomp); + PL_regexecp = MEMBER_TO_FPTR(Perl_regexec_flags); + PL_regint_start = MEMBER_TO_FPTR(Perl_re_intuit_start); + PL_regint_string = MEMBER_TO_FPTR(Perl_re_intuit_string); + PL_regfree = MEMBER_TO_FPTR(Perl_pregfree); PL_regindent = 0; PL_reginterp_cnt = 0; @@ -2903,38 +3504,47 @@ init_main_thread() #endif /* USE_THREADS */ void -call_list(I32 oldscope, AV *paramList) +Perl_call_list(pTHX_ I32 oldscope, AV *paramList) { dTHR; - line_t oldline = PL_curcop->cop_line; + SV *atsv; + line_t oldline = CopLINE(PL_curcop); + CV *cv; STRLEN len; - dJMPENV; int ret; + dJMPENV; while (AvFILL(paramList) >= 0) { - CV *cv = (CV*)av_shift(paramList); - + cv = (CV*)av_shift(paramList); SAVEFREESV(cv); - +#ifdef PERL_FLEXIBLE_EXCEPTIONS + CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_list_body), cv); +#else JMPENV_PUSH(ret); +#endif switch (ret) { - case 0: { - 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: +#ifndef PERL_FLEXIBLE_EXCEPTIONS + call_list_body(cv); +#endif + atsv = ERRSV; + (void)SvPV(atsv, len); + if (len) { + STRLEN n_a; + PL_curcop = &PL_compiling; + CopLINE_set(PL_curcop, oldline); + if (paramList == PL_beginav) + sv_catpv(atsv, "BEGIN failed--compilation aborted"); + else + Perl_sv_catpvf(aTHX_ atsv, + "%s failed--call queue aborted", + paramList == PL_checkav ? "CHECK" + : paramList == PL_initav ? "INIT" + : "END"); + while (PL_scopestack_ix > oldscope) + LEAVE; + JMPENV_POP; + Perl_croak(aTHX_ "%s", SvPVx(atsv, n_a)); } break; case 1: @@ -2946,36 +3556,53 @@ call_list(I32 oldscope, AV *paramList) LEAVE; FREETMPS; 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) { + CopLINE_set(PL_curcop, oldline); + JMPENV_POP; + if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED)) { 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_ "%s failed--call queue aborted", + paramList == PL_checkav ? "CHECK" + : paramList == PL_initav ? "INIT" + : "END"); } 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; + CopLINE_set(PL_curcop, oldline); + JMPENV_JUMP(3); } - JMPENV_POP; - PL_curcop = &PL_compiling; - PL_curcop->cop_line = oldline; - JMPENV_JUMP(3); + PerlIO_printf(Perl_error_log, "panic: restartop\n"); + FREETMPS; + break; } JMPENV_POP; } } +#ifdef PERL_FLEXIBLE_EXCEPTIONS +STATIC void * +S_vcall_list_body(pTHX_ va_list args) +{ + CV *cv = va_arg(args, CV*); + return call_list_body(cv); +} +#endif + +STATIC void * +S_call_list_body(pTHX_ CV *cv) +{ + PUSHMARK(PL_stack_sp); + call_sv((SV*)cv, G_EVAL|G_DISCARD); + return NULL; +} + void -my_exit(U32 status) +Perl_my_exit(pTHX_ U32 status) { dTHR; @@ -2996,7 +3623,7 @@ my_exit(U32 status) } void -my_failure_exit(void) +Perl_my_failure_exit(pTHX) { #ifdef VMS if (vaxc$errno & 1) { @@ -3025,9 +3652,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; @@ -3049,17 +3676,11 @@ my_exit_jump(void) } #ifdef PERL_OBJECT -#define NO_XSLOCKS -#endif /* PERL_OBJECT */ - #include "XSUB.h" +#endif 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); @@ -3073,5 +3694,3 @@ read_e_script(int idx, SV *buf_sv, int maxlen) sv_chop(PL_e_script, nl); return 1; } - - |
