KVM.pm

package Ravada::VM::KVM;

use warnings;
use strict;

=head1 NAME

Ravada::VM::KVM - KVM Virtual Managers library for Ravada

=cut

use Carp qw(croak carp cluck);
use Data::Dumper;
use Digest::MD5;
use Encode;
use Encode::Locale;
use File::Path qw(make_path);
use Fcntl qw(:flock O_WRONLY O_EXCL O_CREAT);
use Hash::Util qw(lock_hash);
use IPC::Run3 qw(run3);
use IO::Interface::Simple;
use JSON::XS;
use Mojo::DOM;
use Mojo::UserAgent;
use Moose;
use Sys::Virt;
use URI;
use XML::LibXML;

use feature qw(signatures);
no warnings "experimental::signatures";

use Ravada::Domain::KVM;
use Ravada::NetInterface::KVM;
use Ravada::NetInterface::MacVTap;
use Ravada::Utils;

with 'Ravada::VM';

##########################################################################
#

has vm => (
#    isa => 'Sys::Virt'
    is => 'rw'
    ,builder => '_connect'
    ,lazy => 1
);

has type => (
    isa => 'Str'
    ,is => 'ro'
    ,default => 'KVM'
);

#########################################################################3
#

#TODO use config file for DIR_XML
our $DIR_XML = "etc/xml";
$DIR_XML = "/var/lib/ravada/xml/" if $0 =~ m{^/usr/sbin};

our $FILE_CONFIG_QEMU = "/etc/libvirt/qemu.conf";

our $XML = XML::LibXML->new();

#-----------
#
# global download vars
#
our ($DOWNLOAD_FH, $DOWNLOAD_TOTAL);

our $CONNECTOR = \$Ravada::CONNECTOR;

our $WGET = `which wget`;
chomp $WGET;

our $BRCTL = `which brctl`;
chomp $BRCTL;

our $CACHE_DOWNLOAD = 1;
our $VERIFY_ISO = 1;

our %_CREATED_DEFAULT_STORAGE = ();
##########################################################################


sub _connect {
    my $self = shift;

    my $vm;
    confess "undefined host" if !defined $self->host;

    my $con_type = $self->type;
    $con_type = 'qemu' if $self->type eq 'KVM';

    if ($self->host eq 'localhost') {
        $vm = Sys::Virt->new( address => $con_type.":///system" , readonly => $self->readonly);
    } else {
        confess "Error: You can't connect to remote VMs in readonly mode"
            if $self->readonly;
        my $transport = 'ssh';
        my $address = $con_type."+".$transport
                                            ."://".'root@'.$self->host
                                            ."/system";
        eval {
            $vm = Sys::Virt->new(
                                address => $address
                              ,auth => 1
                              ,credlist => [
                                  Sys::Virt::CRED_AUTHNAME,
                                  Sys::Virt::CRED_PASSPHRASE,
                              ]
                          );
         };
         confess $@ if $@;
    }
    if ( ! $vm->list_storage_pools && !$_CREATED_DEFAULT_STORAGE{$self->host}) {
	    warn "WARNING: No storage pools creating default\n";
    	$self->_create_default_pool($vm);
        $_CREATED_DEFAULT_STORAGE{$self->host}++;
    }
    $self->_check_networks($vm);
    return $vm;
}

sub _check_networks {
    my $self = shift;
    my $vm = shift;

    for my $net ($vm->list_all_networks) {
        next if $net->is_active;

        warn "INFO: Activating KVM network ".$net->get_name."\n";
        $net->create;
        $net->set_autostart(1);
    }
}

=head2 disconnect

Disconnect from the Virtual Machine Manager

=cut

sub disconnect {
    my $self = shift;

    $self->vm(undef);
}

=head2 connect

Connect to the Virtual Machine Manager

=cut

sub connect {
    my $self = shift;
    return 1 if $self->vm;
    return 1 if $self->is_alive;

    return $self->vm($self->_connect);
#    $self->storage_pool($self->_load_storage_pool);
}

