*
* 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.
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();
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
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(). */
#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*);
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
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;
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
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]);
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);
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);
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++) {
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)",
#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");
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__
{
* 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 =
* 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
INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask)))
)
{
+ int i;
#ifndef OS2 /* ENVIRON is read by the kernel too. */
s = PL_origenviron[0];
while (*s) s++;
# ifdef USE_FAST_STDIO
" USE_FAST_STDIO"
# endif
-# ifdef USE_HASH_SEED_EXPLICIT
- " USE_HASH_SEED_EXPLICIT"
-# endif
# ifdef USE_LOCALE
" USE_LOCALE"
# endif
}
}
+#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);
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));
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);
*/
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;
{
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;
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))
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);
"\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);
}
#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");
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,
#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,
/* 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
close(tmpfd);
} else
Perl_croak(aTHX_ err);
-#else
-# ifdef HAS_MKTEMP
- scriptname = mktemp(tmpname);
- if (!scriptname)
- Perl_croak(aTHX_ err);
-# endif
#endif
}
#endif
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));
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)))
;
}
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 */
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;
#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__)
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] == '.'
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;
while (PL_scopestack_ix > oldscope)
LEAVE;
JMPENV_POP;
- Perl_croak(aTHX_ "%"SVf"", SVfARG(atsv));
+ Perl_croak(aTHX_ "%" SVf, SVfARG(atsv));
}
break;
case 1: