# along with this program; if not, write to the Free Software
# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+#use experimental 'smartmatch';
use warnings;
use strict;
use Getopt::Long;
use Pod::Usage;
+
+use Scalar::Util qw(looks_like_number);
+use File::Temp;
+use IO::String;
+
+use XML::XPath;
+use XML::XPath::XMLParser;
+use URI;
+use URI::Escape;
+
+use Sys::Virt;
use Sys::Guestfs;
+$| = 1;
+
=head1 NAME
run-transfer-tests.pl - Run virt-v2v transfer tests
run-transfer-tests.pl -c xen+ssh://root@xenserver' --all
-Use a different version of libguestfs and virt-v2v:
+Use a different version of libguestfs:
/path/to/libguestfs/run run-transfer-tests.pl [etc]
+When connecting to vCenter and Xen, you may need to set the libguestfs
+backend to C<direct>:
+
+ export LIBGUESTFS_BACKEND=direct run-transfer-tests.pl -c vpx://... [etc]
+
=head1 DESCRIPTION
C<run-transfer-tests.pl> is a script which tests the transfer side of
unless defined $conn;
die "$progname: you must use --all or --tests=...\n"
unless $all || @tests > 0;
+die "$progname: you cannot use --all and --tests=... options together\n"
+ if $all && @tests > 0;
+
+# Connect to hypervisor.
+my $vmm = Sys::Virt->new (uri => $conn, auth => 1);
+
+# Get list of guests.
+if (@guests == 0) {
+ my @doms = $vmm->list_domains ();
+ push @guests, $_->get_name foreach @doms;
+ die "$progname: no guests found on the source hypervisor\n"
+ unless @guests > 0;
+}
+
+my $guest;
+foreach $guest (@guests) {
+ my $dom = $vmm->get_domain_by_name ($guest)
+ or die "$progname: $guest: guest not found\n";
+ my $domxml = $dom->get_xml_description ();
+ my $xp = XML::XPath->new (xml => $domxml);
+
+ # Find all non-removable disks and map them to qemu URIs.
+ # Code copied from virt-v2v Input_libvirt_* modules.
+ my @nodes = $xp->find ('//devices/disk[@device="disk"]')->get_nodelist;
+ my $node;
+ my @original_disks;
+ foreach $node (@nodes) {
+ my $filename = $xp->find ('./source/@dev', $node);
+ unless ($filename) {
+ $filename = $xp->find ('./source/@file', $node);
+ next unless $filename
+ }
+ my $format = $xp->find ('./driver/@type', $node);
+ if ($format) { $format->to_literal } else { undef $format }
+ push @original_disks, [$filename, $format];
+ }
+
+ if (@original_disks == 0) {
+ warn "$progname: $guest: guest seems to have no non-removable non-network disks, skipping\n";
+ next;
+ }
+
+ my $uri = URI->new ($conn);
+
+ if ($uri->scheme eq "vpx" || $uri->scheme eq "esx") {
+ my $disk;
+ foreach $disk (@original_disks) {
+ if ($disk->[0] =~ /^\[(.*?)\] (.*)\.vmdk$/) {
+ my $datastore = $1;
+ my $path = $2;
+
+ my $datacenter = get_datacenter ($uri);
+
+ my ($user, $server, $port);
+ if ($uri->authority =~ /^(.*)@(.*):(\d+)$/) {
+ $user = $1;
+ $server = $2;
+ $port = $3;
+ } elsif ($uri->authority =~ /^(.*)@(.*)$/) {
+ $user = $1;
+ $server = $2;
+ $port = 443;
+ } elsif ($uri->authority =~ /^(.*):(\d+)$/) {
+ $server = $1;
+ $port = $2;
+ } else {
+ $server = $uri->authority;
+ $port = 443;
+ }
+
+ my $url =
+ sprintf ("https://%s:%s/folder/%s-flat.vmdk?dcPath=%s&dsName=%s",
+ $server, $port,
+ uri_escape ($path), uri_escape ($datacenter),
+ uri_escape ($datastore));
+
+ my $cookie = get_session_cookie ($url, $user);
+
+ my @json_params = (
+ ["file.driver", "https"],
+ ["file.url", $url],
+ ["file.timeout", 600],
+ # XXX In virt-v2v itself, this changes:
+ ["file.readahead", 64*1024*1024],
+ ["file.sslverify", "off"],
+ ["file.cookie", $cookie],
+ );
+
+ $disk->[0] = "json: " . json_to_string (@json_params);
+ }
+ }
+ }
+ elsif ($uri->scheme eq "xen+ssh") {
+ my $disk;
+ foreach $disk (@original_disks) {
+ my ($user, $server, $port);
+ if ($uri->authority =~ /^(.*)@(.*):(\d+)$/) {
+ $user = $1;
+ $server = $2;
+ $port = $3;
+ } elsif ($uri->authority =~ /^(.*):(\d+)$/) {
+ $server = $1;
+ $port = $2;
+ } else {
+ $server = $uri->authority;
+ $port = 22;
+ }
+
+ my @json_params = (
+ [ "file.driver", "ssh" ],
+ [ "file.path", $disk->[0] ],
+ [ "file.host", $server ],
+ [ "file.host_key_check", "no" ],
+ [ "file.port", $port ]
+ );
+ if ($user) {
+ push @json_params, [ "file.user", $user ];
+ }
+
+ $disk->[0] = "json: " . json_to_string (@json_params);
+ }
+ }
+ # else probably an error? XXX
+
+ # Create overlay disks.
+ my @overlays;
+ foreach (@original_disks) {
+ my $overlay = File::Temp->new (UNLINK => 0);
+ my @cmd = ("qemu-img", "create", "-q", "-f", "qcow2",
+ "-b", $_->[0]);
+ if ($_->[1]) {
+ push @cmd, "-o", "backing_fmt=".$_->[1];
+ }
+ push @cmd, $overlay;
+ #print (join (" ", @cmd), "\n");
+ system (@cmd) == 0 or die "qemu-img: $!";
+ push @overlays, $overlay;
+ }
+
+=head1 TESTS
+
+=head2 inspect
+
+Open the guest and run libguestfs inspection on it.
+
+This tests libguestfs, C<qemu>, and the curl or ssh block driver.
+=cut
+ if ($all || "inspect" ~~ @tests) {
+ print "test: $guest: inspect\n";
+ my $g = Sys::Guestfs->new ();
+ foreach (@overlays) {
+ $g->add_drive ($_, format => "qcow2",
+ readonly => 1,
+ discard => "besteffort", copyonread => 1);
+ }
+ $g->launch ();
+ my @roots = $g->inspect_os ();
+ die "$progname: $guest: no operating system found in guest\n"
+ if @roots == 0;
+ }
+=head2 trim
+Open the guest and fstrim it.
+Note this only tests that the fstrim doesn't break dramatically (eg.
+cause qemu to crash), not that it is effective.
+This tests C<qemu>, and the curl or ssh block driver.
+=cut
+ if ($all || "trim" ~~ @tests) {
+ print "test: $guest: trim\n";
+ my $g = Sys::Guestfs->new ();
+ foreach (@overlays) {
+ $g->add_drive ($_, format => "qcow2",
+ readonly => 1,
+ discard => "besteffort", copyonread => 1);
+ }
+ $g->launch ();
+ my %fses = $g->list_filesystems ();
+ foreach (sort keys %fses) {
+ eval { $g->fstrim ($_); }
+ }
+ }
+=head2 copy
+Copy the whole disk image of the guest.
+This tests C<qemu-img>, and the curl or ssh block driver.
-
+=cut
+ if ($all || "copy" ~~ @tests) {
+ print "test: $guest: copy\n";
+
+ foreach (@overlays) {
+ my $tmp = File::Temp->new (UNLINK => 0);
+ my @cmd = ("qemu-img", "convert", "-p", $_, $tmp->filename);
+ system (@cmd) == 0 or die "qemu-img convert: $!";
+ unlink ($tmp);
+ }
+ }
+
+ # Delete the overlays.
+ unlink ($_) foreach @overlays;
+}
+
+# Helper function to extract the vCenter datacenter from a URI.
+sub get_datacenter
+{
+ my $uri = shift;
+ my $default_dc = "ha-datacenter";
+
+ if ($uri->scheme eq "vpx") {
+ my $path = $uri->path;
+ $path =~ s{/[^/]*$}{};
+ $path =~ s{^/}{};
+ if ($path ne "") {
+ return $path;
+ } else {
+ return $default_dc;
+ }
+ }
+ else {
+ return $default_dc;
+ }
+}
+
+# Get the session cookie from vCenter.
+sub get_session_cookie
+{
+ my $url = shift;
+ my $user = shift;
+
+ # Pass parameters to curl securely through a config file.
+ my $config_file = File::Temp->new (UNLINK => 1);
+ print $config_file "head\n";
+ print $config_file "silent\n";
+ print $config_file "url = \"$url\"\n";
+ if ($user) {
+ print $config_file "user = \"", $user, "\"\n";
+ }
+ print $config_file "insecure\n";
+ flush $config_file;
+ my $cmd = "curl -q --config " . $config_file->filename;
+ #system ("cat", $config_file->filename);
+ #print $cmd, "\n";
+ open PIPE, "$cmd |" or die "curl: $!";
+ my $cookie;
+ while (<PIPE>) {
+ if (m|^HTTP/401|) {
+ die "$progname: incorrect username or password\n";
+ }
+ if (m|^HTTP/404|) {
+ die "$progname: URL not found\n";
+ }
+ if (m|^Set-Cookie: (.*)|) {
+ my $rest;
+ ($cookie, $rest) = split /;/, $1, 2;
+ }
+ }
+ die "$progname: session cookie could not be read from remote vCenter\n"
+ unless defined $cookie;
+ return $cookie;
+}
+
+# Convert list to JSON string.
+sub json_to_string
+{
+ my $ret;
+ my $io = IO::String->new ($ret);
+
+ print $io "{\n";
+ my $needs_comma = 0;
+ my $kv;
+ foreach $kv (@_) {
+ if ($needs_comma) {
+ print $io ",\n";
+ }
+ $needs_comma = 1;
+
+ my $key = $kv->[0];
+ my $value = $kv->[1];
+
+ print $io "\"$key\": ";
+ if (looks_like_number ($value)) {
+ print $io $value;
+ } else {
+ $value =~ s{"}{\\"}g;
+ print $io "\"$value\"";
+ }
+ }
+ print $io "\n}\n";
+
+ return $ret
+}
=head1 SEE ALSO
L<virt-v2v(1)>,
-L<virt-v2v-test-harness(1)>
+L<virt-v2v-test-harness(1)>,
+L<qemu-img(1)>,
+L<Sys::Guestfs(3)>,
+L<Sys::Virt(3)>
=head1 AUTHOR
git.annexia.org / virt-v2v-test-transfers.git / commitdiff