File is a duplicate of 14f3792:lib/Sys/Virt/TCK.pm. Besides, it
is already exluded by MANIFEST.SKIP.
* lib/Sys/Virt/TCK.pm.orig: Delete.
* .gitignore: Sort. Add *.orig.
---
.gitignore | 25 +-
lib/Sys/Virt/TCK.pm.orig | 766 ----------------------------------------------
2 files changed, 13 insertions(+), 778 deletions(-)
delete mode 100644 lib/Sys/Virt/TCK.pm.orig
diff --git a/.gitignore b/.gitignore
index 2c7ac91..cc1470e 100644
--- a/.gitignore
+++ b/.gitignore
@@ -1,18 +1,19 @@
+#.*#
+*.bak
+*.orig
*~
-pm_to_blib
+Build
+MANIFEST
+META.yml
Makefile
+Makefile.PL
Makefile.old
-#.*#
-blib/
Sys-Virt-TCK-*
-MANIFEST
-*.bak
-results/
-data/
-META.yml
-cover_db/
_build/
-perl-Sys-Virt-TCK.spec
-Build
-Makefile.PL
+blib/
+cover_db/
+data/
libvirt-tck
+perl-Sys-Virt-TCK.spec
+pm_to_blib
+results/
diff --git a/lib/Sys/Virt/TCK.pm.orig b/lib/Sys/Virt/TCK.pm.orig
deleted file mode 100644
index 909ddd8..0000000
--- a/lib/Sys/Virt/TCK.pm.orig
+++ /dev/null
@@ -1,766 +0,0 @@
-
-package Sys::Virt::TCK;
-
-use strict;
-use warnings;
-
-use Sys::Virt;
-use Sys::Virt::TCK::DomainBuilder;
-use Sys::Virt::TCK::NetworkBuilder;
-use Sys::Virt::TCK::StoragePoolBuilder;
-use Sys::Virt::TCK::StorageVolBuilder;
-use Sys::Virt::TCK::Capabilities;
-
-use Config::Record;
-use File::Copy qw(copy);
-use File::Path qw(mkpath);
-use File::Spec::Functions qw(catfile catdir rootdir);
-use Cwd qw(cwd);
-use LWP::UserAgent;
-use IO::Uncompress::Gunzip qw(gunzip);
-use IO::Uncompress::Bunzip2 qw(bunzip2);
-use XML::XPath;
-use Carp qw(cluck carp);
-
-use Test::Builder;
-use Sub::Uplevel qw(uplevel);
-use base qw(Exporter);
-
-our @EXPORT = qw(ok_error ok_domain ok_pool ok_volume xpath err_not_implemented);
-
-our $VERSION = '0.1.0';
-
-sub new {
- my $proto = shift;
- my $class = ref($proto) || $proto;
- my $self = {};
- my %params = @_;
-
- $self->{config} = $params{config} ? $params{config} :
- Config::Record->new(file => ($ENV{LIBVIRT_TCK_CONFIG} || "/etc/tck.conf"));
-
- $self->{autoclean} = $params{autoclean} ? $params{autoclean} :
- ($ENV{LIBVIRT_TCK_AUTOCLEAN} || 0);
-
- if ($ENV{LIBVIRT_TCK_DEBUG}) {
- $SIG{__WARN__} = sub { Carp::cluck $_[0]; };
- $SIG{__DIE__} = sub { Carp::confess $_[0]; };
- }
-
- bless $self, $class;
-
- return $self;
-}
-
-
-sub setup {
- my $self = shift;
-
- my $uri = $self->config("uri", undef);
- $self->{conn} = Sys::Virt->new(address => $uri);
- my $type = $self->{conn}->get_type();
- $self->{type} = lc $type;
-
- $self->reset if $self->{autoclean};
-
- $self->sanity_check;
-
- return $self->{conn};
-}
-
-
-sub sanity_check {
- my $self = shift;
-
- my @doms = grep { $_->get_name =~ /^tck/ } $self->{conn}->list_domains;
- if (@doms) {
- die "there is/are " . int(@doms) . " pre-existing active domain(s) in this driver";
- }
-
- @doms = grep { $_->get_name =~ /^tck/ } $self->{conn}->list_defined_domains;
- if (@doms) {
- die "there is/are " . int(@doms) . " pre-existing inactive domain(s) in this driver";
- }
-
- my @pools = grep { $_->get_name =~ /^tck/ } $self->{conn}->list_storage_pools;
- if (@pools) {
- die "there is/are " . int(@pools) . " pre-existing active storage_pool(s) in this driver";
- }
-
- @pools = grep { $_->get_name =~ /^tck/ } $self->{conn}->list_defined_storage_pools;
- if (@pools) {
- die "there is/are " . int(@pools) . " pre-existing inactive storage_pool(s) in this driver";
- }
-}
-
-sub reset {
- my $self = shift;
-
- my @doms = grep { $_->get_name =~ /^tck/ } $self->{conn}->list_domains;
- foreach my $dom (@doms) {
- if ($dom->get_id != 0) {
- $dom->destroy;
- }
- }
-
- @doms = grep { $_->get_name =~ /^tck/ } $self->{conn}->list_defined_domains();
- foreach my $dom (@doms) {
- $dom->undefine;
- }
-
- my @pools = grep { $_->get_name =~ /^tck/ } $self->{conn}->list_storage_pools;
- foreach my $pool (@pools) {
- my @vols = $pool->list_volumes;
- foreach my $vol (@vols) {
- eval { $vol->delete(0) };
- }
- $pool->destroy;
- }
-
- @pools = grep { $_->get_name =~ /^tck/ } $self->{conn}->list_defined_storage_pools();
- foreach my $pool (@pools) {
- eval {
- $pool->delete(0);
- };
- $pool->undefine;
- }
-}
-
-sub cleanup {
- my $self = shift;
-
- $self->reset();
-
- delete $self->{conn};
-}
-
-sub config {
- my $self = shift;
- my $key = shift;
- if (@_) {
- my $default = shift;
- return $self->{config}->get($key, $default);
- } else {
- return $self->{config}->get($key);
- }
-}
-
-
-sub conn {
- my $self = shift;
- return $self->{conn};
-}
-
-
-sub scratch_dir {
- my $self = shift;
-
- my $scratch = $self->config("scratch_dir", $< > 0 ?
- catdir(cwd(), "libvirt-tck") :
- catdir(rootdir(), "var", "cache", "libvirt-tck"));
-
- mkpath($scratch) unless -e $scratch;
-
- return $scratch;
-}
-
-sub bucket_dir {
- my $self = shift;
- my $name = shift;
-
- my $scratch = $self->scratch_dir;
-
- my $bucket = catdir($scratch, $name);
- mkpath($bucket) unless -e $bucket;
-
- return $bucket;
-}
-
-sub get_scratch_resource {
- my $self = shift;
- my $source = shift;
- my $bucket = shift;
- my $name = shift;
-
- my $dir = $self->bucket_dir($bucket);
- my $target = catfile($dir, $name);
-
- return $target if -e $target;
-
- my $uncompress = undef;
- if (ref($source)) {
- $uncompress = $source->{uncompress};
- $source = $source->{source};
- }
-
- if ($source =~ m,^/,) {
- $self->copy_scratch($source, $target, $uncompress);
- } else {
- $self->download_scratch($source, $target, $uncompress);
- }
-
- return $target;
-}
-
-
-sub download_scratch {
- my $self = shift;
- my $source = shift;
- my $target = shift;
- my $uncompress = shift;
-
- my $ua = LWP::UserAgent->new;
- $ua->timeout(10);
- $ua->env_proxy;
-
- my $response = $ua->get($source);
-
- if ($response->is_success) {
- open TGT, ">$target" or die "cannot create $target: $!";
- if (defined $uncompress) {
- my $data = $response->content;
- if ($uncompress eq "gzip") {
- gunzip \$data => \*TGT;
- } elsif ($uncompress eq "bzip2") {
- bunzip2 \$data => \*TGT;
- } else {
- die "unknown compression method '$uncompress'";
- }
- } else {
- print TGT $response->content or die "cannot write $target: $!";
- }
- close TGT or die "cannot save $target: $!";
- } else {
- die "cannot download $source: " . $response->status_line;
- }
-
-}
-
-sub copy_scratch {
- my $self = shift;
- my $source = shift;
- my $target = shift;
- my $uncompress = shift;
-
- if (defined $uncompress) {
- if ($uncompress eq "gzip") {
- gunzip $source => $target;
- } elsif ($uncompress eq "bzip2") {
- bunzip2 $source => $target;
- } else {
- die "unknown compression method '$uncompress'";
- }
- } else {
- copy ($source, $target) or die "cannot copy $source to $target: $!";
- }
-}
-
-
-sub create_sparse_disk {
- my $self = shift;
- my $bucket = shift;
- my $name = shift;
- my $size = shift;
-
- my $dir = $self->bucket_dir($bucket);
-
- my $target = catfile($dir, $name);
-
- open DISK, ">$target" or die "cannot create $target: $!";
-
- truncate DISK, ($size * 1024 * 1024);
-
- close DISK or die "cannot save $target: $!";
-
- return $target;
-}
-
-
-sub create_minimal_vroot {
- my $self = shift;
- my $bucket = shift;
- my $name = shift;
-
- my $dir = $self->bucket_dir($bucket);
- my $target = catdir($dir, $name);
-
- mkpath($target) unless -e $target;
-
- my $busybox = $self->config("busybox", "/sbin/busybox");
-
- die "$busybox does not exist" unless $busybox;
-
- my $type = `file $busybox 2>&1`;
-
- die "$busybox is not statically linked" unless $type =~ /statically/;
-
- my @dirs = qw(sbin bin dev proc sys tmp);
-
- foreach my $dir (@dirs) {
- my $fulldir = catdir($target, $dir);
- next if -e $fulldir;
- mkpath($fulldir);
- }
-
- my $dst = catfile($target, "sbin", "busybox");
- copy ($busybox, $dst) or die "cannot copy $busybox to $dst: $!";
- chmod 0755, $dst or die "cannot make $dst executable: $!";
-
- my @links = qw(
- ed kill ping6 svlogd
- egrep killall pipe_progress swapoff
-addgroup eject killall5 pivot_root swapon
-adduser env klogd pkill switch_root
-adjtimex envdir last poweroff sync
-ar envuidgid length printenv sysctl
-arp expand less printf syslogd
-arping expr linux32 ps tail
-ash fakeidentd linux64 pscan tar
-awk false linuxrc pwd tcpsvd
-basename fbset ln raidautorun tee
-bunzip2 fdformat loadfont rdate telnet
-busybox fdisk loadkmap readahead telnetd
-bzcat fgrep logger readlink test
-bzip2 find login readprofile tftp
-cal fold logname realpath time
-cat free logread reboot top
-catv freeramdisk losetup renice touch
-chattr fsck ls reset tr
-chgrp fsck.minix lsattr resize traceroute
-chmod ftpget lsmod rm true
-chown ftpput lzmacat rmdir tty
-chpasswd fuser makedevs rmmod ttysize
-chpst getopt md5sum route udhcpc
-chroot getty mdev rpm udhcpd
-chrt grep mesg rpm2cpio udpsvd
-chvt gunzip microcom runlevel umount
-cksum gzip mkdir run-parts uname
-clear halt mkfifo runsv uncompress
-cmp hdparm mkfs.minix runsvdir unexpand
-comm head mknod rx uniq
-cp hexdump mkswap sed unix2dos
-cpio hostid mktemp seq unlzma
-crond hostname modprobe setarch unzip
-crontab httpd more setconsole uptime
-cryptpw hwclock mount setkeycodes usleep
-cut id mountpoint setlogcons uudecode
-date ifconfig msh setsid uuencode
-dc ifdown mt setuidgid vconfig
-dd ifup mv sh vi
-deallocvt inetd nameif sha1sum vlock
-delgroup init nc slattach watch
-deluser insmod netstat sleep watchdog
-df install nice softlimit wc
-dhcprelay ip nmeter sort wget
-diff ipaddr nohup split which
-dirname ipcalc nslookup start-stop-daemon who
-dmesg ipcrm od stat whoami
-dnsd ipcs openvt strings xargs
-dos2unix iplink passwd stty yes
-du iproute patch su zcat
-dumpkmap iprule pgrep sulogin zcip
-dumpleases iptunnel pidof sum
-echo kbd_mode ping sv);
-
- foreach my $file (@links) {
- my $fullfile = catfile($target, "bin", $file);
- next if -e $fullfile;
- symlink "../sbin/busybox", $fullfile
- or die "cannot symlink $fullfile to ../sbin/busybox: $!";
- }
-
- my $init = catfile($target, "sbin", "init");
- open INIT, ">$init" or die "cannot create $init: $!";
-
- print INIT <<EOF;
-#!/sbin/busybox
-
-sh
-EOF
-
- close INIT or die "cannot save $init: $!";
- chmod 0755, $init or die "cannot make $init executable: $!";
-
- return ($target, catfile(rootdir, "sbin", "init"));
-}
-
-sub match_kernel {
- my $self = shift;
- my $caps = shift;
- my $arch = shift;
- my $ostype = shift;
-
- for (my $i = 0 ; $i < $caps->num_guests ; $i++) {
- if ($caps->guest_os_type($i) eq $ostype &&
- $caps->guest_arch_name($i) eq $arch) {
-
- my @domains = $caps->guest_domain_types($i);
- next unless int(@domains);
-
- return ($domains[0],
- $caps->guest_domain_emulator($i, $domains[0]),
- $caps->guest_domain_loader($i, $domains[0]));
- }
- }
-
- return ();
-}
-
-
-sub best_kernel {
- my $self = shift;
- my $caps = shift;
-
- my $kernels = $self->config("kernels", []);
-
- for (my $i = 0 ; $i <= $#{$kernels} ; $i++) {
- my $arch = $kernels->[$i]->{arch};
- my $ostype = $kernels->[$i]->{ostype};
- my @ostype = ref($ostype) ? @{$ostype} : ($ostype);
-
- foreach $ostype (@ostype) {
- my ($domain, $emulator, $loader) =
- $self->match_kernel($caps, $arch, $ostype);
-
- if (defined $domain) {
- return ($i, $domain, $arch, $ostype, $emulator, $loader)
- }
- }
- }
-
- return ();
-}
-
-sub get_kernel {
- my $self = shift;
- my $caps = shift;
-
- my ($cfgindex, $domain, $arch, $ostype, $emulator, $loader) =
- $self->best_kernel($caps);
-
- if (!defined $cfgindex) {
- die "cannot find any supported kernel configuration";
- }
-
- my $kernels = $self->config("kernels", []);
-
- my $kernel = $kernels->[$cfgindex]->{kernel};
- my $initrd = $kernels->[$cfgindex]->{initrd};
- my $disk = $kernels->[$cfgindex]->{disk};
-
- my $bucket = "os-$arch-$ostype";
-
- my $kfile = $self->get_scratch_resource($kernel, $bucket, "vmlinuz");
- my $ifile = $initrd ? $self->get_scratch_resource($initrd, $bucket, "initrd") : undef;
- my $dfile = $disk ? $self->get_scratch_resource($disk, $bucket, "disk.img") : undef;
-
- unless (defined $dfile) {
- $dfile = $self->create_sparse_disk($bucket, "disk.img", 100);
- }
-
- chmod 0755, $kfile;
-
- my $dev;
- if ($ostype eq "xen") {
- $dev = "xvda";
- } elsif ($ostype eq "uml") {
- $dev = "ubda";
- } elsif ($ostype eq "hvm") {
- if ($domain eq "kvm" ||
- $domain eq "qemu" ||
- $domain eq "kqemu") {
- $dev = "vda";
- } else {
- $dev = "hda";
- }
- }
-
- return (
- domain => $domain,
- arch => $arch,
- ostype => $ostype,
- emulator => $emulator,
- loader => $loader,
- kernel => $kfile,
- initrd => $ifile,
- root => $dfile,
- dev => $dev,
- );
-}
-
-
-
-sub generic_machine_domain {
- my $self = shift;
- my $name = shift;
- my $caps = shift;
-
- my %config = $self->get_kernel($caps);
-
- my $b = Sys::Virt::TCK::DomainBuilder->new(conn => $self->{conn},
- name => $name,
- domain => $config{domain},
- ostype => $config{ostype});
- $b->memory(64 * 1024);
- $b->with_acpi();
- $b->with_apic();
-
- # XXX boot CDROM or vroot for other HVs
- $b->boot_kernel($config{kernel}, $config{initrd});
-
- $b->disk(src => $config{root},
- dst => $config{dev},
- type => "file");
-
- return $b;
-}
-
-
-sub best_container_domain {
- my $self = shift;
- my $caps = shift;
-
- for (my $i = 0 ; $i < $caps->num_guests ; $i++) {
- if ($caps->guest_os_type($i) eq "exe") {
- my @domains = $caps->guest_domain_types($i);
- next unless int(@domains);
-
- return $domains[0];
- }
- }
-
- return undef;
-
-}
-
-sub generic_container_domain {
- my $self = shift;
- my $name = shift;
- my $caps = shift;
- my $domain = shift;
-
- my $bucket = "os-exe";
-
- my $b = Sys::Virt::TCK::DomainBuilder->new(conn => $self->{conn},
- name => $name,
- domain => $domain,
- ostype => "exe");
- $b->memory(64 * 1024);
-
- my ($root, $init) = $self->create_minimal_vroot($bucket, $name);
-
- $b->boot_init($init);
-
- $b->filesystem(src => $root,
- dst => "/",
- type => "mount");
-
- return $b;
-}
-
-
-sub generic_domain {
- my $self = shift;
- my $name = @_ ? shift : "tck";
-
- my $caps = Sys::Virt::TCK::Capabilities->new(xml => $self->conn->get_capabilities);
-
- my $container = $self->best_container_domain($caps);
-
- if ($container) {
- return $self->generic_container_domain($name, $caps, $container);
- } else {
- return $self->generic_machine_domain($name, $caps);
- }
-}
-
-sub generic_pool {
- my $self = shift;
- my $type = shift;
- my $name = @_ ? shift : "tck";
-
- my $bucket = $self->bucket_dir("storage-fs");
-
- my $b = Sys::Virt::TCK::StoragePoolBuilder->new(name => $name,
- type => $type);
-
- $b->target(catdir($bucket, $name));
-
- return $b;
-}
-
-
-sub generic_volume {
- my $self = shift;
- my $name = @_ ? shift : "tck";
- my $format = @_ ? shift :undef;
- my $capacity = @_ ? shift : 1024*1024*50;
-
- my $b = Sys::Virt::TCK::StorageVolBuilder->new(name => $name);
- $b->format($format) if $format;
- $b->capacity($capacity);
-
- return $b;
-}
-
-# Borrowed from Test::Exception
-
-sub _quiet_caller (;$) { ## no critic Prototypes
- my $height = $_[0];
- $height++;
- if( wantarray and !@_ ) {
- return (CORE::caller($height))[0..2];
- }
- else {
- return CORE::caller($height);
- }
- }
-
-sub _try_as_caller {
- my $coderef = shift;
-
- # local works here because Sub::Uplevel has already overridden caller
- local *CORE::GLOBAL::caller;
- { no warnings 'redefine'; *CORE::GLOBAL::caller = \&_quiet_caller; }
-
- my $ret = eval { uplevel 3, $coderef };
- return ($ret, $@);
-};
-
-
-my $Tester = Test::Builder->new;
-
-sub ok_domain(&$;$) {
- my $coderef = shift;
- my $description = shift;
- my $name = shift;
-
- die "must pass coderef, description and (optional) expected name"
- unless defined $description;
-
- my ($ret, $exception) = _try_as_caller($coderef);
-
- my $ok = "$exception" eq "" &&
- $ret && ref($ret) && $ret->isa("Sys::Virt::Domain") &&
- (!defined $name || ($ret->get_name() eq $name));
-
- $Tester->ok($ok, $description);
- unless ($ok) {
- $Tester->diag("expected Sys::Virt::Domain object" . ($name ? " with name $name" : ""));
- if ($exception) {
- $Tester->diag("found '$exception'");
- } else {
- if ($ret && ref($ret) && $ret->isa("Sys::Virt::Domain")) {
- $Tester->diag("found Sys::Virt::Domain object with name " . $ret->get_name);
- } else {
- $Tester->diag("found '$ret'");
- }
- }
- }
-}
-
-sub ok_pool(&$;$) {
- my $coderef = shift;
- my $description = shift;
- my $name = shift;
-
- die "must pass coderef, description and (optional) expected name"
- unless defined $description;
-
- my ($ret, $exception) = _try_as_caller($coderef);
-
- my $ok = "$exception" eq "" &&
- $ret && ref($ret) && $ret->isa("Sys::Virt::StoragePool") &&
- (!defined $name || ($ret->get_name() eq $name));
-
- $Tester->ok($ok, $description);
- unless ($ok) {
- $Tester->diag("expected Sys::Virt::StoragePool object" . ($name ? " with name $name" : ""));
- if ($exception) {
- $Tester->diag("found '$exception'");
- } else {
- if ($ret && ref($ret) && $ret->isa("Sys::Virt::StoragePool")) {
- $Tester->diag("found Sys::Virt::StoragePool object with name " . $ret->get_name);
- } else {
- $Tester->diag("found '$ret'");
- }
- }
- }
-}
-
-sub ok_volume(&$;$) {
- my $coderef = shift;
- my $description = shift;
- my $name = shift;
-
- die "must pass coderef, description and (optional) expected name"
- unless defined $description;
-
- my ($ret, $exception) = _try_as_caller($coderef);
-
- my $ok = "$exception" eq "" &&
- $ret && ref($ret) && $ret->isa("Sys::Virt::StorageVol") &&
- (!defined $name || ($ret->get_name() eq $name));
-
- $Tester->ok($ok, $description);
- unless ($ok) {
- $Tester->diag("expected Sys::Virt::StorageVol object" . ($name ? " with name $name" : ""));
- if ($exception) {
- $Tester->diag("found '$exception'");
- } else {
- if ($ret && ref($ret) && $ret->isa("Sys::Virt::StorageVol")) {
- $Tester->diag("found Sys::Virt::StorageVol object with name " . $ret->get_name);
- } else {
- $Tester->diag("found '$ret'");
- }
- }
- }
-}
-
-sub ok_error(&$;$) {
- my $coderef = shift;
- my $description = shift;
- my $code = shift;
-
- die "must pass coderef, description and (optional) expected error code"
- unless defined $description;
-
- my ($ret, $exception) = _try_as_caller($coderef);
-
- my $ok = ref($exception) && $exception->isa("Sys::Virt::Error") &&
- (!defined $code || ($exception->code() == $code));
-
- $Tester->ok($ok, $description);
- unless ($ok) {
- $Tester->diag("expecting Sys::Virt::Error object" . ($code ? " with code $code" : ""));
- $Tester->diag("found '$exception'");
- }
- $@ = $exception;
- return $ok;
-}
-
-
-sub err_not_implemented {
- my $exception = shift;
-
- if ($exception &&
- ref($exception) &&
- $exception->isa("Sys::Virt::Error") &&
- $exception->code() == 3) {
- return 1;
- }
- return 0;
-}
-
-sub xpath {
- my $object = shift;
- my $path = shift;
-
- my $xml = $object->get_xml_description;
-
- my $xp = XML::XPath->new(xml => $xml);
-
- return $xp->find($path);
-}
-
-1;
--
1.6.6.1
