[UPC#441] copy clones

lib/Ravada.pm

@@ -1713,6 +1713,16 @@ sub _cmd_open_iptables {
     );
 }
 
+sub _cmd_clone($self, $request) {
+    my $domain = Ravada::Domain->open($request->args('id_domain'));
+
+    $domain->clone(
+        name => $request->args('name')
+        ,user => Ravada::Auth::SQL->search_by_id($request->args('uid'))
+    );
+
+}
+
 sub _cmd_start {
     my $self = shift;
     my $request = shift;
@@ -1925,7 +1935,8 @@ sub _req_method {
 
     my %methods = (
 
-          start => \&_cmd_start
+          clone => \&_cmd_clone
+         ,start => \&_cmd_start
          ,pause => \&_cmd_pause
         ,create => \&_cmd_create
         ,remove => \&_cmd_remove

lib/Ravada/Domain.pm

@@ -492,7 +492,9 @@ sub open($class, $id) {
     my $vm_class = "Ravada::VM::".$row->{vm};
     bless $vm0, $vm_class;
 
-    my $vm = $vm0->new( readonly => 1);
+    my @ro = ();
+    @ro = (readonly => 1 ) if $>;
+    my $vm = $vm0->new( @ro );
 
     return $vm->search_domain($row->{name});
 }

lib/Ravada/Request.pm

@@ -61,6 +61,7 @@ our %VALID_ARG = (
     ,hybernate=> {uid => 1, id_domain => 1}
     ,download => {uid => 2, id_iso => 1, id_vm => 2, delay => 2}
     ,refresh_storage => { id_vm => 2 }
+    ,clone => { uid => 1, id_domain => 1, name => 1 }
 );
 
 our %CMD_SEND_MESSAGE = map { $_ => 1 }
@@ -246,6 +247,7 @@ sub resume_domain {
 
 sub _check_args {
     my $sub = shift;
+    confess "Odd number of elements ".Dumper(\@_)   if scalar(@_) % 2;
     my $args = { @_ };
 
     my $valid_args = $VALID_ARG{$sub};
@@ -832,6 +834,32 @@ sub refresh_storage {
 
 }
 
+=head2 clone
+
+Copies a virtual machine
+
+    my $req = Ravada::Request->clone(
+             ,uid => $user->id
+        id_domain => $domain->id
+    );
+
+=cut
+
+sub clone {
+    my $proto = shift;
+    my $class = ref($proto) || $proto;
+
+    my $args = _check_args('clone', @_ );
+
+    my $self = {};
+    bless($self,$class);
+
+    return _new_request($self
+        , command => 'clone'
+        , args =>$args
+    );
+}
+
 sub AUTOLOAD {
     my $self = shift;
 

rvd_front.pl

@@ -1621,24 +1621,13 @@ sub copy_machine {
     my $name = $c->req->param($param_name) if $param_name;
     $name = $base->name."-".$USER->name if !$name;
 
-    if (!$base->is_base || $base->is_locked) {
-        my $req = Ravada::Request->prepare_base(
-            id_domain => $id_base
-            ,uid => $USER->id
-        );
-        return $c->render("Problem preparing base for domain ".$base->name)
-            if !$req;
-
-        sleep 1;
-
-    }
     my @create_args =( memory => $ram ) if $ram;
     push @create_args , ( disk => $disk ) if $disk;
-    my $req2 = Ravada::Request->create_domain(
-             name => $name
-        , id_base => $id_base
-       , id_owner => $USER->id
-        ,@create_args
+    my $req2 = Ravada::Request->clone(
+              uid => $USER->id
+            ,name => $name
+       , id_domain => $base->id
+       ,@create_args
     );
     $c->redirect_to("/admin/machines");#    if !@error;
 }

t/vm/c10_copy.t

@@ -88,21 +88,23 @@ sub test_copy_request {
 
     my $clone = $base->clone(
         name => $name_clone
-        ,user => user_admin
+       ,user => user_admin
     );
 
     my $name_copy = new_domain_name();
     my $req;
-    eval { $req = Ravada::Request->copy(
+    eval { $req = Ravada::Request->clone(
             id_domain => $clone->id
                , name => $name_copy
+                , uid => user_admin->id
         );
     };
     is($@,'') or return;
     is($req->status(),'requested');
     rvd_back->_process_all_requests_dont_fork();
 
-    ok($req->status(),'done');
+    is($req->status(),'done');
+    is($req->error,'');
 
     my $copy = rvd_back->search_domain($name_copy);
     ok($copy,"[$vm_name] Expecting domain $name_copy");