sub _reconnect($self) {
    $self->vm(undef);
    return $self->connect();
}

sub _load_storage_pool {
    my $self = shift;

    confess "no hi ha vm" if !$self->vm;

    my $vm_pool;
    my $available;

    if ($self->default_storage_pool_name) {
        return( $self->vm->get_storage_pool_by_name($self->default_storage_pool_name)
            or confess "ERROR: Unknown storage pool: ".$self->default_storage_pool_name);
    }

    for my $pool ($self->vm->list_storage_pools) {
        my $info = $pool->get_info();
        next if defined $available
                && $info->{available} <= $available;

        my $doc = $XML->load_xml(string => $pool->get_xml_description);

        my ($path) =$doc->findnodes('/pool/target/path/text()');
        next if !$path;

        $vm_pool = $pool;
        $available = $info->{available};

    }
    confess "I can't find /pool/target/path in the storage pools xml\n"
        if !$vm_pool;

    return $vm_pool;

}

=head2 storage_pool

Returns a storage pool usable by the domain to store new volumes.

=cut

sub storage_pool {
    my $self = shift;

    return $self->_load_storage_pool();
}

=head2 search_volume

Searches for a volume in all the storage pools known to the Virtual Manager

Argument: the filenaname;
Returns the volume as a Sys::Virt::StorageGol. If called in array context returns a
list of all the volumes.

    my $iso = $vm->search_volume("debian-8.iso");

    my @disk = $vm->search_volume("windows10-clone.img");

=cut

sub search_volume($self,$file,$refresh=0) {
    confess "ERROR: undefined file" if !defined $file;

    my ($name) = $file =~ m{.*/(.*)};
    $name = $file if !defined $name;

    my $vol;
    for my $pool ($self->vm->list_storage_pools) {
        if ($refresh) {
            $pool->refresh();
            sleep 1;
        }
        eval { $vol = $pool->get_volume_by_name($name) };
        die $@ if $@ && $@ !~ /^libvirt error code: 50,/;
    }

    return $self->search_volume_re(qr(^$name$),$refresh);
}

=head2 search_volume_path

Searches for a volume in all the storage pools known to the Virtual Manager

Argument: the filenaname;
Returns the path of the volume. If called in array context returns a
list of all the paths to all the matching volumes.

    my $iso = $vm->search_volume("debian-8.iso");

    my @disk = $vm->search_volume("windows10-clone.img");



=cut

sub search_volume_path {
    my $self = shift;
    my @volume = $self->search_volume(@_);

    my @vol2 = map { $_->get_path() if ref($_) } @volume;

    return $vol2[0] if !wantarray;
    return @vol2;
}

=head2 search_volume_re

Searches for a volume in all the storage pools known to the Virtual Manager

Argument: a regular expression;
Returns the volume. If called in array context returns a
list of all the matching volumes.

    my $iso = $vm->search_volume(qr(debian-\d+\.iso));

    my @disk = $vm->search_volume(qr(windows10-clone.*\.img));

=cut

sub search_volume_re($self,$pattern,$refresh=0) {

    confess "'$pattern' doesn't look like a regexp to me ".ref($pattern)
        if !ref($pattern) || ref($pattern) ne 'Regexp';

    $self->_connect();
    $self->_refresh_storage_pools()    if $refresh;

    my @volume;
    for my $pool ($self->vm->list_storage_pools) {
        for my $vol ( $pool->list_all_volumes()) {
            my ($file) = $vol->get_path =~ m{.*/(.*)};
            next if $file !~ $pattern;

            return $vol if !wantarray;
            push @volume,($vol);
        }
    }
    if (!scalar @volume && !$refresh && !$self->readonly
            && time - ($self->{_time_refreshed} or 0) > 60) {
        $self->{_time_refreshed} = time;
        @volume = $self->search_volume_re($pattern,"refresh");
        return $volume[0] if !wantarray && scalar @volume;
    }
    return if !wantarray && !scalar@volume;
    return @volume;
}

