diff options
Diffstat (limited to 'nixos/lib/test-driver/test-driver.pl')
-rw-r--r-- | nixos/lib/test-driver/test-driver.pl | 178 |
1 files changed, 178 insertions, 0 deletions
diff --git a/nixos/lib/test-driver/test-driver.pl b/nixos/lib/test-driver/test-driver.pl new file mode 100644 index 000000000000..c6a707cdf6b9 --- /dev/null +++ b/nixos/lib/test-driver/test-driver.pl @@ -0,0 +1,178 @@ +#! /somewhere/perl -w + +use strict; +use Machine; +use Term::ReadLine; +use IO::File; +use IO::Pty; +use Logger; +use Cwd; +use POSIX qw(_exit dup2); + +$SIG{PIPE} = 'IGNORE'; # because Unix domain sockets may die unexpectedly + +STDERR->autoflush(1); + +my $log = new Logger; + + +# Start vde_switch for each network required by the test. +my %vlans; +foreach my $vlan (split / /, $ENV{VLANS} || "") { + next if defined $vlans{$vlan}; + # Start vde_switch as a child process. We don't run it in daemon + # mode because we want the child process to be cleaned up when we + # die. Since we have to make sure that the control socket is + # ready, we send a dummy command to vde_switch (via stdin) and + # wait for a reply. Note that vde_switch requires stdin to be a + # TTY, so we create one. + $log->log("starting VDE switch for network $vlan"); + my $socket = Cwd::abs_path "./vde$vlan.ctl"; + my $pty = new IO::Pty; + my ($stdoutR, $stdoutW); pipe $stdoutR, $stdoutW; + my $pid = fork(); die "cannot fork" unless defined $pid; + if ($pid == 0) { + dup2(fileno($pty->slave), 0); + dup2(fileno($stdoutW), 1); + exec "vde_switch -s $socket" or _exit(1); + } + close $stdoutW; + print $pty "version\n"; + readline $stdoutR or die "cannot start vde_switch"; + $ENV{"QEMU_VDE_SOCKET_$vlan"} = $socket; + $vlans{$vlan} = $pty; + die unless -e "$socket/ctl"; +} + + +my %vms; +my $context = ""; + +sub createMachine { + my ($args) = @_; + my $vm = Machine->new({%{$args}, log => $log, redirectSerial => ($ENV{USE_SERIAL} // "0") ne "1"}); + $vms{$vm->name} = $vm; + return $vm; +} + +foreach my $vmScript (@ARGV) { + my $vm = createMachine({startCommand => $vmScript}); + $context .= "my \$" . $vm->name . " = \$vms{'" . $vm->name . "'}; "; +} + + +sub startAll { + $log->nest("starting all VMs", sub { + $_->start foreach values %vms; + }); +} + + +# Wait until all VMs have terminated. +sub joinAll { + $log->nest("waiting for all VMs to finish", sub { + $_->waitForShutdown foreach values %vms; + }); +} + + +# In interactive tests, this allows the non-interactive test script to +# be executed conveniently. +sub testScript { + eval "$context $ENV{testScript};\n"; + warn $@ if $@; +} + + +my $nrTests = 0; +my $nrSucceeded = 0; + + +sub subtest { + my ($name, $coderef) = @_; + $log->nest("subtest: $name", sub { + $nrTests++; + eval { &$coderef }; + if ($@) { + $log->log("error: $@", { error => 1 }); + } else { + $nrSucceeded++; + } + }); +} + + +sub runTests { + if (defined $ENV{tests}) { + $log->nest("running the VM test script", sub { + eval "$context $ENV{tests}"; + if ($@) { + $log->log("error: $@", { error => 1 }); + die $@; + } + }, { expanded => 1 }); + } else { + my $term = Term::ReadLine->new('nixos-vm-test'); + $term->ReadHistory; + while (defined ($_ = $term->readline("> "))) { + eval "$context $_\n"; + warn $@ if $@; + } + $term->WriteHistory; + } + + # Copy the kernel coverage data for each machine, if the kernel + # has been compiled with coverage instrumentation. + $log->nest("collecting coverage data", sub { + foreach my $vm (values %vms) { + my $gcovDir = "/sys/kernel/debug/gcov"; + + next unless $vm->isUp(); + + my ($status, $out) = $vm->execute("test -e $gcovDir"); + next if $status != 0; + + # Figure out where to put the *.gcda files so that the + # report generator can find the corresponding kernel + # sources. + my $kernelDir = $vm->mustSucceed("echo \$(dirname \$(readlink -f /run/current-system/kernel))/.build/linux-*"); + chomp $kernelDir; + my $coverageDir = "/tmp/xchg/coverage-data/$kernelDir"; + + # Copy all the *.gcda files. + $vm->execute("for d in $gcovDir/nix/store/*/.build/linux-*; do for i in \$(cd \$d && find -name '*.gcda'); do echo \$i; mkdir -p $coverageDir/\$(dirname \$i); cp -v \$d/\$i $coverageDir/\$i; done; done"); + } + }); + + if ($nrTests != 0) { + $log->log("$nrSucceeded out of $nrTests tests succeeded", + ($nrSucceeded < $nrTests ? { error => 1 } : { })); + } +} + + +# Create an empty raw virtual disk with the given name and size (in +# MiB). +sub createDisk { + my ($name, $size) = @_; + system("qemu-img create -f raw $name ${size}M") == 0 + or die "cannot create image of size $size"; +} + + +END { + $log->nest("cleaning up", sub { + foreach my $vm (values %vms) { + if ($vm->{pid}) { + $log->log("killing " . $vm->{name} . " (pid " . $vm->{pid} . ")"); + kill 9, $vm->{pid}; + } + } + }); + $log->close(); +} + + +runTests; + +exit ($nrSucceeded < $nrTests ? 1 : 0); |