KVM.pm 67.2 KB
Newer Older
1
2
3
4
5
package Ravada::Domain::KVM;

use warnings;
use strict;

6
7
8
9
10
11
=head2 NAME

Ravada::Domain::KVM - KVM Virtual Machines library for Ravada

=cut

12
13
14
15
use Carp qw(cluck confess croak);
use Data::Dumper;
use File::Copy;
use File::Path qw(make_path);
Francesc Guasch's avatar
Francesc Guasch committed
16
use Hash::Util qw(lock_keys lock_hash);
17
use IPC::Run3 qw(run3);
18
use MIME::Base64;
19
20
use Moose;
use Sys::Virt::Stream;
JanFontanet's avatar
JanFontanet committed
21
use Sys::Virt::Domain;
22
use Sys::Virt;
23
24
use XML::LibXML;

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

Francesc Guasch's avatar
Francesc Guasch committed
28
extends 'Ravada::Front::Domain::KVM';
29
30
31
32
33
with 'Ravada::Domain';

has 'domain' => (
      is => 'rw'
    ,isa => 'Sys::Virt::Domain'
34
    ,required => 0
35
36
37
);

has '_vm' => (
38
    is => 'rw'
39
40
41
42
    ,isa => 'Ravada::VM::KVM'
    ,required => 0
);

Francesc Guasch's avatar
Francesc Guasch committed
43
44
45
46
47
48
has readonly => (
    isa => 'Int'
    ,is => 'rw'
    ,default => 0
);

49
50
51
##################################################
#
our $TIMEOUT_SHUTDOWN = 60;
Roberto P. Rubio's avatar
Roberto P. Rubio committed
52
our $TIMEOUT_REBOOT = 60;
53
54
55
56
57
58
our $OUT;

our %SET_DRIVER_SUB = (
    network => \&_set_driver_network
     ,sound => \&_set_driver_sound
     ,video => \&_set_driver_video
59
60
61
62
63
     ,image => \&_set_driver_image
     ,jpeg => \&_set_driver_jpeg
     ,zlib => \&_set_driver_zlib
     ,playback => \&_set_driver_playback
     ,streaming => \&_set_driver_streaming
Francesc Guasch's avatar
Francesc Guasch committed
64
     ,disk => \&_set_driver_disk
65
66
);

67
68
our %GET_CONTROLLER_SUB = (
    usb => \&_get_controller_usb
Francesc Guasch's avatar
Francesc Guasch committed
69
    ,disk => \&_get_controller_disk
Francesc Guasch's avatar
Francesc Guasch committed
70
    ,network => \&_get_controller_network
71
72
73
    );
our %SET_CONTROLLER_SUB = (
    usb => \&_set_controller_usb
Francesc Guasch's avatar
Francesc Guasch committed
74
    ,disk => \&_set_controller_disk
Francesc Guasch's avatar
Francesc Guasch committed
75
    ,network => \&_set_controller_network
76
77
78
    );
our %REMOVE_CONTROLLER_SUB = (
    usb => \&_remove_controller_usb
Francesc Guasch's avatar
Francesc Guasch committed
79
    ,disk => \&_remove_controller_disk
Francesc Guasch's avatar
Francesc Guasch committed
80
    ,network => \&_remove_controller_network
81
    );
Francesc Guasch's avatar
Francesc Guasch committed
82
83
84

our %CHANGE_HARDWARE_SUB = (
    disk => \&_change_hardware_disk
85
86
    ,vcpus => \&_change_hardware_vcpus
    ,memory => \&_change_hardware_memory
Francesc Guasch's avatar
Francesc Guasch committed
87
    ,network => \&_change_hardware_network
Francesc Guasch's avatar
Francesc Guasch committed
88
);
89
90
##################################################

Francesc Guasch's avatar
Francesc Guasch committed
91
92
93
94
95
sub BUILD {
    my ($self, $arg) = @_;
    $self->readonly( $arg->{readonly} or 0);
}

96
97
98
99
100
101
102
103
104

=head2 name

Returns the name of the domain

=cut

sub name {
    my $self = shift;
105

106
    return $self->domain->get_name if $self->domain;
107
108

    confess "ERROR: Unknown domain name";
109
110
111
112
113
114
115
116
117
118
119
120
121
122
}

=head2 list_disks

Returns a list of the disks used by the virtual machine. CDRoms are not included

  my@ disks = $domain->list_disks();

=cut

sub list_disks {
    my $self = shift;
    my @disks = ();

123
    my $doc = XML::LibXML->load_xml(string => $self->xml_description);
124
125
126
127
128
129
130

    for my $disk ($doc->findnodes('/domain/devices/disk')) {
        next if $disk->getAttribute('device') ne 'disk';

        for my $child ($disk->childNodes) {
            if ($child->nodeName eq 'source') {
                my $file = $child->getAttribute('file');
Francesc Guasch's avatar
Francesc Guasch committed
131
                next if $file =~ /\.iso$/;
132
133
134
135
136
137
138
                push @disks,($file);
            }
        }
    }
    return @disks;
}

Francesc Guasch's avatar
Francesc Guasch committed
139
sub xml_description($self, $inactive=0) {
140
141
142
    return $self->_data_extra('xml')
        if ($self->is_removed || !$self->domain )
            && $self->is_known;
143

144
    confess "ERROR: KVM domain not available ".$self->is_known   if !$self->domain;
145
146
    my $xml;
    eval {
Francesc Guasch's avatar
Francesc Guasch committed
147
148
149
150
151
152
153
154
155
        my @flags;
        @flags = ( Sys::Virt::Domain::XML_INACTIVE ) if $inactive;

        $xml = $self->domain->get_xml_description(@flags);
        $self->_data_extra('xml', $xml) if $self->is_known
                                        && ( $inactive
                                                || !$self->_data_extra('xml')
                                                || !$self->is_active
                                        );
156
157
158
159
160
161
162
163
    };
    confess $@ if $@ && $@ !~ /libvirt error code: 42/;
    if ( $@ ) {
        return $self->_data_extra('xml');
    }
    return $xml;
}

Francesc Guasch's avatar
Francesc Guasch committed
164
165
166
167
sub xml_description_inactive($self) {
    return $self->xml_description(1);
}

168
169
170
171
172
173
174
175
176
177
178
179
180
181
=head2 remove_disks

Remove the volume files of the domain

=cut

sub remove_disks {
    my $self = shift;

    my $removed = 0;

    my $id;
    eval { $id = $self->id };
    return if $@ && $@ =~ /No DB info/i;
182
    confess $@ if $@;
183
184

    $self->_vm->connect();
Francesc Guasch's avatar
Francesc Guasch committed
185
    for my $file ($self->list_disks( device => 'disk')) {
186
        if (! $self->_vm->file_exists($file) ) {
187
188
            next;
        }
189
        eval {
190
        $self->_vol_remove($file);
Francesc Guasch's avatar
Francesc Guasch committed
191
        $self->_vol_remove($file);
192
193
        };
        warn "Error: removing $file $@" if $@;
194
195
196
#        if ( -e $file ) {
#            unlink $file or die "$! $file";
#        }
197
198
199
        $removed++;

    }
200
    return if $self->is_removed;
201
202
203
204
205
206
    warn "WARNING: No disk files removed for ".$self->domain->get_name."\n"
            .Dumper([$self->list_disks])
        if !$removed && $0 !~ /\.t$/;

}

207
208
209
210
211
212
213
214
215
216
=head2 pre_remove_domain

Cleanup operations executed before removing this domain

    $self->pre_remove_domain

=cut

sub pre_remove_domain {
    my $self = shift;
Francesc Guasch's avatar
Francesc Guasch committed
217
    return if $self->is_removed;
218
    $self->xml_description();
219
220
221
    $self->domain->managed_save_remove()    if $self->domain->has_managed_save_image;
}

222
223
224
225
226
sub _vol_remove {
    my $self = shift;
    my $file = shift;
    my $warning = shift;

227
228
    confess "Error: I won't remove an iso file " if $file =~ /\.iso$/i;

229
230
    my $name;
    ($name) = $file =~ m{.*/(.*)}   if $file =~ m{/};
231

232
233
    my $removed = 0;
    for my $pool ( $self->_vm->vm->list_storage_pools ) {
234
        _pool_refresh($pool);
235
236
        my $vol;
        eval { $vol = $pool->get_volume_by_name($name) };
237
        if (! $vol ) {
238
            warn "VOLUME $name not found in $pool \n".($@ or '')
239
                if $@ !~ /libvirt error code: 50,/i;
240
241
            next;
        }
242
243
244
245
246
247
248
        for ( ;; ) {
            eval { $vol->delete() };
            last if !$@;
            sleep 1;
        }
        eval { $pool->refresh };
        warn $@ if $@;
249
250
251
252
    }
    return 1;
}

Francesc Guasch's avatar
Francesc Guasch committed
253
254
255
256
sub remove_volume {
    return _vol_remove(@_);
}

