#!./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 => '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};
}
