X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=perl.c;h=7e9f07a4f41b57007c4b7434583051e96296a183;hb=706de38c2aa2b981f7071fda099501bf2cc8caeb;hp=b90bc7ba1470727bc0a28246a7a4225e53c834ec;hpb=a3635516d37f70bc16a39bf453a8d19cc1f3181b;p=p5sagit%2Fp5-mst-13.2.git diff --git a/perl.c b/perl.c index b90bc7b..7e9f07a 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. @@ -14,6 +14,7 @@ #include "EXTERN.h" #define PERL_IN_PERL_C #include "perl.h" +#include "patchlevel.h" /* for local_patches */ /* XXX If this causes problems, set i_unistd=undef in the hint file. */ #ifdef I_UNISTD @@ -26,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 @@ -46,26 +40,74 @@ static I32 read_e_script(pTHXo_ int idx, SV *buf_sv, int maxlen); #endif #ifdef PERL_OBJECT -CPerlObj* perl_alloc(IPerlMem* ipM, IPerlEnv* ipE, IPerlStdIO* ipStd, - IPerlLIO* ipLIO, IPerlDir* ipD, IPerlSock* ipS, IPerlProc* ipP) +#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 + +#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(); + PerlInterpreter *my_perl; +#ifdef PERL_OBJECT + my_perl = (PerlInterpreter*)new(ipM) CPerlObj(ipM, ipMS, ipMP, ipE, ipStd, + ipLIO, ipD, ipS, ipP); + PERL_SET_INTERP(my_perl); +#else + /* New() needs interpreter, so call malloc() instead */ + my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter)); + PERL_SET_INTERP(my_perl); + 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 pPerl; + return my_perl; } #else + +/* +=for apidoc perl_alloc + +Allocates a new Perl interpreter. See L. + +=cut +*/ + PerlInterpreter * perl_alloc(void) { PerlInterpreter *my_perl; - New(53, my_perl, 1, PerlInterpreter); + /* New() needs interpreter, so call malloc() instead */ + my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter)); PERL_SET_INTERP(my_perl); + 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. + +=cut +*/ void perl_construct(pTHXx) @@ -73,19 +115,22 @@ 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 */ #ifdef MULTIPLICITY - Zero(my_perl, 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 USE_THREADS #ifdef ALLOC_THREAD_KEY ALLOC_THREAD_KEY; #else @@ -110,7 +155,9 @@ perl_construct(pTHXx) 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 */ @@ -158,13 +205,6 @@ perl_construct(pTHXx) PL_rs = SvREFCNT_inc(PL_nrs); init_stacks(); -#ifdef MULTIPLICITY - init_interp(); - PL_perl_destruct_level = 1; -#else - if (PL_perl_destruct_level > 0) - init_interp(); -#endif init_ids(); PL_lex_state = LEX_NOTPARSING; @@ -174,14 +214,30 @@ perl_construct(pTHXx) init_i18nl10n(1); SET_NUMERIC_STANDARD(); + + { + U8 *s; + PL_patchlevel = NEWSV(0,4); + 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 */ @@ -192,14 +248,17 @@ 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); - } ) - ENTER; } +/* +=for apidoc perl_destruct + +Shuts down a Perl interpreter. See L. + +=cut +*/ + void perl_destruct(pTHXx) { @@ -212,12 +271,15 @@ 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 */ 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) { @@ -225,7 +287,7 @@ perl_destruct(pTHXx) 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); @@ -239,11 +301,11 @@ perl_destruct(pTHXx) 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); /* @@ -257,7 +319,7 @@ perl_destruct(pTHXx) 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); @@ -269,14 +331,14 @@ perl_destruct(pTHXx) /* 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) */ @@ -325,8 +387,6 @@ perl_destruct(pTHXx) 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) @@ -364,12 +424,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); @@ -378,10 +437,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); /* $/ */ @@ -390,7 +449,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; @@ -406,34 +467,117 @@ perl_destruct(pTHXx) 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; + /* Prepare to destruct main symbol table. */ hv = PL_defstash; PL_defstash = 0; SvREFCNT_dec(hv); + SvREFCNT_dec(PL_curstname); + PL_curstname = Nullsv; + + /* clear queued errors */ + SvREFCNT_dec(PL_errors); + PL_errors = Nullsv; FREETMPS; if (destruct_level >= 2 && ckWARN_d(WARN_INTERNAL)) { @@ -455,14 +599,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, @@ -494,19 +645,27 @@ 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; + + SvREFCNT(&PL_sv_no) = 0; + sv_clear(&PL_sv_no); + SvANY(&PL_sv_no) = NULL; + 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(); @@ -529,7 +688,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) { @@ -553,13 +712,21 @@ perl_destruct(pTHXx) } } +/* +=for apidoc perl_free + +Releases a Perl interpreter. See L. + +=cut +*/ + void perl_free(pTHXx) { #if defined(PERL_OBJECT) - Safefree(this); + PerlMem_free(this); #else - Safefree(aTHXx); + PerlMem_free(aTHXx); #endif } @@ -572,12 +739,21 @@ 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) { dTHR; I32 oldscope; int ret; + dJMPENV; #ifdef USE_THREADS dTHX; #endif @@ -626,10 +802,20 @@ setuid perl scripts securely.\n"); oldscope = PL_scopestack_ix; PL_dowarn = G_WARN_OFF; - CALLPROTECT(aTHX_ &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 */ @@ -639,23 +825,36 @@ setuid perl scripts securely.\n"); LEAVE; FREETMPS; PL_curstash = PL_defstash; - if (PL_endav) - 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(PerlIO_stderr(), "panic: top_env\n"); - return 1; + PerlIO_printf(Perl_error_log, "panic: top_env\n"); + 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; @@ -663,8 +862,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 */ @@ -688,6 +886,7 @@ S_parse_body(pTHX_ va_list args) #endif case ' ': case '0': + case 'C': case 'F': case 'a': case 'c': @@ -739,18 +938,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); + char *p; + STRLEN len = strlen(s); + p = savepvn(s, len); incpush(p, TRUE); - sv_catpv(sv,"-I"); - sv_catpv(sv,p); - sv_catpv(sv," "); + 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"); @@ -773,7 +972,6 @@ S_parse_body(pTHX_ va_list args) #else sv_catpv(PL_Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\","); #endif -#if defined(DEBUGGING) || defined(MULTIPLICITY) sv_catpv(PL_Sv,"\" Compile-time options:"); # ifdef DEBUGGING sv_catpv(PL_Sv," DEBUGGING"); @@ -781,8 +979,38 @@ S_parse_body(pTHX_ va_list args) # 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; @@ -820,7 +1048,7 @@ print \" \\@INC:\\n @INC\\n\";"); PL_doextract = TRUE; s++; if (*s) - PL_cddir = savepv(s); + cddir = s; break; case 0: break; @@ -850,7 +1078,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') @@ -893,8 +1122,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); @@ -923,10 +1171,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 @@ -955,7 +1206,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) { @@ -970,8 +1221,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; @@ -986,68 +1240,98 @@ 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; #endif oldscope = PL_scopestack_ix; +#ifdef PERL_FLEXIBLE_EXCEPTIONS redo_body: - CALLPROTECT(aTHX_ &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; 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 - return STATUS_NATIVE_EXPORT; + ret = STATUS_NATIVE_EXPORT; + break; case 3: if (PL_restartop) { POPSTACK_TO(PL_mainstack); goto redo_body; } - PerlIO_printf(PerlIO_stderr(), "panic: restartop\n"); + 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")); 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) @@ -1074,6 +1358,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) { @@ -1093,6 +1387,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) { @@ -1104,6 +1408,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) { @@ -1115,6 +1429,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) { @@ -1135,6 +1460,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) @@ -1154,6 +1487,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 */ @@ -1162,6 +1503,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 */ @@ -1169,17 +1519,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) @@ -1193,6 +1554,7 @@ Perl_call_sv(pTHX_ SV *sv, I32 flags) bool oldcatch = CATCH_GET; int ret; OP* oldop = PL_op; + dJMPENV; if (flags & G_DISCARD) { ENTER; @@ -1225,9 +1587,9 @@ 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(FALSE); + CATCH_SET(oldcatch); } else { cLOGOP->op_other = PL_op; @@ -1253,10 +1615,19 @@ Perl_call_sv(pTHX_ SV *sv, I32 flags) } PL_markstack_ptr++; - redo_body: - CALLPROTECT(aTHX_ &ret, MEMBER_TO_FPTR(S_call_body), (OP*)&myop, FALSE); +#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,""); @@ -1268,7 +1639,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 */ @@ -1301,6 +1673,7 @@ Perl_call_sv(pTHX_ SV *sv, I32 flags) PL_curpm = newpm; LEAVE; } + JMPENV_POP; } if (flags & G_DISCARD) { @@ -1313,18 +1686,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; @@ -1340,6 +1715,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) @@ -1352,6 +1735,7 @@ Perl_eval_sv(pTHX_ SV *sv, I32 flags) I32 oldscope; int ret; OP* oldop = PL_op; + dJMPENV; if (flags & G_DISCARD) { ENTER; @@ -1375,10 +1759,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_ &ret, MEMBER_TO_FPTR(S_call_body), (OP*)&myop, TRUE); + 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,""); @@ -1390,7 +1783,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 */ @@ -1410,6 +1804,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; @@ -1420,6 +1815,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) { @@ -1444,6 +1847,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) { @@ -1478,6 +1889,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)", @@ -1498,6 +1910,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 @@ -1521,7 +1935,7 @@ Perl_moreswitches(pTHX_ 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; @@ -1533,6 +1947,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); @@ -1606,14 +2024,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); + 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; @@ -1623,7 +2050,7 @@ Perl_moreswitches(pTHX_ 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 { @@ -1666,7 +2093,7 @@ Perl_moreswitches(pTHX_ char *s) sv_catpv(sv, "})"); } s += strlen(s); - if (PL_preambleav == NULL) + if (!PL_preambleav) PL_preambleav = newAV(); av_push(PL_preambleav, sv); } @@ -1700,20 +2127,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)", - 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 @@ -1749,6 +2171,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 @@ -1846,7 +2271,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; \ @@ -1856,7 +2280,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; \ @@ -1878,8 +2301,13 @@ S_init_interp(pTHX) # define PERLVAR(var,type) # define PERLVARA(var,n,type) # if defined(PERL_IMPLICIT_CONTEXT) -# define PERLVARI(var,type,init) my_perl->var = init; -# define PERLVARIC(var,type,init) my_perl->var = init; +# 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; @@ -1946,7 +2374,7 @@ 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)); /* We must init $/ before switches are processed. */ @@ -1981,7 +2409,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) { @@ -2000,7 +2428,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 @@ -2016,7 +2444,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 @@ -2032,7 +2460,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' \ @@ -2046,7 +2474,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, @@ -2095,24 +2523,26 @@ 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. */ @@ -2120,13 +2550,15 @@ sed %s -e \"/^[^#]/b\" \ 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 @@ -2134,24 +2566,45 @@ S_fd_on_nosuid_fs(pTHX_ 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; @@ -2171,11 +2624,12 @@ S_fd_on_nosuid_fs(pTHX_ 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) - Perl_croak(aTHX_ "Can't check filesystem of script \"%s\"", PL_origfilename); + Perl_croak(aTHX_ "Can't check filesystem of script \"%s\" for nosuid", PL_origfilename); return on_nosuid; } #endif /* IAMSUID */ @@ -2225,7 +2679,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 @@ -2246,7 +2700,7 @@ 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 (fd_on_nosuid_fs(PerlIO_fileno(PL_rsfp))) @@ -2257,12 +2711,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"); @@ -2288,7 +2742,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"); @@ -2322,7 +2776,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"); } @@ -2404,7 +2860,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 */ @@ -2448,8 +2906,6 @@ S_find_beginning(pTHX) /*SUPPRESS 530*/ while (s = moreswitches(s)) ; } - if (PL_cddir && PerlDir_chdir(PL_cddir) < 0) - Perl_croak(aTHX_ "Can't chdir to %s",PL_cddir); } } } @@ -2458,10 +2914,10 @@ S_find_beginning(pTHX) STATIC 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; @@ -2529,7 +2985,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; @@ -2564,10 +3020,6 @@ S_nuke_stacks(pTHX) Safefree(PL_scopestack); Safefree(PL_savestack); Safefree(PL_retstack); - DEBUG( { - Safefree(PL_debname); - Safefree(PL_debdelim); - } ) } #ifndef PERL_OBJECT @@ -2613,9 +3065,9 @@ S_init_predump_symbols(pTHX) GvMULTI_on(tmpgv); GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io); - othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO); - GvMULTI_on(othergv); - io = GvIOp(othergv); + 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); @@ -2640,7 +3092,7 @@ 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; } @@ -2666,7 +3118,11 @@ S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register magicname("0", "0", 1); } if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV)) +#ifdef OS2 + sv_setpv(GvSV(tmpgv), os2_execname()); +#else sv_setpv(GvSV(tmpgv),PL_origargv[0]); +#endif if (PL_argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) { GvMULTI_on(PL_argvgv); (void)gv_AVadd(PL_argvgv); @@ -2712,7 +3168,7 @@ S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register } TAINT_NOT; if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV)) - sv_setiv(GvSV(tmpgv), (IV)getpid()); + sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid()); } STATIC void @@ -2759,18 +3215,26 @@ S_init_perllib(pTHX) incpush(PRIVLIB_EXP, FALSE); #endif -#ifdef SITEARCH_EXP - incpush(SITEARCH_EXP, FALSE); -#endif -#ifdef SITELIB_EXP -#if defined(WIN32) - incpush(SITELIB_EXP, TRUE); +#if defined(WIN32) + incpush(SITELIB_EXP, TRUE); /* XXX Win32 needs inc_version_list support */ #else - incpush(SITELIB_EXP, FALSE); +#ifdef SITELIB_EXP + { + char *path = SITELIB_EXP; + + if (path) { + char buf[1024]; + strcpy(buf,path); + if (strrchr(buf,'/')) /* XXX Hack, Configure var needed */ + *strrchr(buf,'/') = '\0'; + incpush(buf, TRUE); + } + } +#endif #endif #if defined(PERL_VENDORLIB_EXP) #if defined(WIN32) - incpush(PERLVENDORLIB_EXP, TRUE); + incpush(PERL_VENDORLIB_EXP, TRUE); #else incpush(PERL_VENDORLIB_EXP, FALSE); #endif @@ -2802,17 +3266,6 @@ S_incpush(pTHX_ char *p, int addsubdirs) if (addsubdirs) { 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 */ @@ -2842,6 +3295,11 @@ S_incpush(pTHX_ char *p, int addsubdirs) * archname-specific sub-directories. */ if (addsubdirs) { +#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; @@ -2853,25 +3311,41 @@ S_incpush(pTHX_ 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); + /* .../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), - newSVpvn(SvPVX(subdir), SvCUR(subdir) - sizeof "auto")); + av_push(GvAVn(PL_incgv), newSVsv(subdir)); - /* .../archname if -d .../archname/auto */ - sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME), - strlen(PL_patchlevel) + 1, "", 0); + /* .../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), - newSVpvn(SvPVX(subdir), SvCUR(subdir) - sizeof "auto")); + 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 + 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 */ @@ -2895,7 +3369,6 @@ S_init_main_thread(pTHX) 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 */ @@ -2961,29 +3434,44 @@ 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; + dJMPENV; while (AvFILL(paramList) >= 0) { cv = (CV*)av_shift(paramList); SAVEFREESV(cv); - CALLPROTECT(aTHX_ &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: @@ -2995,37 +3483,46 @@ Perl_call_list(pTHX_ I32 oldscope, AV *paramList) LEAVE; FREETMPS; PL_curstash = PL_defstash; - if (PL_endav) - 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(PerlIO_stderr(), "panic: restartop\n"); + 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; @@ -3106,7 +3603,6 @@ S_my_exit_jump(pTHX) } #ifdef PERL_OBJECT -#define NO_XSLOCKS #include "XSUB.h" #endif @@ -3125,5 +3621,3 @@ read_e_script(pTHXo_ int idx, SV *buf_sv, int maxlen) sv_chop(PL_e_script, nl); return 1; } - -