cleanup and test PERL_PERTURB_KEYS environment variable handling

4 files changed, 83 insertions, 32 deletions

diff --git a/embed.fnc b/embed.fnc
index c032be083a..480de45509 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -1556,7 +1556,7 @@ p	|I32	|wait4pid	|Pid_t pid|NN int* statusp|int flags
 p	|U32	|parse_unicode_opts|NN const char **popt
 Ap	|U32	|seed
 : Only used in perl.c
-p        |void        |get_hash_seed        |NN unsigned char *seed_buffer
+p        |void        |get_hash_seed        |NN unsigned char * const seed_buffer
 : Used in doio.c, pp_hot.c, pp_sys.c
 p	|void	|report_evil_fh	|NULLOK const GV *gv
 : Used in doio.c, pp_hot.c, pp_sys.c
diff --git a/proto.h b/proto.h
index 13d96688a4..c2fe6f394d 100644
--- a/proto.h
+++ b/proto.h
@@ -1169,7 +1169,7 @@ PERL_CALLCONV void	Perl_get_db_sub(pTHX_ SV **svp, CV *cv)
 #define PERL_ARGS_ASSERT_GET_DB_SUB	\
 	assert(cv)
 
-PERL_CALLCONV void	Perl_get_hash_seed(pTHX_ unsigned char *seed_buffer)
+PERL_CALLCONV void	Perl_get_hash_seed(pTHX_ unsigned char * const seed_buffer)
 			__attribute__nonnull__(pTHX_1);
 #define PERL_ARGS_ASSERT_GET_HASH_SEED	\
 	assert(seed_buffer)
diff --git a/t/run/runenv.t b/t/run/runenv.t
index a52b5eeb46..b3df796dd1 100644
--- a/t/run/runenv.t
+++ b/t/run/runenv.t
@@ -12,7 +12,7 @@ BEGIN {
     skip_all_without_config('d_fork');
 }
 
-plan tests => 94;
+plan tests => 104;
 
 my $STDOUT = tempfile();
 my $STDERR = tempfile();
@@ -214,6 +214,34 @@ try({PERL_HASH_SEED_DEBUG => 1},
     '',
     qr/HASH_SEED =/);
 
+# special case, seed "0" implies disabled hash key traversal randomization
+try({PERL_HASH_SEED_DEBUG => 1, PERL_HASH_SEED => "0"},
+    ['-e','1'],
+    '',
+    qr/PERTURB_KEYS = 0/);
+
+# check that setting it to a different value with the same logical value
+# triggers the normal "deterministic mode".
+try({PERL_HASH_SEED_DEBUG => 1, PERL_HASH_SEED => "0x0"},
+    ['-e','1'],
+    '',
+    qr/PERTURB_KEYS = 2/);
+
+try({PERL_HASH_SEED_DEBUG => 1, PERL_PERTURB_KEYS => "0"},
+    ['-e','1'],
+    '',
+    qr/PERTURB_KEYS = 0/);
+
+try({PERL_HASH_SEED_DEBUG => 1, PERL_PERTURB_KEYS => "1"},
+    ['-e','1'],
+    '',
+    qr/PERTURB_KEYS = 1/);
+
+try({PERL_HASH_SEED_DEBUG => 1, PERL_PERTURB_KEYS => "2"},
+    ['-e','1'],
+    '',
+    qr/PERTURB_KEYS = 2/);
+
 try({PERL_HASH_SEED_DEBUG => 1, PERL_HASH_SEED => "12345678"},
     ['-e','1'],
     '',
@@ -228,6 +256,25 @@ try({PERL_HASH_SEED_DEBUG => 1, PERL_HASH_SEED => "123456789"},
     ['-e','1'],
     '',
     qr/HASH_SEED = 0x12345678/);
+
+# Test that PERL_PERTURB_KEYS works as expected.  We check that we get the same
+# results if we use PERL_PERTURB_KEYS = 0 or 2 and we reuse the seed from previous run.
+my @print_keys = ( '-e', '@_{"A".."Z"}=(); print keys %_');
+for my $mode ( 0,1, 2 ) { # disabled and deterministic respectively
+    my %base_opts = ( PERL_PERTURB_KEYS => $mode, PERL_HASH_SEED_DEBUG => 1 ),
+    my ($out, $err) = runperl_and_capture( { %base_opts }, [ @print_keys ]);
+    if ($err=~/HASH_SEED = (0x[a-f0-9]+)/) {
+        my $seed = $1;
+        my($out2, $err2) = runperl_and_capture( { %base_opts, PERL_HASH_SEED => $seed }, [ @print_keys ]);
+        if ( $mode == 1 ) {
+            isnt ($out,$out2,"PERL_PERTURB_KEYS = $mode results in different key order with the same key");
+        } else {
+            is ($out,$out2,"PERL_PERTURB_KEYS = $mode allows one to recreate a random hash");
+        }
+        is ($err,$err2,"Got the same debug output when we set PERL_HASH_SEED and PERL_PERTURB_KEYS");
+    }
+}
+
 # Tests for S_incpush_use_sep():
 
 my @dump_inc = ('-e', 'print "$_\n" foreach @INC');
diff --git a/util.c b/util.c
index 56cf5f1fde..ec9cc5e74f 100644
--- a/util.c
+++ b/util.c
@@ -5661,53 +5661,58 @@ Perl_seed(pTHX)
 }
 
 void
