X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/ed8ff0f310e9159df865ecc2e1d316816e8cc11e..577d3e04be845580196418dd9df1575e2cb4c0b6:/perl.c?ds=sidebyside diff --git a/perl.c b/perl.c index de45455..96ad0f6 100644 --- a/perl.c +++ b/perl.c @@ -3,7 +3,7 @@ * * Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001 * 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012 - * 2013, 2014, 2015, 2016 by Larry Wall and others + * 2013, 2014, 2015, 2016, 2017, 2018 by Larry Wall and others * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -22,6 +22,10 @@ * and destroy a perl interpreter, plus the functions used by XS code to * call back into perl. Note that it does not contain the actual main() * function of the interpreter; that can be found in perlmain.c + * + * Note that at build time this file is also linked to as perlmini.c, + * and perlmini.o is then built with PERL_IS_MINIPERL defined, which is + * then used to create the miniperl executable, rather than perl.o. */ #if defined(PERL_IS_MINIPERL) && !defined(USE_SITECUSTOMIZE) @@ -58,10 +62,6 @@ union control_un { # endif #endif -#if !defined(STANDARD_C) && !defined(HAS_GETENV_PROTOTYPE) && !defined(PERL_MICRO) -char *getenv (char *); /* Usually in */ -#endif - static I32 read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen); #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW @@ -92,7 +92,9 @@ S_init_tls_and_interp(PerlInterpreter *my_perl) PERL_SET_THX(my_perl); OP_REFCNT_INIT; OP_CHECK_MUTEX_INIT; + KEYWORD_PLUGIN_MUTEX_INIT; HINTS_REFCNT_INIT; + LOCALE_INIT; MUTEX_INIT(&PL_dollarzero_mutex); MUTEX_INIT(&PL_my_ctx_mutex); # endif @@ -213,6 +215,26 @@ Initializes a new Perl interpreter. See L. =cut */ +static void +S_fixup_platform_bugs(void) +{ +#if defined(__GLIBC__) && IVSIZE == 8 \ + && ( __GLIBC__ < 2 || (__GLIBC__ == 2 && __GLIBC_MINOR__ < 8)) + { + IV l = 3; + IV r = -10; + /* Cannot do this check with inlined IV constants since + * that seems to work correctly even with the buggy glibc. */ + if (l % r == -3) { + dTHX; + /* Yikes, we have the bug. + * Patch in the workaround version. */ + PL_ppaddr[OP_I_MODULO] = &Perl_pp_i_modulo_glibc_bugfix; + } + } +#endif +} + void perl_construct(pTHXx) { @@ -248,17 +270,70 @@ perl_construct(pTHXx) init_stacks(); +/* The PERL_INTERNAL_RAND_SEED set-up must be after init_stacks because it calls + * things that may put SVs on the stack. + */ + +#ifdef NO_PERL_INTERNAL_RAND_SEED + Perl_drand48_init_r(&PL_internal_random_state, seed()); +#else + { + UV seed; + const char *env_pv; + if (PerlProc_getuid() != PerlProc_geteuid() || + PerlProc_getgid() != PerlProc_getegid() || + !(env_pv = PerlEnv_getenv("PERL_INTERNAL_RAND_SEED")) || + grok_number(env_pv, strlen(env_pv), &seed) != IS_NUMBER_IN_UV) { + seed = seed(); + } + Perl_drand48_init_r(&PL_internal_random_state, (U32)seed); + } +#endif + init_ids(); + S_fixup_platform_bugs(); + JMPENV_BOOTSTRAP; STATUS_ALL_SUCCESS; + PL_XPosix_ptrs[_CC_ASCII] = _new_invlist_C_array(ASCII_invlist); + PL_XPosix_ptrs[_CC_ALPHANUMERIC] = _new_invlist_C_array(XPosixAlnum_invlist); + PL_XPosix_ptrs[_CC_ALPHA] = _new_invlist_C_array(XPosixAlpha_invlist); + PL_XPosix_ptrs[_CC_BLANK] = _new_invlist_C_array(XPosixBlank_invlist); + PL_XPosix_ptrs[_CC_CASED] = _new_invlist_C_array(Cased_invlist); + PL_XPosix_ptrs[_CC_CNTRL] = _new_invlist_C_array(XPosixCntrl_invlist); + PL_XPosix_ptrs[_CC_DIGIT] = _new_invlist_C_array(XPosixDigit_invlist); + PL_XPosix_ptrs[_CC_GRAPH] = _new_invlist_C_array(XPosixGraph_invlist); + PL_XPosix_ptrs[_CC_LOWER] = _new_invlist_C_array(XPosixLower_invlist); + PL_XPosix_ptrs[_CC_PRINT] = _new_invlist_C_array(XPosixPrint_invlist); + PL_XPosix_ptrs[_CC_PUNCT] = _new_invlist_C_array(XPosixPunct_invlist); + PL_XPosix_ptrs[_CC_SPACE] = _new_invlist_C_array(XPerlSpace_invlist); + PL_XPosix_ptrs[_CC_UPPER] = _new_invlist_C_array(XPosixUpper_invlist); + PL_XPosix_ptrs[_CC_VERTSPACE] = _new_invlist_C_array(VertSpace_invlist); + PL_XPosix_ptrs[_CC_WORDCHAR] = _new_invlist_C_array(XPosixWord_invlist); + PL_XPosix_ptrs[_CC_XDIGIT] = _new_invlist_C_array(XPosixXDigit_invlist); + PL_GCB_invlist = _new_invlist_C_array(_Perl_GCB_invlist); + PL_SB_invlist = _new_invlist_C_array(_Perl_SB_invlist); + PL_WB_invlist = _new_invlist_C_array(_Perl_WB_invlist); + PL_LB_invlist = _new_invlist_C_array(_Perl_LB_invlist); + PL_Assigned_invlist = _new_invlist_C_array(Assigned_invlist); + PL_SCX_invlist = _new_invlist_C_array(_Perl_SCX_invlist); + init_i18nl10n(1); #if defined(LOCAL_PATCH_COUNT) PL_localpatches = local_patches; /* For possible -v */ #endif +#if defined(LIBM_LIB_VERSION) + /* + * Some BSDs and Cygwin default to POSIX math instead of IEEE. + * This switches them over to IEEE. + */ + _LIB_VERSION = _IEEE_; +#endif + #ifdef HAVE_INTERP_INTERN sys_intern_init(); #endif @@ -268,9 +343,9 @@ perl_construct(pTHXx) PL_fdpid = newAV(); /* for remembering popen pids by fd */ PL_modglobal = newHV(); /* pointers to per-interpreter module globals */ PL_errors = newSVpvs(""); - sv_setpvs(PERL_DEBUG_PAD(0), ""); /* For regex debugging. */ - sv_setpvs(PERL_DEBUG_PAD(1), ""); /* ext/re needs these */ - sv_setpvs(PERL_DEBUG_PAD(2), ""); /* even without DEBUGGING. */ + SvPVCLEAR(PERL_DEBUG_PAD(0)); /* For regex debugging. */ + SvPVCLEAR(PERL_DEBUG_PAD(1)); /* ext/re needs these */ + SvPVCLEAR(PERL_DEBUG_PAD(2)); /* even without DEBUGGING. */ #ifdef USE_ITHREADS /* First entry is a list of empty elements. It needs to be initialised else all hell breaks loose in S_find_uninit_var(). */ @@ -281,27 +356,59 @@ perl_construct(pTHXx) #ifdef USE_REENTRANT_API Perl_reentrant_init(aTHX); #endif -#if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT) - /* [perl #22371] Algorimic Complexity Attack on Perl 5.6.1, 5.8.0 - * This MUST be done before any hash stores or fetches take place. - * If you set PL_hash_seed (and presumably also PL_hash_seed_set) - * yourself, it is your responsibility to provide a good random seed! - * You can also define PERL_HASH_SEED in compile time, see hv.h. - * - * XXX: fix this comment */ if (PL_hash_seed_set == FALSE) { + /* Initialize the hash seed and state at startup. This must be + * done very early, before ANY hashes are constructed, and once + * setup is fixed for the lifetime of the process. + * + * If you decide to disable the seeding process you should choose + * a suitable seed yourself and define PERL_HASH_SEED to a well chosen + * string. See hv_func.h for details. + */ +#if defined(USE_HASH_SEED) + /* get the hash seed from the environment or from an RNG */ Perl_get_hash_seed(aTHX_ PL_hash_seed); +#else + /* they want a hard coded seed, check that it is long enough */ + assert( strlen(PERL_HASH_SEED) >= PERL_HASH_SEED_BYTES ); +#endif + + /* now we use the chosen seed to initialize the state - + * in some configurations this may be a relatively speaking + * expensive operation, but we only have to do it once at startup */ + PERL_HASH_SEED_STATE(PERL_HASH_SEED,PL_hash_state); + +#ifdef PERL_USE_SINGLE_CHAR_HASH_CACHE + /* we can build a special cache for 0/1 byte keys, if people choose + * I suspect most of the time it is not worth it */ + { + char str[2]="\0"; + int i; + for (i=0;i<256;i++) { + str[0]= i; + PERL_HASH_WITH_STATE(PL_hash_state,PL_hash_chars[i],str,1); + } + PERL_HASH_WITH_STATE(PL_hash_state,PL_hash_chars[256],str,0); + } +#endif + /* at this point we have initialezed the hash function, and we can start + * constructing hashes */ PL_hash_seed_set= TRUE; } -#endif /* #if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT) */ - - /* Note that strtab is a rather special HV. Assumptions are made - about not iterating on it, and not adding tie magic to it. - It is properly deallocated in perl_destruct() */ - PL_strtab = newHV(); - HvSHAREKEYS_off(PL_strtab); /* mandatory */ - hv_ksplit(PL_strtab, 512); + /* Allow PL_strtab to be pre-initialized before calling perl_construct. + * can use a custom optimized PL_strtab hash before calling perl_construct */ + if (!PL_strtab) { + /* Note that strtab is a rather special HV. Assumptions are made + about not iterating on it, and not adding tie magic to it. + It is properly deallocated in perl_destruct() */ + PL_strtab = newHV(); + + /* SHAREKEYS tells us that the hash has its keys shared with PL_strtab, + * which is not the case with PL_strtab itself */ + HvSHAREKEYS_off(PL_strtab); /* mandatory */ + hv_ksplit(PL_strtab, 1 << 11); + } Zero(PL_sv_consts, SV_CONSTS_COUNT, SV*); @@ -336,23 +443,14 @@ perl_construct(pTHXx) PL_mmap_page_size = sysconf(_SC_MMAP_PAGE_SIZE); # endif if ((long) PL_mmap_page_size < 0) { - if (errno) { - SV * const error = ERRSV; - SvUPGRADE(error, SVt_PV); - Perl_croak(aTHX_ "panic: sysconf: %s", SvPV_nolen_const(error)); - } - else - Perl_croak(aTHX_ "panic: sysconf: pagesize unknown"); + Perl_croak(aTHX_ "panic: sysconf: %s", + errno ? Strerror(errno) : "pagesize unknown"); } } -#else -# ifdef HAS_GETPAGESIZE +#elif defined(HAS_GETPAGESIZE) PL_mmap_page_size = getpagesize(); -# else -# if defined(I_SYS_PARAM) && defined(PAGESIZE) +#elif defined(I_SYS_PARAM) && defined(PAGESIZE) PL_mmap_page_size = PAGESIZE; /* compiletime, bad */ -# endif -# endif #endif if (PL_mmap_page_size <= 0) Perl_croak(aTHX_ "panic: bad pagesize %" IVdf, @@ -373,26 +471,9 @@ perl_construct(pTHXx) /* Start with 1 bucket, for DFS. It's unlikely we'll need more. */ HvMAX(PL_registered_mros) = 0; - PL_XPosix_ptrs[_CC_ASCII] = _new_invlist_C_array(ASCII_invlist); - PL_XPosix_ptrs[_CC_ALPHANUMERIC] = _new_invlist_C_array(XPosixAlnum_invlist); - PL_XPosix_ptrs[_CC_ALPHA] = _new_invlist_C_array(XPosixAlpha_invlist); - PL_XPosix_ptrs[_CC_BLANK] = _new_invlist_C_array(XPosixBlank_invlist); - PL_XPosix_ptrs[_CC_CASED] = _new_invlist_C_array(Cased_invlist); - PL_XPosix_ptrs[_CC_CNTRL] = _new_invlist_C_array(XPosixCntrl_invlist); - PL_XPosix_ptrs[_CC_DIGIT] = _new_invlist_C_array(XPosixDigit_invlist); - PL_XPosix_ptrs[_CC_GRAPH] = _new_invlist_C_array(XPosixGraph_invlist); - PL_XPosix_ptrs[_CC_LOWER] = _new_invlist_C_array(XPosixLower_invlist); - PL_XPosix_ptrs[_CC_PRINT] = _new_invlist_C_array(XPosixPrint_invlist); - PL_XPosix_ptrs[_CC_PUNCT] = _new_invlist_C_array(XPosixPunct_invlist); - PL_XPosix_ptrs[_CC_SPACE] = _new_invlist_C_array(XPerlSpace_invlist); - PL_XPosix_ptrs[_CC_UPPER] = _new_invlist_C_array(XPosixUpper_invlist); - PL_XPosix_ptrs[_CC_VERTSPACE] = _new_invlist_C_array(VertSpace_invlist); - PL_XPosix_ptrs[_CC_WORDCHAR] = _new_invlist_C_array(XPosixWord_invlist); - PL_XPosix_ptrs[_CC_XDIGIT] = _new_invlist_C_array(XPosixXDigit_invlist); - PL_GCB_invlist = _new_invlist_C_array(_Perl_GCB_invlist); - PL_SB_invlist = _new_invlist_C_array(_Perl_SB_invlist); - PL_WB_invlist = _new_invlist_C_array(_Perl_WB_invlist); - PL_LB_invlist = _new_invlist_C_array(_Perl_LB_invlist); +#ifdef HAS_POSIX_2008_LOCALE + PL_C_locale_obj = newlocale(LC_ALL_MASK, "C", NULL); +#endif ENTER; } @@ -514,9 +595,33 @@ Perl_dump_sv_child(pTHX_ SV *sv) #endif /* -=for apidoc perl_destruct - -Shuts down a Perl interpreter. See L. +=for apidoc Am|int|perl_destruct|PerlInterpreter *my_perl + +Shuts down a Perl interpreter. See L for a tutorial. + +C points to the Perl interpreter. It must have been previously +created through the use of L and L. It may +have been initialised through L, and may have been used +through L and other means. This function should be called for +any Perl interpreter that has been constructed with L, +even if subsequent operations on it failed, for example if L +returned a non-zero value. + +If the interpreter's C word has the +C flag set, then this function will execute code +in C blocks before performing the rest of destruction. If it is +desired to make any use of the interpreter between L and +L other than just calling L, then this flag +should be set early on. This matters if L will not be called, +or if anything else will be done in addition to calling L. + +Returns a value be a suitable value to pass to the C library function +C (or to return from C
), to serve as an exit code indicating +the nature of the way the interpreter terminated. This takes into account +any failure of L and any early exit from L. +The exit code is of the type required by the host operating system, +so because of differing exit code conventions it is not portable to +interpret specific numeric values as having specific meanings. =cut */ @@ -525,7 +630,7 @@ int perl_destruct(pTHXx) { dVAR; - VOL signed char destruct_level; /* see possible values in intrpvar.h */ + volatile signed char destruct_level; /* see possible values in intrpvar.h */ HV *hv; #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP pid_t child; @@ -585,19 +690,42 @@ perl_destruct(pTHXx) assert(PL_scopestack_ix == 0); /* Need to flush since END blocks can produce output */ + /* flush stdout separately, since we can identify it */ +#ifdef USE_PERLIO + { + PerlIO *stdo = PerlIO_stdout(); + if (*stdo && PerlIO_flush(stdo)) { + PerlIO_restore_errno(stdo); + if (errno) + PerlIO_printf(PerlIO_stderr(), "Unable to flush stdout: %s\n", + Strerror(errno)); + if (!STATUS_UNIX) + STATUS_ALL_FAILURE; + } + } +#endif my_fflush_all(); #ifdef PERL_TRACE_OPS - /* If we traced all Perl OP usage, report and clean up */ + /* dump OP-counts if $ENV{PERL_TRACE_OPS} > 0 */ + { + const char * const ptoenv = PerlEnv_getenv("PERL_TRACE_OPS"); + UV uv; + + if (!ptoenv || !Perl_grok_atoUV(ptoenv, &uv, NULL) + || !(uv > 0)) + goto no_trace_out; + } PerlIO_printf(Perl_debug_log, "Trace of all OPs executed:\n"); for (i = 0; i <= OP_max; ++i) { - PerlIO_printf(Perl_debug_log, " %s: %"UVuf"\n", PL_op_name[i], PL_op_exec_cnt[i]); - PL_op_exec_cnt[i] = 0; + if (PL_op_exec_cnt[i]) + PerlIO_printf(Perl_debug_log, " %s: %" UVuf "\n", PL_op_name[i], PL_op_exec_cnt[i]); } /* Utility slot for easily doing little tracing experiments in the runloop: */ if (PL_op_exec_cnt[OP_max+1] != 0) - PerlIO_printf(Perl_debug_log, " SPECIAL: %"UVuf"\n", PL_op_exec_cnt[OP_max+1]); + PerlIO_printf(Perl_debug_log, " SPECIAL: %" UVuf "\n", PL_op_exec_cnt[OP_max+1]); PerlIO_printf(Perl_debug_log, "\n"); + no_trace_out: #endif @@ -616,7 +744,7 @@ perl_destruct(pTHXx) fail gracefully */ int fd[2]; - if(socketpair(AF_UNIX, SOCK_STREAM, 0, fd)) { + if(PerlSock_socketpair_cloexec(AF_UNIX, SOCK_STREAM, 0, fd)) { perror("Debug leaking scalars socketpair failed"); abort(); } @@ -715,7 +843,7 @@ perl_destruct(pTHXx) back into Perl_debug_log, as if we never actually closed it */ if(got_fd != debug_fd) { - if (dup2(got_fd, debug_fd) == -1) { + if (PerlLIO_dup2_cloexec(got_fd, debug_fd) == -1) { where = "dup2"; goto abort; } @@ -1026,6 +1154,24 @@ perl_destruct(pTHXx) PL_numeric_radix_sv = NULL; #endif + if (PL_langinfo_buf) { + Safefree(PL_langinfo_buf); + PL_langinfo_buf = NULL; + } + +#ifdef USE_POSIX_2008_LOCALE +# ifdef USE_LOCALE_NUMERIC + + if (PL_underlying_numeric_obj) { + /* Make sure we aren't using the locale space we are about to free */ + uselocale(LC_GLOBAL_LOCALE); + freelocale(PL_underlying_numeric_obj); + PL_underlying_numeric_obj = (locale_t) NULL; + } + +# endif +#endif + /* clear character classes */ for (i = 0; i < POSIX_SWASH_COUNT; i++) { SvREFCNT_dec(PL_utf8_swash_ptrs[i]); @@ -1073,7 +1219,9 @@ perl_destruct(pTHXx) PL_GCB_invlist = NULL; PL_LB_invlist = NULL; PL_SB_invlist = NULL; + PL_SCX_invlist = NULL; PL_WB_invlist = NULL; + PL_Assigned_invlist = NULL; if (!specialWARN(PL_compiling.cop_warnings)) PerlMemShared_free(PL_compiling.cop_warnings); @@ -1086,7 +1234,7 @@ perl_destruct(pTHXx) hv = PL_defstash; /* break ref loop *:: <=> %:: */ - (void)hv_delete(hv, "main::", 6, G_DISCARD); + (void)hv_deletes(hv, "main::", G_DISCARD); PL_defstash = 0; SvREFCNT_dec(hv); SvREFCNT_dec(PL_curstname); @@ -1205,6 +1353,11 @@ perl_destruct(pTHXx) SvANY(&PL_sv_no) = NULL; SvFLAGS(&PL_sv_no) = 0; + SvREFCNT(&PL_sv_zero) = 0; + sv_clear(&PL_sv_zero); + SvANY(&PL_sv_zero) = NULL; + SvFLAGS(&PL_sv_zero) = 0; + { int i; for (i=0; i<=2; i++) { @@ -1231,8 +1384,8 @@ perl_destruct(pTHXx) PerlIO_printf(Perl_debug_log, "leaked: sv=0x%p" " flags=0x%"UVxf " refcnt=%"UVuf pTHX__FORMAT "\n" - "\tallocated at %s:%d %s %s (parent 0x%"UVxf");" - "serial %"UVuf"\n", + "\tallocated at %s:%d %s %s (parent 0x%" UVxf ");" + "serial %" UVuf "\n", (void*)sv, (UV)sv->sv_flags, (UV)sv->sv_refcnt pTHX__VALUE, sv->sv_debug_file ? sv->sv_debug_file : "(unknown)", @@ -1457,9 +1610,61 @@ Perl_call_atexit(pTHX_ ATEXIT_t fn, void *ptr) } /* -=for apidoc perl_parse - -Tells a Perl interpreter to parse a Perl script. See L. +=for apidoc Am|int|perl_parse|PerlInterpreter *my_perl|XSINIT_t xsinit|int argc|char **argv|char **env + +Tells a Perl interpreter to parse a Perl script. This performs most +of the initialisation of a Perl interpreter. See L for +a tutorial. + +C points to the Perl interpreter that is to parse the script. +It must have been previously created through the use of L +and L. C points to a callback function that +will be called to set up the ability for this Perl interpreter to load +XS extensions, or may be null to perform no such setup. + +C and C supply a set of command-line arguments to the Perl +interpreter, as would normally be passed to the C
function of +a C program. C must be null. These arguments are where +the script to parse is specified, either by naming a script file or by +providing a script in a C<-e> option. +If L|perlvar/$0> will be written to in the Perl interpreter, then +the argument strings must be in writable memory, and so mustn't just be +string constants. + +C specifies a set of environment variables that will be used by +this Perl interpreter. If non-null, it must point to a null-terminated +array of environment strings. If null, the Perl interpreter will use +the environment supplied by the C global variable. + +This function initialises the interpreter, and parses and compiles the +script specified by the command-line arguments. This includes executing +code in C, C, and C blocks. It does not execute +C blocks or the main program. + +Returns an integer of slightly tricky interpretation. The correct +use of the return value is as a truth value indicating whether there +was a failure in initialisation. If zero is returned, this indicates +that initialisation was successful, and it is safe to proceed to call +L and make other use of it. If a non-zero value is returned, +this indicates some problem that means the interpreter wants to terminate. +The interpreter should not be just abandoned upon such failure; the caller +should proceed to shut the interpreter down cleanly with L +and free it with L. + +For historical reasons, the non-zero return value also attempts to +be a suitable value to pass to the C library function C (or to +return from C
), to serve as an exit code indicating the nature +of the way initialisation terminated. However, this isn't portable, +due to differing exit code conventions. A historical bug is preserved +for the time being: if the Perl built-in C is called during this +function's execution, with a type of exit entailing a zero exit code +under the host operating system's conventions, then this function +returns zero rather than a non-zero value. This bug, [perl #2754], +leads to C being called (and therefore C blocks and the +main program running) despite a call to C. It has been preserved +because a popular module-installing module has come to rely on it and +needs time to be fixed. This issue is [perl #132577], and the original +bug is due to be fixed in Perl 5.30. =cut */ @@ -1482,7 +1687,7 @@ perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env) #ifndef MULTIPLICITY PERL_UNUSED_ARG(my_perl); #endif -#if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT) || defined(USE_HASH_SEED_DEBUG) +#if (defined(USE_HASH_SEED) || defined(USE_HASH_SEED_DEBUG)) && !defined(NO_PERL_HASH_SEED_DEBUG) { const char * const s = PerlEnv_getenv("PERL_HASH_SEED_DEBUG"); @@ -1501,7 +1706,7 @@ perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env) PerlIO_printf(Perl_debug_log, "\n"); } } -#endif /* #if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT) */ +#endif /* #if (defined(USE_HASH_SEED) ... */ #ifdef __amigaos4__ { @@ -1510,6 +1715,13 @@ perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env) } #endif + { + int i; + assert(argc >= 0); + for(i = 0; i != argc; i++) + assert(argv[i]); + assert(!argv[argc]); + } PL_origargc = argc; PL_origargv = argv; @@ -1525,7 +1737,6 @@ perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env) * the original argv[0]. (See below for 'contiguous', though.) * --jhi */ const char *s = NULL; - int i; const UV mask = ~(UV)(PTRSIZE-1); /* Do the mask check only if the args seem like aligned. */ const UV aligned = @@ -1541,6 +1752,7 @@ perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env) * like the argv[] interleaved with some other data, we are * fine. (Did I just evoke Murphy's Law?) --jhi */ if (PL_origargv && PL_origargc >= 1 && (s = PL_origargv[0])) { + int i; while (*s) s++; for (i = 1; i < PL_origargc; i++) { if ((PL_origargv[i] == s + 1 @@ -1574,6 +1786,7 @@ perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env) INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask))) ) { + int i; #ifndef OS2 /* ENVIRON is read by the kernel too. */ s = PL_origenviron[0]; while (*s) s++; @@ -1660,6 +1873,15 @@ perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env) call_list(oldscope, PL_checkav); } ret = STATUS_EXIT; + if (ret == 0) { + /* + * At this point we should do + * ret = 0x100; + * to avoid [perl #2754], but that bugfix has been postponed + * because of the Module::Install breakage it causes + * [perl #132577]. + */ + } break; case 3: PerlIO_printf(Perl_error_log, "panic: top_env\n"); @@ -1750,6 +1972,9 @@ S_Internals_V(pTHX_ CV *cv) # ifdef PERL_MEM_LOG_NOIMPL " PERL_MEM_LOG_NOIMPL" # endif +# ifdef PERL_OP_PARENT + " PERL_OP_PARENT" +# endif # ifdef PERL_PERTURB_KEYS_DETERMINISTIC " PERL_PERTURB_KEYS_DETERMINISTIC" # endif @@ -1771,6 +1996,9 @@ S_Internals_V(pTHX_ CV *cv) # ifdef PERL_USE_SAFE_PUTENV " PERL_USE_SAFE_PUTENV" # endif +# ifdef SILENT_NO_TAINT_SUPPORT + " SILENT_NO_TAINT_SUPPORT" +# endif # ifdef UNLINK_ALL_VERSIONS " UNLINK_ALL_VERSIONS" # endif @@ -1780,9 +2008,6 @@ S_Internals_V(pTHX_ CV *cv) # ifdef USE_FAST_STDIO " USE_FAST_STDIO" # endif -# ifdef USE_HASH_SEED_EXPLICIT - " USE_HASH_SEED_EXPLICIT" -# endif # ifdef USE_LOCALE " USE_LOCALE" # endif @@ -2098,6 +2323,21 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) } } +#ifndef NO_PERL_INTERNAL_RAND_SEED + /* If we're not set[ug]id, we might have honored + PERL_INTERNAL_RAND_SEED in perl_construct(). + At this point command-line options have been parsed, so if + we're now tainting and not set[ug]id re-seed. + This could possibly be wasteful if PERL_INTERNAL_RAND_SEED is invalid, + but avoids duplicating the logic from perl_construct(). + */ + if (PL_tainting && + PerlProc_getuid() == PerlProc_geteuid() && + PerlProc_getgid() == PerlProc_getegid()) { + Perl_drand48_init_r(&PL_internal_random_state, seed()); + } +#endif + /* Set $^X early so that it can be used for relocatable paths in @INC */ /* and for SITELIB_EXP in USE_SITECUSTOMIZE */ assert (!TAINT_get); @@ -2120,7 +2360,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) it should be reported immediately as a build failure. */ (void)Perl_av_create_and_unshift_one(aTHX_ &PL_preambleav, Perl_newSVpvf(aTHX_ - "BEGIN { my $f = q%c%s%"SVf"/buildcustomize.pl%c; " + "BEGIN { my $f = q%c%s%" SVf "/buildcustomize.pl%c; " "do {local $!; -f $f }" " and do $f || die $@ || qq '$f: $!' }", 0, (TAINTING_get ? "./" : ""), SVfARG(*inc0), 0)); @@ -2241,6 +2481,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) /* PL_unicode is turned on by -C, or by $ENV{PERL_UNICODE}, * or explicitly in some platforms. + * PL_utf8locale is conditionally turned on by * locale.c:Perl_init_i18nl10n() if the environment * look like the user wants to use UTF-8. */ #if defined(__SYMBIAN32__) @@ -2312,12 +2553,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) SETERRNO(0,SS_NORMAL); if (yyparse(GRAMPROG) || PL_parser->error_count) { - if (PL_minus_c) - Perl_croak(aTHX_ "%s had compilation errors.\n", PL_origfilename); - else { - Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n", - PL_origfilename); - } + abort_execution("", PL_origfilename); } CopLINE_set(PL_curcop, 0); SET_CURSTASH(PL_defstash); @@ -2355,9 +2591,47 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) } /* -=for apidoc perl_run - -Tells a Perl interpreter to run. See L. +=for apidoc Am|int|perl_run|PerlInterpreter *my_perl + +Tells a Perl interpreter to run its main program. See L +for a tutorial. + +C points to the Perl interpreter. It must have been previously +created through the use of L and L, and +initialised through L. This function should not be called +if L returned a non-zero value, indicating a failure in +initialisation or compilation. + +This function executes code in C blocks, and then executes the +main program. The code to be executed is that established by the prior +call to L. If the interpreter's C word +does not have the C flag set, then this function +will also execute code in C blocks. If it is desired to make any +further use of the interpreter after calling this function, then C +blocks should be postponed to L time by setting that flag. + +Returns an integer of slightly tricky interpretation. The correct use +of the return value is as a truth value indicating whether the program +terminated non-locally. If zero is returned, this indicates that +the program ran to completion, and it is safe to make other use of the +interpreter (provided that the C flag was set as +described above). If a non-zero value is returned, this indicates that +the interpreter wants to terminate early. The interpreter should not be +just abandoned because of this desire to terminate; the caller should +proceed to shut the interpreter down cleanly with L +and free it with L. + +For historical reasons, the non-zero return value also attempts to +be a suitable value to pass to the C library function C (or to +return from C
), to serve as an exit code indicating the nature of +the way the program terminated. However, this isn't portable, due to +differing exit code conventions. An attempt is made to return an exit +code of the type required by the host operating system, but because +it is constrained to be non-zero, it is not necessarily possible to +indicate every type of exit. It is only reliable on Unix, where a zero +exit code can be augmented with a set bit that will be ignored. In any +case, this function is not the correct place to acquire an exit code: +one should get that from L. =cut */ @@ -2366,7 +2640,7 @@ int perl_run(pTHXx) { I32 oldscope; - int ret = 0; + int ret = 0, exit_called = 0; dJMPENV; PERL_ARGS_ASSERT_PERL_RUN; @@ -2387,8 +2661,10 @@ perl_run(pTHXx) case 0: /* normal completion */ redo_body: run_body(oldscope); - /* FALLTHROUGH */ + goto handle_exit; case 2: /* my_exit() */ + exit_called = 1; + handle_exit: while (PL_scopestack_ix > oldscope) LEAVE; FREETMPS; @@ -2402,7 +2678,12 @@ perl_run(pTHXx) if (PerlEnv_getenv("PERL_DEBUG_MSTATS")) dump_mstats("after execution: "); #endif - ret = STATUS_EXIT; + if (exit_called) { + ret = STATUS_EXIT; + if (ret == 0) ret = 0x100; + } else { + ret = 0; + } break; case 3: if (PL_restartop) { @@ -2577,6 +2858,9 @@ Perl_get_cvn_flags(pTHX_ const char *name, STRLEN len, I32 flags) PERL_ARGS_ASSERT_GET_CVN_FLAGS; + if (gv && UNLIKELY(SvROK(gv)) && SvTYPE(SvRV((SV *)gv)) == SVt_PVCV) + return (CV*)SvRV((SV *)gv); + /* XXX this is probably not what they think they're getting. * It has the same effect as "sub name;", i.e. just a forward * declaration! */ @@ -2703,14 +2987,14 @@ See L. */ I32 -Perl_call_sv(pTHX_ SV *sv, VOL I32 flags) +Perl_call_sv(pTHX_ SV *sv, volatile I32 flags) /* See G_* flags in cop.h */ { dVAR; LOGOP myop; /* fake syntax tree node */ METHOP method_op; I32 oldmark; - VOL I32 retval = 0; + volatile I32 retval = 0; bool oldcatch = CATCH_GET; int ret; OP* const oldop = PL_op; @@ -2780,7 +3064,7 @@ Perl_call_sv(pTHX_ SV *sv, VOL I32 flags) (void)POPMARK; old_cxix = cxstack_ix; create_eval_scope(NULL, flags|G_FAKINGEVAL); - (void)INCMARK; + INCMARK; JMPENV_PUSH(ret); @@ -2858,8 +3142,8 @@ Perl_eval_sv(pTHX_ SV *sv, I32 flags) { dVAR; UNOP myop; /* fake syntax tree node */ - VOL I32 oldmark; - VOL I32 retval = 0; + volatile I32 oldmark; + volatile I32 retval = 0; int ret; OP* const oldop = PL_op; dJMPENV; @@ -2893,7 +3177,7 @@ Perl_eval_sv(pTHX_ SV *sv, I32 flags) myop.op_private = (OPpEVAL_COPHH | OPpEVAL_RE_REPARSING); /* fail now; otherwise we could fail after the JMPENV_PUSH but - * before a CX_PUSHEVAL, which corrupts the stack after a croak */ + * before a cx_pusheval(), which corrupts the stack after a croak */ TAINT_PROPER("eval_sv()"); JMPENV_PUSH(ret); @@ -3099,6 +3383,7 @@ Perl_get_debug_opts(pTHX_ const char **s, bool givehelp) " M trace smart match resolution\n" " B dump suBroutine definitions, including special Blocks like BEGIN\n", " L trace some locale setting information--for Perl core development\n", + " i trace PerlIO layer processing\n", NULL }; UV uv = 0; @@ -3107,7 +3392,7 @@ Perl_get_debug_opts(pTHX_ const char **s, bool givehelp) if (isALPHA(**s)) { /* if adding extra options, remember to update DEBUG_MASK */ - static const char debopts[] = "psltocPmfrxuUHXDSTRJvCAqMBL"; + static const char debopts[] = "psltocPmfrxuUHXDSTRJvCAqMBLi"; for (; isWORDCHAR(**s); (*s)++) { const char * const d = strchr(debopts,**s); @@ -3165,8 +3450,7 @@ Perl_moreswitches(pTHX_ const char *s) s--; } PL_rs = newSVpvs(""); - SvGROW(PL_rs, (STRLEN)(UVCHR_SKIP(rschar) + 1)); - tmps = (U8*)SvPVX(PL_rs); + tmps = (U8*) SvGROW(PL_rs, (STRLEN)(UVCHR_SKIP(rschar) + 1)); uvchr_to_utf8(tmps, rschar); SvCUR_set(PL_rs, UVCHR_SKIP(rschar)); SvUTF8_on(PL_rs); @@ -3276,12 +3560,6 @@ Perl_moreswitches(pTHX_ const char *s) case 'i': Safefree(PL_inplace); -#if defined(__CYGWIN__) /* do backup extension automagically */ - if (*(s+1) == '\0') { - PL_inplace = savepvs(".bak"); - return s+1; - } -#endif /* __CYGWIN__ */ { const char * const start = ++s; while (*s && !isSPACE(*s)) @@ -3289,11 +3567,6 @@ Perl_moreswitches(pTHX_ const char *s) PL_inplace = savepvn(start, s - start); } - if (*s) { - ++s; - if (*s == '-') /* Additional switches on #! line. */ - s++; - } return s; case 'I': /* -I handled both here and in parse_body() */ forbid_setid('I', FALSE); @@ -3526,7 +3799,7 @@ S_minus_v(pTHX) "\nThis is perl " STRINGIFY(PERL_REVISION) ", version " STRINGIFY(PERL_VERSION) ", subversion " STRINGIFY(PERL_SUBVERSION) - " (%"SVf") built for " ARCHNAME, SVfARG(level) + " (%" SVf ") built for " ARCHNAME, SVfARG(level) ); SvREFCNT_dec_NN(level); } @@ -3540,7 +3813,7 @@ S_minus_v(pTHX) #endif PerlIO_printf(PIO_stdout, - "\n\nCopyright 1987-2016, Larry Wall\n"); + "\n\nCopyright 1987-2018, Larry Wall\n"); #ifdef MSDOS PerlIO_printf(PIO_stdout, "\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n"); @@ -3663,8 +3936,9 @@ STATIC void S_init_main_stash(pTHX) { GV *gv; + HV *hv = newHV(); - PL_curstash = PL_defstash = (HV *)SvREFCNT_inc_simple_NN(newHV()); + PL_curstash = PL_defstash = (HV *)SvREFCNT_inc_simple_NN(hv); /* We know that the string "main" will be in the global shared string table, so it's a small saving to use it rather than allocate another 8 bytes. */ @@ -3675,7 +3949,7 @@ S_init_main_stash(pTHX) because otherwise all we do is delete "main" from it as a consequence of the SvREFCNT_dec, only to add it again with hv_name_set */ SvREFCNT_dec(GvHV(gv)); - hv_name_set(PL_defstash, "main", 4, 0); + hv_name_sets(PL_defstash, "main", 0); GvHV(gv) = MUTABLE_HV(SvREFCNT_inc_simple(PL_defstash)); SvREADONLY_on(gv); PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpvs("INC", GV_ADD|GV_NOTQUAL, @@ -3699,7 +3973,6 @@ S_init_main_stash(pTHX) #endif sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */ CLEAR_ERRSV(); - SET_CURSTASH(PL_defstash); CopSTASH_set(&PL_compiling, PL_defstash); PL_debstash = GvHV(gv_fetchpvs("DB::", GV_ADDMULTI, SVt_PVHV)); PL_globalstash = GvHV(gv_fetchpvs("CORE::GLOBAL::", GV_ADDMULTI, @@ -3727,7 +4000,7 @@ S_open_script(pTHX_ const char *scriptname, bool dosearch, bool *suidscript) /* if find_script() returns, it returns a malloc()-ed value */ scriptname = PL_origfilename = find_script(scriptname, dosearch, NULL, 1); - if (strnEQ(scriptname, "/dev/fd/", 8) + if (strBEGINs(scriptname, "/dev/fd/") && isDIGIT(scriptname[8]) && grok_atoUV(scriptname + 8, &uv, &s) && uv <= PERL_INT_MAX @@ -3789,29 +4062,19 @@ S_open_script(pTHX_ const char *scriptname, bool dosearch, bool *suidscript) }; const char * const err = "Failed to create a fake bit bucket"; if (strEQ(scriptname, BIT_BUCKET)) { -#ifdef HAS_MKSTEMP /* Hopefully mkstemp() is safe here. */ - int old_umask = umask(0177); - int tmpfd = mkstemp(tmpname); - umask(old_umask); + int tmpfd = Perl_my_mkstemp_cloexec(tmpname); if (tmpfd > -1) { scriptname = tmpname; close(tmpfd); } else Perl_croak(aTHX_ err); -#else -# ifdef HAS_MKTEMP - scriptname = mktemp(tmpname); - if (!scriptname) - Perl_croak(aTHX_ err); -# endif -#endif } #endif rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE); #ifdef FAKE_BIT_BUCKET - if (memEQ(scriptname, FAKE_BIT_BUCKET_PREFIX, - sizeof(FAKE_BIT_BUCKET_PREFIX) - 1) - && strlen(scriptname) == sizeof(tmpname) - 1) { + if ( strBEGINs(scriptname, FAKE_BIT_BUCKET_PREFIX) + && strlen(scriptname) == sizeof(tmpname) - 1) + { unlink(scriptname); } scriptname = BIT_BUCKET; @@ -3820,21 +4083,12 @@ S_open_script(pTHX_ const char *scriptname, bool dosearch, bool *suidscript) if (!rsfp) { /* PSz 16 Sep 03 Keep neat error message */ if (PL_e_script) - Perl_croak(aTHX_ "Can't open "BIT_BUCKET": %s\n", Strerror(errno)); + Perl_croak(aTHX_ "Can't open " BIT_BUCKET ": %s\n", Strerror(errno)); else Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n", CopFILE(PL_curcop), Strerror(errno)); } fd = PerlIO_fileno(rsfp); -#if defined(HAS_FCNTL) && defined(F_SETFD) && defined(FD_CLOEXEC) - if (fd >= 0) { - /* ensure close-on-exec */ - if (fcntl(fd, F_SETFD, FD_CLOEXEC) < 0) { - Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n", - CopFILE(PL_curcop), Strerror(errno)); - } - } -#endif if (fd < 0 || (PerlLIO_fstat(fd, &tmpstatbuf) >= 0 @@ -3846,12 +4100,20 @@ S_open_script(pTHX_ const char *scriptname, bool dosearch, bool *suidscript) return rsfp; } -/* Mention +/* In the days of suidperl, we refused to execute a setuid script stored on + * a filesystem mounted nosuid and/or noexec. This meant that we probed for the + * existence of the appropriate filesystem-statting function, and behaved + * accordingly. But even though suidperl is long gone, we must still include + * those probes for the benefit of modules like Filesys::Df, which expect the + * results of those probes to be stored in %Config; see RT#126368. So mention + * the relevant cpp symbols here, to ensure that metaconfig will include their + * probes in the generated Configure: + * * I_SYSSTATVFS HAS_FSTATVFS * I_SYSMOUNT * I_STATFS HAS_FSTATFS HAS_GETFSSTAT * I_MNTENT HAS_GETMNTENT HAS_HASMNTOPT - * here so that metaconfig picks them up. */ + */ #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW @@ -3908,7 +4170,7 @@ S_find_beginning(pTHX_ SV* linestr_sv, PerlIO *rsfp) if (*s++ == '-') { while (isDIGIT(s2[-1]) || s2[-1] == '-' || s2[-1] == '.' || s2[-1] == '_') s2--; - if (strnEQ(s2-4,"perl",4)) + if (strBEGINs(s2-4,"perl")) while ((s = moreswitches(s))) ; } @@ -4084,6 +4346,9 @@ Perl_init_stacks(pTHX) PL_curstackinfo = new_stackinfo(REASONABLE(128), REASONABLE(8192/sizeof(PERL_CONTEXT) - 1)); PL_curstackinfo->si_type = PERLSI_MAIN; +#if defined DEBUGGING && !defined DEBUGGING_RE_ONLY + PL_curstackinfo->si_stack_hwm = 0; +#endif PL_curstack = PL_curstackinfo->si_stack; PL_mainstack = PL_curstack; /* remember in case we switch stacks */ @@ -4290,9 +4555,9 @@ S_init_postdump_symbols(pTHX_ int argc, char **argv, char **env) PERL_ARGS_ASSERT_INIT_POSTDUMP_SYMBOLS; PL_toptarget = newSV_type(SVt_PVIV); - sv_setpvs(PL_toptarget, ""); + SvPVCLEAR(PL_toptarget); PL_bodytarget = newSV_type(SVt_PVIV); - sv_setpvs(PL_bodytarget, ""); + SvPVCLEAR(PL_bodytarget); PL_formtarget = PL_bodytarget; TAINT; @@ -4329,23 +4594,70 @@ S_init_postdump_symbols(pTHX_ int argc, char **argv, char **env) } if (env) { char *s, *old_var; + STRLEN nlen; SV *sv; + HV *dups = newHV(); + for (; *env; env++) { old_var = *env; if (!(s = strchr(old_var,'=')) || s == old_var) continue; + nlen = s - old_var; #if defined(MSDOS) && !defined(DJGPP) *s = '\0'; (void)strupr(old_var); *s = '='; #endif - sv = newSVpv(s+1, 0); - (void)hv_store(hv, old_var, s - old_var, sv, 0); + if (hv_exists(hv, old_var, nlen)) { + const char *name = savepvn(old_var, nlen); + + /* make sure we use the same value as getenv(), otherwise code that + uses getenv() (like setlocale()) might see a different value to %ENV + */ + sv = newSVpv(PerlEnv_getenv(name), 0); + + /* keep a count of the dups of this name so we can de-dup environ later */ + if (hv_exists(dups, name, nlen)) + ++SvIVX(*hv_fetch(dups, name, nlen, 0)); + else + (void)hv_store(dups, name, nlen, newSViv(1), 0); + + Safefree(name); + } + else { + sv = newSVpv(s+1, 0); + } + (void)hv_store(hv, old_var, nlen, sv, 0); if (env_is_not_environ) mg_set(sv); } + if (HvKEYS(dups)) { + /* environ has some duplicate definitions, remove them */ + HE *entry; + hv_iterinit(dups); + while ((entry = hv_iternext_flags(dups, 0))) { + STRLEN nlen; + const char *name = HePV(entry, nlen); + IV count = SvIV(HeVAL(entry)); + IV i; + SV **valp = hv_fetch(hv, name, nlen, 0); + + assert(valp); + + /* try to remove any duplicate names, depending on the + * implementation used in my_setenv() the iteration might + * not be necessary, but let's be safe. + */ + for (i = 0; i < count; ++i) + my_setenv(name, 0); + + /* and set it back to the value we set $ENV{name} to */ + my_setenv(name, SvPV_nolen(*valp)); + } + } + SvREFCNT_dec_NN(dups); } #endif /* USE_ENVIRON_ARRAY */ #endif /* !PERL_MICRO */ @@ -4410,150 +4722,41 @@ S_init_perllib(pTHX) /* miniperl gets just -I..., the split of $ENV{PERL5LIB}, and "." in @INC (and not the architecture specific directories from $ENV{PERL5LIB}) */ +#include "perl_inc_macro.h" /* Use the ~-expanded versions of APPLLIB (undocumented), SITEARCH, SITELIB, VENDORARCH, VENDORLIB, ARCHLIB and PRIVLIB */ -#ifdef APPLLIB_EXP - S_incpush_use_sep(aTHX_ STR_WITH_LEN(APPLLIB_EXP), - INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE); -#endif - -#ifdef SITEARCH_EXP - /* sitearch is always relative to sitelib on Windows for - * DLL-based path intuition to work correctly */ -# if !defined(WIN32) - S_incpush_use_sep(aTHX_ STR_WITH_LEN(SITEARCH_EXP), - INCPUSH_CAN_RELOCATE); -# endif -#endif - -#ifdef SITELIB_EXP -# if defined(WIN32) - /* this picks up sitearch as well */ - s = PerlEnv_sitelib_path(PERL_FS_VERSION, &len); - if (s) - incpush_use_sep(s, len, INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE); -# else - S_incpush_use_sep(aTHX_ STR_WITH_LEN(SITELIB_EXP), INCPUSH_CAN_RELOCATE); -# endif -#endif - -#ifdef PERL_VENDORARCH_EXP - /* vendorarch is always relative to vendorlib on Windows for - * DLL-based path intuition to work correctly */ -# if !defined(WIN32) - S_incpush_use_sep(aTHX_ STR_WITH_LEN(PERL_VENDORARCH_EXP), - INCPUSH_CAN_RELOCATE); -# endif -#endif - -#ifdef PERL_VENDORLIB_EXP -# if defined(WIN32) - /* this picks up vendorarch as well */ - s = PerlEnv_vendorlib_path(PERL_FS_VERSION, &len); - if (s) - incpush_use_sep(s, len, INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE); -# else - S_incpush_use_sep(aTHX_ STR_WITH_LEN(PERL_VENDORLIB_EXP), - INCPUSH_CAN_RELOCATE); -# endif -#endif - -#ifdef ARCHLIB_EXP - S_incpush_use_sep(aTHX_ STR_WITH_LEN(ARCHLIB_EXP), INCPUSH_CAN_RELOCATE); -#endif - -#ifndef PRIVLIB_EXP -# define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl" -#endif + INCPUSH_APPLLIB_EXP + INCPUSH_SITEARCH_EXP + INCPUSH_SITELIB_EXP + INCPUSH_PERL_VENDORARCH_EXP + INCPUSH_PERL_VENDORLIB_EXP + INCPUSH_ARCHLIB_EXP + INCPUSH_PRIVLIB_EXP + INCPUSH_PERL_OTHERLIBDIRS + INCPUSH_PERL5LIB + INCPUSH_APPLLIB_OLD_EXP + INCPUSH_SITELIB_STEM + INCPUSH_PERL_VENDORLIB_STEM + INCPUSH_PERL_OTHERLIBDIRS_ARCHONLY -#if defined(WIN32) - s = PerlEnv_lib_path(PERL_FS_VERSION, &len); - if (s) - incpush_use_sep(s, len, INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE); -#else -# ifdef NETWARE - S_incpush_use_sep(aTHX_ PRIVLIB_EXP, 0, INCPUSH_CAN_RELOCATE); -# else - S_incpush_use_sep(aTHX_ STR_WITH_LEN(PRIVLIB_EXP), INCPUSH_CAN_RELOCATE); -# endif -#endif - -#ifdef PERL_OTHERLIBDIRS - S_incpush_use_sep(aTHX_ STR_WITH_LEN(PERL_OTHERLIBDIRS), - INCPUSH_ADD_VERSIONED_SUB_DIRS|INCPUSH_NOT_BASEDIR - |INCPUSH_CAN_RELOCATE); -#endif +#endif /* !PERL_IS_MINIPERL */ if (!TAINTING_get) { -#ifndef VMS -/* - * It isn't possible to delete an environment variable with - * PERL_USE_SAFE_PUTENV set unless unsetenv() is also available, so in that - * case we treat PERL5LIB as undefined if it has a zero-length value. - */ -#if defined(PERL_USE_SAFE_PUTENV) && ! defined(HAS_UNSETENV) - if (perl5lib && *perl5lib != '\0') -#else - if (perl5lib) +#if !defined(PERL_IS_MINIPERL) && defined(DEFAULT_INC_EXCLUDES_DOT) + const char * const unsafe = PerlEnv_getenv("PERL_USE_UNSAFE_INC"); + if (unsafe && strEQ(unsafe, "1")) #endif - incpush_use_sep(perl5lib, 0, - INCPUSH_ADD_OLD_VERS|INCPUSH_NOT_BASEDIR); -#else /* VMS */ - /* Treat PERL5?LIB as a possible search list logical name -- the - * "natural" VMS idiom for a Unix path string. We allow each - * element to be a set of |-separated directories for compatibility. - */ - char buf[256]; - int idx = 0; - if (vmstrnenv("PERL5LIB",buf,0,NULL,0)) - do { - incpush_use_sep(buf, 0, - INCPUSH_ADD_OLD_VERS|INCPUSH_NOT_BASEDIR); - } while (vmstrnenv("PERL5LIB",buf,++idx,NULL,0)); -#endif /* VMS */ + S_incpush(aTHX_ STR_WITH_LEN("."), 0); } - -/* Use the ~-expanded versions of APPLLIB (undocumented), - SITELIB and VENDORLIB for older versions -*/ -#ifdef APPLLIB_EXP - S_incpush_use_sep(aTHX_ STR_WITH_LEN(APPLLIB_EXP), INCPUSH_ADD_OLD_VERS - |INCPUSH_NOT_BASEDIR|INCPUSH_CAN_RELOCATE); -#endif - -#if defined(SITELIB_STEM) && defined(PERL_INC_VERSION_LIST) - /* Search for version-specific dirs below here */ - S_incpush_use_sep(aTHX_ STR_WITH_LEN(SITELIB_STEM), - INCPUSH_ADD_OLD_VERS|INCPUSH_CAN_RELOCATE); -#endif - - -#if defined(PERL_VENDORLIB_STEM) && defined(PERL_INC_VERSION_LIST) - /* Search for version-specific dirs below here */ - S_incpush_use_sep(aTHX_ STR_WITH_LEN(PERL_VENDORLIB_STEM), - INCPUSH_ADD_OLD_VERS|INCPUSH_CAN_RELOCATE); -#endif - -#ifdef PERL_OTHERLIBDIRS - S_incpush_use_sep(aTHX_ STR_WITH_LEN(PERL_OTHERLIBDIRS), - INCPUSH_ADD_OLD_VERS|INCPUSH_ADD_ARCHONLY_SUB_DIRS - |INCPUSH_CAN_RELOCATE); -#endif -#endif /* !PERL_IS_MINIPERL */ - - if (!TAINTING_get) - S_incpush(aTHX_ STR_WITH_LEN("."), 0); } #if defined(DOSISH) || defined(__SYMBIAN32__) # define PERLLIB_SEP ';' +#elif defined(__VMS) +# define PERLLIB_SEP PL_perllib_sep #else -# if defined(VMS) -# define PERLLIB_SEP '|' -# else # define PERLLIB_SEP ':' -# endif #endif #ifndef PERLLIB_MANGLE # define PERLLIB_MANGLE(s,n) (s) @@ -4636,7 +4839,7 @@ S_mayberelocate(pTHX_ const char *const dir, STRLEN len, U32 flags) */ const char *libpath = SvPVX(libdir); STRLEN libpath_len = SvCUR(libdir); - if (libpath_len >= 4 && memEQ (libpath, ".../", 4)) { + if (memBEGINs(libpath, libpath_len, ".../")) { /* Game on! */ SV * const caret_X = get_sv("\030", 0); /* Going to use the SV just as a scratch buffer holding a C @@ -4662,12 +4865,9 @@ S_mayberelocate(pTHX_ const char *const dir, STRLEN len, U32 flags) libpath = SvPVX(libdir); libpath_len = SvCUR(libdir); - /* This would work more efficiently with memrchr, but as it's - only a GNU extension we'd need to probe for it and - implement our own. Not hard, but maybe not worth it? */ - prefix = SvPVX(prefix_sv); - lastslash = strrchr(prefix, '/'); + lastslash = (char *) my_memrchr(prefix, '/', + SvEND(prefix_sv) - prefix); /* First time in with the *lastslash = '\0' we just wipe off the trailing /perl from (say) /usr/foo/bin/perl @@ -4675,8 +4875,11 @@ S_mayberelocate(pTHX_ const char *const dir, STRLEN len, U32 flags) if (lastslash) { SV *tempsv; while ((*lastslash = '\0'), /* Do that, come what may. */ - (libpath_len >= 3 && memEQ(libpath, "../", 3) - && (lastslash = strrchr(prefix, '/')))) { + ( memBEGINs(libpath, libpath_len, "../") + && (lastslash = + (char *) my_memrchr(prefix, '/', + SvEND(prefix_sv) - prefix)))) + { if (lastslash[1] == '\0' || (lastslash[1] == '.' && (lastslash[2] == '/' /* ends "/." */ @@ -4926,7 +5129,7 @@ Perl_call_list(pTHX_ I32 oldscope, AV *paramList) while (PL_scopestack_ix > oldscope) LEAVE; JMPENV_POP; - Perl_croak(aTHX_ "%"SVf"", SVfARG(atsv)); + Perl_croak(aTHX_ "%" SVf, SVfARG(atsv)); } break; case 1: @@ -5054,8 +5257,9 @@ Perl_my_failure_exit(pTHX) #else int exitstatus; - if (errno & 255) - STATUS_UNIX_SET(errno); + int eno = errno; + if (eno & 255) + STATUS_UNIX_SET(eno); else { exitstatus = STATUS_UNIX >> 8; if (exitstatus & 255) @@ -5097,12 +5301,13 @@ static I32 read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen) { const char * const p = SvPVX_const(PL_e_script); - const char *nl = strchr(p, '\n'); + const char * const e = SvEND(PL_e_script); + const char *nl = (char *) memchr(p, '\n', e - p); PERL_UNUSED_ARG(idx); PERL_UNUSED_ARG(maxlen); - nl = (nl) ? nl+1 : SvEND(PL_e_script); + nl = (nl) ? nl+1 : e; if (nl-p == 0) { filter_del(read_e_script); return 0;