X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=perl.c;h=ff851b441782c779781faefa1d8459017b8d773c;hb=765e9edb2de192ef033766d867f9bd290e9935e9;hp=67c2ccc6e010b60e1aee80ea237eb6c6fd477c33;hpb=6bf425089316a32726a25ea317fa3faa951fb073;p=p5sagit%2Fp5-mst-13.2.git diff --git a/perl.c b/perl.c index 67c2ccc..ff851b4 100644 --- a/perl.c +++ b/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. @@ -27,13 +27,6 @@ char *getenv (char *); /* Usually in */ static I32 read_e_script(pTHXo_ int idx, SV *buf_sv, int maxlen); -#ifdef I_FCNTL -#include -#endif -#ifdef I_SYS_FILE -#include -#endif - #ifdef IAMSUID #ifndef DOSUID #define DOSUID @@ -47,43 +40,89 @@ static I32 read_e_script(pTHXo_ int idx, SV *buf_sv, int maxlen); #endif #ifdef PERL_OBJECT -CPerlObj* -perl_alloc(struct IPerlMem* ipM, 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; -} +#define perl_construct Perl_construct +#define perl_parse Perl_parse +#define perl_run Perl_run +#define perl_destruct Perl_destruct +#define perl_free Perl_free +#endif + +#if defined(USE_THREADS) +# define INIT_TLS_AND_INTERP \ + STMT_START { \ + if (!PL_curinterp) { \ + PERL_SET_INTERP(my_perl); \ + INIT_THREADS; \ + ALLOC_THREAD_KEY; \ + } \ + } STMT_END #else +# if defined(USE_ITHREADS) +# define INIT_TLS_AND_INTERP \ + STMT_START { \ + if (!PL_curinterp) { \ + PERL_SET_INTERP(my_perl); \ + INIT_THREADS; \ + ALLOC_THREAD_KEY; \ + PERL_SET_THX(my_perl); \ + OP_REFCNT_INIT; \ + } \ + else { \ + PERL_SET_THX(my_perl); \ + } \ + } STMT_END +# else +# define INIT_TLS_AND_INTERP \ + STMT_START { \ + if (!PL_curinterp) { \ + PERL_SET_INTERP(my_perl); \ + } \ + PERL_SET_THX(my_perl); \ + } STMT_END +# endif +#endif #ifdef PERL_IMPLICIT_SYS PerlInterpreter * -perl_alloc_using(struct IPerlMem* ipM, struct IPerlEnv* ipE, +perl_alloc_using(struct IPerlMem* ipM, struct IPerlMem* ipMS, + struct IPerlMem* ipMP, struct IPerlEnv* ipE, struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO, struct IPerlDir* ipD, struct IPerlSock* ipS, struct IPerlProc* ipP) { PerlInterpreter *my_perl; - +#ifdef PERL_OBJECT + my_perl = (PerlInterpreter*)new(ipM) CPerlObj(ipM, ipMS, ipMP, ipE, ipStd, + ipLIO, ipD, ipS, ipP); + INIT_TLS_AND_INTERP; +#else /* New() needs interpreter, so call malloc() instead */ my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter)); - PERL_SET_INTERP(my_perl); + 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. + +=cut +*/ + PerlInterpreter * perl_alloc(void) { @@ -91,11 +130,20 @@ perl_alloc(void) /* New() needs interpreter, so call malloc() instead */ my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter)); - PERL_SET_INTERP(my_perl); + + INIT_TLS_AND_INTERP; + Zero(my_perl, 1, PerlInterpreter); return my_perl; } #endif /* PERL_IMPLICIT_SYS */ -#endif /* PERL_OBJECT */ + +/* +=for apidoc perl_construct + +Initializes a new Perl interpreter. See L. + +=cut +*/ void perl_construct(pTHXx) @@ -106,7 +154,7 @@ perl_construct(pTHXx) struct perl_thread *thr = NULL; #endif /* FAKE_THREADS */ #endif /* USE_THREADS */ - + #ifdef MULTIPLICITY init_interp(); PL_perl_destruct_level = 1; @@ -118,14 +166,6 @@ perl_construct(pTHXx) /* 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)) - Perl_croak(aTHX_ "panic: pthread_key_create"); -#endif MUTEX_INIT(&PL_sv_mutex); /* * Safe to use basic SV functions from now on (though @@ -135,16 +175,18 @@ perl_construct(pTHXx) 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 */ @@ -201,14 +243,30 @@ perl_construct(pTHXx) init_i18nl10n(1); SET_NUMERIC_STANDARD(); + + { + U8 *s; + PL_patchlevel = NEWSV(0,4); + (void)SvUPGRADE(PL_patchlevel, SVt_PVNV); + if (PERL_REVISION > 127 || PERL_VERSION > 127 || PERL_SUBVERSION > 127) + SvGROW(PL_patchlevel, UTF8_MAXLEN*3+1); + s = (U8*)SvPVX(PL_patchlevel); + s = uv_to_utf8(s, (UV)PERL_REVISION); + s = uv_to_utf8(s, (UV)PERL_VERSION); + s = uv_to_utf8(s, (UV)PERL_SUBVERSION); + *s = '\0'; + SvCUR_set(PL_patchlevel, s - (U8*)SvPVX(PL_patchlevel)); + SvPOK_on(PL_patchlevel); + SvNVX(PL_patchlevel) = (NV)PERL_REVISION + + ((NV)PERL_VERSION / (NV)1000) #if defined(PERL_SUBVERSION) && PERL_SUBVERSION > 0 - sprintf(PL_patchlevel, "%7.5f", (double) PERL_REVISION - + ((double) PERL_VERSION / (double) 1000) - + ((double) PERL_SUBVERSION / (double) 100000)); -#else - sprintf(PL_patchlevel, "%5.3f", (double) PERL_REVISION + - ((double) PERL_VERSION / (double) 1000)); + + ((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 */ @@ -218,15 +276,19 @@ perl_construct(pTHXx) 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); - } ) + PL_errors = newSVpvn("",0); ENTER; } +/* +=for apidoc perl_destruct + +Shuts down a Perl interpreter. See L. + +=cut +*/ + void perl_destruct(pTHXx) { @@ -239,6 +301,9 @@ perl_destruct(pTHXx) dTHX; #endif /* USE_THREADS */ + /* wait for all pseudo-forked children to finish */ + PERL_WAIT_FOR_CHILDREN; + #ifdef USE_THREADS #ifndef FAKE_THREADS /* Pass 1 on any remaining threads: detach joinables, join zombies */ @@ -313,7 +378,7 @@ perl_destruct(pTHXx) #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; @@ -389,12 +454,11 @@ perl_destruct(pTHXx) 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); @@ -403,10 +467,10 @@ perl_destruct(pTHXx) /* magical thingies */ - Safefree(PL_ofs); /* $, */ + Safefree(PL_ofs); /* $, */ PL_ofs = Nullch; - Safefree(PL_ors); /* $\ */ + Safefree(PL_ors); /* $\ */ PL_ors = Nullch; SvREFCNT_dec(PL_rs); /* $/ */ @@ -415,7 +479,9 @@ perl_destruct(pTHXx) 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; @@ -439,14 +505,15 @@ perl_destruct(pTHXx) /* 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; @@ -456,15 +523,91 @@ perl_destruct(pTHXx) 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); @@ -490,14 +633,21 @@ perl_destruct(pTHXx) /* 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, @@ -529,16 +679,28 @@ perl_destruct(pTHXx) } SvREFCNT_dec(PL_strtab); + /* 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); @@ -565,7 +727,7 @@ perl_destruct(pTHXx) 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) { @@ -581,7 +743,7 @@ perl_destruct(pTHXx) } } /* 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); @@ -589,13 +751,27 @@ perl_destruct(pTHXx) } } +/* +=for apidoc perl_free + +Releases a Perl interpreter. See L. + +=cut +*/ + void perl_free(pTHXx) { #if defined(PERL_OBJECT) PerlMem_free(this); #else +# if defined(PERL_IMPLICIT_SYS) && defined(WIN32) + void *host = w32_internal_host; + PerlMem_free(aTHXx); + win32_delete_internal_host(host); +# else PerlMem_free(aTHXx); +# endif #endif } @@ -608,6 +784,14 @@ Perl_call_atexit(pTHX_ ATEXIT_t fn, void *ptr) ++PL_exitlistlen; } +/* +=for apidoc perl_parse + +Tells a Perl interpreter to parse a Perl script. See L. + +=cut +*/ + int perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env) { @@ -663,11 +847,20 @@ setuid perl scripts securely.\n"); oldscope = PL_scopestack_ix; PL_dowarn = G_WARN_OFF; - CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_parse_body), - env, xsinit); +#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: - return 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 */ @@ -677,23 +870,36 @@ setuid perl scripts securely.\n"); LEAVE; FREETMPS; PL_curstash = PL_defstash; - if (PL_endav && !PL_minus_c) - call_list(oldscope, PL_endav); - return STATUS_NATIVE_EXPORT; + if (PL_checkav) + call_list(oldscope, PL_checkav); + ret = STATUS_NATIVE_EXPORT; + break; case 3: PerlIO_printf(Perl_error_log, "panic: top_env\n"); - return 1; + ret = 1; + break; } - return 0; + 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_ va_list args) +S_parse_body(pTHX_ char **env, XSINIT_t xsinit) { 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; @@ -701,8 +907,7 @@ S_parse_body(pTHX_ va_list args) AV* comppadlist; register SV *sv; register char *s; - - XSINIT_t xsinit = va_arg(args, XSINIT_t); + char *cddir = Nullch; sv_setpvn(PL_linestr,"",0); sv = newSVpvn("",0); /* first used for -I flags */ @@ -721,6 +926,11 @@ S_parse_body(pTHX_ va_list args) 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 @@ -745,7 +955,7 @@ S_parse_body(pTHX_ va_list args) case 'W': case 'X': case 'w': - if (s = moreswitches(s)) + if ((s = moreswitches(s))) goto reswitch; break; @@ -777,18 +987,18 @@ S_parse_body(pTHX_ va_list args) 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"); @@ -821,6 +1031,24 @@ S_parse_body(pTHX_ va_list args) # 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 @@ -869,7 +1097,7 @@ print \" \\@INC:\\n @INC\\n\";"); PL_doextract = TRUE; s++; if (*s) - PL_cddir = savepv(s); + cddir = s; break; case 0: break; @@ -899,7 +1127,8 @@ print \" \\@INC:\\n @INC\\n\";"); #ifndef SECURE_INTERNAL_GETENV !PL_tainting && #endif - (s = PerlEnv_getenv("PERL5OPT"))) { + (s = PerlEnv_getenv("PERL5OPT"))) + { while (isSPACE(*s)) s++; if (*s == '-' && *(s+1) == 'T') @@ -942,8 +1171,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); @@ -972,11 +1220,13 @@ print \" \\@INC:\\n @INC\\n\";"); CvPADLIST(PL_compcv) = comppadlist; boot_core_UNIVERSAL(); +#ifndef PERL_MICRO boot_core_xsutils(); +#endif if (xsinit) (*xsinit)(aTHXo); /* in case linked C routines want magical variables */ -#if defined(VMS) || defined(WIN32) || defined(DJGPP) +#if defined(VMS) || defined(WIN32) || defined(DJGPP) || defined(__CYGWIN__) init_os_extras(); #endif @@ -1005,7 +1255,7 @@ print \" \\@INC:\\n @INC\\n\";"); PL_origfilename); } } - PL_curcop->cop_line = 0; + CopLINE_set(PL_curcop, 0); PL_curstash = PL_defstash; PL_preprocess = FALSE; if (PL_e_script) { @@ -1020,8 +1270,11 @@ print \" \\@INC:\\n @INC\\n\";"); if (PL_do_undump) my_unexec(); - if (isWARN_ONCE) + if (isWARN_ONCE) { + SAVECOPFILE(PL_curcop); + SAVECOPLINE(PL_curcop); gv_check(PL_defstash); + } LEAVE; FREETMPS; @@ -1036,12 +1289,20 @@ print \" \\@INC:\\n @INC\\n\";"); return NULL; } +/* +=for apidoc perl_run + +Tells a Perl interpreter to run. See L. + +=cut +*/ + int perl_run(pTHXx) { dTHR; I32 oldscope; - int ret; + int ret = 0; dJMPENV; #ifdef USE_THREADS dTHX; @@ -1049,14 +1310,23 @@ perl_run(pTHXx) oldscope = PL_scopestack_ix; +#ifdef PERL_FLEXIBLE_EXCEPTIONS redo_body: - CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_run_body), oldscope); + CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vrun_body), oldscope); +#else + JMPENV_PUSH(ret); +#endif switch (ret) { case 1: cxstack_ix = -1; /* start context stack again */ goto redo_body; - case 0: /* normal completion */ - case 2: /* my_exit() */ + 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; @@ -1067,7 +1337,8 @@ perl_run(pTHXx) if (PerlEnv_getenv("PERL_DEBUG_MSTATS")) dump_mstats("after execution: "); #endif - return STATUS_NATIVE_EXPORT; + ret = STATUS_NATIVE_EXPORT; + break; case 3: if (PL_restartop) { POPSTACK_TO(PL_mainstack); @@ -1075,19 +1346,30 @@ perl_run(pTHXx) } PerlIO_printf(Perl_error_log, "panic: restartop\n"); FREETMPS; - return 1; + ret = 1; + break; } - /* NOTREACHED */ - return 0; + JMPENV_POP; + return ret; } +#ifdef PERL_FLEXIBLE_EXCEPTIONS STATIC void * -S_run_body(pTHX_ va_list args) +S_vrun_body(pTHX_ va_list args) { - dTHR; 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")); @@ -1125,6 +1407,16 @@ S_run_body(pTHX_ va_list args) return NULL; } +/* +=for apidoc p||get_sv + +Returns the SV of the specified Perl scalar. If C is set and the +Perl variable does not exist then it will be created. If C is not +set and the variable does not exist then NULL is returned. + +=cut +*/ + SV* Perl_get_sv(pTHX_ const char *name, I32 create) { @@ -1144,6 +1436,16 @@ Perl_get_sv(pTHX_ const char *name, I32 create) return Nullsv; } +/* +=for apidoc p||get_av + +Returns the AV of the specified Perl array. If C is set and the +Perl variable does not exist then it will be created. If C is not +set and the variable does not exist then NULL is returned. + +=cut +*/ + AV* Perl_get_av(pTHX_ const char *name, I32 create) { @@ -1155,6 +1457,16 @@ Perl_get_av(pTHX_ const char *name, I32 create) return Nullav; } +/* +=for apidoc p||get_hv + +Returns the HV of the specified Perl hash. If C is set and the +Perl variable does not exist then it will be created. If C is not +set and the variable does not exist then NULL is returned. + +=cut +*/ + HV* Perl_get_hv(pTHX_ const char *name, I32 create) { @@ -1166,6 +1478,17 @@ Perl_get_hv(pTHX_ const char *name, I32 create) return Nullhv; } +/* +=for apidoc p||get_cv + +Returns the CV of the specified Perl subroutine. If C is set and +the Perl subroutine does not exist then it will be declared (which has the +same effect as saying C). If C is not set and the +subroutine does not exist then NULL is returned. + +=cut +*/ + CV* Perl_get_cv(pTHX_ const char *name, I32 create) { @@ -1186,6 +1509,14 @@ Perl_get_cv(pTHX_ const 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. + +=cut +*/ + I32 Perl_call_argv(pTHX_ const char *sub_name, I32 flags, register char **argv) @@ -1205,6 +1536,14 @@ Perl_call_argv(pTHX_ const char *sub_name, I32 flags, register char **argv) return call_pv(sub_name, flags); } +/* +=for apidoc p||call_pv + +Performs a callback to the specified Perl sub. See L. + +=cut +*/ + I32 Perl_call_pv(pTHX_ const char *sub_name, I32 flags) /* name of the subroutine */ @@ -1213,6 +1552,15 @@ Perl_call_pv(pTHX_ const char *sub_name, I32 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. + +=cut +*/ + I32 Perl_call_method(pTHX_ const char *methname, I32 flags) /* name of the subroutine */ @@ -1220,17 +1568,28 @@ Perl_call_method(pTHX_ const char *methname, I32 flags) { 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(); - if(PL_op == &myop) - PL_op = Nullop; + 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. + +=cut +*/ + I32 Perl_call_sv(pTHX_ SV *sv, I32 flags) @@ -1277,7 +1636,7 @@ Perl_call_sv(pTHX_ SV *sv, I32 flags) if (!(flags & G_EVAL)) { CATCH_SET(TRUE); - call_xbody((OP*)&myop, FALSE); + call_body((OP*)&myop, FALSE); retval = PL_stack_sp - (PL_stack_base + oldmark); CATCH_SET(oldcatch); } @@ -1293,7 +1652,7 @@ Perl_call_sv(pTHX_ 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. */ @@ -1305,11 +1664,19 @@ Perl_call_sv(pTHX_ SV *sv, I32 flags) } PL_markstack_ptr++; - redo_body: - CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_call_body), +#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,""); @@ -1321,7 +1688,8 @@ Perl_call_sv(pTHX_ SV *sv, I32 flags) /* my_exit() was called */ PL_curstash = PL_defstash; FREETMPS; - if (PL_statusvalue) + JMPENV_POP; + if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED)) Perl_croak(aTHX_ "Callback called exit"); my_exit_jump(); /* NOTREACHED */ @@ -1354,6 +1722,7 @@ Perl_call_sv(pTHX_ SV *sv, I32 flags) PL_curpm = newpm; LEAVE; } + JMPENV_POP; } if (flags & G_DISCARD) { @@ -1366,18 +1735,20 @@ Perl_call_sv(pTHX_ SV *sv, I32 flags) return retval; } +#ifdef PERL_FLEXIBLE_EXCEPTIONS STATIC void * -S_call_body(pTHX_ va_list args) +S_vcall_body(pTHX_ va_list args) { OP *myop = va_arg(args, OP*); int is_eval = va_arg(args, int); - call_xbody(myop, is_eval); + call_body(myop, is_eval); return NULL; } +#endif STATIC void -S_call_xbody(pTHX_ OP *myop, int is_eval) +S_call_body(pTHX_ OP *myop, int is_eval) { dTHR; @@ -1393,6 +1764,14 @@ S_call_xbody(pTHX_ OP *myop, int is_eval) /* Eval a string. The G_EVAL flag is always assumed. */ +/* +=for apidoc p||eval_sv + +Tells Perl to C the string in the SV. + +=cut +*/ + I32 Perl_eval_sv(pTHX_ SV *sv, I32 flags) @@ -1429,11 +1808,19 @@ Perl_eval_sv(pTHX_ 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_call_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,""); @@ -1445,7 +1832,8 @@ Perl_eval_sv(pTHX_ SV *sv, I32 flags) /* my_exit() was called */ PL_curstash = PL_defstash; FREETMPS; - if (PL_statusvalue) + JMPENV_POP; + if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED)) Perl_croak(aTHX_ "Callback called exit"); my_exit_jump(); /* NOTREACHED */ @@ -1465,6 +1853,7 @@ Perl_eval_sv(pTHX_ SV *sv, I32 flags) break; } + JMPENV_POP; if (flags & G_DISCARD) { PL_stack_sp = PL_stack_base + oldmark; retval = 0; @@ -1475,6 +1864,14 @@ Perl_eval_sv(pTHX_ SV *sv, I32 flags) return retval; } +/* +=for apidoc p||eval_pv + +Tells Perl to C the given string and return an SV* result. + +=cut +*/ + SV* Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error) { @@ -1499,6 +1896,14 @@ Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error) /* Require a module. */ +/* +=for apidoc p||require_pv + +Tells Perl to C a module. + +=cut +*/ + void Perl_require_pv(pTHX_ const char *pv) { @@ -1520,7 +1925,7 @@ 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); } @@ -1533,6 +1938,7 @@ S_usage(pTHX_ 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 program under debugger", "-D[number/list] set debugging flags (argument is a bit mask or alphabets)", @@ -1553,6 +1959,8 @@ S_usage(pTHX_ char *name) /* XXX move this out into a module ? */ "-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 @@ -1576,7 +1984,8 @@ Perl_moreswitches(pTHX_ char *s) case '0': { dTHR; - rschar = scan_oct(s, 4, &numlen); + numlen = 0; /* disallow underscores */ + rschar = (U32)scan_oct(s, 4, &numlen); SvREFCNT_dec(PL_nrs); if (rschar & ~((U8)~0)) PL_nrs = &PL_sv_undef; @@ -1588,6 +1997,10 @@ Perl_moreswitches(pTHX_ char *s) } return s + numlen; } + case 'C': + PL_widesyscalls = TRUE; + s++; + return s; case 'F': PL_minus_F = TRUE; PL_splitstr = savepv(s + 1); @@ -1661,14 +2074,23 @@ Perl_moreswitches(pTHX_ 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 - Perl_croak(aTHX_ "No space allowed after -I"); + Perl_croak(aTHX_ "No directory specified for -I"); return s; case 'l': PL_minus_l = TRUE; @@ -1678,7 +2100,8 @@ Perl_moreswitches(pTHX_ char *s) if (isDIGIT(*s)) { PL_ors = savepv("\n"); PL_orslen = 1; - *PL_ors = scan_oct(s, 3 + (*s == '0'), &numlen); + numlen = 0; /* disallow underscores */ + *PL_ors = (char)scan_oct(s, 3 + (*s == '0'), &numlen); s += numlen; } else { @@ -1715,13 +2138,16 @@ Perl_moreswitches(pTHX_ char *s) sv_catpv( sv, " ()"); } } else { + if (s == start) + Perl_croak(aTHX_ "Module name required with -%c option", + s[-1]); sv_catpvn(sv, start, s-start); sv_catpv(sv, " split(/,/,q{"); sv_catpv(sv, ++s); sv_catpv(sv, "})"); } s += strlen(s); - if (PL_preambleav == NULL) + if (!PL_preambleav) PL_preambleav = newAV(); av_push(PL_preambleav, sv); } @@ -1755,20 +2181,15 @@ Perl_moreswitches(pTHX_ char *s) s++; return s; case 'v': -#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", - 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)", (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 @@ -1804,6 +2225,9 @@ Perl_moreswitches(pTHX_ char *s) #ifdef __MINT__ 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; #endif @@ -1821,12 +2245,12 @@ Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n"); return s; case 'W': PL_dowarn = G_WARN_ALL_ON|G_WARN_ON; - PL_compiling.cop_warnings = WARN_ALL ; + PL_compiling.cop_warnings = pWARN_ALL ; s++; return s; case 'X': PL_dowarn = G_WARN_ALL_OFF; - PL_compiling.cop_warnings = WARN_NONE ; + PL_compiling.cop_warnings = pWARN_NONE ; s++; return s; case '*': @@ -1901,7 +2325,6 @@ S_init_interp(pTHX) PL_curcop = &PL_compiling;\ PL_curcopdb = NULL; \ PL_dbargs = 0; \ - PL_dlmax = 128; \ PL_dumpindent = 4; \ PL_laststatval = -1; \ PL_laststype = OP_STAT; \ @@ -1911,7 +2334,6 @@ S_init_interp(pTHX) 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; \ @@ -2006,9 +2428,10 @@ S_init_main_stash(pTHX) 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)); + PL_nullstash = GvHV(gv_fetchpv("::", GV_ADDMULTI, SVt_PVHV)); /* We must init $/ before switches are processed. */ sv_setpvn(get_sv("/", TRUE), "\n", 1); } @@ -2017,7 +2440,6 @@ STATIC void S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript) { dTHR; - register char *s; *fdscript = -1; @@ -2041,7 +2463,7 @@ S_open_script(pTHX_ 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) { @@ -2060,7 +2482,7 @@ S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript) 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 @@ -2076,7 +2498,7 @@ 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 # ifdef __OPEN_VM @@ -2092,7 +2514,7 @@ sed %s -e \"/^[^#]/b\" \ -e '/^#[ ]*undef[ ]/b' \ -e '/^#[ ]*endif/b' \ -e 's/^[ ]*#.*//' \ - %s | %_ %_ %s", + %s | %"SVf" %"SVf" %s", # else Perl_sv_setpvf(aTHX_ cmd, "\ %s %s -e '/^[^#]/b' \ @@ -2106,7 +2528,7 @@ sed %s -e \"/^[^#]/b\" \ -e '/^#[ ]*undef[ ]/b' \ -e '/^#[ ]*endif/b' \ -e 's/^[ ]*#.*//' \ - %s | %_ -C %_ %s", + %s | %"SVf" -C %"SVf" %s", # endif #ifdef LOC_SED LOC_SED, @@ -2155,82 +2577,124 @@ 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(Perl_form(aTHX_ "%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); Perl_croak(aTHX_ "Can't do setuid\n"); } #endif #endif Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n", - SvPVX(GvSV(PL_curcop->cop_filegv)), Strerror(errno)); + CopFILE(PL_curcop), Strerror(errno)); } } /* Mention * I_SYSSTATVFS HAS_FSTATVFS * I_SYSMOUNT - * I_STATFS HAS_FSTATFS + * I_STATFS HAS_FSTATFS HAS_GETFSSTAT * I_MNTENT HAS_GETMNTENT HAS_HASMNTOPT * here so that metaconfig picks them up. */ #ifdef IAMSUID STATIC int -S_file_on_nosuid_fs(pTHX_ int fd, char *path) +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(), getmnt(), getmntent(). - * fstatvfs() is UNIX98 and uses the fd. - * fstatfs() is BSD 4.3+ and uses the fd. - * getmnt() is BSD 4.2 (4.1?) and uses the path. - * getmntent() is O(number-of-mounted-filesystems) and - * uses neither fd nor path and can hang. + * Preferred order: fstatvfs(), fstatfs(), ustat()+getmnt(), getmntent(). + * fstatvfs() is UNIX98. + * fstatfs() is 4.3 BSD. + * ustat()+getmnt() is pre-4.3 BSD. + * getmntent() is O(number-of-mounted-filesystems) and can hang on + * an irrelevant filesystem while trying to reach the right one. */ -# ifdef HAS_FSTATVFS +#undef FD_ON_NOSUID_CHECK_OKAY /* found the syscalls to do the check? */ + +# if !defined(FD_ON_NOSUID_CHECK_OKAY) && \ + defined(HAS_FSTATVFS) +# define FD_ON_NOSUID_CHECK_OKAY struct statvfs stfs; + check_okay = fstatvfs(fd, &stfs) == 0; on_nosuid = check_okay && (stfs.f_flag & ST_NOSUID); -# else -# ifdef PERL_MOUNT_NOSUID -# if defined(HAS_FSTATFS) && defined(HAS_STRUCT_STATFS_FLAGS) - struct statfs stfs; +# endif /* fstatvfs */ + +# if !defined(FD_ON_NOSUID_CHECK_OKAY) && \ + defined(PERL_MOUNT_NOSUID) && \ + defined(HAS_FSTATFS) && \ + defined(HAS_STRUCT_STATFS) && \ + defined(HAS_STRUCT_STATFS_F_FLAGS) +# define FD_ON_NOSUID_CHECK_OKAY + struct statfs stfs; + check_okay = fstatfs(fd, &stfs) == 0; on_nosuid = check_okay && (stfs.f_flags & PERL_MOUNT_NOSUID); -# else -# ifdef HAS_GETMNT - struct fs_data fsd; - check_okay = getmnt(0, &fsd, 0, NOSTAT_ONE, path) == 1; - on_nosuid = check_okay && (fsd.fd_req.flags & PERL_MOUNT_NOSUID); -# endif /* getmnt */ -# endif /* fstatfs */ -# else -# if defined(HAS_GETMNTENT) && defined(HAS_HASMNTOPT) && defined(MNTOPT_NOSUID) - FILE *mtab = fopen("/etc/mtab", "r"); - struct mntent *entry; - struct stat stb, fsb; +# endif /* fstatfs */ + +# if !defined(FD_ON_NOSUID_CHECK_OKAY) && \ + defined(PERL_MOUNT_NOSUID) && \ + defined(HAS_FSTAT) && \ + defined(HAS_USTAT) && \ + defined(HAS_GETMNT) && \ + defined(HAS_STRUCT_FS_DATA) && \ + defined(NOSTAT_ONE) +# define FD_ON_NOSUID_CHECK_OKAY + struct stat fdst; + + if (fstat(fd, &fdst) == 0) { + struct ustat us; + if (ustat(fdst.st_dev, &us) == 0) { + struct fs_data fsd; + /* NOSTAT_ONE here because we're not examining fields which + * vary between that case and STAT_ONE. */ + if (getmnt((int*)0, &fsd, (int)0, NOSTAT_ONE, us.f_fname) == 0) { + size_t cmplen = sizeof(us.f_fname); + if (sizeof(fsd.fd_req.path) < cmplen) + cmplen = sizeof(fsd.fd_req.path); + if (strnEQ(fsd.fd_req.path, us.f_fname, cmplen) && + fdst.st_dev == fsd.fd_req.dev) { + check_okay = 1; + on_nosuid = fsd.fd_req.flags & PERL_MOUNT_NOSUID; + } + } + } + } + } +# endif /* fstat+ustat+getmnt */ + +# if !defined(FD_ON_NOSUID_CHECK_OKAY) && \ + defined(HAS_GETMNTENT) && \ + defined(HAS_HASMNTOPT) && \ + defined(MNTOPT_NOSUID) +# define FD_ON_NOSUID_CHECK_OKAY + FILE *mtab = fopen("/etc/mtab", "r"); + struct mntent *entry; + struct stat stb, fsb; if (mtab && (fstat(fd, &stb) == 0)) { - while ((entry = getmntent(mtab))) { - if (stat(entry->mnt_dir, &fsb) == 0 && fsb.st_dev == stb.st_dev) - { - /* found the filesystem */ - check_okay = 1; - if (hasmntopt(entry, MNTOPT_NOSUID)) - on_nosuid = 1; - break; - } /* A single fs may well fail its stat(). Or hang :-( */ - } + while (entry = getmntent(mtab)) { + if (stat(entry->mnt_dir, &fsb) == 0 + && fsb.st_dev == stb.st_dev) + { + /* found the filesystem */ + check_okay = 1; + if (hasmntopt(entry, MNTOPT_NOSUID)) + on_nosuid = 1; + break; + } /* A single fs may well fail its stat(). */ + } } if (mtab) - fclose(mtab); -# endif /* getmntent */ -# endif /* PERL_MOUNT_NOSUID: fstatfs() or getmnt() */ -# endif /* fstatvfs */ + fclose(mtab); +# endif /* getmntent+hasmntopt */ + if (!check_okay) Perl_croak(aTHX_ "Can't check filesystem of script \"%s\" for nosuid", PL_origfilename); return on_nosuid; @@ -2240,7 +2704,9 @@ S_file_on_nosuid_fs(pTHX_ int fd, char *path) STATIC void S_validate_suid(pTHX_ char *validarg, char *scriptname, int fdscript) { +#ifdef IAMSUID int which; +#endif /* do we need to emulate setuid on scripts? */ @@ -2282,7 +2748,7 @@ S_validate_suid(pTHX_ 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*/ + 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 @@ -2303,10 +2769,10 @@ S_validate_suid(pTHX_ char *validarg, char *scriptname, int fdscript) #endif || 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) + 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 (file_on_nosuid_fs(PerlIO_fileno(PL_rsfp), scriptname)) + if (fd_on_nosuid_fs(PerlIO_fileno(PL_rsfp))) Perl_croak(aTHX_ "Permission denied"); #endif if (tmpstatbuf.st_dev != PL_statbuf.st_dev || @@ -2314,12 +2780,12 @@ S_validate_suid(pTHX_ char *validarg, char *scriptname, int fdscript) (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); } Perl_croak(aTHX_ "Permission denied\n"); @@ -2345,7 +2811,7 @@ S_validate_suid(pTHX_ char *validarg, char *scriptname, int fdscript) 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++; + CopLINE_inc(PL_curcop); if (sv_gets(PL_linestr, PL_rsfp, 0) == Nullch || strnNE(SvPV(PL_linestr,n_a),"#!",2) ) /* required even on Sys V */ Perl_croak(aTHX_ "No #! line"); @@ -2379,7 +2845,9 @@ 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(Perl_form(aTHX_ "%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 Perl_croak(aTHX_ "Can't do setuid\n"); } @@ -2461,7 +2929,9 @@ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n"); #if defined(HAS_FCNTL) && defined(F_SETFD) fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0); /* ensure no close-on-exec */ #endif - PerlProc_execv(Perl_form(aTHX_ "%s/perl%s", BIN_EXP, PL_patchlevel), PL_origargv);/* try again */ + 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 */ @@ -2503,10 +2973,9 @@ S_find_beginning(pTHX) 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) - Perl_croak(aTHX_ "Can't chdir to %s",PL_cddir); } } } @@ -2586,7 +3055,7 @@ Perl_init_stacks(pTHX) 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; @@ -2621,10 +3090,6 @@ S_nuke_stacks(pTHX) Safefree(PL_scopestack); Safefree(PL_savestack); Safefree(PL_retstack); - DEBUG( { - Safefree(PL_debname); - Safefree(PL_debdelim); - } ) } #ifndef PERL_OBJECT @@ -2649,7 +3114,6 @@ S_init_predump_symbols(pTHX) { dTHR; GV *tmpgv; - GV *othergv; IO *io; sv_setpvn(get_sv("\"", TRUE), " ", 1); @@ -2697,11 +3161,11 @@ S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register 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); } @@ -2718,21 +3182,28 @@ S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register 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); @@ -2768,8 +3239,8 @@ S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register #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 @@ -2780,9 +3251,9 @@ S_init_perllib(pTHX) #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 @@ -2791,50 +3262,77 @@ S_init_perllib(pTHX) 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 -#if defined(PERL_VENDORLIB_EXP) -#if defined(WIN32) - incpush(PERL_VENDORLIB_EXP, TRUE); -#else - incpush(PERL_VENDORLIB_EXP, FALSE); + +#ifdef PERL_VENDORARCH_EXP + /* vendorarch is always relative to vendorlib on Windows for + * DLL-based path intuition to work correctly */ +# if !defined(WIN32) + incpush(PERL_VENDORARCH_EXP, FALSE, FALSE); +# endif #endif + +#ifdef PERL_VENDORLIB_EXP +# if defined(WIN32) + incpush(PERL_VENDORLIB_EXP, TRUE, FALSE); /* this picks up vendorarch as well */ +# else + incpush(PERL_VENDORLIB_EXP, FALSE, FALSE); +# endif #endif + +#ifdef PERL_VENDORLIB_STEM /* Search for version-specific dirs below here */ + incpush(PERL_VENDORLIB_STEM, FALSE, TRUE); +#endif + +#ifdef PERL_OTHERLIBDIRS + incpush(PERL_OTHERLIBDIRS, TRUE, TRUE); +#endif + if (!PL_tainting) - incpush(".", FALSE); + incpush(".", FALSE, FALSE); } #if defined(DOSISH) @@ -2851,26 +3349,15 @@ S_init_perllib(pTHX) #endif STATIC void -S_incpush(pTHX_ 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 */ @@ -2899,7 +3386,12 @@ S_incpush(pTHX_ 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; @@ -2915,21 +3407,42 @@ S_incpush(pTHX_ char *p, int addsubdirs) "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), - newSVpvn(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), - newSVpvn(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 */ @@ -2985,7 +3498,7 @@ S_init_main_thread(pTHX) #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 @@ -3018,8 +3531,8 @@ void Perl_call_list(pTHX_ I32 oldscope, AV *paramList) { dTHR; - SV *atsv = ERRSV; - line_t oldline = PL_curcop->cop_line; + SV *atsv; + line_t oldline = CopLINE(PL_curcop); CV *cv; STRLEN len; int ret; @@ -3028,20 +3541,34 @@ Perl_call_list(pTHX_ I32 oldscope, AV *paramList) while (AvFILL(paramList) >= 0) { cv = (CV*)av_shift(paramList); SAVEFREESV(cv); - CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_call_list_body), cv); +#ifdef PERL_FLEXIBLE_EXCEPTIONS + CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_list_body), cv); +#else + JMPENV_PUSH(ret); +#endif switch (ret) { case 0: +#ifndef PERL_FLEXIBLE_EXCEPTIONS + call_list_body(cv); +#endif + atsv = ERRSV; (void)SvPV(atsv, len); if (len) { + STRLEN n_a; PL_curcop = &PL_compiling; - PL_curcop->cop_line = oldline; + CopLINE_set(PL_curcop, oldline); if (paramList == PL_beginav) sv_catpv(atsv, "BEGIN failed--compilation aborted"); else - sv_catpv(atsv, "END failed--cleanup aborted"); + 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; - Perl_croak(aTHX_ "%s", SvPVX(atsv)); + JMPENV_POP; + Perl_croak(aTHX_ "%s", SvPVx(atsv, n_a)); } break; case 1: @@ -3053,37 +3580,46 @@ Perl_call_list(pTHX_ I32 oldscope, AV *paramList) LEAVE; FREETMPS; PL_curstash = PL_defstash; - if (PL_endav && !PL_minus_c) - call_list(oldscope, PL_endav); 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) Perl_croak(aTHX_ "BEGIN failed--compilation aborted"); else - Perl_croak(aTHX_ "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) { PL_curcop = &PL_compiling; - PL_curcop->cop_line = oldline; + CopLINE_set(PL_curcop, oldline); JMPENV_JUMP(3); } PerlIO_printf(Perl_error_log, "panic: restartop\n"); FREETMPS; break; } + JMPENV_POP; } } +#ifdef PERL_FLEXIBLE_EXCEPTIONS STATIC void * -S_call_list_body(pTHX_ va_list args) +S_vcall_list_body(pTHX_ va_list args) { - dTHR; 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; @@ -3164,7 +3700,6 @@ S_my_exit_jump(pTHX) } #ifdef PERL_OBJECT -#define NO_XSLOCKS #include "XSUB.h" #endif @@ -3183,5 +3718,3 @@ read_e_script(pTHXo_ int idx, SV *buf_sv, int maxlen) sv_chop(PL_e_script, nl); return 1; } - -