sub refresh_storage_pools($self) {
    $self->_refresh_storage_pools();
}

sub _refresh_storage_pools($self) {
    for my $pool ($self->vm->list_storage_pools) {
        for ( 1 .. 10 ) {
            eval { $pool->refresh() };
            last if !$@;
            warn $@ if $@ !~ /pool .* has asynchronous jobs running/;
            sleep 1;
        }
    }
}

=head2 refresh_storage

Refreshes all the storage pools

=cut

sub refresh_storage($self) {
    $self->_refresh_storage_pools();
    $self->_refresh_isos();
}

sub _refresh_isos($self) {
    $self->_init_connector();
    my $sth = $$CONNECTOR->dbh->prepare(
        "SELECT * FROM iso_images ORDER BY name"
    );
    my $sth_update = $$CONNECTOR->dbh->prepare("UPDATE iso_images set device=? WHERE id=?");

    $sth->execute;
    while (my $row = $sth->fetchrow_hashref) {

        if ( $row->{device} && !-e $row->{device} ) {
            delete $row->{device};
            $sth_update->execute($row->{device}, $row->{id});
            next;
        }
        next if $row->{device};

        my ($file);
        ($file) = $row->{url} =~ m{.*/(.*)}   if $row->{url};
        $file = $row->{rename_file} if $row->{rename_file};
        my $file_re = $row->{file_re};

        next if $row->{device};
        if ($file) {
            my $iso_file = $self->search_volume_path($file);
            if ($iso_file) {
                $row->{device} = $iso_file;
            }
        }
        if (!$row->{device} && $file_re) {
            my $iso_file = $self->search_volume_path_re(qr($file_re));
            if ($iso_file) {
                $row->{device} = $iso_file;
            }
        }
        $sth_update->execute($row->{device}, $row->{id}) if $row->{device};
    }
    $sth->finish;
}

=head2 search_volume_path_re

Searches for a volume in all the storage pools known to the Virtual Manager

Argument: a regular expression;
Returns the volume path. If called in array context returns a
list of all the paths of all the matching volumes.

    my $iso = $vm->search_volume(qr(debian-\d+\.iso));

    my @disk = $vm->search_volume(qr(windows10-clone.*\.img));

=cut


sub search_volume_path_re($self, $pattern) {
    my @vol = $self->search_volume_re($pattern);

    return if !wantarray && !scalar @vol;
    return $vol[0]->get_path if !wantarray;

    return map { $_->get_path() if ref($_) } @vol;

}

=head2 dir_img

Returns the directory where disk images are stored in this Virtual Manager

=cut

sub dir_img {
    my $self = shift;

    my $pool = $self->_load_storage_pool();
    $pool = $self->_create_default_pool() if !$pool;
    my $xml = XML::LibXML->load_xml(string => $pool->get_xml_description());

    my $dir = $xml->findnodes('/pool/target/path/text()');
    die "I can't find /pool/target/path in ".$xml->toString
        if !$dir;

    return $dir;
}

=head2 dir_base

Returns the directory where base images are stored in this Virtual Manager

=cut


sub dir_base($self, $volume_size) {
    my $pool_base = $self->default_storage_pool_name;
    $pool_base = $self->base_storage_pool()    if $self->base_storage_pool();
    $pool_base = $self->storage_pool()         if !$pool_base;

    $self->_check_free_disk($volume_size * 2, $pool_base);
    return $self->_storage_path($pool_base);

}

=head2 dir_clone

Returns the directory where clone images are stored in this Virtual Manager

=cut


sub dir_clone($self) {

    my $dir_img  = $self->dir_img;
    my $clone_pool = $self->clone_storage_pool();
    $dir_img = $self->_storage_path($clone_pool) if $clone_pool;

    return $dir_img;
}

sub _storage_path($self, $storage) {
    if (!ref($storage)) {
        $storage = $self->vm->get_storage_pool_by_name($storage);
    }
    my $xml = XML::LibXML->load_xml(string => $storage->get_xml_description());

    my $dir = $xml->findnodes('/pool/target/path/text()');
    die "I can't find /pool/target/path in ".$xml->toString
        if !$dir;

    return $dir;

}

