70_clone.t 5.57 KB
Newer Older
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
use warnings;
use strict;

use Data::Dumper;
use Test::More;
use Test::SQL::Data;

use lib 't/lib';
use Test::Ravada;

my $test = Test::SQL::Data->new(config => 't/etc/sql.conf');

use_ok('Ravada');

my $FILE_CONFIG = 't/etc/ravada.conf';

my $RVD_BACK = rvd_back($test->connector, $FILE_CONFIG);
my $RVD_FRONT= rvd_front($test->connector, $FILE_CONFIG);

my %ARG_CREATE_DOM = (
      KVM => [ id_iso => 1 ]
    ,Void => [ ]
);

my @ARG_RVD = ( config => $FILE_CONFIG,  connector => $test->connector);

my @VMS = reverse keys %ARG_CREATE_DOM;
my $USER = create_user("foo","bar");

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

sub test_create_domain {
    my $vm_name = shift;

    my $ravada = Ravada->new(@ARG_RVD);
    my $vm = $ravada->search_vm($vm_name);
    ok($vm,"I can't find VM $vm_name") or return;

    my $name = new_domain_name();

    if (!$ARG_CREATE_DOM{$vm_name}) {
        diag("VM $vm_name should be defined at \%ARG_CREATE_DOM");
        return;
    }
    my @arg_create = @{$ARG_CREATE_DOM{$vm_name}};

    my $domain;
    eval { $domain = $vm->create_domain(name => $name
                    , id_owner => $USER->id
                    , @{$ARG_CREATE_DOM{$vm_name}})
    };

    ok($domain,"No domain $name created with ".ref($vm)." ".($@ or '')) or exit;
    ok($domain->name
        && $domain->name eq $name,"Expecting domain name '$name' , got "
        .($domain->name or '<UNDEF>')
        ." for VM $vm_name"
    );

    return $domain;
}
62
63
sub test_clone {
    my ($vm_name, $base) = @_;
64
    my $description = "The description for base ".$base->name." text $$";
65
66
67
    $base->description($description);
    is($base->description,$description);

68
                my $clone1;
69

70
                my $name_clone = new_domain_name();
Francesc Guasch's avatar
Francesc Guasch committed
71
#                diag("[$vm_name] Cloning from base ".$base->name." to $name_clone");
72
                $base->is_public(1);
73
                eval { $clone1 = $base->clone(name => $name_clone, user => $USER) };
74
75
                ok(!$@,"Expecting error='', got='".($@ or '')."'")
                        or die Dumper($base->list_requests);
76
                ok($clone1,"Expecting new cloned domain from ".$base->name) or return;
77

78
    is($clone1->description,undef);
79
80
81
82
83
84
85
86
87
                $clone1->shutdown_now($USER) if $clone1->is_active();
                eval { $clone1->start($USER) };
                is($@,'');
                ok($clone1->is_active);

                my $clone1b = $RVD_FRONT->search_domain($name_clone);
                ok($clone1b,"Expecting new cloned domain ".$name_clone);
                $clone1->shutdown_now($USER) if $clone1->is_active;
                ok(!$clone1->is_active);
88
89
    is($clone1b->description,undef,"[$vm_name] description for "
            .$clone1b->name);
90
91
    return $clone1;
}
92

93
94
95
sub test_mess_with_bases {
    my ($vm_name, $base, $clones) = @_;
    for my $clone (@$clones) {
96
        $clone->shutdown(user => $USER, timeout => 1)   if $clone->is_active;
97
98
        ok($clone->id_base,"Expecting clone has id_base , got "
                .($clone->id_base or '<UNDEF>'));
99
100
101
102
        $clone->prepare_base($USER);
    }

    for my $clone (@$clones) {
103
        next if $clone->is_base;
104
        eval { $clone->start($USER); };
105
106
        ok(!$@,"Expecting error: '' , got: ".($@ or '')) or exit;

107
        ok($clone->is_active);
108
        $clone->shutdown(user => $USER, timeout => 1)   if $clone->is_active;
109
110
111

        $clone->remove_base($USER);
        eval { $clone->start($USER); };
112
        ok(!$@,"[$vm_name] Expecting error: '' , got '".($@ or '')."'");
113
114
115
116
117
        ok($clone->is_active);
        $clone->shutdown(user => $USER, timeout => 1);

    }
}
118
119
120
121
122
123
124
125

sub test_description {
    my $vm_name = shift;

    my $vm = rvd_back->search_vm($vm_name) or return;

    my $domain = test_create_domain($vm_name);
    $domain->prepare_base($USER);
126
    $domain->is_public(1);
127
128
129
130
131
    my $clone = $vm->create_domain(
             name => new_domain_name()
         ,id_base => $domain->id
        ,id_owner => $USER->id
    );
132
133
    is($clone->description, undef);
    $clone->prepare_base($USER);
134
    is($clone->description, $domain->description);
135
    $clone->remove($USER);
136
137
}

138
139
140
141
142
143
144
145
146
147
148
149
150
###############################################################################
remove_old_domains();
remove_old_disks();

for my $vm_name (reverse sort @VMS) {

    diag("Testing $vm_name VM") if $vm_name !~ /Void/i;

    my $vm;
    eval { $vm = $RVD_BACK->search_vm($vm_name) } if $RVD_BACK;

    SKIP: {
        my $msg = "SKIPPED test: No $vm_name VM found ";
151
152
153
154
        if ($vm && $>) {
            $msg = "SKIPPED: Test must run as root";
            $vm = undef;
        }
155
156
157
        diag($msg)      if !$vm;
        skip $msg,10    if !$vm;

158
        use_ok("Ravada::VM::$vm_name");
159
160
        test_description($vm_name);

161
        my $domain = test_create_domain($vm_name);
162

163
164
165
166
167
        eval { $domain->start($USER) if !$domain->is_active() };
        is($@,'');
        ok($domain->is_active);
        $domain->shutdown_now($USER);

168
169
        my @domains = ( $domain);
        my $n = 1;
170
        for my $depth ( 1 .. 3 ) {
171

172
            my @bases = @domains;
173

174
            for my $base(@bases) {
175

176
177
                my @clones;
                for my $n_clones ( 1 .. 2 ) {
178
                    my $clone = test_clone($vm_name,$base);
179
180
181
                    ok($clone->id_base,"Expecting clone has id_base , got "
                        .($clone->id_base or '<UNDEF>'));

182
                    push @clones,($clone) if $clone;
183
                }
184
185
                test_mess_with_bases($vm_name, $base, \@clones);
                push @domains,(@clones);
186
             }
187
        }
188
189
190
191
192
193
194
    }
}

remove_old_domains();
remove_old_disks();

done_testing();