X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/854da30f7a12360c4116d0fe1bbfd4154f69ba24..3337f21af2adb68370e3987aabd1fb1bce0d786f:/perl.c diff --git a/perl.c b/perl.c index aa7d8b6..30ee577 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. @@ -62,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 @@ -96,6 +92,7 @@ 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); @@ -273,6 +270,26 @@ 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(); @@ -280,12 +297,20 @@ perl_construct(pTHXx) JMPENV_BOOTSTRAP; STATUS_ALL_SUCCESS; - init_i18nl10n(1); + init_uniprops(); #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 @@ -308,27 +333,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*); @@ -363,23 +420,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, @@ -400,31 +448,12 @@ 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 USE_THREAD_SAFE_LOCALE +#ifdef USE_POSIX_2008_LOCALE PL_C_locale_obj = newlocale(LC_ALL_MASK, "C", NULL); #endif ENTER; + init_i18nl10n(1); } /* @@ -544,9 +573,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 */ @@ -555,7 +608,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; @@ -622,7 +675,7 @@ perl_destruct(pTHXx) if (*stdo && PerlIO_flush(stdo)) { PerlIO_restore_errno(stdo); if (errno) - PerlIO_printf(PerlIO_stderr(), "Unable to flush stdout: %s", + PerlIO_printf(PerlIO_stderr(), "Unable to flush stdout: %s\n", Strerror(errno)); if (!STATUS_UNIX) STATUS_ALL_FAILURE; @@ -644,11 +697,11 @@ perl_destruct(pTHXx) PerlIO_printf(Perl_debug_log, "Trace of all OPs executed:\n"); for (i = 0; i <= OP_max; ++i) { if (PL_op_exec_cnt[i]) - PerlIO_printf(Perl_debug_log, " %s: %"UVuf"\n", PL_op_name[i], 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 @@ -669,7 +722,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(); } @@ -768,7 +821,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; } @@ -1071,7 +1124,30 @@ perl_destruct(pTHXx) Safefree(PL_collation_name); PL_collation_name = NULL; #endif - +#if defined(USE_POSIX_2008_LOCALE) \ + && defined(USE_THREAD_SAFE_LOCALE) \ + && ! defined(HAS_QUERYLOCALE) + for (i = 0; i < (int) C_ARRAY_LENGTH(PL_curlocales); i++) { + Safefree(PL_curlocales[i]); + PL_curlocales[i] = NULL; + } +#endif +#ifdef HAS_POSIX_2008_LOCALE + { + /* This also makes sure we aren't using a locale object that gets freed + * below */ + const locale_t old_locale = uselocale(LC_GLOBAL_LOCALE); + if (old_locale != LC_GLOBAL_LOCALE) { + freelocale(old_locale); + } + } +# ifdef USE_LOCALE_NUMERIC + if (PL_underlying_numeric_obj) { + freelocale(PL_underlying_numeric_obj); + PL_underlying_numeric_obj = (locale_t) NULL; + } +# endif +#endif #ifdef USE_LOCALE_NUMERIC Safefree(PL_numeric_name); PL_numeric_name = NULL; @@ -1079,54 +1155,21 @@ perl_destruct(pTHXx) PL_numeric_radix_sv = NULL; #endif - /* clear character classes */ - for (i = 0; i < POSIX_SWASH_COUNT; i++) { - SvREFCNT_dec(PL_utf8_swash_ptrs[i]); - PL_utf8_swash_ptrs[i] = NULL; + if (PL_setlocale_buf) { + Safefree(PL_setlocale_buf); + PL_setlocale_buf = NULL; + } + + if (PL_langinfo_buf) { + Safefree(PL_langinfo_buf); + PL_langinfo_buf = NULL; } - SvREFCNT_dec(PL_utf8_mark); - SvREFCNT_dec(PL_utf8_toupper); - SvREFCNT_dec(PL_utf8_totitle); - SvREFCNT_dec(PL_utf8_tolower); - SvREFCNT_dec(PL_utf8_tofold); - SvREFCNT_dec(PL_utf8_idstart); - SvREFCNT_dec(PL_utf8_idcont); - SvREFCNT_dec(PL_utf8_foldable); - SvREFCNT_dec(PL_utf8_foldclosures); - SvREFCNT_dec(PL_AboveLatin1); - SvREFCNT_dec(PL_InBitmap); - SvREFCNT_dec(PL_UpperLatin1); - SvREFCNT_dec(PL_Latin1); - SvREFCNT_dec(PL_NonL1NonFinalFold); - SvREFCNT_dec(PL_HasMultiCharFold); + + /* clear character classes */ #ifdef USE_LOCALE_CTYPE SvREFCNT_dec(PL_warn_locale); -#endif - PL_utf8_mark = NULL; - PL_utf8_toupper = NULL; - PL_utf8_totitle = NULL; - PL_utf8_tolower = NULL; - PL_utf8_tofold = NULL; - PL_utf8_idstart = NULL; - PL_utf8_idcont = NULL; - PL_utf8_foldclosures = NULL; - PL_AboveLatin1 = NULL; - PL_InBitmap = NULL; - PL_HasMultiCharFold = NULL; -#ifdef USE_LOCALE_CTYPE PL_warn_locale = NULL; #endif - PL_Latin1 = NULL; - PL_NonL1NonFinalFold = NULL; - PL_UpperLatin1 = NULL; - for (i = 0; i < POSIX_CC_COUNT; i++) { - SvREFCNT_dec(PL_XPosix_ptrs[i]); - PL_XPosix_ptrs[i] = NULL; - } - PL_GCB_invlist = NULL; - PL_LB_invlist = NULL; - PL_SB_invlist = NULL; - PL_WB_invlist = NULL; if (!specialWARN(PL_compiling.cop_warnings)) PerlMemShared_free(PL_compiling.cop_warnings); @@ -1258,6 +1301,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++) { @@ -1284,8 +1332,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)", @@ -1510,9 +1558,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 */ @@ -1535,7 +1635,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"); @@ -1554,7 +1654,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__ { @@ -1563,6 +1663,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; @@ -1578,7 +1685,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 = @@ -1594,6 +1700,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 @@ -1627,6 +1734,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++; @@ -1713,6 +1821,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"); @@ -1839,9 +1956,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 @@ -2157,6 +2271,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 (TAINT_get && + 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); @@ -2179,7 +2308,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)); @@ -2372,12 +2501,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); @@ -2415,9 +2539,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 */ @@ -2637,6 +2799,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! */ @@ -2763,14 +2928,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; @@ -2918,8 +3083,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; @@ -3180,7 +3345,7 @@ Perl_get_debug_opts(pTHX_ const char **s, bool givehelp) } } else if (isDIGIT(**s)) { - const char* e; + const char* e = *s + strlen(*s); if (grok_atoUV(*s, &uv, &e)) *s = e; for (; isWORDCHAR(**s); (*s)++) ; @@ -3336,12 +3501,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)) @@ -3581,7 +3740,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); } @@ -3595,7 +3754,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"); @@ -3718,8 +3877,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. */ @@ -3754,7 +3914,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, @@ -3781,8 +3940,9 @@ S_open_script(pTHX_ const char *scriptname, bool dosearch, bool *suidscript) UV uv; /* if find_script() returns, it returns a malloc()-ed value */ scriptname = PL_origfilename = find_script(scriptname, dosearch, NULL, 1); + s = scriptname + strlen(scriptname); - if (strEQs(scriptname, "/dev/fd/") + if (strBEGINs(scriptname, "/dev/fd/") && isDIGIT(scriptname[8]) && grok_atoUV(scriptname + 8, &uv, &s) && uv <= PERL_INT_MAX @@ -3844,29 +4004,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; @@ -3875,21 +4025,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 @@ -3901,12 +4042,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 @@ -3963,7 +4112,7 @@ S_find_beginning(pTHX_ SV* linestr_sv, PerlIO *rsfp) if (*s++ == '-') { while (isDIGIT(s2[-1]) || s2[-1] == '-' || s2[-1] == '.' || s2[-1] == '_') s2--; - if (strEQs(s2-4,"perl")) + if (strBEGINs(s2-4,"perl")) while ((s = moreswitches(s))) ; } @@ -4139,6 +4288,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 */ @@ -4512,150 +4664,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 + 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 -#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 - -#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 ';' -#else -# if defined(__VMS) +#elif defined(__VMS) # define PERLLIB_SEP PL_perllib_sep -# else +#else # define PERLLIB_SEP ':' -# endif #endif #ifndef PERLLIB_MANGLE # define PERLLIB_MANGLE(s,n) (s) @@ -4738,7 +4781,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 @@ -4764,12 +4807,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 @@ -4777,8 +4817,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 && _memEQs(libpath, "../") - && (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 "/." */ @@ -4981,7 +5024,7 @@ void Perl_call_list(pTHX_ I32 oldscope, AV *paramList) { SV *atsv; - VOL const line_t oldline = PL_curcop ? CopLINE(PL_curcop) : 0; + volatile const line_t oldline = PL_curcop ? CopLINE(PL_curcop) : 0; CV *cv; STRLEN len; int ret; @@ -5028,7 +5071,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: @@ -5156,8 +5199,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) @@ -5199,12 +5243,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;