diff options
| -rw-r--r-- | INSTALL | 6 | ||||
| -rw-r--r-- | MANIFEST | 3 | ||||
| -rw-r--r-- | dist/threads/t/thread.t | 4 | ||||
| -rw-r--r-- | dist/threads/t/version.t | 11 | ||||
| -rw-r--r-- | dist/threads/threads.xs | 3 | ||||
| -rw-r--r-- | embedvar.h | 2 | ||||
| -rw-r--r-- | handy.h | 72 | ||||
| -rw-r--r-- | hv.c | 4 | ||||
| -rw-r--r-- | intrpvar.h | 4 | ||||
| -rw-r--r-- | perl.c | 37 | ||||
| -rw-r--r-- | perl.h | 25 | ||||
| -rw-r--r-- | pod/perldelta.pod | 11 | ||||
| -rw-r--r-- | pod/perlfunc.pod | 16 | ||||
| -rw-r--r-- | pod/perlrun.pod | 26 | ||||
| -rw-r--r-- | pp.c | 20 | ||||
| -rw-r--r-- | pp_sys.c | 17 | ||||
| -rw-r--r-- | sv.c | 2 | ||||
| -rw-r--r-- | t/op/srand.t | 9 | ||||
| -rw-r--r-- | t/run/runenv_randseed.t | 68 |
19 files changed, 313 insertions, 27 deletions
@@ -2755,6 +2755,12 @@ X<PERL_INTERNAL_RAND_SEED> If you configure perl with C<-Accflags=-DNO_PERL_INTERNAL_RAND_SEED>, perl will ignore the C<PERL_INTERNAL_RAND_SEED> environment variable. +=head2 C<-DNO_PERL_RAND_SEED> +X<PERL_RAND_SEED> + +If you configure perl with C<-Accflags=-DNO_PERL_RAND_SEED>, +perl will ignore the C<PERL_RAND_SEED> environment variable. + =head1 DOCUMENTATION Read the manual entries before running perl. The main documentation @@ -6175,7 +6175,8 @@ t/run/fresh_perl.t Tests that require a fresh perl. t/run/locale.t Tests related to locale handling t/run/noswitch.t Test aliasing ARGV for other switch tests t/run/runenv.t Test if perl honors its environment variables. -t/run/runenv_hashseed.t Test if perl honors PERL_HASH_SEED. +t/run/runenv_hashseed.t Test if perl honors PERL_HASH_SEED. +t/run/runenv_randseed.t Test if perl honors PERL_RAND_SEED. t/run/script.t See if script invocation works t/run/switch0.t Test the -0 switch t/run/switcha.t Test the -a switch diff --git a/dist/threads/t/thread.t b/dist/threads/t/thread.t index 4dc1a292d8..8a56bb6fbd 100644 --- a/dist/threads/t/thread.t +++ b/dist/threads/t/thread.t @@ -11,6 +11,7 @@ BEGIN { } use ExtUtils::testlib; +use Data::Dumper; use threads; @@ -156,7 +157,8 @@ package main; rand(10); threads->create( sub { $rand{int(rand(10000000000))}++ } ) foreach 1..25; $_->join foreach threads->list; - ok((keys %rand >= 23), "Check that rand() is randomized in new threads"); + ok((keys %rand >= 23), "Check that rand() is randomized in new threads") + or diag Dumper(\%rand); } # bugid #24165 diff --git a/dist/threads/t/version.t b/dist/threads/t/version.t index dff8d342f5..fb9130903a 100644 --- a/dist/threads/t/version.t +++ b/dist/threads/t/version.t @@ -1,8 +1,17 @@ use strict; use warnings; -use threads; use Test::More; +BEGIN { + use Config; + if (! $Config{'useithreads'}) { + print("1..0 # SKIP Perl not compiled with 'useithreads'\n"); + exit(0); + } +} + +use threads; + # test that the version documented in threads.pm pod matches # that of the code. diff --git a/dist/threads/threads.xs b/dist/threads/threads.xs index 9c8072d9f5..b4fa1121ed 100644 --- a/dist/threads/threads.xs +++ b/dist/threads/threads.xs @@ -807,6 +807,7 @@ S_ithread_create( thread->gimme = gimme; thread->state = exit_opt; + /* "Clone" our interpreter into the thread's interpreter. * This gives thread access to "static data" and code. */ @@ -1171,6 +1172,7 @@ ithread_create(...) if (! thread) { XSRETURN_UNDEF; /* Mutex already unlocked */ } + PERL_SRAND_OVERRIDE_NEXT_PARENT(); ST(0) = sv_2mortal(S_ithread_to_SV(aTHX_ Nullsv, thread, classname, FALSE)); /* Let thread run. */ @@ -1179,7 +1181,6 @@ ithread_create(...) /* warning: releasing mutex 'thread->mutex' that was not held [-Wthread-safety-analysis] */ MUTEX_UNLOCK(&thread->mutex); CLANG_DIAG_RESTORE_STMT; - /* XSRETURN(1); - implied */ diff --git a/embedvar.h b/embedvar.h index 927a6e5d5f..7f872368bd 100644 --- a/embedvar.h +++ b/embedvar.h @@ -280,6 +280,8 @@ #define PL_sortstash (vTHX->Isortstash) #define PL_splitstr (vTHX->Isplitstr) #define PL_srand_called (vTHX->Isrand_called) +#define PL_srand_override (vTHX->Isrand_override) +#define PL_srand_override_next (vTHX->Isrand_override_next) #define PL_stack_base (vTHX->Istack_base) #define PL_stack_max (vTHX->Istack_max) #define PL_stack_sp (vTHX->Istack_sp) @@ -2967,21 +2967,75 @@ last-inclusive range. * are very useful when you want an integer to "dance" in a random way, * but you also never want it to become 0 and thus false. * - * Obviously they leave x unchanged if it starts out as 0. */ + * Obviously they leave x unchanged if it starts out as 0. + * + * We have two variants just because that can be helpful in certain + * places. There is no advantage to either, they are equally bad as each + * other as far RNG's go. Sufficiently random for many purposes, but + * insufficiently random for serious use as they fail important tests in + * the Test01 BigCrush RNG test suite by L’Ecuyer and Simard. (Note + * that Drand48 also fails BigCrush). The main point is they produce + * different sequences and in places where we want some randomlike + * behavior they are cheap and easy. + * + * Marsaglia was one of the early researchers into RNG testing and wrote + * the Diehard RNG test suite, which after his death become the + * Dieharder RNG suite, and was generally supplanted by the Test01 suite + * by L'Ecruyer and associates. + * + * There are dozens of shift parameters that create a pseudo random ring + * of integers 1..2^N-1, if you need a different sequence just read the + * paper and select a set of parameters. In fact, simply reversing the + * shift order from L/R/L to R/L/R should result in another valid + * example, but read the paper before you do that. + * + * PDF of the original paper: + * https://www.jstatsoft.org/article/download/v008i14/916 + * Wikipedia: + * https://en.wikipedia.org/wiki/Xorshift + * Criticism: + * https://www.iro.umontreal.ca/~lecuyer/myftp/papers/xorshift.pdf + * Test01: + * http://simul.iro.umontreal.ca/testu01/tu01.html + * Diehard: + * https://en.wikipedia.org/wiki/Diehard_tests + * Dieharder: + * https://webhome.phy.duke.edu/~rgb/General/rand_rate/rand_rate.abs + * + */ -#define PERL_XORSHIFT64(x) \ +/* 32 bit version */ +#define PERL_XORSHIFT32_A(x) \ STMT_START { \ - (x) ^= (x) << 13; \ - (x) ^= (x) >> 17; \ - (x) ^= (x) << 5; \ + (x) ^= ((x) << 13); \ + (x) ^= ((x) >> 17); \ + (x) ^= ((x) << 5); \ +} STMT_END + +/* 64 bit version */ +#define PERL_XORSHIFT64_A(x) \ +STMT_START { \ + (x) ^= ((x) << 13); \ + (x) ^= ((x) >> 7); \ + (x) ^= ((x) << 17); \ } STMT_END /* 32 bit version */ -#define PERL_XORSHIFT32(x) \ +#define PERL_XORSHIFT32_B(x) \ +STMT_START { \ + (x) ^= ((x) << 5); \ + (x) ^= ((x) >> 27); \ + (x) ^= ((x) << 8); \ +} STMT_END + +/* 64 bit version - currently this is unused, + * it is provided here to complement the 32 bit _B + * variant which IS used. */ +#define PERL_XORSHIFT64_B(x) \ STMT_START { \ - (x) ^= (x) << 13; \ - (x) ^= (x) >> 7; \ - (x) ^= (x) << 17; \ + (x) ^= ((x) << 15); \ + (x) ^= ((x) >> 49); \ + (x) ^= ((x) << 26); \ } STMT_END @@ -56,10 +56,10 @@ static const char S_strtab_error[] */ #if IVSIZE == 8 /* 64 bit version */ -#define XORSHIFT_RAND_BITS(x) PERL_XORSHIFT64(x) +#define XORSHIFT_RAND_BITS(x) PERL_XORSHIFT64_A(x) #else /* 32 bit version */ -#define XORSHIFT_RAND_BITS(x) PERL_XORSHIFT32(x) +#define XORSHIFT_RAND_BITS(x) PERL_XORSHIFT32_A(x) #endif #define UPDATE_HASH_RAND_BITS_KEY(key,klen) \ diff --git a/intrpvar.h b/intrpvar.h index 58e9ef9a23..ac912acd5a 100644 --- a/intrpvar.h +++ b/intrpvar.h @@ -810,7 +810,9 @@ PERLVARI(I, perl_destruct_level, signed char, 0) PERLVAR(I, pad_reset_pending, bool) /* reset pad on next attempted alloc */ -PERLVAR(I, srand_called, bool) +PERLVARI(I, srand_called, bool, false) /* has random_state been initialized yet? */ +PERLVARI(I, srand_override, U32, 0) /* Should we use a deterministic sequence? */ +PERLVARI(I, srand_override_next, U32, 0) /* Next item in the sequence */ PERLVARI(I, numeric_underlying, bool, TRUE) /* Assume underlying locale numerics */ @@ -266,20 +266,43 @@ perl_construct(pTHXx) init_stacks(); -/* The PERL_INTERNAL_RAND_SEED set-up must be after init_stacks because it calls +#if !defined(NO_PERL_RAND_SEED) || !defined(NO_PERL_INTERNAL_HASH_SEED) + bool sensitive_env_vars_allowed = + (PerlProc_getuid() == PerlProc_geteuid() && + PerlProc_getgid() == PerlProc_getegid()) ? TRUE : FALSE; +#endif + +/* The seed set-up must be after init_stacks because it calls * things that may put SVs on the stack. */ +#ifndef NO_PERL_RAND_SEED + if (sensitive_env_vars_allowed) { + UV seed= 0; + const char *env_pv; + if ((env_pv = PerlEnv_getenv("PERL_RAND_SEED")) && + grok_number(env_pv, strlen(env_pv), &seed) == IS_NUMBER_IN_UV) + { + PL_srand_override_next = seed; + PERL_SRAND_OVERRIDE_NEXT_INIT(); + } + } +#endif + + /* This is NOT the state used for C<rand()>, this is only + * used in internal functionality */ #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() || + if ( + !sensitive_env_vars_allowed || !(env_pv = PerlEnv_getenv("PERL_INTERNAL_RAND_SEED")) || - grok_number(env_pv, strlen(env_pv), &seed) != IS_NUMBER_IN_UV) { + grok_number(env_pv, strlen(env_pv), &seed) != IS_NUMBER_IN_UV) + { + /* use a randomly generated seed */ seed = seed(); } Perl_drand48_init_r(&PL_internal_random_state, (U32)seed); @@ -2038,6 +2061,12 @@ S_Internals_V(pTHX_ CV *cv) # ifdef USE_THREAD_SAFE_LOCALE " USE_THREAD_SAFE_LOCALE" # endif +# ifdef NO_PERL_RAND_SEED + " NO_PERL_RAND_SEED" +# endif +# ifdef NO_PERL_INTERNAL_RAND_SEED + " NO_PERL_INTERNAL_RAND_SEED" +# endif ; PERL_UNUSED_ARG(cv); PERL_UNUSED_VAR(items); @@ -8806,8 +8806,31 @@ END_EXTERN_C # endif #endif -#endif /* DOUBLE_HAS_NAN */ +/* these are used to faciliate the env var PERL_RAND_SEED, + * which allows consistent behavior from code that calls + * srand() with no arguments, either explicitly or implicitly. + */ +#define PERL_SRAND_OVERRIDE_NEXT() PERL_XORSHIFT32_A(PL_srand_override_next); + +#define PERL_SRAND_OVERRIDE_NEXT_INIT() STMT_START { \ + PL_srand_override = PL_srand_override_next; \ + PERL_SRAND_OVERRIDE_NEXT(); \ +} STMT_END + +#define PERL_SRAND_OVERRIDE_GET(into) STMT_START { \ + into= PL_srand_override; \ + PERL_SRAND_OVERRIDE_NEXT_INIT(); \ +} STMT_END +#define PERL_SRAND_OVERRIDE_NEXT_CHILD() STMT_START { \ + PERL_XORSHIFT32_B(PL_srand_override_next); \ + PERL_SRAND_OVERRIDE_NEXT_INIT(); \ +} STMT_END + +#define PERL_SRAND_OVERRIDE_NEXT_PARENT() \ + PERL_SRAND_OVERRIDE_NEXT() + +#endif /* DOUBLE_HAS_NAN */ /* diff --git a/pod/perldelta.pod b/pod/perldelta.pod index a5b6347a6e..5120e3125b 100644 --- a/pod/perldelta.pod +++ b/pod/perldelta.pod @@ -27,6 +27,17 @@ here, but most should go in the L</Performance Enhancements> section. [ List each enhancement as a =head2 entry ] +=head2 PERL_RAND_SEED + +Added a new environment variable C<PERL_RAND_SEED> which can be used to +cause a perl program which uses C<rand> without using C<srand()> +explicitly or which uses C<srand()> with no arguments to be repeatable. +See L<perlrun>. This feature can be disabled at compile time by passing + + -Accflags=-DNO_PERL_RAND_SEED + +to F<Configure> during the build process. + =head1 Security XXX Any security-related notices go here. In particular, any security diff --git a/pod/perlfunc.pod b/pod/perlfunc.pod index 38ebb0d12d..fa16cbd69c 100644 --- a/pod/perlfunc.pod +++ b/pod/perlfunc.pod @@ -8480,7 +8480,7 @@ The point of the function is to "seed" the L<C<rand>|/rand EXPR> function so that L<C<rand>|/rand EXPR> can produce a different sequence each time you run your program. When called with a parameter, L<C<srand>|/srand EXPR> uses that for the seed; otherwise it -(semi-)randomly chooses a seed. In either case, starting with Perl 5.14, +(semi-)randomly chooses a seed (see below). In either case, starting with Perl 5.14, it returns the seed. To signal that your code will work I<only> on Perls of a recent vintage: @@ -8512,6 +8512,20 @@ combinations to test comprehensively in the time available to it each run. It can test a random subset each time, and should there be a failure, log the seed used for that run so that it can later be used to reproduce the same results. +If the C<PERL_RAND_SEED> environment variable is set to a non-negative +integer during process startup then calls to C<srand()> with no +arguments will initialize the perl random number generator with a +consistent seed each time it is called, whether called explicitly with +no arguments or implicitly via use of C<rand()>. The exact seeding that +a given C<PERL_RAND_SEED> will produce is deliberately unspecified, but +using different values for C<PERL_RAND_SEED> should produce different +results. This is intended for debugging and performance analysis and is +only guaranteed to produce consistent results between invocations of the +same perl executable running the same code when all other factors are +equal. The environment variable is read only once during process +startup, and changing it during the program flow will not affect the +currently running process. See L<perlrun> for more details. + B<L<C<rand>|/rand EXPR> is not cryptographically secure. You should not rely on it in security-sensitive situations.> As of this writing, a number of third-party CPAN modules offer random number generators diff --git a/pod/perlrun.pod b/pod/perlrun.pod index 0b5a6d3875..6ed5703811 100644 --- a/pod/perlrun.pod +++ b/pod/perlrun.pod @@ -1405,6 +1405,32 @@ with tainting enabled. Perl may be built to ignore this variable. +=item PERL_RAND_SEED +X<PERL_RAND_SEED> + +When set to an integer value this value will be used to seed the perl +internal random number generator used for C<rand()> when it is used +without an explicit C<srand()> call or for when an explicit no-argument +C<srand()> call is made. + +Normally calling C<rand()> prior to calling C<srand()> or calling +C<srand()> explicitly with no arguments should result in the random +number generator using "best efforts" to seed the generator state with a +relatively high quality random seed. When this environment variable is +set then the seeds used will be deterministically computed from the +value provided in the env var in such a way that the application process +and any forks or threads should continue to have their own unique seed but +that the program may be run twice with identical results as far as +C<rand()> goes (assuming all else is equal). + +PERL_RAND_SEED is intended for performance measurements and debugging +and is explicitly NOT intended for stable testing. The only guarantee is +that a specific perl executable will produce the same results twice in a +row, there is no guarantee that the results will be the same between +perl releases or on different architectures. + +Ignored if perl is run setuid or setgid. + =back Perl also has environment variables that control how Perl handles data @@ -2920,7 +2920,17 @@ PP(pp_sin) PP(pp_rand) { if (!PL_srand_called) { - (void)seedDrand01((Rand_seed_t)seed()); + Rand_seed_t s; + if (PL_srand_override) { + /* env var PERL_RAND_SEED has been set so the user wants + * consistent srand() initialization. */ + PERL_SRAND_OVERRIDE_GET(s); + } else { + /* Pseudo random initialization from context state and possible + * random devices */ + s= (Rand_seed_t)seed(); + } + (void)seedDrand01(s); PL_srand_called = TRUE; } { @@ -2979,7 +2989,13 @@ PP(pp_srand) } } else { - anum = seed(); + if (PL_srand_override) { + /* env var PERL_RAND_SEED has been set so the user wants + * consistent srand() initialization. */ + PERL_SRAND_OVERRIDE_GET(anum); + } else { + anum = seed(); + } } (void)seedDrand01((Rand_seed_t)anum); @@ -4232,6 +4232,7 @@ PP(pp_fork) sigset_t oldmask, newmask; #endif + EXTEND(SP, 1); PERL_FLUSHALL_FOR_CHILD; #ifdef HAS_SIGPROCMASK @@ -4259,6 +4260,9 @@ PP(pp_fork) #ifdef PERL_USES_PL_PIDSTATUS hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */ #endif + PERL_SRAND_OVERRIDE_NEXT_CHILD(); + } else { + PERL_SRAND_OVERRIDE_NEXT_PARENT(); } PUSHi(childpid); RETURN; @@ -4271,6 +4275,19 @@ PP(pp_fork) childpid = PerlProc_fork(); if (childpid == -1) RETPUSHUNDEF; + else if (childpid) { + /* we are in the parent */ + PERL_SRAND_OVERRIDE_NEXT_PARENT(); + } + else { + /* This is part of the logic supporting the env var + * PERL_RAND_SEED which causes use of rand() without an + * explicit srand() to use a deterministic seed. This logic is + * intended to give most forked children of a process a + * deterministic but different srand seed. + */ + PERL_SRAND_OVERRIDE_NEXT_CHILD(); + } PUSHi(childpid); RETURN; #else @@ -15544,6 +15544,8 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_srand_called = proto_perl->Isrand_called; Copy(&(proto_perl->Irandom_state), &PL_random_state, 1, PL_RANDOM_STATE_TYPE); + PL_srand_override = proto_perl->Isrand_override; + PL_srand_override_next = proto_perl->Isrand_override_next; if (flags & CLONEf_COPY_STACKS) { /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */ diff --git a/t/op/srand.t b/t/op/srand.t index 09de60aa22..47f7590812 100644 --- a/t/op/srand.t +++ b/t/op/srand.t @@ -52,9 +52,12 @@ ok( !eq_array(\@first_run, \@second_run), } # This test checks whether Perl called srand for you. -@first_run = `$^X -le "print int rand 100 for 1..100"`; -sleep(1); # in case our srand() is too time-dependent -@second_run = `$^X -le "print int rand 100 for 1..100"`; +{ + local $ENV{PERL_RAND_SEED}; + @first_run = `$^X -le "print int rand 100 for 1..100"`; + sleep(1); # in case our srand() is too time-dependent + @second_run = `$^X -le "print int rand 100 for 1..100"`; +} ok( !eq_array(\@first_run, \@second_run), 'srand() called automatically'); diff --git a/t/run/runenv_randseed.t b/t/run/runenv_randseed.t new file mode 100644 index 0000000000..b0ec6072b8 --- /dev/null +++ b/t/run/runenv_randseed.t @@ -0,0 +1,68 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; + require './test.pl'; + require Config; + Config->import; +} + +skip_all_without_config('d_fork'); +skip_all("This perl is built with NO_PERL_RAND_SEED") + if $Config{ccflags} =~ /-DNO_PERL_RAND_SEED\b/; +use strict; +use warnings; + +for (1..2) { + local $ENV{PERL_RAND_SEED} = 1; + fresh_perl_is("print map { chr(rand(26)+65) } 1..10", + "BLVIOAEZTJ", undef, "Test randomness with PERL_RAND_SEED=1"); +} + +for (1..2) { + local $ENV{PERL_RAND_SEED} = 2; + fresh_perl_is("print map { chr(rand(26)+65) } 1..10", + "XEOUOFRPQZ", undef, "Test randomness with PERL_RAND_SEED=2"); +} + +my %got; +for my $try (1..10) { + local $ENV{PERL_RAND_SEED}; + my ($out,$err)= runperl_and_capture({}, ['-e',"print map { chr(rand(26)+65) } 1..10;"]); + if ($err) { diag $err } + $got{$out}++; +} +ok(8 <= keys %got, "Got at least 8 different strings"); +for (1..2) { + local $ENV{PERL_RAND_SEED} = 1; + my ($out,$err)= runperl_and_capture({}, ['-le', + <<'EOF_TEST_CODE' + for my $l ("A".."E") { + my $pid= fork; + if ($pid) { + push @pids, $pid; + } + elsif (!defined $pid) { + print "$l:failed fork"; + } elsif (!$pid) { + print "$l:", map { chr(rand(26)+65) } 1..10; + exit; + } + } + waitpid $_,0 for @pids; +EOF_TEST_CODE + ]); + is($err, "", "No exceptions forking."); + my @parts= sort { $a cmp $b } split /\n/, $out; + my @want= ( + "A:KNXDITWWJZ", + "B:WDQJGTBJQS", + "C:ZGYCCINIHE", + "D:UGLGAEXFBP", + "E:MQLTNZGZQB" + ); + is("@parts","@want","Works as expected with forks."); +} + +done_testing(); |