257
258
259
260
261
262
263
264
265
266
=head2 remove

Removes this domain. It removes also the disk drives and base images.

=cut

sub remove {
    my $self = shift;
    my $user = shift;

267
    my @volumes;
268
    if (!$self->is_removed ) {
269
270
271
272
273
274
275
276
       my @vols_info;
       for ( 1 .. 10 ) {
           eval { @vols_info = $self->list_volumes_info };
           last if !$@;
           warn "WARNING: remove, volumes info: $@";
           sleep 1;
       }
       for my $vol ( @vols_info ) {
Francesc Guasch's avatar
Francesc Guasch committed
277
278
279
280
            push @volumes,($vol->{file})
                if exists $vol->{file}
                   && exists $vol->{device}
                   && $vol->{device} eq 'file';
Francesc Guasch's avatar
Francesc Guasch committed
281
        }
282
283
    }

Francesc Guasch's avatar
Francesc Guasch committed
284
    if (!$self->is_removed && $self->domain && $self->domain->is_active) {
285
286
        eval { $self->_do_force_shutdown() };
        warn $@ if $@;
287
288
    }

Francesc Guasch's avatar
Francesc Guasch committed
289
    eval { $self->domain->undefine()    if $self->domain && !$self->is_removed };
290
    confess $@ if $@ && $@ !~ /libvirt error code: 42/;
291

Francesc Guasch's avatar
Francesc Guasch committed
292
    eval { $self->remove_disks() if $self->is_known };
293
    confess $@ if $@ && $@ !~ /libvirt error code: 42/;
294

295
    for my $file ( @volumes ) {
296
297
        eval { $self->remove_volume($file) };
        warn $@ if $@;
298
299
    }

300
    eval { $self->_remove_file_image() };
301
        warn $@ if $@;
302
    confess $@ if $@ && $@ !~ /libvirt error code: 42/;
303
304
305
306
307
#    warn "WARNING: Problem removing file image for ".$self->name." : $@" if $@ && $0 !~ /\.t$/;

#    warn "WARNING: Problem removing ".$self->file_base_img." for ".$self->name
#            ." , I will try again later : $@" if $@;

308
309
    # do a post remove but pass the remove flag = 1 ( it is 0 by default )
    $self->_post_remove_base_domain(1) if $self->is_base();
310
311
312
313
314
315
316

}