-Perl_get_hash_seed(pTHX_ unsigned char *seed_buffer)
+Perl_get_hash_seed(pTHX_ unsigned char * const seed_buffer)
 {
     dVAR;
-    const char *s;
-    const unsigned char * const end= seed_buffer + PERL_HASH_SEED_BYTES;
+    const char *env_pv;
+    unsigned long i;
 
     PERL_ARGS_ASSERT_GET_HASH_SEED;
 
-    s= PerlEnv_getenv("PERL_HASH_SEED");
+    env_pv= PerlEnv_getenv("PERL_HASH_SEED");
 
-    if ( s )
+    if ( env_pv )
 #ifndef USE_HASH_SEED_EXPLICIT
     {
-        while (isSPACE(*s))
-	    s++;
+        /* ignore leading spaces */
+        while (isSPACE(*env_pv))
+            env_pv++;
 #ifdef USE_PERL_PERTURB_KEYS
-        if (s[0] == '0' && s[1] == 0) {
+        /* if they set it to "0" we disable key traversal randomization completely */
+        if (strEQ(env_pv,"0")) {
             PL_hash_rand_bits_enabled= 0;
         } else {
+            /* otherwise switch to deterministic mode */
             PL_hash_rand_bits_enabled= 2;
         }
 #endif
-        if (s[0] == '0' && s[1] == 'x')
-            s += 2;
+        /* ignore a leading 0x... if it is there */
+        if (env_pv[0] == '0' && env_pv[1] == 'x')
+            env_pv += 2;
 
-        while (isXDIGIT(*s) && seed_buffer < end) {
-            *seed_buffer = READ_XDIGIT(s) << 4;
-            if (isXDIGIT(*s)) {
-                *seed_buffer |= READ_XDIGIT(s);
+        for( i = 0; isXDIGIT(*env_pv) && i < PERL_HASH_SEED_BYTES; i++ ) {
+            seed_buffer[i] = READ_XDIGIT(env_pv) << 4;
+            if ( isXDIGIT(*env_pv)) {
+                seed_buffer[i] |= READ_XDIGIT(env_pv);
             }
-            seed_buffer++;
         }
-        while (isSPACE(*s))
-	    s++;
-        if (*s && !isXDIGIT(*s)) {
+        while (isSPACE(*env_pv))
+            env_pv++;
+
+        if (*env_pv && !isXDIGIT(*env_pv)) {
             Perl_warn(aTHX_ "perl: warning: Non hex character in '$ENV{PERL_HASH_SEED}', seed only partially set\n");
         }
         /* should we check for unparsed crap? */
+        /* should we warn about unused hex? */
+        /* should we warn about insufficient hex? */
     }
     else
 #endif
     {
-        unsigned char *ptr= seed_buffer;
         (void)seedDrand01((Rand_seed_t)seed());
 
-        while (ptr < end) {
-            *ptr++ = (unsigned char)(Drand01() * (U8_MAX+1));
+        for( i = 0; i < PERL_HASH_SEED_BYTES; i++ ) {
+            seed_buffer[i] = (unsigned char)(Drand01() * (U8_MAX+1));
         }
     }
 #ifdef USE_PERL_PERTURB_KEYS
@@ -5715,23 +5720,22 @@ Perl_get_hash_seed(pTHX_ unsigned char *seed_buffer)
          * This value is highly volatile, it is updated every
          * hash insert, and is used as part of hash bucket chain
          * randomization and hash iterator randomization. */
-        unsigned long i;
-        PL_hash_rand_bits= 0xee49d17f;
+        PL_hash_rand_bits= 0xbe49d17f; /* I just picked a number */
         for( i = 0; i < sizeof(UV) ; i++ ) {
             PL_hash_rand_bits += seed_buffer[i % PERL_HASH_SEED_BYTES];
             PL_hash_rand_bits = ROTL_UV(PL_hash_rand_bits,8);
         }
     }
-    s= PerlEnv_getenv("PERL_PERTURB_KEYS");
-    if (s) {
-        if (strEQ(s,"0") || strEQ(s,"NO")) {
+    env_pv= PerlEnv_getenv("PERL_PERTURB_KEYS");
+    if (env_pv) {
+        if (strEQ(env_pv,"0") || strEQ(env_pv,"NO")) {
             PL_hash_rand_bits_enabled= 0;
-        } else if (strEQ(s,"1") || strEQ(s,"RANDOM")) {
+        } else if (strEQ(env_pv,"1") || strEQ(env_pv,"RANDOM")) {
             PL_hash_rand_bits_enabled= 1;
-        } else if (strEQ(s,"2") || strEQ(s,"DETERMINISTIC")) {
+        } else if (strEQ(env_pv,"2") || strEQ(env_pv,"DETERMINISTIC")) {
             PL_hash_rand_bits_enabled= 2;
         } else {
-            Perl_warn(aTHX_ "perl: warning: strange setting in '$ENV{PERL_PERTURB_KEYS}': '%s'\n",s);
+            Perl_warn(aTHX_ "perl: warning: strange setting in '$ENV{PERL_PERTURB_KEYS}': '%s'\n", env_pv);
         }
     }
 #endif