Merge a74e036 into 7ad5408

MANIFEST

@@ -6128,6 +6128,7 @@ 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/script.t			See if script invocation works
 t/run/switch0.t			Test the -0 switch
 t/run/switcha.t			Test the -a switch

hv.c

@@ -848,7 +848,7 @@ Perl_hv_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen,
      * reset the iterator randomizer if there is one.
      */
     in_collision = *oentry != NULL;
-    if ( *oentry && PL_HASH_RAND_BITS_ENABLED) {
+    if ( *oentry && PL_HASH_RAND_BITS_ENABLED == 1 ) {
         PL_hash_rand_bits++;
         PL_hash_rand_bits= ROTL_UV(PL_hash_rand_bits,1);
         if ( PL_hash_rand_bits & 1 ) {

t/run/runenv.t

@@ -24,43 +24,6 @@ delete $ENV{PERL5LIB};
 delete $ENV{PERL5OPT};
 delete $ENV{PERL_USE_UNSAFE_INC};
 
-
-# Run perl with specified environment and arguments, return (STDOUT, STDERR)
-sub runperl_and_capture {
-  local *F;
-  my ($env, $args) = @_;
-
-  local %ENV = %ENV;
-  delete $ENV{PERLLIB};
-  delete $ENV{PERL5LIB};
-  delete $ENV{PERL5OPT};
-  delete $ENV{PERL_USE_UNSAFE_INC};
-  my $pid = fork;
-  return (0, "Couldn't fork: $!") unless defined $pid;   # failure
-  if ($pid) {                   # parent
-    wait;
-    return (0, "Failure in child.\n") if ($?>>8) == $FAILURE_CODE;
-
-    open my $stdout, '<', $STDOUT
-	or return (0, "Couldn't read $STDOUT file: $!");
-    open my $stderr, '<', $STDERR
-	or return (0, "Couldn't read $STDERR file: $!");
-    local $/;
-    # Empty file with <$stderr> returns nothing in list context
-    # (because there are no lines) Use scalar to force it to ''
-    return (scalar <$stdout>, scalar <$stderr>);
-  } else {                      # child
-    for my $k (keys %$env) {
-      $ENV{$k} = $env->{$k};
-    }
-    open STDOUT, '>', $STDOUT or exit $FAILURE_CODE;
-    open STDERR, '>', $STDERR and do { exec $PERL, @$args };
-    # it did not work:
-    print STDOUT "IWHCWJIHCI\cNHJWCJQWKJQJWCQW\n";
-    exit $FAILURE_CODE;
-  }
-}
-
 sub try {
   my ($env, $args, $stdout, $stderr) = @_;
   my ($actual_stdout, $actual_stderr) = runperl_and_capture($env, $args);

t/run/runenv_hashseed.t

@@ -0,0 +1,70 @@
+#!./perl
+#
+# Tests for Perl run-time environment variable settings
+#
+# $PERL5OPT, $PERL5LIB, etc.
+
+BEGIN {
+    chdir 't' if -d 't';
+    @INC = '../lib';
+    require './test.pl';
+    require Config;
+    Config->import;
+}
+
+skip_all_without_config('d_fork');
+skip_all("NO_PERL_HASH_ENV or NO_PERL_HASH_SEED_DEBUG set")
+    if $Config{ccflags} =~ /-DNO_PERL_HASH_ENV\b/
+    || $Config{ccflags} =~ /-DNO_PERL_HASH_SEED_DEBUG\b/;
+
+plan tests => 12;
+
+# 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', 'my %h; @h{"A".."Z", "a".."z"}=(); print keys %h' );
+for my $mode (qw{NO RANDOM DETERMINISTIC}) {    # 0, 1 and 2 respectively
+    my %base_opts;
+    %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;
+        {
+            # Reusing the same HASH_SEED
+            my ( $out2, $err2 )
+                = runperl_and_capture(
+                { %base_opts, PERL_HASH_SEED => $seed },
+                [@print_keys] );
+            if ( $mode eq 'RANDOM' ) {
+                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"
+            );
+        }
+        {
+            # Using a different HASH_SEED
+            my @chars = split //, $seed;
+
+            # increase by 1 the last digit (only)
+            $chars[-1] = sprintf( "%x", ( hex( $chars[-1] ) + 1 ) % 15 );
+            my $updated_seed = join '', @chars;
+            isnt $updated_seed, $seed, "got a different seed";
+            my ( $out2, $err2 )
+                = runperl_and_capture(
+                { %base_opts, PERL_HASH_SEED => $updated_seed },
+                [@print_keys] );
+            isnt( $out, $out2,
+                "PERL_PERTURB_KEYS = $mode results in different order with a different key"
+            );
+        }
+    }
+}

t/test.pl

@@ -818,6 +818,46 @@ sub runperl {
 # Nice alias
 *run_perl = *run_perl = \&runperl; # shut up "used only once" warning
 
+# Run perl with specified environment and arguments, return (STDOUT, STDERR)
+sub runperl_and_capture {
+  my ($env, $args) = @_;
+
+  my $STDOUT = tempfile();
+  my $STDERR = tempfile();
+  my $PERL   = $^X;
+  my $FAILURE_CODE = 119;
+
+  local %ENV = %ENV;
+  delete $ENV{PERLLIB};
+  delete $ENV{PERL5LIB};
+  delete $ENV{PERL5OPT};
+  delete $ENV{PERL_USE_UNSAFE_INC};
+  my $pid = fork;
+  return (0, "Couldn't fork: $!") unless defined $pid;   # failure
+  if ($pid) {                   # parent
+    wait;
+    return (0, "Failure in child.\n") if ($?>>8) == $FAILURE_CODE;
+
+    open my $stdout, '<', $STDOUT
+    or return (0, "Couldn't read $STDOUT file: $!");
+    open my $stderr, '<', $STDERR
+    or return (0, "Couldn't read $STDERR file: $!");
+    local $/;
+    # Empty file with <$stderr> returns nothing in list context
+    # (because there are no lines) Use scalar to force it to ''
+    return (scalar <$stdout>, scalar <$stderr>);
+  } else {                      # child
+    for my $k (keys %$env) {
+      $ENV{$k} = $env->{$k};
+    }
+    open STDOUT, '>', $STDOUT or exit $FAILURE_CODE;
+    open STDERR, '>', $STDERR and do { exec $PERL, @$args };
+    # it did not work:
+    print STDOUT "IWHCWJIHCI\cNHJWCJQWKJQJWCQW\n"; # not really needed?
+    exit $FAILURE_CODE;
+  }
+}
+
 sub DIE {
     _print_stderr "# @_\n";
     exit 1;