App-FuguVM
view release on metacpan or search on metacpan
t/fuguvm/cli.t view on Meta::CPAN
# clear removes everything. clear --stale keeps the invoked VM's key.
{
my $project = _cache_project();
my $cache = App::FuguVM::DiskCache->new("$project/cache");
my $current = $cache->key(
App::FuguVM::Config->new($project)->load_vm('default'));
ok(defined $current, 'the configured VM derives a cache key');
_fake_entry($cache, $current);
_fake_entry($cache, '7.7-arm64-00000000');
make_path($cache->installed_dir . '/.tmp.999.abcdef');
is(scalar @{ $cache->list }, 2, 'two entries before pruning');
is(App::FuguVM::CLI->run("--project=$project", '--quiet',
'cache', 'clear', '--stale'),
0, 'cache clear --stale succeeds');
my $left = $cache->list;
is(scalar @$left, 1, '--stale keeps exactly one entry');
is($left->[0]{key}, $current, 'and it is the invoked VM\'s key');
ok(!-e $cache->installed_dir . '/.tmp.999.abcdef',
'--stale also sweeps interrupted store trees');
is(App::FuguVM::CLI->run("--project=$project", '--quiet', 'cache', 'clear'),
0, 'bare cache clear succeeds');
is(scalar @{ $cache->list }, 0, 'bare clear removes everything');
}
# The proxy's downloads share cache_dir with the images, and nothing
# else bounds them. Thus the same command prunes both. --stale keeps the
# OpenBSD version the invoked VM installs. A bare clear keeps nothing.
{
my $project = _cache_project();
my $proxy = App::FuguVM::Proxy::Cache->new("$project/cache");
_fake_download($project, '7.8/arm64/base78.tgz');
_fake_download($project, '7.7/arm64/base77.tgz');
is(scalar @{ $proxy->list }, 2, 'two cached downloads before pruning');
is(App::FuguVM::CLI->run("--project=$project", '--quiet',
'cache', 'clear', '--stale'),
0, 'cache clear --stale succeeds');
is_deeply([map { $_->{url} } @{ $proxy->list }],
['http://cdn.openbsd.org/pub/OpenBSD/7.8/arm64/base78.tgz'],
'--stale keeps the version the configured VM installs');
is(App::FuguVM::CLI->run("--project=$project", '--quiet', 'cache', 'clear'),
0, 'bare cache clear succeeds');
is(scalar @{ $proxy->list }, 0, 'bare clear empties the proxy too');
}
# The listing also reports the proxy. Thus a user who decides on a
# prune sees both halves of cache_dir.
{
my $project = _cache_project();
_fake_download($project, '7.7/arm64/base77.tgz');
my $err = _capture_stderr($project, 'cache', 'list');
like($err, qr/Proxy downloads/, 'cache list reports the proxy store');
like($err, qr/OpenBSD 7\.7/, 'broken down by version');
like($err, qr/No cached images/,
'and still says the images are empty');
unlike($err, qr/Distfiles/, 'an empty distfile tree has no line');
}
# The distfile line of cache list: the size against the cap, or the
# size with a note that the cap is off. A distfile never joins the
# per-version grouping, because it carries no version.
{
my $project = _cache_project("distfile_cache 4G\n");
_fake_download($project, '7.8/arm64/base78.tgz');
_fake_distfile($project, 'gmake-4.4.1.tar.gz');
my $err = _capture_stderr($project, 'cache', 'list');
like($err, qr/Distfiles: \d+B of 4\.0G/,
'cache list reports the distfile size and the cap');
is(scalar(grep { /OpenBSD -/ } split /\n/, $err), 0,
'no distfile lands in the version grouping');
my $off = _cache_project();
_fake_distfile($off, 'gmake-4.4.1.tar.gz');
$err = _capture_stderr($off, 'cache', 'list');
like($err, qr/Distfiles: \d+B, caching off/,
'a tree with a cap of 0 reads as caching off');
}
# cache clear --stale keeps the distfile tree and re-applies the cap;
# a bare clear removes the tree with everything else
{
my $project = _cache_project("distfile_cache 4G\n");
_fake_download($project, '7.7/arm64/base77.tgz');
my $distfile = _fake_distfile($project, 'gmake-4.4.1.tar.gz');
is(App::FuguVM::CLI->run("--project=$project", '--quiet',
'cache', 'clear', '--stale'),
0, 'cache clear --stale succeeds');
ok(-f $distfile, '--stale keeps the distfile tree');
is(App::FuguVM::CLI->run("--project=$project", '--quiet',
'cache', 'clear'),
0, 'bare cache clear succeeds');
ok(!-e $distfile, 'and it removes the distfile tree with the rest');
}
# With a cap of 0 no cap applies to --stale, so the flag keeps the
# whole tree: 0 turns the cache off for new stores, and it must not
# read as "keep nothing" here.
{
my $project = _cache_project();
my $distfile = _fake_distfile($project, 'gmake-4.4.1.tar.gz');
is(App::FuguVM::CLI->run("--project=$project", '--quiet',
'cache', 'clear', '--stale'),
0, 'cache clear --stale succeeds with a cap of 0');
ok(-f $distfile, 'and it keeps the distfile tree');
}
# ============================================================
# The mirror subcommand
# ============================================================
# The argument refusals, each with exit code 2
{
my $project = _cache_project();
local $SIG{__WARN__} = sub {};
is(App::FuguVM::CLI->run("--project=$project", '--quiet', 'mirror'), 2,
'mirror without an action returns EXIT_INVALID_ARGS');
is(App::FuguVM::CLI->run("--project=$project", '--quiet',
'mirror', 'frobnicate'),
2, 'an unknown mirror action returns EXIT_INVALID_ARGS');
is(App::FuguVM::CLI->run("--project=$project", '--quiet',
'mirror', 'fetch'),
2, 'mirror fetch without a file returns EXIT_INVALID_ARGS');
is(App::FuguVM::CLI->run("--project=$project", '--quiet',
'mirror', 'verify', 'extra'),
2, 'mirror verify with an argument returns EXIT_INVALID_ARGS');
}
# mirror verify over an empty cache exits 0: no manifest is cached,
# so nothing needs a proof, and the verb is idempotent
{
t/fuguvm/cli.t view on Meta::CPAN
$state->mark_installed('arm64');
local $SIG{__WARN__} = sub {};
is(App::FuguVM::CLI->run("--project=$project", '--quiet',
'snapshot', 'save', 'deps'),
1, 'a standalone disk is a diagnosed error, not a crash');
# Rebuild the disk as an overlay on a cached base
my $base = $cache->store($key, $source, { root_password => 'pw' });
unlink $disk->path('default');
$disk->create('default', undef, $base);
is(App::FuguVM::CLI->run("--project=$project", '--quiet',
'snapshot', 'save', 'deps'),
0, 'save succeeds on a disk backed by a cached image');
ok(defined $cache->snapshot_lookup($key, 'deps'), 'the snapshot exists');
is(App::FuguVM::CLI->run("--project=$project", '--quiet',
'snapshot', 'list'),
0, 'list succeeds');
is(App::FuguVM::CLI->run("--project=$project", '--quiet',
'snapshot', 'restore', 'deps'),
0, 'restore succeeds');
is($disk->backing_file('default'),
$cache->snapshot_path($key, 'deps'),
'restore actually replaced the disk with an overlay on the snapshot');
# Restore from nothing. No disk and no state exist, as in a
# fresh checkout.
unlink $disk->path('default');
unlink "$state_dir/default/status";
is(App::FuguVM::CLI->run("--project=$project", '--quiet',
'snapshot', 'restore', 'deps'),
0, 'restore works with no disk and no state');
my $reseeded = App::FuguVM::State->new($state_dir, 'default');
ok($reseeded->is_installed, 'restore reseeds installed state');
is($reseeded->get_root_password, 'pw',
'restore reseeds the root password from the base');
# A running VM refuses both save and restore
open my $pidfh, '>', "$state_dir/default/vm.pid" or die $!;
print $pidfh "$$\n";
close $pidfh;
is(App::FuguVM::CLI->run("--project=$project", '--quiet',
'snapshot', 'save', 'deps'),
5, 'save refuses while the VM is running');
is(App::FuguVM::CLI->run("--project=$project", '--quiet',
'snapshot', 'restore', 'deps'),
5, 'restore refuses while the VM is running');
unlink "$state_dir/default/vm.pid";
is(App::FuguVM::CLI->run("--project=$project", '--quiet',
'snapshot', 'rm', 'deps'),
0, 'rm succeeds');
}
# --names is the scriptable listing. It writes bare names on stdout,
# where a shell can read them. It does not go through the stderr logger.
SKIP: {
my $has_qemu = `which qemu-img 2>/dev/null`;
skip 'qemu-img not installed', 4 unless $has_qemu;
my $project = _cache_project();
my $cache = App::FuguVM::DiskCache->new("$project/cache");
my $key = $cache->key(App::FuguVM::Config->new($project)->load_vm('default'));
my $source = "$project/source.qcow2";
system('qemu-img', 'create', '-f', 'qcow2', $source, '16M') == 0
or skip 'cannot create a test disk image', 4;
my $base = $cache->store($key, $source, { root_password => 'pw' });
App::FuguVM::Disk->new("$project/.fuguvm/state")
->create('default', undef, $base);
App::FuguVM::State->new("$project/.fuguvm/state", 'default')->mark_installed('arm64');
is(_capture_stdout($project, 'snapshot', 'list', '--names'), '',
'nothing on stdout when there are no snapshots');
App::FuguVM::CLI->run("--project=$project", '--quiet',
'snapshot', 'save', 'deps-aaa');
App::FuguVM::CLI->run("--project=$project", '--quiet',
'snapshot', 'save', 'deps-bbb');
is(_capture_stdout($project, 'snapshot', 'list', '--names'),
"deps-aaa\ndeps-bbb\n", 'one bare name per line, sorted');
is(_capture_stdout($project, 'snapshot', 'list'), '',
'the human listing writes nothing to stdout');
local $SIG{__WARN__} = sub {};
is(App::FuguVM::CLI->run("--project=$project", '--quiet',
'snapshot', 'list', '--bogus'),
2, 'an unknown list option returns EXIT_INVALID_ARGS');
}
# ============================================================
# Image export
# ============================================================
# Usage errors match the style of the other subcommands
{
my $project = _cache_project();
local $SIG{__WARN__} = sub {};
is(App::FuguVM::CLI->run("--project=$project", '--quiet', 'image'), 2,
'image without an action returns EXIT_INVALID_ARGS');
is(App::FuguVM::CLI->run("--project=$project", '--quiet',
'image', 'frobnicate'), 2,
'an unknown image action returns EXIT_INVALID_ARGS');
is(App::FuguVM::CLI->run("--project=$project", '--quiet',
'image', 'export'), 2,
'image export without a path returns EXIT_INVALID_ARGS');
my ($code, $out, $err) = _run_captured("--project=$project",
'image', 'export', "$project/out.qcow2", '--format=vmdk');
is($code, 2, 'an unknown --format value returns EXIT_INVALID_ARGS');
like($err, qr/qcow2.*raw/, 'and the diagnostic names both formats');
}
# The refusals and the export itself, over a real backing chain
t/fuguvm/cli.t view on Meta::CPAN
# An existing target stays unchanged
my $before = -s $target;
is(App::FuguVM::CLI->run("--project=$project", '--quiet',
'image', 'export', $target),
1, 'a second export onto the same path exits 1');
is(-s $target, $before, 'and the file stays unchanged');
# The raw form
($code) = _run_captured("--project=$project", '--quiet',
'image', 'export', "$project/out.raw", '--format=raw');
is($code, 0, 'a raw export succeeds');
like(`qemu-img info "$project/out.raw"`, qr/file format: raw/,
'and writes the raw format');
}
# A byte count for a person to read is presentation, so the CLI owns
# it. The cases came with the function from Fugu::Timeout.
subtest '_format_size' => sub {
my $f = \&App::FuguVM::CLI::_format_size;
is( $f->(0), '0B', 'zero' );
is( $f->(512), '512B', 'bytes' );
is( $f->(1023), '1023B', 'just under 1K' );
is( $f->(1024), '1.0K', 'one kilobyte' );
is( $f->(1536), '1.5K', 'one and a half' );
is( $f->(1024**2), '1.0M', 'one megabyte' );
is( $f->(1024**3), '1.0G', 'one gigabyte' );
is( $f->(1024**4), '1.0T', 'one terabyte' );
is( $f->(1024**5), '1024.0T',
'past the largest unit it keeps counting' );
is( $f->(undef), '?',
'a size nobody could measure is not a size of zero' );
};
done_testing();
# A project whose cache_dir points inside the project. Thus the tests
# never touch the developer's real ~/.cache/fuguvm. The optional
# argument appends top-level configuration lines.
sub _cache_project
{
my ($extra) = @_;
my $project = tempdir(CLEANUP => 1);
make_path("$project/.fuguvm/vms", "$project/.fuguvm/state");
open my $fh, '>', "$project/.fuguvmrc" or die $!;
print $fh "cache_dir $project/cache\n";
print $fh "state_dir .fuguvm/state\n";
print $fh "default_vm default\n";
print $fh $extra if defined $extra;
print $fh "vm \"default\" {\n";
print $fh "\tversion 7.8\n";
print $fh "\tdisk_size 8G\n";
print $fh "}\n";
close $fh;
return $project;
}
# Run a command with both streams captured, and return the exit
# code, the stdout text and the stderr text. Thus scriptable output
# cannot mix with the TAP stream of this test. The capture goes
# through real files, never through an in-memory scalar: a scalar
# handle has no file descriptor, and the output of a child process
# would then land wherever descriptor 1 points at that moment.
sub _run_captured
{
my (@args) = @_;
my $dir = tempdir(CLEANUP => 1);
open my $saved_out, '>&', \*STDOUT or die $!;
open STDOUT, '>', "$dir/out" or die $!;
open my $saved_err, '>&', \*STDERR or die $!;
open STDERR, '>', "$dir/err" or die $!;
my $code = App::FuguVM::CLI->run(@args);
open STDOUT, '>&', $saved_out or die $!;
close $saved_out;
open STDERR, '>&', $saved_err or die $!;
close $saved_err;
return ($code, _slurp("$dir/out"), _slurp("$dir/err"));
}
# Run a command and capture stdout. This separates the scriptable
# output from the logger's stderr.
sub _capture_stdout
{
my ($project, @args) = @_;
my (undef, $out) =
_run_captured("--project=$project", '--quiet', @args);
return $out;
}
# The logger writes to stderr. Thus this helper captures the human
# listing apart from the scriptable output above.
sub _capture_stderr
{
my ($project, @args) = @_;
my (undef, undef, $err) = _run_captured("--project=$project", @args);
return $err;
}
# _slurp($path):
# The whole file as text.
sub _slurp
{
my ($path) = @_;
open my $fh, '<', $path or die "Cannot read $path: $!";
my $text = do { local $/; <$fh> };
close $fh;
return $text;
}
# A cached proxy download, seeded on disk and not through store().
# store() uses cache_path(), which wants URI, a develop dependency.
sub _fake_download
{
my ($project, $rel) = @_;
my $dir = "$project/cache/proxy/cdn.openbsd.org/pub/OpenBSD/$rel";
$dir =~ m{\A(.*)/} and make_path($1);
open my $fh, '>', $dir or die $!;
print $fh 'not a real file set';
close $fh;
return $dir;
}
# _find_signify():
# The signify command on PATH, in the search order of
# Fugu::Signify, or undef.
sub _find_signify
{
for my $name (qw(signify-openbsd signify)) {
for my $dir (split /:/, $ENV{PATH} // '') {
next unless length $dir;
my $path = "$dir/$name";
return $path if -f $path && -x $path;
}
}
return undef;
}
# _fake_mirror_file($project, $relative, $bytes):
# One cached mirror file, seeded on disk at its mirror path.
sub _fake_mirror_file
{
my ($project, $rel, $bytes) = @_;
my $path = "$project/cache/proxy/cdn.openbsd.org/pub/OpenBSD/$rel";
$path =~ m{\A(.*)/} and make_path($1);
open my $fh, '>', $path or die $!;
( run in 0.785 second using v1.01-cache-2.11-cpan-5c0b1e786e0 )