chdir 't' if -d 't';
@INC = '../lib';
require Config; import Config;
- unless ($Config{'d_fork'}) {
- print "1..0 # Skip: no fork\n";
- exit 0;
- }
- require './test.pl'
+ require './test.pl';
+ skip_all_without_config('d_fork');
}
-plan tests => 76;
+plan tests => 104;
my $STDOUT = tempfile();
my $STDERR = tempfile();
-my $PERL = $ENV{PERL} || './perl';
+my $PERL = './perl';
my $FAILURE_CODE = 119;
delete $ENV{PERLLIB};
delete $ENV{PERL5OPT};
+# Run perl with specified environment and arguments, return (STDOUT, STDERR)
sub runperl_and_capture {
local *F;
my ($env, $args) = @_;
- unshift @$args, '-I../lib';
local %ENV = %ENV;
delete $ENV{PERLLIB};
my $pid = fork;
return (0, "Couldn't fork: $!") unless defined $pid; # failure
if ($pid) { # parent
- my ($actual_stdout, $actual_stderr);
wait;
return (0, "Failure in child.\n") if ($?>>8) == $FAILURE_CODE;
- open F, "< $STDOUT" or return (0, "Couldn't read $STDOUT file");
- { local $/; $actual_stdout = <F> }
- open F, "< $STDERR" or return (0, "Couldn't read $STDERR file");
- { local $/; $actual_stderr = <F> }
-
- return ($actual_stdout, $actual_stderr);
+ 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" or it_didnt_work();
- { exec $PERL, @$args }
- it_didnt_work();
+ 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;
}
}
-# Run perl with specified environment and arguments returns a list.
-# First element is true if Perl's stdout and stderr match the
-# supplied $stdout and $stderr argument strings exactly.
-# second element is an explanation of the failure
-sub runperl {
- local *F;
+sub try {
my ($env, $args, $stdout, $stderr) = @_;
my ($actual_stdout, $actual_stderr) = runperl_and_capture($env, $args);
- if ($actual_stdout ne $stdout) {
- return (0, "Stdout mismatch: expected [$stdout], saw [$actual_stdout]");
- } elsif ($actual_stderr ne $stderr) {
- return (0, "Stderr mismatch: expected [$stderr], saw [$actual_stderr]");
+ local $::Level = $::Level + 1;
+ my @envpairs = ();
+ for my $k (sort keys %$env) {
+ push @envpairs, "$k => $env->{$k}";
+ }
+ my $label = join(',' => (@envpairs, @$args));
+ if (ref $stdout) {
+ ok ( $actual_stdout =~/$stdout/, $label . ' stdout' );
} else {
- return 1; # success
+ is ( $actual_stdout, $stdout, $label . ' stdout' );
+ }
+ if (ref $stderr) {
+ ok ( $actual_stderr =~/$stderr/, $label . ' stderr' );
+ } else {
+ is ( $actual_stderr, $stderr, $label . ' stderr' );
}
-}
-
-sub it_didnt_work {
- print STDOUT "IWHCWJIHCI\cNHJWCJQWKJQJWCQW\n";
- exit $FAILURE_CODE;
-}
-
-sub try {
- my ($success, $reason) = runperl(@_);
- $reason =~ s/\n/\\n/g if defined $reason;
- local $::Level = $::Level + 1;
- ok( $success, $reason );
}
# PERL5OPT Command-line options (switches). Switches in
"",
qq{Name "main::x" used only once: possible typo at -e line 1.\nUse of uninitialized value \$x in print at -e line 1.\n});
-try({PERL5OPT => '-Mstrict'}, ['-e', 'print $::x'],
+try({PERL5OPT => '-Mstrict'}, ['-I../lib', '-e', 'print $::x'],
"", "");
-try({PERL5OPT => '-Mstrict'}, ['-e', 'print $x'],
+try({PERL5OPT => '-Mstrict'}, ['-I../lib', '-e', 'print $x'],
"",
qq{Global symbol "\$x" requires explicit package name at -e line 1.\nExecution of -e aborted due to compilation errors.\n});
# Fails in 5.6.0
-try({PERL5OPT => '-Mstrict -w'}, ['-e', 'print $x'],
+try({PERL5OPT => '-Mstrict -w'}, ['-I../lib', '-e', 'print $x'],
"",
qq{Global symbol "\$x" requires explicit package name at -e line 1.\nExecution of -e aborted due to compilation errors.\n});
# Fails in 5.6.0
-try({PERL5OPT => '-w -Mstrict'}, ['-e', 'print $::x'],
+try({PERL5OPT => '-w -Mstrict'}, ['-I../lib', '-e', 'print $::x'],
"",
<<ERROR
Name "main::x" used only once: possible typo at -e line 1.
);
# Fails in 5.6.0
-try({PERL5OPT => '-w -Mstrict'}, ['-e', 'print $::x'],
+try({PERL5OPT => '-w -Mstrict'}, ['-I../lib', '-e', 'print $::x'],
"",
<<ERROR
Name "main::x" used only once: possible typo at -e line 1.
ERROR
);
-try({PERL5OPT => '-MExporter'}, ['-e0'],
+try({PERL5OPT => '-MExporter'}, ['-I../lib', '-e0'],
"",
"");
# Fails in 5.6.0
-try({PERL5OPT => '-MExporter -MExporter'}, ['-e0'],
+try({PERL5OPT => '-MExporter -MExporter'}, ['-I../lib', '-e0'],
"",
"");
try({PERL5OPT => '-Mstrict -Mwarnings'},
- ['-e', 'print "ok" if $INC{"strict.pm"} and $INC{"warnings.pm"}'],
+ ['-I../lib', '-e', 'print "ok" if $INC{"strict.pm"} and $INC{"warnings.pm"}'],
+ "ok",
+ "");
+
+open my $fh, ">", "Oooof.pm" or die "Can't write Oooof.pm: $!";
+print $fh "package Oooof; 1;\n";
+close $fh;
+END { 1 while unlink "Oooof.pm" }
+
+try({PERL5OPT => '-I. -MOooof'},
+ ['-e', 'print "ok" if $INC{"Oooof.pm"} eq "Oooof.pm"'],
+ "ok",
+ "");
+
+try({PERL5OPT => '-I./ -MOooof'},
+ ['-e', 'print "ok" if $INC{"Oooof.pm"} eq "Oooof.pm"'],
"ok",
"");
'');
try({PERL5OPT => '-W'},
- ['-e', 'local $^W = 0; no warnings; print $x'],
+ ['-I../lib','-e', 'local $^W = 0; no warnings; print $x'],
'',
<<ERROR
Name "main::x" used only once: possible typo at -e line 1.
'',
'');
+try({PERL_HASH_SEED_DEBUG => 1},
+ ['-e','1'],
+ '',
+ qr/HASH_FUNCTION =/);
+
+try({PERL_HASH_SEED_DEBUG => 1},
+ ['-e','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'],
+ '',
+ qr/HASH_SEED = 0x12345678/);
+
+try({PERL_HASH_SEED_DEBUG => 1, PERL_HASH_SEED => "12"},
+ ['-e','1'],
+ '',
+ qr/HASH_SEED = 0x12000000/);
+
+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');
my @default_inc = split /\n/, $out;
-is (shift @default_inc, '../lib', 'Our -I../lib is at the front');
+is ($default_inc[-1], '.', '. is last in @INC');
my $sep = $Config{path_sep};
foreach (['nothing', ''],
my @inc = split /\n/, $out;
- is (shift @inc, '../lib', 'Our -I../lib is at the front for $name');
-
is (scalar @inc, scalar @expect,
"expected number of elements in \@INC for $name");
}
# PERL5LIB tests with included arch directories still missing
-
-END {
- 1 while unlink $STDOUT;
- 1 while unlink $STDERR;
-}
https://perl5.git.perl.org / perl5.git / blobdiff