X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/73e1bd1a5c02345bc685f62eb3210f5a55378752..3b2fee47cdd823a304d1ec8183060c268f39c6d3:/perl.c diff --git a/perl.c b/perl.c index 07b8523..c7673fc 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 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(); @@ -286,6 +303,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 @@ -295,9 +320,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(). */ @@ -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, @@ -420,7 +468,8 @@ perl_construct(pTHXx) 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 + 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 @@ -544,9 +593,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 +628,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; @@ -644,11 +717,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 @@ -1079,6 +1152,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]); @@ -1127,6 +1205,7 @@ perl_destruct(pTHXx) 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); @@ -1139,7 +1218,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); @@ -1258,6 +1337,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 +1368,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 +1594,55 @@ 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. + +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. 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 */ @@ -1535,7 +1665,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 +1684,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__ { @@ -1578,7 +1708,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 +1723,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 +1757,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 +1844,7 @@ perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env) call_list(oldscope, PL_checkav); } ret = STATUS_EXIT; + if (ret == 0) ret = 0x100; break; case 3: PerlIO_printf(Perl_error_log, "panic: top_env\n"); @@ -1839,9 +1971,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 +2286,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); @@ -2179,7 +2323,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 +2516,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 +2554,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 */ @@ -2426,7 +2603,7 @@ int perl_run(pTHXx) { I32 oldscope; - int ret = 0; + int ret = 0, exit_called = 0; dJMPENV; PERL_ARGS_ASSERT_PERL_RUN; @@ -2447,8 +2624,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; @@ -2462,7 +2641,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) { @@ -2637,6 +2821,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 +2950,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 +3105,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; @@ -3336,12 +3523,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)) @@ -3349,11 +3530,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); @@ -3586,7 +3762,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); } @@ -3600,7 +3776,7 @@ S_minus_v(pTHX) #endif PerlIO_printf(PIO_stdout, - "\n\nCopyright 1987-2016, 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"); @@ -3723,8 +3899,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. */ @@ -3735,7 +3912,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, @@ -3759,7 +3936,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, @@ -3787,7 +3963,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 @@ -3858,20 +4034,14 @@ 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 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; @@ -3880,7 +4050,7 @@ 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)); @@ -3906,12 +4076,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 @@ -3968,7 +4146,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))) ; } @@ -4144,6 +4322,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 */ @@ -4350,9 +4531,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; @@ -4517,150 +4698,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 + 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 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 - -#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) @@ -4743,7 +4815,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 @@ -4769,12 +4841,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 @@ -4782,8 +4851,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 "/." */ @@ -4986,7 +5058,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; @@ -5033,7 +5105,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: @@ -5161,8 +5233,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) @@ -5204,12 +5277,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;