sub _create_default_pool {
    my $self = shift;
    my $vm = shift;
    $vm = $self->vm if !$vm;

    my $uuid = Ravada::VM::KVM::_new_uuid('68663afc-aaf4-4f1f-9fff-93684c260942');

    my $dir = "/var/lib/libvirt/images";
    mkdir $dir if ! -e $dir;

    my $xml =
"<pool type='dir'>
  <name>default</name>
  <uuid>$uuid</uuid>
  <capacity unit='bytes'></capacity>
  <allocation unit='bytes'></allocation>
  <available unit='bytes'></available>
  <source>
  </source>
  <target>
    <path>$dir</path>
    <permissions>
      <mode>0711</mode>
      <owner>0</owner>
      <group>0</group>
    </permissions>
  </target>
</pool>"
;
    my $pool;
    eval {
        $pool = $vm->define_storage_pool($xml);
        $pool->create();
        $pool->set_autostart(1);
    };
    warn $@ if $@;

}

=head2 create_domain

Creates a domain.

    $dom = $vm->create_domain(name => $name , id_iso => $id_iso);
    $dom = $vm->create_domain(name => $name , id_base => $id_base);

Creates a domain and removes the CPU defined in the XML template:

    $dom = $vm->create_domain(        name => $name 
                                  , id_iso => $id_iso
                              , remove_cpu => 1);

=cut

sub create_domain {
    my $self = shift;
    my %args = @_;
    $args{active} = 1 if !defined $args{active};

    croak "argument name required"       if !$args{name};
    croak "argument id_owner required"   if !$args{id_owner};
    croak "argument id_iso or id_base required ".Dumper(\%args)
        if !$args{id_iso} && !$args{id_base};

    my $domain;
    if ($args{id_iso}) {
        $domain = $self->_domain_create_from_iso(@_);
    } elsif($args{id_base}) {
        $domain = $self->_domain_create_from_base(@_);
    } else {
        confess "TODO";
    }

    return $domain;
}

=head2 search_domain

Returns true or false if domain exists.

    $domain = $vm->search_domain($domain_name);

=cut

sub search_domain($self, $name, $force=undef) {

    eval {
        $self->connect();
    };
    if ($@ && $@ =~ /libvirt error code: 38,/) {
        warn $@;
        if (!$self->is_local) {
            warn "DISABLING NODE ".$self->name;
            $self->enabled(0);
        }
        return;
    }

    my $dom;
    eval { $dom = $self->vm->get_domain_by_name($name); };
    my $error = $@;
    return if $error =~  /error code: 42,/ && !$force;

    if ($error && $error =~ /libvirt error code: 38,/ ) {
        eval {
            $self->disconnect;
            $self->connect;
        };
        confess "Error connecting to ".$self->name." $@" if $@;
        eval { $dom = $self->vm->get_domain_by_name($name); };
        confess $@ if $@ && $@ !~  /error code: 42,/;
    } elsif ($error && $error !~ /error code: 42,/) {
        confess $error;
    }

    if (!$dom) {
        return if !$force;
        return if !$self->_domain_in_db($name);
    }

    my $domain;

        my @domain = ( );
        push @domain, ( domain => $dom ) if $dom;
        push @domain, ( id_owner => $Ravada::USER_DAEMON->id)
            if $force && !$self->_domain_in_db($name);
        eval {
            $domain = Ravada::Domain::KVM->new(
                @domain
                ,name => $name
                ,readonly => $self->readonly
                ,_vm => $self
            );
        };
        warn $@ if $@;
        if ($domain) {
            $domain->xml_description()  if $dom && $domain->is_known();
            return $domain;
        }

    return;
}

=head2 list_domains

Returns a list of the created domains

  my @list = $vm->list_domains();

=cut

