Skip to content
GitLab
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in
Toggle navigation
Menu
Open sidebar
Projets publics
Ravada-Mirror
Commits
c302797a
Commit
c302797a
authored
May 17, 2016
by
Francesc Guasch
Browse files
rvd_back works again with new source architecture
parent
ac3b276d
Changes
7
Expand all
Hide whitespace changes
Inline
Side-by-side
bin/rvd_back.pl
View file @
c302797a
This diff is collapsed.
Click to expand it.
lib/Ravada.pm
View file @
c302797a
...
...
@@ -41,7 +41,12 @@ has 'vm' => (
);
has
'
connector
'
=>
(
is
=>
'
ro
'
is
=>
'
rw
'
);
has
'
config
'
=>
(
is
=>
'
ro
'
,
isa
=>
'
Str
'
);
=head2 BUILD
...
...
@@ -53,11 +58,16 @@ Internal constructor
sub
BUILD
{
my
$self
=
shift
;
if
(
$self
->
config
)
{
_init_config
(
$self
->
config
);
}
if
(
$self
->
connector
)
{
$CONNECTOR
=
$self
->
connector
}
else
{
$CONNECTOR
=
$self
->
_connect_dbh
();
$self
->
connector
(
$CONNECTOR
);
}
}
sub
_connect_dbh
{
...
...
@@ -140,6 +150,25 @@ sub search_domain {
}
}
=head2 list_domains
List all created domains
my @list = $ravada->list_domains();
=cut
sub
list_domains
{
my
$self
=
shift
;
my
@domains
;
for
my
$vm
(
@
{
$self
->
vm
})
{
for
my
$domain
(
$vm
->
list_domains
)
{
push
@domains
,(
$domain
);
}
}
return
@domains
;
}
=head2 remove_volume
$ravada->remove_volume($file);
...
...
lib/Ravada/Domain.pm
View file @
c302797a
...
...
@@ -3,9 +3,11 @@ package Ravada::Domain;
use
warnings
;
use
strict
;
use
Carp
qw(confess)
;
use
Carp
qw(confess
croak
)
;
use
Moose::
Role
;
our
$TIMEOUT_SHUTDOWN
=
20
;
requires
'
name
';
requires
'
remove
';
requires
'
display
';
...
...
@@ -15,6 +17,14 @@ has 'domain' => (
,
is
=>
'
ro
'
);
has
'
timeout_shutdown
'
=>
(
isa
=>
'
Int
'
,
is
=>
'
ro
'
,
default
=>
$TIMEOUT_SHUTDOWN
);
##################################################################################3
#
sub
id
{
...
...
@@ -22,9 +32,12 @@ sub id {
}
sub
file_base_img
{
return
$_
[
0
]
->
_data
('
file_base_img
');
my
$file
;
eval
{
$file
=
$_
[
0
]
->
_data
('
file_base_img
')
};
return
$file
;
}
##################################################################################
sub
_data
{
...
...
@@ -32,22 +45,11 @@ sub _data {
my
$field
=
shift
or
confess
"
Missing field name
";
return
$self
->
{
_data
}
->
{
$field
}
if
exists
$self
->
{
_data
}
->
{
$field
};
$self
->
_load_sql_data
();
return
$self
->
{
_data
}
->
{
$field
};
}
$self
->
{
_data
}
=
$self
->
_select_domain_db
(
name
=>
$self
->
name
);
sub
_load_sql_data
{
my
$self
=
shift
;
my
$sth
=
$self
->
connector
->
dbh
->
prepare
("
SELECT * FROM domains
"
.
"
WHERE name=?
"
);
$sth
->
execute
(
$self
->
name
);
my
$data
=
$sth
->
fetchrow_hashref
;
$sth
->
finish
;
$self
->
{
_data
}
=
$data
;
confess
"
No DB info for domain
"
.
$self
->
name
if
!
$self
->
{
_data
};
return
$
data
;
return
$
self
->
{
_data
}
->
{
$field
}
;
}
sub
open
{
...
...
@@ -58,7 +60,7 @@ sub open {
my
$id
=
$args
{
id
}
or
confess
"
Missing required argument id
";
delete
$args
{
id
};
my
$row
=
$self
->
_select_domain_db
(
id
=>
$id
);
my
$row
=
$self
->
_select_domain_db
(
);
return
$self
->
search_domain
(
$row
->
{
name
});
# confess $row;
}
...
...
@@ -67,6 +69,16 @@ sub _select_domain_db {
my
$self
=
shift
;
my
%args
=
@_
;
if
(
!
keys
%args
)
{
my
$id
;
eval
{
$id
=
$self
->
id
};
if
(
$id
)
{
%args
=
(
id
=>
$id
);
}
else
{
%args
=
(
name
=>
$self
->
name
);
}
}
my
$sth
=
$self
->
connector
->
dbh
->
prepare
(
"
SELECT * FROM domains WHERE
"
.
join
("
,
",
map
{
"
$_
=?
"
}
sort
keys
%args
)
);
...
...
@@ -74,6 +86,7 @@ sub _select_domain_db {
my
$row
=
$sth
->
fetchrow_hashref
;
$sth
->
finish
;
$self
->
{
_data
}
=
$row
;
return
$row
;
}
...
...
@@ -81,12 +94,59 @@ sub _prepare_base_db {
my
$self
=
shift
;
my
$file_img
=
shift
;
if
(
!
$self
->
_select_domain_db
)
{
$self
->
_insert_db
(
name
=>
$self
->
name
);
}
my
$sth
=
$self
->
connector
->
dbh
->
prepare
(
"
UPDATE domains set is_base='y',file_base_img=?
"
.
"
WHERE id=?
"
);
$sth
->
execute
(
$file_img
,
$self
->
id
);
$sth
->
finish
;
$self
->
{
_data
}
=
$self
->
_select_domain_db
();
}
sub
_insert_db
{
my
$self
=
shift
;
my
%field
=
@_
;
croak
"
Field name is mandatory
"
.
Dumper
(
\
%field
)
if
!
exists
$field
{
name
};
my
$query
=
"
INSERT INTO domains
"
.
"
(
"
.
join
("
,
",
sort
keys
%field
)
.
"
)
"
.
"
VALUES (
"
.
join
("
,
",
map
{
'
?
'
}
keys
%field
)
.
"
)
"
;
my
$sth
=
$self
->
connector
->
dbh
->
prepare
(
$query
);
eval
{
$sth
->
execute
(
map
{
$field
{
$_
}
}
sort
keys
%field
)
};
if
(
$@
)
{
warn
"
$query
\n
"
.
Dumper
(
\
%field
);
die
$@
;
}
$sth
->
finish
;
}
sub
_remove_domain_db
{
my
$self
=
shift
;
$self
->
_select_domain_db
or
return
;
my
$sth
=
$self
->
connector
->
dbh
->
prepare
("
DELETE FROM domains
"
.
"
WHERE id=?
");
$sth
->
execute
(
$self
->
id
);
$sth
->
finish
;
}
=head2 is_base
Returns true or false if the domain is a prepared base
=cut
sub
is_base
{
my
$self
=
shift
;
$self
->
_select_domain_db
or
return
;
return
$self
->
_data
('
is_base
')
=~
/y/i
};
1
;
lib/Ravada/Domain/KVM.pm
View file @
c302797a
...
...
@@ -29,10 +29,6 @@ has 'connector' => (
,
required
=>
1
);
#################################################3
#
our
$TIMEOUT_SHUTDOWN
=
20
;
##################################################
#
...
...
@@ -50,7 +46,7 @@ sub name {
sub
_wait_down
{
my
$self
=
shift
;
my
$seconds
=
(
shift
or
$
TIMEOUT_SHUTDOWN
);
my
$seconds
=
(
shift
or
$
self
->
timeout_shutdown
);
for
my
$sec
(
0
..
$seconds
)
{
return
if
!
$self
->
domain
->
is_active
;
print
"
Waiting for
"
.
$self
->
domain
->
get_name
.
"
to shutdown.
"
if
!
$sec
;
...
...
@@ -124,14 +120,6 @@ sub remove {
$self
->
_remove_domain_db
();
}
sub
_remove_domain_db
{
my
$self
=
shift
;
my
$sth
=
$self
->
connector
->
dbh
->
prepare
("
DELETE FROM domains
"
.
"
WHERE id=?
");
$sth
->
execute
(
$self
->
id
);
$sth
->
finish
;
}
sub
remove_file_image
{
my
$self
=
shift
;
...
...
@@ -206,7 +194,6 @@ sub prepare_base {
my
$self
=
shift
;
my
$file_qcow
=
$self
->
_create_qcow_base
();
#update domains set is_base='y' , img = $file_qcow
$self
->
_prepare_base_db
(
$file_qcow
);
}
...
...
@@ -230,4 +217,5 @@ sub display {
return
"
$type
://
$address
:
$port
";
}
1
;
lib/Ravada/VM.pm
View file @
c302797a
...
...
@@ -16,6 +16,8 @@ requires 'connect';
requires
'
create_domain
';
requires
'
search_domain
';
requires
'
list_domains
';
# storage volume
requires
'
create_volume
';
...
...
@@ -63,25 +65,6 @@ sub _domain_remove_db {
$sth
->
finish
;
}
sub
_domain_insert_db
{
my
$self
=
shift
;
my
%field
=
@_
;
croak
"
Field name is mandatory
"
.
Dumper
(
\
%field
)
if
!
exists
$field
{
name
};
my
$query
=
"
INSERT INTO domains
"
.
"
(
"
.
join
("
,
",
sort
keys
%field
)
.
"
)
"
.
"
VALUES (
"
.
join
("
,
",
map
{
'
?
'
}
keys
%field
)
.
"
)
"
;
my
$sth
=
$self
->
connector
->
dbh
->
prepare
(
$query
);
eval
{
$sth
->
execute
(
map
{
$field
{
$_
}
}
sort
keys
%field
)
};
if
(
$@
)
{
warn
"
$query
\n
"
.
Dumper
(
\
%field
);
die
$@
;
}
$sth
->
finish
;
}
sub
domain_remove
{
my
$self
=
shift
;
$self
->
domain_remove_vm
();
...
...
lib/Ravada/VM/KVM.pm
View file @
c302797a
...
...
@@ -94,6 +94,10 @@ sub _load_storage_pool {
}
sub
dir_img
{
return
$DEFAULT_DIR_IMG
;
}
=head2 create_domain
Creates a domain.
...
...
@@ -121,7 +125,7 @@ sub create_domain {
}
else
{
confess
"
TODO
";
}
$
self
->
_
domain_insert_db
(
@fields
);
$domain
->
_insert_db
(
@fields
);
return
$domain
;
}
...
...
@@ -147,6 +151,29 @@ sub search_domain {
}
}
=head2 list_domains
Returns a list of the created domains
my @list = $vm->list_domains();
=cut
sub
list_domains
{
my
$self
=
shift
;
my
@list
;
for
my
$name
(
$self
->
vm
->
list_all_domains
())
{
push
@list
,
(
Ravada::Domain::
KVM
->
new
(
domain
=>
$name
,
storage
=>
$self
->
storage_pool
,
connector
=>
$self
->
connector
)
);
}
return
@list
;
}
=head2 create_volume
Creates a new storage volume. It requires a name and a xml template file defining the volume
...
...
@@ -244,12 +271,17 @@ sub _create_disk_qcow2 {
die
"
WARNING: output file
$file_out
already existed [skipping]
\n
";
}
die
"
ERROR: Missing file_base_img in base
"
.
$base
->
id
.
"
"
.
Dumper
(
$base
->
_select_domain_db
)
if
!
$base
->
file_base_img
;
my
@cmd
=
('
qemu-img
','
create
'
,'
-f
','
qcow2
'
,"
-b
",
$base
->
file_base_img
,
$file_out
);
print
join
("
",
@cmd
)
.
"
\n
";
#
warn
join(" ",@cmd)."\n";
my
(
$in
,
$out
,
$err
);
run3
(
\
@cmd
,
\
$in
,
\
$out
,
\
$err
);
...
...
t/20_domain_kvm.t
View file @
c302797a
use
warnings
;
use
strict
;
use
Data::
Dumper
;
use
IPC::
Run3
;
use
Test::
More
;
use
Test::SQL::
Data
;
...
...
@@ -11,6 +12,8 @@ use_ok('Ravada::Domain::KVM');
my
$test
=
Test::SQL::
Data
->
new
(
config
=>
'
t/etc/ravada.conf
');
my
$ravada
=
Ravada
->
new
(
connector
=>
$test
->
connector
);
my
$cont
=
0
;
sub
test_vm_kvm
{
my
$vm
=
$ravada
->
vm
->
[
0
];
ok
(
$vm
,"
No vm found
")
or
exit
;
...
...
@@ -60,6 +63,7 @@ sub search_domain_db {
sub
test_new_domain
{
my
(
$name
)
=
$
0
=~
m{.*/(.*)\.t}
;
$name
.=
"
_
"
.
$cont
++
;
test_remove_domain
(
$name
);
...
...
@@ -93,19 +97,37 @@ sub test_prepare_base {
$sth
->
finish
;
}
################################################################
test_vm_kvm
();
{
sub
test_domain
{
my
(
$name
)
=
$
0
=~
m{.*/(.*)\.t}
;
test_remove_domain
(
$name
);
my
$n_domains
=
scalar
$ravada
->
list_domains
();
my
$domain
=
test_new_domain
();
if
(
ok
(
$domain
,"
test domain not created
"))
{
my
@list
=
$ravada
->
list_domains
();
ok
(
scalar
(
@list
)
==
$n_domains
+
1
,"
Found
"
.
scalar
(
@list
)
.
"
domains, expecting
"
.
(
$n_domains
+
1
)
.
"
"
.
join
("
,
",
sort
map
{
$_
->
name
}
@list
)
);
ok
(
!
$domain
->
is_base
,"
Domain shouldn't be base
"
.
Dumper
(
$domain
->
_select_domain_db
()));
test_prepare_base
(
$domain
);
ok
(
$domain
->
is_base
,"
Domain should be base
"
.
Dumper
(
$domain
->
_select_domain_db
())
);
test_remove_domain
(
$domain
->
name
);
}
}
{
sub
test_domain_by_name
{
my
$domain
=
test_new_domain
();
if
(
ok
(
$domain
,"
test domain not created
"))
{
...
...
@@ -113,5 +135,39 @@ test_vm_kvm();
}
}
sub
test_prepare_import
{
my
$domain
=
test_new_domain
();
if
(
ok
(
$domain
,"
test domain not created
"))
{
my
$sth
=
$test
->
connector
->
dbh
->
prepare
("
DELETE FROM domains WHERE id=?
");
$sth
->
execute
(
$domain
->
id
);
test_prepare_base
(
$domain
);
ok
(
$domain
->
is_base
,"
Domain should be base
"
.
Dumper
(
$domain
->
_select_domain_db
())
);
test_remove_domain
(
$domain
);
}
}
sub
remove_old_domains
{
my
(
$name
)
=
$
0
=~
m{.*/(.*)\.t}
;
for
(
0
..
10
)
{
test_remove_domain
(
$name
.
"
_
"
.
$_
);
}
}
################################################################
test_vm_kvm
();
remove_old_domains
();
test_domain
();
test_domain_by_name
();
test_prepare_import
();
done_testing
();
Write
Preview
Supports
Markdown
0%
Try again
or
attach a new file
.
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment