[#67] fixed clones still dependant from base even if made base

lib/Ravada.pm

@@ -43,7 +43,7 @@ our $CONFIG = {};
 our $DEBUG;
 our $CAN_FORK = 1;
 our $CAN_LXC = 0;
-our $LIMIT_PROCESS = 1;
+our $LIMIT_PROCESS = 2;
 
 # FAT commands take long
 our %FAT_COMMAND =  map { $_ => 1 } qw(prepare_base remove);

lib/Ravada/Domain.pm

@@ -45,6 +45,7 @@ requires 'disk_device';
 
 requires 'disk_size';
 
+requires 'spinoff_volumes';
 #hardware info
 
 requires 'get_info';
@@ -96,7 +97,7 @@ before 'remove' => \&_pre_remove_domain;
 #\&_allow_remove;
  after 'remove' => \&_after_remove_domain;
 
-before 'prepare_base' => \&_allow_prepare_base;
+before 'prepare_base' => \&_pre_prepare_base;
  after 'prepare_base' => \&_post_prepare_base;
  
 before 'start' => \&_start_preconditions;
@@ -112,7 +113,7 @@ before 'shutdown' => \&_allow_manage_args;
 after 'shutdown' => \&_post_shutdown;
 
 before 'remove_base' => \&_can_remove_base;
-after 'remove_base' => \&_remove_base_db;
+after 'remove_base' => \&_post_remove_base;
 
 before 'rename' => \&_pre_rename;
 after 'rename' => \&_post_rename;
@@ -174,7 +175,7 @@ sub _allow_remove {
 
 }
 
-sub _allow_prepare_base {
+sub _pre_prepare_base {
     my $self = shift;
     my ($user) = @_;
 
@@ -187,6 +188,9 @@ sub _allow_prepare_base {
         $self->shutdown(user => $user);
         $self->{_was_active} = 1;
     }
+    if ($self->id_base ) {
+        $self->spinoff_volumes();
+    }
 };
 
 sub _post_prepare_base {
@@ -200,7 +204,7 @@ sub _post_prepare_base {
     }
     delete $self->{_was_active};
 
-#    $self->_remove_id_base();
+    $self->_remove_id_base();
 };
 
 
@@ -516,13 +520,13 @@ sub is_locked {
 
     $self->_init_connector() if !defined $$CONNECTOR;
 
-    my $sth = $$CONNECTOR->dbh->prepare("SELECT count(*) FROM requests "
+    my $sth = $$CONNECTOR->dbh->prepare("SELECT id FROM requests "
         ." WHERE id_domain=? AND status <> 'done'");
     $sth->execute($self->id);
-    my ($count) = $sth->fetchrow;
+    my ($id) = $sth->fetchrow;
     $sth->finish;
 
-    return $count;
+    return ($id or 0);
 }
 
 =head2 id_owner
@@ -676,7 +680,6 @@ sub _can_remove_base {
 
 sub _post_remove_base {
     my $self = shift;
-    $self->_vm->disconnect();
     $self->_remove_base_db(@_);
 }
 

lib/Ravada/Domain/KVM.pm

@@ -373,6 +373,16 @@ sub shutdown {
         $req->error("Domain already down")  if $req;
         return;
     }
+
+    return $self->_do_shutdown($timeout,$req);
+}
+
+sub _do_shutdown {
+    my $self = shift;
+    my ($timeout, $req) = @_;
+    
+    $timeout = $TIMEOUT_SHUTDOWN if !defined $timeout;
+
     $self->domain->shutdown();
     $req->status("Shutting down") if $req;
 
@@ -384,7 +394,7 @@ sub shutdown {
         sleep 1;
     }
     if ($self->is_active) {
-        my $msg = "Domaing wouldn't shut down, destroying\n";
+        my $msg = "Domain wouldn't shut down, destroying\n";
         $req->error($msg)  if $req;
         $self->domain->destroy();
     }
@@ -844,6 +854,53 @@ sub rename_volumes {
 
 =cut
 
+=head2 spinoff volumes
+
+Makes volumes indpendent from base
+
+=cut
+
+sub spinoff_volumes {
+    my $self = shift;
+
+    $self->_do_shutdown(1) if $self->is_active;
+
+    for my $disk ($self->_disk_devices_xml) {
+
+        my ($source) = $disk->findnodes('source');
+        next if !$source;
+
+        my $volume = $source->getAttribute('file') or next;
+
+        confess "ERROR: Domain ".$self->name
+                ." volume '$volume' does not exists"
+            if ! -e $volume;
+
+        #TODO check mktemp or something
+        my $volume_tmp  = "$volume.$$.tmp";
+
+        unlink($volume_tmp) or die "ERROR $! removing $volume.tmp"
+            if -e $volume_tmp;
+
+        my @cmd = ('qemu-img'
+            ,'convert'
+            ,'-O','qcow2'
+            ,$volume
+            ,$volume_tmp
+        );
+        my ($in, $out, $err);
+        run3(\@cmd,\$in,\$out,\$err);
+        warn $out  if $out;
+        warn $err   if $err;
+        die "ERROR: Output file $volume_tmp not created at ".join(" ",@cmd)."\n"
+            if (! -e $volume_tmp );
+
+        copy($volume_tmp,$volume) or die "$! $volume_tmp -> $volume";
+        unlink($volume_tmp) or die "ERROR $! removing $volume_tmp";
+    }
+}
+
+
 sub _set_spice_ip {
     my $self = shift;
 

lib/Ravada/Domain/Void.pm

@@ -331,4 +331,7 @@ sub disk_size {
     return -s $disk;
 }
 
+sub spinoff_volumes {
+    return;
+}
 1;

lib/Ravada/Front.pm

@@ -111,7 +111,7 @@ sub list_domains {
         eval { $domain   = $self->search_domain($row->{name}) };
         if ( $domain ) {
             $row->{is_active} = 1 if $domain->is_active;
-            $row->{is_locked} = 1 if $domain->is_locked;
+            $row->{is_locked} = $domain->is_locked;
             $row->{is_paused} = 1 if $domain->is_paused;
             $row->{has_clones} = $domain->has_clones;
             $row->{disk_size} = ( $domain->disk_size or 0);

lib/Ravada/VM/KVM.pm

@@ -231,6 +231,7 @@ Returns a list of the created domains
 sub list_domains {
     my $self = shift;
 
+    confess "Missing vm" if !$self->vm;
     my @list;
     my @domains = $self->vm->list_all_domains();
     for my $name (@domains) {

t/request/40_base.t

@@ -288,6 +288,7 @@ sub test_req_remove_base_fail {
         @files_base = $domain_base->list_files_base();
         ok(scalar @files_base,"Expecting files base, got none") or return;
     
+        ok($domain_base->has_clones,"Expecting domain base has clones, got :".$domain_base->has_clones);
         $domain_base->_vm->disconnect();
         $domain_clone->_vm->disconnect();
     

t/vm/70_clone.t

@@ -98,7 +98,7 @@ sub test_mess_with_bases {
 
         $clone->remove_base($USER);
         eval { $clone->start($USER); };
-        is($@,'');
+        ok(!$@,"[$vm_name] Expecting error: '' , got '".($@ or '')."'");
         ok($clone->is_active);
         $clone->shutdown(user => $USER, timeout => 1);