sub list_domains {
    my $self = shift;
    my %args = @_;

    return if !$self->vm;

    my $active = (delete $args{active} or 0);
    my $read_only = delete $args{read_only};

    confess "Arguments unknown ".Dumper(\%args)  if keys %args;

    my $query = "SELECT id, name FROM domains WHERE id_vm = ? ";
    $query .= " AND status = 'active' " if $active;

    my $sth = $$CONNECTOR->dbh->prepare($query);

    $sth->execute( $self->id );
    my @list;
    while ( my ($id) = $sth->fetchrow) {
        my $domain;
        if ($read_only) {
            $domain = Ravada::Front::Domain->open( $id );
        } else {
            $domain = Ravada::Domain->open( id => $id, vm => $self);
        }
        push @list,($domain) if $domain;
    }
    return @list;
}

=head2 create_volume

Creates a new storage volume. It requires a name and a xml template file defining the volume

   my $vol = $vm->create_volume(name => $name, name => $file_xml);

=cut

sub create_volume {
    my $self = shift;

    confess "Wrong arrs " if scalar @_ % 2;
    my %args = @_;

    my $name = delete $args{name}       or confess "ERROR: Missing volume name";
    my $file_xml = delete $args{xml}   or confess "ERROR: Missing XML template";

    my $size        = delete $args{size};
    my $swap        =(delete $args{swap} or 0);
    my $target      = delete $args{target};
    my $capacity    = delete $args{capacity};
    my $allocation  = delete $args{allocation};

    confess "ERROR: Unknown args ".Dumper(\%args)   if keys %args;

    confess "Invalid size"          if defined $size && ( $size == 0 || $size !~ /^\d+$/);

    confess "Invalid capacity"
        if defined $capacity && ( $capacity == 0 || $capacity !~ /^\d+$/);

    confess "Capacity and size are the same, give only one of them"
        if defined $capacity && defined $size;

    $capacity = $size if defined $size;
    $allocation = int($capacity * 0.1)+1
        if !defined $allocation && $capacity;

    open my $fh,'<', $file_xml or confess "$! $file_xml";

    my $doc;
    eval { $doc = $XML->load_xml(IO => $fh) };
    die "ERROR reading $file_xml $@"    if $@;

    my $storage_pool = $self->storage_pool();

    confess $name if $name =~ /-\w{4}-vd[a-z]-\w{4}\./
        || $name =~ /\d-vd[a-z]\./;

    my $img_file = $self->_volume_path(
        target => $target
        , swap => $swap
        , name => $name
        , storage => $storage_pool
    );

    confess if $img_file =~ /\d-vd[a-z]\./;
    my ($volume_name) = $img_file =~m{.*/(.*)};
    $doc->findnodes('/volume/name/text()')->[0]->setData($volume_name);
    $doc->findnodes('/volume/key/text()')->[0]->setData($img_file);
    $doc->findnodes('/volume/target/path/text()')->[0]->setData(
                        $img_file);

    if ($capacity) {
        confess "Size '$capacity' too small" if $capacity< 1024*10;
        $doc->findnodes('/volume/allocation/text()')->[0]->setData(int($allocation));
        $doc->findnodes('/volume/capacity/text()')->[0]->setData($capacity);
    }
    my $vol = $self->storage_pool->create_volume($doc->toString)
        or die "volume $img_file does not exists after creating volume on ".$self->name." "
            .$doc->toString();

    return $img_file;

}

sub _volume_path {
    my $self = shift;

    my %args = @_;
    my $swap     =(delete $args{swap} or 0);
    my $storage  = delete $args{storage} or confess "ERROR: Missing storage";
    my $filename = $args{name}  or confess "ERROR: Missing name";
    my $target = delete $args{target};

    my $dir_img = $self->_storage_path($storage);
    my $suffix = "qcow2";
    $suffix = ".SWAP.qcow2"   if $swap;
    return "$dir_img/$filename.$suffix";
}