sub _remove_file_image {
    my $self = shift;
    for my $file ( $self->list_files_base ) {
317
        next if $file && $file =~ /\.iso$/i;
318
319
320
321
322
323

        next if !$file || ! -e $file;

        chmod 0770, $file or die "$! chmodding $file";
        chown $<,$(,$file    or die "$! chowning $file";
        eval { $self->_vol_remove($file,1) };
324
        warn $@ if $@;
325
326
327
328
329
330
331
332
333
334
335
336
337
338

        if ( -e $file ) {
            eval {
                unlink $file or die "$! $file" ;
                #TODO: do a refresh of all the storage pools in the VM if anything removed
                $self->_vm->storage_pool->refresh();
            };
            warn $@ if $@;
        }
        next if ! -e $file;
        warn $@ if $@;
    }
}

Francesc Guasch's avatar
Francesc Guasch committed
339
sub _disk_device($self, $with_info=undef, $attribute=undef, $value=undef) {
340

Francesc Guasch's avatar
Francesc Guasch committed
341
342
    my $doc = XML::LibXML->load_xml(string
            => $self->xml_description(Sys::Virt::Domain::XML_INACTIVE))
343
344
345
346
        or die "ERROR: $!\n";

    my @img;

Francesc Guasch's avatar
Francesc Guasch committed
347
    my $n_order = 0;
348
    for my $disk ($doc->findnodes('/domain/devices/disk')) {
Francesc Guasch's avatar
Francesc Guasch committed
349
350
351
352
353
        my ($source_node) = $disk->findnodes('source');
        my $file;
        $file = $source_node->getAttribute('file')  if $source_node;

        my ($target_node) = $disk->findnodes('target');
354
355
        my ($driver_node) = $disk->findnodes('driver');
        my ($backing_node) = $disk->findnodes('backingStore');
Francesc Guasch's avatar
Francesc Guasch committed
356
357
358
359
360
361
        my $device = $disk->getAttribute('device');
        my $target = $target_node->getAttribute('dev');
        my $bus = $target_node->getAttribute('bus');

        my ($boot_node) = $disk->findnodes('boot');
        my $info = {};
362
363
        eval { $info = $self->_volume_info($file) if $file && $device eq 'disk' };
        die $@ if $@ && $@ !~ /not found/i;
Francesc Guasch's avatar
Francesc Guasch committed
364
365
366
367
368
369
        $info->{device} = $device;
        if (!$info->{name} ) {
            if ($file) {
                ($info->{name}) = $file =~ m{.*/(.*)};
            } else {
                $info->{name} = $target."-".$info->{device};
370
371
            }
        }
Francesc Guasch's avatar
Francesc Guasch committed
372
        $info->{target} = $target;
373
374
        # we use driver to make it compatible with other hardware but it is more accurate
        # to say bus
Francesc Guasch's avatar
Francesc Guasch committed
375
        $info->{driver} = $bus;
376
        $info->{bus} = $bus;
Francesc Guasch's avatar
Francesc Guasch committed
377
378
        $info->{n_order} = $n_order++;
        $info->{boot} = $boot_node->getAttribute('order') if $boot_node;
Francesc Guasch's avatar
Francesc Guasch committed
379
        $info->{file} = $file if defined $file;
380
381
382
383
        if ($driver_node) {
            for my $attr  ($driver_node->attributes()) {
                $info->{"driver_".$attr->name} = $attr->getValue();
            }
384
385
386
        }
        $info->{backing} = $backing_node->toString()
        if $backing_node && $backing_node->attributes();
Francesc Guasch's avatar
Francesc Guasch committed
387
388
389
390
391

        next if defined $attribute
           && (!exists $info->{$attribute}
                || $info->{$attribute} ne $value);

Francesc Guasch's avatar
Francesc Guasch committed
392
        if (!$with_info) {
Francesc Guasch's avatar
Francesc Guasch committed
393
            push @img,($file) if $file;
Francesc Guasch's avatar
Francesc Guasch committed
394
395
            next;
        }
396
        push @img,Ravada::Volume->new(file => $file, info => $info, domain => $self);
397
398
399
400
401
    }
    return @img;

}

402
403
404
405
406
407
408
409
410
sub _pool_refresh($pool) {
    for ( ;; ) {
        eval { $pool->refresh };
        return if !$@;
        warn "WARNING: on vol remove , pool refresh $@" if $@;
        sleep 1;
    }
}

Francesc Guasch's avatar
Francesc Guasch committed
411
sub _volume_info($self, $file, $refresh=0) {
Francesc Guasch's avatar
Francesc Guasch committed
412
413
    confess "Error: No vm connected" if !$self->_vm->vm;

Francesc Guasch's avatar
Francesc Guasch committed
414
415
416
417
    my ($name) = $file =~ m{.*/(.*)};

    my $vol;
    for my $pool ( $self->_vm->vm->list_storage_pools ) {
418
        _pool_refresh($pool) if $refresh;
Francesc Guasch's avatar
Francesc Guasch committed
419
420
421
422
423
424
425
426
        eval { $vol = $pool->get_volume_by_name($name) };
        warn $@ if $@ && $@ !~ /^libvirt error code: 50,/;
        last if $vol;
    }
    if (!$vol && !$refresh) {
        return $self->_volume_info($file, ++$refresh);
    }

Francesc Guasch's avatar
Francesc Guasch committed
427
    if (!$vol) {
Francesc Guasch's avatar
Francesc Guasch committed
428
        confess "Error: Volume $file not found ".$self->name;
Francesc Guasch's avatar
Francesc Guasch committed
429
430
        return;
    }
Francesc Guasch's avatar
Francesc Guasch committed
431

Francesc Guasch's avatar
Francesc Guasch committed
432
433
434
    my $info;
    eval { $info = $vol->get_info };
    warn "WARNING: $@" if $@ && $@ !~ /^libvirt error code: 50,/;
Francesc Guasch's avatar
Francesc Guasch committed
435
436
    $info->{file} = $file;
    $info->{name} = $name;
Francesc Guasch's avatar
Francesc Guasch committed
437
    $info->{driver} = delete $info->{bus} if exists $info->{bus};
Francesc Guasch's avatar
Francesc Guasch committed
438
439
440
441

    return $info;
}

442
443
444
sub _disk_devices_xml {
    my $self = shift;

445
    my $doc = XML::LibXML->load_xml(string => $self->xml_description)
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
        or die "ERROR: $!\n";

    my @devices;

    for my $disk ($doc->findnodes('/domain/devices/disk')) {
        my $is_disk = 0;
        for my $child ($disk->childNodes) {
            $is_disk++ if $child->nodeName eq 'source';
        }
        push @devices,($disk) if $is_disk;
    }
    return @devices;

}

=head2 disk_device

Returns the file name of the disk of the domain.

  my $file_name = $domain->disk_device();

=cut

sub disk_device {
    my $self = shift;
471
    return $self->_disk_device(@_);
472
473
}

474

475
476
477
478
479
480
481
482
483
=head2 pre_prepare_base

Run this before preparing the base. It is necessary to correctly
detect disks drivers for newer libvirts.

This is executed automatically so it shouldn't been called.

=cut

484
485
sub pre_prepare_base($self) {
    $self->_detect_disks_driver();
486
487
}

488
=head2 post_prepare_base
489

490
Task to run after preparing a base virtual machine
491

492
=cut
493
494


495
sub post_prepare_base {
496
497
    my $self = shift;

498
499
500
    $self->_set_volumes_backing_store();
    $self->_store_xml();
}
501

Francesc Guasch's avatar
Francesc Guasch committed
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
sub _set_backing_store($self, $disk, $backing_file) {
    my ($backing_store) = $disk->findnodes('backingStore');
    if ($backing_file) {
        my $vol_backing_file = Ravada::Volume->new(
            file => $backing_file
            ,vm => $self->_vm
        );
        my $backing_file_format = (
            $vol_backing_file->_qemu_info('file format')
                or 'qcow2'
        );

        $backing_store = $disk->addNewChild(undef,'backingStore') if !$backing_store;
        $backing_store->setAttribute('type' => 'file');

        my ($format) = $backing_store->findnodes('format');
        $format = $backing_store->addNewChild(undef,'format') if !$format;
        $format->setAttribute('type' => $backing_file_format);

        my ($source_bf) = $backing_store->findnodes('source');
        $source_bf = $backing_store->addNewChild(undef,'source') if !$source_bf;
        $source_bf->setAttribute('file' => $backing_file);

        my $next_backing_file = $vol_backing_file->backing_file();
        $self->_set_backing_store($backing_store, $next_backing_file);
    } else {
        $disk->removeChild($backing_store) if $backing_store;
        $backing_store = $disk->addNewChild(undef,'backingStore') if !$backing_store;
    }

}

534
535
536
537
sub _set_volumes_backing_store($self) {
    my $doc = XML::LibXML->load_xml(string
            => $self->xml_description(Sys::Virt::Domain::XML_INACTIVE))
        or die "ERROR: $!\n";
538

539
540
541
542
543
544
545
    my @volumes_info = grep { defined($_) && $_->file } $self->list_volumes_info;
    my %vol = map { $_->file => $_ } @volumes_info;
    for my $disk ($doc->findnodes('/domain/devices/disk')) {
        next if $disk->getAttribute('device') ne 'disk';
        for my $source( $disk->findnodes('source')) {
            my $file = $source->getAttribute('file');
            my $backing_file = $vol{$file}->backing_file();
Francesc Guasch's avatar
Francesc Guasch committed
546

Francesc Guasch's avatar
Francesc Guasch committed
547
            $self->_set_backing_store($disk, $backing_file);
548
549
550

        }
    }
551
    $self->reload_config($doc);
552
553
554
}


555
sub _store_xml($self) {
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
    my $xml = $self->domain->get_xml_description(Sys::Virt::Domain::XML_INACTIVE);
    my $sth = $self->_dbh->prepare(
        "INSERT INTO base_xml (id_domain, xml) "
        ." VALUES ( ?,? ) "
    );
    $sth->execute($self->id , $xml);
    $sth->finish;
}

=head2 get_xml_base

Returns the XML definition for the base, only if prepare_base has been run befor

=cut

sub get_xml_base{

    my $self = shift;
    my $sth = $self->_dbh->prepare(
        "SELECT xml FROM base_xml WHERE id_domain=?"
    );
    $sth->execute($self->id);
578
579
    my $xml = $sth->fetchrow;
    return ($xml or $self->domain->get_xml_description);
580
581
}

582
sub _post_remove_base_domain($self, $remove=0) {
583
584
585
586
    my $sth = $self->_dbh->prepare(
        "DELETE FROM base_xml WHERE id_domain=?"
    );
    $sth->execute($self->id);
587
588
589
590
591

    if (!$remove) {
        $self->_set_volumes_backing_store();
        $self->_detect_disks_driver();
    }
592
593
}

594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
sub _detect_disks_driver($self) {
    my $doc = XML::LibXML->load_xml(string
        => $self->xml_description(Sys::Virt::Domain::XML_INACTIVE))
        or die "ERROR: $!\n";

    my @img;

    my @vols = $self->list_volumes_info();

    my $n_order = 0;
    for my $disk ($doc->findnodes('/domain/devices/disk')) {
        next if $disk->getAttribute('device') ne 'disk';
        my ( $driver ) = $disk->findnodes('driver');
        my ( $source ) = $disk->findnodes('source');

        my $file = $source->getAttribute('file');
        next if $file =~ /iso$/;
611
        next unless $self->_vm->file_exists($file);
612
613
614
615

        my ($vol) = grep { defined $_->file && $_->file eq $file } @vols;
        my $format = $vol->_qemu_info('file format');
        confess "Error: wrong format ".Dumper($format)." for file $file"
616
        unless !$format || $format =~ /^\w+$/;
617

Francesc Guasch's avatar
Francesc Guasch committed
618
        $driver->setAttribute(type => $format) if defined $format;
619
620
    }

621
    $self->reload_config($doc);
622
}
JanFontanet's avatar
JanFontanet committed
623

624
625
sub post_resume_aux($self, %args) {
    my $set_time = delete $args{set_time};
626
    $set_time = 1 if !defined $set_time;
JanFontanet's avatar
JanFontanet committed
627
    eval {
628
        $self->set_time() if $set_time;
JanFontanet's avatar
JanFontanet committed
629
    };
630
631
632
633
    # 55: domain is not running
    # 74: not configured
    # 86: no agent
    die "$@\n" if $@ && $@ !~ /libvirt error code: (55|74|86),/;
634
635
636
637
638
}

sub set_time($self) {
    my $time = time();
    $self->domain->set_time($time, 0, 0);
JanFontanet's avatar
JanFontanet committed
639
640
}

Francesc Guasch's avatar
Francesc Guasch committed
641
=head2 display_info
642

Francesc Guasch's avatar
Francesc Guasch committed
643
Returns the display information as a hashref. The display URI is in the display entry
644
645
646

=cut

Francesc Guasch's avatar
Francesc Guasch committed
647
sub display_info($self, $user) {
648

649
    my $xml = XML::LibXML->load_xml(string => $self->xml_description);
650
651
652
653
654
    my ($graph) = $xml->findnodes('/domain/devices/graphics')
        or die "ERROR: I can't find graphic";

    my ($type) = $graph->getAttribute('type');
    my ($port) = $graph->getAttribute('port');
Francesc Guasch's avatar
Francesc Guasch committed
655
    my ($tls_port) = $graph->getAttribute('tlsPort');
656
657
    my ($address) = $graph->getAttribute('listen');

658
    warn "ERROR: Machine ".$self->name." is not active in node ".$self->_vm->name."\n"
659
        if !$port && !$self->is_active;
660

Francesc Guasch's avatar
Francesc Guasch committed
661
662
663
664

    my %display = (
                type => $type
               ,port => $port
665
                 ,ip => $address
Francesc Guasch's avatar
Francesc Guasch committed
666
667
          ,tls_port => $tls_port
    );
668
669
670
    $port = '' if !defined $port;
    my $display = $type."://$address:$port";
    $display{display} = $display;
Francesc Guasch's avatar
Francesc Guasch committed
671
672
    lock_hash(%display);
    return \%display;
673
674
675
676
677
678
679
680
681
682
}

=head2 is_active

Returns whether the domain is running or not

=cut

sub is_active {
    my $self = shift;
683
    return 0 if $self->is_removed;
Francesc Guasch's avatar
Francesc Guasch committed
684
685
    my $is_active = 0;
    eval { $is_active = $self->domain->is_active };
686
687
688
    return 0 if $@ && (    $@->code == 1    # client socket is closed
                        || $@->code == 38   # broken pipe
                    );
Francesc Guasch's avatar
Francesc Guasch committed
689
690
    die $@ if $@ && $@ !~ /code: 42,/;
    return $is_active;
691
692
}

Francesc Guasch's avatar
Francesc Guasch committed
693
694
695
696
697
698
699
700
=head2 is_persistent

Returns wether the domain has a persistent configuration file

=cut

sub is_persistent($self) {
    return $self->domain->is_persistent;
701
702
703
704
705
706
707
708
709
710
}

=head2 start

Starts the domain

=cut

sub start {
    my $self = shift;
711
712
    my %arg;

713
    if (!(scalar(@_) % 2))  {
714
715
        %arg = @_;
    }
716

717
718
    my $remote_ip = delete $arg{remote_ip};
    my $request = delete $arg{request};
719
720
    my $listen_ip = ( delete $arg{listen_ip} or $self->_listen_ip);
    my $set_password = delete $arg{set_password};
721

722

723
724
725
    my $is_active = 0;
    eval { $is_active = $self->domain->is_active };
    warn $@ if $@;
Francesc Guasch's avatar
Francesc Guasch committed
726
    if (!$is_active && !$self->is_hibernated) {
727
728
729
        $self->_check_qcow_format($request);
        $self->_set_volumes_backing_store();
        $self->_detect_disks_driver();
Francesc Guasch's avatar
Francesc Guasch committed
730
        $self->_set_spice_ip($set_password, $listen_ip);
731
732
    }

733
    $self->status('starting');
Francesc Guasch's avatar
Francesc Guasch committed
734
735
736
737
738
739
740
741
742
743

    my $error;
    for ( ;; ) {
        eval { $self->domain->create() };
        $error = $@;
        next if $error && $error =~ /libvirt error code: 1, .* pool .* asynchronous/;
        last;
    }
    return if !$error || $error =~ /already running/i;
    if ($error =~ /libvirt error code: 38,/) {
744
745
        die "Error starting ".$self->name." on ".$self->_vm->name
            ."\n$error";
Francesc Guasch's avatar
Francesc Guasch committed
746
747
    } elsif ( $error =~ /libvirt error code: 9, .*already defined with uuid/) {
        die "TODO";
748
749
750
    } elsif ( $error =~ /libvirt error code: 1,.*smbios/) {
        $self->_remove_smbios();
        $self->domain->create();
Francesc Guasch's avatar
Francesc Guasch committed
751
752
753
754
755
756
    } elsif ( $self->domain->has_managed_save_image ) {
        $request->status("removing saved image") if $request;
        $self->domain->managed_save_remove();
        $self->domain->create();
    } else {
        die $error;
757
    }
758
759
}

760
761
762
763
764
765
766
767
768
769
770
771
772
773
sub _check_qcow_format($self, $request) {
    return if $self->is_active;
    for my $vol ( $self->list_volumes_info ) {
        next if !$vol->file || $vol->file =~ /iso$/;
        next if !$vol->backing_file;

        next if $vol->_qemu_info('backing file format') eq 'qcow2';

        $request->status("rebasing","rebasing to release 0.8 "
            .$vol->file."\n".$vol->backing_file) if $request;
        $vol->rebase($vol->backing_file);
    }
}

774
775
776
777
778
779
780
781
782
783
784
sub _remove_smbios($self) {
    my $doc = XML::LibXML->load_xml(string => $self->domain->get_xml_description(Sys::Virt::Domain::XML_INACTIVE));

    my ($os) = $doc->findnodes('/domain/os');
    my ($smbios) = $os->findnodes('smbios');
    $os->removeChild($smbios) if $smbios;

    my $new_domain = $self->_vm->vm->define_domain($doc->toString);
    $self->domain($new_domain);
}

Francesc Guasch's avatar
Francesc Guasch committed
785
786
sub _pre_shutdown_domain {
    my $self = shift;
Francesc Guasch's avatar
Francesc Guasch committed
787

Francesc Guasch's avatar
Francesc Guasch committed
788
789
790
791
792
793
794
795
796
797
798
    my ($state, $reason) = $self->domain->get_state();

    if ($state == Sys::Virt::Domain::STATE_PMSUSPENDED_UNKNOWN 
         || $state == Sys::Virt::Domain::STATE_PMSUSPENDED_DISK_UNKNOWN 
         || $state == Sys::Virt::Domain::STATE_PMSUSPENDED) {
        $self->domain->pm_wakeup();
        for ( 1 .. 10 ) {
            last if $self->is_active;
            sleep 1;
        }
    }
799
800
801

    $self->domain->managed_save_remove()
        if $self->domain->has_managed_save_image();
Francesc Guasch's avatar
Francesc Guasch committed
802

Francesc Guasch's avatar
Francesc Guasch committed
803
804
}

805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
=head2 shutdown

Stops the domain

=cut

sub shutdown {
    my $self = shift;

    my %args = @_;
    my $req = $args{req};

    if (!$self->is_active && !$args{force}) {
        $req->status("done")                if $req;
        $req->error("Domain already down")  if $req;
        return;
    }

    return $self->_do_force_shutdown() if $args{force};
    return $self->_do_shutdown();

}

sub _do_shutdown {
    my $self = shift;
Francesc Guasch's avatar
Francesc Guasch committed
830
831
832
    return if !$self->domain->is_active;
    eval { $self->domain->shutdown() };
    die $@ if $@ && $@ !~ /libvirt error code: 55,/;
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854

}

=head2 shutdown_now

Shuts down uncleanly the domain

=cut

sub shutdown_now {
    my $self = shift;
    return $self->_do_force_shutdown()  if $self->is_active;
}

=head2 force_shutdown

Shuts down uncleanly the domain

=cut

sub force_shutdown{
    my $self = shift;
855
    return $self->_do_force_shutdown() if $self->is_active;
856
857
858
859
}

sub _do_force_shutdown {
    my $self = shift;
860
861
862
863
    return if !$self->domain->is_active;

    eval { $self->domain->destroy   };
    warn $@ if $@;
864
865
}

Roberto P. Rubio's avatar
Roberto P. Rubio committed
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
=head2 reboot

Stops the domain

=cut

sub reboot {
    my $self = shift;
    my %args = @_;
    my $req = $args{req};

    if (!$self->is_active) {
        $req->status("done")           if $req;
        $req->error("Domain is down")  if $req;
        return;
    }

Roberto P. Rubio's avatar
Roberto P. Rubio committed
883
    return $self->_do_force_shutdown() if $args{force};
Roberto P. Rubio's avatar
Roberto P. Rubio committed
884
885
886
887
    return $self->_do_reboot();

}

Roberto P. Rubio's avatar
Roberto P. Rubio committed
888
889
890
891
892
893
894
895
896
897
898
899
sub force_reboot {
    my $self = shift;
    return $self->_do_force_reboot()  if $self->is_active;
}

sub _do_force_reboot {
    my $self = shift;
    return if !$self->domain->is_active;
    eval { $self->domain->reset() };
    warn $@ if $@;
}

Roberto P. Rubio's avatar
Roberto P. Rubio committed
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
sub _do_reboot {
    my $self = shift;
    return if !$self->domain->is_active;
    eval { $self->domain->reboot() };
    die $@ if $@;
}

=head2 reboot_now

Reboots uncleanly the domain

=cut

sub reboot_now {
    my $self = shift;
    return $self->_do_reboot()  if $self->is_active;
}
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936

=head2 pause

Pauses the domain

=cut

sub pause {
    my $self = shift;
    return $self->domain->suspend();
}

=head2 resume

Resumes a paused the domain

=cut

sub resume {
    my $self = shift;
Francesc Guasch's avatar
Francesc Guasch committed
937
    eval { $self->domain->resume() };
938
    confess $@ if $@ && $@ !~ /libvirt error code: 55/;
939
940
941
}


942
943
944
945
946
947
948
949
950
951
952
=head2 is_hibernated

Returns if the domain has a managed saved state.

=cut

sub is_hibernated {
    my $self = shift;
    return $self->domain->has_managed_save_image;
}

953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
=head2 is_paused

Returns if the domain is paused

=cut

sub is_paused {
    my $self = shift;
    my ($state, $reason) = $self->domain->get_state();



    return 0 if $state == 1;
    #TODO, find out which one of those id "1" and remove it from this list
    #
    return $state &&
        ($state == Sys::Virt::Domain::STATE_PAUSED_UNKNOWN
        || $state == Sys::Virt::Domain::STATE_PAUSED_USER
        || $state == Sys::Virt::Domain::STATE_PAUSED_DUMP
        || $state == Sys::Virt::Domain::STATE_PAUSED_FROM_SNAPSHOT
        || $state == Sys::Virt::Domain::STATE_PAUSED_IOERROR
        || $state == Sys::Virt::Domain::STATE_PAUSED_MIGRATION
        || $state == Sys::Virt::Domain::STATE_PAUSED_SAVE
        || $state == Sys::Virt::Domain::STATE_PAUSED_SHUTTING_DOWN
    );
    return 0;
}

981
982
983
984
985
986
987
988
=head2 can_hybernate

Returns true (1) for KVM domains

=cut

sub can_hybernate { 1 };

Francesc Guasch's avatar
Francesc Guasch committed
989
990
991
992
993
994
995
996
=head2 can_hybernate

Returns true (1) for KVM domains

=cut

sub can_hibernate { 1 };

997
998
999
1000
=head2 hybernate

Take a snapshot of the domain's state and save the information to a
managed save location. The domain will be automatically restored with
For faster browsing, not all history is shown. View entire blame