view release on metacpan or  search on metacpan

t/fuguvm/diskcache.t  view on Meta::CPAN

		$cache->snapshot_store( $key, 'another', $source, {} );
	};
	is( $orphan, undef, 'and no new snapshot can be added to it' );
}

done_testing();

sub _backing ($path)
{
	my $out = qx{qemu-img info --output=json "$path" 2>/dev/null};
	my $info = eval { JSON::XS::decode_json($out) };
	return $info->{'full-backing-filename'} // $info->{'backing-filename'};
}

# _lock_in_child($dir, $key, $timeout):
#	Try the entry lock from a child process. Return 1 when the
#	child took the lock, and 0 when its deadline elapsed. The
#	child exits through POSIX::_exit, so it runs no END block of
#	the test harness.
sub _lock_in_child ( $dir, $key, $timeout )
{
	my $pid = fork // die "Cannot fork: $!";
	if ( $pid == 0 ) {
		my $cache = App::FuguVM::DiskCache->new($dir);
		my $lock  = $cache->lock_entry( $key, $timeout );
		require POSIX;
		POSIX::_exit( defined $lock ? 1 : 0 );
	}

	waitpid $pid, 0;
	return $? >> 8;
}

sub _spit ( $path, $content )
{
	open my $fh, '>', $path or die "Cannot write $path: $!";
	binmode $fh;
	print $fh $content;
	close $fh;
	return;
}

sub _temp_trees ($dir)
{
	return 0 if !-d $dir;
	opendir my $dh, $dir or return 0;
	my @tmp = grep { index( $_, '.tmp.' ) == 0 } readdir $dh;
	closedir $dh;
	return scalar @tmp;
}

# A cache whose two file-backed key inputs live in a scratch
# directory. Thus tests can rotate them and never touch the checkout.
package TestInputs;

# The inheritance must be in place before the tests above run
BEGIN { our @ISA = ('App::FuguVM::DiskCache'); }

sub new ( $class, $cache_dir, $input_dir )
{
	my $self = $class->SUPER::new($cache_dir);
	$self->{input_dir} = $input_dir;
	return $self;
}

sub _driver_script ( $self, $name )
{
	my $path = "$self->{input_dir}/$name";
	return -f $path ? $path : undef;
}

sub _generation_file ($self)
{
	my $path = "$self->{input_dir}/cache-generation";
	return -f $path ? $path : undef;
}