sub _domain_create_from_iso {
    my $self = shift;
    my %args = @_;
    my %args2 = %args;
    for (qw(id_iso id_owner name)) {
        delete $args2{$_};
        croak "argument $_ required"
            if !$args{$_};
    }
    my $remove_cpu = delete $args2{remove_cpu};
    for (qw(disk swap active request vm memory iso_file id_template volatile spice_password
            listen_ip)) {
        delete $args2{$_};
    }

    my $iso_file = delete $args{iso_file};
    confess "Unknown parameters : ".join(" , ",sort keys %args2)
        if keys %args2;

    die "Domain $args{name} already exists"
        if $self->search_domain($args{name});

    my $vm = $self->vm;
    my $iso = $self->_search_iso($args{id_iso} , $iso_file);

    die "ERROR: Empty field 'xml_volume' in iso_image ".Dumper($iso)
        if !$iso->{xml_volume};
        
    my $device_cdrom;

    confess "Template ".$iso->{name}." has no URL, iso_file argument required."
        if !$iso->{url} && !$iso_file && !$iso->{device};

    if ($iso_file) {
        if ( $iso_file ne "<NONE>") {
            $device_cdrom = $iso_file;
        }
    }
    else {
      $device_cdrom = $self->_iso_name($iso, $args{request});
    }
    
    #if ((not exists $args{iso_file}) || ((exists $args{iso_file}) && ($args{iso_file} eq "<NONE>"))) {
    #    $device_cdrom = $self->_iso_name($iso, $args{request});
    #}
    #else {
    #    $device_cdrom = $args{iso_file};
    #}
    
    my $disk_size;
    $disk_size = $args{disk} if $args{disk};

    my $file_xml =  $DIR_XML."/".$iso->{xml_volume};

    my $device_disk = $self->create_volume(
          name => "$args{name}-vda-".Ravada::Utils::random_name(4)
         , xml => $file_xml
        , size => $disk_size
        ,target => 'vda'
    );

    my $xml = $self->_define_xml($args{name} , "$DIR_XML/$iso->{xml}");

    if ($device_cdrom) {
        _xml_modify_cdrom($xml, $device_cdrom);
    } else {
        _xml_remove_cdrom($xml);
    }
    _xml_remove_cpu($xml)                     if $remove_cpu;
    _xml_modify_disk($xml, [$device_disk])    if $device_disk;
    $self->_xml_modify_usb($xml);
    _xml_modify_video($xml);

    my ($domain, $spice_password)
        = $self->_domain_create_common($xml,%args);
    $domain->_insert_db(name=> $args{name}, id_owner => $args{id_owner}
        , id_vm => $self->id
    );

    $domain->_set_spice_password($spice_password)
        if $spice_password;
    $domain->xml_description();

    return $domain;
}

sub _domain_create_common {
    my $self = shift;
    my $xml = shift;
    my %args = @_;

    my $id_owner = delete $args{id_owner} or confess "ERROR: The id_owner is mandatory";
    my $is_volatile = delete $args{is_volatile};
    my $listen_ip = delete $args{listen_ip};
    my $spice_password = delete $args{spice_password};
    my $user = Ravada::Auth::SQL->search_by_id($id_owner)
        or confess "ERROR: User id $id_owner doesn't exist";

    $self->_xml_modify_memory($xml,$args{memory})   if $args{memory};
    $self->_xml_modify_network($xml , $args{network})   if $args{network};
    $self->_xml_modify_mac($xml);
    my $uuid = $self->_xml_modify_uuid($xml);
    $self->_xml_modify_spice_port($xml, $spice_password, $listen_ip);
    $self->_fix_pci_slots($xml);
    $self->_xml_add_guest_agent($xml);
    $self->_xml_clean_machine_type($xml) if !$self->is_local;
    $self->_xml_add_sysinfo_entry($xml, hostname => $args{name});

    my $dom;

    for ( 1 .. 10 ) {
        eval {
            if ($user->is_temporary || $is_volatile ) {
                $dom = $self->vm->create_domain($xml->toString());
            } else {
                $dom = $self->vm->define_domain($xml->toString());
                $dom->create if $args{active};
            }
        };

        last if !$@;
        if ($@ =~ /libvirt error code: 9, .*already defined with uuid/) {
            $self->_xml_modify_uuid($xml);
        } elsif ($@ =~ /libvirt error code: 1, .* pool .* asynchronous/) {
            sleep 1;
        } else {
            last ;
        }
    }
    if ($@) {
        my $out;
		warn $self->name."\n".$@;
        my $name_out = "/var/tmp/$args{name}.xml";
        warn "Dumping $name_out";
        open $out,">",$name_out and do {
            print $out $xml->toString();
        };
        close $out;
        warn "$! $name_out" if !$out;
        confess $@ if !$dom;
    }

    my $domain = Ravada::Domain::KVM->new(
              _vm => $self
         , domain => $dom
        , storage => $self->storage_pool
       , id_owner => $id_owner
    );
    return ($domain, $spice_password);
}

