#!./perl
# We do all of the work in child processes here to ensure that any
# memory used is released immediately.
# These tests use ridiculous amounts of memory and CPU.
use strict;
use warnings;
use Config;
use Storable qw(store_fd retrieve_fd nstore_fd);
use Test::More;
use File::Temp qw(tempfile);
use File::Spec;
BEGIN {
plan skip_all => 'Storable was not built'
if $ENV{PERL_CORE} && $Config{'extensions'} !~ /\b Storable \b/x;
plan skip_all => 'Need 64-bit pointers for this test'
if $Config{ptrsize} < 8 and $] > 5.013;
plan skip_all => 'Need 64-bit int for this test on older versions'
if $Config{uvsize} < 8 and $] < 5.013;
plan skip_all => 'Need ~8 GiB memory for this test, set PERL_TEST_MEMORY >= 8'
if !$ENV{PERL_TEST_MEMORY} || $ENV{PERL_TEST_MEMORY} < 8;
plan skip_all => 'These tests are slow, set PERL_RUN_SLOW_TESTS'
unless $ENV{PERL_RUN_SLOW_TESTS};
plan skip_all => "Need fork for this test",
unless $Config{d_fork};
}
find_exe("gzip")
or plan skip_all => "Need gzip for this test";
find_exe("gunzip")
or plan skip_all => "Need gunzip for this test";
plan tests => 12;
my $skips = $ENV{PERL_STORABLE_SKIP_ID_TEST} || '';
my $keeps = $ENV{PERL_STORABLE_KEEP_ID_TEST};
freeze_thaw_test
(
name => "object ids between 2G and 4G",
freeze => \&make_2g_data,
thaw => \&check_2g_data,
id => "2g",
memory => 34,
);
freeze_thaw_test
(
name => "object ids over 4G",
freeze => \&make_4g_data,
thaw => \&check_4g_data,
id => "4g",
memory => 70,
);
freeze_thaw_test
(
name => "hook object ids over 4G",
freeze => \&make_hook_data,
thaw => \&check_hook_data,
id => "hook4g",
memory => 70,
);
# not really an id test, but the infrastructure here makes tests
# easier
freeze_thaw_test
(
name => "network store large PV",
freeze => \&make_net_large_pv,
thaw => \&check_net_large_pv,
id => "netlargepv",
memory => 8,
);
freeze_thaw_test
(
name => "hook store with 2g data",
freeze => \&make_2g_hook_data,
thaw => \&check_2g_hook_data,
id => "hook2gdata",
memory => 4,
);
freeze_thaw_test
(
name => "hook store with 4g data",
freeze => \&make_4g_hook_data,
thaw => \&check_4g_hook_data,
id => "hook4gdata",
memory => 8,
);
sub freeze_thaw_test {
my %opts = @_;
my $freeze = $opts{freeze}
or die "Missing freeze";
my $thaw = $opts{thaw}
or die "Missing thaw";
my $id = $opts{id}
or die "Missing id";
my $name = $opts{name}
or die "Missing name";
my $memory = $opts{memory}
or die "Missing memory";
my $todo_thaw = $opts{todo_thaw} || "";
SKIP:
{
# IPC::Run would be handy here
$ENV{PERL_TEST_MEMORY} >= $memory
or skip "Not enough memory to test $name", 2;
$skips =~ /\b\Q$id\E\b/
and skip "You requested test $name ($id) be skipped", 2;
defined $keeps && $keeps !~ /\b\Q$id\E\b/
and skip "You didn't request test $name ($id)", 2;
my $stored;
if (defined(my $pid = open(my $fh, "-|"))) {
unless ($pid) {
# child
open my $cfh, "|-", "gzip"
or die "Cannot pipe to gzip: $!";
binmode $cfh;
$freeze->($cfh);
exit;
}
# parent
$stored = do { local $/; <$fh> };
close $fh;
}
else {
skip "$name: Cannot fork for freeze", 2;
}
ok($stored, "$name: we got output data")
or skip "$name: skipping thaw test", 1;
my ($tfh, $tname) = tempfile();
#my $tname = "$id.store.gz";
#open my $tfh, ">", $tname or die;
#binmode $tfh;
print $tfh $stored;
close $tfh;
if (defined(my $pid = open(my $fh, "-|"))) {
unless ($pid) {
# child
open my $bfh, "-|", "gunzip <$tname"
or die "Cannot pipe from gunzip: $!";
binmode $bfh;
$thaw->($bfh);
exit;
}
my $out = do { local $/; <$fh> };
chomp $out;
local $TODO = $todo_thaw;
is($out, "OK", "$name: check result");
}
else {
skip "$name: Cannot fork for thaw", 1;
}
}
}
sub make_2g_data {
my ($fh) = @_;
my @x;
my $y = 1;
my $z = 2;
my $g2 = 0x80000000;
$x[0] = \$y;
$x[$g2] = \$y;
$x[$g2+1] = \$z;
$x[$g2+2] = \$z;
store_fd(\@x, $fh);
}
sub check_2g_data {
my ($fh) = @_;
my $x = retrieve_fd($fh);
my $g2 = 0x80000000;
$x->[0] == $x->[$g2]
or die "First entry mismatch";
$x->[$g2+1] == $x->[$g2+2]
or die "2G+ entry mismatch";
print "OK";
}
sub make_4g_data {
my ($fh) = @_;
my @x;
my $y = 1;
my $z = 2;
my $g4 = 2*0x80000000;
$x[0] = \$y;
$x[$g4] = \$y;
$x[$g4+1] = \$z;
$x[$g4+2] = \$z;
store_fd(\@x, $fh);
}
sub check_4g_data {
my ($fh) = @_;
my $x = retrieve_fd($fh);
my $g4 = 2*0x80000000;
$x->[0] == $x->[$g4]
or die "First entry mismatch";
$x->[$g4+1] == $x->[$g4+2]
or die "4G+ entry mismatch";
${$x->[$g4+1]} == 2
or die "Incorrect value in 4G+ entry";
print "OK";
}
sub make_hook_data {
my ($fh) = @_;
my @x;
my $y = HookLargeIds->new(101, { name => "one" });
my $z = HookLargeIds->new(201, { name => "two" });
my $g4 = 2*0x8000_0000;
$x[0] = $y;
$x[$g4] = $y;
$x[$g4+1] = $z;
$x[$g4+2] = $z;
store_fd(\@x, $fh);
}
sub check_hook_data {
my ($fh) = @_;
my $x = retrieve_fd($fh);
my $g4 = 2*0x8000_0000;
my $y = $x->[$g4+1];
$y = $x->[$g4+1];
$y->id == 201
or die "Incorrect id in 4G+ object";
ref($y->data) eq 'HASH'
or die "data isn't a ref";
$y->data->{name} eq "two"
or die "data name not 'one'";
print "OK";
}
sub make_net_large_pv {
my ($fh) = @_;
my $x = "x"; # avoid constant folding making a 4G scalar
my $g4 = 2*0x80000000;
my $y = $x x ($g4 + 5);
nstore_fd(\$y, $fh);
}
sub check_net_large_pv {
my ($fh) = @_;
my $x = retrieve_fd($fh);
my $g4 = 2*0x80000000;
ref $x && ref($x) eq "SCALAR"
or die "Not a scalar ref ", ref $x;
length($$x) == $g4+5
or die "Incorect length";
print "OK";
}
sub make_2g_hook_data {
my ($fh) = @_;
my $g2 = 0x80000000;
my $x = HookLargeData->new($g2);
store_fd($x, $fh);
}
sub check_2g_hook_data {
my ($fh) = @_;
my $x = retrieve_fd($fh);
my $g2 = 0x80000000;
$x->size == $g2
or die "Size incorrect ", $x->size;
print "OK";
}
sub make_4g_hook_data {
my ($fh) = @_;
my $g2 = 0x80000000;
my $g4 = 2 * $g2;
my $x = HookLargeData->new($g4+1);
store_fd($x, $fh);
}
sub check_4g_hook_data {
my ($fh) = @_;
my $x = retrieve_fd($fh);
my $g2 = 0x80000000;
my $g4 = 2 * $g2;
$x->size == $g4+1
or die "Size incorrect ", $x->size;
print "OK";
}
sub find_exe {
my ($exe) = @_;
$exe .= $Config{_exe};
my @path = split /\Q$Config{path_sep}/, $ENV{PATH};
for my $dir (@path) {
my $abs = File::Spec->catfile($dir, $exe);
-x $abs
and return $abs;
}
}
package HookLargeIds;
sub new {
my $class = shift;
my ($id, $data) = @_;
return bless { id => $id, data => $data }, $class;
}
sub STORABLE_freeze {
#print STDERR "freeze called\n";
#Devel::Peek::Dump($_[0]);
return $_[0]->id, $_[0]->data;
}
sub STORABLE_thaw {
my ($self, $cloning, $ser, $data) = @_;
#Devel::Peek::Dump(\@_);
#print STDERR "thaw called\n";
#Devel::Peek::Dump($self);
$self->{id} = $ser+0;
$self->{data} = $data;
}
sub id {
$_[0]{id};
}
sub data {
$_[0]{data};
}
package HookLargeData;
sub new {
my ($class, $size) = @_;
return bless { size => $size }, $class;
}
sub STORABLE_freeze {
return "x" x $_[0]{size};
}
sub STORABLE_thaw {
my ($self, $cloning, $ser) = @_;
$self->{size} = length $ser;
}
sub size {
$_[0]{size};
}