X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/22ff313068aa37b1a24855e760e71ee9a20a1a90..8162b70e63fb41df1eaf259c13d61d8b563cd7f5:/perl.c diff --git a/perl.c b/perl.c index 230244b..2540cb3 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 - * by Larry Wall and others + * 2013, 2014, 2015, 2016, 2017 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) @@ -93,6 +97,7 @@ S_init_tls_and_interp(PerlInterpreter *my_perl) OP_REFCNT_INIT; OP_CHECK_MUTEX_INIT; HINTS_REFCNT_INIT; + LOCALE_INIT; MUTEX_INIT(&PL_dollarzero_mutex); MUTEX_INIT(&PL_my_ctx_mutex); # endif @@ -213,6 +218,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,8 +273,30 @@ 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; @@ -259,6 +306,14 @@ perl_construct(pTHXx) 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 +323,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 +336,54 @@ 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(); + /* 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, 512); + hv_ksplit(PL_strtab, 1 << 11); Zero(PL_sv_consts, SV_CONSTS_COUNT, SV*); @@ -389,9 +471,14 @@ perl_construct(pTHXx) 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(Grapheme_Cluster_Break_invlist); - PL_SB_invlist = _new_invlist_C_array(Sentence_Break_invlist); - PL_WB_invlist = _new_invlist_C_array(Word_Break_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); +#ifdef HAS_POSIX_2008_LOCALE + PL_C_locale_obj = newlocale(LC_ALL_MASK, "C", NULL); +#endif ENTER; } @@ -524,7 +611,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; @@ -584,19 +671,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", + 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 @@ -1025,6 +1135,11 @@ perl_destruct(pTHXx) PL_numeric_radix_sv = NULL; #endif + if (PL_langinfo_buf) { + Safefree(PL_langinfo_buf); + PL_langinfo_buf = NULL; + } + /* clear character classes */ for (i = 0; i < POSIX_SWASH_COUNT; i++) { SvREFCNT_dec(PL_utf8_swash_ptrs[i]); @@ -1070,8 +1185,10 @@ perl_destruct(pTHXx) PL_XPosix_ptrs[i] = NULL; } PL_GCB_invlist = NULL; + PL_LB_invlist = NULL; PL_SB_invlist = NULL; PL_WB_invlist = NULL; + PL_Assigned_invlist = NULL; if (!specialWARN(PL_compiling.cop_warnings)) PerlMemShared_free(PL_compiling.cop_warnings); @@ -1084,7 +1201,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); @@ -1203,6 +1320,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++) { @@ -1229,8 +1351,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)", @@ -1313,6 +1435,13 @@ perl_destruct(pTHXx) Perl_reentrant_free(aTHX); #endif + /* These all point to HVs that are about to be blown away. + Code in core and on CPAN assumes that if the interpreter is re-started + that they will be cleanly NULL or pointing to a valid HV. */ + PL_custom_op_names = NULL; + PL_custom_op_descs = NULL; + PL_custom_ops = NULL; + sv_free_arenas(); while (PL_regmatch_slab) { @@ -1473,13 +1602,13 @@ 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"); if (s && strEQ(s, "1")) { - unsigned char *seed= PERL_HASH_SEED; - unsigned char *seed_end= PERL_HASH_SEED + PERL_HASH_SEED_BYTES; + const unsigned char *seed= PERL_HASH_SEED; + const unsigned char *seed_end= PERL_HASH_SEED + PERL_HASH_SEED_BYTES; PerlIO_printf(Perl_debug_log, "HASH_FUNCTION = %s HASH_SEED = 0x", PERL_HASH_FUNC); while (seed < seed_end) { PerlIO_printf(Perl_debug_log, "%02x", *seed++); @@ -1492,7 +1621,15 @@ 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__ + { + struct NameTranslationInfo nti; + __translate_amiga_to_unix_path_name(&argv[0],&nti); + } +#endif + PL_origargc = argc; PL_origargv = argv; @@ -1508,7 +1645,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 = @@ -1524,6 +1660,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 @@ -1557,6 +1694,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++; @@ -1685,6 +1823,9 @@ S_Internals_V(pTHX_ CV *cv) # ifdef PERL_BOOL_AS_CHAR " PERL_BOOL_AS_CHAR" # endif +# ifdef PERL_COPY_ON_WRITE + " PERL_COPY_ON_WRITE" +# endif # ifdef PERL_DISABLE_PMC " PERL_DISABLE_PMC" # endif @@ -1730,8 +1871,8 @@ S_Internals_V(pTHX_ CV *cv) # ifdef PERL_MEM_LOG_NOIMPL " PERL_MEM_LOG_NOIMPL" # endif -# ifdef PERL_NEW_COPY_ON_WRITE - " PERL_NEW_COPY_ON_WRITE" +# ifdef PERL_OP_PARENT + " PERL_OP_PARENT" # endif # ifdef PERL_PERTURB_KEYS_DETERMINISTIC " PERL_PERTURB_KEYS_DETERMINISTIC" @@ -1754,6 +1895,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 @@ -1763,15 +1907,15 @@ 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 # ifdef USE_LOCALE_CTYPE " USE_LOCALE_CTYPE" # endif +# ifdef WIN32_NO_REGISTRY + " USE_NO_REGISTRY" +# endif # ifdef USE_PERL_ATOF " USE_PERL_ATOF" # endif @@ -1788,15 +1932,20 @@ S_Internals_V(pTHX_ CV *cv) PUSHs(Perl_newSVpvn_flags(aTHX_ non_bincompat_options, sizeof(non_bincompat_options) - 1, SVs_TEMP)); -#ifdef __DATE__ -# ifdef __TIME__ +#ifndef PERL_BUILD_DATE +# ifdef __DATE__ +# ifdef __TIME__ +# define PERL_BUILD_DATE __DATE__ " " __TIME__ +# else +# define PERL_BUILD_DATE __DATE__ +# endif +# endif +#endif + +#ifdef PERL_BUILD_DATE PUSHs(Perl_newSVpvn_flags(aTHX_ - STR_WITH_LEN("Compiled at " __DATE__ " " __TIME__), + STR_WITH_LEN("Compiled at " PERL_BUILD_DATE), SVs_TEMP)); -# else - PUSHs(Perl_newSVpvn_flags(aTHX_ STR_WITH_LEN("Compiled on " __DATE__), - SVs_TEMP)); -# endif #else PUSHs(&PL_sv_undef); #endif @@ -1826,7 +1975,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) int argc = PL_origargc; char **argv = PL_origargv; const char *scriptname = NULL; - VOL bool dosearch = FALSE; + bool dosearch = FALSE; char c; bool doextract = FALSE; const char *cddir = NULL; @@ -2073,6 +2222,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); @@ -2095,7 +2259,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)); @@ -2216,6 +2380,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__) @@ -2287,12 +2452,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); @@ -2508,7 +2668,7 @@ Perl_get_av(pTHX_ const char *name, I32 flags) Returns the HV of the specified Perl hash. C are passed to C. If C is set and the Perl variable does not exist then it will be created. If C is zero -and the variable does not exist then NULL is returned. +and the variable does not exist then C is returned. =cut */ @@ -2582,7 +2742,7 @@ Perl_get_cv(pTHX_ const char *name, I32 flags) =for apidoc p||call_argv Performs a callback to the specified named and package-scoped Perl subroutine -with C (a NULL-terminated array of strings) as arguments. See +with C (a C-terminated array of strings) as arguments. See L. Approximate Perl equivalent: C<&{"$sub_name"}(@$argv)>. @@ -2601,13 +2761,11 @@ Perl_call_argv(pTHX_ const char *sub_name, I32 flags, char **argv) PERL_ARGS_ASSERT_CALL_ARGV; PUSHMARK(SP); - if (argv) { - while (*argv) { - mXPUSHs(newSVpv(*argv,0)); - argv++; - } - PUTBACK; + while (*argv) { + mXPUSHs(newSVpv(*argv,0)); + argv++; } + PUTBACK; return call_pv(sub_name, flags); } @@ -2659,22 +2817,35 @@ Perl_call_method(pTHX_ const char *methname, I32 flags) /* =for apidoc p||call_sv -Performs a callback to the Perl sub whose name is in the SV. See -L. +Performs a callback to the Perl sub specified by the SV. + +If neither the C nor C flag is supplied, the +SV may be any of a CV, a GV, a reference to a CV, a reference to a GV +or C will be used as the name of the sub to call. + +If the C flag is supplied, the SV may be a reference to a CV or +C will be used as the name of the method to call. + +If the C flag is supplied, C will be used as +the name of the method to call. + +Some other values are treated specially for internal use and should +not be depended on. + +See L. =cut */ 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; dSP; + dVAR; LOGOP myop; /* fake syntax tree node */ METHOP method_op; I32 oldmark; - VOL I32 retval = 0; - I32 oldscope; + volatile I32 retval = 0; bool oldcatch = CATCH_GET; int ret; OP* const oldop = PL_op; @@ -2699,11 +2870,13 @@ Perl_call_sv(pTHX_ SV *sv, VOL I32 flags) SAVEOP(); PL_op = (OP*)&myop; - EXTEND(PL_stack_sp, 1); - if (!(flags & G_METHOD_NAMED)) - *++PL_stack_sp = sv; + if (!(flags & G_METHOD_NAMED)) { + dSP; + EXTEND(SP, 1); + PUSHs(sv); + PUTBACK; + } oldmark = TOPMARK; - oldscope = PL_scopestack_ix; if (PERLDB_SUB && PL_curstash != PL_debstash /* Handle first BEGIN of -d. */ @@ -2737,10 +2910,12 @@ Perl_call_sv(pTHX_ SV *sv, VOL I32 flags) CATCH_SET(oldcatch); } else { + I32 old_cxix; myop.op_other = (OP*)&myop; - PL_markstack_ptr--; - create_eval_scope(flags|G_FAKINGEVAL); - PL_markstack_ptr++; + (void)POPMARK; + old_cxix = cxstack_ix; + create_eval_scope(NULL, flags|G_FAKINGEVAL); + INCMARK; JMPENV_PUSH(ret); @@ -2780,8 +2955,13 @@ Perl_call_sv(pTHX_ SV *sv, VOL I32 flags) break; } - if (PL_scopestack_ix > oldscope) + /* if we croaked, depending on how we croaked the eval scope + * may or may not have already been popped */ + if (cxstack_ix > old_cxix) { + assert(cxstack_ix == old_cxix + 1); + assert(CxTYPE(CX_CUR()) == CXt_EVAL); delete_eval_scope(); + } JMPENV_POP; } @@ -2801,7 +2981,7 @@ Perl_call_sv(pTHX_ SV *sv, VOL I32 flags) =for apidoc p||eval_sv Tells Perl to C the string in the SV. It supports the same flags -as C, with the obvious exception of G_EVAL. See L. +as C, with the obvious exception of C. See L. =cut */ @@ -2812,10 +2992,9 @@ Perl_eval_sv(pTHX_ SV *sv, I32 flags) /* See G_* flags in cop.h */ { dVAR; - dSP; UNOP myop; /* fake syntax tree node */ - VOL I32 oldmark = SP - PL_stack_base; - VOL I32 retval = 0; + volatile I32 oldmark; + volatile I32 retval = 0; int ret; OP* const oldop = PL_op; dJMPENV; @@ -2830,8 +3009,13 @@ Perl_eval_sv(pTHX_ SV *sv, I32 flags) SAVEOP(); PL_op = (OP*)&myop; Zero(&myop, 1, UNOP); - EXTEND(PL_stack_sp, 1); - *++PL_stack_sp = sv; + { + dSP; + oldmark = SP - PL_stack_base; + EXTEND(SP, 1); + PUSHs(sv); + PUTBACK; + } if (!(flags & G_NOARGS)) myop.op_flags = OPf_STACKED; @@ -2844,7 +3028,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 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); @@ -3050,6 +3234,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; @@ -3058,7 +3243,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); @@ -3116,10 +3301,9 @@ Perl_moreswitches(pTHX_ const char *s) s--; } PL_rs = newSVpvs(""); - SvGROW(PL_rs, (STRLEN)(UNISKIP(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, UNISKIP(rschar)); + SvCUR_set(PL_rs, UVCHR_SKIP(rschar)); SvUTF8_on(PL_rs); } else { @@ -3227,12 +3411,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)) @@ -3240,11 +3418,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); @@ -3477,7 +3650,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); } @@ -3491,7 +3664,7 @@ S_minus_v(pTHX) #endif PerlIO_printf(PIO_stdout, - "\n\nCopyright 1987-2015, Larry Wall\n"); + "\n\nCopyright 1987-2017, Larry Wall\n"); #ifdef MSDOS PerlIO_printf(PIO_stdout, "\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n"); @@ -3626,7 +3799,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, @@ -3650,7 +3823,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, @@ -3678,7 +3850,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 (strEQs(scriptname, "/dev/fd/") && isDIGIT(scriptname[8]) && grok_atoUV(scriptname + 8, &uv, &s) && uv <= PERL_INT_MAX @@ -3741,7 +3913,7 @@ 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(0600); + int old_umask = umask(0177); int tmpfd = mkstemp(tmpname); umask(old_umask); if (tmpfd > -1) { @@ -3749,12 +3921,6 @@ S_open_script(pTHX_ const char *scriptname, bool dosearch, bool *suidscript) close(tmpfd); } else Perl_croak(aTHX_ err); -#else -# ifdef HAS_MKTEMP - scriptname = mktemp(tmpname); - if (!scriptname) - Perl_croak(aTHX_ err); -# endif #endif } #endif @@ -3771,16 +3937,16 @@ 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) +#if defined(HAS_FCNTL) && defined(F_SETFD) && defined(FD_CLOEXEC) if (fd >= 0) { /* ensure close-on-exec */ - if (fcntl(fd, F_SETFD, 1) < 0) { + if (fcntl(fd, F_SETFD, FD_CLOEXEC) < 0) { Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n", CopFILE(PL_curcop), Strerror(errno)); } @@ -3821,16 +3987,13 @@ S_validate_suid(pTHX_ PerlIO *rsfp) if (my_euid != my_uid || my_egid != my_gid) { /* (suidperl doesn't exist, in fact) */ dVAR; int fd = PerlIO_fileno(rsfp); - if (fd < 0) { - Perl_croak(aTHX_ "Illegal suidscript"); - } else { - if (PerlLIO_fstat(fd, &PL_statbuf) < 0) { /* may be either wrapped or real suid */ - Perl_croak(aTHX_ "Illegal suidscript"); - } + Stat_t statbuf; + if (fd < 0 || PerlLIO_fstat(fd, &statbuf) < 0) { /* may be either wrapped or real suid */ + Perl_croak_nocontext( "Illegal suidscript"); } - if ((my_euid != my_uid && my_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID) + if ((my_euid != my_uid && my_euid == statbuf.st_uid && statbuf.st_mode & S_ISUID) || - (my_egid != my_gid && my_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID) + (my_egid != my_gid && my_egid == statbuf.st_gid && statbuf.st_mode & S_ISGID) ) if (!PL_do_undump) Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\ @@ -3862,7 +4025,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 (strEQs(s2-4,"perl")) while ((s = moreswitches(s))) ; } @@ -4032,10 +4195,15 @@ Perl_init_debugger(pTHX) void Perl_init_stacks(pTHX) { + SSize_t size; + /* start with 128-item stack and 8K cxstack */ 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 */ @@ -4061,9 +4229,11 @@ Perl_init_stacks(pTHX) PL_scopestack_ix = 0; PL_scopestack_max = REASONABLE(32); - Newx(PL_savestack,REASONABLE_but_at_least(128,SS_MAXPUSH),ANY); + size = REASONABLE_but_at_least(128,SS_MAXPUSH); + Newx(PL_savestack, size, ANY); PL_savestack_ix = 0; - PL_savestack_max = REASONABLE_but_at_least(128,SS_MAXPUSH); + /*PL_savestack_max lies: it always has SS_MAXPUSH more than it claims */ + PL_savestack_max = size - SS_MAXPUSH; } #undef REASONABLE @@ -4240,9 +4410,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; @@ -4279,23 +4449,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 */ @@ -4345,12 +4562,12 @@ S_init_perllib(pTHX) */ char buf[256]; int idx = 0; - if (my_trnlnm("PERL5LIB",buf,0)) + if (vmstrnenv("PERL5LIB",buf,0,NULL,0)) do { incpush_use_sep(buf, 0, INCPUSH_ADD_SUB_DIRS); - } while (my_trnlnm("PERL5LIB",buf,++idx)); + } while (vmstrnenv("PERL5LIB",buf,++idx,NULL,0)); else { - while (my_trnlnm("PERLLIB",buf,idx++)) + while (vmstrnenv("PERLLIB",buf,idx++,NULL,0)) incpush_use_sep(buf, 0, 0); } #endif /* VMS */ @@ -4380,7 +4597,7 @@ S_init_perllib(pTHX) #ifdef SITELIB_EXP # if defined(WIN32) /* this picks up sitearch as well */ - s = win32_get_sitelib(PERL_FS_VERSION, &len); + s = PerlEnv_sitelib_path(PERL_FS_VERSION, &len); if (s) incpush_use_sep(s, len, INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE); # else @@ -4400,7 +4617,7 @@ S_init_perllib(pTHX) #ifdef PERL_VENDORLIB_EXP # if defined(WIN32) /* this picks up vendorarch as well */ - s = win32_get_vendorlib(PERL_FS_VERSION, &len); + s = PerlEnv_vendorlib_path(PERL_FS_VERSION, &len); if (s) incpush_use_sep(s, len, INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE); # else @@ -4418,7 +4635,7 @@ S_init_perllib(pTHX) #endif #if defined(WIN32) - s = win32_get_privlib(PERL_FS_VERSION, &len); + s = PerlEnv_lib_path(PERL_FS_VERSION, &len); if (s) incpush_use_sep(s, len, INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE); #else @@ -4456,11 +4673,11 @@ S_init_perllib(pTHX) */ char buf[256]; int idx = 0; - if (my_trnlnm("PERL5LIB",buf,0)) + if (vmstrnenv("PERL5LIB",buf,0,NULL,0)) do { incpush_use_sep(buf, 0, INCPUSH_ADD_OLD_VERS|INCPUSH_NOT_BASEDIR); - } while (my_trnlnm("PERL5LIB",buf,++idx)); + } while (vmstrnenv("PERL5LIB",buf,++idx,NULL,0)); #endif /* VMS */ } @@ -4492,15 +4709,20 @@ S_init_perllib(pTHX) #endif #endif /* !PERL_IS_MINIPERL */ - if (!TAINTING_get) - S_incpush(aTHX_ STR_WITH_LEN("."), 0); + if (!TAINTING_get) { +#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 + S_incpush(aTHX_ STR_WITH_LEN("."), 0); + } } #if defined(DOSISH) || defined(__SYMBIAN32__) # define PERLLIB_SEP ';' #else -# if defined(VMS) -# define PERLLIB_SEP '|' +# if defined(__VMS) +# define PERLLIB_SEP PL_perllib_sep # else # define PERLLIB_SEP ':' # endif @@ -4625,7 +4847,7 @@ 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) + (libpath_len >= 3 && _memEQs(libpath, "../") && (lastslash = strrchr(prefix, '/')))) { if (lastslash[1] == '\0' || (lastslash[1] == '.' @@ -4876,7 +5098,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: @@ -5034,7 +5256,10 @@ S_my_exit_jump(pTHX) } POPSTACK_TO(PL_mainstack); - dounwind(-1); + if (cxstack_ix >= 0) { + dounwind(-1); + cx_popblock(cxstack); + } LEAVE_SCOPE(0); JMPENV_JUMP(2); @@ -5061,7 +5286,7 @@ read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen) /* removes boilerplate code at the end of each boot_Module xsub */ void -Perl_xs_boot_epilog(pTHX_ const U32 ax) +Perl_xs_boot_epilog(pTHX_ const I32 ax) { if (PL_unitcheckav) call_list(PL_scopestack_ix, PL_unitcheckav); @@ -5069,11 +5294,5 @@ Perl_xs_boot_epilog(pTHX_ const U32 ax) } /* - * Local variables: - * c-indentation-style: bsd - * c-basic-offset: 4 - * indent-tabs-mode: nil - * End: - * * ex: set ts=8 sts=4 sw=4 et: */