sub _create_disk {
    return _create_disk_qcow2(@_);
}

sub _create_disk_qcow2 {
    my $self = shift;
    my ($base, $name) = @_;

    confess "Missing base" if !$base;
    confess "Missing name" if !$name;

    my @files_out;

    for my $file_data ( $base->list_files_base_target ) {
        my ($file_base,$target) = @$file_data;
        my $vol_base = Ravada::Volume->new(
            file => $file_base
            ,is_base => 1
            ,vm => $self
        );
        my $clone = $vol_base->clone(name => "$name-$target");
        push @files_out,($clone->file);
    }
    return @files_out;

}

sub _random_name { return Ravada::Utils::random_name(@_); };

sub _search_domain_by_id {
    my $self = shift;
    my $id = shift;

    my $sth = $$CONNECTOR->dbh->prepare("SELECT * FROM domains WHERE id=?");
    $sth->execute($id);
    my $row = $sth->fetchrow_hashref;
    $sth->finish;

    return $self->search_domain($row->{name});
}

sub _domain_create_from_base {
    my $self = shift;
    my %args = @_;

    confess "argument id_base or base required ".Dumper(\%args)
        if !$args{id_base} && !$args{base};

    die "Domain $args{name} already exists"
        if $self->search_domain($args{name});

    my $base = $args{base};

    $base = $self->_search_domain_by_id($args{id_base}) if $args{id_base};
    confess "Unknown base id: $args{id_base}" if !$base;

    my $vm = $self->vm;
    my $storage = $self->storage_pool;

    my $xml = XML::LibXML->load_xml(string => $base->get_xml_base());


    my @device_disk = $self->_create_disk($base, $args{name});
#    _xml_modify_cdrom($xml);
    _xml_remove_cdrom($xml);
    my ($node_name) = $xml->findnodes('/domain/name/text()');
    $node_name->setData($args{name});

    _xml_modify_disk($xml, \@device_disk);#, \@swap_disk);

    my ($domain, $spice_password)
        = $self->_domain_create_common($xml,%args, is_volatile => $base->volatile_clones);
    $domain->_insert_db(name=> $args{name}, id_base => $base->id, id_owner => $args{id_owner}
        , id_vm => $self->id
    );
    $domain->_set_spice_password($spice_password);
    $domain->xml_description();
    return $domain;
}

sub _fix_pci_slots {
    my $self = shift;
    my $doc = shift;

    my %dupe = ("0x01/0x1" => 1); #reserved por IDE PCI
    my ($all_devices) = $doc->findnodes('/domain/devices');

    for my $dev ($all_devices->findnodes('*')) {

        # skip IDE PCI, reserved before
        next if $dev->getAttribute('type')
            && $dev->getAttribute('type') =~ /^(ide)$/i;

#        warn "finding address of type ".$dev->getAttribute('type')."\n";

        for my $child ($dev->findnodes('address')) {
            my $bus = $child->getAttribute('bus');
            my $slot = ($child->getAttribute('slot') or '');
            my $function = ($child->getAttribute('function') or '');
            my $multifunction = $child->getAttribute('multifunction');