diff --git a/MANIFEST b/MANIFEST index 20548634b26c..92a19fd7536a 100644 --- a/MANIFEST +++ b/MANIFEST @@ -6122,6 +6122,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 diff --git a/hv.c b/hv.c index f503dae14c69..e971463d7547 100644 --- a/hv.c +++ b/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 ) { diff --git a/t/run/runenv.t b/t/run/runenv.t index a709f51c9a2b..a406fd317464 100644 --- a/t/run/runenv.t +++ b/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); diff --git a/t/run/runenv_hashseed.t b/t/run/runenv_hashseed.t new file mode 100644 index 000000000000..9c5d45560439 --- /dev/null +++ b/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" + ); + } + } +} diff --git a/t/test.pl b/t/test.pl index 945ad20702c6..33501bbd6052 100644 --- a/t/test.pl +++ b/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;