One Hat Cyber Team

View File Name : hugeids.t

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